unit GIF;

{$MODE OBJFPC}
{$M+}
{$ASSERTIONS ON}

interface
uses type_fixes, loaders, classes, framebuffers, colors;

{TODO:
animations?
colorspace
writing?
handle Plain Text extension?
}

type
  TApplicationDataOpaque = shortstring;
  TApplicationDataBody = array of TApplicationDataOpaque; // binary data body.

  // note: this record is the on-disk format.    
  TPlainTextExtensionHeader = record
    LeftPosition : TUINT16;
    TopPosition : TUINT16;
    Width : TUINT16;
    Height : TUINT16;
    CharacterCellWidth : TByte;
    CharacterCellHeight : TByte;
    TextForegroundColor : TByte; // index.
    TextBackgroundColor : TByte; // index.
  end; { after that: LoadLVStringList. }
  
  TPlainTextBody = array of shortstring;
  TPlainText = record
    Header : TPlainTextExtensionHeader;
    Texts : TPlainTextBody;
  end;

  TApplicationData = record
    ApplicationID : shortstring; // 0..7.
    Data : TApplicationDataBody;
  end;

  TGraphicControlExtension = record
    Flags : TByte; { bit 0..2: Reserved
                  bit 3..5: Disposal Method
                  bit 6:    User Input Flag
                  bit 7:    Transparent Color Flag}
    DelayTime : TUINT16; // in 1/100ths of a second.
    TransparentColorIndex : TByte;
  end;

  { note that the pixmap info palette contains the GLOBAL palette of the file, which may not be what you expected... }
  TLoader = class(TInterfacedObject, ILoader, IInterface)
  private
    fStream : TStream;
    fBHeadersLoaded : TBoolean;
    //fInitialPosition : TINT64;
    fPixmapInfo : IPixmapInfo;
    fPixmapInfoR : TPixmapInfo;
    fComments : TStringList;
    fApplicationData : array of TApplicationData;
    fTexts : array of TPlainText;
    fGraphicControlExtension : TGraphicControlExtension; // the current one, that is.
  protected
    function GetHeaders() : IPixmapInfo;
  published
    constructor Create(aStream : TStream);
    property Headers : IPixmapInfo read GetHeaders;
    function NextRun() : TRun;
  protected
    procedure LoadExtensions();
    procedure LoadExtensionBody();
    procedure LoadHeaders();
    function GetApplicationData(const aApplicationID : shortstring) : TApplicationDataBody;
    
    function GetText(aIndex : Integer) : TPlainText; inline;
    function GetTextCount() : Integer; inline;
  protected
    procedure ResetGraphicControlExtension(); inline; 
  public
    destructor Destroy(); override;
    property Comments : TStringList read fComments; // Read-only.
    
    // TODO iterable keys?
    property ApplicationData[aApplicationID : shortstring] : TApplicationDataBody read GetApplicationData;
    property Texts[aIndex : Integer] : TPlainText read GetText;
    property TextCount : Integer read GetTextCount;
  end;
  
implementation
uses sysutils, loggers, GIFLZW;

{$PACKRECORDS C}

type
  THeader = record
    // FIXME byte order: little endian.
    Magic : array[0..2] of Char; // "GIF".
    Version : array[0..2] of Char; // "87a" or "89a".
    Width : TUINT16;
    Height : TUINT16;
    Flags : TByte; { bit 0 : global color table flag (GCTF).
                     bit 1..3: color resolution.
                     bit 4: sort flag to global color table.
                     bit 5..7: size of global color table: 2^(1+n)}
    BackgroundColor : TByte; // index.
    PixelAspectRatio : TByte;
  end; { after that:
Offset   Length   Contents
 13      ? bytes  <Global Color Table(0..255 x 3 bytes) if GCTF is one>
         ? bytes  <Blocks>
         1 bytes  <Trailer> (0x3b)
}

  TImageBlockHeader = record
    LeftPosition : TUINT16;
    TopPosition : TUINT16;
    Width : TUINT16;
    Height : TUINT16;
    Flags : TByte; { bit 0:    Local Color Table Flag (LCTF)
                  bit 1:    Interlace Flag
                  bit 2:    Sort Flag
                  bit 2..3: Reserved
                  bit 4..7: Size of Local Color Table: 2^(1+n) }
  end; { after that:
         ? bytes  Local Color Table(0..255 x 3 bytes) if LCTF is one
         1 byte   LZW root size.
[ // Blocks
         1 byte   Block Size (s)
        (s)bytes  Image Data
]*
         1 byte   Block Terminator(0x00)
}


  
  TApplicationExtensionHeader = record
    ApplicationID : array[0..7] of Char;
  end; // after that: TApplicationExtensionBlockItem list.
  
  // usually ordered in order of decreasing importance.
  TPalette = bitpacked array[0..255] of TPaletteEntry;
  { TIColorArray }


function TLoader.GetHeaders() : IPixmapInfo;
begin
  if not fBHeadersLoaded then
    LoadHeaders();

  Result := fPixmapInfo;
end;

constructor TLoader.Create(aStream : TStream);
begin
  SetLength(fApplicationData, 0);
  SetLength(fTexts, 0);
  fStream := aStream;
  fPixmapInfoR := TPixmapInfo.Create();
  fPixmapInfo := fPixmapInfoR; // pin down until the loader is done.
end;


procedure EnsureHeaderSanity(const aHeader : THeader); inline;
begin
  with aHeader do 
    if (Magic[0] <> 'G') or (Magic[1] <> 'I') or (Magic[2] <> 'F') or (Version[0] <> '8') or not ((Version[1] = '7') or (Version[1] = '9')) or (Version[2] <> 'a') or {arbitrary endianness check} (Width >= 32 * 256) then
      raise EReadError.Create('invalid GIF header.');
end;

procedure EnsurePlainTextExtensionHeaderSanity(const aHeader : TPlainTextExtensionHeader); inline;
begin
  if aHeader.LeftPosition >= 32 * 256 then
    raise EReadError.Create('invalid GIF plain text extension header.');
end;

const 
  HeaderFlagGlobalColorTable = 1 shl 0;
  HeaderFlagSortGlobalColorTable = 1 shl 1; // FIXME???

function DefaultPalette() : TIColorArray; inline;
begin
  SetLength(Result, 2);
  Result[0] := TRGBColor.Create(0, 0, 0); // black.
  Result[1] := TRGBColor.Create($FFFF, $FFFF, $FFFF); // white.
end;

function LoadPaletteBody(aStream : TStream; aCount : Integer) : TIColorArray;
var
  vPaletteIndex : Integer;
  vLowlevelPalette : TPalette;
begin
  assert(aCount <= 256);
  SetLength(Result, aCount);
  //SetLength(vLowlevelPalette, aCount);
  aStream.ReadBuffer(vLowlevelPalette[0], Sizeof(TPaletteEntry) * aCount);

  for vPaletteIndex := 0 to aCount - 1 do begin
    with vLowlevelPalette[vPaletteIndex] do begin
      Result[vPaletteIndex] := TRGBColor.Create(Red * $FFFF div $FF, Green * $FFFF div $FF, Blue * $FFFF div $FF); { 257. }
    end;
    //aStream.ReadBuffer(vPaletteItem, 3);
  end;
end;

function ReadL(aStream : TStream) : TByte; inline;
begin
  Result := aStream.ReadByte();
end;


{ reads and skips a (length, value) block. 
  returns whether (Length > 0).}
function SkipLV(aStream : TStream) : Boolean; inline;
var
  vLength : TByte;
  i : Integer;
begin
  vLength := ReadL(aStream);
  Result := vLength > 0;
  if Result then 
    for i := 1 to vLength do 
      aStream.ReadByte();
end;

function LoadStringLV(aStream : TStream) : shortstring; inline;
var
  vLength : TByte;
begin
  vLength := ReadL(aStream);
  SetLength(Result, vLength);
  aStream.ReadBuffer(Result[1], vLength);
end;

// for binary/unknown data.
function LoadBlurbLV(aStream : TStream) : shortstring; inline;
var
  vLength : TByte;
begin
  vLength := ReadL(aStream);
  SetLength(Result, vLength);
  aStream.ReadBuffer(Result[1], vLength);
end;

function LoadStringListLV(aStream : TStream) : TStringList; inline;
var
  s : shortstring;
begin
  Result := TStringList.Create();
  try
    repeat
      s := LoadStringLV(aStream);
      if s <> '' then
        Result.Add(s);
    until s = '';
  except
    FreeAndNil(Result);
  end;
end;

procedure SkipUntilTerminator(aStream : TStream); inline;
begin
  if SkipLV(aStream) then begin
    while SkipLV(aStream) do begin
    end;
    Warn('ignored extra junk before terminator.');
  end;
end;

function LoadGraphicControlExtensionBlock(aStream : TStream) : TGraphicControlExtension;
begin
  if ReadL(aStream) <> Sizeof(TGraphicControlExtension) then
    raise EReadError.Create('invalid GIF graphic control extension: length is unexpected.');

  aStream.ReadBuffer(Result, Sizeof(Result));
  SkipUntilTerminator(aStream);
end;

function LoadCommentExtensionBlock(aStream : TStream) : TStringList;
var
  vComments : TStringList;
begin
  vComments := LoadStringListLV(aStream);
  SkipUntilTerminator(aStream);
  Result := vComments;
end;

function LoadPlainTextExtensionBlock(aStream : TStream) : TPlainText;
var
  vTexts : TStringList;
  vHeader : TPlainTextExtensionHeader;
  vTextIndex : Integer;
begin
  if ReadL(aStream) <> Sizeof(vHeader) then
    raise EReadError.Create('invalid GIF plain text extension block size.');
  
  aStream.ReadBuffer(vHeader, Sizeof(vHeader));
  EnsurePlainTextExtensionHeaderSanity(vHeader);
  
  vTexts := LoadStringListLV(aStream);
  SkipUntilTerminator(aStream);
  Result.Header := vHeader;
  SetLength(Result.Texts, vTexts.Count);
  for vTextIndex := 0 to vTexts.Count - 1 do
    Result.Texts[vTextIndex] := vTexts[vTextIndex];
    
  // FIXME.
  FreeAndNil(vTexts);
end;

// that isn't exactly fast or nice:
function LoadApplicationExtensionBlock(aStream : TStream) : TApplicationData;
var
  vHeader : TApplicationExtensionHeader;
  vData : TApplicationDataBody;
  s : TApplicationDataOpaque;
begin
  if ReadL(aStream) <> Sizeof(vHeader) then
    raise EReadError.Create('invalid GIF plain text extension block size.');

  aStream.ReadBuffer(vHeader, SizeOf(vHeader));

  SetLength(vData, 0);
  repeat
    s := LoadBlurbLV(aStream);
    if s <> '' then begin
      SetLength(vData, Length(vData) + 1);
      vData[High(vData)] := s;
    end;
  until s = '';
  
  SkipUntilTerminator(aStream);
  Result.ApplicationID := vHeader.ApplicationID;
  Result.Data := vData;
end;

type
  TCompressedBuffer = bitpacked array[0..255] of Byte;
  TImageData = array of TByte; // uncompressed, left-to-right, top-to-bottom.
  
function LoadImageBlock(aStream : TStream; {const aGlobalPalette : TIColorArray; }out aLocalPalette : TIColorArray; out aPosition : TImageBlockHeader) : TImageData;
var
  vHeader : TImageBlockHeader;
  vBHasLocalColorTable : Boolean;
  vBInterlaced : Boolean;
  vBLocalColorTableSorted : Boolean;
  vLocalColorTableSize : TUINT16;
  vPalette : TIColorArray;
  vLZWRootSizeBits : TByte;
  vSize : TByte;
  vBuffer : TCompressedBuffer;
  fGIFLZWDecoder : GIFLZW.TDecoder;
  vResultPosition : TCardinal;
const
  HeaderFlagLocalColorTable = 1 shl 0;
  HeaderFlagLocalInterlaced = 1 shl 1;
  HeaderFlagLocalColorTableSorted = 1 shl 2;
begin
  if ReadL(aStream) <> Sizeof(vHeader) then
    raise EReadError.Create('GIF image block header size is invalid.');
    
  aStream.ReadBuffer(vHeader, Sizeof(vHeader));
  aPosition := vHeader;

  SetLength(Result, aPosition.Width * aPosition.Height);
  vResultPosition := 0;

  vBHasLocalColorTable := (vHeader.Flags and HeaderFlagLocalColorTable) <> 0;
  vBLocalColorTableSorted := (vHeader.Flags and HeaderFlagLocalColorTableSorted) <> 0;
  vBInterlaced := (vHeader.Flags and HeaderFlagLocalInterlaced) <> 0; 
  { 4-pass interlace:
   The rows of an Interlaced images are arranged in the following order:
   
   Group 1 : Every 8th. row, starting with row 0. (Pass 1)
   Group 2 : Every 8th. row, starting with row 4. (Pass 2)
   Group 3 : Every 4th. row, starting with row 2. (Pass 3)
   Group 4 : Every 2nd. row, starting with row 1. (Pass 4) 
  }
  vLocalColorTableSize := 1 shl (1 + ( (vHeader.Flags shr 4) and $7  ));
  
  if vBHasLocalColorTable then
    aLocalPalette := LoadPaletteBody(aStream, vLocalColorTableSize)
  else
    aLocalPalette := nil;
    //vPalette := aGlobalPalette; 
  
{    LeftPosition : TUINT16;
    TopPosition : TUINT16;
    Width : TUINT16;
    Height : TUINT16;
                  bit 4..7: Size of Local Color Table: 2^(1+n)
}

  vLZWRootSizeBits := aStream.ReadByte(); // in bits.
  try
    fGIFLZWDecoder := GIFLZW.TDecoder.Create(aStream, False, vLZWRootSizeBits);
  
    repeat
      vSize := aStream.ReadByte();
      if vSize <> 0 then begin
        aStream.ReadBuffer(vBuffer[0], vSize + 1);

        // FIXME LZW decode. Use windowed stream?
      
        // FIXME fGIFLZWDecoder.ReadBuffer(Result[vResultPosition], ???); don't forget interlaced.
        Inc(vResultPosition, vSize);
      end;
    until vSize = 0;
  finally
    FreeAndNil(fGIFLZWDecoder);
  end; 
  
{
sequence of sub-blocks, of size at most 255 bytes each, containing an index into the active color table, for each pixel in the image. 
The sequence of indices is encoded using the LZW Algorithm with variable-length code, as described in Appendix F.

LZW Minimum Code Size. This byte determines the initial number of bits used for LZW codes in the image data, as described in Appendix F.
}

  SkipUntilTerminator(aStream);
end;

procedure EnsureSingleInstance(var destination : TStringList; source : TStringList); inline;
begin
  if Assigned(destination) then begin
    Warn('GIF: ignored duplicate extension block.');
    FreeAndNil(source);
  end else begin
    destination := source;
  end;
end;

procedure TLoader.ResetGraphicControlExtension(); inline;
begin
  with fGraphicControlExtension do begin
    Flags := 0; // FIXME maybe set bit 7 (transparent color)?
    DelayTime := 0;
    TransparentColorIndex := 0; // FIXME maybe set this?
  end;
end;

procedure TLoader.LoadExtensionBody();
var
  vExtensionType : TByte;
begin
      vExtensionType := fStream.ReadByte();
      { each extension block is:
          [len
           value
          ]* (until len = 0).
      }
      case vExtensionType of 
        $F9:
          begin
            fGraphicControlExtension := LoadGraphicControlExtensionBlock(fStream);
            // note that there can be a lot of them.
            // TODO do more stuff.
          end;
{FIXME
TGraphicControlExtension = record
    Flags : TByte; // bit 0..2: Reserved
                  bit 3..5: Disposal Method
                  bit 6:    User Input Flag
                  bit 7:    Transparent Color Flag
    DelayTime : TUINT16; // in 1/100ths of a second.
    TransparentColorIndex : TByte;
  end;
}
        $FE: EnsureSingleInstance(fComments, LoadCommentExtensionBlock(fStream));
        $01:
          begin
            SetLength(fTexts, Length(fTexts) + 1);
            fTexts[High(fTexts)] := LoadPlainTextExtensionBlock(fStream);
          end;
        $FF: 
          begin
            SetLength(fApplicationData, Length(fApplicationData) + 1);
            fApplicationData[High(fApplicationData)] := LoadApplicationExtensionBlock(fStream);
          end;
        else
          begin
            warn(Format('ignoring unknown GIF extension block %X', [vExtensionType]));
            while SkipLV(fStream) do begin
              // ignore unknown extension block item...
            end;
          end;
      end;
end;

procedure TLoader.LoadExtensions();
var
  vExtensionMagic : TByte;
begin
  repeat
    vExtensionMagic := fStream.ReadByte();
    if vExtensionMagic = $21 then // is an extension.
      LoadExtensionBody(); // Plain Text extension etc.
  until vExtensionMagic <> $21;

  if vExtensionMagic <> $2C then
    raise EReadError.Create('expect image blocks after extension blocks or GIF header.');
    
  // FIXME use extensions.
end;

procedure EnsureTrailer(aStream : TStream); inline;
begin
  if aStream.ReadByte() <> $3B then
    raise EReadError.Create('expected GIF trailer, got junk.');
end;

// if this reads anything, it will stop exactly at the image descriptor (after the $2C).
procedure TLoader.LoadHeaders();
var
  vHeader : THeader;
  vBHasGlobalColorTable : Boolean;
  vBGlobalColorTableSorted : Boolean;
  vColorResolution : TByte;
  vGlobalColorTableSize : TUINT16;
  vBackgroundColor : TByte;
  vPixelAspectRatio : TByte;
begin
  if fBHeadersLoaded then
    Exit;
    
  fStream.ReadBuffer(vHeader, Sizeof(vHeader));
  EnsureHeaderSanity(vHeader);

  fPixmapInfoR.Width := vHeader.Width;
  fPixmapInfoR.Height := vHeader.Height;
  
  vBHasGlobalColorTable := (vHeader.Flags and HeaderFlagGlobalColorTable) <> 0;
  vBGlobalColorTableSorted := (vHeader.Flags and HeaderFlagSortGlobalColorTable) <> 0;
  
  vColorResolution := (vHeader.Flags shr 1) and $7; // Number of bits per primary color available to the original image, minus 1. This value represents the size of the entire palette from which the colors in the graphic were selected, not the number of colors actually used in the graphic.
  
  vGlobalColorTableSize := 1 shl (1 + ( (vHeader.Flags shr 5) and $7  ));

  vBackgroundColor := vHeader.BackgroundColor; // index.
  vPixelAspectRatio := vHeader.PixelAspectRatio; // 0, or = (real Pixel Aspect Ratio + 15) / 64 
  {  The Pixel Aspect Ratio is defined to be the quotient of the pixel's width over its height. The value range in this field allows specification of the widest pixel of 4:1 to the tallest pixel of 1:4 in increments of 1/64th.  }

  if vBHasGlobalColorTable then begin
    fPixmapInfoR.Palette := LoadPaletteBody(fStream, vGlobalColorTableSize);
  end else begin
    fPixmapInfoR.Palette := DefaultPalette();
  end;
  
  if vHeader.Version[1] > '7' then begin // allow extensions.
    Self.LoadExtensions();
  end;
  

{
GIF87a:

GIF Header
Image Block
Trailer

GIF89a:

GIF Header
Graphic Control Extension
Image Block
Trailer

GIF Animation

GIF Header
Application Extension
[
Graphic Control Extension
Image Block
]*
Trailer
}
  
  fBHeadersLoaded := True;
end;

destructor TLoader.Destroy();
begin
  FreeAndNil(fTexts);
  FreeAndNil(fComments);
  inherited Destroy();
end;

function TLoader.GetApplicationData(const aApplicationID : shortstring) : TApplicationDataBody;
var
  i : Integer;
begin // TODO optimize? 
  SetLength(Result, 0);
  for i := Low(fApplicationData) to High(fApplicationData) do
    with fApplicationData[i] do 
      if ApplicationID = aApplicationID then
        Result := Data;
end;

function TLoader.GetText(aIndex : Integer) : TPlainText; inline;
begin
  Result := fTexts[aIndex];
end;

function TLoader.GetTextCount() : Integer; inline;
begin
  Result := Length(fTexts);
end;


function TLoader.NextRun() : TRun;
var
  vMagic : TByte;
  vImageData : TImageData;
  vLocalPalette : TIColorArray;
  vPosition : TImageBlockHeader;
begin
  if not fBHeadersLoaded then
    LoadHeaders();

  // Load image data.

{ order:

  Graphic Control Extension*
  Image Descriptor    <---- you are here.
  [Local Color Table]
  Image Data

}
  vImageData := LoadImageBlock(fStream, vLocalPalette, vPosition);
  if not Assigned(vLocalPalette) then
    vLocalPalette := fPixmapInfoR.Palette; // use global palette.

  // for the next frame:    
  // especially load TGraphicControlExtension. while ... LoadExtensionBody();
  // especially handle plain text extensions.
  // $21 $F9 LoadGraphicControlExtensionBlock(fStream) $2C.
  //vMagic := ReadByte();
  //if vMagic = $2C then LoadImageBlock();
  //if vMagic = $21 then $F9 LoadGraphicControlExtensionBlock

// at most one Graphic Control Extension may precede a graphic rendering block. Scope is the graphic rendering block to follow.
      

{
Graphic-Rendering Blocks
Plain Text Extension        Opt. (*)   0x01 (001)  yes    89a
Image Descriptor            Opt. (*)   0x2C (044)  no     87a (89a)

Control Blocks
Graphic Control Extension   Opt. (*)   0xF9 (249)  yes    89a

Special Purpose Blocks
Trailer                     Req. (1)   0x3B (059)  no     87a
Comment Extension           Opt. (*)   0xFE (254)  yes    89a
Application Extension       Opt. (*)   0xFF (255)  yes    89a
}
  // ... at the end: EnsureTrailer(fStream);
end;
      
initialization
  assert(Sizeof(THeader) = 13);
  assert(Sizeof(TGraphicControlExtension) = 4);
  assert(Sizeof(TImageBlockHeader) = 9);
  assert(Sizeof(TPlainTextExtensionHeader) = 13);
  assert(Sizeof(TApplicationExtensionHeader) = 8);
  assert(Sizeof(TPaletteEntry) = 3);
  
end.