www.pudn.com > HgzVip1.2_code.rar > Lh5Unit.pas
(******************************************************************************)
(* *)
(* LH5.PAS *)
(* *)
(* This code compress/decompress data using the same algorithm as LHArc 2.x *)
(* It is roughly derived from the C source code of AR002 (a C version of a *)
(* subset of LHArc, written by Haruhiko Okomura). *)
(* The algorithm was created by Haruhiko Okomura and Haruyasu Yoshizaki. *)
(* *)
(* 6/11/98 Modified by Gregory L. Bullock with the hope of fixing a
problem when compiled for 32-bits.
Some variables of type TWord are sometimes treated as
ARRAY[0..32759]OF Integer; and other times as
ARRAY[0..32759]OF Word;
InsertNode, for example, expects a signed integer since it
includes the expression Position^[t]<0.
To account for this, I've defined TwoByteInt which is a 2-byte
signed integer on either platform.
*)
(* 4/20/98 Modified by Gregory L. Bullock (bullock@tsppd.com) *)
(* - to use TStream (and descendents) instead of files, *)
(* - to reduce the memory requirements in the data segment, *)
(* - to changed the program to a unit. *)
(* The interface consists of the two procedures *)
(* procedure LHACompress(InStr, OutStr: TStream); *)
(* procedure LHAExpand(InStr, OutStr: TStream); *)
(* These procedures DO NOT change the current position of EITHER *)
(* TStream before performing their function. Thus, LHACompress *)
(* starts compressing at InStr's current position and continues to *)
(* the end of InStr, placing the compressed output in OutStr *)
(* starting at OutStr's current position. If you need the entirety *)
(* of InStr compressed or uncompressed, you'll need to set *)
(* InStr.Position := 0 before calling one of these procedures. *)
(* *)
(* See the test program at the end of this unit for an example of *)
(* how to use these procedures. *)
(* *)
(* Changing this to a unit required the (internal) addition of *)
(* procedure FreeMemory; *)
(* procedure InitMemory; *)
(* to ensure that memory gets initialized properly between calls *)
(* to the unit's interface procedures. *)
(******************************************************************************)
{procedure THgzFsb.spSkinButton2Click(Sender: TObject);
var
MyStream: TMemoryStream;
MyStream1: TMemoryStream;
begin
MyStream := TMemoryStream.Create;
MyStream1 := TMemoryStream.Create;
MyStream.LoadFromFile('D:\Documents and Settings\gejun\×ÀÃæ\H_Client.exe');
MyStream.Position :=0;
LHACompress(MyStream,MyStream1);
MyStream1.SaveToFile('D:\Documents and Settings\gejun\×ÀÃæ\H_Client.exezipp');
end;
procedure THgzFsb.spSkinButton1Click(Sender: TObject);
var
MyStream: TMemoryStream;
MyStream1: TMemoryStream;
begin
MyStream := TMemoryStream.Create;
MyStream1 := TMemoryStream.Create;
MyStream.LoadFromFile('D:\Documents and Settings\gejun\×ÀÃæ\H_Client.exezipp');
MyStream.Position :=0;
LHAExpand(MyStream,MyStream1);
MyStream1.SaveToFile('D:\Documents and Settings\gejun\×ÀÃæ\H_Cli000ent.exe');
end;}
unit Lh5Unit;
{Turn off range checking - MANDATORY ! and stack checking (to speed up things)}
{$B-,R-,S-}
{$DEFINE PERCOLATE}
(*
NOTE :
LHArc uses a "percolating" update of its Lempel-Ziv structures.
If you use the percolating method, the compressor will run slightly faster,
using a little more memory, and will be slightly less efficient than the
standard method.
You can choose either method, and note that the decompressor is not
affected by this choice and is able to decompress data created by each one
of the compressors.
*)
interface
uses
SysUtils, Classes;
procedure LHACompress(InStr, OutStr: TStream);
(* LHACompress starts compressing at InStr's current position and continues
to the end of InStr, placing the compressed output in OutStr starting at
OutStr's current position. If you need the entirety of InStr compressed
you'll need to set InStr.Position := 0 before calling.
*)
procedure LHAExpand(InStr, OutStr: TStream);
(* LHAExpand starts expanding at InStr's current position and continues to
the end of InStr, placing the expanded output in OutStr starting at
OutStr's current position. If you need the entirety of InStr expanded
you'll need to set InStr.Position := 0 before calling.
*)
implementation
type
{$IFDEF WIN32}
TwoByteInt = SmallInt;
{$ELSE}
TwoByteInt = Integer;
{$ENDIF}
PWord = ^TWord;
TWord = array[0..32759] of TwoByteInt;
PByte = ^TByte;
TByte = array[0..65519] of Byte;
const
(*
NOTE :
The following constants are set to the values used by LHArc.
You can change three of them as follows :
DICBIT : Lempel-Ziv dictionnary size.
Lowering this constant can lower the compression efficiency a lot !
But increasing it (on a 32 bit platform only, i.e. Delphi 2) will not yield
noticeably better results.
If you set DICBIT to 15 or more, set PBIT to 5; and if you set DICBIT to 19
or more, set NPT to NP, too.
WINBIT : Sliding window size.
The compression ratio depends a lot of this value.
You can increase it to 15 to get better results on large files.
I recommend doing this if you have enough memory, except if you want that
your compressed data remain compatible with LHArc.
On a 32 bit platform, you can increase it to 16. Using a larger value will
only waste time and memory.
BUFBIT : I/O Buffer size. You can lower it to save memory, or increase it
to reduce disk access.
*)
BITBUFSIZ = 16;
UCHARMAX = 255;
DICBIT = 13;
DICSIZ = 1 shl DICBIT;
MATCHBIT = 8;
MAXMATCH = 1 shl MATCHBIT;
THRESHOLD = 3;
PERCFLAG = $8000;
NC = (UCHARMAX + MAXMATCH + 2 - THRESHOLD);
CBIT = 9;
CODEBIT = 16;
NP = DICBIT + 1;
NT = CODEBIT + 3;
PBIT = 4; {Log2(NP)}
TBIT = 5; {Log2(NT)}
NPT = NT; {Greater from NP and NT}
NUL = 0;
MAXHASHVAL = (3 * DICSIZ + (DICSIZ shr 9 + 1) * UCHARMAX);
WINBIT = 14;
WINDOWSIZE = 1 shl WINBIT;
BUFBIT = 13;
BUFSIZE = 1 shl BUFBIT;
type
BufferArray = array[0..PRED(BUFSIZE)] of Byte;
LeftRightArray = array[0..2 * (NC - 1)] of Word;
CTableArray = array[0..4095] of Word;
CLenArray = array[0..PRED(NC)] of Byte;
HeapArray = array[0..NC] of Word;
var
OrigSize, CompSize: Longint;
InFile, OutFile: TStream;
BitBuf: Word;
n, HeapSize: TwoByteInt;
SubBitBuf, BitCount: Word;
Buffer: ^BufferArray;
BufPtr: Word;
Left, Right: ^LeftRightArray;
PtTable: array[0..255] of Word;
PtLen: array[0..PRED(NPT)] of Byte;
CTable: ^CTableArray;
CLen: ^CLenArray;
BlockSize: Word;
{ The following variables are used by the compression engine only }
Heap: ^HeapArray;
LenCnt: array[0..16] of Word;
Freq, SortPtr: PWord;
Len: PByte;
Depth: Word;
Buf: PByte;
CFreq: array[0..2 * (NC - 1)] of Word;
PFreq: array[0..2 * (NP - 1)] of Word;
TFreq: array[0..2 * (NT - 1)] of Word;
CCode: array[0..PRED(NC)] of Word;
PtCode: array[0..PRED(NPT)] of Word;
CPos, OutputPos, OutputMask: Word;
Text, ChildCount: PByte;
Pos, MatchPos, Avail: Word;
Position, Parent, Prev, Next: PWord;
Remainder, MatchLen: TwoByteInt;
Level: PByte;
{********************************** File I/O **********************************}
function GetC: Byte;
begin
if BufPtr = 0 then
InFile.Read(Buffer^, BUFSIZE);
GetC := Buffer^[BufPtr]; BufPtr := SUCC(BufPtr) and PRED(BUFSIZE);
end;
procedure PutC(c: Byte);
begin
if BufPtr = BUFSIZE then
begin
OutFile.Write(Buffer^, BUFSIZE); BufPtr := 0;
end;
Buffer^[BufPtr] := C; INC(BufPtr);
end;
function BRead(p: POINTER; n: TwoByteInt): TwoByteInt;
begin
BRead := InFile.Read(p^, n);
end;
procedure BWrite(p: POINTER; n: TwoByteInt);
begin
OutFile.Write(p^, n);
end;
{**************************** Bit handling routines ***************************}
procedure FillBuf(n: TwoByteInt);
begin
BitBuf := (BitBuf shl n);
while n > BitCount do begin
DEC(n, BitCount);
BitBuf := BitBuf or (SubBitBuf shl n);
if (CompSize <> 0) then
begin
DEC(CompSize); SubBitBuf := GetC;
end else
SubBitBuf := 0;
BitCount := 8;
end;
DEC(BitCount, n);
BitBuf := BitBuf or (SubBitBuf shr BitCount);
end;
function GetBits(n: TwoByteInt): Word;
begin
GetBits := BitBuf shr (BITBUFSIZ - n);
FillBuf(n);
end;
procedure PutBits(n: TwoByteInt; x: Word);
begin
if n < BitCount then
begin
DEC(BitCount, n);
SubBitBuf := SubBitBuf or (x shl BitCount);
end else begin
DEC(n, BitCount);
PutC(SubBitBuf or (x shr n)); INC(CompSize);
if n < 8 then
begin
BitCount := 8 - n; SubBitBuf := x shl BitCount;
end else begin
PutC(x shr (n - 8)); INC(CompSize);
BitCount := 16 - n; SubBitBuf := x shl BitCount;
end;
end;
end;
procedure InitGetBits;
begin
BitBuf := 0; SubBitBuf := 0; BitCount := 0; FillBuf(BITBUFSIZ);
end;
procedure InitPutBits;
begin
BitCount := 8; SubBitBuf := 0;
end;
{******************************** Decompression *******************************}
procedure MakeTable(nchar: TwoByteInt; BitLen: PByte; TableBits: TwoByteInt; Table: PWord);
var
count, weight: array[1..16] of Word;
start: array[1..17] of Word;
p: PWord;
i, k, Len, ch, jutbits, Avail, nextCode, mask: TwoByteInt;
begin
for i := 1 to 16 do
count[i] := 0;
for i := 0 to PRED(nchar) do
INC(count[BitLen^[i]]);
start[1] := 0;
for i := 1 to 16 do
start[SUCC(i)] := start[i] + (count[i] shl (16 - i));
if start[17] <> 0 then
HALT(1);
jutbits := 16 - TableBits;
for i := 1 to TableBits do
begin
start[i] := start[i] shr jutbits; weight[i] := 1 shl (TableBits - i);
end;
i := SUCC(TableBits);
while (i <= 16) do begin
weight[i] := 1 shl (16 - i); INC(i);
end;
i := start[SUCC(TableBits)] shr jutbits;
if i <> 0 then
begin
k := 1 shl TableBits;
while i <> k do begin
Table^[i] := 0; INC(i);
end;
end;
Avail := nchar; mask := 1 shl (15 - TableBits);
for ch := 0 to PRED(nchar) do
begin
Len := BitLen^[ch];
if Len = 0 then
CONTINUE;
k := start[Len];
nextCode := k + weight[Len];
if Len <= TableBits then
begin
for i := k to PRED(nextCode) do
Table^[i] := ch;
end else begin
p := Addr(Table^[word(k) shr jutbits]); i := Len - TableBits;
while i <> 0 do begin
if p^[0] = 0 then
begin
right^[Avail] := 0; left^[Avail] := 0; p^[0] := Avail; INC(Avail);
end;
if (k and mask) <> 0 then
p := addr(right^[p^[0]])
else
p := addr(left^[p^[0]]);
k := k shl 1; DEC(i);
end;
p^[0] := ch;
end;
start[Len] := nextCode;
end;
end;
procedure ReadPtLen(nn, nBit, ispecial: TwoByteInt);
var
i, c, n: TwoByteInt;
mask: Word;
begin
n := GetBits(nBit);
if n = 0 then
begin
c := GetBits(nBit);
for i := 0 to PRED(nn) do
PtLen[i] := 0;
for i := 0 to 255 do
PtTable[i] := c;
end else begin
i := 0;
while (i < n) do begin
c := BitBuf shr (BITBUFSIZ - 3);
if c = 7 then
begin
mask := 1 shl (BITBUFSIZ - 4);
while (mask and BitBuf) <> 0 do begin
mask := mask shr 1; INC(c);
end;
end;
if c < 7 then
FillBuf(3)
else
FillBuf(c - 3);
PtLen[i] := c; INC(i);
if i = ispecial then
begin
c := PRED(TwoByteInt(GetBits(2)));
while c >= 0 do begin
PtLen[i] := 0; INC(i); DEC(c);
end;
end;
end;
while i < nn do begin
PtLen[i] := 0; INC(i);
end;
MakeTable(nn, @PtLen, 8, @PtTable);
end;
end;
procedure ReadCLen;
var
i, c, n: TwoByteInt;
mask: Word;
begin
n := GetBits(CBIT);
if n = 0 then
begin
c := GetBits(CBIT);
for i := 0 to PRED(NC) do
CLen^[i] := 0;
for i := 0 to 4095 do
CTable^[i] := c;
end else begin
i := 0;
while i < n do begin
c := PtTable[BitBuf shr (BITBUFSIZ - 8)];
if c >= NT then
begin
mask := 1 shl (BITBUFSIZ - 9);
repeat
if (BitBuf and mask) <> 0 then
c := right^[c]
else
c := left^[c];
mask := mask shr 1;
until c < NT;
end;
FillBuf(PtLen[c]);
if c <= 2 then
begin
if c = 1 then
c := 2 + GetBits(4)
else
if c = 2 then
c := 19 + GetBits(CBIT);
while c >= 0 do begin
CLen^[i] := 0; INC(i); DEC(c);
end;
end else begin
CLen^[i] := c - 2; INC(i);
end;
end;
while i < NC do begin
CLen^[i] := 0; INC(i);
end;
MakeTable(NC, PByte(CLen), 12, PWord(CTable));
end;
end;
function DecodeC: Word;
var
j, mask: Word;
begin
if BlockSize = 0 then
begin
BlockSize := GetBits(16);
ReadPtLen(NT, TBIT, 3);
ReadCLen;
ReadPtLen(NP, PBIT, -1);
end;
DEC(BlockSize);
j := CTable^[BitBuf shr (BITBUFSIZ - 12)];
if j >= NC then
begin
mask := 1 shl (BITBUFSIZ - 13);
repeat
if (BitBuf and mask) <> 0 then
j := right^[j]
else
j := left^[j];
mask := mask shr 1;
until j < NC;
end;
FillBuf(CLen^[j]);
DecodeC := j;
end;
function DecodeP: Word;
var
j, mask: Word;
begin
j := PtTable[BitBuf shr (BITBUFSIZ - 8)];
if j >= NP then
begin
mask := 1 shl (BITBUFSIZ - 9);
repeat
if (BitBuf and mask) <> 0 then
j := right^[j]
else
j := left^[j];
mask := mask shr 1;
until j < NP;
end;
FillBuf(PtLen[j]);
if j <> 0 then
begin
DEC(j); j := (1 shl j) + GetBits(j);
end;
DecodeP := j;
end;
{declared as static vars}
var
decode_i: Word;
decode_j: TwoByteInt;
procedure DecodeBuffer(count: Word; Buffer: PByte);
var
c, r: Word;
begin
r := 0; DEC(decode_j);
while (decode_j >= 0) do begin
Buffer^[r] := Buffer^[decode_i]; decode_i := SUCC(decode_i) and PRED(DICSIZ);
INC(r);
if r = count then
EXIT;
DEC(decode_j);
end;
while TRUE do begin
c := DecodeC;
if c <= UCHARMAX then
begin
Buffer^[r] := c; INC(r);
if r = count then
EXIT;
end else begin
decode_j := c - (UCHARMAX + 1 - THRESHOLD);
decode_i := (LongInt(r) - DecodeP - 1) and PRED(DICSIZ);
DEC(decode_j);
while decode_j >= 0 do begin
Buffer^[r] := Buffer^[decode_i];
decode_i := SUCC(decode_i) and PRED(DICSIZ);
INC(r);
if r = count then
EXIT;
DEC(decode_j);
end;
end;
end;
end;
procedure Decode;
var
p: PByte;
l: Longint;
a: Word;
begin
{Initialize decoder variables}
GetMem(p, DICSIZ);
InitGetBits; BlockSize := 0;
decode_j := 0;
{skip file size}
l := OrigSize; DEC(compSize, 4);
{unpacks the file}
while l > 0 do begin
if l > DICSIZ then
a := DICSIZ
else
a := l;
DecodeBuffer(a, p);
OutFile.Write(p^, a); DEC(l, a);
end;
FreeMem(p, DICSIZ);
end;
{********************************* Compression ********************************}
{-------------------------------- Huffman part --------------------------------}
procedure CountLen(i: TwoByteInt);
begin
if i < n then
begin
if Depth < 16 then
INC(LenCnt[Depth])
else
INC(LenCnt[16]);
end else begin
INC(Depth);
CountLen(Left^[i]); CountLen(Right^[i]);
DEC(Depth);
end;
end;
procedure MakeLen(root: TwoByteInt);
var
i, k: TwoByteInt;
cum: word;
begin
for i := 0 to 16 do
LenCnt[i] := 0;
CountLen(root); cum := 0;
for i := 16 downto 1 do
INC(cum, LenCnt[i] shl (16 - i));
while cum <> 0 do begin
DEC(LenCnt[16]);
for i := 15 downto 1 do
if LenCnt[i] <> 0 then
begin
DEC(LenCnt[i]); INC(LenCnt[SUCC(i)], 2);
BREAK;
end;
DEC(cum);
end;
for i := 16 downto 1 do begin
k := PRED(Longint(LenCnt[i]));
while k >= 0 do begin
DEC(k); Len^[SortPtr^[0]] := i;
asm
ADD WORD PTR SortPtr,2; {SortPtr:=addr(SortPtr^[1]);}
end;
end;
end;
end;
procedure DownHeap(i: TwoByteInt);
var
j, k: TwoByteInt;
begin
k := Heap^[i]; j := i shl 1;
while (j <= HeapSize) do begin
if (j < HeapSize) and (Freq^[Heap^[j]] > Freq^[Heap^[SUCC(j)]]) then INC(j);
if Freq^[k] <= Freq^[Heap^[j]] then break;
Heap^[i] := Heap^[j]; i := j; j := i shl 1;
end;
Heap^[i] := k;
end;
procedure MakeCode(n: TwoByteInt; Len: PByte; Code: PWord);
var
i, k: TwoByteInt;
start: array[0..17] of Word;
begin
start[1] := 0;
for i := 1 to 16 do
start[SUCC(i)] := (start[i] + LenCnt[i]) shl 1;
for i := 0 to PRED(n) do begin
k := Len^[i];
Code^[i] := start[k];
INC(start[k]);
end;
end;
function MakeTree(NParm: TwoByteInt; Freqparm: PWord; LenParm: PByte; Codeparm: PWord): TwoByteInt;
var
i, j, k, Avail: TwoByteInt;
begin
n := NParm; Freq := Freqparm; Len := LenParm; Avail := n; HeapSize := 0; Heap^[1] := 0;
for i := 0 to PRED(n) do begin
Len^[i] := 0;
if Freq^[i] <> 0 then
begin
INC(HeapSize); Heap^[HeapSize] := i;
end;
end;
if HeapSize < 2 then
begin
Codeparm^[Heap^[1]] := 0; MakeTree := Heap^[1];
EXIT;
end;
for i := (HeapSize div 2) downto 1 do DownHeap(i);
SortPtr := Codeparm;
repeat
i := Heap^[1];
if i < n then
begin
SortPtr^[0] := i;
asm
ADD WORD PTR SortPtr,2; {SortPtr:=addr(SortPtr^[1]);}
end;
end;
Heap^[1] := Heap^[HeapSize]; DEC(HeapSize); DownHeap(1);
j := Heap^[1];
if j < n then
begin
SortPtr^[0] := j;
asm
ADD WORD PTR SortPtr,2; {SortPtr:=addr(SortPtr^[1]);}
end;
end;
k := Avail; INC(Avail);
Freq^[k] := Freq^[i] + Freq^[j]; Heap^[1] := k; DownHeap(1);
Left^[k] := i; Right^[k] := j;
until HeapSize <= 1;
SortPtr := Codeparm;
MakeLen(k); MakeCode(NParm, LenParm, Codeparm);
MakeTree := k;
end;
procedure CountTFreq;
var
i, k, n, Count: TwoByteInt;
begin
for i := 0 to PRED(NT) do
TFreq[i] := 0; n := NC;
while (n > 0) and (CLen^[PRED(n)] = 0) do
DEC(n);
i := 0;
while i < n do begin
k := CLen^[i]; INC(i);
if k = 0 then
begin
Count := 1;
while (i < n) and (CLen^[i] = 0) do begin
INC(i); INC(Count);
end;
if Count <= 2 then
INC(TFreq[0], Count)
else
if Count <= 18 then
INC(TFreq[1])
else
if Count = 19 then
begin
INC(TFreq[0]); INC(TFreq[1]);
end else
INC(TFreq[2]);
end else
INC(TFreq[k + 2]);
end;
end;
procedure WritePtLen(n, nBit, ispecial: TwoByteInt);
var
i, k: TwoByteInt;
begin
while (n > 0) and (PtLen[PRED(n)] = 0) do
DEC(n);
PutBits(nBit, n); i := 0;
while (i < n) do begin
k := PtLen[i]; INC(i);
if k <= 6 then
PutBits(3, k)
else
begin
DEC(k, 3);
PutBits(k, (1 shl k) - 2);
end;
if i = ispecial then
begin
while (i < 6) and (PtLen[i] = 0) do
INC(i);
PutBits(2, (i - 3) and 3);
end;
end;
end;
procedure WriteCLen;
var
i, k, n, Count: TwoByteInt;
begin
n := NC;
while (n > 0) and (CLen^[PRED(n)] = 0) do
DEC(n);
PutBits(CBIT, n); i := 0;
while (i < n) do begin
k := CLen^[i]; INC(i);
if k = 0 then
begin
Count := 1;
while (i < n) and (CLen^[i] = 0) do begin
INC(i); INC(Count);
end;
if Count <= 2 then
for k := 0 to PRED(Count) do
PutBits(PtLen[0], PtCode[0])
else
if Count <= 18 then
begin
PutBits(PtLen[1], PtCode[1]);
PutBits(4, Count - 3);
end else
if Count = 19 then
begin
PutBits(PtLen[0], PtCode[0]);
PutBits(PtLen[1], PtCode[1]);
PutBits(4, 15);
end else begin
PutBits(PtLen[2], PtCode[2]);
PutBits(CBIT, Count - 20);
end;
end else
PutBits(PtLen[k + 2], PtCode[k + 2]);
end;
end;
procedure EncodeC(c: TwoByteInt);
begin
PutBits(CLen^[c], CCode[c]);
end;
procedure EncodeP(p: Word);
var
c, q: Word;
begin
c := 0; q := p;
while q <> 0 do begin
q := q shr 1; INC(c);
end;
PutBits(PtLen[c], PtCode[c]);
if c > 1 then
PutBits(PRED(c), p and ($FFFF shr (17 - c)));
end;
procedure SendBlock;
var
i, k, flags, root, Pos, Size: Word;
begin
root := MakeTree(NC, @CFreq, PByte(CLen), @CCode);
Size := CFreq[root];
PutBits(16, Size);
if root >= NC then
begin
CountTFreq;
root := MakeTree(NT, @TFreq, @PtLen, @PtCode);
if root >= NT then
WritePtLen(NT, TBIT, 3)
else
begin
PutBits(TBIT, 0);
PutBits(TBIT, root);
end;
WriteCLen;
end else begin
PutBits(TBIT, 0);
PutBits(TBIT, 0);
PutBits(CBIT, 0);
PutBits(CBIT, root);
end;
root := MakeTree(NP, @PFreq, @PtLen, @PtCode);
if root >= NP then
WritePtLen(NP, PBIT, -1)
else
begin
PutBits(PBIT, 0);
PutBits(PBIT, root);
end;
Pos := 0;
for i := 0 to PRED(Size) do begin
if (i and 7) = 0 then
begin
flags := Buf^[Pos]; INC(Pos);
end else
flags := flags shl 1;
if (flags and (1 shl 7)) <> 0 then
begin
k := Buf^[Pos] + (1 shl 8); INC(Pos); EncodeC(k);
k := Buf^[Pos] shl 8; INC(Pos); INC(k, Buf^[Pos]); INC(Pos); EncodeP(k);
end else begin
k := Buf^[Pos]; INC(Pos); EncodeC(k);
end;
end;
for i := 0 to PRED(NC) do
CFreq[i] := 0;
for i := 0 to PRED(NP) do
PFreq[i] := 0;
end;
procedure Output(c, p: Word);
begin
OutputMask := OutputMask shr 1;
if OutputMask = 0 then
begin
OutputMask := 1 shl 7;
if (OutputPos >= WINDOWSIZE - 24) then
begin
SendBlock; OutputPos := 0;
end;
CPos := OutputPos; INC(OutputPos); Buf^[CPos] := 0;
end;
Buf^[OutputPos] := c; INC(OutputPos); INC(CFreq[c]);
if c >= (1 shl 8) then
begin
Buf^[CPos] := Buf^[CPos] or OutputMask;
Buf^[OutputPos] := (p shr 8); INC(OutputPos);
Buf^[OutputPos] := p; INC(OutputPos); c := 0;
while p <> 0 do begin
p := p shr 1; INC(c);
end;
INC(PFreq[c]);
end;
end;
{------------------------------- Lempel-Ziv part ------------------------------}
procedure InitSlide;
var
i: Word;
begin
for i := DICSIZ to (DICSIZ + UCHARMAX) do begin
Level^[i] := 1;
{$IFDEF PERCOLATE}
Position^[i] := NUL;
{$ENDIF}
end;
for i := DICSIZ to PRED(2 * DICSIZ) do
Parent^[i] := NUL;
Avail := 1;
for i := 1 to DICSIZ - 2 do
Next^[i] := SUCC(i);
Next^[PRED(DICSIZ)] := NUL;
for i := (2 * DICSIZ) to MAXHASHVAL do
Next^[i] := NUL;
end;
{ Hash function }
function Hash(p: TwoByteInt; c: Byte): TwoByteInt;
begin
Hash := p + (c shl (DICBIT - 9)) + 2 * DICSIZ;
end;
function Child(q: TwoByteInt; c: Byte): TwoByteInt;
var
r: TwoByteInt;
begin
r := Next^[Hash(q, c)]; Parent^[NUL] := q;
while Parent^[r] <> q do
r := Next^[r];
Child := r;
end;
procedure MakeChild(q: TwoByteInt; c: Byte; r: TwoByteInt);
var
h, t: TwoByteInt;
begin
h := Hash(q, c);
t := Next^[h]; Next^[h] := r; Next^[r] := t;
Prev^[t] := r; Prev^[r] := h; Parent^[r] := q;
INC(ChildCount^[q]);
end;
procedure Split(old: TwoByteInt);
var
new, t: TwoByteInt;
begin
new := Avail; Avail := Next^[new];
ChildCount^[new] := 0;
t := Prev^[old]; Prev^[new] := t;
Next^[t] := new;
t := Next^[old]; Next^[new] := t;
Prev^[t] := new;
Parent^[new] := Parent^[old];
Level^[new] := MatchLen;
Position^[new] := Pos;
MakeChild(new, Text^[MatchPos + MatchLen], old);
MakeChild(new, Text^[Pos + MatchLen], Pos);
end;
procedure InsertNode;
var
q, r, j, t: TwoByteInt;
c: Byte;
t1, t2: PChar;
begin
if MatchLen >= 4 then
begin
DEC(MatchLen);
r := SUCC(MatchPos) or DICSIZ;
q := Parent^[r];
while q = NUL do begin
r := Next^[r]; q := Parent^[r];
end;
while Level^[q] >= MatchLen do begin
r := q; q := Parent^[q];
end;
t := q;
{$IFDEF PERCOLATE}
while Position^[t] < 0 do begin
Position^[t] := Pos; t := Parent^[t];
end;
if t < DICSIZ then
Position^[t] := Pos or PERCFLAG;
{$ELSE}
while t < DICSIZ do begin
Position^[t] := Pos; t := Parent^[t];
end;
{$ENDIF}
end else begin
q := Text^[Pos] + DICSIZ; c := Text^[SUCC(Pos)]; r := Child(q, c);
if r = NUL then
begin
MakeChild(q, c, Pos); MatchLen := 1;
EXIT;
end;
MatchLen := 2;
end;
while true do begin
if r >= DICSIZ then
begin
j := MAXMATCH; MatchPos := r;
end else begin
j := Level^[r]; MatchPos := Position^[r] and not PERCFLAG;
end;
if MatchPos >= Pos then
DEC(MatchPos, DICSIZ);
t1 := addr(Text^[Pos + MatchLen]); t2 := addr(Text^[MatchPos + MatchLen]);
while MatchLen < j do begin
if t1^ <> t2^ then
begin
Split(r);
EXIT;
end;
INC(MatchLen); INC(t1); INC(t2);
end;
if MatchLen >= MAXMATCH then
BREAK;
Position^[r] := Pos; q := r;
r := Child(q, ORD(t1^));
if r = NUL then
begin
MakeChild(q, ORD(t1^), Pos);
EXIT;
end;
INC(MatchLen);
end;
t := Prev^[r]; Prev^[Pos] := t; Next^[t] := Pos;
t := Next^[r]; Next^[Pos] := t; Prev^[t] := Pos;
Parent^[Pos] := q; Parent^[r] := NUL; Next^[r] := Pos;
end;
procedure DeleteNode;
var
r, s, t, u: TwoByteInt;
{$IFDEF PERCOLATE}
q: TwoByteInt;
{$ENDIF}
begin
if Parent^[Pos] = NUL then
EXIT;
r := Prev^[Pos]; s := Next^[Pos]; Next^[r] := s; Prev^[s] := r;
r := Parent^[Pos]; Parent^[Pos] := NUL; DEC(ChildCount^[r]);
if (r >= DICSIZ) or (ChildCount^[r] > 1) then
EXIT;
{$IFDEF PERCOLATE}
t := Position^[r] and not PERCFLAG;
{$ELSE}
t := Position^[r];
{$ENDIF}
if t >= Pos then
DEC(t, DICSIZ);
{$IFDEF PERCOLATE}
s := t; q := Parent^[r]; u := Position^[q];
while (u and PERCFLAG) <> 0 do begin
u := u and not PERCFLAG;
if u >= Pos then
DEC(u, DICSIZ);
if u > s then
s := u;
Position^[q] := s or DICSIZ; q := Parent^[q]; u := Position^[q];
end;
if q < DICSIZ then
begin
if u >= Pos then
DEC(u, DICSIZ);
if u > s then
s := u;
Position^[q] := s or DICSIZ or PERCFLAG;
end;
{$ENDIF}
s := Child(r, Text^[t + Level^[r]]);
t := Prev^[s]; u := Next^[s]; Next^[t] := u; Prev^[u] := t;
t := Prev^[r]; Next^[t] := s; Prev^[s] := t;
t := Next^[r]; Prev^[t] := s; Next^[s] := t;
Parent^[s] := Parent^[r]; Parent^[r] := NUL;
Next^[r] := Avail; Avail := r;
end;
procedure GetNextMatch;
var
n: TwoByteInt;
begin
DEC(Remainder); INC(Pos);
if Pos = 2 * DICSIZ then
begin
move(Text^[DICSIZ], Text^[0], DICSIZ + MAXMATCH);
n := InFile.Read(Text^[DICSIZ + MAXMATCH], DICSIZ);
INC(Remainder, n); Pos := DICSIZ;
end;
DeleteNode; InsertNode;
end;
procedure Encode;
var
LastMatchLen, LastMatchPos: TwoByteInt;
begin
{ initialize encoder variables }
GetMem(Text, 2 * DICSIZ + MAXMATCH);
GetMem(Level, DICSIZ + UCHARMAX + 1);
GetMem(ChildCount, DICSIZ + UCHARMAX + 1);
{$IFDEF PERCOLATE}
GetMem(Position, (DICSIZ + UCHARMAX + 1) * SizeOf(Word));
{$ELSE}
GetMem(Position, (DICSIZ) * SizeOf(Word));
{$ENDIF}
GetMem(Parent, (DICSIZ * 2) * SizeOf(Word));
GetMem(Prev, (DICSIZ * 2) * SizeOf(Word));
GetMem(Next, (MAXHASHVAL + 1) * SizeOf(Word));
Depth := 0;
InitSlide;
GetMem(Buf, WINDOWSIZE);
Buf^[0] := 0;
FillChar(CFreq, sizeof(CFreq), 0);
FillChar(PFreq, sizeof(PFreq), 0);
OutputPos := 0; OutputMask := 0; InitPutBits;
Remainder := InFile.Read(Text^[DICSIZ], DICSIZ + MAXMATCH);
MatchLen := 0; Pos := DICSIZ; InsertNode;
if MatchLen > Remainder then
MatchLen := Remainder;
while Remainder > 0 do begin
LastMatchLen := MatchLen; LastMatchPos := MatchPos; GetNextMatch;
if MatchLen > Remainder then
MatchLen := Remainder;
if (MatchLen > LastMatchLen) or (LastMatchLen < THRESHOLD) then
Output(Text^[PRED(Pos)], 0)
else
begin
Output(LastMatchLen + (UCHARMAX + 1 - THRESHOLD), (Pos - LastMatchPos - 2) and PRED(DICSIZ));
DEC(LastMatchLen);
while LastMatchLen > 0 do begin
GetNextMatch; DEC(LastMatchLen);
end;
if MatchLen > Remainder then
MatchLen := Remainder;
end;
end;
{flush buffers}
SendBlock; PutBits(7, 0);
if BufPtr <> 0 then
OutFile.Write(Buffer^, BufPtr);
FreeMem(Buf, WINDOWSIZE);
FreeMem(Next, (MAXHASHVAL + 1) * SizeOf(Word));
FreeMem(Prev, (DICSIZ * 2) * SizeOf(Word));
FreeMem(Parent, (DICSIZ * 2) * SizeOf(Word));
{$IFDEF PERCOLATE}
FreeMem(Position, (DICSIZ + UCHARMAX + 1) * SizeOf(Word));
{$ELSE}
FreeMem(Position, (DICSIZ) * SizeOf(Word));
{$ENDIF}
FreeMem(ChildCount, DICSIZ + UCHARMAX + 1);
FreeMem(Level, DICSIZ + UCHARMAX + 1);
FreeMem(Text, 2 * DICSIZ + MAXMATCH);
end;
{****************************** LH5 as Unit Procedures ************************}
procedure FreeMemory;
begin
if CLen <> nil then Dispose(CLen); CLen := nil;
if CTable <> nil then Dispose(CTable); CTable := nil;
if Right <> nil then Dispose(Right); Right := nil;
if Left <> nil then Dispose(Left); Left := nil;
if Buffer <> nil then Dispose(Buffer); Buffer := nil;
if Heap <> nil then Dispose(Heap); Heap := nil;
end;
procedure InitMemory;
begin
{In should be harmless to call FreeMemory here, since it won't free
unallocated memory (i.e., nil pointers).
So let's call it in case an exception was thrown at some point and
memory wasn't entirely freed.}
FreeMemory;
New(Buffer);
New(Left);
New(Right);
New(CTable);
New(CLen);
FillChar(Buffer^, SizeOf(Buffer^), 0);
FillChar(Left^, SizeOf(Left^), 0);
FillChar(Right^, SizeOf(Right^), 0);
FillChar(CTable^, SizeOf(CTable^), 0);
FillChar(CLen^, SizeOf(CLen^), 0);
decode_i := 0;
BitBuf := 0;
n := 0;
HeapSize := 0;
SubBitBuf := 0;
BitCount := 0;
BufPtr := 0;
FillChar(PtTable, SizeOf(PtTable), 0);
FillChar(PtLen, SizeOf(PtLen), 0);
BlockSize := 0;
{ The following variables are used by the compression engine only }
New(Heap);
FillChar(Heap^, SizeOf(Heap^), 0);
FillChar(LenCnt, SizeOf(LenCnt), 0);
Depth := 0;
FillChar(CFreq, SizeOf(CFreq), 0);
FillChar(PFreq, SizeOf(PFreq), 0);
FillChar(TFreq, SizeOf(TFreq), 0);
FillChar(CCode, SizeOf(CCode), 0);
FillChar(PtCode, SizeOf(PtCode), 0);
CPos := 0;
OutputPos := 0;
OutputMask := 0;
Pos := 0;
MatchPos := 0;
Avail := 0;
Remainder := 0;
MatchLen := 0;
end;
{******************************** Interface Procedures ************************}
procedure LHACompress(InStr, OutStr: TStream);
begin
InitMemory;
try
InFile := InStr;
OutFile := OutStr;
OrigSize := InFile.Size - InFile.Position;
CompSize := 0;
OutFile.Write(OrigSize, 4);
Encode;
finally
FreeMemory;
end;
end;
procedure LHAExpand(InStr, OutStr: TStream);
begin
try
InitMemory;
InFile := InStr;
OutFile := OutStr;
CompSize := InFile.Size - InFile.Position;
InFile.Read(OrigSize, 4);
Decode;
finally
FreeMemory;
end;
end;
initialization
CLen := nil;
CTable := nil;
Right := nil;
Left := nil;
Buffer := nil;
Heap := nil;
end.
{******************************** Test Program ********************************}
{
The following simple program can be used for testing the LH5Unit.
It compresses/expands files compatible with LHArc.
}
program Testlh5;
uses
WinCRT,
SysUtils,
Classes,
Lh5Unit;
var
InStr, OutStr: TFileStream;
begin
if not (ParamCount in [2..3]) then
begin
Writeln('Usage :');
Writeln('To compress infile into outfile : LH5 infile outfile');
Writeln('To expand infile into outfile : LH5 infile outfile E');
HALT;
end;
InStr := TFileStream.Create(Paramstr(1), fmOpenRead);
OutStr := TFileStream.Create(Paramstr(2), fmCreate);
if ParamCount = 2 then
LHACompress(InStr, OutStr)
else
LHAExpand(InStr, OutStr);
InStr.Free;
OutStr.Free;
end.