src/lib/vampimg/ImagingTarga.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 Targa images.}
  29 unit ImagingTarga;
  30
  31 {$I ImagingOptions.inc}
  32
  33 interface
  34
  35 uses
  36   ImagingTypes, Imaging, ImagingFormats, ImagingUtility;
  37
  38 type
  39   { Class for loading and saving Truevision Targa images.
  40     It can load/save 8bit indexed or grayscale, 16 bit RGB or grayscale,
  41     24 bit RGB and 32 bit ARGB images with or without RLE compression.}
  42   TTargaFileFormat = class(TImageFileFormat)
  43   protected
  44     FUseRLE: LongBool;
  45     procedure Define; override;
  46     function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
  47       OnlyFirstLevel: Boolean): Boolean; override;
  48     function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
  49       Index: LongInt): Boolean; override;
  50     procedure ConvertToSupported(var Image: TImageData;
  51       const Info: TImageFormatInfo); override;
  52   public
  53     function TestFormat(Handle: TImagingHandle): Boolean; override;
  54   published
  55     { Controls that RLE compression is used during saving. Accessible trough
  56       ImagingTargaRLE option.}
  57     property UseRLE: LongBool read FUseRLE write FUseRLE;
  58   end;
  59
  60 implementation
  61
  62 const
  63   STargaFormatName = 'Truevision Targa Image';
  64   STargaMasks      = '*.tga';
  65   TargaSupportedFormats: TImageFormats = [ifIndex8, ifGray8, ifA1R5G5B5,
  66     ifR8G8B8, ifA8R8G8B8];
  67   TargaDefaultRLE = False;
  68
  69 const
  70   STargaSignature = 'TRUEVISION-XFILE';
  71
  72 type
  73   { Targa file header.}
  74   TTargaHeader = packed record
  75     IDLength: Byte;
  76     ColorMapType: Byte;
  77     ImageType: Byte;
  78     ColorMapOff: Word;
  79     ColorMapLength: Word;
  80     ColorEntrySize: Byte;
  81     XOrg: SmallInt;
  82     YOrg: SmallInt;
  83     Width: SmallInt;
  84     Height: SmallInt;
  85     PixelSize: Byte;
  86     Desc: Byte;
  87   end;
  88
  89   { Footer at the end of TGA file.}
  90   TTargaFooter = packed record
  91     ExtOff: LongWord;             // Extension Area Offset
  92     DevDirOff: LongWord;          // Developer Directory Offset
  93     Signature: TChar16;           // TRUEVISION-XFILE
  94     Reserved: Byte;               // ASCII period '.'
  95     NullChar: Byte;               // 0
  96   end;
  97
  98
  99 { TTargaFileFormat class implementation }
 100
 101 procedure TTargaFileFormat.Define;
 102 begin
 103   inherited;
 104   FName := STargaFormatName;
 105   FFeatures := [ffLoad, ffSave];
 106   FSupportedFormats := TargaSupportedFormats;
 107
 108   FUseRLE := TargaDefaultRLE;
 109
 110   AddMasks(STargaMasks);
 111   RegisterOption(ImagingTargaRLE, @FUseRLE);
 112 end;
 113
 114 function TTargaFileFormat.LoadData(Handle: TImagingHandle;
 115   var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
 116 var
 117   Hdr: TTargaHeader;
 118   Foo: TTargaFooter;
 119   FooterFound, ExtFound: Boolean;
 120   I, PSize, PalSize: LongWord;
 121   Pal: Pointer;
 122   FmtInfo: TImageFormatInfo;
 123   WordValue: Word;
 124
 125   procedure LoadRLE;
 126   var
 127     I, CPixel, Cnt: LongInt;
 128     Bpp, Rle: Byte;
 129     Buffer, Dest, Src: PByte;
 130     BufSize: LongInt;
 131   begin
 132     with GetIO, Images[0] do
 133     begin
 134       // Alocates buffer large enough to hold the worst case
 135       // RLE compressed data and reads then from input
 136       BufSize := Width * Height * FmtInfo.BytesPerPixel;
 137       BufSize := BufSize + BufSize div 2 + 1;
 138       GetMem(Buffer, BufSize);
 139       Src := Buffer;
 140       Dest := Bits;
 141       BufSize := Read(Handle, Buffer, BufSize);
 142
 143       Cnt := Width * Height;
 144       Bpp := FmtInfo.BytesPerPixel;
 145       CPixel := 0;
 146       while CPixel < Cnt do
 147       begin
 148         Rle := Src^;
 149         Inc(Src);
 150         if Rle < 128 then
 151         begin
 152           // Process uncompressed pixel
 153           Rle := Rle + 1;
 154           CPixel := CPixel + Rle;
 155           for I := 0 to Rle - 1 do
 156           begin
 157             // Copy pixel from src to dest
 158             case Bpp of
 159               1: Dest^ := Src^;
 160               2: PWord(Dest)^ := PWord(Src)^;
 161               3: PColor24Rec(Dest)^ := PColor24Rec(Src)^;
 162               4: PLongWord(Dest)^ := PLongWord(Src)^;
 163             end;
 164             Inc(Src, Bpp);
 165             Inc(Dest, Bpp);
 166           end;
 167         end
 168         else
 169         begin
 170           // Process compressed pixels
 171           Rle := Rle - 127;
 172           CPixel := CPixel + Rle;
 173           // Copy one pixel from src to dest (many times there)
 174           for I := 0 to Rle - 1 do
 175           begin
 176             case Bpp of
 177               1: Dest^ := Src^;
 178               2: PWord(Dest)^ := PWord(Src)^;
 179               3: PColor24Rec(Dest)^ := PColor24Rec(Src)^;
 180               4: PLongWord(Dest)^ := PLongWord(Src)^;
 181             end;
 182             Inc(Dest, Bpp);
 183           end;
 184           Inc(Src, Bpp);
 185         end;
 186       end;
 187       // set position in source to real end of compressed data
 188       Seek(Handle, -(BufSize - LongInt(LongWord(Src) - LongWord(Buffer))),
 189         smFromCurrent);
 190       FreeMem(Buffer);
 191     end;
 192   end;
 193
 194 begin
 195   SetLength(Images, 1);
 196   with GetIO, Images[0] do
 197   begin
 198     // Read targa header
 199     Read(Handle, @Hdr, SizeOf(Hdr));
 200     // Skip image ID info
 201     Seek(Handle, Hdr.IDLength, smFromCurrent);
 202     // Determine image format
 203     Format := ifUnknown;
 204     case Hdr.ImageType of
 205       1, 9: Format := ifIndex8;
 206       2, 10: case Hdr.PixelSize of
 207           15: Format := ifX1R5G5B5;
 208           16: Format := ifA1R5G5B5;
 209           24: Format := ifR8G8B8;
 210           32: Format := ifA8R8G8B8;
 211         end;
 212       3, 11: Format := ifGray8;
 213     end;
 214     // Format was not assigned by previous testing (it should be in
 215     // well formed targas), so formats which reflects bit dept are selected
 216     if Format = ifUnknown then
 217       case Hdr.PixelSize of
 218         8: Format := ifGray8;
 219         15: Format := ifX1R5G5B5;
 220         16: Format := ifA1R5G5B5;
 221         24: Format := ifR8G8B8;
 222         32: Format := ifA8R8G8B8;
 223       end;
 224     NewImage(Hdr.Width, Hdr.Height, Format, Images[0]);
 225     FmtInfo := GetFormatInfo(Format);
 226
 227     if (Hdr.ColorMapType = 1) and (Hdr.ImageType in [1, 9]) then
 228     begin
 229       // Read palette
 230       PSize := Hdr.ColorMapLength * (Hdr.ColorEntrySize shr 3);
 231       GetMem(Pal, PSize);
 232       try
 233         Read(Handle, Pal, PSize);
 234         // Process palette
 235         PalSize := Iff(Hdr.ColorMapLength > FmtInfo.PaletteEntries,
 236           FmtInfo.PaletteEntries, Hdr.ColorMapLength);
 237         for I := 0 to PalSize - 1 do
 238           case Hdr.ColorEntrySize of
 239             24:
 240               with Palette[I] do
 241               begin
 242                 A := $FF;
 243                 R := PPalette24(Pal)[I].R;
 244                 G := PPalette24(Pal)[I].G;
 245                 B := PPalette24(Pal)[I].B;
 246               end;
 247             // I've never seen tga with these palettes so they are untested
 248             16:
 249               with Palette[I] do
 250               begin
 251                 A := (PWordArray(Pal)[I] and $8000) shr 12;
 252                 R := (PWordArray(Pal)[I] and $FC00) shr 7;
 253                 G := (PWordArray(Pal)[I] and $03E0) shr 2;
 254                 B := (PWordArray(Pal)[I] and $001F) shl 3;
 255               end;
 256             32:
 257               with Palette[I] do
 258               begin
 259                 A := PPalette32(Pal)[I].A;
 260                 R := PPalette32(Pal)[I].R;
 261                 G := PPalette32(Pal)[I].G;
 262                 B := PPalette32(Pal)[I].B;
 263               end;
 264           end;
 265       finally
 266         FreeMemNil(Pal);
 267       end;
 268     end;
 269
 270     case Hdr.ImageType of
 271       0, 1, 2, 3:
 272         // Load uncompressed mode images
 273         Read(Handle, Bits, Size);
 274       9, 10, 11:
 275         // Load RLE compressed mode images
 276         LoadRLE;
 277     end;
 278
 279     // Check if there is alpha channel present in A1R5GB5 images, if it is not
 280     // change format to X1R5G5B5
 281     if Format = ifA1R5G5B5 then
 282     begin
 283       if not Has16BitImageAlpha(Width * Height, Bits) then
 284         Format := ifX1R5G5B5;
 285     end;
 286
 287     // We must find true end of file and set input' position to it
 288     // paint programs appends extra info at the end of Targas
 289     // some of them multiple times (PSP Pro 8)
 290     repeat
 291       ExtFound := False;
 292       FooterFound := False;
 293
 294       if Read(Handle, @WordValue, 2) = 2 then
 295       begin
 296         // 495 = size of Extension Area
 297         if WordValue = 495 then
 298         begin
 299           Seek(Handle, 493, smFromCurrent);
 300           ExtFound := True;
 301         end
 302         else
 303           Seek(Handle, -2, smFromCurrent);
 304       end;
 305
 306       if Read(Handle, @Foo, SizeOf(Foo)) = SizeOf(Foo) then
 307       begin
 308         if Foo.Signature = STargaSignature then
 309           FooterFound := True
 310         else
 311           Seek(Handle, -SizeOf(Foo), smFromCurrent);
 312       end;
 313     until (not ExtFound) and (not FooterFound);
 314
 315     // Some editors save targas flipped
 316     if Hdr.Desc < 31 then
 317       FlipImage(Images[0]);
 318
 319     Result := True;
 320   end;
 321 end;
 322
 323 function TTargaFileFormat.SaveData(Handle: TImagingHandle;
 324   const Images: TDynImageDataArray; Index: LongInt): Boolean;
 325 var
 326   I: LongInt;
 327   Hdr: TTargaHeader;
 328   FmtInfo: TImageFormatInfo;
 329   Pal: PPalette24;
 330   ImageToSave: TImageData;
 331   MustBeFreed: Boolean;
 332
 333   procedure SaveRLE;
 334   var
 335     Dest: PByte;
 336     WidthBytes, Written, I, Total, DestSize: LongInt;
 337
 338     function CountDiff(Data: PByte; Bpp, PixelCount: Longint): LongInt;
 339     var
 340       Pixel: LongWord;
 341       NextPixel: LongWord;
 342       N: LongInt;
 343     begin
 344       N := 0;
 345       Pixel := 0;
 346       NextPixel := 0;
 347       if PixelCount = 1 then
 348       begin
 349         Result := PixelCount;
 350         Exit;
 351       end;
 352       case Bpp of
 353         1: Pixel := Data^;
 354         2: Pixel := PWord(Data)^;
 355         3: PColor24Rec(@Pixel)^ := PColor24Rec(Data)^;
 356         4: Pixel := PLongWord(Data)^;
 357       end;
 358       while PixelCount > 1 do
 359       begin
 360         Inc(Data, Bpp);
 361         case Bpp of
 362           1: NextPixel := Data^;
 363           2: NextPixel := PWord(Data)^;
 364           3: PColor24Rec(@NextPixel)^ := PColor24Rec(Data)^;
 365           4: NextPixel := PLongWord(Data)^;
 366         end;
 367         if NextPixel = Pixel then
 368           Break;
 369         Pixel := NextPixel;
 370         N := N + 1;
 371         PixelCount := PixelCount - 1;
 372       end;
 373       if NextPixel = Pixel then
 374         Result := N
 375       else
 376         Result := N + 1;
 377     end;
 378
 379     function CountSame(Data: PByte; Bpp, PixelCount: LongInt): LongInt;
 380     var
 381       Pixel: LongWord;
 382       NextPixel: LongWord;
 383       N: LongInt;
 384     begin
 385       N := 1;
 386       Pixel := 0;
 387       NextPixel := 0;
 388       case Bpp of
 389         1: Pixel := Data^;
 390         2: Pixel := PWord(Data)^;
 391         3: PColor24Rec(@Pixel)^ := PColor24Rec(Data)^;
 392         4: Pixel := PLongWord(Data)^;
 393       end;
 394       PixelCount := PixelCount - 1;
 395       while PixelCount > 0 do
 396       begin
 397         Inc(Data, Bpp);
 398         case Bpp of
 399           1: NextPixel := Data^;
 400           2: NextPixel := PWord(Data)^;
 401           3: PColor24Rec(@NextPixel)^ := PColor24Rec(Data)^;
 402           4: NextPixel := PLongWord(Data)^;
 403         end;
 404         if NextPixel <> Pixel then
 405           Break;
 406         N := N + 1;
 407         PixelCount := PixelCount - 1;
 408       end;
 409       Result := N;
 410     end;
 411
 412     procedure RleCompressLine(Data: PByte; PixelCount, Bpp: LongInt; Dest:
 413       PByte; var Written: LongInt);
 414     const
 415       MaxRun = 128;
 416     var
 417       DiffCount: LongInt;
 418       SameCount: LongInt;
 419       RleBufSize: LongInt;
 420     begin
 421       RleBufSize := 0;
 422       while PixelCount > 0 do
 423       begin
 424         DiffCount := CountDiff(Data, Bpp, PixelCount);
 425         SameCount := CountSame(Data, Bpp, PixelCount);
 426         if (DiffCount > MaxRun) then
 427           DiffCount := MaxRun;
 428         if (SameCount > MaxRun) then
 429           SameCount := MaxRun;
 430         if (DiffCount > 0) then
 431         begin
 432           Dest^ := Byte(DiffCount - 1);
 433           Inc(Dest);
 434           PixelCount := PixelCount - DiffCount;
 435           RleBufSize := RleBufSize + (DiffCount * Bpp) + 1;
 436           Move(Data^, Dest^, DiffCount * Bpp);
 437           Inc(Data, DiffCount * Bpp);
 438           Inc(Dest, DiffCount * Bpp);
 439         end;
 440         if SameCount > 1 then
 441         begin
 442           Dest^ := Byte((SameCount - 1) or $80);
 443           Inc(Dest);
 444           PixelCount := PixelCount - SameCount;
 445           RleBufSize := RleBufSize + Bpp + 1;
 446           Inc(Data, (SameCount - 1) * Bpp);
 447           case Bpp of
 448             1: Dest^ := Data^;
 449             2: PWord(Dest)^ := PWord(Data)^;
 450             3: PColor24Rec(Dest)^ := PColor24Rec(Data)^;
 451             4: PLongWord(Dest)^ := PLongWord(Data)^;
 452           end;
 453           Inc(Data, Bpp);
 454           Inc(Dest, Bpp);
 455         end;
 456       end;
 457       Written := RleBufSize;
 458     end;
 459
 460   begin
 461     with ImageToSave do
 462     begin
 463       // Allocate enough space to hold the worst case compression
 464       // result and then compress source's scanlines
 465       WidthBytes := Width * FmtInfo.BytesPerPixel;
 466       DestSize := WidthBytes * Height;
 467       DestSize := DestSize + DestSize div 2 + 1;
 468       GetMem(Dest, DestSize);
 469       Total := 0;
 470       try
 471         for I := 0 to Height - 1 do
 472         begin
 473           RleCompressLine(@PByteArray(Bits)[I * WidthBytes], Width,
 474             FmtInfo.BytesPerPixel, @PByteArray(Dest)[Total], Written);
 475           Total := Total + Written;
 476         end;
 477         GetIO.Write(Handle, Dest, Total);
 478       finally
 479         FreeMem(Dest);
 480       end;
 481     end;
 482   end;
 483
 484 begin
 485   Result := False;
 486   if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
 487   with GetIO, ImageToSave do
 488   try
 489     FmtInfo := GetFormatInfo(Format);
 490     // Fill targa header
 491     FillChar(Hdr, SizeOf(Hdr), 0);
 492     Hdr.IDLength := 0;
 493     Hdr.ColorMapType := Iff(FmtInfo.PaletteEntries > 0, 1, 0);
 494     Hdr.Width := Width;
 495     Hdr.Height := Height;
 496     Hdr.PixelSize := FmtInfo.BytesPerPixel * 8;
 497     Hdr.ColorMapLength := FmtInfo.PaletteEntries;
 498     Hdr.ColorEntrySize := Iff(FmtInfo.PaletteEntries > 0, 24, 0);
 499     Hdr.ColorMapOff := 0;
 500     // This indicates that targa is stored in top-left format
 501     // as our images -> no flipping is needed.
 502     Hdr.Desc := 32;
 503     // Set alpha channel size in descriptor (mostly ignored by other software though)
 504     if Format = ifA8R8G8B8 then
 505       Hdr.Desc := Hdr.Desc or 8
 506     else if Format = ifA1R5G5B5 then
 507       Hdr.Desc := Hdr.Desc or 1;
 508
 509     // Choose image type
 510     if FmtInfo.IsIndexed then
 511       Hdr.ImageType := Iff(FUseRLE, 9, 1)
 512     else
 513       if FmtInfo.HasGrayChannel then
 514         Hdr.ImageType := Iff(FUseRLE, 11, 3)
 515       else
 516         Hdr.ImageType := Iff(FUseRLE, 10, 2);
 517
 518     Write(Handle, @Hdr, SizeOf(Hdr));
 519
 520     // Write palette
 521     if FmtInfo.PaletteEntries > 0 then
 522     begin
 523       GetMem(Pal, FmtInfo.PaletteEntries * SizeOf(TColor24Rec));
 524       try
 525         for I := 0 to FmtInfo.PaletteEntries - 1 do
 526           with Pal[I] do
 527           begin
 528             R := Palette[I].R;
 529             G := Palette[I].G;
 530             B := Palette[I].B;
 531           end;
 532         Write(Handle, Pal, FmtInfo.PaletteEntries * SizeOf(TColor24Rec));
 533       finally
 534         FreeMemNil(Pal);
 535       end;
 536     end;
 537
 538     if FUseRLE then
 539       // Save rle compressed mode images
 540       SaveRLE
 541     else
 542       // Save uncompressed mode images
 543       Write(Handle, Bits, Size);
 544
 545     Result := True;
 546   finally
 547     if MustBeFreed then
 548       FreeImage(ImageToSave);
 549   end;
 550 end;
 551
 552 procedure TTargaFileFormat.ConvertToSupported(var Image: TImageData;
 553   const Info: TImageFormatInfo);
 554 var
 555   ConvFormat: TImageFormat;
 556 begin
 557   if Info.HasGrayChannel then
 558     // Convert all grayscale images to Gray8 (preserve alpha of AxGrayx formats)
 559     ConvFormat := IffFormat(not Info.HasAlphaChannel, ifGray8, ifA8R8G8B8)
 560   else if Info.IsIndexed then
 561     // Convert all indexed images to Index8
 562     ConvFormat := ifIndex8
 563   else if Info.HasAlphaChannel then
 564     // Convert images with alpha channel to A8R8G8B8
 565     ConvFormat := ifA8R8G8B8
 566   else if Info.UsePixelFormat then
 567     // Convert 16bit images (without alpha channel) to A1R5G5B5
 568     ConvFormat := ifA1R5G5B5
 569   else
 570     // Convert all other formats to R8G8B8
 571     ConvFormat := ifR8G8B8;
 572
 573   ConvertImage(Image, ConvFormat);
 574 end;
 575
 576 function TTargaFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
 577 var
 578   Hdr: TTargaHeader;
 579   ReadCount: LongInt;
 580 begin
 581   Result := False;
 582   if Handle <> nil then
 583   begin
 584     ReadCount := GetIO.Read(Handle, @Hdr, SizeOf(Hdr));
 585     GetIO.Seek(Handle, -ReadCount, smFromCurrent);
 586     Result := (ReadCount >= SizeOf(Hdr)) and
 587       (Hdr.ImageType in [0, 1, 2, 3, 9, 10, 11]) and
 588       (Hdr.PixelSize in [1, 8, 15, 16, 24, 32]) and
 589       (Hdr.ColorEntrySize in [0, 16, 24, 32]);
 590   end;
 591 end;
 592
 593 initialization
 594   RegisterImageFileFormat(TTargaFileFormat);
 595
 596 {
 597   File Notes:
 598
 599  -- TODOS ----------------------------------------------------
 600     - nothing now
 601
 602   -- 0.21 Changes/Bug Fixes -----------------------------------
 603     - MakeCompatible method moved to base class, put ConvertToSupported here.
 604       GetSupportedFormats removed, it is now set in constructor.
 605     - Made public properties for options registered to SetOption/GetOption
 606       functions.
 607     - Changed extensions to filename masks.
 608     - Changed SaveData, LoadData, and MakeCompatible methods according
 609       to changes in base class in Imaging unit.
 610
 611   -- 0.17 Changes/Bug Fixes -----------------------------------
 612     - 16 bit images are usually without alpha but some has alpha
 613       channel and there is no indication of it - so I have added
 614       a check: if all pixels of image are with alpha = 0 image is treated
 615       as X1R5G5B5 otherwise as A1R5G5B5
 616     - fixed problems with some nonstandard 15 bit images
 617 }
 618
 619 end.