src/lib/vampimg/ImagingRadiance.pas

   1 {
   2   Vampyre Imaging Library
   3   by Marek Mauder
   4   http://imaginglib.sourceforge.net
   5
   6   The contents of this file are used with permission, subject to the Mozilla
   7   Public License Version 1.1 (the "License"); you may not use this file except
   8   in compliance with the License. You may obtain a copy of the License at
   9   http://www.mozilla.org/MPL/MPL-1.1.html
  10
  11   Software distributed under the License is distributed on an "AS IS" basis,
  12   WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
  13   the specific language governing rights and limitations under the License.
  14
  15   Alternatively, the contents of this file may be used under the terms of the
  16   GNU Lesser General Public License (the  "LGPL License"), in which case the
  17   provisions of the LGPL License are applicable instead of those above.
  18   If you wish to allow use of your version of this file only under the terms
  19   of the LGPL License and not to allow others to use your version of this file
  20   under the MPL, indicate your decision by deleting  the provisions above and
  21   replace  them with the notice and other provisions required by the LGPL
  22   License.  If you do not delete the provisions above, a recipient may use
  23   your version of this file under either the MPL or the LGPL License.
  24
  25   For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
  26 }
  27
  28 { This unit contains image format loader/saver for Radiance HDR/RGBE images.}
  29 unit ImagingRadiance;
  30
  31 {$I ImagingOptions.inc}
  32
  33 interface
  34
  35 uses
  36   SysUtils, Classes, Imaging, ImagingTypes, ImagingUtility;
  37
  38 type
  39   { Radiance is a suite of tools for performing lighting simulation. It's
  40     development started in 1985 and it pioneered the concept of
  41     high dynamic range imaging. Radiance defined an image format for storing
  42     HDR images, now described as RGBE image format. Since it was the first
  43     HDR image format, this format is supported by many other software packages.
  44
  45     Radiance image file consists of three sections: a header, resolution string,
  46     followed by the pixel data. Each pixel is stored as 4 bytes, one byte
  47     mantissa for each r, g, b and a shared one byte exponent.
  48     The pixel data may be stored uncompressed or using run length encoding.
  49
  50     Imaging translates RGBE pixels to original float values and stores them
  51     in ifR32G32B32F data format. It can read both compressed and uncompressed
  52     files, and saves files as compressed.}
  53   THdrFileFormat = class(TImageFileFormat)
  54   protected
  55     procedure Define; override;
  56     function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
  57       OnlyFirstLevel: Boolean): Boolean; override;
  58     function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
  59       Index: LongInt): Boolean; override;
  60     procedure ConvertToSupported(var Image: TImageData;
  61       const Info: TImageFormatInfo); override;
  62   public
  63     function TestFormat(Handle: TImagingHandle): Boolean; override;
  64   end;
  65
  66 implementation
  67
  68 uses
  69   Math, ImagingIO;
  70
  71 const
  72   SHdrFormatName = 'Radiance HDR/RGBE';
  73   SHdrMasks      = '*.hdr';
  74   HdrSupportedFormats: TImageFormats = [ifR32G32B32F];
  75
  76 type
  77   TSignature = array[0..9] of AnsiChar;
  78   THdrFormat = (hfRgb, hfXyz);
  79
  80   THdrHeader = record
  81     Format: THdrFormat;
  82     Width: Integer;
  83     Height: Integer;
  84   end;
  85
  86   TRgbe = packed record
  87     R, G, B, E: Byte;
  88   end;
  89   PRgbe = ^TRgbe;
  90   TDynRgbeArray = array of TRgbe;
  91
  92 const
  93   RadianceSignature: TSignature = '#?RADIANCE';
  94   RgbeSignature: TSignature = '#?RGBE';
  95   MaxLineLength = 256;
  96   SFmtRgbeRle = '32-bit_rle_rgbe';
  97   SFmtXyzeRle = '32-bit_rle_xyze';
  98
  99 resourcestring
 100   SErrorBadHeader = 'Bad HDR/RGBE header format.';
 101   SWrongScanLineWidth = 'Wrong scanline width.';
 102   SXyzNotSupported = 'XYZ color space not supported.';
 103
 104 { THdrFileFormat }
 105
 106 procedure THdrFileFormat.Define;
 107 begin
 108   inherited;
 109   FName := SHdrFormatName;
 110   FFeatures := [ffLoad, ffSave];
 111   FSupportedFormats := HdrSupportedFormats;
 112
 113   AddMasks(SHdrMasks);
 114 end;
 115
 116 function THdrFileFormat.LoadData(Handle: TImagingHandle;
 117   var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
 118 var
 119   Header: THdrHeader;
 120   IO: TIOFunctions;
 121
 122   function ReadHeader: Boolean;
 123   const
 124     CommentIds: TAnsiCharSet = ['#', '!'];
 125   var
 126     Line: AnsiString;
 127     HasResolution: Boolean;
 128     Count, Idx: Integer;
 129     ValStr, NativeLine: string;
 130     ValFloat: Double;
 131   begin
 132     Result := False;
 133     HasResolution := False;
 134     Count := 0;
 135
 136     repeat
 137       if not ReadLine(IO, Handle, Line) then
 138         Exit;
 139
 140       Inc(Count);
 141       if Count > 16 then // Too long header for HDR
 142         Exit;
 143
 144       if Length(Line) = 0 then
 145         Continue;
 146       if Line[1] in CommentIds then
 147         Continue;
 148
 149       NativeLine := string(Line);
 150
 151       if StrMaskMatch(NativeLine, 'Format=*') then
 152       begin
 153         // Data format parsing
 154         ValStr := Copy(NativeLine, 8, MaxInt);
 155         if ValStr = SFmtRgbeRle then
 156           Header.Format := hfRgb
 157         else if ValStr = SFmtXyzeRle then
 158           Header.Format := hfXyz
 159         else
 160           Exit;
 161       end;
 162
 163       if StrMaskMatch(NativeLine, 'Gamma=*') then
 164       begin
 165         ValStr := Copy(NativeLine, 7, MaxInt);
 166         if TryStrToFloat(ValStr, ValFloat, GetFormatSettingsForFloats) then
 167           FMetadata.SetMetaItem(SMetaGamma, ValFloat);
 168       end;
 169
 170       if StrMaskMatch(NativeLine, 'Exposure=*') then
 171       begin
 172         ValStr := Copy(NativeLine, 10, MaxInt);
 173         if TryStrToFloat(ValStr, ValFloat, GetFormatSettingsForFloats) then
 174           FMetadata.SetMetaItem(SMetaExposure, ValFloat);
 175       end;
 176
 177       if StrMaskMatch(NativeLine, '?Y * ?X *') then
 178       begin
 179         Idx := Pos('X', NativeLine);
 180         ValStr := SubString(NativeLine, 4, Idx - 2);
 181         if not TryStrToInt(ValStr, Header.Height) then
 182           Exit;
 183         ValStr := Copy(NativeLine, Idx + 2, MaxInt);
 184         if not TryStrToInt(ValStr, Header.Width) then
 185           Exit;
 186
 187         if (NativeLine[1] = '-') then
 188           Header.Height := -Header.Height;
 189         if (NativeLine[Idx - 1] = '-') then
 190           Header.Width := -Header.Width;
 191
 192         HasResolution := True;
 193       end;
 194
 195     until HasResolution;
 196     Result := True;
 197   end;
 198
 199   procedure DecodeRgbe(const Src: TRgbe; Dest: PColor96FPRec); {$IFDEF USE_INLINE}inline;{$ENDIF}
 200   var
 201     Mult: Single;
 202   begin
 203     if Src.E > 0 then
 204     begin
 205       Mult := Math.Ldexp(1, Src.E - 128);
 206       Dest.R := Src.R / 255 * Mult;
 207       Dest.G := Src.G / 255 * Mult;
 208       Dest.B := Src.B / 255 * Mult;
 209     end
 210     else
 211     begin
 212       Dest.R := 0;
 213       Dest.G := 0;
 214       Dest.B := 0;
 215     end;
 216   end;
 217
 218   procedure ReadCompressedLine(Width, Y: Integer; var DestBuffer: TDynRgbeArray);
 219   var
 220     Pos: Integer;
 221     I, X, Count: Integer;
 222     Code, Value: Byte;
 223     LineBuff: TDynByteArray;
 224     Rgbe: TRgbe;
 225     Ptr: PByte;
 226   begin
 227     SetLength(LineBuff, Width);
 228     IO.Read(Handle, @Rgbe, SizeOf(Rgbe));
 229
 230     if ((Rgbe.B shl 8) or Rgbe.E) <> Width  then
 231       RaiseImaging(SWrongScanLineWidth);
 232
 233     for I := 0 to 3 do
 234     begin
 235       Pos := 0;
 236       while Pos < Width do
 237       begin
 238         IO.Read(Handle, @Code, SizeOf(Byte));
 239         if Code > 128 then
 240         begin
 241           Count := Code - 128;
 242           IO.Read(Handle, @Value, SizeOf(Byte));
 243           FillMemoryByte(@LineBuff[Pos], Count, Value);
 244         end
 245         else
 246         begin
 247           Count := Code;
 248           IO.Read(Handle, @LineBuff[Pos], Count * SizeOf(Byte));
 249         end;
 250         Inc(Pos, Count);
 251       end;
 252
 253       Ptr := @PByteArray(@DestBuffer[0])[I];
 254       for X := 0 to Width - 1 do
 255       begin
 256         Ptr^ := LineBuff[X];
 257         Inc(Ptr, 4);
 258       end;
 259     end;
 260   end;
 261
 262   procedure ReadPixels(var Image: TImageData);
 263   var
 264     Y, X, SrcLineLen: Integer;
 265     Dest: PColor96FPRec;
 266     Compressed: Boolean;
 267     Rgbe: TRgbe;
 268     Buffer: TDynRgbeArray;
 269   begin
 270     Dest := Image.Bits;
 271     Compressed := not ((Image.Width < 8) or (Image.Width > $7FFFF));
 272     SrcLineLen := Image.Width * SizeOf(TRgbe);
 273
 274     IO.Read(Handle, @Rgbe, SizeOf(Rgbe));
 275     IO.Seek(Handle, -SizeOf(Rgbe), smFromCurrent);
 276
 277     if (Rgbe.R <> 2) or (Rgbe.G <> 2) or ((Rgbe.B and 128) > 0) then
 278       Compressed := False;
 279
 280     SetLength(Buffer, Image.Width);
 281
 282     for Y := 0 to Image.Height - 1 do
 283     begin
 284       if Compressed then
 285         ReadCompressedLine(Image.Width, Y, Buffer)
 286       else
 287         IO.Read(Handle, @Buffer[0], SrcLineLen);
 288
 289       for X := 0 to Image.Width - 1 do
 290       begin
 291         DecodeRgbe(Buffer[X], Dest);
 292         Inc(Dest);
 293       end;
 294     end;
 295   end;
 296
 297 begin
 298   IO := GetIO;
 299   SetLength(Images, 1);
 300
 301   // Read header, allocate new image and, then read and convert the pixels
 302   if not ReadHeader then
 303     RaiseImaging(SErrorBadHeader);
 304   if (Header.Format = hfXyz) then
 305     RaiseImaging(SXyzNotSupported);
 306
 307   NewImage(Abs(Header.Width), Abs(Header.Height), ifR32G32B32F, Images[0]);
 308   ReadPixels(Images[0]);
 309
 310   // Flip/mirror the image as needed (height < 0 is default top-down)
 311   if Header.Width < 0 then
 312     MirrorImage(Images[0]);
 313   if Header.Height > 0 then
 314     FlipImage(Images[0]);
 315
 316   Result := True;
 317 end;
 318
 319 function THdrFileFormat.SaveData(Handle: TImagingHandle;
 320   const Images: TDynImageDataArray; Index: Integer): Boolean;
 321 const
 322   LineEnd = #$0A;
 323   SPrgComment = '#Made with Vampyre Imaging Library';
 324   SSizeFmt = '-Y %d +X %d';
 325 var
 326   ImageToSave: TImageData;
 327   MustBeFreed: Boolean;
 328   IO: TIOFunctions;
 329
 330   procedure SaveHeader;
 331   begin
 332     WriteLine(IO, Handle, RadianceSignature, LineEnd);
 333     WriteLine(IO, Handle, SPrgComment, LineEnd);
 334     WriteLine(IO, Handle, 'FORMAT=' + SFmtRgbeRle, LineEnd + LineEnd);
 335     WriteLine(IO, Handle, AnsiString(Format(SSizeFmt, [ImageToSave.Height, ImageToSave.Width])), LineEnd);
 336   end;
 337
 338   procedure EncodeRgbe(const Src: TColor96FPRec; var DestR, DestG, DestB, DestE: Byte); {$IFDEF USE_INLINE}inline;{$ENDIF}
 339   var
 340     V, M: {$IFDEF FPC}Float{$ELSE}Extended{$ENDIF};
 341     E: Integer;
 342   begin
 343     V := Src.R;
 344     if (Src.G > V) then
 345       V := Src.G;
 346     if (Src.B > V) then
 347       V := Src.B;
 348
 349     if V < 1e-32 then
 350     begin
 351       DestR := 0;
 352       DestG := 0;
 353       DestB := 0;
 354       DestE := 0;
 355     end
 356     else
 357     begin
 358       Frexp(V, M, E);
 359       V := M * 256.0 / V;
 360       DestR := ClampToByte(Round(Src.R * V));
 361       DestG := ClampToByte(Round(Src.G * V));
 362       DestB := ClampToByte(Round(Src.B * V));
 363       DestE := ClampToByte(E + 128);
 364     end;
 365   end;
 366
 367   procedure WriteRleLine(const Line: array of Byte; Width: Integer);
 368   const
 369     MinRunLength = 4;
 370   var
 371     Cur, BeginRun, RunCount, OldRunCount, NonRunCount: Integer;
 372     Buf: array[0..1] of Byte;
 373   begin
 374     Cur := 0;
 375     while Cur < Width do
 376     begin
 377       BeginRun := Cur;
 378       RunCount := 0;
 379       OldRunCount := 0;
 380       while (RunCount < MinRunLength) and (BeginRun < Width) do
 381       begin
 382         Inc(BeginRun, RunCount);
 383         OldRunCount := RunCount;
 384         RunCount := 1;
 385         while (BeginRun + RunCount < Width) and (RunCount < 127) and (Line[BeginRun] = Line[BeginRun + RunCount]) do
 386           Inc(RunCount);
 387       end;
 388       if (OldRunCount > 1) and (OldRunCount = BeginRun - Cur) then
 389       begin
 390         Buf[0] := 128 + OldRunCount;
 391         Buf[1] := Line[Cur];
 392         IO.Write(Handle, @Buf, 2);
 393         Cur := BeginRun;
 394       end;
 395       while Cur < BeginRun do
 396       begin
 397         NonRunCount := Min(128, BeginRun - Cur);
 398         Buf[0] := NonRunCount;
 399         IO.Write(Handle, @Buf, 1);
 400         IO.Write(Handle, @Line[Cur], NonRunCount);
 401         Inc(Cur, NonRunCount);
 402       end;
 403       if RunCount >= MinRunLength then
 404       begin
 405         Buf[0] := 128 + RunCount;
 406         Buf[1] := Line[BeginRun];
 407         IO.Write(Handle, @Buf, 2);
 408         Inc(Cur, RunCount);
 409       end;
 410     end;
 411   end;
 412
 413   procedure SavePixels;
 414   var
 415     Y, X, I, Width: Integer;
 416     SrcPtr: PColor96FPRecArray;
 417     Components: array of array of Byte;
 418     StartLine: array[0..3] of Byte;
 419   begin
 420     Width := ImageToSave.Width;
 421     // Save using RLE, each component is compressed separately
 422     SetLength(Components, 4, Width);
 423
 424     for Y := 0 to ImageToSave.Height - 1 do
 425     begin
 426       SrcPtr := @PColor96FPRecArray(ImageToSave.Bits)[ImageToSave.Width * Y];
 427
 428       // Identify line as using "new" RLE scheme (separate components)
 429       StartLine[0] := 2;
 430       StartLine[1] := 2;
 431       StartLine[2] := Width shr 8;
 432       StartLine[3] := Width and $FF;
 433       IO.Write(Handle, @StartLine, SizeOf(StartLine));
 434
 435       for X := 0 to Width - 1 do
 436       begin
 437         EncodeRgbe(SrcPtr[X], Components[0, X], Components[1, X],
 438           Components[2, X], Components[3, X]);
 439       end;
 440
 441       for I := 0 to 3 do
 442         WriteRleLine(Components[I], Width);
 443     end;
 444   end;
 445
 446 begin
 447   Result := False;
 448   IO := GetIO;
 449   // Makes image to save compatible with Jpeg saving capabilities
 450   if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
 451   with ImageToSave do
 452   try
 453     // Save header
 454     SaveHeader;
 455     // Save uncompressed pixels
 456     SavePixels;
 457   finally
 458     if MustBeFreed then
 459       FreeImage(ImageToSave);
 460   end;
 461 end;
 462
 463 procedure THdrFileFormat.ConvertToSupported(var Image: TImageData;
 464   const Info: TImageFormatInfo);
 465 begin
 466   ConvertImage(Image, ifR32G32B32F);
 467 end;
 468
 469 function THdrFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
 470 var
 471   FileSig: TSignature;
 472   ReadCount: Integer;
 473 begin
 474   Result := False;
 475   if Handle <> nil then
 476   begin
 477     ReadCount := GetIO.Read(Handle, @FileSig, SizeOf(FileSig));
 478     GetIO.Seek(Handle, -ReadCount, smFromCurrent);
 479     Result := (ReadCount = SizeOf(FileSig)) and
 480       ((FileSig = RadianceSignature) or CompareMem(@FileSig, @RgbeSignature, 6));
 481   end;
 482 end;
 483
 484 initialization
 485   RegisterImageFileFormat(THdrFileFormat);
 486
 487 {
 488   File Notes:
 489
 490   -- 0.77.1 ---------------------------------------------------
 491     - Added RLE compression to saving.
 492     - Added image saving.
 493     - Unit created with initial stuff (loading only).
 494
 495 }
 496
 497 end.