searchanddisplace-ingest/resources/libraries/deskew/Imaging/ImagingTarga.pas

{
  Vampyre Imaging Library
  by Marek Mauder 
  http://imaginglib.sourceforge.net

  The contents of this file are used with permission, subject to the Mozilla
  Public License Version 1.1 (the "License"); you may not use this file except
  in compliance with the License. You may obtain a copy of the License at
  http://www.mozilla.org/MPL/MPL-1.1.html

  Software distributed under the License is distributed on an "AS IS" basis,
  WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
  the specific language governing rights and limitations under the License.

  Alternatively, the contents of this file may be used under the terms of the
  GNU Lesser General Public License (the  "LGPL License"), in which case the
  provisions of the LGPL License are applicable instead of those above.
  If you wish to allow use of your version of this file only under the terms
  of the LGPL License and not to allow others to use your version of this file
  under the MPL, indicate your decision by deleting  the provisions above and
  replace  them with the notice and other provisions required by the LGPL
  License.  If you do not delete the provisions above, a recipient may use
  your version of this file under either the MPL or the LGPL License.

  For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
}

{ This unit contains image format loader/saver for Targa images.}
unit ImagingTarga;

{$I ImagingOptions.inc}

interface

uses
  ImagingTypes, Imaging, ImagingFormats, ImagingUtility;

type
  { Class for loading and saving Truevision Targa images.
    It can load/save 8bit indexed or grayscale, 16 bit RGB or grayscale,
    24 bit RGB and 32 bit ARGB images with or without RLE compression.}
  TTargaFileFormat = class(TImageFileFormat)
  protected
    FUseRLE: LongBool;
    procedure Define; override;
    function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
      OnlyFirstLevel: Boolean): Boolean; override;
    function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
      Index: LongInt): Boolean; override;
    procedure ConvertToSupported(var Image: TImageData;
      const Info: TImageFormatInfo); override;
  public
    function TestFormat(Handle: TImagingHandle): Boolean; override;
  published
    { Controls that RLE compression is used during saving. Accessible trough
      ImagingTargaRLE option.}
    property UseRLE: LongBool read FUseRLE write FUseRLE;
  end;

implementation

const
  STargaFormatName = 'Truevision Targa Image';
  STargaMasks      = '*.tga';
  TargaSupportedFormats: TImageFormats = [ifIndex8, ifGray8, ifA1R5G5B5,
    ifR8G8B8, ifA8R8G8B8];
  TargaDefaultRLE = False;  

const
  STargaSignature = 'TRUEVISION-XFILE';

type
  { Targa file header.}
  TTargaHeader = packed record
    IDLength: Byte;
    ColorMapType: Byte;
    ImageType: Byte;
    ColorMapOff: Word;
    ColorMapLength: Word;
    ColorEntrySize: Byte;
    XOrg: SmallInt;
    YOrg: SmallInt;
    Width: SmallInt;
    Height: SmallInt;
    PixelSize: Byte;
    Desc: Byte;
  end;

  { Footer at the end of TGA file.}
  TTargaFooter = packed record
    ExtOff: LongWord;             // Extension Area Offset
    DevDirOff: LongWord;          // Developer Directory Offset
    Signature: TChar16;           // TRUEVISION-XFILE
    Reserved: Byte;               // ASCII period '.'
    NullChar: Byte;               // 0
  end;


{ TTargaFileFormat class implementation }

procedure TTargaFileFormat.Define;
begin
  inherited;
  FName := STargaFormatName;
  FFeatures := [ffLoad, ffSave];
  FSupportedFormats := TargaSupportedFormats;

  FUseRLE := TargaDefaultRLE;

  AddMasks(STargaMasks);
  RegisterOption(ImagingTargaRLE, @FUseRLE);
end;

function TTargaFileFormat.LoadData(Handle: TImagingHandle;
  var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
var
  Hdr: TTargaHeader;
  Foo: TTargaFooter;
  FooterFound, ExtFound: Boolean;
  I, PSize, PalSize: LongWord;
  Pal: Pointer;
  FmtInfo: TImageFormatInfo;
  WordValue: Word;

  procedure LoadRLE;
  var
    I, CPixel, Cnt: LongInt;
    Bpp, Rle: Byte;
    Buffer, Dest, Src: PByte;
    BufSize: LongInt;
  begin
    with GetIO, Images[0] do
    begin
      // Alocates buffer large enough to hold the worst case
      // RLE compressed data and reads then from input
      BufSize := Width * Height * FmtInfo.BytesPerPixel;
      BufSize := BufSize + BufSize div 2 + 1;
      GetMem(Buffer, BufSize);
      Src := Buffer;
      Dest := Bits;
      BufSize := Read(Handle, Buffer, BufSize);

      Cnt := Width * Height;
      Bpp := FmtInfo.BytesPerPixel;
      CPixel := 0;
      while CPixel < Cnt do
      begin
        Rle := Src^;
        Inc(Src);
        if Rle < 128 then
        begin
          // Process uncompressed pixel
          Rle := Rle + 1;
          CPixel := CPixel + Rle;
          for I := 0 to Rle - 1 do
          begin
            // Copy pixel from src to dest
            case Bpp of
              1: Dest^ := Src^;
              2: PWord(Dest)^ := PWord(Src)^;
              3: PColor24Rec(Dest)^ := PColor24Rec(Src)^;
              4: PLongWord(Dest)^ := PLongWord(Src)^;
            end;
            Inc(Src, Bpp);
            Inc(Dest, Bpp);
          end;
        end
        else
        begin
          // Process compressed pixels
          Rle := Rle - 127;
          CPixel := CPixel + Rle;
          // Copy one pixel from src to dest (many times there)
          for I := 0 to Rle - 1 do
          begin
            case Bpp of
              1: Dest^ := Src^;
              2: PWord(Dest)^ := PWord(Src)^;
              3: PColor24Rec(Dest)^ := PColor24Rec(Src)^;
              4: PLongWord(Dest)^ := PLongWord(Src)^;
            end;
            Inc(Dest, Bpp);
          end;
          Inc(Src, Bpp);
        end;
      end;
      // set position in source to real end of compressed data
      Seek(Handle, -(BufSize - LongInt(LongWord(Src) - LongWord(Buffer))),
        smFromCurrent);
      FreeMem(Buffer);
    end;
  end;

begin
  SetLength(Images, 1);
  with GetIO, Images[0] do
  begin
    // Read targa header
    Read(Handle, @Hdr, SizeOf(Hdr));
    // Skip image ID info
    Seek(Handle, Hdr.IDLength, smFromCurrent);
    // Determine image format
    Format := ifUnknown;
    case Hdr.ImageType of
      1, 9: Format := ifIndex8;
      2, 10: case Hdr.PixelSize of
          15: Format := ifX1R5G5B5;
          16: Format := ifA1R5G5B5;
          24: Format := ifR8G8B8;
          32: Format := ifA8R8G8B8;
        end;
      3, 11: Format := ifGray8;
    end;
    // Format was not assigned by previous testing (it should be in
    // well formed targas), so formats which reflects bit dept are selected
    if Format = ifUnknown then
      case Hdr.PixelSize of
        8: Format := ifGray8;
        15: Format := ifX1R5G5B5;
        16: Format := ifA1R5G5B5;
        24: Format := ifR8G8B8;
        32: Format := ifA8R8G8B8;
      end;
    NewImage(Hdr.Width, Hdr.Height, Format, Images[0]);
    FmtInfo := GetFormatInfo(Format);

    if (Hdr.ColorMapType = 1) and (Hdr.ImageType in [1, 9]) then
    begin
      // Read palette
      PSize := Hdr.ColorMapLength * (Hdr.ColorEntrySize shr 3);
      GetMem(Pal, PSize);
      try
        Read(Handle, Pal, PSize);
        // Process palette
        PalSize := Iff(Hdr.ColorMapLength > FmtInfo.PaletteEntries,
          FmtInfo.PaletteEntries, Hdr.ColorMapLength);
        for I := 0 to PalSize - 1 do
          case Hdr.ColorEntrySize of
            24:
              with Palette[I] do
              begin
                A := $FF;
                R := PPalette24(Pal)[I].R;
                G := PPalette24(Pal)[I].G;
                B := PPalette24(Pal)[I].B;
              end;
            // I've never seen tga with these palettes so they are untested
            16:
              with Palette[I] do
              begin
                A := (PWordArray(Pal)[I] and $8000) shr 12;
                R := (PWordArray(Pal)[I] and $FC00) shr 7;
                G := (PWordArray(Pal)[I] and $03E0) shr 2;
                B := (PWordArray(Pal)[I] and $001F) shl 3;
              end;
            32:
              with Palette[I] do
              begin
                A := PPalette32(Pal)[I].A;
                R := PPalette32(Pal)[I].R;
                G := PPalette32(Pal)[I].G;
                B := PPalette32(Pal)[I].B;
              end;
          end;
      finally
        FreeMemNil(Pal);
      end;
    end;

    case Hdr.ImageType of
      0, 1, 2, 3:
        // Load uncompressed mode images
        Read(Handle, Bits, Size);
      9, 10, 11:
        // Load RLE compressed mode images
        LoadRLE;
    end;

    // Check if there is alpha channel present in A1R5GB5 images, if it is not
    // change format to X1R5G5B5
    if Format = ifA1R5G5B5 then
    begin
      if not Has16BitImageAlpha(Width * Height, Bits) then
        Format := ifX1R5G5B5;
    end;

    // We must find true end of file and set input' position to it
    // paint programs appends extra info at the end of Targas
    // some of them multiple times (PSP Pro 8)
    repeat
      ExtFound := False;
      FooterFound := False;

      if Read(Handle, @WordValue, 2) = 2 then
      begin
        // 495 = size of Extension Area
        if WordValue = 495 then
        begin
          Seek(Handle, 493, smFromCurrent);
          ExtFound := True;
        end
        else
          Seek(Handle, -2, smFromCurrent);
      end;

      if Read(Handle, @Foo, SizeOf(Foo)) = SizeOf(Foo) then
      begin
        if Foo.Signature = STargaSignature then
          FooterFound := True
        else
          Seek(Handle, -SizeOf(Foo), smFromCurrent);
      end;
    until (not ExtFound) and (not FooterFound);

    // Some editors save targas flipped
    if Hdr.Desc < 31 then
      FlipImage(Images[0]);

    Result := True;
  end;
end;

function TTargaFileFormat.SaveData(Handle: TImagingHandle;
  const Images: TDynImageDataArray; Index: LongInt): Boolean;
var
  I: LongInt;
  Hdr: TTargaHeader;
  FmtInfo: TImageFormatInfo;
  Pal: PPalette24;
  ImageToSave: TImageData;
  MustBeFreed: Boolean;

  procedure SaveRLE;
  var
    Dest: PByte;
    WidthBytes, Written, I, Total, DestSize: LongInt;

    function CountDiff(Data: PByte; Bpp, PixelCount: Longint): LongInt;
    var
      Pixel: LongWord;
      NextPixel: LongWord;
      N: LongInt;
    begin
      N := 0;
      Pixel := 0;
      NextPixel := 0;
      if PixelCount = 1 then
      begin
        Result := PixelCount;
        Exit;
      end;
      case Bpp of
        1: Pixel := Data^;
        2: Pixel := PWord(Data)^;
        3: PColor24Rec(@Pixel)^ := PColor24Rec(Data)^;
        4: Pixel := PLongWord(Data)^;
      end;
      while PixelCount > 1 do
      begin
        Inc(Data, Bpp);
        case Bpp of
          1: NextPixel := Data^;
          2: NextPixel := PWord(Data)^;
          3: PColor24Rec(@NextPixel)^ := PColor24Rec(Data)^;
          4: NextPixel := PLongWord(Data)^;
        end;
        if NextPixel = Pixel then
          Break;
        Pixel := NextPixel;
        N := N + 1;
        PixelCount := PixelCount - 1;
      end;
      if NextPixel = Pixel then
        Result := N
      else
        Result := N + 1;
    end;

    function CountSame(Data: PByte; Bpp, PixelCount: LongInt): LongInt;
    var
      Pixel: LongWord;
      NextPixel: LongWord;
      N: LongInt;
    begin
      N := 1;
      Pixel := 0;
      NextPixel := 0;
      case Bpp of
        1: Pixel := Data^;
        2: Pixel := PWord(Data)^;
        3: PColor24Rec(@Pixel)^ := PColor24Rec(Data)^;
        4: Pixel := PLongWord(Data)^;
      end;
      PixelCount := PixelCount - 1;
      while PixelCount > 0 do
      begin
        Inc(Data, Bpp);
        case Bpp of
          1: NextPixel := Data^;
          2: NextPixel := PWord(Data)^;
          3: PColor24Rec(@NextPixel)^ := PColor24Rec(Data)^;
          4: NextPixel := PLongWord(Data)^;
        end;
        if NextPixel <> Pixel then
          Break;
        N := N + 1;
        PixelCount := PixelCount - 1;
      end;
      Result := N;
    end;

    procedure RleCompressLine(Data: PByte; PixelCount, Bpp: LongInt; Dest:
      PByte; var Written: LongInt);
    const
      MaxRun = 128;
    var
      DiffCount: LongInt;
      SameCount: LongInt;
      RleBufSize: LongInt;
    begin
      RleBufSize := 0;
      while PixelCount > 0 do
      begin
        DiffCount := CountDiff(Data, Bpp, PixelCount);
        SameCount := CountSame(Data, Bpp, PixelCount);
        if (DiffCount > MaxRun) then
          DiffCount := MaxRun;
        if (SameCount > MaxRun) then
          SameCount := MaxRun;
        if (DiffCount > 0) then
        begin
          Dest^ := Byte(DiffCount - 1);
          Inc(Dest);
          PixelCount := PixelCount - DiffCount;
          RleBufSize := RleBufSize + (DiffCount * Bpp) + 1;
          Move(Data^, Dest^, DiffCount * Bpp);
          Inc(Data, DiffCount * Bpp);
          Inc(Dest, DiffCount * Bpp);
        end;
        if SameCount > 1 then
        begin
          Dest^ := Byte((SameCount - 1) or $80);
          Inc(Dest);
          PixelCount := PixelCount - SameCount;
          RleBufSize := RleBufSize + Bpp + 1;
          Inc(Data, (SameCount - 1) * Bpp);
          case Bpp of
            1: Dest^ := Data^;
            2: PWord(Dest)^ := PWord(Data)^;
            3: PColor24Rec(Dest)^ := PColor24Rec(Data)^;
            4: PLongWord(Dest)^ := PLongWord(Data)^;
          end;
          Inc(Data, Bpp);
          Inc(Dest, Bpp);
        end;
      end;
      Written := RleBufSize;
    end;

  begin
    with ImageToSave do
    begin
      // Allocate enough space to hold the worst case compression
      // result and then compress source's scanlines
      WidthBytes := Width * FmtInfo.BytesPerPixel;
      DestSize := WidthBytes * Height;
      DestSize := DestSize + DestSize div 2 + 1;
      GetMem(Dest, DestSize);
      Total := 0;
      try
        for I := 0 to Height - 1 do
        begin
          RleCompressLine(@PByteArray(Bits)[I * WidthBytes], Width,
            FmtInfo.BytesPerPixel, @PByteArray(Dest)[Total], Written);
          Total := Total + Written;
        end;
        GetIO.Write(Handle, Dest, Total);
      finally
        FreeMem(Dest);
      end;
    end;
  end;

begin
  Result := False;
  if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
  with GetIO, ImageToSave do
  try
    FmtInfo := GetFormatInfo(Format);
    // Fill targa header
    FillChar(Hdr, SizeOf(Hdr), 0);
    Hdr.IDLength := 0;
    Hdr.ColorMapType := Iff(FmtInfo.PaletteEntries > 0, 1, 0);
    Hdr.Width := Width;
    Hdr.Height := Height;
    Hdr.PixelSize := FmtInfo.BytesPerPixel * 8;
    Hdr.ColorMapLength := FmtInfo.PaletteEntries;
    Hdr.ColorEntrySize := Iff(FmtInfo.PaletteEntries > 0, 24, 0);
    Hdr.ColorMapOff := 0;
    // This indicates that targa is stored in top-left format
    // as our images -> no flipping is needed.
    Hdr.Desc := 32;
    // Set alpha channel size in descriptor (mostly ignored by other software though)
    if Format = ifA8R8G8B8 then
      Hdr.Desc := Hdr.Desc or 8
    else if Format = ifA1R5G5B5 then
      Hdr.Desc := Hdr.Desc or 1;

    // Choose image type
    if FmtInfo.IsIndexed then
      Hdr.ImageType := Iff(FUseRLE, 9, 1)
    else
      if FmtInfo.HasGrayChannel then
        Hdr.ImageType := Iff(FUseRLE, 11, 3)
      else
        Hdr.ImageType := Iff(FUseRLE, 10, 2);

    Write(Handle, @Hdr, SizeOf(Hdr));

    // Write palette
    if FmtInfo.PaletteEntries > 0 then
    begin
      GetMem(Pal, FmtInfo.PaletteEntries * SizeOf(TColor24Rec));
      try
        for I := 0 to FmtInfo.PaletteEntries - 1 do
          with Pal[I] do
          begin
            R := Palette[I].R;
            G := Palette[I].G;
            B := Palette[I].B;
          end;
        Write(Handle, Pal, FmtInfo.PaletteEntries * SizeOf(TColor24Rec));
      finally
        FreeMemNil(Pal);
      end;
    end;

    if FUseRLE then
      // Save rle compressed mode images
      SaveRLE
    else
      // Save uncompressed mode images
      Write(Handle, Bits, Size);

    Result := True;
  finally
    if MustBeFreed then
      FreeImage(ImageToSave);
  end;
end;

procedure TTargaFileFormat.ConvertToSupported(var Image: TImageData;
  const Info: TImageFormatInfo);
var
  ConvFormat: TImageFormat;
begin
  if Info.HasGrayChannel then
    // Convert all grayscale images to Gray8 (preserve alpha of AxGrayx formats)
    ConvFormat := IffFormat(not Info.HasAlphaChannel, ifGray8, ifA8R8G8B8)
  else if Info.IsIndexed then
    // Convert all indexed images to Index8
    ConvFormat := ifIndex8
  else if Info.HasAlphaChannel then
    // Convert images with alpha channel to A8R8G8B8
    ConvFormat := ifA8R8G8B8
  else if Info.UsePixelFormat then
    // Convert 16bit images (without alpha channel) to A1R5G5B5
    ConvFormat := ifA1R5G5B5
  else
    // Convert all other formats to R8G8B8
    ConvFormat := ifR8G8B8;

  ConvertImage(Image, ConvFormat);
end;

function TTargaFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
var
  Hdr: TTargaHeader;
  ReadCount: LongInt;
begin
  Result := False;
  if Handle <> nil then
  begin
    ReadCount := GetIO.Read(Handle, @Hdr, SizeOf(Hdr));
    GetIO.Seek(Handle, -ReadCount, smFromCurrent);
    Result := (ReadCount >= SizeOf(Hdr)) and
      (Hdr.ImageType in [0, 1, 2, 3, 9, 10, 11]) and
      (Hdr.PixelSize in [1, 8, 15, 16, 24, 32]) and
      (Hdr.ColorEntrySize in [0, 16, 24, 32]);
  end;
end;

initialization
  RegisterImageFileFormat(TTargaFileFormat);

{
  File Notes:

 -- TODOS ----------------------------------------------------
    - nothing now

  -- 0.21 Changes/Bug Fixes -----------------------------------
    - MakeCompatible method moved to base class, put ConvertToSupported here.
      GetSupportedFormats removed, it is now set in constructor.
    - Made public properties for options registered to SetOption/GetOption
      functions.
    - Changed extensions to filename masks.
    - Changed SaveData, LoadData, and MakeCompatible methods according
      to changes in base class in Imaging unit.

  -- 0.17 Changes/Bug Fixes -----------------------------------
    - 16 bit images are usually without alpha but some has alpha
      channel and there is no indication of it - so I have added
      a check: if all pixels of image are with alpha = 0 image is treated
      as X1R5G5B5 otherwise as A1R5G5B5
    - fixed problems with some nonstandard 15 bit images
}

end.