(* ImageEn Build 7.0.0.06.2637 @ 7-4-17 14:58:42.679 *)
(*
Copyright (c) 1998-2017 by Carlotta Calandra. All rights reserved.
Copyright (c) 2011-2017 by Xequte Software.

This software comes without express or implied warranty.
In no case shall the author be liable for any damage or unwanted behavior of any
computer hardware and/or software.

Author grants you the right to include the component
in your application, whether COMMERCIAL, SHAREWARE, or FREEWARE.

ImageEn, IEvolution and ImageEn ActiveX may not be included in any
commercial, shareware or freeware libraries or components.

www.ImageEn.com
*)

(*
File version 1003
*)

unit ietgafil;

{$R-}
{$Q-}

{$I ie.inc}

interface

uses
  Windows, Classes, Graphics, SysUtils, ImageEnIO, hyiedefs, iexBitmaps;
  

procedure ReadTGAStream(Stream: TStream; Bitmap: TIEBitmap; var IOParams: TIOParams; var Progress: TProgressRec; Preview: boolean; var AlphaChannel: TIEMask; IgnoreAlpha: boolean);
procedure WriteTGAStream(Stream: TStream; Bitmap: TIEBitmap; var IOParams: TIOParams; var Progress: TProgressRec; AlphaChannel: TIEMask);
function TryTGA(Stream: TStream): boolean;

implementation

uses
  ImageEnProc, neurquant, ImageEnView, ieview, iesettings, hyieutils;

{$R-}

type
  TGAHeader = packed record
    IdentSize: Byte;      // length of Identifier String
    ColorMaptype: Byte;   // 0 = no map
    Imagetype: Byte;      // image type
    ColorMapStart: Word;  // index of first color map entry
    ColorMapLength: Word; // number of entries in color map
    ColorMapBits: Byte;   // size of color map entry (15, 16, 24, 32)
    XStart: Word;         // x origin of image
    YStart: Word;         // y origin of image
    Width: Word;          // width of image
    Height: Word;         // height of image
    Bits: Byte;           // pixel size (8, 16, 24, 32)
    Descriptor: Byte;     // image descriptor
  end;

  TGAFooter = packed record
    ExtensionArea: dword;
    DeveloperDir: dword;
    Signature: array[0..17] of AnsiChar; // must be 'TRUEVISION-XFILE.\0'
  end;

  TGAExtension = packed record
    ExtSize: word;
    AuthorName: array[0..40] of AnsiChar;
    AuthorComments: array[0..323] of AnsiChar;
    DateTime: array[0..5] of word;
    JobName: array[0..40] of AnsiChar;
    JobTime: array[0..2] of word;
    SoftwareID: array[0..40] of AnsiChar;
    SoftwareVer: array[0..2] of byte;
    KeyColor: array[0..3] of byte;
    AspectRatio: array[0..1] of word;
    Gamma: array[0..1] of word;
    ColorCorrection: dword;
    PostageStamp: dword;
    ScanLine: dword;
    AttributesType: byte;
  end;

  TRC = record
    IndexData: array[0..8192 - 1] of Byte;
    Palette256: array[0..255] of TRGB;
    alpha256: array [0..255] of byte;
    hasalpha256: boolean;
    TempArrayD: PBYTEROW;
    //TempArrayD2: PBYTEROW;
    TempArrayDBIg: PBYTEROW;
    TempArrayAlpha: PBYTEROW;
    CompRow: PBYTEROW;
    Index1: Word;
    Index2: Word;
    Newtype: boolean;
    Footer: TGAFooter;
    Extension: TGAExtension;
    sbase: integer;
    RemSize, RemCode: integer;
  end;
  PRC = ^TRC;



function TryTGA(Stream: TStream): boolean;
var
  TGAHead: TGAHeader;
  c: AnsiChar;
  B: Byte;
  sp: int64;
begin
  sp := Stream.Position;
  // Read Targa Header
  Stream.Read(TGAHead, Sizeof(TGAHeader));
  if (TGAHead.Imagetype in [1, 2, 3, 9, 10, 11]) and (TGAHead.Bits in [1, 4, 8, 16, 24, 32]) and
    (TGAHead.ColorMaptype < 2) and (TGAHead.Width>0) and (TGAHead.Height>0) then
  begin
    result := true;
    Stream.Position := sp;
    Stream.Read(c, 1);
    if c = 'P' then
    begin
      Stream.Read(b, 1);
      if (b - 48 > 01) and (b - 48 < 7) then
      begin
        Stream.Read(c, 1);
        if (c <> ' ') and (c <> '#') and (c <> #$0A) then
          result := false;
      end;
    end;
  end
  else
    result := false;
  Stream.Position := sp;
end;

procedure SetUpMaskGrayPalette(var rc: TRC);
var
  J: integer;
begin
  for J := 0 to 255 do
    with rc.Palette256[J] do
    begin
      r := J;
      g := J;
      b := J;
    end;
end;

procedure MakeGenPalette(var rc: TRC);
var
  X: integer;
  R, G, B: Word;
begin
  with rc do
  begin
    X := 0;
    for R := 0 to 7 do
      for G := 0 to 7 do
        for B := 0 to 3 do
        begin
          Palette256[X].r := ((R + 1) * 8 - 1) * 4;
          Palette256[X].g := ((G + 1) * 8 - 1) * 4;
          Palette256[X].b := ((B + 1) * 16 - 1) * 4;
          Inc(X);
        end;
  end;
end;



procedure ReadTGAStream(Stream: TStream; Bitmap: TIEBitmap; var IOParams: TIOParams; var Progress: TProgressRec; Preview: boolean; var AlphaChannel: TIEMask; IgnoreAlpha: boolean);
var
  rc: PRC;
  Width: Word;
  Height: Word;
  BitsPerPixel: SmallInt;
  Compressed: Boolean;
  TGAHead: TGAHeader;
  FileOk: Boolean;
  //
  procedure FileGetMore;
  var
    NumRead: integer;
  begin
    with rc^ do
    begin
      NumRead := Stream.Size - Stream.Position;
      //FillChar(IndexData, 8192, 0);
      if NumRead < 8192 then
      begin
        Stream.Read(IndexData, NumRead);
        Index1 := NumRead;
      end
      else
      begin
        Stream.Read(IndexData, 8192);
        Index1 := 8192;
      end;
      Index2 := 0;
    end;
  end;
  //
  procedure FastGetBytes(var Ptr1; NumBytes: Word);
  var
    X: Integer;
  begin
    with rc^ do
    begin
      // if we have enough the block it! Otherwise do one at a time!
      if Index1 < NumBytes then
      begin
        if Index1 = 0 then
          FileGetMore;
        for X := 0 to NumBytes - 1 do
        begin
          TBYTEROW(Ptr1)[X] := IndexData[Index2];
          Inc(Index2);
          Dec(Index1);
          if Index1 = 0 then
            FileGetMore;
        end;
      end
      else
      begin
        // Block it fast!
        Move(IndexData[Index2], TBYTEROW(Ptr1)[0], NumBytes);
        Index2 := Index2 + Numbytes;
        Index1 := Index1 - NumBytes;
      end;
    end;
  end;
  //
  function FastGetByte: Byte;
  begin
    with rc^ do
    begin
      if Index1 = 0 then
        FileGetMore;
      FastGetByte := IndexData[Index2];
      Inc(Index2);
      Dec(Index1);
    end;
  end;
  //
  function FastGetWord: Word;
  begin
    FastGetWord := Word(FastGetByte) + Word(FastGetByte) * 256;
  end;
  //
  procedure ReadTGAFileHeader(var FileOk: Boolean;
    var Width: Word; var Height: Word; var BitsPerPixel: SmallInt;
    var Compressed: Boolean);
  var
    W1: Word;
    I: integer;
    ss: AnsiString;
  begin
    with rc^ do
    begin
      // Read Targa footer (if exists)
      Stream.Seek(-sizeof(TGAFooter), soEnd);
      Stream.Read(Footer, sizeof(TGAFooter));
      NewType := Footer.Signature = 'TRUEVISION-XFILE.';
      // default values
      IOParams.TGA_Author := '';
      IOParams.TGA_Date := date;
      IOParams.TGA_ImageName := '';
      IOParams.TGA_Background := CreateRGB(0, 0, 0);
      IOParams.TGA_AspectRatio := 1;
      IOParams.TGA_Gamma := 2.2;
      if NewType then
        with Extension do
        begin
          Stream.Position := sbase + integer(Footer.ExtensionArea);
          Stream.Read(Extension, sizeof(TGAExtension));
          IOParams.TGA_Author := AuthorName;
          try
            if (DateTime[0] <> 0) and (DateTime[1] <> 0) and (DateTime[2] <> 0) and
              (DateTime[2] > 0) and (DateTime[2] < 2500) and
              (DateTime[0] > 0) and (DateTime[0] < 13) and
              (DateTime[1] > 0) and (DateTime[1] < 32) and
              (DateTime[3] < 24) and
              (DateTime[4] < 60) and
              (DateTime[5] < 60) then
              IOParams.TGA_Date := EncodeDate(DateTime[2], DateTime[0], DateTime[1]) +
                EncodeTime(DateTime[3], DateTime[4], DateTime[5], 0);
          except
          end;
          IOParams.TGA_ImageName := JobName;
          IOParams.TGA_Background := CreateRGB(KeyColor[1], KeyColor[2], KeyColor[3]);
          if (AspectRatio[0] <> 0) and (AspectRatio[1] <> 0) then
            IOParams.TGA_AspectRatio := AspectRatio[0] / AspectRatio[1];
          if (Gamma[0] <> 0) and (Gamma[1] <> 0) then
            IOParams.TGA_Gamma := Gamma[0] / Gamma[1];
        end;
      Stream.Position := sbase;
      // Read Targa Header
      FastGetBytes(TGAHead, Sizeof(TGAHeader));
      IOParams.TGA_XPos := TGAHead.XStart;
      IOParams.TGA_YPos := TGAHead.YStart;
      FileOk := (TGAHead.Imagetype in [1, 2, 3, 9, 10, 11]) and (TGAHead.Bits in [1, 4, 8, 16, 24, 32]);
      if FileOk then
      begin
        Width := TGAHead.Width;
        Height := TGAHead.Height;
        BitsPerPixel := TGAHead.Bits;
        SetLength(ss, TGAHead.IdentSize);
        FastGetBytes(ss[1], TGAHead.IdentSize);
        IOParams.TGA_Descriptor := ss;
        // Read in colormap
        MakeGenPalette(rc^);
        if TGAHead.ColorMaptype = 1 then
        begin
          case TGAHead.ColorMapBits of
            15, 16:
              for I := TGAHead.ColorMapStart to TGAHead.ColorMapStart + TGAHead.ColorMapLength - 1 do
              begin
                W1 := FastGetWord;
                Palette256[I].r := (((W1 shr 10) and $1F) shl 1) * 4;
                Palette256[I].g := (((W1 shr 5) and $1F) shl 1) * 4;
                Palette256[I].b := (((W1 shr 0) and $1F) shl 1) * 4;
              end;
            24:
              for I := TGAHead.ColorMapStart to TGAHead.ColorMapStart + TGAHead.ColorMapLength - 1 do
              begin
                Palette256[I].b := FastGetByte;
                Palette256[I].g := FastGetByte;
                Palette256[I].r := FastGetByte;
              end;
            32:
              begin
                hasalpha256 := true;
                for I := TGAHead.ColorMapStart to TGAHead.ColorMapStart + TGAHead.ColorMapLength - 1 do
                begin
                  Palette256[I].b := FastGetByte;
                  Palette256[I].g := FastGetByte;
                  Palette256[I].r := FastGetByte;
                  alpha256[I] := FastGetByte;
                end;
              end;
          end;
          IOParams.FreeColorMap;
          IOParams.fColorMapCount := TGAHead.ColorMapLength;
          IOParams.fColorMap := allocmem(TGAHead.ColorMapLength * sizeof(TRGB));
          move(Palette256[0], IOParams.fcolorMap^[0], TGAHead.ColorMapLength * sizeof(TRGB));
          IOParams.TGA_GrayLevel := false;
        end
        else
        if BitsPerPixel = 8 then
        begin
          // gray level image (8bpp but without colormap)
          SetUpMaskGrayPalette(rc^);
          IOParams.TGA_GrayLevel := true;
        end
        else
        if BitsPerPixel = 1 then
        begin
          // bilevel image
          Palette256[0] := CreateRGB(0, 0, 0);
          Palette256[1] := CreateRGB(255, 255, 255);
        end;
        Compressed := TGAHead.Imagetype in [9, 10, 11];
        IOParams.TGA_Compressed := Compressed;
      end;
    end;
  end;
  //
const
  MaskTable: array[0..7] of Byte = (128, 64, 32, 16, 8, 4, 2, 1);
var
  II: Word;
  LineBytes: Word;
  StartLine, IncLine, I: SmallInt;
  Ptr1: Pointer;
  //
  procedure PixelSwapArray(var TempArrayD; Wide: Word);
  var
    W, X, Y, Z: integer;
    Byte1, Byte2, Byte3: Byte;
  begin
    // Should I do 1 byte pixel or 3 byte pixels
    case BitsPerPixel of
      8:
        begin
          Y := Wide shr 1;
          Z := Wide - 1;
          for X := 0 to Y - 1 do
          begin
            Byte1 := TBYTEROW(TempArrayD)[X];
            TBYTEROW(TempArrayD)[X] := TBYTEROW(TempArrayD)[Z];
            TBYTEROW(TempArrayD)[Z] := Byte1;
            Dec(Z);
          end;
        end;
      24:
        begin
          Y := (Wide div 3) div 2;
          Z := Wide - 3;
          W := 0;
          for X := 0 to Y - 1 do
          begin
            Byte1 := TBYTEROW(TempArrayD)[W + 0];
            Byte2 := TBYTEROW(TempArrayD)[W + 1];
            Byte3 := TBYTEROW(TempArrayD)[W + 2];
            TBYTEROW(TempArrayD)[W + 0] := TBYTEROW(TempArrayD)[Z + 0];
            TBYTEROW(TempArrayD)[W + 1] := TBYTEROW(TempArrayD)[Z + 1];
            TBYTEROW(TempArrayD)[W + 2] := TBYTEROW(TempArrayD)[Z + 2];
            TBYTEROW(TempArrayD)[Z + 0] := Byte1;
            TBYTEROW(TempArrayD)[Z + 1] := Byte2;
            TBYTEROW(TempArrayD)[Z + 2] := Byte3;
            dec(Z, 3);
            inc(W, 3);
          end;
        end;
      32:
        begin
          Y := Wide shr 3;
          Z := Wide - 4;
          W := 0;
          for X := 0 to Y - 1 do
          begin
            Byte1 := TBYTEROW(TempArrayD)[W + 0];
            Byte2 := TBYTEROW(TempArrayD)[W + 1];
            Byte3 := TBYTEROW(TempArrayD)[W + 2];
            TBYTEROW(TempArrayD)[W + 0] := TBYTEROW(TempArrayD)[Z + 0];
            TBYTEROW(TempArrayD)[W + 1] := TBYTEROW(TempArrayD)[Z + 1];
            TBYTEROW(TempArrayD)[W + 2] := TBYTEROW(TempArrayD)[Z + 2];
            TBYTEROW(TempArrayD)[Z + 0] := Byte1;
            TBYTEROW(TempArrayD)[Z + 1] := Byte2;
            TBYTEROW(TempArrayD)[Z + 2] := Byte3;
            Z := Z - 4;
            W := W + 4;
          end;
        end;
    end;
  end;
  //
  procedure TGAReverse(var TempArrayD: TBYTEROW);
  begin
    if TGAHead.Descriptor and $10 <> 0 then
      PixelSwapArray(TempArrayD, LineBytes);
  end;
  //
  procedure TGA16_ANY_U(var Z: integer; var TempArrayD; Width: Word);
  var
    W1: Word;
    I: integer;
    R, G, B: Byte;
  begin
    for I := 0 to Width - 1 do
    begin
      W1 := FastGetWord;
      R := ((W1 shr 10) and $1F) shl 3;
      G := ((W1 shr 5) and $1F) shl 3;
      B := ((W1 shr 0) and $1F) shl 3;
      TBYTEROW(TempArrayD)[Z + 0] := B;
      TBYTEROW(TempArrayD)[Z + 1] := G;
      TBYTEROW(TempArrayD)[Z + 2] := R;
      inc(z, 3);
    end;
  end;
  //
  procedure TGA24_ANY_U(var Z: integer; Flag: Byte; var TempArrayD; Width: Word; TempArrayAlpha: PBYTEROW);
  var
    I: integer;
  begin
    for I := 0 to Width - 1 do
    begin
      TBYTEROW(TempArrayD)[Z + 0] := FastGetByte;
      TBYTEROW(TempArrayD)[Z + 1] := FastGetByte;
      TBYTEROW(TempArrayD)[Z + 2] := FastGetByte;
      if Flag = 1 then
      begin
        if TempArrayAlpha <> nil then
          TempArrayAlpha[Z div 3] := FastGetByte
        else
          FastGetByte;
      end;
      inc(Z, 3);
    end;
  end;
  //
  procedure ReadTGALine;
  var
    Size, LineSize: integer;
    W1: Word;
    Z: integer;
    R, G, B, B1: Byte;
    procedure do8;
    var
      I: integer;
    begin
      with rc^ do
        for I := 0 to Size - 1 do
        begin
          TempArrayD^[Z] := ((R shl 5) + (G shl 6) + (B * 12)) div 108;
          Inc(Z);
        end;
    end;
    procedure do24Raw;
    var
      I, Z: integer;
    begin
      with rc^ do
      begin
        Z := 0;
        for I := 0 to Width - 1 do
        begin
          B1 := FastGetByte;
          TempArrayD^[Z + 0] := Palette256[B1].b;
          TempArrayD^[Z + 1] := Palette256[B1].g;
          TempArrayD^[Z + 2] := Palette256[B1].r;
          if (TempArrayAlpha<>nil) and hasalpha256 then
            TempArrayAlpha[Z div 3] := alpha256[B1];
          inc(Z, 3);
        end;
      end;
    end;
    procedure do24RawPart;
    var
      I: integer;
    begin
      with rc^ do
        for I := 0 to Size - 1 do
        begin
          B1 := FastGetByte;
          TempArrayD^[Z + 0] := Palette256[B1].b;
          TempArrayD^[Z + 1] := Palette256[B1].g;
          TempArrayD^[Z + 2] := Palette256[B1].r;
          if (TempArrayAlpha<>nil) and hasalpha256 then
            TempArrayAlpha[Z div 3] := alpha256[B1];
          inc(Z, 3);
        end;
    end;
    procedure do24Fill(B1: Byte);
    var
      I: integer;
      R, G, B: Byte;
    begin
      with rc^ do
      begin
        R := Palette256[B1].r;
        G := Palette256[B1].g;
        B := Palette256[B1].b;
        for I := 0 to Size - 1 do
        begin
          TempArrayD^[Z + 0] := B;
          TempArrayD^[Z + 1] := G;
          TempArrayD^[Z + 2] := R;
          if (TempArrayAlpha<>nil) and hasalpha256 then
            TempArrayAlpha[Z div 3] := alpha256[B1];
          inc(Z, 3);
        end;
      end;
    end;
    procedure do24;
    var
      I: integer;
    begin
      with rc^ do
        for I := 0 to Size - 1 do
        begin
          TempArrayD^[Z + 0] := B;
          TempArrayD^[Z + 1] := G;
          TempArrayD^[Z + 2] := R;
          inc(Z, 3);
        end;
    end;
  var
    col, q: integer;
  begin
    // ReadTGALine
    with rc^ do
    begin
      if BitsPerPixel = 1 then
        LineSize := (Width + 7) shr 3
      else
        LineSize := Width;
      // Uncompressed Lines
      if TGAHead.Imagetype in [1, 2, 3] then
        case BitsPerPixel of
          1: FastGetBytes(TempArrayD^[0], LineBytes);
          8: do24Raw;
          16:
            begin
              Z := 0;
              TGA16_ANY_U(Z, TempArrayD^[0], Width);
            end;
          24:
            begin
              Z := 0;
              TGA24_ANY_U(Z, 0, TempArrayD^[0], Width, TempArrayAlpha);
            end;
          32:
            begin
              Z := 0;
              TGA24_ANY_U(Z, 1, TempArrayD^[0], Width, TempArrayAlpha);
            end;
        end
      else
      begin
        // Compressed Lines
        Z := 0;
        col := 0;
        repeat
          if RemCode>-1 then
          begin
            B1 := RemCode;
            Size := RemSize;
            RemCode := -1;
          end
          else
          begin
            B1 := FastGetByte;
            Size := (B1 and $7F) + 1;
          end;
          if Size+col>LineSize then
          begin
            RemSize := (Size+Col)-LineSize;
            RemCode := B1;
            Size := LineSize-col;
          end;
          if (B1 and $80) <> 0 then
          begin
            // Run length packet
            case BitsPerPixel of
              1, 8:
                begin
                  B1 := FastGetByte;
                  do24Fill(B1);
                end;
              16:
                begin
                  W1 := FastGetWord;
                  R := ((W1 shr 10) and $1F) shl 3;
                  G := ((W1 shr 5) and $1F) shl 3;
                  B := ((W1 shr 0) and $1F) shl 3;
                  do24;
                end;
              24, 32:
                begin
                  B := FastGetByte;
                  G := FastGetByte;
                  R := FastGetByte;
                  if BitsPerPixel = 32 then
                  begin
                    B1 := FastGetByte;
                    if TempArrayAlpha <> nil then
                      for q := col to col+Size-1 do
                        TempArrayAlpha[q] := B1;
                  end;
                  do24;
                end;
            end;
          end
          else
            // Single bytes
            case BitsPerPixel of
              1, 8:
                do24RawPart;
              16:
                TGA16_ANY_U(Z, TempArrayD^[0], Size);
              24:
                TGA24_ANY_U(Z, 0, TempArrayD^[0], Size, TempArrayAlpha);
              32:
                TGA24_ANY_U(Z, 1, TempArrayD^[0], Size, TempArrayAlpha);
            end;
          inc(col, Size);
        until col >= LineSize;
      end;
    end;
  end;
  //
begin
  new(rc);
  try
    zeromemory(rc, sizeof(TRC));
    with rc^ do
    begin
      // init alpha
      for i := 0 to 255 do
        alpha256[i] := 255;
      hasalpha256 := false;

      // Read Targa Stream
      sbase := Stream.Position;
      Index1 := 0;
      Index2 := 0;
      FileOk := true;
      ReadTgaFileHeader(FileOK, Width, Height, BitsPerPixel, Compressed);
      if FileOK then
      begin
        IOParams.Width := Width;
        IOParams.Height := Height;
        IOParams.OriginalWidth := Width;
        IOParams.OriginalHeight := Height;
        IOParams.DpiX := IEGlobalSettings().DefaultDPIX;
        IOParams.DpiY := IEGlobalSettings().DefaultDPIY;
        IOParams.ImageCount := 1;
        case BitsPerPixel of
          1:
            begin
              IOParams.BitsPerSample := 1;
              IOParams.SamplesPerPixel := 1;
            end;
          8:
            begin
              IOParams.BitsPerSample := 8;
              IOParams.SamplesPerPixel := 1;
            end;
          16:
            begin
              IOParams.BitsPerSample := 5;
              IOParams.SamplesPerPixel := 3;
            end;
          24:
            begin
              IOParams.BitsPerSample := 8;
              IOParams.SamplesPerPixel := 3;
            end;
          32:
            begin
              IOParams.BitsPerSample := 8;
              IOParams.SamplesPerPixel := 4;
            end;
        end;
        if not Preview then
        begin
          Progress.per1 := 100 / Height;
          Progress.val := 0;
          if BitsPerPixel = 1 then
          begin
            Bitmap.Allocate(Width, Height, ie1g);
            LineBytes := (Width + 7) shr 3;
          end
          else
          begin
            Bitmap.Allocate(Width, Height, ie24RGB);
            LineBytes := Width * 3;
          end;
          TempArrayD := nil;
          TempArrayAlpha := nil;
          try
            GetMem(TempArrayD, LineBytes);
            if (not IgnoreAlpha) and ( ((BitsPerPixel = 32) (*and ((TGAHead.Descriptor and 8) <> 0)*)) or (TGAHead.ColorMapBits=32) ) then
            begin
              if not assigned(AlphaChannel) then
                AlphaChannel := TIEMask.Create;
              AlphaChannel.AllocateBits(Width, Height, 8);
              AlphaChannel.Fill(255);
              getmem(TempArrayAlpha, Width);
              FillChar(TempArrayAlpha^, Width, 255);
              AlphaChannel.Full := false;
            end
            else
              TempArrayAlpha := nil;
            if ((ord(TGAHead.Descriptor) and 32) <> 32) and ((ord(TGAHead.Descriptor) and 16) <> 16) then
            begin
              StartLine := Height - 1;
              IncLine := -1;
            end
            else
            begin
              StartLine := 0;
              IncLine := 1;
            end;
            RemCode := -1;
            I := StartLine;
            II := 0;
            if TGAHead.Imagetype in [1, 2, 3, 9, 10, 11] then
              repeat
                ReadTGALine;
                TGAReverse(TempArrayD^);
                Ptr1 := BitMap.ScanLine[I];
                // Copy the data
                Move(TempArrayD^, Ptr1^, LineBytes);
                // copy alpha
                if TempArrayAlpha <> nil then
                  copymemory(AlphaChannel.Scanline[I], TempArrayAlpha, Width);
                Inc(II);
                I := I + IncLine;
                with Progress do
                begin
                  inc(val);
                  if assigned(fOnProgress) then
                    fOnProgress(Sender, trunc(per1 * val));
                end;
              until (II >= Height) or (Progress.Aborting^=True)
            else
              Progress.Aborting^ := True;
          finally
            FreeMem(TempArrayD);
            if TempArrayAlpha <> nil then
              FreeMem(TempArrayAlpha);
          end;
        end; // not preview
      end
      else
        Progress.Aborting^ := True;
    end;
  finally
    dispose(rc);
  end;
  if assigned(AlphaChannel) then
  begin
    AlphaChannel.SyncRect;
    if AlphaChannel.IsEmpty then
      FreeAndNil(AlphaChannel);
  end;
end;

///////////////////////////////////////////////////////////////////////////////////////

procedure WriteTGAStream(Stream: TStream; Bitmap: TIEBitmap; var IOParams: TIOParams; var Progress: TProgressRec; AlphaChannel: TIEMask);
var
  rc: PRC;
  TGAHead: TGAHeader;
  OutputWidth: integer;
  OutputHeight: integer;
  DestBitsPerPixel: integer;
  OrigBitsPerPixel: integer;
  NewLine: PBYTEROW;
  XBitmap: TIEBitmap;
  qt: TIEQuantizer;
  NullProgress: TProgressRec;
  //
  procedure TGAWriteHeader;
  begin
    TGAHead.IdentSize := Length(IOParams.TGA_Descriptor) + 1;
    TGAHead.Bits := DestBitsPerPixel;
    TGAHead.Descriptor := 0;
    case DestBitsPerPixel of
      1:
        begin
          // bilevel image
          TGAHead.ColorMaptype := 0;
          if IOParams.TGA_Compressed then
            TGAHead.Imagetype := 11
          else
            TGAHead.Imagetype := 3;
          TGAHead.ColorMapStart := 0;
          TGAHead.ColorMapLength := 0;
          TGAHead.ColorMapBits := 0;
        end;
      4, 8:
        begin
          if (DestBitsPerPixel = 8) and IOParams.TGA_GrayLevel then
          begin
            // gray scaled image
            TGAHead.ColorMaptype := 0;
            if IOParams.TGA_Compressed then
              TGAHead.Imagetype := 11
            else
              TGAHead.Imagetype := 3;
            TGAHead.ColorMapStart := 0;
            TGAHead.ColorMapLength := 1 shl DestBitsPerPixel;
            TGAHead.ColorMapBits := 24;
          end
          else
          begin
            // colormapped image
            TGAHead.ColorMaptype := 1;
            if IOParams.TGA_Compressed then
              TGAHead.Imagetype := 9
            else
              TGAHead.Imagetype := 1;
            TGAHead.ColorMapStart := 0;
            TGAHead.ColorMapLength := 1 shl DestBitsPerPixel;
            TGAHead.ColorMapBits := 24;
          end;
        end;
      24:
        begin
          // true color image
          TGAHead.ColorMaptype := 0;
          if IOParams.TGA_Compressed then
            TGAHead.Imagetype := 10
          else
            TGAHead.Imagetype := 2;
          TGAHead.ColorMapStart := 0;
          TGAHead.ColorMapLength := 0;
          TGAHead.ColorMapBits := 0;
        end;
      32:
        begin
          // true color image with alpha (AlphaChannel must be valid and not empty)
          TGAHead.ColorMaptype := 0;
          if IOParams.TGA_Compressed then
            TGAHead.Imagetype := 10
          else
            TGAHead.Imagetype := 2;
          TGAHead.ColorMapStart := 0;
          TGAHead.ColorMapLength := 0;
          TGAHead.ColorMapBits := 0;
          TGAHead.Descriptor := TGAHead.Descriptor or $8; // alpha channel with 8 bit
        end;
    end;
    TGAHead.XStart := IOParams.TGA_XPos;
    TGAHead.YStart := IOParams.TGA_YPos;
    TGAHead.Width := OutputWidth;
    TGAHead.Height := OutputHeight;
    TGAHead.Descriptor := TGAHead.Descriptor or $20; // isn't IOParams.TGA_Descriptor!!
    SafeStreamWrite(Stream, Progress.Aborting^, TGAHead, Sizeof(TGAHead));
    SafeStreamWrite(Stream, Progress.Aborting^, PAnsiChar(IOParams.TGA_Descriptor)^, Length(IOParams.TGA_Descriptor) + 1);
    if TGAHead.ColorMaptype = 1 then
      SafeStreamWrite(Stream, Progress.Aborting^, rc^.Palette256[0], (1 shl DestBitsPerPixel) * 3);
  end;
  //
  // convert to gray TempArrayDBIG (TBYTEROW)
  // only for 8bpp
  procedure TGAConvertToGray;
  var
    i: integer;
  begin
    for i := 0 to OutputWidth - 1 do
      with rc^, Palette256[TempArrayDBIG^[i]] do
        TempArrayDBIG^[i] := _RGBToGray(CreateRGB(r, g, b));
  end;
  //
  // compress TempArrayDBIG (TBYTEROW) and saves it in CompRow and then in the stream
  // implemented only for 8 and 24 bit
  procedure TGACompress;
  var
    p, bwidth: integer;
    l8: byte;
    l24: TRGB;
    l: byte;
    warr: pbyte;
  begin
    with rc^ do
    begin
      warr := pbyte(@CompRow[0]);
      p := 0;
      case DestBitsPerPixel of
        8: // encode 8 bit row (1 byte)
          begin
            bwidth := OutputWidth;
            repeat
              l8 := TempArrayDBIG^[p];
              inc(p);
              l := 1;
              while (p < bwidth) and (l8 = TempArrayDBIG^[p]) and (l < 128) do
              begin
                inc(p);
                inc(l);
              end;
              if l > 1 then
              begin
                // encode as run-length packet
                warr^ := $80 or (l - 1);
                inc(warr);
                warr^ := l8;
                inc(warr);
              end
              else
              begin
                // encode as raw packet
                dec(p);
                l := 0;
                while (p < bwidth - 1) and (TempArrayDBIG^[p] <> TemparrayDBIG^[p + 1]) and (l < 127) do
                begin
                  inc(p);
                  inc(l);
                end;
                if p = bwidth - 1 then
                begin
                  inc(p);
                  inc(l);
                end;
                warr^ := l - 1;
                inc(warr);
                CopyMemory(warr, @TempArrayDBIG^[p - l], l);
                inc(warr, l);
              end;
            until p >= bwidth;
          end;
        24: // encode 24 bit row (3 byte)
          begin
            bwidth := OutputWidth * 3;
            repeat
              l24 := PRGB(@TempArrayDBIG^[p])^;
              inc(p, 3);
              l := 1;
              while (p < bwidth) and equalrgb(l24, PRGB(@TempArrayDBIG^[p])^) and (l < 128) do
              begin
                inc(p, 3);
                inc(l);
              end;
              if l > 1 then
              begin
                // encode as run-length packet
                warr^ := $80 or (l - 1);
                inc(warr);
                PRGB(warr)^ := l24;
                inc(warr, 3);
              end
              else
              begin
                // encode as raw packet
                dec(p, 3);
                l := 0;
                while (p < bwidth - 3) and (not equalrgb(PRGB(@TempArrayDBIG^[p])^, PRGB(@TemparrayDBIG^[p + 3])^)) and (l < 127) do
                begin
                  inc(p, 3);
                  inc(l);
                end;
                if p = bwidth - 3 then
                begin
                  inc(p, 3);
                  inc(l);
                end;
                warr^ := l - 1;
                inc(warr);
                CopyMemory(warr, @TempArrayDBIG^[p - l * 3], l * 3);
                inc(warr, l * 3);
              end;
            until p >= bwidth;
          end;
      end;
      SafeStreamWrite(Stream, Progress.Aborting^, CompRow^[0], uint64(warr) - uint64(@CompRow[0]));
    end;
  end;
  //
  procedure TGAWriteBody;
  var
    i, l, x: integer;
    oarr, px, al, sp: pbyte;
  begin
    with rc^ do
    begin
      i := 0;
      Progress.per1 := 100 / OutputHeight;
      Progress.val := 0;

      if DestBitsPerPixel = 32 then
        getmem(oarr, XBitmap.Width * 4)
      else
        oarr := nil;

      try

        repeat
          TempArrayD := XBitMap.ScanLine[i];
          if DestBitsPerPixel = 32 then
            l := _ConvertXBitsToYBits(TempArrayD^, TempArrayDBIG^, OrigBitsPerPixel, 24, OutputWidth, Palette256, qt)
          else
            l := _ConvertXBitsToYBits(TempArrayD^, TempArrayDBIG^, OrigBitsPerPixel, DestBitsPerPixel, OutputWidth, Palette256, qt);
          if IOParams.TGA_GrayLevel and (DestBitsPerPixel = 8) then
            TGAConvertToGray;
          if IOParams.TGA_Compressed then
            TGACompress
          else
          begin
            if DestBitsPerPixel = 32 then
            begin
              // add and save alpha channel
              al := AlphaChannel.Scanline[i];
              px := oarr;
              sp := pbyte(TempArrayDBIG);
              for x := 0 to XBitmap.Width - 1 do
              begin
                px^ := sp^;
                inc(px);
                inc(sp);
                px^ := sp^;
                inc(px);
                inc(sp);
                px^ := sp^;
                inc(px);
                inc(sp);
                px^ := al^;
                inc(px);
                inc(al);
              end;
              SafeStreamWrite(Stream, Progress.Aborting^, oarr^, 4 * XBitmap.Width);
            end
            else
              SafeStreamWrite(Stream, Progress.Aborting^, TempArrayDBIG^[0], l);
          end;
          inc(i);
          with Progress do
          begin
            inc(val);
            if assigned(fOnProgress) then
              fOnProgress(Sender, trunc(per1 * val));
          end;
        until (i >= OutputHeight);

      finally
        if DestBitsPerPixel = 32 then
          freemem(oarr);
      end;

    end;
  end;
  //
  procedure TGAWriteExtension;
  var
    ms: word;
  begin
    with rc^, Extension do
    begin
      zeromemory(@Extension, sizeof(TGAExtension));
      IEStrCopy(AuthorName, PAnsiChar(IOParams.TGA_Author));
      IEStrCopy(JobName, PAnsiChar(IOParams.TGA_ImageName));
      DecodeDate(IOParams.TGA_Date, DateTime[2], DateTime[0], DateTime[1]);
      DecodeTime(IOParams.TGA_Date, DateTime[3], DateTime[4], DateTime[5], ms);
      KeyColor[0] := 0;
      KeyColor[1] := IOParams.TGA_Background.r;
      KeyColor[2] := IOParams.TGA_Background.g;
      KeyColor[3] := IOParams.TGA_Background.b;
      AspectRatio[0] := trunc(IOParams.TGA_AspectRatio) * 10000;
      AspectRatio[1] := 10000;
      Gamma[0] := trunc(IOParams.TGA_Gamma) * 10000;
      Gamma[1] := 10000;
      SafeStreamWrite(Stream, Progress.Aborting^, Extension, sizeof(TGAExtension));
      if DestBitsPerPixel = 32 then
        AttributesType := 0;
    end;
  end;
  //
  procedure TGAWriteFooter;
  begin
    with rc^ do
    begin
      Footer.Signature := 'TRUEVISION-XFILE.' + AnsiChar(0);
      Footer.DeveloperDir := 0;
      Footer.ExtensionArea := sbase + Stream.Position;
      TGAWriteExtension;
      SafeStreamWrite(Stream, Progress.Aborting^, Footer, sizeof(TGAFooter));
    end;
  end;
  //
var
  rgb1, rgb2: TRGB;
begin
  if (Bitmap.PixelFormat <> ie24RGB) and (Bitmap.PixelFormat <> ie1g) then
    exit;
  NullProgress := NullProgressRec( Progress.Aborting, False );
  XBitmap := Bitmap;
  qt := nil;
  new(rc);
  zeromemory(rc, sizeof(TRC));

  try

    with rc^ do
    begin
      // Write TARGA Stream.
      sbase := Stream.Position;
      Index1 := 0;
      Index2 := 0;
      if Bitmap.PixelFormat = ie24RGB then
        OrigBitsPerPixel := 24
      else
        OrigBitsPerPixel := 1;
      if IOParams.SamplesPerPixel = 1 then
      begin
        case IOParams.BitsPerSample of
          1:
            begin
              if OrigBitsPerPixel = 24 then
              begin
                XBitmap := _ConvertTo1bitEx(Bitmap, rgb1, rgb2);
                if XBitmap = nil then
                begin
                  // impossible to convert to 1 bit, converts from color to black/white
                  // 3.0.0
                  XBitmap := TIEBitmap.Create(Bitmap.Width, Bitmap.Height, ie1g);
                  XBitmap.CopyAndConvertFormat(Bitmap);
                end;
                OrigBitsPerPixel := 1;
              end;
              DestBitsPerPixel := 1;
              Palette256[0] := CreateRGB(0, 0, 0);
              Palette256[1] := CreateRGB(255, 255, 255);
              IOParams.TGA_Compressed := false;
            end;
          4:
            begin
              if OrigBitsPerPixel = 24 then
              begin
                IOParams.FreeColorMap;
                IOParams.fColorMapCount := 16;
                getmem(IOParams.fColorMap, 16 * 3);
                qt := TIEQuantizer.Create(Bitmap, IOParams.ColorMap^, 16);
                copymemory(@Palette256[0], IOparams.ColorMap, 16 * 3);
              end;
              DestBitsPerPixel := 4;
              IOParams.TGA_Compressed := false;
            end;
          8:
            begin
              if OrigBitsPerPixel = 24 then
              begin
                IOParams.FreeColorMap;
                IOParams.fColorMapCount := 256;
                getmem(IOParams.fColorMap, 256 * 3);
                qt := TIEQuantizer.Create(Bitmap, IOParams.ColorMap^, 256);
                copymemory(@Palette256[0], IOparams.ColorMap, 256 * 3);
              end;
              DestBitsPerPixel := 8;
            end;
        end;
      end
      else
      begin
        if assigned(AlphaChannel) then
        begin
          DestBitsPerPixel := 32;
          IOParams.TGA_Compressed := false; // alpha+compression not supported
        end
        else
          DestBitsPerPixel := 24;
      end;
      OutputWidth := XBitmap.Width;
      OutputHeight := XBitmap.Height;
      GetMem(NewLine, OutputWidth * 3);
      GetMem(TempArrayDBig, OutputWidth * 3);
      if IOParams.TGA_Compressed then
        GetMem(CompRow, OutputWidth * 3 * 3);
      try
        TGAWriteHeader;
        TGAWriteBody;
        TGAWriteFooter;
      finally
        FreeMem(TempArrayDBig);
        FreeMem(NewLine);
        if IOParams.TGA_Compressed then
          freemem(CompRow);
      end;
    end;

  finally

    dispose(rc);
    if XBitmap <> Bitmap then
      FreeAndNil(XBitmap);
    if assigned(qt) then
      FreeAndNil(qt);

  end;
end;

end.