src/lib/vampimg/ImagingPortableMaps.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 loader/saver for Portable Maps file format family (or PNM).
  29   That includes PBM, PGM, PPM, PAM, and PFM formats.}
  30 unit ImagingPortableMaps;
  31
  32 {$I ImagingOptions.inc}
  33
  34 interface
  35
  36 uses
  37   SysUtils, ImagingTypes, Imaging, ImagingFormats, ImagingUtility;
  38
  39 type
  40   { Types of pixels of PNM images.}
  41   TTupleType = (ttInvalid, ttBlackAndWhite, ttGrayScale, ttRGB, ttBlackAndWhiteAlpha,
  42     ttGrayScaleAlpha, ttRGBAlpha, ttGrayScaleFP, ttRGBFP);
  43
  44   { Record with info about PNM image used in both loading and saving functions.}
  45   TPortableMapInfo = record
  46     Width: LongInt;
  47     Height: LongInt;
  48     FormatId: AnsiChar;
  49     MaxVal: LongInt;
  50     BitCount: LongInt;
  51     Depth: LongInt;
  52     TupleType: TTupleType;
  53     Binary: Boolean;
  54     HasPAMHeader: Boolean;
  55     IsBigEndian: Boolean;
  56   end;
  57
  58   { Base class for Portable Map file formats (or Portable AnyMaps or PNM).
  59     There are several types of PNM file formats that share common
  60     (simple) structure. This class can actually load all supported PNM formats.
  61     Saving is also done by this class but descendants (each for different PNM
  62     format) control it.}
  63   TPortableMapFileFormat = class(TImageFileFormat)
  64   protected
  65     FIdNumbers: TChar2;
  66     FSaveBinary: LongBool;
  67     FUSFormat: TFormatSettings;
  68     procedure Define; override;
  69     function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
  70       OnlyFirstLevel: Boolean): Boolean; override;
  71     function SaveDataInternal(Handle: TImagingHandle; const Images: TDynImageDataArray;
  72       Index: LongInt; var MapInfo: TPortableMapInfo): Boolean;
  73   public
  74     function TestFormat(Handle: TImagingHandle): Boolean; override;
  75   published
  76     { If set to True images will be saved in binary format. If it is False
  77       they will be saved in text format (which could result in 5-10x bigger file).
  78       Default is value True. Note that PAM and PFM files are always saved in binary.}
  79     property SaveBinary: LongBool read FSaveBinary write FSaveBinary;
  80   end;
  81
  82   { Portable Bit Map is used to store monochrome 1bit images. Raster data
  83     can be saved as text or binary data. Either way value of 0 represents white
  84     and 1 is black. As Imaging does not have support for 1bit data formats
  85     PBM images can be loaded but not saved. Loaded images are returned in
  86     ifGray8 format (witch pixel values scaled from 1bit to 8bit).}
  87   TPBMFileFormat = class(TPortableMapFileFormat)
  88   protected
  89     procedure Define; override;
  90   end;
  91
  92   { Portable Gray Map is used to store grayscale 8bit or 16bit images.
  93     Raster data can be saved as text or binary data.}
  94   TPGMFileFormat = class(TPortableMapFileFormat)
  95   protected
  96     procedure Define; override;
  97     function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
  98       Index: LongInt): Boolean; override;
  99     procedure ConvertToSupported(var Image: TImageData;
 100       const Info: TImageFormatInfo); override;
 101   end;
 102
 103   { Portable Pixel Map is used to store RGB images with 8bit or 16bit channels.
 104     Raster data can be saved as text or binary data.}
 105   TPPMFileFormat = class(TPortableMapFileFormat)
 106   protected
 107     procedure Define; override;
 108     function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
 109       Index: LongInt): Boolean; override;
 110     procedure ConvertToSupported(var Image: TImageData;
 111       const Info: TImageFormatInfo); override;
 112   end;
 113
 114   { Portable Arbitrary Map is format that can store image data formats
 115     of PBM, PGM, and PPM formats with optional alpha channel. Raster data
 116     can be stored only in binary format. All data formats supported
 117     by this format are ifGray8, ifGray16, ifA8Gray8, ifA16Gray16,
 118     ifR8G8B8, ifR16G16R16, ifA8R8G8B8, and ifA16R16G16B16.}
 119   TPAMFileFormat = class(TPortableMapFileFormat)
 120   protected
 121     procedure Define; override;
 122     function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
 123       Index: LongInt): Boolean; override;
 124     procedure ConvertToSupported(var Image: TImageData;
 125       const Info: TImageFormatInfo); override;
 126   end;
 127
 128   { Portable Float Map is unofficial extension of PNM format family which
 129     can store images with floating point pixels. Raster data is saved in
 130     binary format as array of IEEE 32 bit floating point numbers. One channel
 131     or RGB images are supported by PFM format (so no alpha).}
 132   TPFMFileFormat = class(TPortableMapFileFormat)
 133   protected
 134     procedure Define; override;
 135     function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
 136       Index: LongInt): Boolean; override;
 137     procedure ConvertToSupported(var Image: TImageData;
 138       const Info: TImageFormatInfo); override;
 139   end;
 140
 141 implementation
 142
 143 const
 144   PortableMapDefaultBinary = True;
 145
 146   SPBMFormatName = 'Portable Bit Map';
 147   SPBMMasks =      '*.pbm';
 148   SPGMFormatName = 'Portable Gray Map';
 149   SPGMMasks =      '*.pgm';
 150   PGMSupportedFormats = [ifGray8, ifGray16];
 151   SPPMFormatName = 'Portable Pixel Map';
 152   SPPMMasks =      '*.ppm';
 153   PPMSupportedFormats = [ifR8G8B8, ifR16G16B16];
 154   SPAMFormatName = 'Portable Arbitrary Map';
 155   SPAMMasks =      '*.pam';
 156   PAMSupportedFormats = [ifGray8, ifGray16, ifA8Gray8, ifA16Gray16,
 157     ifR8G8B8, ifR16G16B16, ifA8R8G8B8, ifA16R16G16B16];
 158   SPFMFormatName = 'Portable Float Map';
 159   SPFMMasks =      '*.pfm';
 160   PFMSupportedFormats = [ifR32F, ifB32G32R32F];
 161
 162 const
 163   { TAB, CR, LF, and Space are used as seperators in Portable map headers and data.}
 164   WhiteSpaces = [#9, #10, #13, #32];
 165   SPAMWidth = 'WIDTH';
 166   SPAMHeight = 'HEIGHT';
 167   SPAMDepth = 'DEPTH';
 168   SPAMMaxVal = 'MAXVAL';
 169   SPAMTupleType = 'TUPLTYPE';
 170   SPAMEndHdr = 'ENDHDR';
 171
 172   { Size of buffer used to speed up text PNM loading/saving.}
 173   LineBufferCapacity = 16 * 1024;
 174
 175   TupleTypeNames: array[TTupleType] of string = (
 176     'INVALID', 'BLACKANDWHITE', 'GRAYSCALE', 'RGB',
 177     'BLACKANDWHITE_ALPHA', 'GRAYSCALE_ALPHA', 'RGB_ALPHA', 'GRAYSCALEFP',
 178     'RGBFP');
 179
 180 { TPortableMapFileFormat }
 181
 182 procedure TPortableMapFileFormat.Define;
 183 begin
 184   inherited;
 185   FFeatures := [ffLoad, ffSave];
 186   FSaveBinary := PortableMapDefaultBinary;
 187   FUSFormat := GetFormatSettingsForFloats;
 188 end;
 189
 190 function TPortableMapFileFormat.LoadData(Handle: TImagingHandle;
 191   var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
 192 var
 193   I, ScanLineSize, MonoSize: LongInt;
 194   Dest: PByte;
 195   MonoData: Pointer;
 196   Info: TImageFormatInfo;
 197   LineBuffer: array[0..LineBufferCapacity - 1] of AnsiChar;
 198   LineEnd, LinePos: LongInt;
 199   MapInfo: TPortableMapInfo;
 200   LineBreak: string;
 201
 202   procedure CheckBuffer;
 203   begin
 204     if (LineEnd = 0) or (LinePos = LineEnd) then
 205     begin
 206       // Reload buffer if its is empty or its end was reached
 207       LineEnd := GetIO.Read(Handle, @LineBuffer[0], LineBufferCapacity);
 208       LinePos := 0;
 209     end;
 210   end;
 211
 212   procedure FixInputPos;
 213   begin
 214     // Sets input's position to its real pos as it would be without buffering
 215     if LineEnd > 0 then
 216     begin
 217       GetIO.Seek(Handle, -LineEnd + LinePos, smFromCurrent);
 218       LineEnd := 0;
 219     end;
 220   end;
 221
 222   function ReadString: string;
 223   var
 224     S: AnsiString;
 225     C: AnsiChar;
 226   begin
 227     // First skip all whitespace chars
 228     SetLength(S, 1);
 229     repeat
 230       CheckBuffer;
 231       S[1] := LineBuffer[LinePos];
 232       Inc(LinePos);
 233       if S[1] = '#' then
 234       repeat
 235         // Comment detected, skip everything until next line is reached
 236         CheckBuffer;
 237         S[1] := LineBuffer[LinePos];
 238         Inc(LinePos);
 239       until S[1] = #10;
 240     until not(S[1] in WhiteSpaces);
 241     // Now we have reached some chars other than white space, read them until
 242     // there is whitespace again
 243     repeat
 244       SetLength(S, Length(S) + 1);
 245       CheckBuffer;
 246       S[Length(S)] := LineBuffer[LinePos];
 247       Inc(LinePos);
 248       // Repeat until current char is whitespace or end of file is reached
 249       // (Line buffer has 0 bytes which happens only on EOF)
 250     until (S[Length(S)] in WhiteSpaces) or (LineEnd = 0);
 251     // Get rid of last char - whitespace or null
 252     SetLength(S, Length(S) - 1);
 253     // Move position to the beginning of next string (skip white space - needed
 254     // to make the loader stop at the right input position)
 255     repeat
 256       CheckBuffer;
 257       C := LineBuffer[LinePos];
 258       Inc(LinePos);
 259     until not (C in WhiteSpaces) or (LineEnd = 0);
 260     // Dec pos, current is the begining of the the string
 261     Dec(LinePos);
 262
 263     Result := string(S);
 264   end;
 265
 266   function ReadIntValue: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
 267   begin
 268     Result := StrToInt(ReadString);
 269   end;
 270
 271   procedure FindLineBreak;
 272   var
 273     C: AnsiChar;
 274   begin
 275     LineBreak := #10;
 276     repeat
 277       CheckBuffer;
 278       C := LineBuffer[LinePos];
 279       Inc(LinePos);
 280
 281       if C = #13 then
 282         LineBreak := #13#10;
 283
 284     until C = #10;
 285   end;
 286
 287   function ParseHeader: Boolean;
 288   var
 289     Id: TChar2;
 290     I: TTupleType;
 291     TupleTypeName: string;
 292     Scale: Single;
 293   begin
 294     Result := False;
 295     with GetIO do
 296     begin
 297       FillChar(MapInfo, SizeOf(MapInfo), 0);
 298       Read(Handle, @Id, SizeOf(Id));
 299       FindLineBreak;
 300
 301       if Id[1] in ['1'..'6'] then
 302       begin
 303         // Read header for PBM, PGM, and PPM files
 304         MapInfo.Width := ReadIntValue;
 305         MapInfo.Height := ReadIntValue;
 306
 307         if Id[1] in ['1', '4'] then
 308         begin
 309           MapInfo.MaxVal := 1;
 310           MapInfo.BitCount := 1
 311         end
 312         else
 313         begin
 314           // Read channel max value, <=255 for 8bit images, >255 for 16bit images
 315           // but some programs think its max colors so put <=256 here
 316           MapInfo.MaxVal := ReadIntValue;
 317           MapInfo.BitCount := Iff(MapInfo.MaxVal <= 256, 8, 16);
 318         end;
 319
 320         MapInfo.Depth := 1;
 321         case Id[1] of
 322           '1', '4': MapInfo.TupleType := ttBlackAndWhite;
 323           '2', '5': MapInfo.TupleType := ttGrayScale;
 324           '3', '6':
 325             begin
 326               MapInfo.TupleType := ttRGB;
 327               MapInfo.Depth := 3;
 328             end;
 329         end;
 330       end
 331       else if Id[1] = '7' then
 332       begin
 333         // Read values from PAM header
 334         // WIDTH
 335         if (ReadString <> SPAMWidth) then Exit;
 336         MapInfo.Width := ReadIntValue;
 337         // HEIGHT
 338         if (ReadString <> SPAMheight) then Exit;
 339         MapInfo.Height := ReadIntValue;
 340         // DEPTH
 341         if (ReadString <> SPAMDepth) then Exit;
 342         MapInfo.Depth := ReadIntValue;
 343         // MAXVAL
 344         if (ReadString <> SPAMMaxVal) then Exit;
 345         MapInfo.MaxVal := ReadIntValue;
 346         MapInfo.BitCount := Iff(MapInfo.MaxVal <= 256, 8, 16);
 347         // TUPLETYPE
 348         if (ReadString <> SPAMTupleType) then Exit;
 349         TupleTypeName := ReadString;
 350         for I := Low(TTupleType) to High(TTupleType) do
 351           if SameText(TupleTypeName, TupleTypeNames[I]) then
 352           begin
 353             MapInfo.TupleType := I;
 354             Break;
 355           end;
 356         // ENDHDR
 357         if (ReadString <> SPAMEndHdr) then Exit;
 358       end
 359       else if Id[1] in ['F', 'f'] then
 360       begin
 361         // Read header of PFM file
 362         MapInfo.Width := ReadIntValue;
 363         MapInfo.Height := ReadIntValue;
 364         Scale := StrToFloatDef(ReadString, 0, FUSFormat);
 365         MapInfo.IsBigEndian := Scale > 0.0;
 366         if Id[1] = 'F' then
 367           MapInfo.TupleType := ttRGBFP
 368         else
 369           MapInfo.TupleType := ttGrayScaleFP;
 370         MapInfo.Depth := Iff(MapInfo.TupleType = ttRGBFP, 3, 1);
 371         MapInfo.BitCount := Iff(MapInfo.TupleType = ttRGBFP, 96, 32);
 372       end;
 373
 374       FixInputPos;
 375       MapInfo.Binary := (Id[1] in ['4', '5', '6', '7', 'F', 'f']);
 376
 377       if MapInfo.Binary  and not (Id[1] in ['F', 'f']) then
 378       begin
 379         // Mimic the behaviour of Photoshop and other editors/viewers:
 380         // If linenreaks in file are DOS CR/LF 16bit binary values are
 381         // little endian, Unix LF only linebreak indicates big endian.
 382         MapInfo.IsBigEndian := LineBreak = #10;
 383       end;
 384
 385       // Check if values found in header are valid
 386       Result := (MapInfo.Width > 0) and (MapInfo.Height > 0) and
 387         (MapInfo.BitCount in [1, 8, 16, 32, 96]) and (MapInfo.TupleType <> ttInvalid);
 388       // Now check if image has proper number of channels (PAM)
 389       if Result then
 390         case MapInfo.TupleType of
 391           ttBlackAndWhite, ttGrayScale:           Result := MapInfo.Depth = 1;
 392           ttBlackAndWhiteAlpha, ttGrayScaleAlpha: Result := MapInfo.Depth = 2;
 393           ttRGB:      Result := MapInfo.Depth = 3;
 394           ttRGBAlpha: Result := MapInfo.Depth = 4;
 395         end;
 396     end;
 397   end;
 398
 399 begin
 400   Result := False;
 401   LineEnd := 0;
 402   LinePos := 0;
 403   SetLength(Images, 1);
 404
 405   with GetIO, Images[0] do
 406   begin
 407     Format := ifUnknown;
 408     // Try to parse file header
 409     if not ParseHeader then Exit;
 410     // Select appropriate data format based on values read from file header
 411     case MapInfo.TupleType of
 412       ttBlackAndWhite:      Format := ifGray8;
 413       ttBlackAndWhiteAlpha: Format := ifA8Gray8;
 414       ttGrayScale:          Format := IffFormat(MapInfo.BitCount = 8, ifGray8, ifGray16);
 415       ttGrayScaleAlpha:     Format := IffFormat(MapInfo.BitCount = 8, ifA8Gray8, ifA16Gray16);
 416       ttRGB:                Format := IffFormat(MapInfo.BitCount = 8, ifR8G8B8, ifR16G16B16);
 417       ttRGBAlpha:           Format := IffFormat(MapInfo.BitCount = 8, ifA8R8G8B8, ifA16R16G16B16);
 418       ttGrayScaleFP:        Format := ifR32F;
 419       ttRGBFP:              Format := ifB32G32R32F;
 420     end;
 421     // Exit if no matching data format was found
 422     if Format = ifUnknown then Exit;
 423
 424     NewImage(MapInfo.Width, MapInfo.Height, Format, Images[0]);
 425     Info := GetFormatInfo(Format);
 426
 427     // Now read pixels from file to dest image
 428     if not MapInfo.Binary then
 429     begin
 430       Dest := Bits;
 431       for I := 0 to Width * Height - 1 do
 432       begin
 433         case Format of
 434           ifGray8:
 435             begin
 436               Dest^ := ReadIntValue;
 437               if MapInfo.BitCount = 1 then
 438                 // If source is 1bit mono image (where 0=white, 1=black)
 439                 // we must scale it to 8bits
 440                 Dest^ := 255 - Dest^ * 255;
 441             end;
 442           ifGray16: PWord(Dest)^ := ReadIntValue;
 443           ifR8G8B8:
 444             with PColor24Rec(Dest)^ do
 445             begin
 446               R := ReadIntValue;
 447               G := ReadIntValue;
 448               B := ReadIntValue;
 449             end;
 450           ifR16G16B16:
 451             with PColor48Rec(Dest)^ do
 452             begin
 453               R := ReadIntValue;
 454               G := ReadIntValue;
 455               B := ReadIntValue;
 456             end;
 457         end;
 458         Inc(Dest, Info.BytesPerPixel);
 459       end;
 460     end
 461     else
 462     begin
 463       if MapInfo.BitCount > 1 then
 464       begin
 465         if not (MapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then
 466         begin
 467           // Just copy bytes from binary Portable Maps (non 1bit, non FP)
 468           Read(Handle, Bits, Size);
 469         end
 470         else
 471         begin
 472           Dest := Bits;
 473           // FP images are in BGR order and endian swap maybe needed.
 474           // Some programs store scanlines in bottom-up order but
 475           // I will stick with Photoshops behaviour here
 476           Read(Handle, Bits, Size);
 477           if MapInfo.IsBigEndian then
 478             SwapEndianLongWord(PLongWord(Dest), Size div SizeOf(LongWord));
 479         end;
 480
 481         if MapInfo.TupleType in [ttBlackAndWhite, ttBlackAndWhiteAlpha] then
 482         begin
 483           // Black and white PAM files must be scaled to 8bits. Note that
 484           // in PAM files 1=white, 0=black (reverse of PBM)
 485           for I := 0 to Width * Height * Iff(MapInfo.TupleType = ttBlackAndWhiteAlpha, 2, 1) - 1 do
 486             PByteArray(Bits)[I] := PByteArray(Bits)[I] * 255;
 487         end
 488         else if MapInfo.TupleType in [ttRGB, ttRGBAlpha] then
 489         begin
 490           // Swap channels of RGB/ARGB images. Binary RGB image files use BGR order.
 491           SwapChannels(Images[0], ChannelBlue, ChannelRed);
 492         end;
 493
 494         // Swap byte order if needed
 495         if (MapInfo.BitCount = 16) and MapInfo.IsBigEndian then
 496           SwapEndianWord(Bits, Width * Height * Info.BytesPerPixel div SizeOf(Word));
 497       end
 498       else
 499       begin
 500         // Handle binary PBM files (ttBlackAndWhite 1bit)
 501         ScanLineSize := (Width + 7) div 8;
 502         // Get total binary data size, read it from file to temp
 503         // buffer and convert the data to Gray8
 504         MonoSize := ScanLineSize * Height;
 505         GetMem(MonoData, MonoSize);
 506         try
 507           Read(Handle, MonoData, MonoSize);
 508           Convert1To8(MonoData, Bits, Width, Height, ScanLineSize, False);
 509           // 1bit mono images must be scaled to 8bit, but inverted (where 0=white, 1=black)
 510           for I := 0 to Width * Height - 1 do
 511             PByteArray(Bits)[I] := 255 - PByteArray(Bits)[I] * 255;
 512         finally
 513           FreeMem(MonoData);
 514         end;
 515       end;
 516     end;
 517
 518     FixInputPos;
 519
 520     if (MapInfo.MaxVal <> Pow2Int(MapInfo.BitCount) - 1) and
 521       (MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha, ttRGB, ttRGBAlpha]) then
 522     begin
 523       Dest := Bits;
 524       // Scale color values according to MaxVal we got from header
 525       // if necessary.
 526       for I := 0 to Width * Height * Info.BytesPerPixel div (MapInfo.BitCount shr 3) - 1 do
 527       begin
 528         if MapInfo.BitCount = 8 then
 529           Dest^ := Dest^ * 255 div MapInfo.MaxVal
 530         else
 531           PWord(Dest)^ := PWord(Dest)^ * 65535 div MapInfo.MaxVal;
 532         Inc(Dest, MapInfo.BitCount shr 3);
 533       end;
 534     end;
 535
 536     Result := True;
 537   end;
 538 end;
 539
 540 function TPortableMapFileFormat.SaveDataInternal(Handle: TImagingHandle;
 541   const Images: TDynImageDataArray; Index: Integer; var MapInfo: TPortableMapInfo): Boolean;
 542 const
 543   // Use Unix linebreak, for many viewers/editors it means that
 544   // 16bit samples are stored as big endian - so we need to swap byte order
 545   // before saving
 546   LineDelimiter  = #10;
 547   PixelDelimiter = #32;
 548 var
 549   ImageToSave: TImageData;
 550   MustBeFreed: Boolean;
 551   Info: TImageFormatInfo;
 552   I, LineLength: LongInt;
 553   Src: PByte;
 554   Pixel32: TColor32Rec;
 555   Pixel64: TColor64Rec;
 556   W: Word;
 557
 558   procedure WriteString(S: string; Delimiter: Char = LineDelimiter);
 559   begin
 560     SetLength(S, Length(S) + 1);
 561     S[Length(S)] := Delimiter;
 562   {$IF Defined(DCC) and Defined(UNICODE)}
 563     GetIO.Write(Handle, @AnsiString(S)[1], Length(S));
 564   {$ELSE}
 565     GetIO.Write(Handle, @S[1], Length(S));
 566   {$IFEND}
 567     Inc(LineLength, Length(S));
 568   end;
 569
 570   procedure WriteHeader;
 571   begin
 572     WriteString('P' + MapInfo.FormatId);
 573     if not MapInfo.HasPAMHeader then
 574     begin
 575       // Write header of PGM, PPM, and PFM files
 576       WriteString(IntToStr(ImageToSave.Width));
 577       WriteString(IntToStr(ImageToSave.Height));
 578       case MapInfo.TupleType of
 579         ttGrayScale, ttRGB: WriteString(IntToStr(Pow2Int(MapInfo.BitCount) - 1));
 580         ttGrayScaleFP, ttRGBFP:
 581           begin
 582             // Negative value indicates that raster data is saved in little endian
 583             WriteString(FloatToStr(-1.0, FUSFormat));
 584           end;
 585       end;
 586     end
 587     else
 588     begin
 589       // Write PAM file header
 590       WriteString(Format('%s %d', [SPAMWidth, ImageToSave.Width]));
 591       WriteString(Format('%s %d', [SPAMHeight, ImageToSave.Height]));
 592       WriteString(Format('%s %d', [SPAMDepth, MapInfo.Depth]));
 593       WriteString(Format('%s %d', [SPAMMaxVal, Pow2Int(MapInfo.BitCount) - 1]));
 594       WriteString(Format('%s %s', [SPAMTupleType, TupleTypeNames[MapInfo.TupleType]]));
 595       WriteString(SPAMEndHdr);
 596     end;
 597   end;
 598
 599 begin
 600   Result := False;
 601   if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
 602   with GetIO, ImageToSave do
 603   try
 604     Info := GetFormatInfo(Format);
 605     // Fill values of MapInfo record that were not filled by
 606     // descendants in their SaveData methods
 607     MapInfo.BitCount := (Info.BytesPerPixel div Info.ChannelCount) * 8;
 608     MapInfo.Depth := Info.ChannelCount;
 609     if MapInfo.TupleType = ttInvalid then
 610     begin
 611       if Info.HasGrayChannel then
 612       begin
 613         if Info.HasAlphaChannel then
 614           MapInfo.TupleType := ttGrayScaleAlpha
 615         else
 616           MapInfo.TupleType := ttGrayScale;
 617       end
 618       else
 619       begin
 620         if Info.HasAlphaChannel then
 621           MapInfo.TupleType := ttRGBAlpha
 622         else
 623           MapInfo.TupleType := ttRGB;
 624       end;
 625     end;
 626     // Write file header
 627     WriteHeader;
 628
 629     if not MapInfo.Binary then
 630     begin
 631       Src := Bits;
 632       LineLength := 0;
 633       // For each pixel find its text representation and write it to file
 634       for I := 0 to Width * Height  - 1 do
 635       begin
 636         case Format of
 637           ifGray8: WriteString(IntToStr(Src^), PixelDelimiter);
 638           ifGray16: WriteString(IntToStr(PWord(Src)^), PixelDelimiter);
 639           ifR8G8B8:
 640             with PColor24Rec(Src)^ do
 641               WriteString(SysUtils.Format('%d %d %d', [R, G, B]), PixelDelimiter);
 642           ifR16G16B16:
 643             with PColor48Rec(Src)^ do
 644               WriteString(SysUtils.Format('%d %d %d', [R, G, B]), PixelDelimiter);
 645         end;
 646         // Lines in text PNM images should have length <70
 647         if LineLength > 65 then
 648         begin
 649           LineLength := 0;
 650           WriteString('', LineDelimiter);
 651         end;
 652         Inc(Src, Info.BytesPerPixel);
 653       end;
 654     end
 655     else
 656     begin
 657       // Write binary images
 658       if not (MapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then
 659       begin
 660         // Save integer binary images
 661         if  MapInfo.BitCount = 8 then
 662         begin
 663           if MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha] then
 664           begin
 665             // 8bit grayscale images can be written in one Write call
 666             Write(Handle, Bits, Size);
 667           end
 668           else
 669           begin
 670             // 8bit RGB/ARGB images: red and blue must be swapped and
 671             // 3 or 4 bytes must be written
 672             Src := Bits;
 673             for I := 0 to Width * Height - 1 do
 674             with PColor32Rec(Src)^ do
 675             begin
 676               if MapInfo.TupleType = ttRGBAlpha then
 677                 Pixel32.A := A;
 678               Pixel32.R := B;
 679               Pixel32.G := G;
 680               Pixel32.B := R;
 681               Write(Handle, @Pixel32, Info.BytesPerPixel);
 682               Inc(Src, Info.BytesPerPixel);
 683             end;
 684           end;
 685         end
 686         else
 687         begin
 688           // Images with 16bit channels: make sure that channel values are saved in big endian
 689           Src := Bits;
 690           if MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha] then
 691           begin
 692             // 16bit grayscale image
 693             for I := 0 to Width * Height * Info.BytesPerPixel div SizeOf(Word) - 1 do
 694             begin
 695               W := SwapEndianWord(PWord(Src)^);
 696               Write(Handle, @W, SizeOf(Word));
 697               Inc(Src, SizeOf(Word));
 698             end;
 699           end
 700           else
 701           begin
 702             // RGB images with 16bit channels: swap RB and endian too
 703             for I := 0 to Width * Height - 1 do
 704             with PColor64Rec(Src)^ do
 705             begin
 706               if MapInfo.TupleType = ttRGBAlpha then
 707                 Pixel64.A := SwapEndianWord(A);
 708               Pixel64.R := SwapEndianWord(B);
 709               Pixel64.G := SwapEndianWord(G);
 710               Pixel64.B := SwapEndianWord(R);
 711               Write(Handle, @Pixel64, Info.BytesPerPixel);
 712               Inc(Src, Info.BytesPerPixel);
 713             end;
 714           end;
 715         end;
 716       end
 717       else
 718       begin
 719         // Floating point images (no need to swap endian here - little
 720         // endian is specified in file header)
 721         Write(Handle, Bits, Size);
 722       end;
 723     end;
 724     Result := True;
 725   finally
 726     if MustBeFreed then
 727       FreeImage(ImageToSave);
 728   end;
 729 end;
 730
 731 function TPortableMapFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
 732 var
 733   Id: TChar4;
 734   ReadCount: LongInt;
 735 begin
 736   Result := False;
 737   if Handle <> nil then
 738   with GetIO do
 739   begin
 740     ReadCount := Read(Handle, @Id, SizeOf(Id));
 741     Seek(Handle, -ReadCount, smFromCurrent);
 742     Result := (Id[0] = 'P') and (Id[1] in [FIdNumbers[0], FIdNumbers[1]]) and
 743       (Id[2] in WhiteSpaces);
 744   end;
 745 end;
 746
 747 { TPBMFileFormat }
 748
 749 procedure TPBMFileFormat.Define;
 750 begin
 751   inherited;
 752   FName := SPBMFormatName;
 753   FFeatures := [ffLoad];
 754   AddMasks(SPBMMasks);
 755   FIdNumbers := '14';
 756 end;
 757
 758 { TPGMFileFormat }
 759
 760 procedure TPGMFileFormat.Define;
 761 begin
 762   inherited;
 763   FName := SPGMFormatName;
 764   FSupportedFormats := PGMSupportedFormats;
 765   AddMasks(SPGMMasks);
 766   RegisterOption(ImagingPGMSaveBinary, @FSaveBinary);
 767   FIdNumbers := '25';
 768 end;
 769
 770 function TPGMFileFormat.SaveData(Handle: TImagingHandle;
 771   const Images: TDynImageDataArray; Index: Integer): Boolean;
 772 var
 773   MapInfo: TPortableMapInfo;
 774 begin
 775   FillChar(MapInfo, SizeOf(MapInfo), 0);
 776   if FSaveBinary then
 777     MapInfo.FormatId := FIdNumbers[1]
 778   else
 779     MapInfo.FormatId := FIdNumbers[0];
 780   MapInfo.Binary := FSaveBinary;
 781   Result := SaveDataInternal(Handle, Images, Index, MapInfo);
 782 end;
 783
 784 procedure TPGMFileFormat.ConvertToSupported(var Image: TImageData;
 785   const Info: TImageFormatInfo);
 786 var
 787   ConvFormat: TImageFormat;
 788 begin
 789   if Info.IsFloatingPoint then
 790     // All FP images go to 16bit
 791     ConvFormat :=  ifGray16
 792   else if Info.HasGrayChannel then
 793     // Grayscale will be 8 or 16 bit - depends on input's bitcount
 794     ConvFormat := IffFormat(Info.BytesPerPixel div Info.ChannelCount > 1,
 795       ifGray16, ifGray8)
 796   else if Info.BytesPerPixel > 4 then
 797     // Large bitcounts -> 16bit
 798     ConvFormat := ifGray16
 799   else
 800     // Rest of the formats -> 8bit
 801     ConvFormat := ifGray8;
 802
 803   ConvertImage(Image, ConvFormat);
 804 end;
 805
 806 { TPPMFileFormat }
 807
 808 procedure TPPMFileFormat.Define;
 809 begin
 810   inherited;
 811   FName := SPPMFormatName;
 812   FSupportedFormats := PPMSupportedFormats;
 813   AddMasks(SPPMMasks);
 814   RegisterOption(ImagingPPMSaveBinary, @FSaveBinary);
 815   FIdNumbers := '36';
 816 end;
 817
 818 function TPPMFileFormat.SaveData(Handle: TImagingHandle;
 819   const Images: TDynImageDataArray; Index: Integer): Boolean;
 820 var
 821   MapInfo: TPortableMapInfo;
 822 begin
 823   FillChar(MapInfo, SizeOf(MapInfo), 0);
 824   if FSaveBinary then
 825     MapInfo.FormatId := FIdNumbers[1]
 826   else
 827     MapInfo.FormatId := FIdNumbers[0];
 828   MapInfo.Binary := FSaveBinary;
 829   Result := SaveDataInternal(Handle, Images, Index, MapInfo);
 830 end;
 831
 832 procedure TPPMFileFormat.ConvertToSupported(var Image: TImageData;
 833   const Info: TImageFormatInfo);
 834 var
 835   ConvFormat: TImageFormat;
 836 begin
 837   if Info.IsFloatingPoint then
 838     // All FP images go to 48bit RGB
 839     ConvFormat :=  ifR16G16B16
 840   else if Info.HasGrayChannel then
 841     // Grayscale will be 24 or 48 bit RGB - depends on input's bitcount
 842     ConvFormat := IffFormat(Info.BytesPerPixel div Info.ChannelCount > 1,
 843       ifR16G16B16, ifR8G8B8)
 844   else if Info.BytesPerPixel > 4 then
 845     // Large bitcounts -> 48bit RGB
 846     ConvFormat := ifR16G16B16
 847   else
 848     // Rest of the formats -> 24bit RGB
 849     ConvFormat := ifR8G8B8;
 850
 851   ConvertImage(Image, ConvFormat);
 852 end;
 853
 854 { TPAMFileFormat }
 855
 856 procedure TPAMFileFormat.Define;
 857 begin
 858   inherited;
 859   FName := SPAMFormatName;
 860   FSupportedFormats := PAMSupportedFormats;
 861   AddMasks(SPAMMasks);
 862   FIdNumbers := '77';
 863 end;
 864
 865 function TPAMFileFormat.SaveData(Handle: TImagingHandle;
 866   const Images: TDynImageDataArray; Index: Integer): Boolean;
 867 var
 868   MapInfo: TPortableMapInfo;
 869 begin
 870   FillChar(MapInfo, SizeOf(MapInfo), 0);
 871   MapInfo.FormatId := FIdNumbers[0];
 872   MapInfo.Binary := True;
 873   MapInfo.HasPAMHeader := True;
 874   Result := SaveDataInternal(Handle, Images, Index, MapInfo);
 875 end;
 876
 877 procedure TPAMFileFormat.ConvertToSupported(var Image: TImageData;
 878   const Info: TImageFormatInfo);
 879 var
 880   ConvFormat: TImageFormat;
 881 begin
 882   if Info.IsFloatingPoint then
 883     ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16R16G16B16, ifR16G16B16)
 884   else if Info.HasGrayChannel then
 885     ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16Gray16, ifGray16)
 886   else
 887   begin
 888     if Info.BytesPerPixel <= 4 then
 889       ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8R8G8B8, ifR8G8B8)
 890     else
 891       ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16R16G16B16, ifR16G16B16);
 892   end;
 893   ConvertImage(Image, ConvFormat);
 894 end;
 895
 896 { TPFMFileFormat }
 897
 898 procedure TPFMFileFormat.Define;
 899 begin
 900   inherited;
 901   FName := SPFMFormatName;
 902   AddMasks(SPFMMasks);
 903   FIdNumbers := 'Ff';
 904   FSupportedFormats := PFMSupportedFormats;
 905 end;
 906
 907 function TPFMFileFormat.SaveData(Handle: TImagingHandle;
 908   const Images: TDynImageDataArray; Index: Integer): Boolean;
 909 var
 910   Info: TImageFormatInfo;
 911   MapInfo: TPortableMapInfo;
 912 begin
 913   FillChar(MapInfo, SizeOf(MapInfo), 0);
 914   Info := GetFormatInfo(Images[Index].Format);
 915
 916   if (Info.ChannelCount > 1) or Info.IsIndexed then
 917     MapInfo.TupleType := ttRGBFP
 918   else
 919     MapInfo.TupleType := ttGrayScaleFP;
 920
 921   if MapInfo.TupleType = ttGrayScaleFP then
 922     MapInfo.FormatId := FIdNumbers[1]
 923   else
 924     MapInfo.FormatId := FIdNumbers[0];
 925
 926   MapInfo.Binary := True;
 927   Result := SaveDataInternal(Handle, Images, Index, MapInfo);
 928 end;
 929
 930 procedure TPFMFileFormat.ConvertToSupported(var Image: TImageData;
 931   const Info: TImageFormatInfo);
 932 begin
 933   if (Info.ChannelCount > 1) or Info.IsIndexed then
 934     ConvertImage(Image, ifB32G32R32F)
 935   else
 936     ConvertImage(Image, ifR32F);
 937 end;
 938
 939 initialization
 940   RegisterImageFileFormat(TPBMFileFormat);
 941   RegisterImageFileFormat(TPGMFileFormat);
 942   RegisterImageFileFormat(TPPMFileFormat);
 943   RegisterImageFileFormat(TPAMFileFormat);
 944   RegisterImageFileFormat(TPFMFileFormat);
 945
 946 {
 947   File Notes:
 948
 949   -- TODOS ----------------------------------------------------
 950     - nothing now
 951
 952   -- 0.77.1 Changes/Bug Fixes -----------------------------------
 953     - Native RGB floating point format of PFM is now supported by Imaging
 954       so we use it now for saving instead of A32B32G32B32.
 955     - String to float formatting changes (don't change global settings).
 956
 957   -- 0.26.3 Changes/Bug Fixes -----------------------------------
 958     - Fixed D2009 Unicode related bug in PNM saving.
 959
 960   -- 0.24.3 Changes/Bug Fixes -----------------------------------
 961     - Improved compatibility of 16bit/component image loading.
 962     - Changes for better thread safety.
 963
 964   -- 0.21 Changes/Bug Fixes -----------------------------------
 965     - Made modifications to ASCII PNM loading to be more "stream-safe".
 966     - Fixed bug: indexed images saved as grayscale in PFM.
 967     - Changed converting to supported formats little bit.
 968     - Added scaling of channel values (non-FP and non-mono images) according
 969       to MaxVal.
 970     - Added buffering to loading of PNM files. More than 10x faster now
 971       for text files.
 972     - Added saving support to PGM, PPM, PAM, and PFM format.
 973     - Added PFM file format.
 974     - Initial version created.
 975 }
 976
 977 end.