home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / LZH.ZIP / LZH.PAS next >
Encoding:
Pascal/Delphi Source File  |  1991-05-01  |  19.5 KB  |  856 lines
  1. unit lzh;
  2. {$A+,B-,D+,E-,F-,I+,L+,N-,O+,R-,S-,V-}
  3. (*
  4.  * LZHUF.C English version 1.0
  5.  * Based on Japanese version 29-NOV-1988
  6.  * LZSS coded by Haruhiko OKUMURA
  7.  * Adaptive Huffman Coding coded by Haruyasu YOSHIZAKI
  8.  * Edited and translated to English by Kenji RIKITAKE
  9.  * Translated from C to Turbo Pascal by Douglas Webb   2/18/91
  10.  *    Update and bug correction of TP version 4/29/91 (Sorry!!)
  11.  *)
  12.  
  13. {
  14.      This unit allows the user to commpress data using a combination of
  15.    LZSS compression and adaptive Huffman coding, or conversely to decompress
  16.    data that was previously compressed by this unit.
  17.  
  18.      There are a number of options as to where the data being compressed/
  19.    decompressed is coming from/going to.
  20.  
  21.     In fact it requires that you pass the "LZHPack" procedure 2 procedural
  22.   parameter of type 'GetProcType' and 'PutProcType' (declared below) which
  23.   will accept 3 parameters and act in every way like a 'BlockRead'/'BlockWrite'
  24.   procedure call. Your 'GetProcType' procedure should return the data
  25.   to be compressed, and Your 'PutProcType' procedure should do something with
  26.   the compressed data (ie., put it in a file).  In case you need to know (and
  27.   you do if you want to decompress this data again) the number of bytes in the
  28.   compressed data (original, not compressed size) is returned in 'Bytes_Written'.
  29.  
  30.   GetBytesProc = PROCEDURE(VAR DTA; NBytes:WORD; VAR Bytes_Got : WORD);
  31.   
  32.   DTA is the start of a memory location where the information returned should
  33.   be.  NBytes is the number of bytes requested.  The actual number of bytes
  34.   returned must be passed in Bytes_Got (if there is no more data then 0
  35.   should be returned).
  36.  
  37.   PutBytesProc = PROCEDURE(VAR DTA; NBytes:WORD; VAR Bytes_Got : WORD);
  38.  
  39.   As above except instead of asking for data the procedure is dumping out
  40.   compressed data, do somthing with it.
  41.  
  42.  
  43.     "LZHUnPack" is basically the same thing in reverse.  It requires
  44.   procedural parameters of type 'PutProcType'/'GetProcType' which
  45.   will act as above.  'GetProcType' must retrieve data compressed using
  46.   "LZHPack" (above) and feed it to the unpacking routine as requested.
  47.   'PutProcType' must accept the decompressed data and do something
  48.   withit.  You must also pass in the original size of the decompressed data,
  49.   failure to do so will have adverse results.
  50.  
  51.  
  52.      Don't forget that as procedural parameters the 'GetProcType'/'PutProcType'
  53.   procedures must be compiled in the 'F+' state to avoid a catastrophe.
  54.  
  55.  
  56.  
  57. }
  58.  
  59. { Note: All the large data structures for these routines are allocated when
  60.   needed from the heap, and deallocated when finished.  So when not in use
  61.   memory requirements are minimal.  However, this unit uses about 34K of
  62.   heap space, and 400 bytes of stack when in use. }
  63.  
  64.  
  65. interface
  66.  
  67. TYPE
  68.  
  69.  
  70.   PutBytesProc = PROCEDURE(VAR DTA; NBytes:WORD; VAR Bytes_Put : WORD);
  71.   GetBytesProc = PROCEDURE(VAR DTA; NBytes:WORD; VAR Bytes_Got : WORD);
  72.  
  73.  
  74.  
  75. Procedure LZHPack(VAR Bytes_Written:LongInt; GetBytes:GetBytesProc; PutBytes:PutBytesProc);
  76. Procedure LZHUnpack(TextSize : Longint; GetBytes:GetBytesProc; PutBytes: PutBytesProc);
  77.  
  78.  
  79.  
  80.  
  81. implementation
  82.  
  83. CONST
  84.   EXIT_OK = 0;
  85.   EXIT_FAILED = 1;
  86. { LZSS Parameters }
  87.   N        = 4096;    { Size of string buffer }
  88.   F        = 60;    { Size of look-ahead buffer }
  89.   THRESHOLD    = 2;
  90.   NUL        = N;    { End of tree's node  }
  91.  
  92.  
  93. { Huffman coding parameters }
  94.   N_CHAR   =    (256 - THRESHOLD + F);
  95.         { character code (:= 0..N_CHAR-1) }
  96.   T        =    (N_CHAR * 2 - 1);    { Size of table }
  97.   R        =    (T - 1);        { root position }
  98.   MAX_FREQ =    $8000;
  99.                     { update when cumulative frequency }
  100.                     { reaches to this value }
  101. {
  102.  * Tables FOR encoding/decoding upper 6 bits of
  103.  * sliding dictionary pointer
  104.  }
  105. { encoder table }
  106.   p_len : Array[0..63] of BYTE =
  107.        ($03, $04, $04, $04, $05, $05, $05, $05,
  108.     $05, $05, $05, $05, $06, $06, $06, $06,
  109.     $06, $06, $06, $06, $06, $06, $06, $06,
  110.     $07, $07, $07, $07, $07, $07, $07, $07,
  111.     $07, $07, $07, $07, $07, $07, $07, $07,
  112.     $07, $07, $07, $07, $07, $07, $07, $07,
  113.     $08, $08, $08, $08, $08, $08, $08, $08,
  114.     $08, $08, $08, $08, $08, $08, $08, $08);
  115.  
  116.   p_code : Array [0..63] OF BYTE =
  117.        ($00, $20, $30, $40, $50, $58, $60, $68,
  118.     $70, $78, $80, $88, $90, $94, $98, $9C,
  119.     $A0, $A4, $A8, $AC, $B0, $B4, $B8, $BC,
  120.     $C0, $C2, $C4, $C6, $C8, $CA, $CC, $CE,
  121.     $D0, $D2, $D4, $D6, $D8, $DA, $DC, $DE,
  122.     $E0, $E2, $E4, $E6, $E8, $EA, $EC, $EE,
  123.     $F0, $F1, $F2, $F3, $F4, $F5, $F6, $F7,
  124.     $F8, $F9, $FA, $FB, $FC, $FD, $FE, $FF);
  125.  
  126. { decoder table }
  127.   d_code: Array [0..255] OF BYTE =
  128.        ($00, $00, $00, $00, $00, $00, $00, $00,
  129.     $00, $00, $00, $00, $00, $00, $00, $00,
  130.     $00, $00, $00, $00, $00, $00, $00, $00,
  131.     $00, $00, $00, $00, $00, $00, $00, $00,
  132.     $01, $01, $01, $01, $01, $01, $01, $01,
  133.     $01, $01, $01, $01, $01, $01, $01, $01,
  134.     $02, $02, $02, $02, $02, $02, $02, $02,
  135.     $02, $02, $02, $02, $02, $02, $02, $02,
  136.     $03, $03, $03, $03, $03, $03, $03, $03,
  137.     $03, $03, $03, $03, $03, $03, $03, $03,
  138.     $04, $04, $04, $04, $04, $04, $04, $04,
  139.     $05, $05, $05, $05, $05, $05, $05, $05,
  140.     $06, $06, $06, $06, $06, $06, $06, $06,
  141.     $07, $07, $07, $07, $07, $07, $07, $07,
  142.     $08, $08, $08, $08, $08, $08, $08, $08,
  143.     $09, $09, $09, $09, $09, $09, $09, $09,
  144.     $0A, $0A, $0A, $0A, $0A, $0A, $0A, $0A,
  145.     $0B, $0B, $0B, $0B, $0B, $0B, $0B, $0B,
  146.     $0C, $0C, $0C, $0C, $0D, $0D, $0D, $0D,
  147.     $0E, $0E, $0E, $0E, $0F, $0F, $0F, $0F,
  148.     $10, $10, $10, $10, $11, $11, $11, $11,
  149.     $12, $12, $12, $12, $13, $13, $13, $13,
  150.     $14, $14, $14, $14, $15, $15, $15, $15,
  151.     $16, $16, $16, $16, $17, $17, $17, $17,
  152.     $18, $18, $19, $19, $1A, $1A, $1B, $1B,
  153.     $1C, $1C, $1D, $1D, $1E, $1E, $1F, $1F,
  154.     $20, $20, $21, $21, $22, $22, $23, $23,
  155.     $24, $24, $25, $25, $26, $26, $27, $27,
  156.     $28, $28, $29, $29, $2A, $2A, $2B, $2B,
  157.     $2C, $2C, $2D, $2D, $2E, $2E, $2F, $2F,
  158.     $30, $31, $32, $33, $34, $35, $36, $37,
  159.     $38, $39, $3A, $3B, $3C, $3D, $3E, $3F);
  160.  
  161.  d_len: Array[0..255] of BYTE =
  162.        ($03, $03, $03, $03, $03, $03, $03, $03,
  163.     $03, $03, $03, $03, $03, $03, $03, $03,
  164.     $03, $03, $03, $03, $03, $03, $03, $03,
  165.     $03, $03, $03, $03, $03, $03, $03, $03,
  166.     $04, $04, $04, $04, $04, $04, $04, $04,
  167.     $04, $04, $04, $04, $04, $04, $04, $04,
  168.     $04, $04, $04, $04, $04, $04, $04, $04,
  169.     $04, $04, $04, $04, $04, $04, $04, $04,
  170.     $04, $04, $04, $04, $04, $04, $04, $04,
  171.     $04, $04, $04, $04, $04, $04, $04, $04,
  172.     $05, $05, $05, $05, $05, $05, $05, $05,
  173.     $05, $05, $05, $05, $05, $05, $05, $05,
  174.     $05, $05, $05, $05, $05, $05, $05, $05,
  175.     $05, $05, $05, $05, $05, $05, $05, $05,
  176.     $05, $05, $05, $05, $05, $05, $05, $05,
  177.     $05, $05, $05, $05, $05, $05, $05, $05,
  178.     $05, $05, $05, $05, $05, $05, $05, $05,
  179.     $05, $05, $05, $05, $05, $05, $05, $05,
  180.     $06, $06, $06, $06, $06, $06, $06, $06,
  181.     $06, $06, $06, $06, $06, $06, $06, $06,
  182.     $06, $06, $06, $06, $06, $06, $06, $06,
  183.     $06, $06, $06, $06, $06, $06, $06, $06,
  184.     $06, $06, $06, $06, $06, $06, $06, $06,
  185.     $06, $06, $06, $06, $06, $06, $06, $06,
  186.     $07, $07, $07, $07, $07, $07, $07, $07,
  187.     $07, $07, $07, $07, $07, $07, $07, $07,
  188.     $07, $07, $07, $07, $07, $07, $07, $07,
  189.     $07, $07, $07, $07, $07, $07, $07, $07,
  190.     $07, $07, $07, $07, $07, $07, $07, $07,
  191.     $07, $07, $07, $07, $07, $07, $07, $07,
  192.     $08, $08, $08, $08, $08, $08, $08, $08,
  193.     $08, $08, $08, $08, $08, $08, $08, $08);
  194.  
  195.   getbuf : WORD = 0;
  196.   getlen : BYTE = 0;
  197.   putlen : BYTE = 0;
  198.   putbuf : WORD = 0;
  199.   textsize : longint = 0;
  200.   codesize : longINT = 0;
  201.   printcount : longint = 0;
  202.   match_position : Integer = 0;
  203.   match_length : Integer = 0;
  204.  
  205.  
  206. TYPE
  207.   Freqtype = Array[0..T] OF WORD; 
  208.   FreqPtr = ^freqtype;
  209.   PntrType = Array[0..PRED(T+N_Char)] OF Integer;
  210.   pntrPtr = ^pntrType;
  211.   SonType = Array[0..PRED(T)] OF Integer;
  212.   SonPtr = ^SonType;
  213.  
  214.  
  215.   TextBufType = Array[0..N+F-2] OF BYTE;
  216.   TBufPtr = ^TextBufType;
  217.   WordRay = Array[0..N] OF Integer;
  218.   WordRayPtr = ^WordRay;
  219.   BWordRay = Array[0..N+256] OF Integer;
  220.   BWordRayPtr = ^BWordRay;
  221.  
  222. VAR
  223.   text_buf : TBufPtr;
  224.   lson,dad : WordRayPtr;
  225.   rson : BWordRayPtr;
  226.   freq : FreqPtr;    { cumulative freq table }
  227.  
  228. {
  229.  * pointing parent nodes.
  230.  * area [T..(T + N_CHAR - 1)] are pointers FOR leaves
  231.  }
  232.   prnt : PntrPtr;
  233.  
  234. { pointing children nodes (son[], son[] + 1)}
  235.   son : SonPtr;
  236.  
  237.  
  238.  
  239. Procedure InitTree;  { Initializing tree }
  240.  
  241. VAR
  242.   i : integer;
  243. BEGIN
  244.   FOR i := N + 1 TO N + 256 DO
  245.     rson^[i] := NUL;            { root }
  246.   FOR i := 0 TO N DO
  247.     dad^[i] := NUL;            { node }
  248. END;
  249.  
  250.  
  251.  
  252.  
  253.  
  254. Procedure InsertNode(r : Integer);  { Inserting node to the tree }
  255.  
  256. VAR
  257.   tmp,i, p, cmp : Integer;
  258.   key : TBufPtr;
  259.   c : WORD;
  260.  
  261. BEGIN
  262.      cmp := 1;
  263.      key := @text_buf^[r];
  264.      p := SUCC(N) + key^[0];
  265.      rson^[r] := NUL;
  266.      lson^[r] := NUL;
  267.      match_length := 0;
  268.      WHILE match_length < F DO
  269.        BEGIN
  270.          IF (cmp >= 0) THEN
  271.            BEGIN
  272.          IF (rson^[p] <> NUL) THEN
  273.            p := rson^[p]
  274.          ELSE
  275.                BEGIN
  276.              rson^[p] := r;
  277.          dad^[r] := p;
  278.          exit;
  279.            END;
  280.        END
  281.          ELSE
  282.            BEGIN
  283.          IF (lson^[p] <> NUL) THEN
  284.            p := lson^[p]
  285.          ELSE
  286.                BEGIN
  287.              lson^[p] := r;
  288.          dad^[r] := p;
  289.          exit;
  290.            END;
  291.        END;
  292.          i := 0;
  293.          cmp := 0;
  294.      While (i < F) AND (cmp = 0) DO
  295.            BEGIN
  296.              inc(i);
  297.              cmp := key^[i] - text_buf^[p + i];
  298.            END;
  299.          IF (i > THRESHOLD) THEN
  300.            BEGIN
  301.              tmp := PRED((r - p) AND PRED(N));
  302.          IF (i > match_length) THEN
  303.                BEGIN
  304.              match_position := tmp;
  305.                  match_length := i;
  306.            END;
  307.          IF (match_length < F) AND (i = match_length) THEN
  308.                BEGIN
  309.                  c := tmp;
  310.          IF (c < match_position) THEN
  311.                    match_position := c;
  312.            END;
  313.        END;
  314.        END;                { WHILE TRUE DO }
  315.      dad^[r] := dad^[p];
  316.      lson^[r] := lson^[p];
  317.      rson^[r] := rson^[p];
  318.      dad^[lson^[p]] := r;
  319.      dad^[rson^[p]] := r;
  320.      IF (rson^[dad^[p]] = p) THEN
  321.        rson^[dad^[p]] := r
  322.      ELSE
  323.        lson^[dad^[p]] := r;
  324.      dad^[p] := NUL;  { remove p }
  325. END;
  326.  
  327.  
  328.  
  329.  
  330. Procedure DeleteNode(p: Integer);  { Deleting node from the tree }
  331.  
  332. VAR
  333.   q : Integer;
  334.  
  335. BEGIN
  336.   IF (dad^[p] = NUL) THEN
  337.     exit;            { unregistered }
  338.   IF (rson^[p] = NUL) THEN
  339.     q := lson^[p]
  340.   ELSE IF (lson^[p] = NUL) THEN
  341.     q := rson^[p]
  342.   ELSE
  343.     BEGIN
  344.       q := lson^[p];
  345.       IF (rson^[q] <> NUL) THEN
  346.         BEGIN
  347.       REPEAT
  348.             q := rson^[q];
  349.       UNTIL (rson^[q] = NUL);
  350.           rson^[dad^[q]] := lson^[q];
  351.       dad^[lson^[q]] := dad^[q];
  352.       lson^[q] := lson^[p];
  353.       dad^[lson^[p]] := q;
  354.     END;
  355.       rson^[q] := rson^[p];
  356.       dad^[rson^[p]] := q;
  357.     END;
  358.   dad^[q] := dad^[p];
  359.   IF (rson^[dad^[p]] = p) THEN
  360.     rson^[dad^[p]] := q
  361.   ELSE
  362.     lson^[dad^[p]] := q;
  363.   dad^[p] := NUL;
  364. END;
  365.  
  366.  
  367. { Huffman coding parameters }
  368.  
  369.  
  370. Function GetBit(GetBytes:GetBytesProc): Integer;    { get one bit }
  371. VAR
  372.   i: BYTE;
  373.   i2 : Integer;
  374.   result : Word;
  375.  
  376. BEGIN
  377.   WHILE (getlen <= 8) DO
  378.     BEGIN
  379.       GetBytes(i,1,Result);
  380.       If Result = 1 THEN
  381.         i2 := i
  382.       ELSE i2 := 0;
  383.       getbuf := getbuf OR (i2 SHL (8 - getlen));
  384.       INC(getlen,8);
  385.     END;
  386.   i2 := getbuf;
  387.   getbuf := getbuf SHL 1;
  388.   DEC(getlen);
  389.   getbit := INTEGER((i2 < 0));
  390. END;
  391.  
  392.  
  393.  
  394.  
  395. Function GetByte(GetBytes:GetBytesProc): Integer;    { get a byte }
  396.  
  397. VAR
  398.   j : BYTE;
  399.   i,result : WORD;
  400. BEGIN
  401.   WHILE (getlen <= 8) DO
  402.     BEGIN
  403.       GetBytes(j,1,result);
  404.       If Result = 1 THEN
  405.         i := j
  406.       ELSE
  407.         i := 0;
  408.       getbuf := getbuf OR (i SHL (8 - getlen));
  409.       INC(getlen,8);
  410.     END;
  411.   i := getbuf;
  412.   getbuf := getbuf SHL 8;
  413.   DEC(getlen,8);
  414.   getbyte := integer(i SHR 8);
  415. END;
  416.  
  417.  
  418.  
  419.  
  420.  
  421. PROCEDURE Putcode(l : Integer; c: WORD;PutBytes:PutBytesProc);        { output c bits }
  422. VAR
  423.   Temp : BYTE;
  424.   Got : WORD;
  425. BEGIN
  426.   putbuf := putbuf OR (c SHR putlen);
  427.   inc(putlen,l);
  428.   IF (putlen >= 8) THEN
  429.     BEGIN
  430.       Temp := putbuf SHR 8;
  431.       PutBytes(Temp,1,Got);
  432.       DEC(putlen,8);
  433.       IF (putlen  >= 8) THEN
  434.         BEGIN
  435.           Temp := Lo(PutBuf);
  436.       PutBytes(Temp,1,Got);
  437.       INC(codesize,2);
  438.       DEC(putlen,8);
  439.       putbuf := c SHL (l - putlen);
  440.     END
  441.       ELSE
  442.         BEGIN
  443.       putbuf := putbuf SHL 8;
  444.       INC(codesize);
  445.     END;
  446.     END;
  447. END;
  448.  
  449.  
  450.  
  451. { initialize freq tree }
  452.  
  453. Procedure StartHuff;
  454. VAR
  455.   i, j : Integer;
  456. BEGIN
  457.   FOR i := 0 to PRED(N_CHAR) DO
  458.     BEGIN
  459.       freq^[i] := 1;
  460.       son^[i] := i + T;
  461.       prnt^[i + T] := i;
  462.     END;
  463.   i := 0;
  464.   j := N_CHAR;
  465.   WHILE (j <= R) DO
  466.     BEGIN
  467.       freq^[j] := freq^[i] + freq^[i + 1];
  468.       son^[j] := i;
  469.       prnt^[i] := j;
  470.       prnt^[i + 1] := j;
  471.       INC(i,2);
  472.       INC(j);
  473.     END;
  474.   freq^[T] := $ffff;
  475.   prnt^[R] := 0;
  476. END;
  477.  
  478.  
  479.  
  480.  
  481. { reconstruct freq tree }
  482.  
  483. PROCEDURE reconst;
  484. VAR
  485.  i, j, k, tmp : Integer;
  486.  f, l : WORD;
  487. BEGIN
  488.  { halven cumulative freq FOR leaf nodes }
  489.   j := 0;
  490.   FOR i := 0 to PRED(T) DO
  491.     BEGIN
  492.       IF (son^[i] >= T) THEN
  493.         BEGIN
  494.       freq^[j] := SUCC(freq^[i]) DIV 2;    {@@ Bug Fix MOD -> DIV @@}
  495.       son^[j] := son^[i];
  496.       INC(j);
  497.     END;
  498.     END;
  499.   { make a tree : first, connect children nodes }
  500.   i := 0;
  501.   j := N_CHAR;
  502.   WHILE (j < T) DO
  503.     BEGIN
  504.       k := SUCC(i);
  505.       f := freq^[i] + freq^[k];
  506.       freq^[j] := f;
  507.       k := PRED(j);
  508.       WHILE f < freq^[k] DO
  509.         DEC(K);
  510.       INC(k);
  511.       l := (j - k) SHL 1;
  512.       tmp := SUCC(k);
  513.       move(freq^[k], freq^[tmp], l);
  514.       freq^[k] := f;
  515.       move(son^[k], son^[tmp], l);
  516.       son^[k] := i;
  517.       INC(i,2);
  518.       INC(j);
  519.     END;
  520.         { connect parent nodes }
  521.   FOR i := 0 to PRED(T) DO
  522.     BEGIN
  523.       k := son^[i];
  524.       IF (k >= T) THEN
  525.         BEGIN
  526.       prnt^[k] := i;
  527.     END
  528.       ELSE
  529.         BEGIN
  530.       prnt^[k] := i;
  531.           prnt^[SUCC(k)] := i;
  532.     END;
  533.     END;
  534. END;
  535.  
  536.  
  537. { update freq tree }
  538.  
  539. Procedure update(c : Integer);
  540. VAR
  541.   i, j, k, l : Integer;
  542. BEGIN
  543.   IF (freq^[R] = MAX_FREQ) THEN
  544.     BEGIN
  545.       reconst;
  546.     END;
  547.   c := prnt^[c + T];
  548.   REPEAT
  549.     INC(freq^[c]);
  550.     k := freq^[c];
  551.  
  552.     { swap nodes to keep the tree freq-ordered }
  553.    l := SUCC(C);
  554.    IF (k > freq^[l]) THEN
  555.      BEGIN
  556.        WHILE (k > freq^[l]) DO
  557.          INC(l);
  558.        DEC(l);
  559.        freq^[c] := freq^[l];
  560.        freq^[l] := k;
  561.  
  562.        i := son^[c];
  563.        prnt^[i] := l;
  564.        IF (i < T) THEN prnt^[SUCC(i)] := l;
  565.  
  566.        j := son^[l];
  567.        son^[l] := i;
  568.  
  569.        prnt^[j] := c;
  570.        IF (j < T) THEN prnt^[SUCC(j)] := c;
  571.        son^[c] := j;
  572.  
  573.        c := l;
  574.      END;
  575.    c := prnt^[c];
  576.  UNTIL (c = 0);    { REPEAT it until reaching the root }
  577. END;
  578.  
  579.  
  580. VAR
  581.   code, len : WORD;
  582.  
  583.  
  584.  
  585.  
  586. PROCEDURE EncodeChar(c: WORD;PutBytes:PutBytesProc);
  587. VAR
  588.   i : WORD;
  589.   j, k : Integer;
  590. BEGIN
  591.   i := 0;
  592.   j := 0;
  593.   k := prnt^[c + T];
  594.  
  595.     { search connections from leaf node to the root }
  596.   REPEAT
  597.     i := i SHR 1;
  598.  
  599.     {
  600.     IF node's address is odd, output 1
  601.     ELSE output 0
  602.     }
  603.     IF BOOLEAN(k AND 1) THEN INC(i,$8000);
  604.     INC(j);
  605.     k := prnt^[k];
  606.   UNTIL (k = R);
  607.   Putcode(j, i,PutBytes);
  608.   code := i;
  609.   len := j;
  610.   update(c);
  611. END;
  612.  
  613.  
  614.  
  615. Procedure EncodePosition(c : WORD;PutBytes:PutBytesProc);
  616. VAR
  617.   i,j : WORD;
  618. BEGIN
  619.     { output upper 6 bits with encoding }
  620.   i := c SHR 6;
  621.   j := p_code[i];
  622.   Putcode(p_len[i],j SHL 8,PutBytes);
  623.  
  624.     { output lower 6 bits directly }
  625.   Putcode(6, (c AND $3f) SHL 10,PutBytes);
  626. END;
  627.  
  628.  
  629.  
  630. Procedure EncodeEnd(PutBytes:PutBytesProc);
  631. VAR
  632.   Temp : BYTE;
  633.   Got : WORD;
  634. BEGIN
  635.   IF BOOLEAN(putlen) THEN
  636.     BEGIN
  637.       Temp := Lo(putbuf SHR 8);
  638.       PutBytes(Temp,1,Got);
  639.       INC(codesize);
  640.     END;
  641. END;
  642.  
  643.  
  644.  
  645.  
  646.  
  647. FUNCTION DecodeChar(GetBytes:GetBytesProc): Integer;
  648. VAR
  649.   c : WORD;
  650. BEGIN
  651.   c := son^[R];
  652.  
  653.     {
  654.      * start searching tree from the root to leaves.
  655.      * choose node #(son[]) IF input bit = 0
  656.      * ELSE choose #(son[]+1) (input bit = 1)
  657.     }
  658.   WHILE (c < T) DO
  659.     BEGIN
  660.       c := c + GetBit(GetBytes);
  661.       c := son^[c];
  662.     END;
  663.   c := c - T;
  664.   update(c);
  665.   Decodechar := Integer(c);
  666. END;
  667.  
  668.  
  669.  
  670.  
  671.  
  672. Function DecodePosition(GetBytes:GetBytesProc) : WORD;
  673. VAR
  674.   i, j, c : WORD;
  675. BEGIN
  676.      { decode upper 6 bits from given table }
  677.   i := GetByte(GetBytes);
  678.   c := WORD(d_code[i] SHL 6);
  679.   j := d_len[i];
  680.  
  681.     { input lower 6 bits directly }
  682.   DEC(j,2);
  683.   While j <> 0 DO
  684.     BEGIN
  685.       i := (i SHL 1) + GetBit(GetBytes);
  686.       DEC(J);
  687.     END;
  688.   DecodePosition := c OR i AND $3f;
  689. END;
  690.  
  691.  
  692.  
  693. { Compression }
  694.  
  695.  
  696.  
  697. Procedure InitLZH;
  698. BEGIN
  699.   getbuf := 0;
  700.   getlen := 0;
  701.   putlen := 0;
  702.   putbuf := 0;
  703.   textsize := 0;
  704.   codesize := 0;
  705.   printcount := 0;
  706.   match_position := 0;
  707.   match_length := 0;
  708.   New(lson);
  709.   New(dad);
  710.   New(rson);
  711.   New(text_buf);
  712.   New(freq);
  713.   New(prnt);
  714.   New(son);
  715. END;
  716.  
  717.  
  718. Procedure EndLZH;
  719.  
  720. BEGIN
  721.   Dispose(son);
  722.   Dispose(prnt);
  723.   Dispose(freq);
  724.   Dispose(text_buf);
  725.   Dispose(rson);
  726.   Dispose(dad);
  727.   Dispose(lson);
  728. END;
  729.  
  730.  
  731. Procedure LZHPack(VAR Bytes_Written:LongInt; GetBytes:GetBytesProc; PutBytes:PutBytesProc);
  732. VAR
  733.    ct : BYTE;
  734.    i, len, r, s, last_match_length : Integer;
  735.    Got : WORD;
  736. BEGIN
  737.   InitLZH;
  738.  
  739.   textsize := 0;            { rewind and rescan }
  740.   StartHuff;
  741.   InitTree;
  742.   s := 0;
  743.   r := N - F;
  744.   FillChar(Text_buf^[0],r,' ');
  745.   len := 0;
  746.   Got := 1;
  747.   While (len < F) AND (Got <> 0) DO
  748.     BEGIN
  749.       GetBytes(ct,1,Got);
  750.       IF Got <> 0 THEN
  751.         BEGIN
  752.           text_buf^[r + len] := ct;
  753.           INC(len);
  754.         END;
  755.     END;
  756.   textsize := len;
  757.   FOR i := 1 to F DO
  758.     InsertNode(r - i);
  759.   InsertNode(r);
  760.   REPEAT
  761.     IF (match_length > len) THEN
  762.       match_length := len;
  763.     IF (match_length <= THRESHOLD) THEN
  764.       BEGIN
  765.         match_length := 1;
  766.     EncodeChar(text_buf^[r],PutBytes);
  767.       END
  768.     ELSE
  769.       BEGIN
  770.         EncodeChar(255 - THRESHOLD + match_length,PutBytes);
  771.     EncodePosition(match_position,PutBytes);
  772.       END;
  773.     last_match_length := match_length;
  774.     i := 0;
  775.     Got := 1;
  776.     While (i < last_match_length) AND (Got <> 0) DO
  777.       BEGIN
  778.         GetBytes(ct,1,Got);
  779.         IF Got <> 0 THEN
  780.           BEGIN
  781.             DeleteNode(s);
  782.         text_buf^[s] := ct;
  783.           IF (s < PRED(F)) THEN
  784.           text_buf^[s + N] := ct;
  785.         s := SUCC(s) AND PRED(N);
  786.         r := SUCC(r) AND PRED(N);
  787.         InsertNode(r);
  788.             inc(i);
  789.           END;
  790.       END;
  791.     INC(textsize,i);
  792.     While (i < last_match_length) DO
  793.       BEGIN
  794.         INC(i);
  795.         DeleteNode(s);
  796.         s := SUCC(s) AND PRED(N);
  797.         r := SUCC(r) AND PRED(N);
  798.         DEC(len);
  799.         IF BOOLEAN(len) THEN InsertNode(r);
  800.       END;
  801.   UNTIL (len <= 0);
  802.   EncodeEnd(PutBytes);
  803.   EndLZH;
  804.   Bytes_Written := TextSize;
  805. END;
  806.  
  807.  
  808.  
  809.  
  810. Procedure LZHUnpack(TextSize : Longint; GetBytes:GetBytesProc; PutBytes: PutBytesProc);
  811. VAR
  812.   c, i, j, k, r : Integer;
  813.   c2,a : Byte;
  814.   count : Longint;
  815.   Put : Word;
  816.  
  817. BEGIN
  818.   InitLZH;
  819.   StartHuff;
  820.   r := N - F;
  821.   FillChar(text_buf^[0],r,' ');
  822.   Count := 0;
  823.   While count < textsize DO
  824.     BEGIN
  825.       c := DecodeChar(GetBytes);
  826.       IF (c < 256) THEN
  827.         BEGIN
  828.           c2 := Lo(c);
  829.       PutBytes(c2,1,Put);
  830.       text_buf^[r] := c;
  831.           INC(r);
  832.       r := r AND PRED(N);
  833.       INC(count);
  834.     END
  835.       ELSE
  836.         BEGIN
  837.       i := (r - SUCC(DecodePosition(GetBytes))) AND PRED(N);
  838.       j := c - 255 + THRESHOLD;
  839.       FOR k := 0 TO PRED(j) DO
  840.             BEGIN
  841.           c := text_buf^[(i + k) AND PRED(N)];
  842.               c2 := Lo(c);
  843.           PutBytes(c2,1,Put);
  844.           text_buf^[r] := c;
  845.               INC(r);
  846.           r := r AND PRED(N);
  847.           INC(count);
  848.         END;
  849.     END;
  850.     END;
  851.   ENDLZH;
  852. END;
  853.  
  854.  
  855. END.
  856.