unit Lzw;

interface

uses
Windows, SysUtils, Classes;

const
NOCODE = -1;
LZWBITS = 8;
LZWBUFFER = $FFFF;
LZWMAXBITS = 12;
LZWSTACKBUFFERSIZE = $FFFF;
LZWEXPORTBLOCKSIZE = $FFFF;
LZWMAXCODES = 1 shl LZWMAXBITS;
LZWTABLESIZE = 1 shl (LZWBITS + LZWMAXBITS);

type
TLZWEncode = class(TObject)
private
EncodeTable: array [0..LZWTABLESIZE - 1] of Word;
EncodePointer: array [0..LZWMAXCODES - 1] of LongWord;
ExportBlock: Pointer;
ExportBlockPtr: array of Byte;
InitBits: Integer;
ClearCode: Integer;
EofCode: Integer;
PrefixCode: Integer;
SuffixCode: Integer;
Encode: Integer;
RunBits: Integer;
MaxCodeSize: Integer;
FBegin: Boolean;
FExportSize: Integer;
FExportIndex: Integer;
FExportTotalSize: Integer;
ShiftBits: Integer;
ShiftCode: Integer;
protected
procedure ExportData(AData: Integer); virtual;
public
function GetExportPointer: Pointer;
function GetExportSize: Integer;
procedure GetBegin;
procedure GetEnd;
procedure Execute(Data: array of Byte; DataSize: Integer); virtual;
constructor Create;
destructor Destroy; override;
end;

TLZWUnencode = class(TObject)
private
InitBits: Integer;
ClearCode: Integer;
EofCode: Integer;
PrefixCode: Integer;
SuffixCode: Integer;
Encode: Integer;
RunBits: Integer;
MaxCodeSize: Integer;
ExportBlock: Pointer;
ExportBlockPtr: array of Byte;
StackIndex: Integer;
StackTable: array [0..LZWSTACKBUFFERSIZE - 1] of Byte;
PrefixTable: array [0..LZWMAXCODES - 1] of Word;
SuffixTable: array [0..LZWMAXCODES - 1] of Byte;
FExportSize: Integer;
FExportIndex: Integer;
FExportTotalSize: Integer;
ShiftBits: Integer;
ShiftCode: Integer;
protected
procedure ExportData(AData: Integer); virtual;
public
function GetExportPointer: Pointer;
function GetExportSize: Integer;
procedure GetBegin;
procedure GetEnd;
procedure Execute(Data: array of Byte; DataSize: Integer); virtual;
constructor Create;
destructor Destroy; override;
end;

implementation

{ TLZWEncode }

constructor TLZWEncode.Create;
begin
InitBits := LZWBITS;
ClearCode := 1 shl InitBits;
EofCode := ClearCode + 1;
Encode := EofCode + 1;
RunBits := InitBits + 1;
MaxCodeSize := 1 shl RunBits;
FBegin := False;
FExportSize := 0;
FExportIndex := 0;
FExportTotalSize := 0;
ShiftBits := 0;
ShiftCode := 0;
end;

destructor TLZWEncode.Destroy;
begin
FreeMem(ExportBlock);
inherited;
end;

procedure TLZWEncode.Execute(Data: array of Byte; DataSize: Integer);
var
AIndex: Integer;
ArrayIndex: Integer;
Vi: Integer;
begin
AIndex := 0;
FExportIndex := 0;
FExportTotalSize := LZWEXPORTBLOCKSIZE;
if FBegin then
begin
FBegin := False;
ExportData(ClearCode);
PrefixCode := Data[AIndex];
Inc(AIndex);
end;
while AIndex < DataSize do
begin
SuffixCode := Data[AIndex];
Inc(AIndex);
ArrayIndex := (PrefixCode shl LZWBITS) + SuffixCode;
if EncodeTable[ArrayIndex] = 0 then
begin
ExportData(PrefixCode);
if Encode = LZWMAXCODES then
begin
ExportData(ClearCode);
Encode := EofCode + 1;
RunBits := InitBits + 1;
MaxCodeSize := 1 shl RunBits;
for Vi := Encode to LZWMAXCODES - 1 do
EncodeTable[EncodePointer[Vi]] := 0;
end
else begin
if Encode = MaxCodeSize then
begin
Inc(RunBits);
MaxCodeSize := 1 shl RunBits;
end;
EncodeTable[ArrayIndex] := Encode;
EncodePointer[Encode] := ArrayIndex;
Inc(Encode);
end;
PrefixCode := SuffixCode;
end
else begin
PrefixCode := EncodeTable[ArrayIndex];
end;
end;
end;

procedure TLZWEncode.ExportData(AData: Integer);
procedure ExportProcedure;
begin
while ShiftBits >= LZWBITS do
begin
ExportBlockPtr[FExportIndex] := ShiftCode and $00FF;
Inc(FExportIndex);
if FExportIndex = FExportTotalSize then
begin
ReallocMem(ExportBlock, FExportIndex + LZWEXPORTBLOCKSIZE);
Pointer(ExportBlockPtr) := ExportBlock;
Inc(FExportTotalSize, LZWEXPORTBLOCKSIZE);
end;
ShiftCode := ShiftCode shr LZWBITS;
Dec(ShiftBits, LZWBITS);
end;
end;
begin
ShiftCode := AData shl ShiftBits + ShiftCode;
Inc(ShiftBits, RunBits);
ExportProcedure;
end;

function TLZWEncode.GetExportPointer: Pointer;
begin
Result := ExportBlock;
end;

function TLZWEncode.GetExportSize: Integer;
begin
FExportSize := FExportIndex;
Result := FExportSize;
end;

procedure TLZWEncode.GetBegin;
begin
FBegin := True;
ExportBlock := AllocMem(LZWEXPORTBLOCKSIZE);
Pointer(ExportBlockPtr) := ExportBlock;
end;

procedure TLZWEncode.GetEnd;
begin
ExportData(PrefixCode);
EXportData(EofCode);
while ShiftBits > 0 do
begin
ExportBlockPtr[FExportIndex] := ShiftCode and $00FF;
Inc(FExportIndex);
if FExportIndex = FExportTotalSize then
begin
ReallocMem(ExportBlock, FExportIndex + LZWEXPORTBLOCKSIZE);
Pointer(ExportBlockPtr) := ExportBlock;
Inc(FExportTotalSize, LZWEXPORTBLOCKSIZE);
end;
ShiftCode := ShiftCode shr LZWBITS;
Dec(ShiftBits, LZWBITS);
end;
end;

{ TLZWUnencode }

constructor TLZWUnencode.Create;
begin
InitBits := LZWBITS;
ClearCode := 1 shl InitBits;
EofCode := ClearCode + 1;
Encode := EofCode + 1;
RunBits := InitBits + 1;
MaxCodeSize := 1 shl RunBits;
ShiftBits := 0;
ShiftCode := 0;
FExportSize := 0;
FExportIndex := 0;
FExportTotalSize := 0;
end;

destructor TLZWUnencode.Destroy;
begin
inherited;
end;

procedure TLZWUnencode.Execute(Data: array of Byte; DataSize: Integer);
const
MaskCode: array [0..LZWMAXBITS] of Word = (
$0000, $0001, $0003, $0007,
$000F, $001F, $003F, $007F,
$00FF, $01FF, $03FF, $07FF,
$0FFF);
var
AIndex: Integer;
CurrentCode, ACode: Integer;
begin
AIndex := 0;
FExportIndex := 0;
FExportTotalSize := LZWSTACKBUFFERSIZE;
while AIndex < DataSize do
begin
while (ShiftBits < RunBits) and (AIndex < DataSize) do
begin
ShiftCode := Data[AIndex] shl ShiftBits + ShiftCode;
Inc(AIndex);
Inc(ShiftBits, LZWBITS);
end;

if AIndex >= DataSize then
Exit;
CurrentCode := ShiftCode and MaskCode[RunBits];
ShiftCode := ShiftCode shr RunBits;
Dec(ShiftBits, RunBits);
if CurrentCode = EofCode then
Exit;
if CurrentCode = ClearCode then
begin
RunBits := InitBits + 1;
Encode := EofCode + 1;
MaxCodeSize := 1 shl RunBits;
PrefixCode := NOCODE;
SuffixCode := NOCODE;
end
else
begin
ACode := CurrentCode;
StackIndex := 0;
if ACode = Encode then
begin
StackTable[StackIndex] := SuffixCode;
Inc(StackIndex);
ACode := PrefixCode;
end;
while ACode > EofCode do
begin
StackTable[StackIndex] := SuffixTable[ACode];
Inc(StackIndex);
ACode := PrefixTable[ACode];
end;
SuffixCode := ACode;
ExportData(ACode);
while StackIndex > 0 do
begin
Dec(StackIndex);
ExportData(StackTable[StackIndex]);
end;
if (Encode < LZWMAXCODES) and (PrefixCode <> NOCODE) then
begin
PrefixTable[Encode] := PrefixCode;
SuffixTable[Encode] := SuffixCode;
Inc(Encode);
if (Encode >= MaxCodeSize) and (RunBits < LZWMAXBITS) then
begin
MaxCodeSize := MaxCodeSize shl 1;
Inc(RunBits);
end;
end;
PrefixCode := CurrentCode;
end;
end;
end;

procedure TLZWUnencode.ExportData(AData: Integer);
begin
ExportBlockPtr[FExportIndex] := AData;
Inc(FExportIndex);
if FExportIndex = FExportTotalSize then
begin
ReallocMem(ExportBlock, FExportIndex + LZWSTACKBUFFERSIZE);
Pointer(ExportBlockPtr) := ExportBlock;
Inc(FExportTotalSize, LZWSTACKBUFFERSIZE);
end;
end;

procedure TLZWUnencode.GetBegin;
begin
ExportBlock := AllocMem(LZWSTACKBUFFERSIZE);
Pointer(ExportBlockPtr) := ExportBlock;
end;

procedure TLZWUnencode.GetEnd;
begin
FreeMem(ExportBlock);
end;

function TLZWUnencode.GetExportPointer: Pointer;
begin
Result := ExportBlock;
end;

function TLZWUnencode.GetExportSize: Integer;
begin
FExportSize := FExportIndex;
Result := FExportSize;
end;

end.