unit LZW;

// <http://www.martinreddy.net/gfx/2d/GIF-comp.txt>.

{$MODE OBJFPC}
{$M+}

interface
uses type_fixes, classes, custom_decoders, bitstreams;

{
GIF LZW:
  1. A special Clear code is defined which resets all compression/decompression parameters and tables to a start-up state. The value of this code is 2**<code size>. For example if the code size indicated was 4 (image was 4 bits/pixel) the Clear code value would be 16 (10000 binary). The Clear code can appear at any point in the image data stream and therefore requires the LZW algorithm to process succeeding codes as if a new data stream was starting. Encoders should output a Clear code as the first code of each image data stream.
  2. An End of Information code is defined that explicitly indicates the end of the image data stream. LZW processing terminates when this code is encountered. It must be the last code output by the encoder for an image. The value of this code is +1.
  3. The first available compression code value is <clear code>+2.
  4. The output codes are of variable length, starting at <code size>+1 bits per code, up to 12 bits per code. This defines a maximum code value of 4095 (0xFFF). Whenever the LZW code value would exceed the current code length, the code length is increased by one. The packing/unpacking of these codes must then be altered to reflect the new code length. 
  
  The code size changes while decompressing.
  The code table is limited to 4096 bits.
}

type
  { TODO Actually, a possible optimization:
       each code from 0 to #characters - 1 maps to a root. 
       There will be no other entries in the table that have this property.  
       No PrefixIndex loops, please. }
  TCodeTableEntry = record
    PrefixIndex : Integer; // -1 none.
    Character : TByte;
  end;
  
  TCodeTable = array of TCodeTableEntry;
  
  TSpecialHandlingVerdict = (shNothingSpecial, shGoOn, shStopParsing, shReinitialize);
  
  // limitation: in order to be able to use TOwnerStream framework, this class uses a TStream, not a TBitstream as init parameter (it constructs a TBitstream by itself). This means you can't start parsing in the middle of a Byte.
  TDecoder = class(TCustomDecoder)
  protected
    fBitstream : TBitstream;
    fCodeTable : TCodeTable;
    fCodeSize : TByte;//in bits.
    fRootSize : TByte;
    fInitialCodeSize : TByte;
    fCodeSizeStep : TByte; // in bits.
    fCodeSizeMax : TByte; // in bits.
    fNextCode : TUINT16;
    fOldCode : Integer; // in the beginning: -1. 
    fCharacter : Byte;
  protected
    procedure InitializeCodeTable(aCodeSize : TByte { in bits });
    function HasCodeP(aCode : TUINT16) : Boolean; inline;
    function GetStringForCode(aCode : Integer) : ANSIString; inline;
    function AddTranslation(aPrefix : Integer; aInput : TByte) : TUINT16; inline;
    procedure Print(const aPrefix : ANSIString); inline;
    function DecodeItem() : Boolean; inline; // returns False if done with everything.
    property NextCode : TUINT16 read fNextCode;
    function HandleSpecialCode(aCode : TUINT16) : TSpecialHandlingVerdict; virtual;
    procedure IncreaseCodeSize(); inline; // by CodeSizeStep, if any.
  protected
    procedure ReadFromSourceAndDecode(aDecodedBufferAvailableByteCount : Cardinal); override; // for TCustomDecoder.
  published
    constructor Create(aStream : TStream; aBOwnsStream : Boolean; aCodeSize, aCodeSizeStep, aCodeSizeMax : TByte { in bits });
    property CodeSize : TByte read fCodeSize; // write fCodeSize; // in bits.
    property CodeSizeStep : TByte read fCodeSizeStep; // write fCodeSizeStep; // increase in bits, if needed.
    property CodeSizeMax : TByte read fCodeSizeMax; // write fCodeSizeMax; // in bits.
  public 
    destructor Destroy(); override;
  end;

implementation
uses sysutils;

constructor TDecoder.Create(aStream : TStream; aBOwnsStream : Boolean; aCodeSize, aCodeSizeStep, aCodeSizeMax : TByte);
begin
  inherited Create(aStream);
  inherited SourceOwner := aBOwnsStream;
  fBitstream := TBitstream.Create(aStream, False);
  fCodeSize := aCodeSize;
  fRootSize := aCodeSize;
  fInitialCodeSize := aCodeSize;
  fCodeSizeStep := aCodeSizeStep;
  fCodeSizeMax := aCodeSizeMax;
  InitializeCodeTable(aCodeSize);
  fOldCode := -1; // no prefix yet.
end;

destructor TDecoder.Destroy();
begin
  FreeAndNil(fBitstream);
  inherited Destroy();
end;
  
procedure TDecoder.InitializeCodeTable(aCodeSize : TByte { in bits });
var
  vTableIndex : TUINT16;
  vRootCount : TUINT16;
begin
  //assert(aCodeSize <= 12);
  vRootCount := 1 shl aCodeSize;
  
  SetLength(fCodeTable, vRootCount); // 1 shl aCodeSize);
  if vRootCount > 0 then
    for vTableIndex := 0 to vRootCount - 1 do
      with fCodeTable[vTableIndex] do begin
        PrefixIndex := -1;
        Character := vTableIndex; // map each low code to a root (just a character).
      end;
      
  fNextCode := Length(fCodeTable);
end;

function TDecoder.HasCodeP(aCode : TUINT16) : Boolean; inline;
begin
  Result := (aCode >= 0) and (aCode < Length(fCodeTable));
end;

// adds a NEW code at the end. For root codes it just assumes they are already there.
function TDecoder.AddTranslation(aPrefix : Integer; aInput : TByte) : TUINT16; inline;
begin
  if aPrefix = -1 then begin
    Result := aInput;
    with fCodeTable[aInput] do begin // be paranoid. be very paranoid.
      assert(Character = aInput);
      assert(PrefixIndex = -1);
    end;
    Exit;
  end;
  
  Result := fNextCode;
  Inc(fNextCode);
  SetLength(fCodeTable, Result + 1); // TODO maybe do this in big chunks?
  with fCodeTable[High(fCodeTable)] do begin
    PrefixIndex := aPrefix;
    Character := aInput;
  end;
end;

{normal:
function TDecoder.GetStringForCode(aCode : Integer) : ANSIString; inline;
var
  vEntry : TCodeTableEntry;
begin
  if aCode = -1 then begin
    Result := '';
    Exit;
  end;
    
  vEntry := fCodeTable[aCode];
  Result := Chr(vEntry.Character);
  
  if vEntry.PrefixIndex <> -1 just aCode >= 1 shl fRootSize then begin
    Result := GetStringForCode(vEntry.PrefixIndex) + Result;
  end;
end;
}

// procedural:

// the returned string is max. Length(CodeTable) long.
function TDecoder.GetStringForCode(aCode : Integer) : ANSIString; inline;
var
  vEntry : TCodeTableEntry;
begin
  Result := '';
  while aCode <> -1 do begin
    vEntry := fCodeTable[aCode];
    Result := Chr(vEntry.Character) + Result;
    aCode := vEntry.PrefixIndex; // = -1 for aCode < 1 shl fRootSize 
  end;
end;

procedure TDecoder.Print(const aPrefix : ANSIString);
begin
  Buffer.Write(aPrefix[1], Length(aPrefix));
end;

function TDecoder.HandleSpecialCode(aCode : TUINT16) : TSpecialHandlingVerdict;
begin
  Result := shNothingSpecial;
end;

function TDecoder.DecodeItem() : Boolean; inline;
var
  fCode : TUINT16;
  fSpecialHandlingVerdict : TSpecialHandlingVerdict;
  fPrefix : ANSIString; // max. length = 4K + 1 characters (for GIF). So don't use shortstring.
begin
    Result := True;

    fBitstream.ReadBuffer(fCode, fCodeSize);

    // GIF oddities:
        
    fSpecialHandlingVerdict := HandleSpecialCode(fCode);
    if fSpecialHandlingVerdict <> shNothingSpecial then begin
      case fSpecialHandlingVerdict of 
        shGoOn: ;
        shStopParsing:
          begin
            Result := False;
            Exit;
          end;
        shReinitialize: 
          begin
            fCodeSize := fInitialCodeSize;
            InitializeCodeTable(fCodeSize);
          end;
      end;
      Result := True;
      Exit;
    end;
    
    // normal:
    
    if HasCodeP(fCode) then begin
      fPrefix := GetStringForCode(fCode);
    end else begin
      fPrefix := GetStringForCode(fOldCode);
      //fCharacter := fPrefix[1];
      fPrefix := fPrefix + Chr(fCharacter);
    end;
    Print(fPrefix);
    fCharacter := Ord(fPrefix[1]);
    if AddTranslation(fOldCode, fCharacter) = (1 shl fCodeSize) - 1 then begin // the string table is now full.
      IncreaseCodeSize();
    end;
    fOldCode := fCode;
end;

{procedure TDecoder.Decode();
begin
  //fPrefix := '';
  // variable-length codes, between 3 and 12 bits each...

  the first step amounts to:
  
  fBitstream.ReadBuffer(fCode, fCodeSize);
  Print(Chr(fCode));
  fOldCode := fCode;
  fCharacter := fOldCode;
  
  i.e. exactly what DecodeItem() does when it has an initialized root table to work with, EXCEPT for the AddTranlation(fOldCode), because the entry is already there.

  while DecodeItem() do 
    ;
end;}

{
      Read OLD_CODE
      output OLD_CODE                          
      CHARACTER = OLD_CODE
      WHILE there are still input characters DO
          Read NEW_CODE
          IF NEW_CODE is not in the translation table THEN 
              STRING = get translation of OLD_CODE         
              STRING = STRING+CHARACTER <--- XXX
          ELSE                         
              STRING = get translation of NEW_CODE
          END of IF
          output STRING
          CHARACTER = first character in STRING
          add OLD_CODE + CHARACTER to the translation table
          OLD_CODE = NEW_CODE
      END of WHILE
}

procedure TDecoder.IncreaseCodeSize(); inline;
begin
  if fCodeSize < fCodeSizeMax then
    Inc(fCodeSize, fCodeSizeStep);
end;

procedure TDecoder.ReadFromSourceAndDecode(aDecodedBufferAvailableByteCount : Cardinal);
var
  vEncodedBufferCount : Cardinal;
  vPermittedReadCount : Cardinal;
begin
  { already done by called. if fBSourceEOF then
    Exit;
  }
    
  if not DecodeItem() then begin
    BSourceEOF := True;
    // Finish()
    Exit;
  end;
//      raise EReadError.Create('was not allowed to read anything from the source');
end;

end.