home *** CD-ROM | disk | FTP | other *** search
/ The Equalizer BBS / equalizer-bbs-collection_2004.zip / equalizer-bbs-collection / DEMOSCENE-STUFF / INTRO93.ZIP / LZH.PAS < prev    next >
Pascal/Delphi Source File  |  1993-02-27  |  14KB  |  562 lines
  1. { LZHUF.C English version 1.0
  2.   Based on Japanese version 29-NOV-1988
  3.   LZSS coded by Haruhiko OKUMURA
  4.   Adaptive Huffman Coding coded by Haruyasu YOSHIZAKI
  5.   Edited and translated to English by Kenji RIKITAKE
  6.   Converted to Turbo Pascal 5.0
  7.     by Peter Sawatzki with assistance of Wayne Sullivan
  8. }
  9. {$i-,r-,v-,s-}
  10. Unit LZH;
  11. Interface
  12. type
  13.   bufar = array[0..0] of byte; {will be overindexed}
  14.  
  15. var
  16.   WriteFromBuffer,
  17.   ReadToBuffer: procedure;
  18.   inbuf,outbuf: ^bufar;
  19.   inptr,inend,outptr,outend: word;
  20.  
  21.   procedure Encode (bytes: LongInt);
  22.   procedure Decode;
  23.  
  24. Implementation
  25. Const
  26. {-LZSS Parameters}
  27.   N         = 256; {Size of string buffer}
  28.   F         = 60;   {60 Size of look-ahead buffer}
  29.   THRESHOLD = 2;
  30.   NODENIL   = N;    {End of tree's node}
  31.  
  32. {-Huffman coding parameters}
  33.   N_CHAR    = 256-THRESHOLD+F;
  34.                             {character code (= 0..N_CHAR-1)}
  35.   T         = N_CHAR*2 -1;  {Size of table}
  36.   R         = T-1;          {root position}
  37.   MAX_FREQ  = $8000; {update when cumulative frequency reaches to this value}
  38.  
  39. {-Tables for encoding/decoding upper 6 bits of sliding dictionary pointer}
  40. {-encoder table}
  41. p_len: array[0..63] of byte =
  42.        ($03,$04,$04,$04,$05,$05,$05,$05,$05,$05,$05,$05,$06,$06,$06,$06,
  43.         $06,$06,$06,$06,$06,$06,$06,$06,$07,$07,$07,$07,$07,$07,$07,$07,
  44.         $07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,
  45.         $08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08);
  46.  
  47. p_code: array[0..63] of byte =
  48.        ($00,$20,$30,$40,$50,$58,$60,$68,$70,$78,$80,$88,$90,$94,$98,$9C,
  49.         $A0,$A4,$A8,$AC,$B0,$B4,$B8,$BC,$C0,$C2,$C4,$C6,$C8,$CA,$CC,$CE,
  50.         $D0,$D2,$D4,$D6,$D8,$DA,$DC,$DE,$E0,$E2,$E4,$E6,$E8,$EA,$EC,$EE,
  51.         $F0,$F1,$F2,$F3,$F4,$F5,$F6,$F7,$F8,$F9,$FA,$FB,$FC,$FD,$FE,$FF);
  52.  
  53. {-decoder table}
  54. d_code: array[0..255] of byte =
  55.        ($00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,
  56.         $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,
  57.         $01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,
  58.         $02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,
  59.         $03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,
  60.         $04,$04,$04,$04,$04,$04,$04,$04,$05,$05,$05,$05,$05,$05,$05,$05,
  61.         $06,$06,$06,$06,$06,$06,$06,$06,$07,$07,$07,$07,$07,$07,$07,$07,
  62.         $08,$08,$08,$08,$08,$08,$08,$08,$09,$09,$09,$09,$09,$09,$09,$09,
  63.         $0A,$0A,$0A,$0A,$0A,$0A,$0A,$0A,$0B,$0B,$0B,$0B,$0B,$0B,$0B,$0B,
  64.         $0C,$0C,$0C,$0C,$0D,$0D,$0D,$0D,$0E,$0E,$0E,$0E,$0F,$0F,$0F,$0F,
  65.         $10,$10,$10,$10,$11,$11,$11,$11,$12,$12,$12,$12,$13,$13,$13,$13,
  66.         $14,$14,$14,$14,$15,$15,$15,$15,$16,$16,$16,$16,$17,$17,$17,$17,
  67.         $18,$18,$19,$19,$1A,$1A,$1B,$1B,$1C,$1C,$1D,$1D,$1E,$1E,$1F,$1F,
  68.         $20,$20,$21,$21,$22,$22,$23,$23,$24,$24,$25,$25,$26,$26,$27,$27,
  69.         $28,$28,$29,$29,$2A,$2A,$2B,$2B,$2C,$2C,$2D,$2D,$2E,$2E,$2F,$2F,
  70.         $30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$3A,$3B,$3C,$3D,$3E,$3F);
  71.  
  72. d_len: array[0..255] of byte =
  73.        ($03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,
  74.         $03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,
  75.         $04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,
  76.         $04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,
  77.         $04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,
  78.         $05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,
  79.         $05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,
  80.         $05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,
  81.         $05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,
  82.         $06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,
  83.         $06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,
  84.         $06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,
  85.         $07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,
  86.         $07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,
  87.         $07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,
  88.         $08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08);
  89.  
  90.   getbuf: word = 0;
  91.   getlen: byte = 0;
  92.   putbuf: word = 0;
  93.   putlen: word = 0;
  94.  
  95.   textsize: LongInt = 0;
  96.   codesize: LongInt = 0;
  97.   printcount: LongInt = 0;
  98.  
  99. var
  100.   text_buf: array[0..N + F - 2] of byte;
  101.   match_position, match_length: word;
  102.   lson,dad: array[0..N] of word;
  103.   rson:     array[0..N + 256] of word;
  104.  
  105.   freq: array[0..T] of word; {cumulative freq table}
  106.  
  107. {-pointing parent nodes. area [T..(T + N_CHAR - 1)] are pointers for leaves}
  108.   prnt: array [0..T+N_CHAR-1] of word;
  109.  
  110. {-pointing children nodes (son[], son[] + 1)}
  111.   son: array[0..T-1] of word;
  112.  
  113.   function getc: byte;
  114.   begin
  115.     getc:= inbuf^[inptr];
  116.     Inc(inptr);
  117.     if inptr=inend then ReadToBuffer
  118.   end;
  119.  
  120.   procedure putc (c: byte);
  121.   begin
  122.     outbuf^[outptr]:= c;
  123.     Inc(outptr);
  124.     if outptr=outend then
  125.       WriteFromBuffer
  126.   end;
  127.  
  128. procedure InitTree;
  129. {-Initializing tree}
  130. var
  131.   i: word;
  132. begin
  133.   for i:= N+1 to N+256 do rson[i] := NODENIL; {root}
  134.   for i:= 0 to N-1 do     dad[i]  := NODENIL; {node}
  135. end;
  136.  
  137. procedure InsertNode (r: word);
  138. {-Inserting node to the tree}
  139. Label
  140.   Done;
  141. var
  142.   i,p: word;
  143.   geq: boolean;
  144.   c: word;
  145. begin
  146.   geq:= true;
  147.   p:= N+1+text_buf[r];
  148.   rson[r]:= NODENIL;
  149.   lson[r]:= NODENIL;
  150.   match_length := 0;
  151.   while TRUE do begin
  152.     if geq then
  153.       if rson[p]=NODENIL then begin
  154.         rson[p]:= r;
  155.         dad[r] := p;
  156.         exit
  157.       end else
  158.         p:= rson[p]
  159.     else
  160.       if lson[p]=NODENIL then begin
  161.         lson[p]:= r;
  162.         dad[r] := p;
  163.         exit
  164.       end else
  165.         p:= lson[p];
  166.     i:= 1;
  167.     while (i<F) AND (text_buf[r+i]=text_buf[p+i]) do Inc(i);
  168.     geq:= (text_buf[r+i]>=text_buf[p+i]) or (i=F);
  169.  
  170.     if i>THRESHOLD then begin
  171.       if i>match_length then begin
  172.         match_position := (r-p) AND (N-1) -1;
  173.         match_length:= i;
  174.         if match_length>=F then goto done;
  175.       end;
  176.       if i=match_length then begin
  177.         c:= (r-p) AND (N-1) -1;
  178.         if c<match_position then match_position:= c
  179.       end
  180.     end
  181.   end;
  182.   Done:
  183.   dad[r]:= dad[p];
  184.   lson[r]:= lson[p];
  185.   rson[r]:= rson[p];
  186.   dad[lson[p]]:= r;
  187.   dad[rson[p]]:= r;
  188.   if rson[dad[p]]=p then
  189.     rson[dad[p]]:= r
  190.   else
  191.     lson[dad[p]]:= r;
  192.   dad[p]:= NODENIL; {remove p}
  193. end;
  194.  
  195. procedure DeleteNode (p: word);
  196. {-Delete node from the tree}
  197. var
  198.   q: word;
  199. begin
  200.   if dad[p] =NODENIL then exit; {unregistered}
  201.   if rson[p]=NODENIL then q:= lson[p] else
  202.   if lson[p]=NODENIL then q:= rson[p] else begin
  203.     q:= lson[p];
  204.     if rson[q]<>NODENIL then begin
  205.       repeat
  206.         q:= rson[q];
  207.       until rson[q]=NODENIL;
  208.       rson[dad[q]]:= lson[q];
  209.       dad[lson[q]]:= dad[q];
  210.       lson[q]:= lson[p];
  211.       dad[lson[p]]:= q;
  212.     end;
  213.     rson[q]:= rson[p];
  214.     dad[rson[p]]:= q;
  215.   end;
  216.   dad[q]:= dad[p];
  217.   if rson[dad[p]]=p then
  218.     rson[dad[p]]:= q
  219.   else
  220.     lson[dad[p]]:= q;
  221.   dad[p]:= NODENIL;
  222. end;
  223.  
  224. function GetBit: byte;
  225. {-get one bit}
  226. begin
  227.   while getlen<=8 do begin
  228.     getbuf:= getbuf OR (WORD(getc) SHL (8-getlen));
  229.     Inc(getlen,8);
  230.   end;
  231.   GetBit:= getbuf SHR 15;
  232. {   if (getbuf AND $8000)>0 then GetBit:= 1 else GetBit:= 0;}
  233.   getbuf:= getbuf SHL 1;
  234.   Dec(getlen);
  235. end;
  236.  
  237. function GetByte: Byte;
  238. {-get a byte}
  239. begin
  240.   while getlen<=8 do begin
  241.     getbuf:= getbuf OR (WORD(getc) SHL (8 - getlen));
  242.     Inc(getlen,8);
  243.   end;
  244.   GetByte:= Hi(getbuf);
  245.   getbuf:= getbuf SHL 8;
  246.   Dec(getlen,8);
  247. end;
  248.  
  249. procedure Putcode (l: byte; c: word);
  250. {-output l bits}
  251. begin
  252.   putbuf:= putbuf OR (c SHR putlen);
  253.   Inc(putlen,l);
  254.   if putlen>=8 then begin
  255.     putc(Hi(putbuf));
  256.     Dec(putlen,8);
  257.     if putlen>=8 then begin
  258.       putc(Lo(putbuf));
  259.       Inc(codesize,2);
  260.       Dec(putlen,8);
  261.       putbuf:= c SHL (l-putlen);
  262.     end else begin
  263.       putbuf:= Swap(putbuf AND $FF); {SHL 8;}
  264.       Inc(codesize);
  265.     end
  266.   end
  267. end;
  268.  
  269. procedure StartHuff;
  270. {-initialize freq tree}
  271. var
  272.   i,j: word;
  273. begin
  274.   for i:= 0 to N_CHAR-1 do begin
  275.     freq[i]:= 1;
  276.     son[i] := i+T;
  277.     prnt[i+T]:= i
  278.   end;
  279.   i:= 0; j:= N_CHAR;
  280.   while j<=R do begin
  281.     freq[j]:= freq[i]+freq[i+1];
  282.     son[j] := i;
  283.     prnt[i]:= j;
  284.     prnt[i+1]:= j;
  285.     Inc(i,2); Inc(j)
  286.   end;
  287.   freq[T]:= $FFFF;
  288.   prnt[R]:= 0;
  289. end;
  290.  
  291. procedure reconst;
  292. {-reconstruct freq tree }
  293. var
  294.   i,j,k,f,l: word;
  295. begin
  296.   {-halven cumulative freq for leaf nodes}
  297.   j:= 0;
  298.   for i:= 0 to T-1 do
  299.     if son[i]>=T then begin
  300.       freq[j]:= (freq[i]+1) SHR 1;
  301.       son[j] := son[i];
  302.       Inc(j)
  303.     end;
  304.   {-make a tree : first, connect children nodes}
  305.   i:= 0; j:= N_CHAR;
  306.   while j<T do begin
  307.     k:= i+1;
  308.     f:= freq[i]+freq[k];
  309.     freq[j]:= f;
  310.     k:= j-1;
  311.     while f<freq[k] do Dec(k);
  312.     Inc(k);
  313.     l:= (j-k)*2;
  314.  
  315.     move(freq[k],freq[k+1],l);
  316.     freq[k]:= f;
  317.     move(son[k],son[k+1],l);
  318.     son[k]:= i;
  319.     Inc(i,2);
  320.     Inc(j)
  321.   end;
  322.   {-connect parent nodes}
  323.   for i:= 0 to T-1 do begin
  324.     k:= son[i];
  325.     prnt[k]:= i;
  326.     if k<T then
  327.       prnt[k+1]:= i
  328.   end
  329. end;
  330.  
  331. procedure update(c: word);
  332. {-update freq tree}
  333. var
  334.   i,j,k,l: word;
  335. begin
  336.   if freq[R]=MAX_FREQ then reconst;
  337.   c:= prnt[c+T];
  338.   repeat
  339.     Inc(freq[c]);
  340.     k:= freq[c];
  341.     {-swap nodes to keep the tree freq-ordered}
  342.     l:= c+1;
  343.     if k>freq[l] then begin
  344.       while k>freq[l+1] do Inc(l);
  345.       freq[c]:= freq[l];
  346.       freq[l]:= k;
  347.  
  348.       i:= son[c];
  349.       prnt[i]:= l;
  350.       if i<T then prnt[i+1]:= l;
  351.  
  352.       j:= son[l];
  353.       son[l]:= i;
  354.  
  355.       prnt[j]:= c;
  356.       if j<T  then prnt[j+1]:= c;
  357.       son[c]:= j;
  358.  
  359.       c := l;
  360.     end;
  361.     c:= prnt[c]
  362.   until c=0; {do it until reaching the root}
  363. end;
  364.  
  365. procedure EncodeChar (c: word);
  366. var
  367.   code,len,k: word;
  368. begin
  369.   code:= 0;
  370.   len:= 0;
  371.   k:= prnt[c+T];
  372.  
  373.   {-search connections from leaf node to the root}
  374.   repeat
  375.     code:= code SHR 1;
  376.     {-if node's address is odd, output 1 else output 0}
  377.     if (k AND 1)>0 then Inc(code,$8000);
  378.     Inc(len);
  379.     k:= prnt[k];
  380.   until k=R;
  381.   Putcode(len,code);
  382.   update(c)
  383. end;
  384.  
  385. procedure EncodePosition(c: word);
  386. var
  387.   i: word;
  388. begin
  389.   {-output upper 6 bits with encoding}
  390.   i:= c SHR 6;
  391.   Putcode(p_len[i], WORD(p_code[i]) SHL 8);
  392.   {-output lower 6 bits directly}
  393.   Putcode(6, (c AND $3F) SHL 10);
  394. end;
  395.  
  396. procedure EncodeEnd;
  397. begin
  398.   if putlen>0 then begin
  399.     putc(Hi(putbuf));
  400.     Inc(codesize)
  401.   end
  402. end;
  403.  
  404. function DecodeChar: word;
  405. var
  406.   c: word;
  407. begin
  408.   c:= son[R];
  409.   {-start searching tree from the root to leaves.
  410.     choose node #(son[]) if input bit = 0
  411.     else choose #(son[]+1) (input bit = 1)}
  412.   while c<T do c:= son[c+GetBit];
  413.   Dec(c,T);
  414.   update(c);
  415.   DecodeChar:= c
  416. end;
  417.  
  418. function DecodePosition: word;
  419. var
  420.   i,j,c: word;
  421. begin
  422.   {-decode upper 6 bits from given table}
  423.   i:= GetByte;
  424.   c:= WORD(d_code[i]) SHL 6;
  425.   j:= d_len[i];
  426.   {-input lower 6 bits directly}
  427.   Dec(j,2);
  428.   while j>0 do begin
  429.     Dec(j);
  430.     i:= (i SHL 1) OR GetBit;
  431.   end;
  432.   DecodePosition:= c OR (i AND $3F);
  433. end;
  434.  
  435. {-Compression }
  436. procedure Encode (bytes: LongInt);
  437. {-Encoding/Compressing}
  438. type
  439.   ByteRec = record
  440.               b0,b1,b2,b3: byte
  441.             end;
  442. var
  443.   i,c,len,r,s,last_match_length: word;
  444. begin
  445.   {-write size of original text}
  446.   with ByteRec(Bytes) do begin
  447.     putc(b0);
  448.     putc(b1);
  449.     putc(b2);
  450.     putc(b3)
  451.   end;
  452.   if bytes=0 then exit;
  453.   textsize:= 0;
  454.   StartHuff;
  455.   InitTree;
  456.   s:= 0;
  457.   r:= N-F;
  458.   fillchar(text_buf[0],r,' ');
  459.   len:= 0;
  460.   while (len<F) AND (inptr OR inend>0) do begin
  461.     text_buf[r+len]:= getc;
  462.     Inc(len)
  463.   end;
  464.   textsize := len;
  465.   for i:= 1 to F do InsertNode(r - i);
  466.   InsertNode(r);
  467.   repeat
  468.     if match_length>len then match_length:= len;
  469.     if match_length<=THRESHOLD then begin
  470.       match_length := 1;
  471.       EncodeChar(text_buf[r])
  472.     end else begin
  473.       EncodeChar(255 - THRESHOLD + match_length);
  474.       EncodePosition(match_position)
  475.     end;
  476.     last_match_length := match_length;
  477.     i:= 0;
  478.     while (i<last_match_length) AND (inptr OR inend>0) do begin
  479.       Inc(i);
  480.       DeleteNode(s);
  481.       c:= getc;
  482.       text_buf[s]:= c;
  483.       if s<F-1 then text_buf[s+N]:= c;
  484.       s:= (s+1) AND (N-1);
  485.       r:= (r+1) AND (N-1);
  486.       InsertNode(r);
  487.     end;
  488.     Inc(textsize,i);
  489.     if textsize>printcount then begin
  490.       Inc(printcount,1024)
  491.     end;
  492.     while i<last_match_length do begin
  493.       Inc(i);
  494.       DeleteNode(s);
  495.       s := (s+1) AND (N-1);
  496.       r := (r+1) AND (N-1);
  497.       Dec(len);
  498.       if len>0 then InsertNode(r)
  499.     end;
  500.   until len=0;
  501.   EncodeEnd;
  502. end;
  503.  
  504. procedure Decode;
  505. {-Decoding/Uncompressing}
  506. type
  507.   ByteRec = Record
  508.               b0,b1,b2,b3: byte
  509.             end;
  510. var
  511.   i,j,k,r,c: word;
  512.   count: LongInt;
  513. begin
  514.   i:=0;k:=0;j:=0;r:=0;c:=0;
  515.   for i:=0 to (N+F-2) do text_buf[i]:=0;
  516.   match_position:=0;match_length:=0;
  517.   for i:=0 to N do lson[I]:=0;
  518.   for i:=0 to N do dad[I]:=0;
  519.   for i:=0 to (N+256) do rson[i]:=0;
  520.   for i:=0 to T do freq[i]:=0;
  521.   for i:=0 to (T+N_CHAR-1) do prnt[i]:=0;
  522.   for i:=0 to (T-1) do son[i]:=0;
  523.   i:=0;
  524.  
  525.   {-read size of original text}
  526.   with ByteRec(textsize) do begin
  527.     b0:= getc;
  528.     b1:= getc;
  529.     b2:= getc;
  530.     b3:= getc
  531.   end;
  532.   if textsize=0 then exit;
  533.   StartHuff;
  534.   fillchar(text_buf[0],N-F,' ');
  535.   r:= N-F;
  536.   count:= 0;
  537.   while count<textsize do begin
  538.     c:= DecodeChar;
  539.     if c<256 then begin
  540.       putc(c);
  541.       text_buf[r]:= c;
  542.       r:= (r+1) AND (N-1);
  543.       Inc(count)
  544.     end else begin
  545.       i:= (r-DecodePosition-1) AND (N-1);
  546.       j:= c-255+THRESHOLD;
  547.       for k:= 0 to j-1 do begin
  548.         c:= text_buf[(i+k) AND (N-1)];
  549.         putc(c);
  550.         text_buf[r]:= c;
  551.         r:= (r+1) AND (N-1);
  552.         Inc(count)
  553.       end;
  554.     end;
  555.     if count>printcount then begin
  556.       Inc(printcount,1024)
  557.     end
  558.   end;
  559. end;
  560.  
  561. end.
  562.