lzrw.pas

LZW, LZRW Compression Method

unit LZRW;

interface

uses SysUtils, Classes;

{$IFDEF WIN32}
type
  Int16 = SmallInt;
{$ELSE}
type
  Int16 = Integer;
{$ENDIF}

const
  BufferMaxSize = 32768;
  BufferMax     = BufferMaxSize - 1;
  FLAG_Copied   = $80;
  FLAG_Compress = $40;
  FSignature = 'LZRW';
  
type
  BufferIndex = 0..BufferMax + 15;
  BufferSize  = 0..BufferMaxSize;
  { extra bytes needed here if compression fails      *dh *}
  BufferArray = array [BufferIndex] of BYTE;
  BufferPtr   = ^BufferArray;


  ELzrw1KHCompressor = class(Exception);


function Compression(Source, Dest: BufferPtr; SourceSize: BufferSize): BufferSize;
function Decompression(Source, Dest: BufferPtr; SourceSize: BufferSize): BufferSize;

procedure CompressStream(InStream, OutStream: TStream; InSize: LongInt);
procedure DeCompressStream(InStream, OutStream: TStream);

implementation

type
  HashTable  = array [0..4095] of Int16;
  HashTabPtr = ^Hashtable;

var
  Hash: HashTabPtr;

  { check if this string has already been seen }
  { in the current 4 KB window }
  
function GetMatch(Source: BufferPtr; X: BufferIndex;
  SourceSize: BufferSize; Hash: HashTabPtr; var Size: WORD;
  var Pos: BufferIndex): BOOLEAN;
var
  HashValue: WORD;
  TmpHash: Int16;
begin
  HashValue := (40543 * ((((Source^[X] shl 4) xor Source^[X + 1]) shl 4) xor
    Source^[X + 2]) shr 4) and $0FFF;
  Result := False;
  TmpHash := Hash^[HashValue];
  if (TmpHash <> -1) and (X - TmpHash < 4096) then
  begin
    Pos  := TmpHash;
    Size := 0;
    while ((Size < 18) and (Source^[X + Size] = Source^[Pos + Size]) and
      (X + Size < SourceSize)) do
    begin
      INC(Size);
    end;
    Result := (Size >= 3)
  end;
  Hash^[HashValue] := X
end;

{ compress a buffer of max. 32 KB }

function Compression(Source, Dest: BufferPtr;
  SourceSize: BufferSize): BufferSize;
var
  Bit, Command, Size: WORD;
  Key: Word;
  X, Y, Z, Pos: BufferIndex;
begin
  FillChar(Hash^, SizeOf(Hashtable), $FF);
  Dest^[0] := FLAG_Compress;
  X := 0;
  Y := 3;
  Z := 1;
  Bit := 0;
  Command := 0;
  while (X < SourceSize) and (Y <= SourceSize) do
  begin
    if (Bit > 15) then
    begin
      Dest^[Z] := HI(Command);
      Dest^[Z + 1] := LO(Command);
      Z := Y;
      Bit := 0;
      INC(Y, 2)
    end;
    Size := 1;
    while ((Source^[X] = Source^[X + Size]) and (Size < $FFF) and
      (X + Size < SourceSize)) do
    begin
      INC(Size);
    end;
    if (Size >= 16) then
    begin
      Dest^[Y] := 0;
      Dest^[Y + 1] := HI(Size - 16);
      Dest^[Y + 2] := LO(Size - 16);
      Dest^[Y + 3] := Source^[X];
      INC(Y, 4);
      INC(X, Size);
      Command := (Command shl 1) + 1;
    end
    else
    begin { not size >= 16 }
      if (GetMatch(Source, X, SourceSize, Hash, Size, Pos)) then
      begin
        Key := ((X - Pos) shl 4) + (Size - 3);
        Dest^[Y] := HI(Key);
        Dest^[Y + 1] := LO(Key);
        INC(Y, 2);
        INC(X, Size);
        Command := (Command shl 1) + 1
      end
      else
      begin
        Dest^[Y] := Source^[X];
        INC(Y);
        INC(X);
        Command := Command shl 1
      end;
    end; { size <= 16 }
    INC(Bit);
  end; { while x < sourcesize ... }
  Command := Command shl (16 - Bit);
  Dest^[Z] := HI(Command);
  Dest^[Z + 1] := LO(Command);
  if (Y > SourceSize) then
  begin
    MOVE(Source^[0], Dest^[1], SourceSize);
    Dest^[0] := FLAG_Copied;
    Y        := SUCC(SourceSize)
  end;
  Result := Y
end;

{ decompress a buffer of max 32 KB }

function Decompression(Source, Dest: BufferPtr;
  SourceSize: BufferSize): BufferSize;
var
  X, Y, Pos: BufferIndex;
  Command, Size, K: WORD;
  Bit: BYTE;
  SaveY: BufferIndex; { * dh * unsafe for-loop variable Y }
begin
  if (Source^[0] = FLAG_Copied) then
  begin
    for Y := 1 to PRED(SourceSize) do
    begin
      Dest^[PRED(Y)] := Source^[Y];
      SaveY := Y;
    end;
    Y := SaveY;
  end
  else
  begin
    Y       := 0;
    X       := 3;
    Command := (Source^[1] shl 8) + Source^[2];
    Bit     := 16;
    while (X < SourceSize) do
    begin
      if (Bit = 0) then
      begin
        Command := (Source^[X] shl 8) + Source^[X + 1];
        Bit := 16;
        INC(X, 2)
      end;
      if ((Command and $8000) = 0) then
      begin
        Dest^[Y] := Source^[X];
        INC(X);
        INC(Y)
      end
      else
      begin  { command and $8000 }
        Pos := ((Source^[X] shl 4) + (Source^[X + 1] shr 4));
        if (Pos = 0) then
        begin
          Size := (Source^[X + 1] shl 8) + Source^[X + 2] + 15;
          for K := 0 to Size do
          begin
            Dest^[Y + K] := Source^[X + 3];
          end;
          INC(X, 4);
          INC(Y, Size + 1)
        end
        else
        begin  { pos = 0 }
          Size := (Source^[X + 1] and $0F) + 2;
          for K := 0 to Size do
            Dest^[Y + K] := Dest^[Y - Pos + K];
          INC(X, 2);
          INC(Y, Size + 1)
        end; { pos = 0 }
      end;   { command and $8000 }
      Command := Command shl 1;
      DEC(Bit)
    end { while x < sourcesize }
  end;
  Result := Y
end;  { decompression }

{
  Unit "Finalization" as Delphi 2.0 would have it
}

procedure CompressStream(InStream, OutStream: TStream; InSize: LongInt);
var
  InBuffer, OutBuffer: BufferArray;
  CompressedSize, BytesRead, FinalPos, SizePos, TotalSize: LongInt;
begin
  TotalSize := 0;
  OutStream.WriteBuffer(FSignature, SizeOf(FSignature));
  SizePos := OutStream.Position;
  OutStream.WriteBuffer(TotalSize, SizeOf(TotalSize));
  while InSize > 0 do
  begin
    BytesRead      := InStream.Read(InBuffer, SizeOf(InBuffer));
    CompressedSize := Compression(@InBuffer, @OutBuffer, BytesRead);
    OutStream.WriteBuffer(CompressedSize, SizeOf(CompressedSize));
    OutStream.WriteBuffer(OutBuffer, CompressedSize);
    TotalSize := TotalSize + CompressedSize + SizeOf(CompressedSize);
    InSize    := InSize - BytesRead;
  end;
  FinalPos := OutStream.Position;
  OutStream.Position := SizePos;
  OutStream.WriteBuffer(TotalSize, SizeOf(TotalSize));
  OutStream.Position := FinalPos;
end;

procedure DeCompressStream(InStream, OutStream: TStream);
var
  InBuffer, OutBuffer: BufferArray;
  CompressedSize, UnCompressedSize, InSize: LongInt;
  Sig: array[0..SizeOf(FSignature) - 1] of Char;
begin
  InStream.ReadBuffer(Sig, SizeOf(FSignature));
  if Sig <> FSignature then
    raise Exception.Create('Wrong file type');
  InStream.ReadBuffer(InSize, SizeOf(InSize));
  while InSize > 0 do
  begin
    InStream.ReadBuffer(CompressedSize, SizeOf(CompressedSize));
    InStream.ReadBuffer(InBuffer, CompressedSize);
    UnCompressedSize := DeCompression(@InBuffer, @OutBuffer, CompressedSize);
    OutStream.WriteBuffer(OutBuffer, UnCompressedSize);
    InSize := InSize - CompressedSize - SizeOf(CompressedSize);
  end;
end;

var
  ExitSave: Pointer;

procedure Cleanup; far;
begin
  ExitProc := ExitSave;
  if (Hash <> nil) then
    Freemem(Hash, Sizeof(HashTable));
end;

initialization
  Hash := nil;
  try
    Getmem(Hash, Sizeof(Hashtable));
  except
    raise ELzrw1KHCompressor.Create('LZRW1KH : no memory for HASH table');
  end;
  ExitSave := ExitProc;
  ExitProc := @Cleanup;
end.