{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: cDIB.PAS, released August 28, 2000.

The Initial Developer of the Original Code is Peter Morris (pete@stuckindoors.com),
Portions created by Peter Morris are Copyright (C) 2000 Peter Morris.
All Rights Reserved.

Purpose of file:
This is the main drawing engine.

Contributor(s):
None as yet


Last Modified: March 18, 2001
Current Version: 1.8

-----------------------------------------------------------------------------}

unit Lzh;

{$R-}

interface

uses Sysutils, Classes;

const
  //LZss parameters
  cStringBufferSize = 4096; //Size of string buffer
  cLookAheadSize = 60; //Size of look-ahead buffer
  cThreshHold = 2;
  cNull = cStringBufferSize; //End of the tree's node


  //Huffman parameters
  cNumChars = 256 - cThreshHold + cLookAheadSize;
  cTableSize  = (cNumChars * 2) - 1;  //Size of table
  cRootPos =	cTableSize - 1; //Root position
  cMaximumFreq = $8000; //Update when cummulative Freq hits this value

  //Tables FOR encoding/decoding upper 6 bits of sliding dictionary pointer
  //Encoder table
  cEncTableLen: array[0..63] of byte = ($03, $04, $04, $04, $05, $05, $05, $05,
    $05, $05, $05, $05, $06, $06, $06, $06, $06, $06, $06, $06, $06, $06, $06,
    $06, $07, $07, $07, $07, $07, $07, $07, $07, $07, $07, $07, $07, $07, $07,
    $07, $07, $07, $07, $07, $07, $07, $07, $07, $07, $08, $08, $08, $08, $08,
    $08, $08, $08, $08, $08, $08, $08, $08, $08, $08, $08);

  cEncTableCode: array [0..63] of byte = ($00, $20, $30, $40, $50, $58, $60,
    $68, $70, $78, $80, $88, $90, $94, $98, $9C, $A0, $A4, $A8, $AC, $B0, $B4,
    $B8, $BC, $C0, $C2, $C4, $C6, $C8, $CA, $CC, $CE, $D0, $D2, $D4, $D6, $D8,
    $DA, $DC, $DE, $E0, $E2, $E4, $E6, $E8, $EA, $EC, $EE, $F0, $F1, $F2, $F3,
    $F4, $F5, $F6, $F7, $F8, $F9, $FA, $FB, $FC, $FD, $FE, $FF);

  //Decoder table
  cDecTableLen: array[0..255] of byte = ($03, $03, $03, $03, $03, $03, $03, $03,
    $03, $03, $03, $03, $03, $03, $03, $03, $03, $03, $03, $03, $03, $03, $03,
    $03, $03, $03, $03, $03, $03, $03, $03, $03, $04, $04, $04, $04, $04, $04,
    $04, $04, $04, $04, $04, $04, $04, $04, $04, $04, $04, $04, $04, $04, $04,
    $04, $04, $04, $04, $04, $04, $04, $04, $04, $04, $04, $04, $04, $04, $04,
    $04, $04, $04, $04, $04, $04, $04, $04, $04, $04, $04, $04, $05, $05, $05,
    $05, $05, $05, $05, $05, $05, $05, $05, $05, $05, $05, $05, $05, $05, $05,
    $05, $05, $05, $05, $05, $05, $05, $05, $05, $05, $05, $05, $05, $05, $05,
    $05, $05, $05, $05, $05, $05, $05, $05, $05, $05, $05, $05, $05, $05, $05,
    $05, $05, $05, $05, $05, $05, $05, $05, $05, $05, $05, $05, $05, $05, $05,
    $05, $06, $06, $06, $06, $06, $06, $06, $06, $06, $06, $06, $06, $06, $06,
    $06, $06, $06, $06, $06, $06, $06, $06, $06, $06, $06, $06, $06, $06, $06,
    $06, $06, $06, $06, $06, $06, $06, $06, $06, $06, $06, $06, $06, $06, $06,
    $06, $06, $06, $06, $07, $07, $07, $07, $07, $07, $07, $07, $07, $07, $07,
    $07, $07, $07, $07, $07, $07, $07, $07, $07, $07, $07, $07, $07, $07, $07,
    $07, $07, $07, $07, $07, $07, $07, $07, $07, $07, $07, $07, $07, $07, $07,
    $07, $07, $07, $07, $07, $07, $07, $08, $08, $08, $08, $08, $08, $08, $08,
	  $08, $08, $08, $08, $08, $08, $08, $08);

  cDecTableCode: array [0..255] of byte = ($00, $00, $00, $00, $00, $00, $00,
    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00,
    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $01, $01, $01, $01, $01,
    $01, $01, $01, $01, $01, $01, $01, $01, $01, $01, $01, $02, $02, $02, $02,
    $02, $02, $02, $02, $02, $02, $02, $02, $02, $02, $02, $02, $03, $03, $03,
    $03, $03, $03, $03, $03, $03, $03, $03, $03, $03, $03, $03, $03, $04, $04,
    $04, $04, $04, $04, $04, $04, $05, $05, $05, $05, $05, $05, $05, $05, $06,
    $06, $06, $06, $06, $06, $06, $06, $07, $07, $07, $07, $07, $07, $07, $07,
    $08, $08, $08, $08, $08, $08, $08, $08, $09, $09, $09, $09, $09, $09, $09,
    $09, $0A, $0A, $0A, $0A, $0A, $0A, $0A, $0A, $0B, $0B, $0B, $0B, $0B, $0B,
    $0B, $0B, $0C, $0C, $0C, $0C, $0D, $0D, $0D, $0D, $0E, $0E, $0E, $0E, $0F,
    $0F, $0F, $0F, $10, $10, $10, $10, $11, $11, $11, $11, $12, $12, $12, $12,
    $13, $13, $13, $13, $14, $14, $14, $14, $15, $15, $15, $15, $16, $16, $16,
    $16, $17, $17, $17, $17, $18, $18, $19, $19, $1A, $1A, $1B, $1B, $1C, $1C,
    $1D, $1D, $1E, $1E, $1F, $1F, $20, $20, $21, $21, $22, $22, $23, $23, $24,
    $24, $25, $25, $26, $26, $27, $27, $28, $28, $29, $29, $2A, $2A, $2B, $2B,
    $2C, $2C, $2D, $2D, $2E, $2E, $2F, $2F, $30, $31, $32, $33, $34, $35, $36,
    $37, $38, $39, $3A, $3B, $3C, $3D, $3E, $3F);


type
  TLZHAction = (acCompress, acDecompress);
  ElzhException = Class(Exception);

  //====================
  PFrequency = ^TFrequency;
  TFrequency = array [0..cTableSize] of word;

  PParent = ^TParent;
  TParent = array [0..pred(cTableSize + cNumChars)] of SmallInt;

  PChild = ^TChild;
  TChild = array [0..PRED(cTableSize)] of SmallInt;

  PTextBuffer = ^TTextBuffer;
  TTextBuffer = array [0..cStringBufferSize + cLookAheadSize - 2] of byte;

  PLinkArray = ^TLinkArray;
  TLinkArray = array [0..cStringBufferSize] of SmallInt;

  PLinkBackArray = ^TLinkBackArray;
  TLinkBackArray = array [0..cStringBufferSize + 256] of SmallInt;

  TLZHStream = class
  private
    { Private declarations }
    FAction: TLZHAction;

    Code,
    Len,
    PutBuf,
    GetBuf: Word;

    GetLen,
    PutLen: Byte;

    FUncompressedSize,
    FBytesWritten,
    FBytesRead,
    OrigSize,
    CodeSize,
    PrintCount: Longint;

    MatchPos,
    MatchLen: SmallInt;


    TextBuff: PTextBuffer;

    LeftLeaf,
    ParentLeaf: PLinkArray;
    RightLeaf: PLinkBackArray;
    
    Freq: PFrequency;

    Parent: PParent;
    Child: PChild;

    FSource,
    FDest                     : TStream;
    //Initialize the tree
    procedure InitTree;

    //Insert a new node
    procedure InsertNode(r : SmallInt);

    //Delete a node from the tree
    procedure DeleteNode(p: SmallInt);

    //Get a bit from the stream
    function GetBit: SmallInt;

    //Get a byte from the stream
    function GetByte: SmallInt;

    //Update a char
    procedure update(c : SmallInt);

    //Start huffman encoding
    procedure StartHuff;

    //Output some results
    procedure Putcode(l : SmallInt; c: WORD);

    //Reconstruct frequency tree
    procedure Reconstruct;

    //Encode a character
    procedure EncodeChar(c: WORD);

    //Encode a string position in the tree
    procedure EncodePosition(c : WORD);

    //Output "endcode end" flag
    procedure EncodeEnd;

    //Decode a character
    function DecodeChar: SmallInt;

    //Decode a string from the tree
    function DecodePosition: Word;

    //Start LZH
    procedure InitLZH;

    //End LZH
    procedure EndLZH;
  protected
    procedure InternalRead(var Data; Size : Word; var BytesRead: Word);
    procedure InternalWrite(const Data; Size : Word; var BytesWritten: Word);
    procedure ReadData(var Data; Size : Word; var BytesRead: Word);
    procedure WriteData(const Data; Size : Word; var BytesWritten: Word);
  public
    constructor Create(Source, Dest : TStream);
    function Pack(OrigSize: Longint): Longint;
    procedure Unpack;
  end;

implementation {===============================================================}

procedure TLZHStream.InitTree;
var
  I: SmallInt;
begin
  for I := cStringBufferSize + 1 to cStringBufferSize + 256 do
    RightLeaf[i] := cNull;  // ROOT !!

  for I := 0 TO cStringBufferSize do
    ParentLeaf[i] := cNull; //NODE
end;

Procedure TLZHStream.InsertNode(r : SmallInt);
var
  tmp,i, p, cmp : SmallInt;
  key : PTextBuffer;
  c : WORD;
begin
  cmp := 1;
  key := @TextBuff[r];
  p := SUCC(cStringBufferSize) + key[0];
  RightLeaf[r] := cNull;
  LeftLeaf[r] := cNull;
  MatchLen := 0;
  while MatchLen < cLookAheadSize do begin
    if (cmp >= 0) then begin
	    if (RightLeaf[p] <> cNull) then
        p := RightLeaf[p]
      else begin
	      RightLeaf[p] := r;
		    ParentLeaf[r] := p;
		    exit;
      end;
    end else begin
      if (LeftLeaf[p] <> cNull) then
	       p := LeftLeaf[p]
      else begin
        LeftLeaf[p] := r;
		    ParentLeaf[r] := p;
		    exit;
      end;
    end;

    i := 0;
    cmp := 0;
	  while (i < cLookAheadSize) and (cmp = 0) do begin
      inc(i);
      cmp := key[i] - TextBuff[p + i];
    end;

    if (i > cThreshHold) then begin
      tmp := PRED((r - p) and PRED(cStringBufferSize));
	    if (i > MatchLen) then begin
        MatchPos := tmp;
        MatchLen := i;
      end;

	    if (MatchLen < cLookAheadSize) and (i = MatchLen) then begin
        c := tmp;
		    if (c < MatchPos) then begin
          MatchPos := c;
        end;
      end;
    end; { if i > threshold }
  end; { WHILE match_length < F }

  ParentLeaf[r] := ParentLeaf[p];
  LeftLeaf[r] := LeftLeaf[p];
  RightLeaf[r] := RightLeaf[p];
  ParentLeaf[LeftLeaf[p]] := r;
  ParentLeaf[RightLeaf[p]] := r;
  if (RightLeaf[ParentLeaf[p]] = p) then
    RightLeaf[ParentLeaf[p]] := r
  else
    LeftLeaf[ParentLeaf[p]] := r;

  ParentLeaf[p] := cNull;  { remove p }
end;

procedure TLZHStream.DeleteNode(p: SmallInt);
var
  q : SmallInt;
begin
  if (ParentLeaf[p] = cNull) then exit; //Unregistered node

  if RightLeaf[p] = cNull then
   q := LeftLeaf[p]
  else begin
    if (LeftLeaf[p] = cNull) then
      q := RightLeaf[p]
    else begin
      q := LeftLeaf[p];
      if (RightLeaf[q] <> cNull) then begin
        repeat
          q := RightLeaf[q];
        until (RightLeaf[q] = cNull);

        RightLeaf[ParentLeaf[q]] := LeftLeaf[q];
        ParentLeaf[LeftLeaf[q]] := ParentLeaf[q];
        LeftLeaf[q] := LeftLeaf[p];
        ParentLeaf[LeftLeaf[p]] := q;
      end;

      RightLeaf[q] := RightLeaf[p];
      ParentLeaf[RightLeaf[p]] := q;
    end;
  end;
  ParentLeaf[q] := ParentLeaf[p];

  if (RightLeaf[ParentLeaf[p]] = p) then
    RightLeaf[ParentLeaf[p]] := q
  else
    LeftLeaf[ParentLeaf[p]] := q;

  ParentLeaf[p] := cNull;
end;


{ Huffman coding parameters }
function TLZHStream.GetBit: SmallInt;
var
  i: BYTE;
  i2: SmallInt;
  Wresult: Word;
begin
  while (getlen <= 8) do begin
    InternalRead(i,1,Wresult);
    if Wresult = 1 then
      i2 := i
    else
      i2 := 0;

    getbuf := getbuf OR (i2 SHL (8 - getlen));
    inc(getlen,8);
  end;

  i2 := getbuf;
  getbuf := getbuf SHL 1;
  dec(getlen);
  getbit := SmallInt((i2 < 0));
end;

function TLZHStream.GetByte: SmallInt;
var
  j: BYTE;
  i,Wresult: WORD;
begin
  while (getlen <= 8) do begin
    InternalRead(j,1,Wresult);
    if Wresult = 1 then
      i := j
    else
      i := 0;

    getbuf := getbuf OR (i SHL (8 - getlen));
    inc(getlen,8);
  end;

  i := getbuf;
  getbuf := getbuf SHL 8;
  dec(getlen,8);
  getbyte := SmallInt(i SHR 8);
end;

procedure TLZHStream.Putcode(l : SmallInt; c: WORD);
var
  Temp: byte;
  Got: Word;
begin
  putbuf := putbuf OR (c SHR putlen);
  inc(putlen,l);

  if (putlen >= 8) then begin
    Temp := putbuf SHR 8;
    InternalWrite(Temp,1,Got);
    dec(putlen,8);
    if (putlen  >= 8) then begin
      Temp := Lo(PutBuf);
      InternalWrite(Temp,1,Got);
      inc(codesize,2);
      dec(putlen,8);
      putbuf := c SHL (l - putlen);
    end else begin
	    putbuf := putbuf SHL 8;
	    inc(codesize);
    end;
  end;
end;

procedure TLZHStream.StartHuff;
var