unit Lzw;

interface

uses
  Windows, SysUtils, Classes;

const
  NOCODE = -1; // 空編碼
  LZWBITS = 8; // 字對處理位
  LZWBUFFER = $FFFF; // 編碼處理緩存容量（輸入緩存容量。經實踐，該值能達到較好的效率）
  LZWMAXBITS = 12; // 最大的編碼位（增加該值會增加編碼表的內存空間）
  LZWSTACKBUFFERSIZE = $FFFF; // 棧緩存容量（要保證它足夠大）
  LZWEXPORTBLOCKSIZE = $FFFF; // 輸出緩存容量
  LZWMAXCODES = 1 shl LZWMAXBITS; // 最大編碼（4096）
  LZWTABLESIZE = 1 shl (LZWBITS + LZWMAXBITS); // 編碼表容量（2MB空間）

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; // 該指針指向 ExportBlock ，用于訪問數組
    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; // 該指針指向 ExportBlock ，用于訪問數組
    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
  { 輸出位總是大于 LZWBITS 的 }
  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.