数据压缩 -- 源码

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);