unit dgifwriter;

//
// gif.h
// by Charlie Tangora
// Public domain.
// Email me : ctangora -at- gmail -dot- com
//
// This file offers a simple, very limited way to create animated GIFs directly in code.
//
// Those looking for particular cleverness are likely to be disappointed; it's pretty
// much a straight-ahead implementation of the GIF format with optional Floyd-Steinberg
// dithering. (It does at least use delta encoding - only the changed portions of each
// frame are saved.)
//
// So resulting files are often quite large. The hope is that it will be handy nonetheless
// as a quick and easily-integrated way for programs to spit out animations.
//
// Only RGBA8 is currently supported as an input format. (The alpha is ignored.)
//
// If capturing a buffer with a bottom-left origin (such as OpenGL), define GIF_FLIP_VERT
// to automatically flip the buffer data when writing the image (the buffer itself is
// unchanged.
//
// USAGE:
// Create a GifWriter struct. Pass it to GifBegin() to initialize and write the header.
// Pass subsequent frames to GifWriteFrame().
// Finally, call GifEnd() to close the file handle and free memory.
//

{$MODE FPC}
{$MODESWITCH RESULT}
{$MODESWITCH DEFAULTPARAMETERS}

interface

type
TFile = file of Byte;
PFile = ^TFile;

PGifWriter = ^TGifWriter;
TGifWriter = record
  f: PFile;
  fholder: TFile;
  oldImage: PUInt8;
  firstFrame: Boolean;
end;

function GifBegin(writer: PGifWriter; filename: PAnsiChar; width, height, delay: UInt32; bitDepth: Int32 = 8; dither: Boolean = false): Boolean;
// Creates a gif file.
// The input GIFWriter is assumed to be uninitialized.
// The delay value is the time between frames in hundredths of a second - note that not all viewers pay much attention to this value.

function GifWriteFrame(writer: PGifWriter; image: PUInt8; width, height, delay: UInt32; bitDepth: PtrInt = 8; dither: Boolean = false): Boolean;
// Writes out a new frame to a GIF in progress.
// The GIFWriter should have been created by GIFBegin.
// AFAIK, it is legal to use different bit depths for different frames of an image -
// this may be handy to save bits in animations that don't change much.

function GifEnd(writer: PGifWriter): Boolean;
// Writes the EOF code, closes the file handle, and frees temp memory used by a GIF.
// Many if not most viewers will still display a GIF properly if the EOF code is missing,
// but it's still a good idea to write it out.

implementation

function fopen_wb(filename: PAnsiChar; var Holder: TFile): PFile;
begin
  Assign(Holder, filename);
  {$push} {$I-}
  Rewrite(Holder);
  {$pop}
  if IOResult <> 0 then
    Exit(nil);
  Exit(@Holder);
end;

procedure fclose(F: PFile);
begin
  {$push} {$I-}
  Close(F^);
  {$pop}
end;

function fputc(character: Byte; f: PFile): PtrInt;
begin
  BlockWrite(f^, character, 1, Result);
end;

function fwrite(p: Pointer; Size: SizeInt; Count: SizeInt; f: PFile): SizeInt;
begin
  BlockWrite(f^, p^, Size * Count, Result);
end;

function fputs(str: PAnsiChar; f: PFile): PtrInt;
begin
  BlockWrite(f^, str^, StrLen(str), Result);
end;

// Define these macros to hook into a custom memory allocator.
// TEMP_MALLOC and TEMP_FREE will only be called in stack fashion - frees in the reverse order of mallocs
// and any temp memory allocated by a function will be freed before it exits.
// MALLOC and FREE are used only by GifBegin and GifEnd respectively (to allocate a buffer the size of the image, which
// is used to find changed pixels for delta-encoding.)

{$IF not Declared(GIF_TEMP_MALLOC)}
function GIF_TEMP_MALLOC(Size: SizeUInt): Pointer; inline;
begin
  Result := GetMem(Size);
end;
{$ENDIF}

{$IF not Declared(GIF_TEMP_FREE)}
procedure GIF_TEMP_FREE(P: Pointer); inline;
begin
  FreeMem(P);
end;
{$ENDIF}

{$IF not Declared(GIF_MALLOC)}
function GIF_MALLOC(Size: SizeUInt): Pointer; inline;
begin
  Result := GetMem(Size);
end;
{$ENDIF}

{$IF not Declared(GIF_FREE)}
procedure GIF_FREE(P: Pointer); inline;
begin
  FreeMem(P);
end;
{$ENDIF}

const
  kGifTransIndex = 0;

type
PGifPalette = ^TGifPalette;
TGifPalette = record
  bitDepth: PtrInt;

  r: array[0 .. 256 - 1] of Byte;
  g: array[0 .. 256 - 1] of Byte;
  b: array[0 .. 256 - 1] of Byte;

  // k-d tree over RGB space, organized in heap fashion
  // i.e. left child of node i is node i*2, right child is node i*2+1
  // nodes 256-511 are implicitly the leaves, containing a color
  treeSplitElt: array[0 .. 255 - 1] of Byte;
  treeSplit: array[0 .. 255 - 1] of Byte;
end;

// max, min, and abs functions
function GifIMax(l, r: PtrInt): PtrInt; inline;
begin
  if l > r then begin
    Exit(l);
  end else
    Exit(r);
end;

function GifIMin(l, r: PtrInt): PtrInt; inline;
begin
  if l < r then begin
    Exit(l);
  end else
    Exit(r);
end;

function GifIAbs(i: PtrInt): PtrInt;
begin
  Exit(Abs(i));
end;

// walks the k-d tree to pick the palette entry for a desired color.
// Takes as in/out parameters the current best color and its error -
// only changes them if it finds a better color in its subtree.
// this is the major hotspot in the code at the moment.
procedure GifGetClosestPaletteColor(pPal: PGifPalette; r, g, b: PtrInt; var bestInd: PtrInt; var bestDiff: PtrInt; treeRoot: PtrInt = 1);
var
  ind: PtrInt;
  r_err, g_err, b_err, diff: PtrInt;
  comps: array[0 .. 3 - 1] of PtrInt;
  splitComp: PtrInt;
  splitPos: PtrInt;
begin
  // base case, reached the bottom of the tree
  if treeRoot > (1 shl pPal^.bitDepth) - 1 then begin
    ind := treeRoot - (1 shl pPal^.bitDepth);
    if ind = kGifTransIndex then
      Exit;

    // check whether this color is better than the current winner
    r_err := r - Int32(pPal^.r[ind]);
    g_err := g - Int32(pPal^.g[ind]);
    b_err := b - Int32(pPal^.b[ind]);
    diff := GifIAbs(r_err) + GifIAbs(g_err) + GifIAbs(b_err);

    if diff < bestDiff then begin
      bestInd := ind;
      bestDiff := diff;
    end;

    Exit;
  end;

  // take the appropriate color (r, g, or b) for this node of the k-d tree
  comps[0] := r;
  comps[1] := g;
  comps[2] := b;
  splitComp := comps[pPal^.treeSplitElt[treeRoot]];

  splitPos := pPal^.treeSplit[treeRoot];
  if splitPos > splitComp then begin
    // check the left subtree
    GifGetClosestPaletteColor(pPal, r, g, b, bestInd, bestDiff, treeRoot * 2);
    if bestDiff > splitPos - splitComp then begin
      // cannot prove there's not a better value in the right subtree, check that too
      GifGetClosestPaletteColor(pPal, r, g, b, bestInd, bestDiff, treeRoot * 2 + 1);
    end;
  end else begin
    GifGetClosestPaletteColor(pPal, r, g, b, bestInd, bestDiff, treeRoot * 2 + 1);
    if bestDiff > splitComp - splitPos then begin
      GifGetClosestPaletteColor(pPal, r, g, b, bestInd, bestDiff, treeRoot * 2);
    end;
  end;
end;

procedure GifSwapPixels(image: PUInt8; pixA: PtrInt; pixB: PtrInt);
var
  rA, gA, bA, aA: Uint8;
  rB, gB, bB, aB: Uint8;
begin
  rA := image[pixA * 4];
  gA := image[pixA * 4 + 1];
  bA := image[pixA * 4 + 2];
  aA := image[pixA * 4 + 3];

  rB := image[pixB * 4];
  gB := image[pixB * 4 + 1];
  bB := image[pixB * 4 + 2];
  aB := image[pixA * 4 + 3];

  image[pixA * 4]     := rB;
  image[pixA * 4 + 1] := gB;
  image[pixA * 4 + 2] := bB;
  image[pixA * 4 + 3] := aB;

  image[pixB * 4]     := rA;
  image[pixB * 4 + 1] := gA;
  image[pixB * 4 + 2] := bA;
  image[pixB * 4 + 3] := aA;
end;

// just the partition operation from quicksort
function GifPartition(image: PUInt8; left, right, elt, pivotIndex: PtrInt): PtrInt;
var
  pivotValue: PtrInt;
  storeIndex: PtrInt;
  split: Boolean;
  ii: PtrInt;
  arrayVal: PtrInt;
begin
  pivotValue := image[pivotIndex * 4 + elt];
  GifSwapPixels(image, pivotIndex, right - 1);
  storeIndex := left;
  split := False;
  for ii := left to right - 1 - 1 do begin
    arrayVal := image[ii * 4 + elt];
    if arrayVal < pivotValue then begin
      GifSwapPixels(image, ii, storeIndex);
      Inc(storeIndex);
    end else if arrayVal = pivotValue then begin
      if split then begin
        GifSwapPixels(image, ii, storeIndex);
        Inc(storeIndex);
      end;
      split := not split;
    end;
  end;
  GifSwapPixels(image, storeIndex, right - 1);
  Exit(storeIndex);
end;

// Perform an incomplete sort, finding all elements above and below the desired median
procedure GifPartitionByMedian(image: PUInt8; left, right, com, neededCenter: PtrInt);
var
  pivotIndex: PtrInt;
begin
  if left < right - 1 then begin
    pivotIndex := left + (right - left) div 2;

    pivotIndex := GifPartition(image, left, right, com, pivotIndex);

    // Only "sort" the section of the array that contains the median
    if pivotIndex > neededCenter then
      GifPartitionByMedian(image, left, pivotIndex, com, neededCenter);

    if pivotIndex < neededCenter then
      GifPartitionByMedian(image, pivotIndex+1, right, com, neededCenter);
  end;
end;

// Builds a palette by creating a balanced k-d tree of all pixels in the image
procedure GifSplitPalette(image: PUInt8; numPixels, firstElt, lastElt, splitElt, splitDist, treeNode: PtrInt; buildForDither: Boolean; pal: PGifPalette);
var
  r32, g32, b32: UInt32;
  ii: PtrInt;
  r64, g64, b64: UInt64;
  r, g, b: PtrInt;
  minR, maxR, minG, maxG, minB, maxB: PtrInt;
  rRange, gRange, bRange: PtrInt;
  splitCom: PtrInt;
  subPixelsA: PtrInt;
  subPixelsB: PtrInt;
begin
  if (lastElt <= firstElt) or (numPixels = 0) then
    Exit;

  // base case, bottom of the tree
  if lastElt = firstElt + 1 then begin
    if buildForDither then begin
      // Dithering needs at least one color as dark as anything
      // in the image and at least one brightest color -
      // otherwise it builds up error and produces strange artifacts
      if firstElt = 1 then begin
        // special case: the darkest color in the image
        r32 := 255;
        g32 := 255;
        b32 := 255;
        for ii := 0 to numPixels - 1 do begin
          r32 := UInt32(GifIMin(Int32(r32), image[ii * 4 + 0]));
          g32 := UInt32(GifIMin(Int32(g32), image[ii * 4 + 1]));
          b32 := UInt32(GifIMin(Int32(b32), image[ii * 4 + 2]));
        end;

        pal^.r[firstElt] := UInt8(r32);
        pal^.g[firstElt] := UInt8(g32);
        pal^.b[firstElt] := UInt8(b32);

        Exit;
      end;

      if firstElt = (1 shl pal^.bitDepth) - 1 then begin
        // special case: the lightest color in the image
        r32 := 0;
        g32 := 0;
        b32 := 0;
        for ii := 0 to numPixels - 1 do begin
          r32 := UInt32(GifIMax(Int32(r32), image[ii * 4 + 0]));
          g32 := UInt32(GifIMax(Int32(g32), image[ii * 4 + 1]));
          b32 := UInt32(GifIMax(Int32(b32), image[ii * 4 + 2]));
        end;

        pal^.r[firstElt] := UInt8(r32);
        pal^.g[firstElt] := UInt8(g32);
        pal^.b[firstElt] := UInt8(b32);

        Exit;
      end;
    end;

    // otherwise, take the average of all colors in this subcube
    r64 := 0;
    g64 := 0;
    b64 := 0;
    for ii := 0 to numPixels - 1 do begin
      Inc(r64, image[ii * 4 + 0]);
      Inc(g64, image[ii * 4 + 1]);
      Inc(b64, image[ii * 4 + 2]);
    end;

    Inc(r64, UInt64(numPixels) div 2);  // round to nearest
    Inc(g64, UInt64(numPixels) div 2);
    Inc(b64, UInt64(numPixels) div 2);

    r64 := r64 div UInt64(numPixels);
    g64 := g64 div UInt64(numPixels);
    b64 := b64 div UInt64(numPixels);

    pal^.r[firstElt] := UInt8(r64);
    pal^.g[firstElt] := UInt8(g64);
    pal^.b[firstElt] := UInt8(b64);

    Exit;
  end;

  // Find the axis with the largest range
  minR := 255;
  maxR := 0;
  minG := 255;
  maxG := 0;
  minB := 255;
  maxB := 0;
  for ii := 0 to numPixels - 1 do begin
    r := image[ii * 4 + 0];
    g := image[ii * 4 + 1];
    b := image[ii * 4 + 2];

    if r > maxR then
      maxR := r;
    if r < minR then
      minR := r;

    if g > maxG then
      maxG := g;
    if g < minG then
      minG := g;

    if b > maxB then
      maxB := b;
    if b < minB then
      minB := b;
  end;

  rRange := maxR - minR;
  gRange := maxG - minG;
  bRange := maxB - minB;

  // and split along that axis. (incidentally, this means this isn't a "proper" k-d tree but I don't know what else to call it)
  splitCom := 1;
  if bRange > gRange then
    splitCom := 2;
  if (rRange > bRange) and (rRange > gRange) then
    splitCom := 0;

  subPixelsA := numPixels * (splitElt - firstElt) div (lastElt - firstElt);
  subPixelsB := numPixels - subPixelsA;

  GifPartitionByMedian(image, 0, numPixels, splitCom, subPixelsA);

  pal^.treeSplitElt[treeNode] := UInt8(splitCom);
  pal^.treeSplit[treeNode] := image[subPixelsA * 4 + splitCom];

  GifSplitPalette(image,              subPixelsA, firstElt, splitElt, splitElt - splitDist, splitDist div 2, treeNode * 2,   buildForDither, pal);
  GifSplitPalette(image + subPixelsA * 4, subPixelsB, splitElt, lastElt,  splitElt+splitDist, splitDist div 2, treeNode * 2 + 1, buildForDither, pal);
end;

// Finds all pixels that have changed from the previous image and
// moves them to the front of the buffer.
// This allows us to build a palette optimized for the colors of the
// changed pixels only.
function GifPickChangedPixels(lastFrame: PUInt8; frame: PUInt8; numPixels: PtrInt): PtrInt;
var
  numChanged: PtrInt;
  writeIter: PUInt8;
  ii: PtrInt;
begin
  numChanged := 0;
  writeIter := frame;

  for ii := 0 to numPixels - 1 do begin
    if (lastFrame[0] <> frame[0])
    or (lastFrame[1] <> frame[1])
    or (lastFrame[2] <> frame[2]) then begin
       writeIter[0] := frame[0];
       writeIter[1] := frame[1];
       writeIter[2] := frame[2];
       Inc(numChanged);
       Inc(writeIter, 4);
    end;
    Inc(lastFrame, 4);
    Inc(frame, 4);
  end;

  Exit(numChanged);
end;

// Creates a palette by placing all the image pixels in a k-d tree and then averaging the blocks at the bottom.
// This is known as the "modified median split" technique
procedure GifMakePalette(lastFrame: PUInt8; nextFrame: PUInt8; width: UInt32; height: UInt32; bitDepth: PtrInt; buildForDither: Boolean; pPal: PGifPalette);
var
  imageSize: SizeInt;
  destroyableImage: PUInt8;
  numPixels: PtrInt;
  lastElt: PtrInt;
  splitElt: PtrInt;
  splitDist: PtrInt;
begin
  pPal^.bitDepth := bitDepth;

  // SplitPalette is destructive (it sorts the pixels by color) so
  // we must create a copy of the image for it to destroy
  imageSize := SizeInt(width * height * 4 * SizeOf(UInt8));
  destroyableImage := PUInt8(GIF_TEMP_MALLOC(imageSize));
  Move(nextFrame^, destroyableImage^, imageSize);

  numPixels := PtrInt(width * height);
  if lastFrame <> nil then
    numPixels := GifPickChangedPixels(lastFrame, destroyableImage, numPixels);

  lastElt := 1 shl bitDepth;
  splitElt := lastElt div 2;
  splitDist := splitElt div 2;

  GifSplitPalette(destroyableImage, numPixels, 1, lastElt, splitElt, splitDist, 1, buildForDither, pPal);

  GIF_TEMP_FREE(destroyableImage);

  // add the bottom node for the transparency index
  pPal^.treeSplit[1 shl (bitDepth - 1)] := 0;
  pPal^.treeSplitElt[1 shl (bitDepth - 1)] := 0;

  pPal^.r[0] := 0;
  pPal^.g[0] := 0;
  pPal^.b[0] := 0;
end;

// Implements Floyd-Steinberg dithering, writes palette value to alpha
procedure GifDitherImage(lastFrame: PUInt8; nextFrame: PUInt8; outFrame: PUInt8; width, height: UInt32; pPal: PGifPalette);
var
  numPixels: PtrInt;
  quantPixels: PInt32;
  pix: UInt8;
  pix16: UInt32;
  yy: PtrInt;
  xx: PtrInt;
  nextPix: PInt32;
  lastPix: PUInt8;
  rr: Int32;
  gg: Int32;
  bb: Int32;
  bestDiff: Int32;
  bestInd: Int32;
  r_err, g_err, b_err: Int32;
  quantloc_7, quantloc_3, quantloc_5, quantloc_1: PtrInt;
  pix7: PInt32;
  pix3: PInt32;
  pix5: PInt32;
  pix1: PInt32;
  ii: PtrInt;
begin
  numPixels := PtrInt(width * height);

  // quantPixels initially holds color*256 for all pixels
  // The extra 8 bits of precision allow for sub-single-color error values
  // to be propagated
  quantPixels := PInt32(GIF_TEMP_MALLOC(SizeOf(Int32) * SizeInt(numPixels) * 4));

  for ii := 0 to numPixels*4 - 1 do begin
    pix := nextFrame[ii];
    pix16 := Int32(pix) * 256;
    quantPixels[ii] := pix16;
  end;

  for yy := 0 to height - 1 do begin
    for xx := 0 to width - 1 do begin
      nextPix := quantPixels + 4 * (yy * width + xx);
      if lastFrame <> nil then begin
        lastPix := lastFrame + 4 * (yy * width + xx);
      end else
        lastPix := nil;

      // Compute the colors we want (rounding to nearest)
      rr := (nextPix[0] + 127) div 256;
      gg := (nextPix[1] + 127) div 256;
      bb := (nextPix[2] + 127) div 256;

      // if it happens that we want the color from last frame, then just write out
      // a transparent pixel
      if  (lastFrame <> nil)
      and (lastPix[0] = rr)
      and (lastPix[1] = gg)
      and (lastPix[2] = bb) then begin
        nextPix[0] := rr;
        nextPix[1] := gg;
        nextPix[2] := bb;
        nextPix[3] := kGifTransIndex;
        continue;
      end;

      bestDiff := 1000000;
      bestInd := kGifTransIndex;

      // Search the palete
      GifGetClosestPaletteColor(pPal, rr, gg, bb, bestInd, bestDiff);

      // Write the result to the temp buffer
      r_err := nextPix[0] - Int32(pPal^.r[bestInd]) * 256;
      g_err := nextPix[1] - Int32(pPal^.g[bestInd]) * 256;
      b_err := nextPix[2] - Int32(pPal^.b[bestInd]) * 256;

      nextPix[0] := pPal^.r[bestInd];
      nextPix[1] := pPal^.g[bestInd];
      nextPix[2] := pPal^.b[bestInd];
      nextPix[3] := bestInd;

      // Propagate the error to the four adjacent locations
      // that we haven't touched yet
      quantloc_7 := PtrInt(yy * width + xx + 1);
      quantloc_3 := PtrInt(yy * width + width + xx - 1);
      quantloc_5 := PtrInt(yy * width + width + xx);
      quantloc_1 := PtrInt(yy * width + width + xx + 1);

      if quantloc_7 < numPixels then begin
        pix7 := quantPixels + 4 * quantloc_7;
        Inc(pix7[0], GifIMax(- pix7[0], (r_err * 7) div 16));
        Inc(pix7[1], GifIMax(- pix7[1], (g_err * 7) div 16));
        Inc(pix7[2], GifIMax(- pix7[2], (b_err * 7) div 16));
      end;

      if quantloc_3 < numPixels then begin
        pix3 := quantPixels + 4 * quantloc_3;
        Inc(pix3[0], GifIMax(- pix3[0], (r_err * 3) div 16));
        Inc(pix3[1], GifIMax(- pix3[1], (g_err * 3) div 16));
        Inc(pix3[2], GifIMax(- pix3[2], (b_err * 3) div 16));
      end;

      if quantloc_5 < numPixels then begin
        pix5 := quantPixels + 4 * quantloc_5;
        Inc(pix5[0], GifIMax(- pix5[0], (r_err * 5) div 16));
        Inc(pix5[1], GifIMax(- pix5[1], (g_err * 5) div 16));
        Inc(pix5[2], GifIMax(- pix5[2], (b_err * 5) div 16));
      end;

      if quantloc_1 < numPixels then begin
        pix1 := quantPixels + 4 * quantloc_1;
        Inc(pix1[0], GifIMax(- pix1[0], r_err div 16));
        Inc(pix1[1], GifIMax(- pix1[1], g_err div 16));
        Inc(pix1[2], GifIMax(- pix1[2], b_err div 16));
      end;
    end;
  end;

  // Copy the palettized result to the output buffer
  for ii := 0 to numPixels * 4 - 1 do begin
    outFrame[ii] := UInt8(quantPixels[ii]);
  end;

  GIF_TEMP_FREE(quantPixels);
end;

// Picks palette colors for the image using simple thresholding, no dithering
procedure GifThresholdImage(lastFrame, nextFrame, outFrame: PUInt8; width, height: UInt32; pPal: PGifPalette);
var
  numPixels: UInt32;
  ii: UInt32;
  bestDiff: Int32;
  bestInd: Int32;
begin
  numPixels := width * height;
  for ii := 0 to numPixels - 1 do begin
    // if a previous color is available, and it matches the current color,
    // set the pixel to transparent
    if  (lastFrame <> nil)
    and (lastFrame[0] = nextFrame[0])
    and (lastFrame[1] = nextFrame[1])
    and (lastFrame[2] = nextFrame[2]) then begin
      outFrame[0] := lastFrame[0];
      outFrame[1] := lastFrame[1];
      outFrame[2] := lastFrame[2];
      outFrame[3] := kGifTransIndex;
    end else begin
      // palettize the pixel
      bestDiff := 1000000;
      bestInd := 1;
      GifGetClosestPaletteColor(pPal, nextFrame[0], nextFrame[1], nextFrame[2], bestInd, bestDiff);

      // Write the resulting color to the output buffer
      outFrame[0] := pPal^.r[bestInd];
      outFrame[1] := pPal^.g[bestInd];
      outFrame[2] := pPal^.b[bestInd];
      outFrame[3] := UInt8(bestInd);
    end;

    if (lastFrame <> nil) then
      Inc(lastFrame, 4);
    Inc(outFrame, 4);
    Inc(nextFrame, 4);
  end;
end;

// Simple structure to write out the LZW-compressed portion of the image
// one bit at a time
type
PGifBitStatus = ^TGifBitStatus;
TGifBitStatus = record
  bitIndex: UInt8;  // how many bits in the partial byte written so far
  byte: UInt8;      // current partial byte

  chunkIndex: UInt32;
  chunk: array[0 .. 256 - 1] of Byte; // bytes are written in here until we have 256 of them, then written to the file
end;

// insert a single bit
procedure GifWriteBit(var stat: TGifBitStatus; bit: UInt32);
begin
  bit := bit and 1;
  bit := bit shl stat.bitIndex;
  stat.byte := stat.byte or bit;

  Inc(stat.bitIndex);
  if stat.bitIndex > 7 then begin
    // move the newly-finished byte to the chunk buffer
    stat.chunk[stat.chunkIndex] := stat.byte;
    Inc(stat.chunkIndex);
    // and start a new byte
    stat.bitIndex := 0;
    stat.byte := 0;
  end;
end;

// write all bytes so far to the file
procedure GifWriteChunk(f: PFile; var stat: TGifBitStatus);
begin
  fputc(stat.chunkIndex, f);
  fwrite(@stat.chunk[0], 1, stat.chunkIndex, f);

  stat.bitIndex := 0;
  stat.byte := 0;
  stat.chunkIndex := 0;
end;

procedure GifWriteCode(f: PFile; var stat: TGifBitStatus; code, length: UInt32);
var
  ii: PtrInt;
begin
  for ii := 0 to length - 1 do begin
    GifWriteBit(stat, code);
    code := code shr 1;

    if stat.chunkIndex = 255 then begin
      GifWriteChunk(f, stat);
    end;
  end;
end;

// The LZW dictionary is a 256-ary tree constructed as the file is encoded,
// this is one node
type
PGifLzwNode = ^TGifLzwNode;
TGifLzwNode = record
  m_next: array[0 .. 256 - 1] of UInt16;
end;

// write a 256-color (8-bit) image palette to the file
procedure GifWritePalette(pPal: PGifPalette; f: PFile);
var
  ii: PtrInt;
  r, g, b: UInt32;
begin
  fputc(0, f);  // first color: transparency
  fputc(0, f);
  fputc(0, f);

  for ii := 1 to (1 shl pPal^.bitDepth) - 1 do begin
    r := pPal^.r[ii];
    g := pPal^.g[ii];
    b := pPal^.b[ii];

    fputc(r, f);
    fputc(g, f);
    fputc(b, f);
  end;
end;

// write the image header, LZW-compress and write out the image
procedure GifWriteLzwImage(f: PFile; image: PUInt8; left, top, width, height, delay: UInt32; pPal: PGifPalette);
var
  minCodeSize: PtrInt;
  clearCode: UInt32;
  codetree: PGifLzwNode;
  curCode: Int32;
  codeSize: UInt32;
  maxCode: UInt32;
  stat: TGifBitStatus;
  xx, yy: PtrInt;
  nextValue: UInt8;
begin
  // graphics control extension
  fputc($21, f);
  fputc($f9, f);
  fputc($04, f);
  fputc($05, f); // leave prev frame in place, this frame has transparency
  fputc(delay and $ff, f);
  fputc((delay shr 8) and $ff, f);
  fputc(kGifTransIndex, f); // transparent color index
  fputc(0, f);

  fputc($2c, f); // image descriptor block

  fputc(left and $ff, f);           // corner of image in canvas space
  fputc((left shr 8) and $ff, f);
  fputc(top and $ff, f);
  fputc((top shr 8) and $ff, f);

  fputc(width and $ff, f);          // width and height of image
  fputc((width shr 8) and $ff, f);
  fputc(height and $ff, f);
  fputc((height shr 8) and $ff, f);

  //fputc(0, f); // no local color table, no transparency
  //fputc($80, f); // no local color table, but transparency

  fputc($80 + pPal^.bitDepth - 1, f); // local color table present, 2 ^ bitDepth entries
  GifWritePalette(pPal, f);

  minCodeSize := pPal^.bitDepth;
  clearCode := 1 shl pPal^.bitDepth;

  fputc(minCodeSize, f); // min code size 8 bits

  codetree := PGifLzwNode(GIF_TEMP_MALLOC(SizeOf(TGifLzwNode) * 4096));

  FillChar(codetree^, SizeOf(TGifLzwNode) * 4096, 0);
  curCode := -1;
  codeSize := UInt32(minCodeSize) + 1;
  maxCode := clearCode + 1;

  stat.byte := 0;
  stat.bitIndex := 0;
  stat.chunkIndex := 0;

  GifWriteCode(f, stat, clearCode, codeSize);  // start with a fresh LZW dictionary

  for yy := 0 to height - 1 do begin
    for xx := 0 to width - 1 do begin
  {$IF Defined(GIF_FLIP_VERT)}
      // bottom-left origin image (such as an OpenGL capture)
      nextValue := image[((height - 1 - yy) * width + xx) * 4 + 3];
  {$ELSE}
      // top-left origin
      nextValue := image[(yy * width + xx) * 4 + 3];
  {$ENDIF}

      // "loser mode" - no compression, every single code is followed immediately by a clear
      //WriteCode( f, stat, nextValue, codeSize );
      //WriteCode( f, stat, 256, codeSize );

      if curCode < 0 then begin
        // first value in a new run
        curCode := nextValue;
      end else if codetree[curCode].m_next[nextValue] <> 0 then begin
        // current run already in the dictionary
        curCode := codetree[curCode].m_next[nextValue];
      end else begin
        // finish the current run, write a code
        GifWriteCode(f, stat, UInt32(curCode), codeSize);

        // insert the new run into the dictionary
        Inc(maxCode);
        codetree[curCode].m_next[nextValue] := Uint16(maxCode);

        if maxCode >= (1 shl codeSize) then begin
          // dictionary entry count has broken a size barrier,
          // we need more bits for codes
          Inc(codeSize);
        end;
        if maxCode = 4095 then begin
          // the dictionary is full, clear it out and begin anew
          GifWriteCode(f, stat, clearCode, codeSize); // clear tree

          FillChar(codetree^, SizeOF(TGifLzwNode) * 4096, 0);
          codeSize := Uint32(minCodeSize + 1);
          maxCode := clearCode + 1;
        end;

        curCode := nextValue;
      end;
    end;
  end;

  // compression footer
  GifWriteCode(f, stat, UInt32(curCode), codeSize);
  GifWriteCode(f, stat, clearCode, codeSize);
  GifWriteCode(f, stat, clearCode + 1, UInt32(minCodeSize) + 1);

  // write out the last partial chunk
  while stat.bitIndex <> 0 do begin
    GifWriteBit(stat, 0);
  end;
  if stat.chunkIndex <> 0 then
    GifWriteChunk(f, stat);

  fputc(0, f); // image block terminator

  GIF_TEMP_FREE(codetree);
end;

function GifBegin(writer: PGifWriter; filename: PAnsiChar; width, height, delay: UInt32; bitDepth: Int32 = 8; dither: Boolean = false): Boolean;
begin
  writer^.f := fopen_wb(filename, writer^.fholder);
  if writer^.f = nil then
    Exit(False);

  writer^.firstFrame := true;

  // allocate
  writer^.oldImage := PUInt8(GIF_MALLOC(width * height * 4));

  fputs('GIF89a', writer^.f);

  // screen descriptor
  fputc(width and $ff, writer^.f);
  fputc((width shr 8) and $ff, writer^.f);
  fputc(height and $ff, writer^.f);
  fputc((height shr 8) and $ff, writer^.f);

  fputc($f0, writer^.f);   // there is an unsorted global color table of 2 entries
  fputc(0, writer^.f);     // background color
  fputc(0, writer^.f);     // pixels are square (we need to specify this because it's 1989)

  // now the "global" palette (really just a dummy palette)
  // color 0: black
  fputc(0, writer^.f);
  fputc(0, writer^.f);
  fputc(0, writer^.f);
  // color 1: also black
  fputc(0, writer^.f);
  fputc(0, writer^.f);
  fputc(0, writer^.f);

  if delay <> 0 then begin
    // animation header
    fputc($21, writer^.f);  // extension
    fputc($ff, writer^.f);  // application specific
    fputc(11, writer^.f); // length 11
    fputs('NETSCAPE2.0', writer^.f); // yes, really
    fputc(3, writer^.f); // 3 bytes of NETSCAPE2.0 data

    fputc(1, writer^.f); // JUST BECAUSE
    fputc(0, writer^.f); // loop infinitely (byte 0)
    fputc(0, writer^.f); // loop infinitely (byte 1)

    fputc(0, writer^.f); // block terminator
  end;

  Exit(True);
end;

function GifWriteFrame(writer: PGifWriter; image: PUInt8; width, height, delay: UInt32; bitDepth: PtrInt = 8; dither: Boolean = false): Boolean;
var
  oldImage: PUInt8;
  pal: TGifPalette;
  lastFrame: PUInt8;
begin
  if writer^.f = nil then
    Exit(False);

  if writer^.firstFrame then begin
    oldImage := nil;
  end else
    oldImage := writer^.oldImage;
  writer^.firstFrame := false;

  if dither then begin
    lastFrame := nil;
  end else
    lastFrame := oldImage;
  GifMakePalette(lastFrame, image, width, height, bitDepth, dither, @pal);

  if dither then begin
    GifDitherImage(oldImage, image, writer^.oldImage, width, height, @pal);
  end else
    GifThresholdImage(oldImage, image, writer^.oldImage, width, height, @pal);

  GifWriteLzwImage(writer^.f, writer^.oldImage, 0, 0, width, height, delay, @pal);

  Exit(True);
end;

function GifEnd(writer: PGifWriter): Boolean;
begin
  if writer^.f = nil then
    Exit(False);

  fputc($3b, writer^.f); // end of file
  fclose(writer^.f);
  GIF_FREE(writer^.oldImage);

  writer^.f := nil;
  writer^.oldImage := nil;

  Exit(True);
end;

end.
