{*******************************************************}
{                                                       }
{  Responsive Software     http://www.responsive.co.nz  }
{                                                       }
{  Copyright (c) 2003-2006 Responsive Software Limited  }
{                                                       }
{*******************************************************}

unit Compress;

interface

uses
  Windows, SysUtils, Classes;

type
  ECompressorError = class( exception );

  TCompressorStatus = ( CompressorIdle, CompressorBusy );

  TGetCompressorDataEvent = procedure( Sender :TObject;
    pData :Pointer; Var cbData :Integer ) of object;

  TSetCompressorDataEvent = procedure( Sender :TObject;
    pData :Pointer; Var cbData :Integer ) of object;

  CCustomCompressor = class Of TCustomCompressor;

  TCustomCompressor = class( TComponent )
  private
    FInBufferSize :Integer;
    FOutBufferSize :Integer;
    FInBuffer :Pointer;
    FOutBuffer :Pointer;
    FInPtr :Integer;
    FOutPtr :Integer;
    FInCnt :Integer;
    FStatus :TCompressorStatus;
    FOnDone :TNotifyEvent;
    FOnGetData :TGetCompressorDataEvent;
    FOnSetData :TSetCompressorDataEvent;
    FElapsedTime :Cardinal;
    procedure SetOnGetData( Value :TGetCompressorDataEvent );
    procedure SetOnSetData( Value :TSetCompressorDataEvent );
    procedure SetInBufferSize( Value :Integer );
    procedure SetOutBufferSize( Value :Integer );
    procedure AllocateBuffers;
  protected
    procedure ValidateIdleState;
    procedure Done; virtual;
    procedure GetData( pData :Pointer; var cbData :Integer ); virtual;
    procedure SetData( pData :Pointer; var cbData :Integer ); virtual;
    procedure DoCompress; virtual; abstract;
    procedure DoDecompress; virtual; abstract;
    function  GetChar :Integer;
    procedure PutChar( C :Integer );
    procedure FlushOutBuffer;
    procedure ResetInBuffer;
    procedure ResetOutBuffer;
    property InBuffer :Pointer
      read FInBuffer;
    property OutBuffer :Pointer
      read FOutBuffer;
  public
    constructor Create( anOwner :TComponent ); override;
    destructor Destroy; override;
    procedure WaitForIdle;
    procedure Compress;
    procedure Decompress;
    property InBufferSize :Integer
      read FInBufferSize write SetInBufferSize;
    property OutBufferSize :Integer
      read FOutBufferSize write SetOutBufferSize;
    property Status :TCompressorStatus
      read FStatus;
    property ElapsedTime :Cardinal
      read FElapsedTime;
    property OnGetData :TGetCompressorDataEvent
      read FOnGetData write SetOnGetData;
    property OnSetData :TSetCompressorDataEvent
      read FOnSetData write SetOnSetData;
    property OnDone :TNotifyEvent
      read FOnDone write FOnDone;
  end;

  TNullCOmpressor = class( TCustomCompressor )
  private
    procedure TransferData;
  protected
    procedure DoCompress; override;
    procedure DoDecompress; override;
  published
    property InBufferSize;
    property OutBufferSize;
    property OnDone;
    property OnGetData;
    property OnSetData;
  end;

const
  LZW_MAX_TABLE = $1000000;
  LZW_DEF_TABLE = $1000;
  LZW_MIN_TABLE = $1000;

type

  TLZWTableEntry = record
    Used : LongBool;
    PrevChar : Integer;
    FollChar : Integer;
    Next : Integer;
  end;

  PLZWStringTable = ^TLZWStringTable;
  TLZWStringTable = array[ 0..LZW_MAX_TABLE - 1 ] of TLZWTableEntry;

  TLZWStack = array [0..LZW_MAX_TABLE ] Of Integer;
  PLZWStack = ^TLZWStack;

  TLZWCompressor = class( TCustomCompressor )
  private
    FStrTbl :PLZWStringTable;
    FTblUsed :Integer;
    FTblSize :Integer;
    FTblLim  :Integer;
    procedure LZWReset;
    procedure MakeTableEntry( PrevC, FollC: Integer );
    function  Lookup( PrevC, FollC: Integer) : Integer;
    function  GetHashCode( PrevC, FollC : Integer ): integer;
  protected
    procedure DoCompress; override;
    procedure DoDecompress; override;
  public
    constructor Create( anOwner :TComponent ); override;
    destructor Destroy; override;
  published
    property InBufferSize;
    property OutBufferSize;
    property OnDone;
    property OnGetData;
    property OnSetData;
  end;

implementation

{$O+}
{$R-}
{$Q-}

const
  SFirst               = 42260;
  SCompressorBusy      = SFirst     +0;
  SInvalidBufferSize   = SFirst     +1;
  SInvalidData         = SFirst     +2;

  EOF_CHAR  = -2;

  MIN_BUFFER_SIZE     = $1000;
  DEFAULT_BUFFER_SIZE = $1000;

constructor TCustomCompressor.Create( anOwner :TComponent );
begin
  inherited Create( anOwner );
  FInBufferSize := DEFAULT_BUFFER_SIZE;
  FOutBufferSize := DEFAULT_BUFFER_SIZE;
  FStatus := CompressorIdle;
end;

destructor TCustomCompressor.Destroy;
begin
  ValidateIdleState;
  if FInBuffer <> Nil then FreeMem( FInBuffer );
  if FOutBuffer <> Nil then FreeMem( FOutBuffer );
  inherited Destroy;
end;

procedure TCustomCompressor.WaitForIdle;
begin
  while Status <> CompressorIdle do sleep(0);
end;

procedure TCustomCompressor.Compress;
begin
  ValidateIdleState;
  FStatus := CompressorBusy;
  try
    AllocateBuffers;
    FElapsedTime := GetTickCount;
    DoCompress;
    FElapsedTime := GetTickCount - FElapsedTime;
    Done;
  finally
    FStatus := CompressorIdle;
  end;
end;

procedure TCustomCompressor.Decompress;
begin
  ValidateIdleState;
  FStatus := CompressorBusy;
  try
    AllocateBuffers;
    FElapsedTime := GetTickCount;
    DoDecompress;
    FElapsedTime := GetTickCount - FElapsedTime;
    Done;
  finally
    FStatus := CompressorIdle;
  end;
end;

procedure TCustomCompressor.ValidateIdleState;
begin
 if Status <> CompressorIdle then
  raise ECompressorError.CreateRes( SCompressorBusy );
end;

procedure TCustomCompressor.Done;
begin
 if assigned( FOnDone ) then FOnDone( Self );
end;

procedure TCustomCompressor.SetOnGetData(
  Value :TGetCompressorDataEvent );
begin
  ValidateIdleState;
  FOnGetData := Value;
end;

procedure TCustomCompressor.SetOnSetData(
  Value :TSetCompressorDataEvent );
begin
  ValidateIdleState;
  FOnSetData := Value;
end;

procedure TCustomCompressor.SetInBufferSize( Value :Integer );
var NewBuffer :Pointer;
begin
   ValidateIdleState;
   if Value < MIN_BUFFER_SIZE then
     raise ECompressorError.CreateRes( SInvalidBufferSize );
   if FInBuffer <> Nil then
     begin
       GetMem( NewBuffer, Value );
       try
         FreeMem( FInBuffer );
       except
         FreeMem( NewBuffer );
         raise;
       end;
       FInBuffer := NewBuffer;
       FInBufferSize := Value;
     end
    else FInBufferSize := Value;
end;

procedure TCustomCompressor.SetOutBufferSize( Value :Integer );
var NewBuffer :Pointer;
begin
   ValidateIdleState;
   if Value < MIN_BUFFER_SIZE then
     raise ECompressorError.CreateRes( SInvalidBufferSize );
   if FOutBuffer <> Nil then
     begin
       GetMem( NewBuffer, Value );
       try
         FreeMem( FOutBuffer );
       except
         FreeMem( NewBuffer );
         raise;
       end;
       FOutBuffer := NewBuffer;
       FOutBufferSize := Value;
     end
    else FOutBufferSize := Value;
end;


procedure TCustomCompressor.AllocateBuffers;
begin
  if FInBuffer = nil then GetMem( FInBuffer, FInBufferSize );
  if FOutBuffer = nil then GetMem( FOutBuffer, FOutBufferSize );
end;

procedure TCustomCompressor.GetData(
  pData :Pointer; var cbData :Integer );
begin
  if assigned( FOnGetData )
    then FOnGetData( Self, pData, cbData )
    else cbData := 0;
end;

procedure TCustomCompressor.SetData(
  pData :Pointer; var cbData :Integer );
begin
  if assigned( FOnSetData ) then FOnSetData( Self, pData, cbData );
end;

function TCustomCompressor.GetChar :integer;
Begin
  result := EOF_CHAR;
  if FInPtr >= FInCnt then
    begin
      FInCnt := FInBufferSize;
      GetData( FInBuffer, FInCnt );
      FInPtr := 0;
    end;
  if FInPtr < FInCnt then
    asm
      mov    eax, self
      mov    ecx, [ eax ].TCustomCOmpressor.FInPtr
      inc    [ eax ].TCustomCOmpressor.FInPtr
      mov    eax, [ eax ].TCustomCOmpressor.FInBuffer
      movzx  eax, byte ptr [ eax + ecx ]
      mov    @result, eax
    end;
End;

procedure TCustomCompressor.PutChar( C :Integer );
assembler;
asm
        mov   ecx, [ eax ].TCustomCompressor.FOutPtr
        cmp   ecx, [ eax ].TCustomCompressor.FOutBufferSize
        jl    @@1
        push  eax
        push  edx
        call  TCustomCompressor.FlushOutBuffer
        pop   edx
        pop   eax
        mov   ecx, [ eax ].TCustomCompressor.FOutPtr
@@1:    inc   [ eax ].TCustomCompressor.FOutPtr
        mov   eax, [ eax ].TCustomCOmpressor.FOutBuffer
        mov   [ eax + ecx ], dl
end;

procedure TCustomCompressor.FlushOutBuffer;
begin
  SetData( FOutBuffer, FOutPtr );
  FOutPtr := 0;
end;

procedure TCustomCompressor.ResetInBuffer;
begin
  FInCnt := 0;
  FInPtr := 0;
end;

procedure TCustomCompressor.ResetOutBuffer;
begin
  FOutPtr := 0;
end;

procedure TNullCompressor.DoCompress;
begin
  TransferData;
end;

procedure TNullCompressor.DoDecompress;
begin
  TransferData;
end;

procedure TNullCompressor.TransferData;
var C :Integer;
begin
   repeat
     C := InBufferSize;
     GetData( InBuffer, C );
     SetData( InBuffer, C );
   until ( C = 0 );
end;

const
  LZW_NO_PREV   = $7FFF;
  LZW_END_LIST  = -1;
  LZW_EMPTY     = -3;

constructor TLZWCompressor.Create( anOwner :TComponent );
begin
 inherited Create( anOwner );
 FTblSize := LZW_DEF_TABLE;
 FTblLim := FTblSize - 1;
end;

destructor TLZWCompressor.Destroy;
begin
 if assigned( FStrTbl ) then FreeMem( FStrTbl );
 inherited Destroy;
end;

function TLZWCompressor.GetHashCode(
  PrevC, FollC : Integer) : integer;
assembler;
asm
   push  esi
   push  edi
   mov   esi, edx
   shl   esi, 5
   xor   esi, ecx
   mov   ecx, [ eax ].TLZWCompressor.FTblLim
   mov   eax, [ eax ].TLZWCompressor.FStrTbl
   and   esi, ecx
   mov   edi, esi
   shl   edi, 4
   cmp   [ eax + edi ].TLZWTableEntry.Used, 0
   je    @@1
@@3:
   cmp   [ eax + edi ].TLZWTableEntry.Next, LZW_END_LIST
   je    @@2
   mov   edi, [ eax + edi ].TLZWTableEntry.Next
   shl   edi, 4
   jmp   @@3
@@2:
   shr   edi, 4
   mov   esi, edi
   add   edi, 101
   and   edi, ecx
@@5:
   mov   edx, edi
   shl   edx, 4
   cmp   [ eax + edx ].TLZWTableEntry.Used, 0
   je    @@4
   inc   edi
   and   edi, ecx
   jmp   @@5
@@4:
   xchg  esi, edi
   shl   edi, 4
   mov   [ eax + edi ].TLZWTableEntry.Next, esi
@@1:
   mov   eax, esi
   pop   edi
   pop   esi
end;

procedure TLZWCompressor.DoCompress;
var PrevCode :Integer;

  procedure PutCode( H : Integer );
  begin
    If ( PrevCode = LZW_EMPTY )
      then begin
        PutChar( ( H SHR 4 ) AND $FF );
        PrevCode := H AND $0F;
      end
      else begin
        PutChar((( PrevCode SHL 4 ) AND $FF0) + (( H SHR 8) AND $00F));
        PutChar( H AND $FF );
        PrevCode := LZW_EMPTY;
      end;
  end;

Var C, I, W : Integer;
begin
  LZWReset;
  PrevCode := LZW_EMPTY;
  W := Lookup( LZW_NO_PREV, GetChar );
  C := GetChar;
  while ( C <> EOF_CHAR ) do
    begin
      I := Lookup( W, C );
      If ( I = LZW_END_LIST ) then
        begin
          MakeTableEntry( W, C );
          PutCode( W );
          W := Lookup( LZW_NO_PREV, C );
        end
        else W := I;
      C := GetChar;
    end;
  PutCode( W );
  FlushOutBuffer;
  FlushOutBuffer;
end;

procedure TLZWCompressor.MakeTableEntry( PrevC, FollC :Integer );
assembler;
asm
     push  esi
     mov   esi, [ eax ].TLZWCompressor.FTblUsed
     cmp   esi, [ eax ].TLZWCompressor.FTblLim
     jge   @@1
     inc   [ eax ].TLZWCompressor.FTblUsed
     push  edx
     push  ecx
     push  eax
     call  TLZWCompressor.GetHashCode
     shl   eax, 4
     pop   esi
     add   eax, [ esi ].TLZWCompressor.FStrTbl
     mov   [ eax ].TLZWTableEntry.Used, 1
     mov   [ eax ].TLZWTableEntry.Next, LZW_END_LIST
     nop
     pop   [ eax ].TLZWTableEntry.FollChar
     pop   [ eax ].TLZWTableEntry.PrevChar
@@1:
     pop   esi
end;

procedure TLZWCompressor.LZWReset;
Var I : Integer;
begin
  if FStrTbl = Nil then GetMem( FStrTbl, FTblSize * SizeOf( TLZWTableEntry ) );
  ResetInBuffer;
  ResetOutBuffer;
  FTblUsed := 0;
  For I := 0 to FTblLim Do
    With FStrTbl^[I] Do
      Begin
        PrevChar := LZW_NO_PREV;
        FollChar := LZW_NO_PREV;
        Next := -1;
        Used := False;
      End;
  For I := 0 to 255 Do MakeTableEntry(LZW_NO_PREV, I);
end;

function TLZWCompressor.Lookup(PrevC, FollC: Integer) : Integer;
assembler;
asm
   push ebx
   push esi
   mov  esi, edx
   shl  edx, 5
   xor  edx, ecx
   and  edx, [ eax ].TLZWCompressor.FTblLim
   mov  ebx, [ eax ].TLZWCompressor.FStrTbl
   mov  eax, LZW_END_LIST
@@2:
   shl  edx, 4
   cmp  [ edx + ebx ].TLZWTableEntry.PrevChar, esi
   jne  @@1
   cmp  [ edx + ebx ].TLZWTableEntry.FollChar, ecx
   je   @@3
@@1:
   mov  edx, [ edx + ebx ].TLZWTableEntry.Next
   cmp  edx, eax
   jne  @@2
   jmp  @@4
@@3:
   shr  edx, 4
   mov  eax, edx
@@4:
   pop  esi
   pop  ebx
end;

procedure TLZWCompressor.DoDecompress;
Var PrevCode :Integer;

  function GetCode : Integer;
  assembler;
  asm
     push  esi
     mov   eax, self
     mov   esi, eax
     call  TCustomCompressor.GetChar
     cmp   eax, EOF_CHAR
     je    @@x
     cmp   PrevCode, LZW_EMPTY
     jne   @@1
     mov   edx, eax
     mov   eax, esi
     push  edx
     call  TCustomCompressor.GetChar
     pop   edx
     cmp   eax, EOF_CHAR
     je    @@x
     and   edx, 000000FFh
     shl   edx, 4
     mov   PrevCode, eax
     and   PrevCode, 0000000Fh
     shr   eax, 4
     and   eax, 0000000Fh
     add   eax, edx
     jmp   @@x
  @@1:
     mov   edx, PrevCode
     shl   edx, 8
     and   edx, 00000F00h
     add   eax, edx
     mov   PrevCode, LZW_EMPTY
  @@X:
     pop   esi
  end;

Var
  Code : Integer;
  OldCode : Integer;
  FInChar : Integer;
  InCode : Integer;
  LastChar : Integer;
  U : Boolean;
  S : PLZWStack;
  P : Integer;
begin
  LZWReset;
  LastChar := 0;
  PrevCode := LZW_EMPTY;
  GetMem( S, SizeOf(Integer) * FTblSize );
  try
    P := 0;
    U := False;
    OldCode := GetCode;
    Code := OldCode;
    FinChar := FStrTbl^[ Code ].FollChar;
    PutChar( FInChar );
    InCode := GetCode;
    while ( InCode <> EOF_CHAR ) do
      begin
        Code := InCode;
        if ( not FStrTbl^[Code].Used ) then
          begin
            LastChar := FInChar;
            Code := OldCode;
            U := TRUE;
          End;
        while ( FStrTbl^[ Code ].PrevChar <> LZW_NO_PREV ) Do
          with FStrTbl[Code] do
            begin
              S^[ P ] := FollChar;
              inc( P );
              If P >= FTblSize Then raise ECompressorError.CreateRes(SInvalidData);
              Code := PrevChar;
            end;
        FInChar := FStrTbl^[Code].FollChar;
        PutChar( FInChar );
        asm
        @@2:
           mov  ecx, p
           or   ecx, ecx
           je   @@1
           dec  ecx
           mov  p, ecx
           mov  eax, s
           mov  edx, [ eax + ecx*4 ]
           mov  eax, self
           call TCustomCompressor.PutChar
           jmp  @@2
        @@1:
        end;
        If U Then
          Begin
            FInChar := LastChar;
            PutChar ( FInChar );
            U := FALSE;
          End;
        MakeTableEntry( OldCode, FInChar );
        OldCode := InCode;
        InCode := GetCode;
      End;

    FlushOutBuffer;
    FlushOutBuffer;

  finally
    FreeMem( S );
  end;
end;

end.