LZScene

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

7
   History :  
8
   17/11/14 - PW - Renamed from RGBE.pas to GLSRGBE.pas
9
   15/06/10 - Yar - Fixes for Linux x64
10
   20/01/10 - Yar - Creation
11
   
12
}
13
unit GLSRGBE;
14

15
interface
16

17
{$I GLScene.inc}
18

19
uses
20
  Classes, SysUtils,
21
   
22
  GLVectorTypes, GLVectorGeometry, GLCrossPlatform;
23

24
procedure Float2rgbe(var RGBE: TVector4b; const Red, Green, Blue: Single);
25
procedure Rgbe2float(var Red, Green, Blue: Single; const RGBE: TVector4b);
26
procedure LoadRLEpixels(Stream: TStream; Dst: PSingle;
27
  Scanline_width, Num_scanlines: Integer);
28
procedure LoadRGBEpixels(Stream: TStream; Dst: PSingle; Numpixels: Integer);
29

30
implementation
31

32
type
33
  ERGBEexception = class(Exception);
34

35
  { Extract exponent and mantissa from X }
36
procedure Frexp(X: Extended; var Mantissa: Extended; var Exponent: Integer);
37
{ Mantissa ptr in EAX, Exponent ptr in EDX }
38
{$IFDEF GLS_NO_ASM}
39
begin
40
  Exponent := 0;
41
  if (X <> 0) then
42
    if (Abs(X) < 0.5) then
43
      repeat
44
        X := X * 2;
45
        Dec(Exponent);
46
      until (Abs(X) >= 0.5)
47
    else
48
      while (Abs(X) >= 1) do
49
      begin
50
        X := X / 2;
51
        Inc(Exponent);
52
      end;
53
  Mantissa := X;
54
{$ELSE}
55
asm
56
  FLD     X
57
  PUSH    EAX
58
  MOV     dword ptr [edx], 0    { if X = 0, return 0 }
59

60
  FTST
61
  FSTSW   AX
62
  FWAIT
63
  SAHF
64
  JZ      @@Done
65

66
  FXTRACT                 // ST(1) = exponent, (pushed) ST = fraction
67
  FXCH
68

69
  // The FXTRACT instruction normalizes the fraction 1 bit higher than
70
  // wanted for the definition of frexp() so we need to tweak the result
71
  // by scaling the fraction down and incrementing the exponent.
72

73
  FISTP   dword ptr [edx]
74
  FLD1
75
  FCHS
76
  FXCH
77
  FSCALE                  // scale fraction
78
  INC     dword ptr [edx] // exponent biased to match
79
  FSTP ST(1)              // discard -1, leave fraction as TOS
80

81
@@Done:
82
  POP     EAX
83
  FSTP    tbyte ptr [eax]
84
  FWAIT
85
  {$ENDIF}
86
end;
87

88
function Ldexp(X: Extended; const P: Integer): Extended;
89
{$IFDEF GLS_NO_ASM}
90
begin
91
  Ldexp := X * Intpower(2.0, P);
92
{$ELSE}
93
{ Result := X * (2^P) }
94
asm
95
  PUSH    EAX
96
  FILD    dword ptr [ESP]
97
  FLD     X
98
  FSCALE
99
  POP     EAX
100
  FSTP    ST(1)
101
  FWAIT
102
  {$ENDIF}
103
end;
104

105
// standard conversion from float pixels to rgbe pixels
106
procedure Float2rgbe(var RGBE: TVector4b; const Red, Green, Blue: Single);
107
var
108
  V, M: Extended;
109
  E: Integer;
110
begin
111
  V := Red;
112
  if (Green > V) then
113
    V := Green;
114
  if (Blue > V) then
115
    V := Blue;
116
  if (V < 1E-32) then
117
  begin
118
    RGBE.V[0] := 0;
119
    RGBE.V[1] := 0;
120
    RGBE.V[2] := 0;
121
    RGBE.V[3] := 0;
122
  end
123
  else
124
  begin
125
    FrExp(V, M, E);
126
    M := M * 256 / V;
127
    RGBE.V[0] := Floor(Red * V);
128
    RGBE.V[1] := Floor(Green * V);
129
    RGBE.V[2] := Floor(Blue * V);
130
    RGBE.V[3] := Floor(E + 128);
131
  end;
132
end;
133

134
// standard conversion from rgbe to float pixels
135
// note: Ward uses ldexp(col+0.5,exp-(128+8)).  However we wanted pixels
136
// in the range [0,1] to map back into the range [0,1].
137
procedure Rgbe2float(var Red, Green, Blue: Single; const RGBE: TVector4b);
138
var
139
  F: Single;
140
begin
141
  if RGBE.V[3] <> 0 then // nonzero pixel
142
  begin
143
    F := Ldexp(1.0, RGBE.V[3] - (128 + 8));
144
    Red := RGBE.V[0] * F;
145
    Green := RGBE.V[1] * F;
146
    Blue := RGBE.V[2] * F;
147
  end
148
  else
149
  begin
150
    Red := 0;
151
    Green := 0;
152
    Blue := 0;
153
  end;
154
end;
155

156
procedure LoadRLEpixels(Stream: TStream; Dst: PSingle;
157
  Scanline_width, Num_scanlines: Integer);
158
var
159
  RgbeTemp: TVector4b;
160
  Buf: TVector2b;
161
  Rf, Gf, Bf: Single;
162
  Scanline_buffer: PByteArray;
163
  Ptr, Ptr_end: PByte;
164
  I: Integer;
165
  Count: Cardinal;
166
begin
167
  if (Scanline_width < 8) or (Scanline_width > $7FFF) then
168
  begin
169
    // run length encoding is not allowed so read flat
170
    LoadRGBEPixels(Stream, Dst, Scanline_width * Num_scanlines);
171
    Exit;
172
  end;
173

174
  Scanline_buffer := nil;
175
  while Num_scanlines > 0 do
176
  begin
177
    Stream.Read(RgbeTemp, SizeOf(TVector4b));
178
    if (RgbeTemp.V[0] <> 2) or (RgbeTemp.V[1] <> 2) or
179
      (RgbeTemp.V[2] and $80 <> 0) then
180
    begin
181
      // this file is not run length encoded
182
      Rgbe2float(Rf, Gf, Bf, RgbeTemp);
183
      Dst^ := Rf;
184
      Inc(Dst);
185
      Dst^ := Gf;
186
      Inc(Dst);
187
      Dst^ := Bf;
188
      Inc(Dst);
189
      if Assigned(Scanline_buffer) then
190
        FreeMem(Scanline_buffer);
191
      LoadRGBEpixels(Stream, Dst, Scanline_width * Num_scanlines - 1);
192
      Exit;
193
    end;
194
    if ((Integer(RgbeTemp.V[2]) shl 8) or RgbeTemp.V[3]) <> Scanline_width
195
    then
196
    begin
197
      if Assigned(Scanline_buffer) then
198
        FreeMem(Scanline_buffer);
199
      raise ERGBEexception.Create('Wrong scanline width.');
200
    end;
201

202
    if not Assigned(Scanline_buffer) then
203
      ReallocMem(Scanline_buffer, 4 * Scanline_width);
204

205
    Ptr := PByte(Scanline_buffer);
206
    // read each of the four channels for the scanline into the buffer
207
    for I := 0 to 3 do
208
    begin
209
      Ptr_end := @Scanline_buffer[(I + 1) * Scanline_width];
210
      while PtrUInt(Ptr) < PtrUInt(Ptr_end) do
211
      begin
212
        Stream.Read(Buf, SizeOf(TVector2b));
213
        if Buf.V[0] > 128 then
214
        begin // a run of the same value
215
          Count := Buf.V[0] - 128;
216
          if (Count = 0) or (Count > PtrUInt(Ptr_end) - PtrUInt(Ptr)) then
217
          begin
218
            FreeMem(Scanline_buffer);
219
            raise ERGBEexception.Create('Bad HDR scanline data.');
220
          end;
221
          while Count > 0 do
222
          begin
223
            Ptr^ := Buf.V[1];
224
            Dec(Count);
225
            Inc(Ptr);
226
          end;
227
        end
228
        else
229
        begin // a non-run
230
          Count := Buf.V[0];
231
          if (Count = 0) or (Count > PtrUInt(Ptr_end) - PtrUInt(Ptr)) then
232
          begin
233
            FreeMem(Scanline_buffer);
234
            raise ERGBEexception.Create('Bad HDR scanline data.');
235
          end;
236
          Ptr^ := Buf.V[1];
237
          Dec(Count);
238
          Inc(Ptr);
239
          if Count > 0 then
240
            Stream.Read(Ptr^, Count);
241
          Inc(Ptr, Count);
242
        end;
243
      end;
244
    end;
245

246
    // now convert data from buffer into floats
247
    for I := 0 to Scanline_width - 1 do
248
    begin
249
      RgbeTemp.V[0] := Scanline_buffer[I];
250
      RgbeTemp.V[1] := Scanline_buffer[I + Scanline_width];
251
      RgbeTemp.V[2] := Scanline_buffer[I + 2 * Scanline_width];
252
      RgbeTemp.V[3] := Scanline_buffer[I + 3 * Scanline_width];
253
      Rgbe2float(Rf, Gf, Bf, RgbeTemp);
254
      Dst^ := Rf;
255
      Inc(Dst);
256
      Dst^ := Gf;
257
      Inc(Dst);
258
      Dst^ := Bf;
259
      Inc(Dst);
260
    end;
261
    Dec(Num_scanlines);
262
  end;
263
  if Assigned(Scanline_buffer) then
264
    FreeMem(Scanline_buffer);
265
end;
266

267
procedure LoadRGBEpixels(Stream: TStream; Dst: PSingle; Numpixels: Integer);
268
var
269
  RgbeTemp: TVector4b;
270
  Rf, Gf, Bf: Single;
271
begin
272
  while Numpixels > 0 do
273
  begin
274
    Stream.Read(RgbeTemp, SizeOf(TVector4b));
275
    Rgbe2float(Rf, Gf, Bf, RgbeTemp);
276
    Dst^ := Rf;
277
    Inc(Dst);
278
    Dst^ := Gf;
279
    Inc(Dst);
280
    Dst^ := Bf;
281
    Inc(Dst);
282
    Dec(Numpixels);
283
  end;
284
end;
285

286
end.
287