数据压缩 -- 源码

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;