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