{
Copyright (c) 2007-2023, Udo Schmal <udo.schmal@t-online.de>

Permission to use, copy, modify, and/or distribute the software for any purpose
with or without fee is hereby granted, provided that the above copyright notice
and this permission notice appear in all copies.

THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH
REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,
INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
PERFORMANCE OF THIS SOFTWARE.

https://www.gocher.me/FPWriteGIF
}

unit FPWriteGIF;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FPImage, FPReadGif;

type TColor = -$7FFFFFFF - 1..$7FFFFFFF;

const
// GIF record separators
  kGifImageSeparator: byte = $2c;
  kGifExtensionSeparator: byte = $21;
  kGifTerminator: byte = $3b;
  kGifLabelGraphic: byte = $f9;
  kGifBlockTerminator: byte = $00;
// LZW encode table sizes
  kGifCodeTableSize = 4096;
// Raw rgb value
  clNone = TColor($1FFFFFFF);
  AlphaOpaque = $FF;
  AlphaTransparent = 0;
  MaxArr = (MaxLongint div Sizeof(integer)) - 1;

type
  APixel8 = array[0..MaxArr] of Byte;
  PAPixel8 = ^APixel8;

  TRGBQuadArray256 = array[0..256] of TFPCompactImgRGBA8BitValue;
  TOpenColorTableArray = array of TColor;
  TColorTableArray = array[0..$FF] of TColor;

  TOctreeNode = class; // Forward definition so TReducibleNodes can be declared
  TReducibleNodes = array[0..7] of TOctreeNode;
  TOctreeNode = class(TObject)
    IsLeaf: Boolean;
    PixelCount: Integer;
    RedSum, GreenSum, BlueSum: Integer;
    Next: TOctreeNode;
    Child: TReducibleNodes;
    constructor Create(const Level: Integer; var LeafCount: Integer; var ReducibleNodes: TReducibleNodes);
    destructor Destroy; override;
  end;

  TFPWriterGIF = class(TFPCustomImageWriter)
  private
    fHeader: TGifHeader;
    fDescriptor: TGifImageDescriptor; // only one image supported
    fGraphicsCtrlExt: TGifGraphicsControlExtension;
    fTransparent: Boolean;
    fBackground: TColor;
    fPixels: PAPixel8;
    fPixelList: PChar; // decoded pixel indices
    fPixelCount: longint; // number of pixels
    fColorTable: TColorTableArray;
    fColorTableSize: integer;

    procedure SaveToStream(Destination: TStream);
  protected
    procedure InternalWrite(Stream: TStream; Img: TFPCustomImage); override;
  public
    constructor Create; override;
    destructor Destroy; override;
  end;

implementation
{$REGION ' - TOctreeNode - '}
constructor TOctreeNode.Create(const Level: Integer; var LeafCount: Integer; var ReducibleNodes: TReducibleNodes);
var i: Integer;
begin
  PixelCount := 0;
  RedSum := 0;
  GreenSum := 0;
  BlueSum := 0;
  for i := Low(Child) to High(Child) do
    Child[i] := nil;
  IsLeaf := (Level = 8);
  if IsLeaf then
  begin
    Next := nil;
    Inc(LeafCount);
  end
  else
  begin
    Next := ReducibleNodes[Level];
    ReducibleNodes[Level] := Self;
  end
end;

destructor TOctreeNode.Destroy;
var i: Integer;
begin
  for i := Low(Child) to High(Child) do
    Child[i].Free
end;
{$ENDREGION}

{$REGION ' - TFPWriterGIF. - '}
constructor TFPWriterGIF.Create;
begin
  inherited Create;
end;

destructor TFPWriterGIF.Destroy;
begin
  inherited Destroy;
end;

// save the current GIF definition to a stream object
// at first, just write it to our memory stream fSOURCE
procedure TFPWriterGIF.SaveToStream(Destination: TStream);
var
  LZWStream: TMemoryStream; // temp storage for LZW
  LZWSize: integer; // LZW minimum code size

  // these LZW encode routines sqrunch a bitmap into a memory stream
  procedure LZWEncode();
  var
    rPrefix: array[0..kGifCodeTableSize-1] of integer; // string prefixes
    rSuffix: array[0..kGifCodeTableSize-1] of integer; // string suffixes
    rCodeStack: array[0..kGifCodeTableSize-1] of byte; // encoded pixels
    rSP: integer; // pointer into CodeStack
    rClearCode: integer; // reset decode params
    rEndCode: integer; // last code in input stream
    rCurSize: integer; // current code size
    rBitString: integer; // steady stream of bits to be decoded
    rBits: integer; // number of valid bits in BitString
    rMaxVal: boolean; // max code value found?
    rCurX: integer; // position of next pixel
    rCurY: integer; // position of next pixel
    rCurPass: integer; // pixel line pass 1..4
    rFirstSlot: integer; // for encoding an image
    rNextSlot: integer; // for encoding
    rCount: integer; // number of bytes read/written
    rLast: integer; // last byte read in
    rUnget: boolean; // read a new byte, or use zLast?

    procedure LZWReset;
    var i: integer;
    begin
      for i := 0 to (kGifCodeTableSize - 1) do
      begin
        rPrefix[i] := 0;
        rSuffix[i] := 0;
      end;
      rCurSize := LZWSize + 1;
      rClearCode := (1 shl LZWSize);
      rEndCode := rClearCode + 1;
      rFirstSlot := (1 shl (rCurSize - 1)) + 2;
      rNextSlot := rFirstSlot;
      rMaxVal := false;
    end;

    // save a code value on the code stack
    procedure LZWSaveCode(Code: integer);
    begin
      rCodeStack[rSP] := Code;
      inc(rSP);
    end;

    // save the code in the output data stream
    procedure LZWPutCode(code: integer);
    var
      n: integer;
      b: byte;
    begin
      // write out finished bytes
      // a literal "8" for 8 bits per byte
      while (rBits >= 8) do
      begin
        b := (rBitString and $ff);
        rBitString := (rBitString shr 8);
        rBits := rBits - 8;
        LZWStream.Write(b, 1);
      end;
      // make sure no junk bits left above the first byte
      rBitString := (rBitString and $ff);
      // and save out-going code
      n := (code shl rBits);
      rBitString := (rBitString or n);
      rBits := rBits + rCurSize;
    end;

    // get the next pixel from the bitmap, and return it as an index into the colormap
    function LZWReadBitmap: integer;
    var
      n: integer;
      j: longint;
      p: PChar;
    begin
      if (rUnget) then
      begin
        n := rLast;
        rUnget := false;
      end
      else
      begin
        inc(rCount);
        j := (rCurY * fDescriptor.Width) + rCurX;
        if ((0 <= j) and (j < fPixelCount)) then
        begin
          p := fPixelList + j;
          n := ord(p^);
        end
        else
          n := 0;
        // if first pass, make sure CurPass was initialized
        if (rCurPass = 0) then rCurPass := 1;
        inc(rCurX); // inc X position
        if (rCurX >= fDescriptor.Width) then // bumping Y ?
        begin
          rCurX := 0;
          inc(rCurY);
        end;
      end;
      rLast := n;
      result := n;
    end;

  var
    i,n,
    cc: integer; // current code to translate
    oc: integer; // last code encoded
    found: boolean; // decoded string in prefix table?
    pixel: byte; // lowest code to search for
    ldx: integer; // last index found
    fdx: integer; // current index found
    b: byte;
  begin
    // init data block
    fillchar(rCodeStack, sizeof(rCodeStack), 0);
    rBitString := 0;
    rBits := 0;
    rCurX := 0;
    rCurY := 0;
    rCurPass := 0;
    rLast := 0;
    rUnget:= false;

    LZWReset;
    // all within the data record
    // always save the clear code first ...
    LZWPutCode(rClearCode);
    // and first pixel
    oc := LZWReadBitmap;
    LZWPutCode(oc);
    // nothing found yet (but then, we haven't searched)
    ldx := 0;
    fdx := 0;
    // and the rest of the pixels
    rCount := 1;
    while (rCount <= fPixelCount) do
    begin
      rSP := 0; // empty the stack of old data
      n := LZWReadBitmap; // next pixel from the bitmap
      LZWSaveCode(n);
      cc := rCodeStack[0]; // beginning of the string
      // add new encode table entry
      rPrefix[rNextSlot] := oc;
      rSuffix[rNextSlot] := cc;
      inc(rNextSlot);
      if (rNextSlot >= kGifCodeTableSize) then
        rMaxVal := true
      else if (rNextSlot > (1 shl rCurSize)) then
        inc(rCurSize);
      // find the running string of matching codes
      ldx := cc;
      found := true;
      while (found and (rCount <= fPixelCount)) do
      begin
        n := LZWReadBitmap;
        LZWSaveCode(n);
        cc := rCodeStack[0];
        if (ldx < rFirstSlot) then
          i := rFirstSlot
        else
          i := ldx + 1;
        pixel := rCodeStack[rSP - 1];
        found := false;
        while ((not found) and (i < rNextSlot)) do
        begin
          found := ((rPrefix[i] = ldx) and (rSuffix[i] = pixel));
          inc(i);
        end;
        if (found) then
        begin
          ldx := i - 1;
          fdx := i - 1;
        end;
      end;
      // if not found, save this index, and get the same code again
      if (not found) then
      begin
        rUnget := true;
        rLast := rCodeStack[rSP-1];
        dec(rSP);
        cc := ldx;
      end
      else
        cc := fdx;
      // whatever we got, write it out as current table entry
      LZWPutCode(cc);
      if ((rMaxVal) and (rCount <= fPixelCount)) then
      begin
        LZWPutCode(rClearCode);
        LZWReset;
        cc := LZWReadBitmap;
        LZWPutCode(cc);
      end;
      oc := cc;
    end;
    LZWPutCode(rEndCode);
    // write out the rest of the bit string
    while (rBits > 0) do
    begin
      b := (rBitString and $ff);
      rBitString := (rBitString shr 8);
      rBits := rBits - 8;
      LZWStream.Write(b, 1);
    end;
  end;

var i: integer;
begin
  Destination.Position := 0;
  with fHeader do
  begin
    // write the GIF signature
    // if only one image, and no image extensions, then GIF is GIF87a,
    // else use the updated version GIF98a
    // we just added an extension block; the signature must be version 89a
    Destination.Write(Signature, 3);
    Destination.Write(Version, 3);
    // write the overall GIF screen description to the source stream
    Destination.Write(ScreenWidth, 2); // logical screen width
    Destination.Write(ScreenHeight, 2); // logical screen height
    Destination.Write(Packedbit, 1); // packed bit fields (Global Color valid, Global Color size, Sorted, Color Resolution)
    Destination.Write(BackgroundColor, 1); // background color
    Destination.Write(AspectRatio, 1); // pixel aspect ratio
    if (Packedbit and $80)>0 then //Global Color valid
      // write out color gobal table with RGB values
      for i := 0 to fColorTableSize-1 do
        Destination.Write(fColorTable[i], 3);
  end;
  // write out graphic extension for this image
  Destination.Write(kGifExtensionSeparator, 1); // write the extension separator
  Destination.Write(kGifLabelGraphic, 1); // write the extension label
  Destination.Write(fGraphicsCtrlExt.BlockSize, 1); // block size (always 4)
  Destination.Write(fGraphicsCtrlExt.Packedbit, 1); // packed bit field
  Destination.Write(fGraphicsCtrlExt.DelayTime, 2); // delay time
  Destination.Write(fGraphicsCtrlExt.ColorIndex, 1); // transparent color
  Destination.Write(fGraphicsCtrlExt.Terminator, 1); // block terminator
  // write actual image data
  Destination.Write(kGifImageSeparator, 1);
  // write the next image descriptor shortcut to the record fields
  with fDescriptor do
  begin
    // write the basic descriptor record
    Destination.Write(Left, 2); // left position
    Destination.Write(Top, 2); // top position
    Destination.Write(Width, 2); // size of image
    Destination.Write(Height, 2); // size of image
    Destination.Write(Packedbit, 1); // packed bit field
    // there is no local color table defined we use global
    LZWSize := 8; // the LZW minimum code size
    Destination.Write(LZWSize, 1);
    LZWStream := TMemoryStream.Create; // init the storage for compressed data
    try
      LZWEncode(); // encode the image and save it in LZWStream
      // write out the data stream as a series of data blocks
      LZWStream.Position := 0;
      while (LZWStream.Position < LZWStream.Size) do
      begin
        i := LZWStream.Size - LZWStream.Position;
        if (i > 255) then i := 255;
        Destination.Write(i, 1);
        Destination.CopyFrom(LZWStream, i);
      end;
    finally
      FreeAndNil(LZWStream);
    end;
    Destination.Write(kGifBlockTerminator, 1); // block terminator
  end;
  Destination.Write(kGifTerminator, 1); // done with writing
end;

procedure TFPWriterGIF.InternalWrite(Stream: TStream; Img: TFPCustomImage);
var
  CT: TOpenColorTableArray;
  Palette: TList;
  PaletteHasAllColours: Boolean;
  Mappings: array[BYTE, BYTE] of TList;
  Tree: TOctreeNode;
  LeafCount: Integer;
  ReducibleNodes: TReducibleNodes;
  LastColor: TColor;
  LastColorIndex: Byte;

  // convert TFPCustomImage TFPColor to TColor
  function FPColorToTColor(const FPColor: TFPColor): TColor;
  begin
    result := TColor(((FPColor.Red shr 8) and $ff) or (FPColor.Green and $ff00) or ((FPColor.Blue shl 8) and $ff0000));
  end;

  // try to make color table of all colors
  function MakeColorTableOfAllColors(): Boolean;
  var
    Flags: array[Byte, Byte] of TBits;
    x, y, ci: Cardinal;
    Red, Green, Blue: Byte;
    Cnt: word;
  begin
    result := false;
    // init Flags
    for y := 0 to $FF do
      for x := 0 to $FF do
        Flags[x, y] := nil;
    try
      for ci := 0 to $ff do
        CT[ci] := 0;
      Cnt := 0;
      for y := 0 to Img.Height - 1 do
        for x := 0 to Img.Width - 1 do
        begin
          Red := Byte(Img.Colors[x, y].red shr 8);
          Green := Byte(Img.Colors[x, y].green shr 8);
          Blue := Byte(Img.Colors[x, y].blue shr 8);
          if (Flags[Red, Green]) = nil then
          begin
            Flags[Red, Green] := Classes.TBits.Create;
            Flags[Red, Green].Size := 256;
          end;
          if not Flags[Red, Green].Bits[Blue] then
          begin
            CT[Cnt] := FPColorToTColor(Img.Colors[x, y]);
            if Cnt = $ff then exit;
            inc(Cnt);
            Flags[Red, Green].Bits[Blue] := true;
          end;
        end;
      result := true;
      PaletteHasAllColours := true;
    finally // free Flags
      for y := 0 to $FF do
        for x := 0 to $FF do
          if Flags[x, y] <> nil then
            FreeAndNil(Flags[x, y]);
    end;
    fColorTableSize := High(CT) + 1;
    for x := 0 to fColorTableSize - 1 do
      fColorTable[x] := CT[x];
    LastColor := clNone;
  end;

  procedure MakeColorTableofReducedColors();
    procedure AddColor(var Node: TOctreeNode; const r, g, b: Byte; const Level: Integer; var ReducibleNodes: TReducibleNodes);
    const mask: array[0..7] of Byte = ($80, $40, $20, $10, $08, $04, $02, $01);
    var Index, Shift: Integer;
    begin
      if Node = nil then
        Node := TOctreeNode.Create(Level, LeafCount, ReducibleNodes);
      if Node.IsLeaf then
      begin
        Inc(Node.PixelCount);
        Inc(Node.RedSum, r);
        Inc(Node.GreenSum, g);
        Inc(Node.BlueSum, b)
      end
      else
      begin
        Shift := 7 - Level;
        Index := (((r and mask[Level]) shr Shift) shl 2) or (((g and mask[Level]) shr Shift) shl 1) or
          ((b and mask[Level]) shr Shift);
        AddColor(Node.Child[Index], r, g, b, Level + 1, ReducibleNodes)
      end
    end;

    procedure ReduceTree(var LeafCount: Integer; var ReducibleNodes: TReducibleNodes);
    var
      RedSum, BlueSum, GreenSum, Children, i: Integer;
      Node: TOctreeNode;
    begin
      i := 7;
      while (i > 0) and (ReducibleNodes[i] = nil) do
        dec(i);
      Node := ReducibleNodes[i];
      ReducibleNodes[i] := Node.Next;
      RedSum := 0;
      GreenSum := 0;
      BlueSum := 0;
      Children := 0;
      for i := Low(ReducibleNodes) to High(ReducibleNodes) do
        if Node.Child[i] <> nil then
        begin
          Inc(RedSum, Node.Child[i].RedSum);
          Inc(GreenSum, Node.Child[i].GreenSum);
          Inc(BlueSum, Node.Child[i].BlueSum);
          Inc(Node.PixelCount, Node.Child[i].PixelCount);
          Node.Child[i].Free;
          Node.Child[i] := nil;
          inc(Children)
        end;
      Node.IsLeaf := true;
      Node.RedSum := RedSum;
      Node.GreenSum := GreenSum;
      Node.BlueSum := BlueSum;
      Dec(LeafCount, Children - 1)
    end;

    procedure GetPaletteColors(const Node: TOctreeNode; var RGBQuadArray: TRGBQuadArray256; var Index: integer);
    var i: integer;
    begin
      if Node.IsLeaf then
      begin
        with RGBQuadArray[Index] do
        begin
          try
            r := Byte(Node.RedSum div Node.PixelCount);
            g := Byte(Node.GreenSum div Node.PixelCount);
            b := Byte(Node.BlueSum div Node.PixelCount);
            a := 0;
          except
            r := 0;
            g := 0;
            b := 0;
            a := 0;
          end;
          a := 0
        end;
        inc(Index);
      end
      else
        for i := Low(Node.Child) to High(Node.Child) do
          if Node.Child[i] <> nil then
            GetPaletteColors(Node.Child[i], RGBQuadArray, Index)
    end;

    procedure SetPalette(Pal: array of TColor; Size: integer);
    var
      PalSize, i: integer;
      Col: PFPCompactImgRGB8BitValue;
      x, y: Cardinal;
      Red, Green, Blue: Byte;
      Pcol: PInteger;
      DistanceSquared, SmallestDistanceSquared: integer;
      R1, G1, B1: Byte;
    begin
      if Size <> -1 then PalSize := Size else PalSize := High(Pal) + 1;
      for i := 0 to PalSize - 1 do
      begin
        GetMem(Col, SizeOf(TFPCompactImgRGB8BitValue));
        Col^.r := Byte(Pal[i]);
        Col^.g := Byte(Pal[i] shr 8);
        Col^.b := Byte(Pal[i] shr 16);
        Palette.Add(Col);
      end;
      for y := 0 to $ff do
        for x := 0 to $ff do
          Mappings[y,x] := nil;
      for y := 0 to Img.Height - 1 do
        for x := 0 to Img.Width - 1 do
        begin
          Red := Byte(Img.Colors[x, y].red shr 8);
          Green := Byte(Img.Colors[x, y].green shr 8);
          Blue := Byte(Img.Colors[x, y].blue shr 8);
          //Small reduction of color space
          dec(Red, Red mod 3);
          dec(Green, Green mod 3);
          dec(Blue, Blue mod 3);
          if (Mappings[Red, Green]) = nil then
          begin
            Mappings[Red, Green] := TList.Create;
            Mappings[Red, Green].Count := 256;
          end;
          if (Mappings[Red, Green].Items[Blue] = nil) then
          begin
            GetMem(Pcol, SizeOf(integer));
            PCol^ := 0;
            SmallestDistanceSquared := $1000000;
            for i := 0 to Palette.Count - 1 do
            begin
              R1 := PFPCompactImgRGB8BitValue(Palette[i])^.r;
              G1 := PFPCompactImgRGB8BitValue(Palette[i])^.g;
              B1 := PFPCompactImgRGB8BitValue(Palette[i])^.b;
              DistanceSquared := (Red - R1) * (Red - R1) + (Green - G1) * (Green - G1) + (Blue - B1) * (Blue - B1);
              if DistanceSquared < SmallestDistanceSquared then
              begin
                PCol^ := i;
                if (Red = R1) and (Green = G1) and (Blue = B1) then break;
                SmallestDistanceSquared := DistanceSquared;
              end
            end;
            Mappings[Red, Green].Items[Blue] := PCol;
          end;
        end;
    end;

    procedure DeleteTree(var Node: TOctreeNode);
    var i: integer;
    begin
      for i := Low(TReducibleNodes) to High(TReducibleNodes) do
        if Node.Child[i] <> nil then
          DeleteTree(Node.Child[i]);
      FreeAndNil(Node);
    end;

  var
    i, j, Index: integer;
    QArr: TRGBQuadArray256;
  begin
    PaletteHasAllColours := false;
    Tree := nil;
    LeafCount := 0;
    for i := Low(ReducibleNodes) to High(ReducibleNodes) do
      ReducibleNodes[i] := nil;
    if (Img.Height > 0) and (Img.Width > 0) then
      for j := 0 to Img.Height - 1 do
        for i := 0 to Img.Width - 1 do
        begin
          AddColor(Tree, Byte(Img.Colors[i,j].red shr 8), Byte(Img.Colors[i,j].green shr 8), Byte(Img.Colors[i,j].blue shr 8), 0, ReducibleNodes);
          while LeafCount > 256 do
            ReduceTree(LeafCount, ReducibleNodes)
        end;
    Index := 0;
    GetPaletteColors(Tree, QArr, Index);
    for i := 0 to LeafCount - 1 do
      CT[i] := (QArr[i].b shl 16) + (QArr[i].g shl 8) + QArr[i].r;
    fColorTableSize := LeafCount;
    for i := 0 to fColorTableSize - 1 do
      fColorTable[i] := CT[i];
    LastColor := clNone;
    SetPalette(fColorTable, LeafCount);
    if Tree <> nil then DeleteTree(Tree);
  end;

  procedure ClearMappings;
  var i, j, k: integer;
  begin
    { wp: Avoids crash at FreeMem - may result in a memory leak !!!!
    for j := 0 to $FF do
      for i := 0 to $FF do
      begin
        if Assigned(Mappings[i, j]) then
        begin
          for k := 0 to $FF do
            FreeMem(Mappings[i, j].Items[k], SizeOf(TColor));
          Mappings[i, j].Free;
        end;
        Mappings[i, j] := nil;
      end;
      }
  end;

  procedure SetPixel(X, Y: Integer; Value: TColor);
  var
    Val: integer;
    PCol: PInteger;
    R, G, B: byte;
  begin
    if not ((Img.Width >= X) and (Img.Height >= Y) and (X > -1) and (Y > -1)) then exit;
    Val := -1;
    if LastColor = Value then
      Val := LastColorIndex
    else
    begin
      if PaletteHasAllColours then
      begin
        TFPCompactImgRGBA8BitValue(Value).a := 0;
        for Val := 0 to fColorTableSize - 1 do
          if fColorTable[Val] = Value then break;
      end
      else
      begin
        B := Byte(Value shr 16);
        B := B - (B mod 3);
        G := Byte(Value shr 8);
        G := G - (G mod 3);
        R := Byte(Value);
        R := R - (R mod 3);
        Val := -1;
        if Mappings[R, G] <> nil then
        begin
          PCol := Mappings[R, G].Items[B];
          if PCol <> nil then Val := PCol^;
        end;
      end;
      LastColor := Value;
      LastColorIndex := Val;
    end;
    fPixels^[Y * Img.Width + X] := Val;
  end;

  // find the color within the color table; returns 0..255, -1 if color not found
  function FindColorIndex(c: TColor): integer;
  var i: integer;
  begin
    i := 0;
    result := -1;
    while (i<fColorTableSize) and (result < 0) do
    begin
      if (fColorTable[i] = c) then result := i;
      inc(i);
    end;
  end;

  function lsb(w: word): byte;
  begin
    result := 0;
    while ((w shr result) and 1) = 0 do inc(result);
  end;

var
  x, y: cardinal;
  i, n, ci: integer;
  b: byte;
  pptr: PChar;
begin
  if not ((Img.Width < 1) or (Img.Height < 1)) then
  try
    fTransparent := false;
    // translate 64bit image to 8bit colortable image
    Palette := TList.Create;
    fColorTableSize := 0;
    SetLength(CT, 256);
    //try to make optimized palette on original Data.
    if not MakeColorTableOfAllColors() then
      MakeColorTableofReducedColors(); // to mutch colors, reduce colors
    GetMem(fPixels, Img.Height * Img.Width);
    for y := 0 to Img.Height - 1 do
      for x := 0 to Img.Width - 1 do
      begin
        SetPixel(x, y, FPColorToTColor(Img.Colors[x, y]));
        if not fTransparent then
          if Img.Colors[x, y].alpha = AlphaTransparent then
          begin
            fBackground := FPColorToTColor(Img.Colors[x, y]);
            fTransparent := true;
          end;
      end;
    // color count must be a power of 2
    if (fColorTableSize <= 2) then fColorTableSize := 2
    else if (fColorTableSize <= 4) then fColorTableSize := 4
    else if (fColorTableSize <= 8) then fColorTableSize := 8
    else if (fColorTableSize <= 16) then fColorTableSize := 16
    else if (fColorTableSize <= 32) then fColorTableSize := 32
    else if (fColorTableSize <= 64) then fColorTableSize := 64
    else if (fColorTableSize <= 128) then fColorTableSize := 128
    else fColorTableSize := 256;
  finally
    for i := 0 to Palette.Count - 1 do
      FreeMem(Palette[i], SizeOf(TFPCompactImgRGB8BitValue));
    Palette.Clear;
    ClearMappings;
    Palette.Free;
  end;

  // create a new gif image record from the given 8bit colortable image
  with fHeader do
  begin
    Signature := 'GIF';
    Version := '89a';
    ScreenWidth := Img.Width;
    ScreenHeight := Img.Height;
    b := lsb(fColorTableSize)-1;
    Packedbit := (Packedbit and $8F) or (b shl 4); // Color Resolution
    Packedbit := (Packedbit and $F7); // not sorted
    Packedbit := (Packedbit and $F8) or b;
    BackgroundColor := 0;
    Packedbit := Packedbit or $80; // Global Color valid
  end;

  // make a descriptor record, color map for this image, and space for a pixel list
  with fDescriptor do
  begin
    Left := 0;
    Top := 0;
    Width := Img.Width;
    Height := Img.Height;
    Packedbit := 0; // or $80 = but non local Color Table; or $40 = but not interlaced; or $20 but not sorted
  end;

  fPixelList := nil; // make empty pixel list
  fPixelCount := Img.Width * Img.Height;
  fPixelList := allocmem(fPixelCount);
  if (fPixelList = nil) then OutOfMemoryError;
  // and the color table
  // the first call attempts to use all colors in the bitmap
  // if too many colors, the 2nd call uses only most significat 8 bits of color
  for ci:=0 to fPixelCount-1 do
  begin
    pptr := fPixelList + ci;
    pptr^ := Chr(fPixels^[ci]);
  end;

  // set transparency for this image
  with fGraphicsCtrlExt do
  begin
    BlockSize := 4;
    Packedbit := $00;
    ColorIndex := 0;
    if (fTransparent) then
    begin
      n := FindColorIndex(fBackground);
      if (n < 0) then n := FindColorIndex(fBackground and $00E0E0E0);
      if (n < 0) then n := FindColorIndex(fBackground and $00C0E0E0);
      if (n > -1) then
      begin
        Packedbit := Packedbit or $01; // transparent color given (Packedbit or $01)
        ColorIndex := n; //transparent color index
      end;
    end;
    DelayTime := 0;
    Terminator := 0; // allways 0
  end;

  SaveToStream(Stream);

  if (fPixelList <> nil) then FreeMem(fPixelList);
  FreeMem(fPixels);
  fPixels := nil;
end;
{$ENDREGION}

initialization
  ImageHandlers.RegisterImageWriter ('GIF Graphics', 'gif', TFPWriterGif);
end.