LZScene

1
//
2
// This unit is part of the GLScene Engine https://github.com/glscene
3
//
4
{
5
   HDR File support for GLScene.
6

7
  History :  
8
         04/11/10 - DaStr - Added Delphi5 and Delphi6 compatibility  
9
         23/08/10 - Yar - Replaced OpenGL1x to OpenGLTokens
10
         08/05/10 - Yar - Removed check for residency in AssignFromTexture
11
         22/04/10 - Yar - Fixes after GLState revision
12
         23/11/10 - DaStr - Added $I GLScene.inc
13
         23/01/10 - Yar - Added to AssignFromTexture CurrentFormat parameter
14
         20/01/10 - Yar - Creation
15
    
16
}
17
unit GLFileHDR;
18

19
{$I GLScene.inc}
20

21
interface
22

23
uses
24
  Classes,
25
  SysUtils,
26
   
27
  OpenGLTokens,
28
  GLContext,
29
  GLGraphics,
30
  GLTextureFormat,
31
  GLApplicationFileIO,
32
  GLCrossPlatform,
33
  GLSRGBE,
34
  GLVectorTypes,
35
  GLVectorGeometry;
36

37

38
type
39

40
  TGLHDRImage = class(TGLBaseImage)
41
  private
42
    function GetProgramType: Ansistring;
43
    procedure SetProgramType(aval: Ansistring);
44
  protected
45
    fGamma: Single; // image has already been gamma corrected with
46
    // given gamma.  defaults to 1.0 (no correction) */
47
    fExposure: Single; // a value of 1.0 in an image corresponds to
48
    // <exposure> watts/steradian/m^2.
49
    // defaults to 1.0
50
    fProgramType: string[16];
51
  public
52
    class function Capabilities: TGLDataFileCapabilities; override;
53

54
    procedure LoadFromFile(const filename: string); override;
55
    procedure LoadFromStream(stream: TStream); override;
56

57
    procedure AssignFromTexture(textureContext: TGLContext;
58
      const textureHandle: TGLuint;
59
      textureTarget: TGLTextureTarget;
60
      const CurrentFormat: Boolean;
61
      const intFormat: TGLInternalFormat); reintroduce;
62

63
    property Gamma: Single read fGamma;
64
    property Exposure: Single read fExposure;
65
    property ProgramType: Ansistring read GetProgramType write SetProgramType;
66
  end;
67
//---------------------------------------------------------------------
68
//---------------------------------------------------------------------
69
//---------------------------------------------------------------------
70
implementation
71
//---------------------------------------------------------------------
72
//---------------------------------------------------------------------
73
//---------------------------------------------------------------------
74

75
// ------------------
76
// ------------------ TGLHDRImage ------------------
77
// ------------------
78

79
 
80
//
81

82
procedure TGLHDRImage.LoadFromFile(const filename: string);
83
var
84
  fs: TStream;
85
begin
86
  if FileStreamExists(fileName) then
87
  begin
88
    fs := CreateFileStream(fileName, fmOpenRead);
89
    try
90
      LoadFromStream(fs);
91
    finally
92
      fs.Free;
93
      ResourceName := filename;
94
    end;
95
  end
96
  else
97
    raise EInvalidRasterFile.CreateFmt('File %s not found', [filename]);
98
end;
99

100
procedure TGLHDRImage.LoadFromStream(stream: TStream);
101
const
102
  cRgbeFormat32bit = 'FORMAT=32-bit_rle_rgbe';
103
  cGamma = 'GAMMA=';
104
  cEXPOSURE = 'EXPOSURE=';
105
  cY = '-Y ';
106
var
107
  buf: array[0..1023] of AnsiChar;
108
  header: TStringList;
109
  s, sn: string;
110
  lineSize: integer;
111
  tempBuf, top, bottom: PByte;
112
  i, j, err: Integer;
113
  formatDefined: boolean;
114

115
  function CmpWord(const word: string): boolean;
116
  var
117
    l: Integer;
118
    ts: string;
119
  begin
120
    Result := false;
121
    ts := header.Strings[i];
122
    if Length(word) > Length(ts) then
123
      Exit;
124
    for l := 1 to Length(word) do
125
      if word[l] <> ts[l] then
126
        Exit;
127
    Result := true;
128
  end;
129

130
begin
131
  fProgramtype := '';
132
  fGamma := 1.0;
133
  fExposure := 1.0;
134
  UnMipmap;
135
  // Read HDR header
136
  stream.Read(buf, Length(buf) * sizeOf(AnsiChar));
137
  header := TStringList.Create;
138
  s := '';
139
  i := 0;
140
  j := 0;
141
  while i < Length(buf) do
142
  begin
143
    if buf[i] = #0 then
144
      Break;
145
    if buf[i] = #10 then
146
    begin
147
      header.Add(s);
148
      s := '';
149
      Inc(i);
150
      j := i;
151
      Continue;
152
    end;
153
    s := s + string(buf[i]);
154
    Inc(i);
155
  end;
156
  if i < Length(buf) then
157
    stream.Position := j
158
  else
159
    raise EInvalidRasterFile.Create('Can''t find HDR header end.');
160

161
  if (header.Strings[0][1] <> '#') or (header.Strings[0][2] <> '?') then
162
  begin
163
    header.Free;
164
    raise EInvalidRasterFile.Create('Bad HDR initial token.');
165
  end;
166
  // Get program type
167
  SetProgramtype(AnsiString(Copy(header.Strings[0], 3, Length(header.Strings[0])
168
    - 2)));
169

170
  formatDefined := false;
171
  for i := 1 to header.Count - 1 do
172
  begin
173
    if header.Strings[i] = cRgbeFormat32bit then
174
      formatDefined := true
175
    else if CmpWord(cGamma) then
176
    begin
177
      j := Length(cGamma);
178
      s := Copy(header.Strings[i], j + 1, Length(header.Strings[i]) - j);
179
      val(s, fGamma, err);
180
      if err <> 0 then
181
        raise EInvalidRasterFile.Create('Bad HDR header.');
182
    end
183
    else if CmpWord(cEXPOSURE) then
184
    begin
185
      j := Length(cEXPOSURE);
186
      s := Copy(header.Strings[i], j + 1, Length(header.Strings[i]) - j);
187
      val(s, fExposure, err);
188
      if err <> 0 then
189
        raise EInvalidRasterFile.Create('Bad HDR header.');
190
    end
191
    else if CmpWord(cY) then
192
    begin
193
      j := Length(cY);
194
      s := Copy(header.Strings[i], j + 1, Length(header.Strings[i]) - j);
195
      j := Pos(' ', s);
196
      sn := Copy(s, 1, j - 1);
197
      val(sn, FLOD[0].Height, err);
198
      Delete(s, 1, j + 3); // scip '+X '
199
      val(s, FLOD[0].Width, err);
200
      if err <> 0 then
201
        raise EInvalidRasterFile.Create('Bad HDR header.');
202
    end
203
  end; // for i
204
  header.Free;
205

206
  if not formatDefined then
207
    raise EInvalidRasterFile.Create('no FORMAT specifier found.');
208

209
  if (FLOD[0].Width = 0) or (FLOD[0].Height = 0) then
210
    raise EInvalidRasterFile.Create('Bad image dimension.');
211
  //set all the parameters
212
  FLOD[0].Depth := 0;
213
  fColorFormat := GL_RGB;
214
  fInternalFormat := tfRGBA_FLOAT32;
215
  fDataType := GL_FLOAT;
216
  fCubeMap := false;
217
  fTextureArray := false;
218
  fElementSize := GetTextureElementSize(tfFLOAT_RGB32);
219
  ReallocMem(fData, DataSize);
220
  LoadRLEpixels(stream, PSingle(fData), FLOD[0].Width, FLOD[0].Height);
221

222
  //hdr images come in upside down then flip it
223
  lineSize := fElementSize * FLOD[0].Width;
224
  GetMem(tempBuf, lineSize);
225
  top := PByte(fData);
226
  bottom := top;
227
  Inc(bottom, lineSize * (FLOD[0].Height - 1));
228
  for j := 0 to (FLOD[0].Height div 2) - 1 do
229
  begin
230
    Move(top^, tempBuf^, lineSize);
231
    Move(bottom^, top^, lineSize);
232
    Move(tempBuf^, bottom^, lineSize);
233
    Inc(top, lineSize);
234
    Dec(bottom, lineSize);
235
  end;
236
  FreeMem(tempBuf);
237
end;
238

239
function TGLHDRImage.GetProgramType: Ansistring;
240
begin
241
  Result := fProgramType;
242
end;
243

244
procedure TGLHDRImage.SetProgramType(aval: Ansistring);
245
var
246
  i: integer;
247
begin
248
  for i := 1 to Length(fProgramType) do
249
    fProgramType[i] := aval[i];
250
end;
251

252
// AssignFromTexture
253
//
254

255
procedure TGLHDRImage.AssignFromTexture(textureContext: TGLContext;
256
  const textureHandle: TGLuint;
257
  textureTarget: TGLTextureTarget;
258
  const CurrentFormat: Boolean;
259
  const intFormat: TGLInternalFormat);
260
var
261
  oldContext: TGLContext;
262
  contextActivate: Boolean;
263
  texFormat: Cardinal;
264
  residentFormat: TGLInternalFormat;
265
  glTarget: TGLEnum;
266
begin
267
  glTarget := DecodeGLTextureTarget(textureTarget);
268
  if not ((glTarget = GL_TEXTURE_2D)
269
    or (glTarget = GL_TEXTURE_RECTANGLE)) then
270
    Exit;
271

272
  oldContext := CurrentGLContext;
273
  contextActivate := (oldContext <> textureContext);
274
  if contextActivate then
275
  begin
276
    if Assigned(oldContext) then
277
      oldContext.Deactivate;
278
    textureContext.Activate;
279
  end;
280

281
  try
282
    textureContext.GLStates.TextureBinding[0, textureTarget] := textureHandle;
283
    fLevelCount := 0;
284
    fCubeMap := false;
285
    fTextureArray := false;
286
    fColorFormat := GL_RGB;
287
    fDataType := GL_FLOAT;
288
    // Check level existence
289
    GL.GetTexLevelParameteriv(glTarget, 0, GL_TEXTURE_INTERNAL_FORMAT, @texFormat);
290
    if texFormat > 1 then
291
    begin
292
      GL.GetTexLevelParameteriv(glTarget, 0, GL_TEXTURE_WIDTH, @FLOD[0].Width);
293
      GL.GetTexLevelParameteriv(glTarget, 0, GL_TEXTURE_HEIGHT, @FLOD[0].Height);
294
      FLOD[0].Depth := 0;
295
      residentFormat := OpenGLFormatToInternalFormat(texFormat);
296
      if CurrentFormat then
297
        fInternalFormat := residentFormat
298
      else
299
        fInternalFormat := intFormat;
300
      Inc(fLevelCount);
301
    end;
302

303
    if fLevelCount > 0 then
304
    begin
305
      fElementSize := GetTextureElementSize(fColorFormat, fDataType);
306
      ReallocMem(FData, DataSize);
307
      GL.GetTexImage(glTarget, 0, fColorFormat, fDataType, fData);
308
    end
309
    else
310
      fLevelCount := 1;
311
    GL.CheckError;
312
  finally
313
    if contextActivate then
314
    begin
315
      textureContext.Deactivate;
316
      if Assigned(oldContext) then
317
        oldContext.Activate;
318
    end;
319
  end;
320
end;
321

322
// Capabilities
323
//
324

325
class function TGLHDRImage.Capabilities: TGLDataFileCapabilities;
326
begin
327
  Result := [dfcRead {, dfcWrite}];
328
end;
329

330
initialization
331
  { Register this Fileformat-Handler with GLScene }
332
  RegisterRasterFormat('hdr', 'High Dynamic Range Image', TGLHDRImage);
333

334
end.
335