; 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;
&nb 上一页 [1] [2] [3] [4] [5] [6] [7] 下一页 |
