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     Hdr.ColorMapOff := LEtoN(Hdr.ColorMapOff);
 201     Hdr.ColorMapLength := LEtoN(Hdr.ColorMapLength);
 202     Hdr.XOrg := LEtoN(Hdr.XOrg);
 203     Hdr.YOrg := LEtoN(Hdr.YOrg);
 204     Hdr.Width := LEtoN(Hdr.Width);
 205     Hdr.Height := LEtoN(Hdr.Height);
 206     // Skip image ID info
 207     Seek(Handle, Hdr.IDLength, smFromCurrent);
 208     // Determine image format
 209     Format := ifUnknown;
 210     case Hdr.ImageType of
 211       1, 9: Format := ifIndex8;
 212       2, 10: case Hdr.PixelSize of
 213           15: Format := ifX1R5G5B5;
 214           16: Format := ifA1R5G5B5;
 215           24: Format := ifR8G8B8;
 216           32: Format := ifA8R8G8B8;
 217         end;
 218       3, 11: Format := ifGray8;
 219     end;
 220     // Format was not assigned by previous testing (it should be in
 221     // well formed targas), so formats which reflects bit dept are selected
 222     if Format = ifUnknown then
 223       case Hdr.PixelSize of
 224         8: Format := ifGray8;
 225         15: Format := ifX1R5G5B5;
 226         16: Format := ifA1R5G5B5;
 227         24: Format := ifR8G8B8;
 228         32: Format := ifA8R8G8B8;
 229       end;
 230     NewImage(Hdr.Width, Hdr.Height, Format, Images[0]);
 231     FmtInfo := GetFormatInfo(Format);
 232
 233     if (Hdr.ColorMapType = 1) and (Hdr.ImageType in [1, 9]) then
 234     begin
 235       // Read palette
 236       PSize := Hdr.ColorMapLength * (Hdr.ColorEntrySize shr 3);
 237       GetMem(Pal, PSize);
 238       try
 239         Read(Handle, Pal, PSize);
 240         // Process palette
 241         PalSize := Iff(Hdr.ColorMapLength > FmtInfo.PaletteEntries,
 242           FmtInfo.PaletteEntries, Hdr.ColorMapLength);
 243         for I := 0 to PalSize - 1 do
 244           case Hdr.ColorEntrySize of
 245             24:
 246               with Palette[I] do
 247               begin
 248                 A := $FF;
 249                 R := PPalette24(Pal)[I].R;
 250                 G := PPalette24(Pal)[I].G;
 251                 B := PPalette24(Pal)[I].B;
 252               end;
 253             // I've never seen tga with these palettes so they are untested
 254             16:
 255               with Palette[I] do
 256               begin
 257                 A := (PWordArray(Pal)[I] and $8000) shr 12;
 258                 R := (PWordArray(Pal)[I] and $FC00) shr 7;
 259                 G := (PWordArray(Pal)[I] and $03E0) shr 2;
 260                 B := (PWordArray(Pal)[I] and $001F) shl 3;
 261               end;
 262             32:
 263               with Palette[I] do
 264               begin
 265                 A := PPalette32(Pal)[I].A;
 266                 R := PPalette32(Pal)[I].R;
 267                 G := PPalette32(Pal)[I].G;
 268                 B := PPalette32(Pal)[I].B;
 269               end;
 270           end;
 271       finally
 272         FreeMemNil(Pal);
 273       end;
 274     end;
 275
 276     case Hdr.ImageType of
 277       0, 1, 2, 3:
 278         // Load uncompressed mode images
 279         Read(Handle, Bits, Size);
 280       9, 10, 11:
 281         // Load RLE compressed mode images
 282         LoadRLE;
 283     end;
 284
 285     // Check if there is alpha channel present in A1R5GB5 images, if it is not
 286     // change format to X1R5G5B5
 287     if Format = ifA1R5G5B5 then
 288     begin
 289       if not Has16BitImageAlpha(Width * Height, Bits) then
 290         Format := ifX1R5G5B5;
 291     end;
 292
 293     // We must find true end of file and set input' position to it
 294     // paint programs appends extra info at the end of Targas
 295     // some of them multiple times (PSP Pro 8)
 296     repeat
 297       ExtFound := False;
 298       FooterFound := False;
 299
 300       if Read(Handle, @WordValue, 2) = 2 then
 301       begin
 302         // 495 = size of Extension Area
 303         if WordValue = 495 then
 304         begin
 305           Seek(Handle, 493, smFromCurrent);
 306           ExtFound := True;
 307         end
 308         else
 309           Seek(Handle, -2, smFromCurrent);
 310       end;
 311
 312       if Read(Handle, @Foo, SizeOf(Foo)) = SizeOf(Foo) then
 313       begin
 314         if Foo.Signature = STargaSignature then
 315           FooterFound := True
 316         else
 317           Seek(Handle, -SizeOf(Foo), smFromCurrent);
 318       end;
 319     until (not ExtFound) and (not FooterFound);
 320
 321     // Some editors save targas flipped
 322     if Hdr.Desc < 31 then
 323       FlipImage(Images[0]);
 324
 325     Result := True;
 326   end;
 327 end;
 328
 329 function TTargaFileFormat.SaveData(Handle: TImagingHandle;
 330   const Images: TDynImageDataArray; Index: LongInt): Boolean;
 331 var
 332   I: LongInt;
 333   Hdr: TTargaHeader;
 334   FmtInfo: TImageFormatInfo;
 335   Pal: PPalette24;
 336   ImageToSave: TImageData;
 337   MustBeFreed: Boolean;
 338
 339   procedure SaveRLE;
 340   var
 341     Dest: PByte;
 342     WidthBytes, Written, I, Total, DestSize: LongInt;
 343
 344     function CountDiff(Data: PByte; Bpp, PixelCount: Longint): LongInt;
 345     var
 346       Pixel: LongWord;
 347       NextPixel: LongWord;
 348       N: LongInt;
 349     begin
 350       N := 0;
 351       Pixel := 0;
 352       NextPixel := 0;
 353       if PixelCount = 1 then
 354       begin
 355         Result := PixelCount;
 356         Exit;
 357       end;
 358       case Bpp of
 359         1: Pixel := Data^;
 360         2: Pixel := PWord(Data)^;
 361         3: PColor24Rec(@Pixel)^ := PColor24Rec(Data)^;
 362         4: Pixel := PLongWord(Data)^;
 363       end;
 364       while PixelCount > 1 do
 365       begin
 366         Inc(Data, Bpp);
 367         case Bpp of
 368           1: NextPixel := Data^;
 369           2: NextPixel := PWord(Data)^;
 370           3: PColor24Rec(@NextPixel)^ := PColor24Rec(Data)^;
 371           4: NextPixel := PLongWord(Data)^;
 372         end;
 373         if NextPixel = Pixel then
 374           Break;
 375         Pixel := NextPixel;
 376         N := N + 1;
 377         PixelCount := PixelCount - 1;
 378       end;
 379       if NextPixel = Pixel then
 380         Result := N
 381       else
 382         Result := N + 1;
 383     end;
 384
 385     function CountSame(Data: PByte; Bpp, PixelCount: LongInt): LongInt;
 386     var
 387       Pixel: LongWord;
 388       NextPixel: LongWord;
 389       N: LongInt;
 390     begin
 391       N := 1;
 392       Pixel := 0;
 393       NextPixel := 0;
 394       case Bpp of
 395         1: Pixel := Data^;
 396         2: Pixel := PWord(Data)^;
 397         3: PColor24Rec(@Pixel)^ := PColor24Rec(Data)^;
 398         4: Pixel := PLongWord(Data)^;
 399       end;
 400       PixelCount := PixelCount - 1;
 401       while PixelCount > 0 do
 402       begin
 403         Inc(Data, Bpp);
 404         case Bpp of
 405           1: NextPixel := Data^;
 406           2: NextPixel := PWord(Data)^;
 407           3: PColor24Rec(@NextPixel)^ := PColor24Rec(Data)^;
 408           4: NextPixel := PLongWord(Data)^;
 409         end;
 410         if NextPixel <> Pixel then
 411           Break;
 412         N := N + 1;
 413         PixelCount := PixelCount - 1;
 414       end;
 415       Result := N;
 416     end;
 417
 418     procedure RleCompressLine(Data: PByte; PixelCount, Bpp: LongInt; Dest:
 419       PByte; var Written: LongInt);
 420     const
 421       MaxRun = 128;
 422     var
 423       DiffCount: LongInt;
 424       SameCount: LongInt;
 425       RleBufSize: LongInt;
 426     begin
 427       RleBufSize := 0;
 428       while PixelCount > 0 do
 429       begin
 430         DiffCount := CountDiff(Data, Bpp, PixelCount);
 431         SameCount := CountSame(Data, Bpp, PixelCount);
 432         if (DiffCount > MaxRun) then
 433           DiffCount := MaxRun;
 434         if (SameCount > MaxRun) then
 435           SameCount := MaxRun;
 436         if (DiffCount > 0) then
 437         begin
 438           Dest^ := Byte(DiffCount - 1);
 439           Inc(Dest);
 440           PixelCount := PixelCount - DiffCount;
 441           RleBufSize := RleBufSize + (DiffCount * Bpp) + 1;
 442           Move(Data^, Dest^, DiffCount * Bpp);
 443           Inc(Data, DiffCount * Bpp);
 444           Inc(Dest, DiffCount * Bpp);
 445         end;
 446         if SameCount > 1 then
 447         begin
 448           Dest^ := Byte((SameCount - 1) or $80);
 449           Inc(Dest);
 450           PixelCount := PixelCount - SameCount;
 451           RleBufSize := RleBufSize + Bpp + 1;
 452           Inc(Data, (SameCount - 1) * Bpp);
 453           case Bpp of
 454             1: Dest^ := Data^;
 455             2: PWord(Dest)^ := PWord(Data)^;
 456             3: PColor24Rec(Dest)^ := PColor24Rec(Data)^;
 457             4: PLongWord(Dest)^ := PLongWord(Data)^;
 458           end;
 459           Inc(Data, Bpp);
 460           Inc(Dest, Bpp);
 461         end;
 462       end;
 463       Written := RleBufSize;
 464     end;
 465
 466   begin
 467     with ImageToSave do
 468     begin
 469       // Allocate enough space to hold the worst case compression
 470       // result and then compress source's scanlines
 471       WidthBytes := Width * FmtInfo.BytesPerPixel;
 472       DestSize := WidthBytes * Height;
 473       DestSize := DestSize + DestSize div 2 + 1;
 474       GetMem(Dest, DestSize);
 475       Total := 0;
 476       try
 477         for I := 0 to Height - 1 do
 478         begin
 479           RleCompressLine(@PByteArray(Bits)[I * WidthBytes], Width,
 480             FmtInfo.BytesPerPixel, @PByteArray(Dest)[Total], Written);
 481           Total := Total + Written;
 482         end;
 483         GetIO.Write(Handle, Dest, Total);
 484       finally
 485         FreeMem(Dest);
 486       end;
 487     end;
 488   end;
 489
 490 begin
 491   Result := False;
 492   if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
 493   with GetIO, ImageToSave do
 494   try
 495     FmtInfo := GetFormatInfo(Format);
 496     // Fill targa header
 497     FillChar(Hdr, SizeOf(Hdr), 0);
 498     Hdr.IDLength := 0;
 499     Hdr.ColorMapType := Iff(FmtInfo.PaletteEntries > 0, 1, 0);
 500     Hdr.Width := Width;
 501     Hdr.Height := Height;
 502     Hdr.PixelSize := FmtInfo.BytesPerPixel * 8;
 503     Hdr.ColorMapLength := FmtInfo.PaletteEntries;
 504     Hdr.ColorEntrySize := Iff(FmtInfo.PaletteEntries > 0, 24, 0);
 505     Hdr.ColorMapOff := 0;
 506     // This indicates that targa is stored in top-left format
 507     // as our images -> no flipping is needed.
 508     Hdr.Desc := 32;
 509     // Set alpha channel size in descriptor (mostly ignored by other software though)
 510     if Format = ifA8R8G8B8 then
 511       Hdr.Desc := Hdr.Desc or 8
 512     else if Format = ifA1R5G5B5 then
 513       Hdr.Desc := Hdr.Desc or 1;
 514
 515     // Choose image type
 516     if FmtInfo.IsIndexed then
 517       Hdr.ImageType := Iff(FUseRLE, 9, 1)
 518     else
 519       if FmtInfo.HasGrayChannel then
 520         Hdr.ImageType := Iff(FUseRLE, 11, 3)
 521       else
 522         Hdr.ImageType := Iff(FUseRLE, 10, 2);
 523
 524     Write(Handle, @Hdr, SizeOf(Hdr));
 525
 526     // Write palette
 527     if FmtInfo.PaletteEntries > 0 then
 528     begin
 529       GetMem(Pal, FmtInfo.PaletteEntries * SizeOf(TColor24Rec));
 530       try
 531         for I := 0 to FmtInfo.PaletteEntries - 1 do
 532           with Pal[I] do
 533           begin
 534             R := Palette[I].R;
 535             G := Palette[I].G;
 536             B := Palette[I].B;
 537           end;
 538         Write(Handle, Pal, FmtInfo.PaletteEntries * SizeOf(TColor24Rec));
 539       finally
 540         FreeMemNil(Pal);
 541       end;
 542     end;
 543
 544     if FUseRLE then
 545       // Save rle compressed mode images
 546       SaveRLE
 547     else
 548       // Save uncompressed mode images
 549       Write(Handle, Bits, Size);
 550
 551     Result := True;
 552   finally
 553     if MustBeFreed then
 554       FreeImage(ImageToSave);
 555   end;
 556 end;
 557
 558 procedure TTargaFileFormat.ConvertToSupported(var Image: TImageData;
 559   const Info: TImageFormatInfo);
 560 var
 561   ConvFormat: TImageFormat;
 562 begin
 563   if Info.HasGrayChannel then
 564     // Convert all grayscale images to Gray8 (preserve alpha of AxGrayx formats)
 565     ConvFormat := IffFormat(not Info.HasAlphaChannel, ifGray8, ifA8R8G8B8)
 566   else if Info.IsIndexed then
 567     // Convert all indexed images to Index8
 568     ConvFormat := ifIndex8
 569   else if Info.HasAlphaChannel then
 570     // Convert images with alpha channel to A8R8G8B8
 571     ConvFormat := ifA8R8G8B8
 572   else if Info.UsePixelFormat then
 573     // Convert 16bit images (without alpha channel) to A1R5G5B5
 574     ConvFormat := ifA1R5G5B5
 575   else
 576     // Convert all other formats to R8G8B8
 577     ConvFormat := ifR8G8B8;
 578
 579   ConvertImage(Image, ConvFormat);
 580 end;
 581
 582 function TTargaFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
 583 var
 584   Hdr: TTargaHeader;
 585   ReadCount: LongInt;
 586 begin
 587   Result := False;
 588   if Handle <> nil then
 589   begin
 590     ReadCount := GetIO.Read(Handle, @Hdr, SizeOf(Hdr));
 591     GetIO.Seek(Handle, -ReadCount, smFromCurrent);
 592     Result := (ReadCount >= SizeOf(Hdr)) and
 593       (Hdr.ImageType in [0, 1, 2, 3, 9, 10, 11]) and
 594       (Hdr.PixelSize in [1, 8, 15, 16, 24, 32]) and
 595       (Hdr.ColorEntrySize in [0, 16, 24, 32]);
 596   end;
 597 end;
 598
 599 initialization
 600   RegisterImageFileFormat(TTargaFileFormat);
 601
 602 {
 603   File Notes:
 604
 605  -- TODOS ----------------------------------------------------
 606     - nothing now
 607
 608   -- 0.21 Changes/Bug Fixes -----------------------------------
 609     - MakeCompatible method moved to base class, put ConvertToSupported here.
 610       GetSupportedFormats removed, it is now set in constructor.
 611     - Made public properties for options registered to SetOption/GetOption
 612       functions.
 613     - Changed extensions to filename masks.
 614     - Changed SaveData, LoadData, and MakeCompatible methods according
 615       to changes in base class in Imaging unit.
 616
 617   -- 0.17 Changes/Bug Fixes -----------------------------------
 618     - 16 bit images are usually without alpha but some has alpha
 619       channel and there is no indication of it - so I have added
 620       a check: if all pixels of image are with alpha = 0 image is treated
 621       as X1R5G5B5 otherwise as A1R5G5B5
 622     - fixed problems with some nonstandard 15 bit images
 623 }
 624
 625 end.