开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Delphi控件源码 > 查看源码
WinConvert.pas
资源名称：VCLSkinv5.30FS.rar　[点击查看]
上传用户：xjwsee
上传日期：2008-08-02
资源大小：796k
文件大小：25k
源码类别：

Delphi控件源码

开发平台：

Delphi

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