(*  unit:        ThCoDec
    version:     2
    release:     Sep 2004
    developed:   2004
    environment: Borland Delphi 7
    --------------------------------------------------
    author: Thomas Lackó
    web:    http://thomas.sk
    e-mail: thomas.lacko@gmail.com
*)

unit ThCoDec;

INTERFACE

uses Thomas,Classes;
const UnitVersion = $04090702;

type
  TProgressProc=procedure(p:Real);
  THuffmanTree=class
    L,R:THuffmanTree; Code,Count:Integer;
    constructor Create(Left,Right:THuffmanTree;ACode,ACount:Integer);
    destructor Destroy; override;
  end;
  THuffmanMaster=class
    CodeSize:Integer;
    procedure CreateTree(const Count:array of Integer);
    procedure ReadTree(BS:TBitStream);
    function  ReadCode(BS:TBitStream):Integer;
    procedure WriteTree(BS:TBitStream);
    procedure WriteCode(BS:TBitStream;Code:Integer);
    destructor Destroy; override;
   private
    H:THuffmanTree;
    R:array of array of Integer;
  end;

procedure Huffman_Compress(SI,SO:TStream;SLen:Integer;Progress:TProgressProc);
procedure Huffman_Decompress(SI,SO:TStream;Progress:TProgressProc);
procedure LZW_Compress(SI,SO:TStream;SLen:Integer;LastChar:Byte;Progress:TProgressProc);
procedure LZW_Decompress(SI,SO:TStream;LastChar:Byte;Progress:TProgressProc);

IMPLEMENTATION

uses SysUtils;

const
  MAXSIZE=12; MAXCODE=1 shl MAXSIZE-1;

{ THuffmanTree }

constructor THuffmanTree.Create(Left,Right:THuffmanTree;ACode,ACount:Integer);
begin L:=Left; R:=Right; Code:=ACode; Count:=ACount; end;

destructor THuffmanTree.Destroy;
begin L.Free; R.Free; end;

{ THuffmanMaster }

function HufCompare(A,B:TObject):Boolean;
begin Result:=THuffmanTree(A).Count<=THuffmanTree(B).Count end;

procedure THuffmanMaster.ReadTree(BS:TBitStream);
  function ReadBranch:THuffmanTree;
  var T:THuffmanTree;
  begin
    if BS.Read(1)=0 then Result:=THuffmanTree.Create(nil,nil,BS.Read(CodeSize),0)
    else begin
      T:=ReadBranch; Result:=THuffmanTree.Create(T,ReadBranch,-1,0);
    end;
  end;
begin
  FreeAndNil(H); SetLength(R,0);
  CodeSize:=BS.Read(Log(INTBSIZE));
  H:=ReadBranch;
end;

function THuffmanMaster.ReadCode(BS:TBitStream):Integer;
var K:THuffmanTree;
begin
  K:=H;
  while K.L<>nil do
    if BS.Read(1)=0 then K:=K.L else K:=K.R;
  Result:=K.Code;
end;

procedure THuffmanMaster.CreateTree(const Count:array of Integer);
var
  P:TPriorityQueue; h1,h2:THuffmanTree; i:Integer;
  Nav:array[0..1023] of Byte; // (erm, this should be more than enough...)

  procedure Traverse(K:THuffmanTree;Depth:Integer);
  var j:Integer; i:^Integer;
  begin
    Assert((K.L=nil)=(K.R=nil),'Invalid Huffman tree');
    if K.L=nil then begin
      SetLength(R[K.Code],(Depth+INTBSIZE-1) div INTBSIZE+1);
      i:=@R[K.Code][0]; i^:=Depth;
      for j:=0 to Depth-1 do begin
        if j mod INTBSIZE=0 then begin
          Inc(i); i^:=0;
        end;
        if Nav[j]<>0 then i^:=i^ or 1 shl (j mod INTBSIZE);
      end;
    end
    else begin
      Nav[Depth]:=0; Traverse(K.L,Depth+1);
      Nav[Depth]:=1; Traverse(K.R,Depth+1);
    end;
  end;

begin
  FreeAndNil(H);
  CodeSize:=Log(Max(IndexOfLastOther(Count,0),0))+1;
  P:=TPriorityQueue.Create(HufCompare,False); P.BeginUpdate;
  try
    for i:=0 to High(Count) do
      if Count[i]<>0 then P.Push(THuffmanTree.Create(nil,nil,i,Count[i]));
    if P.Size=0 then P.Push(THuffmanTree.Create(nil,nil,0,0))
    else while P.Size>1 do begin
      h1:=THuffmanTree(P.Pop); h2:=THuffmanTree(P.Pop);
      P.Push(THuffmanTree.Create(h1,h2,0,h1.Count+h2.Count));
    end;
    H:=THuffmanTree(P.Pop);
  finally P.Free end;
  SetLength(R,Length(Count),1);
  for i:=0 to High(R) do R[i,0]:=0;
  Traverse(H,0);
end;

procedure THuffmanMaster.WriteTree(BS:TBitStream);
  procedure WriteBranch(K:THuffmanTree);
  begin
    if K.L=nil then begin
      BS.Write(1,0); BS.Write(CodeSize,K.Code);
    end
    else begin
      BS.Write(1,1); WriteBranch(K.L); WriteBranch(K.R);
    end;
  end;
begin
  if H=nil then raise Exception.Create('Huffman tree not ready');
  BS.Write(Log(INTBSIZE),CodeSize);
  WriteBranch(H);
end;

procedure THuffmanMaster.WriteCode(BS:TBitStream;Code:Integer);
var s:Integer; i:^Integer;
begin
  i:=@R[Code][0]; s:=i^;
  if s>0 then begin
    Inc(i);
    while s>INTBSIZE do begin
      BS.Write(INTBSIZE,i^); Inc(i); Dec(s,INTBSIZE);
    end;
    BS.Write(s,i^);
  end;
end;

destructor THuffmanMaster.Destroy;
begin H.Free end;

{ Huffman compression }

procedure Huffman_Compress(SI,SO:TStream;SLen:Integer;Progress:TProgressProc);
var
  H:THuffmanMaster; B:TBitStream;
  c:array[Byte] of Integer;
  i:Integer; x:Byte;
begin
  FillChar(c,SizeOf(c),0);
  for i:=1 to SLen do begin
    SI.Read(x,1); Inc(c[x]);
    if (i and $FFFF=0) and Assigned(Progress) then Progress(i/(2*SLen));
  end;
  SI.Seek(-SLen,soFromCurrent);
  SO.Write(SLen,4);
  H:=THuffmanMaster.Create;
  B:=TBufferedBitStream.Create(SO,bmWrite);
  try
    H.CreateTree(c); H.WriteTree(B);
    for i:=1 to SLen do begin
      SI.Read(x,1); H.WriteCode(B,x);
      if (i and $FFFF=0) and Assigned(Progress) then Progress((SLen+i)/(2*SLen));
    end;
  finally
    B.Free; H.Free;
  end;
end;

procedure Huffman_Decompress(SI,SO:TStream;Progress:TProgressProc);
var
  H:THuffmanMaster; B:TBitStream;
  s,p,i:Integer; x:Byte;
begin
  SI.Read(s,SizeOf(s)); p:=SI.Position+s;
  H:=THuffmanMaster.Create;
  B:=TBufferedBitStream.Create(SI,bmRead);
  try
    H.ReadTree(B);
    for i:=1 to s do begin
      x:=H.ReadCode(B); SO.Write(x,1);
      if (i and $FFFF=0) and Assigned(Progress) then Progress(i/s);
    end;
  finally
    B.Free; H.Free; SI.Position:=p;
  end;
end;

{ LZW }

procedure LZW_Compress(SI,SO:TStream;SLen:Integer;LastChar:Byte;Progress:TProgressProc);
var
  BS:TBitStream;
  L:array[0..MAXCODE  ] of Integer;
  Q:array[0..MAXCODE+1] of Integer;
  P:array[0..MAXCODE  ] of Integer;
  A:array[0..MAXCODE  ] of Byte;
  start,Mem,LSum,r,CodeSize,B,K,n,i:Integer;

  procedure Reset;
  begin
    FillInt(Q[0],High(Q),-1); LSum:=LastChar+1;
    n:=LastChar+2; CodeSize:=Log(n)+1;
  end;

begin
  start:=SO.Position; i:=0; SO.Write(i,4); SO.Write(i,4);
  for i:=0 to LastChar do begin
    L[i]:=1; P[i]:=i-1; A[i]:=i;
  end;
  P[LastChar+1]:=-1; Q[High(Q)]:=LastChar;
  BS:=TBufferedBitStream.Create(SO,bmWrite);
  Mem:=0; Reset; B:=High(Q); K:=0; r:=0;
  try
    while r<SLen do begin
      SI.Read(K,1); Inc(r);
      if (r and $7FFF=0) and Assigned(Progress) then Progress(r/SLen);
      i:=Q[B]; while (i>=0) and (A[i]<>K) do i:=P[i];
      if i>=0 then B:=i
      else begin
        BS.Write(CodeSize,B);
        L[n]:=L[B]+1; Inc(LSum,L[n]);
        P[n]:=Q[B]; Q[B]:=n; A[n]:=K;
        Inc(n); B:=K;
        if n=1 shl CodeSize then begin
          Inc(CodeSize);
          if CodeSize>MAXSIZE then begin
            if LSum>Mem then Mem:=LSum;
            Reset;
          end;
        end;
      end;
    end;
    if B>=0 then begin
      BS.Write(CodeSize,B);
      if n+1=1 shl CodeSize then Inc(CodeSize);
    end;
    if LSum>Mem then Mem:=LSum;
  finally
    BS.Write(CodeSize,LastChar+1); BS.Free;
  end;
  i:=SO.Position; r:=i-start-8; SO.Position:=start;
  SO.Write(r,4); SO.Write(Mem,4); SO.Position:=i;
end;

procedure LZW_Decompress(SI,SO:TStream;LastChar:Byte;Progress:TProgressProc);
var
  BS:TBitStream; B:PChar;
  L:array[0..MAXCODE] of Integer;
  T:array[0..MAXCODE] of PChar;
  ofs,size,r,rr,CodeSize,oc,nc,n,i:Integer;

  procedure UpdateProgress(s:Integer);
  begin
    Inc(r,s);
    if r>$7FFF then begin
      Dec(r,$8000); Inc(rr); Progress((rr shl 15+r)/size);
    end;
  end;

begin
  FillInt(L,LastChar+1,1); L[LastChar+1]:=0;
  {$if SizeOf(Integer)<>4} size:=0; i:=0; {$ifend}
  SI.Read(size,4); SI.Read(i,4); ofs:=SI.Position+size;
  if i>LastChar then GetMem(B,i)
  else raise Exception.Create('Invalid memory size record in LZW stream');
  {else GetMem(B,(MAXCODE-254)*(MAXCODE-253) div 2+255);}
  BS:=TBufferedBitStream.Create(SI,bmRead);
  try
    for i:=0 to LastChar do begin
      T[i]:=B+i; T[i]^:=Char(i);
    end;
    T[LastChar+1]:=B+LastChar+1; rr:=0; r:=0;
    repeat
      n:=LastChar+2; CodeSize:=Log(n)+1;
      nc:=BS.Read(CodeSize); Inc(r,CodeSize);
      SO.Write(T[nc]^,L[nc]);
      oc:=nc; nc:=BS.Read(CodeSize); Inc(r,CodeSize);
      while nc<>LastChar+1 do begin
        L[n]:=L[oc]+1;
        T[n]:=T[n-1]+L[n-1];
        Move(T[oc]^,T[n]^,L[n]);
        if nc<n then (T[n]+L[oc])^:=T[nc]^
        else (T[n]+L[oc])^:=T[oc]^;
        Inc(n); SO.Write(T[nc]^,L[nc]);
        if n=1 shl CodeSize-1 then begin
          Inc(CodeSize); if CodeSize>MAXSIZE then Break;
        end;
        oc:=nc; nc:=BS.Read(CodeSize); Inc(r,CodeSize);
        if r>$7FFF then begin
          Dec(r,$8000); Inc(rr);
          if Assigned(Progress) then Progress((rr shl 15+r)/size);
        end;
      end;
    until nc=LastChar+1;
  finally
    FreeMem(B); BS.Free; SI.Position:=ofs;
  end;
end;

END.
