Data compression - source code

xiaoxiao2021-03-06  74

(********************************************************* *****************************) (* *) (* lh5.pas *) (*) (* this code compress / DECOMPRESS DATA USING THE ALGORITHM As Lharc 2.x *) (* IT IS Roughly Derived from the c Source Code 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 required) 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 instructioned or unco Mpressed, You'll Need to Set *) (* INSTR.PSITION: = 0 Before Calling One of these Procedures. *) (* *) (* See The test program at the end of this unit for an example of *) ( * ~ (* *) (* CHANGING THIS A Unit Required THE (INTERNAL) (* Procedure FreeMemory; *) (* procedure initmemory;

* (* To Ensure That Memory Gets Initialized Properly Between Calls *) (* to the unit's interface procedures. *) (*********************** *********************************************************** ****) 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 isplay 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 evting 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] Const (* NOTE: The Following Conntants 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, ie 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 increable 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: ^ bufferay; 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 (buffsize);

Procedure PUTC (C: BYTE); begin if bufptr = bufsize dam ^, bufsize; bufptr: = 0; end; buffer ^ [bufptr]: = C; INC (bufptr);

Function Bread (p: pointer; n: twobyte): twobyteint; begin break: = infile.read (p ^, n); end;

Procedure BWRITE (P: POINTER; N: Twobyteint); Begin Outfile.write (P ^, N); END;

{******************************************************* *********}

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: = getc; end else subbitbuf: = 0; bitcount: = 8; end; dec (bitcount, n); bitbuf: = bitbuf or (subbitbus 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

Procedure initgetBits; becom bitbuf: = 0; SubbitBuf: = 0; Bitcount: = 0; FillBuf (Bitbufsiz);

Procedure initputbits; begin bitcount: = 8; SubbitBuf: = 0;

{********************************************************* **************}

Procedure MakeTable (nchar: twobyte; tablebits: tablete; 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 the 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; ELSE BEGIN i: = 0; While (i 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 (TWOBYTEIN)); 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;

Procedure readclen; var i, c, n: twobyteint; maask: 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 = Nt dam: = 1 shl (Bitbufsiz-9); Repeat IF (Bitbuf and mask) <> 0 THEN C: = Right ^ [c] Else C: = left ^ [c] Mask: = Mask SHR 1; Until 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 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

Function decod: word; var j, mask: word; begin j: = pttable [bitbuf shr (bitbufsiz-8)]; if j> = np dam 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 0; j: = (1 shl j) getBits (j); end; decode: = j; end; {declared as static vars} var Decode_i: word; decode_j: twobyteint;

Procedure DecodeBuffer (Count: Word; Buffer); 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 dam; dec (decode_j); end; while true do beg c: = decodec; if c <= ucharmax the begin Buffer ^ [r]: = C; INC (r); if r = count dam; 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 (DCODE_I) AND PRED (DICSIZ); INC (r); if R = count kiln exit; dec (decode_j); end; end; end; end;

Procedure decode; var: pbyte; l: longint; a: word; begin {initialize decoder variables} getmem (p, dics); 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 TEN A: = DICSIZ ELSE A: = L; DECodeBuffer (a, p); Outfile.Write (P ^, A) DEC (L, A); End; FreeMem (p, dics); end; {***************************************** *******************************************

{------------------------------------- -----------------}

Procedure countlen (i: twobyteint); Begin IF i

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)], 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 address ptr sortptr, 2; {sortptr: = addr (sortptr ^ 1]);

Procedure Downheap; Var J, K: Twobyteint; Begin K: = HEAP ^ [i]; J: = I SHL 1; While (j <= Heapsize) Do Begin IF (J freq ^ [heap ^ [SUCC (j)]]) THEN INC (j); if freq ^ [k] <= freq ^ [heap ^ [j]] kil out; heap ^ [I]: = Heap ^ [J]; i: = j; j: = I shl 1; end; heap ^ [i]: = k; end; procedure makecode (N: TwobyTeint; Len: pbyte; code: pword; 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 beg k: = len ^ [i]; code ^ [i]: = start [k]; inc (Start [k] END;

FREQPARM: PWORD ;LENPARM: PBYTE; CODEPARM: PWORD: Twobyteint; Var i, j, k, avail: twobyteint; begin n: = nparm; freq: = freqarm; len: = lenparm; avail : = n; Heapsize: = 0; Heap ^ [1]: = 0; for i: = 0 to Pred (n) do beg Lin ^ [i]: = 0; if freq ^ [i] <> 0 THEN Begin INC (Heap ^ [Heapsize]: = I; End; End; if Heapsize <2 Then Begin CodeParm ^ [HEAP ^ [1]]: = 0; Maketree: = Heap ^ [1]; EXIT; For i: = (Heapsize Div 2) Downto 1 Do DownHeap (I); Sortptr: = CodeParm; Repeat i: = Heap ^ [1]; IF i

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 0) and (PTLEN [PRED (N)] = 0) DO DEC (N ); Putbits (nbit, n); i: = 0; while (i

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

Procedure Encodep (P: Word); Var C, Q: Word; Begin C: = 0; Q: = P; WHILE => 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)));

Procedure sendblock; var i, k, flags, root, pos, size: word; begin root: = maketree (nc, @ cfreq, pbyte (ccode); size: = cfreq [root]; Putbits (16, Size); if root> = nc The 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, ROOT); End; root: = maketree (NP, @ pfreq, @ ptlen, @ ptcode); if root> = np kiliteptlen (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); 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); EL Se recomgin 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;

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; utputpos ); C: = 0; while P <> 0 DO begin p: = p shr 1; INC (c); end; inc; end; end; {--------- --------------------- Lempel-ziv part ------------------------ ------}

Procedure initslide; var i: word; begin for i: = DICSIZ To (DICSIZ UCHARMAX) do beg 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 has: = p (C SHL (Dicbit-9)) 2 * DICSIZ; END;

Function CHild; 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]);

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

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 = 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 beg position ^ [t]: = POS; T: = Parent ^ [t]; end; if T = DICSIZ THEN BEGIN J: = MaxMatch; MatchPos: = r; Else Begin J: = Level ^ [R]; Matchpos : = POSITION ^ [R] and not percflag; end; if matchpos> = POS THEN DEC (MatchPos, Dics); T1: = Addr (Text ^ [POS Matchlen]); T2: = AddR (Text ^ [MatchPos Matchlen]); While Matchlen T2 ^ THEN Begin Split (r); EXIT; End; INC (Matchlen); INC (T1); INC (T2); end; if matchlen> = maxmatch the Break; Position ^ [r]: = POS; Q: = R; R: = Child (q, ORD (T1 ^)); if r = nul dam 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: q: 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, Dics); {$ Ifdef percolate} s: = t; q: = parent ^ [r]; u: = position ^ [q]; while (u and percflag) <> 0 do beg u: = u and not percflag; if u> = POS THEN DEC (U, Dics); if u> s: = u; position ^ [q]: = s or dics; q: = parent ^ [q]; u: = position ^ [q]; end; if Q = POS THEN DEC (U, Dics); if u> 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; = prev ^ [r]; Next ^ [t]: = S; prev ^ [s]: = T; T: = Next ^ [r]; pre V ^ [t]: = S; Next ^ [S]: = T; Parent ^ [S]: = Parent ^ [R]; Parent ^ [R]: = NUL; Next ^ [R]: = Avail; Avail : = R; END;

Procedure getNextMatch; var N: twobyte; begin dec (remainder); INC (POS); if POS = 2 * DICSIZ THEN BEGIN MOVE (Text ^ [DICSIZ], Text ^ [0], Dicsiz MaxMatch); N: = Infile .Read; r =; r;,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,

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 dam: = remainder; if (Matchlen> Lastmatchlen) or (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 (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 dam; ctable: = nil; if right <> nil dam; rT: = nil; if left > NIL THEN DISPOSE (LEFT); Left: = nil; if Buffer <> nil dam; buffer: = nil; if Heap <> nil dam; heap; heap: = nil; end;

procedure InitMemory;. begin {In should be harmless to call FreeMemory here, since it will not free unallocated memory (ie, nil pointers) So let's call it in case an exception was thrown at some point and memory was not entirely freed. FreeMemory; New (LEFER); New (right); new (ctable); new; fillchar (buffer ^, sizeof (buffer ^), 0); Fillchar (Left ^, Sizeof ^, 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

procedure LHAExpand (InStr, OutStr: TStream); // decode begin try InitMemory; InFile: = InStr; OutFile: = OutStr; CompSize: = InFile.Size - InFile.Position; InFile.Read (OrigSize, 4); Decode; finally .

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. Its Compresses / Expands Files Compatible with Lharc.} Program Testlh5;

Uses WinCRT, SYSUTILS, CLASSES, LH5UNIT;

Var INSTR: TFILESTREAM;

转载请注明原文地址:https://www.9cbs.com/read-109134.html

New Post(0)