src/lib/vampimg/ImagingTarga.pas

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