[Back to ARCHIVES SWAG index] [Back to Main SWAG index] [Original]
(******************************************************************************)
(* *)
(* 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. *)
(* *)
(******************************************************************************)
PROGRAM Lh5;
{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.
*)
TYPE
PWord=^TWord;
TWord=ARRAY[0..32759]OF Integer;
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;
VAR
OrigSize,CompSize:Longint;
InFile,OutFile:File;
BitBuf:Word;
n,HeapSize:Integer;
SubBitBuf,BitCount:Word;
Buffer:ARRAY[0..PRED(BUFSIZE)]OF Byte;
BufPtr:Word;
Left,Right:ARRAY[0..2*(NC-1)]OF Word;
PtTable:ARRAY[0..255]OF Word;
PtLen:ARRAY[0..PRED(NPT)]OF Byte;
CTable:ARRAY[0..4095]OF Word;
CLen:ARRAY[0..PRED(NC)]OF Byte;
BlockSize:Word;
{ The following variables are used by the compression engine only }
Heap:ARRAY[0..NC]OF Word;
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:Integer;
Level:PByte;
{********************************** File I/O **********************************}
FUNCTION GetC:Byte;
BEGIN
IF BufPtr=0 THEN
BlockRead(InFile,Buffer,BUFSIZE);
GetC:=Buffer[BufPtr];BufPtr:=SUCC(BufPtr)AND PRED(BUFSIZE);
END;
PROCEDURE PutC(c:Byte);
BEGIN
IF BufPtr=BUFSIZE THEN
BEGIN
BlockWrite(OutFile,Buffer,BUFSIZE);BufPtr:=0;
END;
Buffer[BufPtr]:=C;INC(BufPtr);
END;
FUNCTION BRead(p:POINTER;n:Integer):Integer;
BEGIN
BlockRead(InFile,p^,n,n);
BRead:=n;
END;
PROCEDURE BWrite(p:POINTER;n:Integer);
BEGIN
BlockWrite(OutFile,p^,n);
END;
{**************************** Bit handling routines ***************************}
PROCEDURE FillBuf(n:Integer);
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:Integer):Word;
BEGIN
GetBits:=BitBuf SHR (BITBUFSIZ-n);
FillBuf(n);
END;
PROCEDURE PutBits(n:Integer;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:Integer;BitLen:PByte;TableBits:Integer;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:Integer;
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^[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:Integer);
VAR
i,c,n:Integer;
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(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:Integer;
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,@CLen,12,@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:Integer;
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:=(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);
BWrite(p,a);DEC(l,a);
END;
FreeMem(p,DICSIZ);
END;
{********************************* Compression ********************************}
{-------------------------------- Huffman part --------------------------------}
PROCEDURE CountLen(i:Integer);
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:Integer);
VAR
i,k:Integer;
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(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:Integer);
VAR
j,k:Integer;
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:Integer;Len:PByte;Code:PWord);
VAR
i,k:Integer;
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:Integer;Freqparm:PWord;LenParm:PByte;Codeparm:PWord):Integer;
VAR
i,j,k,Avail:Integer;
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:Integer;
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:Integer);
VAR
i,k:Integer;
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:Integer;
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:Integer);
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,@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:Integer;c:Byte):Integer;
BEGIN
Hash:=p+(c SHL (DICBIT-9))+2*DICSIZ;
END;
FUNCTION Child(q:Integer;c:Byte):Integer;
VAR
r:Integer;
BEGIN
r:=Next^[Hash(q,c)];Parent^[NUL]:=q;
WHILE Parent^[r]<>q DO
r:=Next^[r];
Child:=r;
END;
PROCEDURE MakeChild(q:Integer;c:Byte;r:Integer);
VAR
h,t:Integer;
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:Integer);
VAR
new,t:Integer;
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:Integer;
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:Integer;
{$IFDEF PERCOLATE}
q:Integer;
{$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:Integer;
BEGIN
DEC(Remainder);INC(Pos);
IF Pos=2*DICSIZ THEN
BEGIN
move(Text^[DICSIZ],Text^[0],DICSIZ+MAXMATCH);
n:=BRead(Addr(Text^[DICSIZ+MAXMATCH]),DICSIZ);
INC(Remainder,n);Pos:=DICSIZ;
END;
DeleteNode;InsertNode;
END;
PROCEDURE Encode;
VAR
LastMatchLen,LastMatchPos:Integer;
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)SHL 1);
{$ELSE}
GetMem(Position,(DICSIZ)SHL 1);
{$ENDIF}
GetMem(Parent,(DICSIZ*2)SHL 1);
GetMem(Prev,(DICSIZ*2)SHL 1);
GetMem(Next,(MAXHASHVAL+1)SHL 1);
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:=BRead(Addr(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
BlockWrite(OutFile,Buffer,BufPtr);
FreeMem(Buf,WINDOWSIZE);
FreeMem(Next,(MAXHASHVAL+1)SHL 1);
FreeMem(Prev,(DICSIZ*2)SHL 1);
FreeMem(Parent,(DICSIZ*2)SHL 1);
{$IFDEF PERCOLATE}
FreeMem(Position,(DICSIZ+UCHARMAX+1)SHL 1);
{$ELSE}
FreeMem(Position,(DICSIZ)SHL 1);
{$ENDIF}
FreeMem(ChildCount,DICSIZ+UCHARMAX+1);
FreeMem(Level,DICSIZ+UCHARMAX+1);
FreeMem(Text,2*DICSIZ+MAXMATCH);
END;
{******************************** Main program ********************************}
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;
BufPtr:=0;
Assign(InFile,Paramstr(1));Reset(InFile,1);
Assign(OutFile,Paramstr(2));Rewrite(OutFile,1);
IF ParamCount=2 THEN
BEGIN
OrigSize:=FileSize(InFile);
CompSize:=0;
BlockWrite(OutFile,OrigSize,4);
Encode;
END ELSE BEGIN
CompSize:=FileSize(InFile);
BlockRead(InFile,OrigSize,4);
Decode;
END;
Close(InFile);Close(OutFile);
END.
[Back to ARCHIVES SWAG index] [Back to Main SWAG index] [Original]