compresslzw.pas

老外的超高效率压缩

unit CompressLZW;

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
  private
    FInBufferSize :Integer;
    FOutBufferSize :Integer;
    FInBuffer :Pointer;
    FOutBuffer :Pointer;
    FInPtr :Integer;
    FOutPtr :Integer;
    FInCnt :Integer;
    FStatus :TCompressorStatus;
    FOnDone :TNotifyEvent;
    FOnGetData :TGetCompressorDataEvent;
    FOnSetData :TSetCompressorDataEvent;
    FElapsedTime :Integer;
    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;
    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 :Integer
      read FElapsedTime;
    property OnGetData :TGetCompressorDataEvent
      read FOnGetData write SetOnGetData;
    property OnSetData :TSetCompressorDataEvent
      read FOnSetData write SetOnSetData;
    property OnDone :TNotifyEvent
      read FOnDone write FOnDone;
  end;


  { LZW Compressor. Original TP Code by IAN HUNTER.
  I have rewritten some code in BASM, so now it
  works a bit faster, but is much more difficult
  to read/understand. Original code (pascal only, no asm)
  can be found in SWAG/ARCHIVES }

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;
    FInStream, FOutStream: TStream;
    procedure LZWReset;
    procedure MakeTableEntry( PrevC, FollC: Integer );
    function  Lookup( PrevC, FollC: Integer) : Integer;
    function  GetHashCode( PrevC, FollC : Integer ): integer;
  protected
    procedure GetData( pData :Pointer; var cbData :Integer ); override;
    procedure SetData( pData :Pointer; var cbData :Integer ); override;
    procedure DoCompress; override;
    procedure DoDecompress; override;
  public
    constructor Create; 
    destructor Destroy; override;
    property InStream: TStream read FInStream write FInStream;
    property OutStream: TStream read FOutStream write FOutStream;
    property InBufferSize;
    property OutBufferSize;
    property OnDone;
    property OnGetData;
    property OnSetData;
  end;



  
implementation

{$I COMPRESSLZW.INC}


const

EOF_CHAR  = -2;


MIN_BUFFER_SIZE     = $1000;
DEFAULT_BUFFER_SIZE = $1000;

{ Custom Compressor }

constructor TCustomCompressor.Create;
begin
  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;