Форум: "Прочее";
Текущий архив: 2006.02.26;
Скачать: [xml.tar.bz2];

Вниз

Исходники архиваторов?   Найти похожие ветки 

← →
ZbarKiy   (2006-02-04 15:31) [0]

Уважаемые знатоки? Подскажите где можно найти стоящий исходники архиватора на делфях.

---

← →
Desdechado ©   (2006-02-04 17:09) [1]

zlib
хотя наиважнейшая часть там на Си, как и в прочих халявных архиваторах
можешь поискать на torry.net

---

← →
Lamer@fools.ua ©   (2006-02-04 17:48) [2]

>>Desdechado ©   (04.02.06 17:09) [1]

>хотя наиважнейшая часть там на Си
Я видел перевод в Object Pascal.

---

← →
kaZaNoVa ©   (2006-02-04 17:57) [3]

на старом Паскале:

Lzh.pas
{$A+,B-,D+,E-,F-,I+,L+,N-,O+,R-,S-,V-}
unit lzh;
(*
* LZHUF.C English version 1.0
* Based on Japanese version 29-NOV-1988
* LZSS coded by Haruhiko OKUMURA
* Adaptive Huffman Coding coded by Haruyasu YOSHIZAKI
* Edited and translated to English by Kenji RIKITAKE
* Translated from C to Turbo Pascal by Douglas Webb   2/18/91
*    Update and bug correction of TP version 4/29/91 (Sorry!!)
*)

{
    This unit allows the user to compress data using a combination of
  LZSS compression and adaptive Huffman coding, or conversely to decompress
  data that was previously compressed by this unit.

    There are a number of options as to where the data being compressed/
  decompressed is coming from/going to.

  In fact it requires that you pass the "LZHPack" procedure 2 procedural
 parameter of type "GetProcType" and "PutProcType" (declared below) which
 will accept 3 parameters and act in every way like a "BlockRead"/
 "BlockWrite" procedure call. Your "GetBytesProc" procedure should return
 the data to be compressed, and Your "PutBytesProc" procedure should do
 something with the compressed data (ie., put it in a file).  In case you
 need to know (and you do if you want to decompress this data again) the
 number of bytes in the compressed data (original, not compressed size)
 is returned in "Bytes_Written".

 GetBytesProc = PROCEDURE(VAR DTA; NBytes:WORD; VAR Bytes_Got : WORD);
 
 DTA is the start of a memory location where the information returned
 should be.  NBytes is the number of bytes requested.  The actual number
 of bytes returned must be passed in Bytes_Got (if there is no more data
 then 0 should be returned).

 PutBytesProc = PROCEDURE(VAR DTA; NBytes:WORD; VAR Bytes_Got : WORD);

 As above except instead of asking for data the procedure is dumping out
 compressed data, do somthing with it.

  "LZHUnPack" is basically the same thing in reverse.  It requires
 procedural parameters of type "PutProcType"/"GetProcType" which
 will act as above.  "GetProcType" must retrieve data compressed using
 "LZHPack" (above) and feed it to the unpacking routine as requested.
 "PutProcType" must accept the decompressed data and do something
 withit.  You must also pass in the original size of the decompressed data,
 failure to do so will have adverse results.

  Don"t forget that as procedural parameters the "GetProcType"/"PutProcType"
 procedures must be compiled in the "F+" state to avoid a catastrophe.

}

{ Note: All the large data structures for these routines are allocated when
 needed from the heap, and deallocated when finished.  So when not in use
 memory requirements are minimal.  However, this unit uses about 34K of
 heap space, and 400 bytes of stack when in use. }

interface

TYPE

 PutBytesProc = PROCEDURE(VAR DTA; NBytes:WORD; VAR Bytes_Put : WORD);
 {
  Your "PutBytesProc" procedure should do something with the compressed
  data (ie., put it in a file).

  DTA is the start of a memory location where the information returned
  should be.  NBytes is the number of bytes requested.  The actual number
  of bytes put should be returned in Bytes_Got.

  Don"t forget that as procedural parameters the "GetProcType"/"PutProcType"
 procedures must be compiled in the "F+" state to avoid a catastrophe.
 }

 GetBytesProc = PROCEDURE(VAR DTA; NBytes:WORD; VAR Bytes_Got : WORD);
 {
  Your "GetBytesProc" procedure should return the data to be compressed.
  In case you need to know (and you do if you want to decompress this
  data again) the number of bytes in the compressed data (original, not
  compressed size) is returned in "Bytes_Written".

  DTA is the start of a memory location where the information returned
  should be.  NBytes is the number of bytes requested.  The actual number
  of bytes returned must be passed in Bytes_Got (if there is no more data
  then 0 should be returned).

  Don"t forget that as procedural parameters the "GetProcType"/"PutProcType"
 procedures must be compiled in the "F+" state to avoid a catastrophe.
 }

Procedure LZHPack(VAR Bytes_Written:LongInt; GetBytes:GetBytesProc; PutBytes:PutBytesProc);
 {#XLZHUnPack}
 {
    This procedure allows the user to compress data using a combination of
  LZSS compression and adaptive Huffman coding.

    There are a number of options as to where the data being compressed
 is coming from.

  In fact it requires that you pass the "LZHPack" procedure 2 procedural
 parameter of type "GetProcType" and "PutProcType" (declared below) which
 will accept 3 parameters and act in every way like a "BlockRead"/
 "BlockWrite" procedure call. Your "GetBytesProc" procedure should return
 the data to be compressed, and Your "PutBytesProc" procedure should do
 something with the compressed data (ie., put it in a file).  In case you
 need to know (and you do if you want to decompress this data again) the
 number of bytes in the compressed data (original, not compressed size)
 is returned in "Bytes_Written".

 DTA is the start of a memory location where the information returned
 should be.  NBytes is the number of bytes requested.  The actual number
 of bytes returned must be passed in Bytes_Got (if there is no more data
 then 0 should be returned).

 As above except instead of asking for data the procedure is dumping out
 compressed data, do somthing with it.

 }

Procedure LZHUnpack(TextSize : Longint; GetBytes:GetBytesProc; PutBytes: PutBytesProc);
 {#X LZHPack}
 {
   "LZHUnPack" is basically the same as LZHPack in reverse.  It requires
 procedural parameters of type "PutProcType"/"GetProcType" which
 will act as above.  "GetProcType" must retrieve data compressed using
 "LZHPack" (above) and feed it to the unpacking routine as requested.
 "PutProcType" must accept the decompressed data and do something
 withit.  You must also pass in the original size of the decompressed data,

---

← →
kaZaNoVa ©   (2006-02-04 17:57) [4]

 failure to do so will have adverse results.
 }

implementation

CONST
 EXIT_OK = 0;
 EXIT_FAILED = 1;
{ LZSS Parameters }
 N  = 4096; { Size of string buffer }
 F  = 60; { Size of look-ahead buffer }
 THRESHOLD = 2;
 NUL  = N; { End of tree"s node  }

{ Huffman coding parameters }
 N_CHAR   = (256 - THRESHOLD + F);
 { character code (:= 0..N_CHAR-1) }
 T     = (N_CHAR * 2 - 1); { Size of table }
 R     = (T - 1);  { root position }
 MAX_FREQ = $8000;
    { update when cumulative frequency }
    { reaches to this value }
{
* Tables FOR encoding/decoding upper 6 bits of
* sliding dictionary pointer
}
{ encoder table }
 p_len : Array[0..63] of BYTE =
      ($03, $04, $04, $04, $05, $05, $05, $05,
$05, $05, $05, $05, $06, $06, $06, $06,
$06, $06, $06, $06, $06, $06, $06, $06,
$07, $07, $07, $07, $07, $07, $07, $07,
$07, $07, $07, $07, $07, $07, $07, $07,
$07, $07, $07, $07, $07, $07, $07, $07,
$08, $08, $08, $08, $08, $08, $08, $08,
$08, $08, $08, $08, $08, $08, $08, $08);

 p_code : Array [0..63] OF BYTE =
      ($00, $20, $30, $40, $50, $58, $60, $68,
$70, $78, $80, $88, $90, $94, $98, $9C,
$A0, $A4, $A8, $AC, $B0, $B4, $B8, $BC,
$C0, $C2, $C4, $C6, $C8, $CA, $CC, $CE,
$D0, $D2, $D4, $D6, $D8, $DA, $DC, $DE,
$E0, $E2, $E4, $E6, $E8, $EA, $EC, $EE,
$F0, $F1, $F2, $F3, $F4, $F5, $F6, $F7,
$F8, $F9, $FA, $FB, $FC, $FD, $FE, $FF);

{ decoder table }
 d_code: Array [0..255] OF BYTE =
      ($00, $00, $00, $00, $00, $00, $00, $00,
$00, $00, $00, $00, $00, $00, $00, $00,
$00, $00, $00, $00, $00, $00, $00, $00,
$00, $00, $00, $00, $00, $00, $00, $00,
$01, $01, $01, $01, $01, $01, $01, $01,
$01, $01, $01, $01, $01, $01, $01, $01,
$02, $02, $02, $02, $02, $02, $02, $02,
$02, $02, $02, $02, $02, $02, $02, $02,
$03, $03, $03, $03, $03, $03, $03, $03,
$03, $03, $03, $03, $03, $03, $03, $03,
$04, $04, $04, $04, $04, $04, $04, $04,
$05, $05, $05, $05, $05, $05, $05, $05,
$06, $06, $06, $06, $06, $06, $06, $06,
$07, $07, $07, $07, $07, $07, $07, $07,
$08, $08, $08, $08, $08, $08, $08, $08,
$09, $09, $09, $09, $09, $09, $09, $09,
$0A, $0A, $0A, $0A, $0A, $0A, $0A, $0A,
$0B, $0B, $0B, $0B, $0B, $0B, $0B, $0B,
$0C, $0C, $0C, $0C, $0D, $0D, $0D, $0D,
$0E, $0E, $0E, $0E, $0F, $0F, $0F, $0F,
$10, $10, $10, $10, $11, $11, $11, $11,
$12, $12, $12, $12, $13, $13, $13, $13,
$14, $14, $14, $14, $15, $15, $15, $15,
$16, $16, $16, $16, $17, $17, $17, $17,
$18, $18, $19, $19, $1A, $1A, $1B, $1B,
$1C, $1C, $1D, $1D, $1E, $1E, $1F, $1F,
$20, $20, $21, $21, $22, $22, $23, $23,
$24, $24, $25, $25, $26, $26, $27, $27,
$28, $28, $29, $29, $2A, $2A, $2B, $2B,
$2C, $2C, $2D, $2D, $2E, $2E, $2F, $2F,
$30, $31, $32, $33, $34, $35, $36, $37,
$38, $39, $3A, $3B, $3C, $3D, $3E, $3F);

d_len: Array[0..255] of BYTE =
      ($03, $03, $03, $03, $03, $03, $03, $03,
$03, $03, $03, $03, $03, $03, $03, $03,
$03, $03, $03, $03, $03, $03, $03, $03,
$03, $03, $03, $03, $03, $03, $03, $03,
$04, $04, $04, $04, $04, $04, $04, $04,
$04, $04, $04, $04, $04, $04, $04, $04,
$04, $04, $04, $04, $04, $04, $04, $04,
$04, $04, $04, $04, $04, $04, $04, $04,
$04, $04, $04, $04, $04, $04, $04, $04,
$04, $04, $04, $04, $04, $04, $04, $04,
$05, $05, $05, $05, $05, $05, $05, $05,
$05, $05, $05, $05, $05, $05, $05, $05,
$05, $05, $05, $05, $05, $05, $05, $05,
$05, $05, $05, $05, $05, $05, $05, $05,
$05, $05, $05, $05, $05, $05, $05, $05,
$05, $05, $05, $05, $05, $05, $05, $05,
$05, $05, $05, $05, $05, $05, $05, $05,
$05, $05, $05, $05, $05, $05, $05, $05,
$06, $06, $06, $06, $06, $06, $06, $06,
$06, $06, $06, $06, $06, $06, $06, $06,
$06, $06, $06, $06, $06, $06, $06, $06,
$06, $06, $06, $06, $06, $06, $06, $06,
$06, $06, $06, $06, $06, $06, $06, $06,
$06, $06, $06, $06, $06, $06, $06, $06,
$07, $07, $07, $07, $07, $07, $07, $07,
$07, $07, $07, $07, $07, $07, $07, $07,
$07, $07, $07, $07, $07, $07, $07, $07,
$07, $07, $07, $07, $07, $07, $07, $07,
$07, $07, $07, $07, $07, $07, $07, $07,
$07, $07, $07, $07, $07, $07, $07, $07,
$08, $08, $08, $08, $08, $08, $08, $08,
$08, $08, $08, $08, $08, $08, $08, $08);

 getbuf : WORD = 0;
 getlen : BYTE = 0;
 putlen : BYTE = 0;
 putbuf : WORD = 0;
 textsize : longint = 0;
 codesize : longINT = 0;
 printcount : longint = 0;
 match_position : Integer = 0;
 match_length : Integer = 0;

TYPE
 Freqtype = Array[0..T] OF WORD;
 FreqPtr = ^freqtype;
 PntrType = Array[0..PRED(T+N_Char)] OF Integer;
 pntrPtr = ^pntrType;
 SonType = Array[0..PRED(T)] OF Integer;
 SonPtr = ^SonType;

 TextBufType = Array[0..N+F-2] OF BYTE;
 TBufPtr = ^TextBufType;
 WordRay = Array[0..N] OF Integer;
 WordRayPtr = ^WordRay;
 BWordRay = Array[0..N+256] OF Integer;
 BWordRayPtr = ^BWordRay;

VAR
 text_buf : TBufPtr;
 lson,dad : WordRayPtr;
 rson : BWordRayPtr;
 freq : FreqPtr; { cumulative freq table }

{
* pointing parent nodes.
* area [T..(T + N_CHAR - 1)] are pointers FOR leaves
}
 prnt : PntrPtr;

{ pointing children nodes (son[], son[] + 1)}
 son : SonPtr;

Procedure InitTree;  { Initializing tree }

VAR
 i : integer;
BEGIN
 FOR i := N + 1 TO N + 256 DO
rson^[i] := NUL;   { root }
 FOR i := 0 TO N DO
dad^[i] := NUL;   { node }
END;

Procedure InsertNode(r : Integer);  { Inserting node to the tree }

VAR
 tmp,i, p, cmp : Integer;
 key : TBufPtr;
 c : WORD;

BEGIN
    cmp := 1;
    key := @text_buf^[r];
    p := SUCC(N) + key^[0];
    rson^[r] := NUL;
    lson^[r] := NUL;
    match_length := 0;
    WHILE match_length < F DO
      BEGIN
        IF (cmp >= 0) THEN
          BEGIN
     IF (rson^[p] <> NUL) THEN
       p := rson^[p]
     ELSE
              BEGIN
         rson^[p] := r;
  dad^[r] := p;
  exit;
       END;
   END
        ELSE
          BEGIN
     IF (lson^[p] <> NUL) THEN
       p := lson^[p]
     ELSE
              BEGIN
         lson^[p] := r;
  dad^[r] := p;
  exit;
       END;

---

← →
kaZaNoVa ©   (2006-02-04 17:57) [5]

   END;
        i := 0;
        cmp := 0;
 While (i < F) AND (cmp = 0) DO
          BEGIN
            inc(i);
            cmp := key^[i] - text_buf^[p + i];
          END;
        IF (i > THRESHOLD) THEN
          BEGIN
            tmp := PRED((r - p) AND PRED(N));
     IF (i > match_length) THEN
              BEGIN
         match_position := tmp;
                match_length := i;
       END;
     IF (match_length < F) AND (i = match_length) THEN
              BEGIN
                c := tmp;
  IF (c < match_position) THEN
                  match_position := c;
       END;
   END;
      END;                { WHILE TRUE DO }
    dad^[r] := dad^[p];
    lson^[r] := lson^[p];
    rson^[r] := rson^[p];
    dad^[lson^[p]] := r;
    dad^[rson^[p]] := r;
    IF (rson^[dad^[p]] = p) THEN
      rson^[dad^[p]] := r
    ELSE
      lson^[dad^[p]] := r;
    dad^[p] := NUL;  { remove p }
END;

Procedure DeleteNode(p: Integer);  { Deleting node from the tree }

VAR
 q : Integer;

BEGIN
 IF (dad^[p] = NUL) THEN
   exit;   { unregistered }
 IF (rson^[p] = NUL) THEN
   q := lson^[p]
 ELSE IF (lson^[p] = NUL) THEN
   q := rson^[p]
 ELSE
   BEGIN
     q := lson^[p];
     IF (rson^[q] <> NUL) THEN
       BEGIN
  REPEAT
           q := rson^[q];
  UNTIL (rson^[q] = NUL);
         rson^[dad^[q]] := lson^[q];
  dad^[lson^[q]] := dad^[q];
  lson^[q] := lson^[p];
  dad^[lson^[p]] := q;
END;
     rson^[q] := rson^[p];
     dad^[rson^[p]] := q;
   END;
 dad^[q] := dad^[p];
 IF (rson^[dad^[p]] = p) THEN
   rson^[dad^[p]] := q
 ELSE
   lson^[dad^[p]] := q;
 dad^[p] := NUL;
END;

{ Huffman coding parameters }

Function GetBit(GetBytes:GetBytesProc): Integer; { get one bit }
VAR
 i: BYTE;
 i2 : Integer;
 result : Word;

BEGIN
 WHILE (getlen <= 8) DO
   BEGIN
     GetBytes(i,1,Result);
     If Result = 1 THEN
       i2 := i
     ELSE i2 := 0;
     getbuf := getbuf OR (i2 SHL (8 - getlen));
     INC(getlen,8);
   END;
 i2 := getbuf;
 getbuf := getbuf SHL 1;
 DEC(getlen);
 getbit := INTEGER((i2 < 0));
END;

Function GetByte(GetBytes:GetBytesProc): Integer; { get a byte }

VAR
 j : BYTE;
 i,result : WORD;
BEGIN
 WHILE (getlen <= 8) DO
   BEGIN
     GetBytes(j,1,result);
     If Result = 1 THEN
       i := j
     ELSE
       i := 0;
     getbuf := getbuf OR (i SHL (8 - getlen));
     INC(getlen,8);
   END;
 i := getbuf;
 getbuf := getbuf SHL 8;
 DEC(getlen,8);
 getbyte := integer(i SHR 8);
END;

PROCEDURE Putcode(l : Integer; c: WORD;PutBytes:PutBytesProc);  { output c bits }
VAR
 Temp : BYTE;
 Got : WORD;
BEGIN
 putbuf := putbuf OR (c SHR putlen);
 inc(putlen,l);
 IF (putlen >= 8) THEN
   BEGIN
     Temp := putbuf SHR 8;
     PutBytes(Temp,1,Got);
     DEC(putlen,8);
     IF (putlen  >= 8) THEN
       BEGIN
         Temp := Lo(PutBuf);
  PutBytes(Temp,1,Got);
  INC(codesize,2);
  DEC(putlen,8);
  putbuf := c SHL (l - putlen);
END
     ELSE
       BEGIN
  putbuf := putbuf SHL 8;
  INC(codesize);
END;
   END;
END;

{ initialize freq tree }

Procedure StartHuff;
VAR
 i, j : Integer;
BEGIN
 FOR i := 0 to PRED(N_CHAR) DO
   BEGIN
     freq^[i] := 1;
     son^[i] := i + T;
     prnt^[i + T] := i;
   END;
 i := 0;
 j := N_CHAR;
 WHILE (j <= R) DO
   BEGIN
     freq^[j] := freq^[i] + freq^[i + 1];
     son^[j] := i;
     prnt^[i] := j;
     prnt^[i + 1] := j;
     INC(i,2);
     INC(j);
   END;
 freq^[T] := $ffff;
 prnt^[R] := 0;
END;

{ reconstruct freq tree }

PROCEDURE reconst;
VAR
i, j, k, tmp : Integer;
f, l : WORD;
BEGIN
{ halven cumulative freq FOR leaf nodes }
 j := 0;
 FOR i := 0 to PRED(T) DO
   BEGIN
     IF (son^[i] >= T) THEN
       BEGIN
  freq^[j] := SUCC(freq^[i]) DIV 2;    {@@ Bug Fix MOD -> DIV @@}
  son^[j] := son^[i];
  INC(j);
END;
   END;
 { make a tree : first, connect children nodes }
 i := 0;
 j := N_CHAR;
 WHILE (j < T) DO
   BEGIN
     k := SUCC(i);
     f := freq^[i] + freq^[k];
     freq^[j] := f;
     k := PRED(j);
     WHILE f < freq^[k] DO
       DEC(K);
     INC(k);
     l := (j - k) SHL 1;
     tmp := SUCC(k);
     move(freq^[k], freq^[tmp], l);
     freq^[k] := f;
     move(son^[k], son^[tmp], l);
     son^[k] := i;
     INC(i,2);
     INC(j);
   END;
    { connect parent nodes }
 FOR i := 0 to PRED(T) DO
   BEGIN
     k := son^[i];
     IF (k >= T) THEN
       BEGIN
  prnt^[k] := i;
END
     ELSE
       BEGIN
  prnt^[k] := i;
         prnt^[SUCC(k)] := i;
END;
   END;
END;

{ update freq tree }

Procedure update(c : Integer);
VAR
 i, j, k, l : Integer;
BEGIN
 IF (freq^[R] = MAX_FREQ) THEN
   BEGIN
     reconst;
   END;
 c := prnt^[c + T];
 REPEAT
   INC(freq^[c]);
   k := freq^[c];

{ swap nodes to keep the tree freq-ordered }
  l := SUCC(C);
  IF (k > freq^[l]) THEN
    BEGIN
      WHILE (k > freq^[l]) DO
        INC(l);
      DEC(l);
      freq^[c] := freq^[l];
      freq^[l] := k;

      i := son^[c];
      prnt^[i] := l;
      IF (i < T) THEN prnt^[SUCC(i)] := l;

      j := son^[l];
      son^[l] := i;

      prnt^[j] := c;
      IF (j < T) THEN prnt^[SUCC(j)] := c;
      son^[c] := j;

      c := l;
    END;
  c := prnt^[c];
UNTIL (c = 0); { REPEAT it until reaching the root }
END;

VAR
 code, len : WORD;

PROCEDURE EncodeChar(c: WORD;PutBytes:PutBytesProc);
VAR
 i : WORD;
 j, k : Integer;
BEGIN
 i := 0;
 j := 0;
 k := prnt^[c + T];

{ search connections from leaf node to the root }
 REPEAT
   i := i SHR 1;

{
IF node"s address is odd, output 1
ELSE output 0
}
   IF BOOLEAN(k AND 1) THEN INC(i,$8000);
   INC(j);
   k := prnt^[k];
 UNTIL (k = R);
 Putcode(j, i,PutBytes);
 code := i;
 len := j;
 update(c);
END;

---

← →
kaZaNoVa ©   (2006-02-04 17:58) [6]

Procedure EncodePosition(c : WORD;PutBytes:PutBytesProc);
VAR
 i,j : WORD;
BEGIN
{ output upper 6 bits with encoding }
 i := c SHR 6;
 j := p_code[i];
 Putcode(p_len[i],j SHL 8,PutBytes);

{ output lower 6 bits directly }
 Putcode(6, (c AND $3f) SHL 10,PutBytes);
END;

Procedure EncodeEnd(PutBytes:PutBytesProc);
VAR
 Temp : BYTE;
 Got : WORD;
BEGIN
 IF BOOLEAN(putlen) THEN
   BEGIN
     Temp := Lo(putbuf SHR 8);
     PutBytes(Temp,1,Got);
     INC(codesize);
   END;
END;

FUNCTION DecodeChar(GetBytes:GetBytesProc): Integer;
VAR
 c : WORD;
BEGIN
 c := son^[R];

   {
    * start searching tree from the root to leaves.
    * choose node #(son[]) IF input bit = 0
    * ELSE choose #(son[]+1) (input bit = 1)
   }
 WHILE (c < T) DO
   BEGIN
     c := c + GetBit(GetBytes);
     c := son^[c];
   END;
 c := c - T;
 update(c);
 Decodechar := Integer(c);
END;

Function DecodePosition(GetBytes:GetBytesProc) : WORD;
VAR
 i, j, c : WORD;
BEGIN
    { decode upper 6 bits from given table }
 i := GetByte(GetBytes);
 c := WORD(d_code[i] SHL 6);
 j := d_len[i];

{ input lower 6 bits directly }
 DEC(j,2);
 While j <> 0 DO
   BEGIN
     i := (i SHL 1) + GetBit(GetBytes);
     DEC(J);
   END;
 DecodePosition := c OR i AND $3f;
END;

{ Compression }

Procedure InitLZH;
BEGIN
 getbuf := 0;
 getlen := 0;
 putlen := 0;
 putbuf := 0;
 textsize := 0;
 codesize := 0;
 printcount := 0;
 match_position := 0;
 match_length := 0;
 New(lson);
 New(dad);
 New(rson);
 New(text_buf);
 New(freq);
 New(prnt);
 New(son);
END;

Procedure EndLZH;

BEGIN
 Dispose(son);
 Dispose(prnt);
 Dispose(freq);
 Dispose(text_buf);
 Dispose(rson);
 Dispose(dad);
 Dispose(lson);
END;

Procedure LZHPack(VAR Bytes_Written:LongInt; GetBytes:GetBytesProc; PutBytes:PutBytesProc);
VAR
  ct : BYTE;
  i, len, r, s, last_match_length : Integer;
  Got : WORD;
BEGIN
 InitLZH;

 textsize := 0;   { rewind and rescan }
 StartHuff;
 InitTree;
 s := 0;
 r := N - F;
 FillChar(Text_buf^[0],r," ");
 len := 0;
 Got := 1;
 While (len < F) AND (Got <> 0) DO
   BEGIN
     GetBytes(ct,1,Got);
     IF Got <> 0 THEN
       BEGIN
         text_buf^[r + len] := ct;
         INC(len);
       END;
   END;
 textsize := len;
 FOR i := 1 to F DO
   InsertNode(r - i);
 InsertNode(r);
 REPEAT
   IF (match_length > len) THEN
     match_length := len;
   IF (match_length <= THRESHOLD) THEN
     BEGIN
       match_length := 1;
EncodeChar(text_buf^[r],PutBytes);
     END
   ELSE
     BEGIN
       EncodeChar(255 - THRESHOLD + match_length,PutBytes);
EncodePosition(match_position,PutBytes);
     END;
   last_match_length := match_length;
   i := 0;
   Got := 1;
   While (i < last_match_length) AND (Got <> 0) DO
     BEGIN
       GetBytes(ct,1,Got);
       IF Got <> 0 THEN
         BEGIN
           DeleteNode(s);
    text_buf^[s] := ct;
      IF (s < PRED(F)) THEN
      text_buf^[s + N] := ct;
    s := SUCC(s) AND PRED(N);
    r := SUCC(r) AND PRED(N);
    InsertNode(r);
           inc(i);
         END;
     END;
   INC(textsize,i);
   While (i < last_match_length) DO
     BEGIN
       INC(i);
       DeleteNode(s);
       s := SUCC(s) AND PRED(N);
       r := SUCC(r) AND PRED(N);
       DEC(len);
       IF BOOLEAN(len) THEN InsertNode(r);
     END;
 UNTIL (len <= 0);
 EncodeEnd(PutBytes);
 EndLZH;
 Bytes_Written := TextSize;
END;

Procedure LZHUnpack(TextSize : Longint; GetBytes:GetBytesProc; PutBytes: PutBytesProc);
VAR
 c, i, j, k, r : Integer;
 c2,a : Byte;
 count : Longint;
 Put : Word;

BEGIN
 InitLZH;
 StartHuff;
 r := N - F;
 FillChar(text_buf^[0],r," ");
 Count := 0;
 While count < textsize DO
   BEGIN
     c := DecodeChar(GetBytes);
     IF (c < 256) THEN
       BEGIN
         c2 := Lo(c);
  PutBytes(c2,1,Put);
  text_buf^[r] := c;
         INC(r);
  r := r AND PRED(N);
  INC(count);
END
     ELSE
       BEGIN
  i := (r - SUCC(DecodePosition(GetBytes))) AND PRED(N);
  j := c - 255 + THRESHOLD;
  FOR k := 0 TO PRED(j) DO
           BEGIN
      c := text_buf^[(i + k) AND PRED(N)];
             c2 := Lo(c);
      PutBytes(c2,1,Put);
      text_buf^[r] := c;
             INC(r);
      r := r AND PRED(N);
      INC(count);
    END;
END;
   END;
 ENDLZH;
END;

END.


Lzhtest.pas

Program LZHTest;

{ This is a demo program to illstrate the use of the LZH unit.
 it implements a very simple 1 file at a time compressor program.

 Author : Douglas P. Webb
}

uses LZH;

CONST
 MaxBuf = 4096;     { Must be bigger than the biggest chunk being asked for. }

Type
 BufType = Array[1..MaxBuf] OF BYTE;
 BufPtr = ^BufType;

VAR
 InBuf,OutBuf : BufPtr;
 infile,Outfile : FILE;
 s : STRING;
 Bytes_Written : LongInt;
 Size : LongInt;
 Temp : WORD;

{$F+}

Procedure GetBlock(VAR Target; NoBytes:Word; VAR Actual_Bytes:Word);
CONST
 Posn : Word = 1;
 Buf : Word = 0;

VAR
 Temp:Word;

BEGIN
 IF (Posn > Buf) OR (Posn + NoBytes > SUCC(Buf)) THEN
   BEGIN
     IF Posn > Buf THEN
       BEGIN
         BlockRead(InFile,InBuf^,MaxBuf,Buf);
         Write("+");
       END
     ELSE
       BEGIN
         Move(InBuf^[Posn],InBuf^[1],Buf-Posn);
         BlockRead(InFile,InBuf^[Buf-Posn],MaxBuf-(Buf-Posn),Temp);
         Buf := Buf-Posn+Temp;
         Write("+");
       END;
     IF Buf = 0 THEN
       BEGIN
         Actual_Bytes := 0;
         Writeln;
         Exit;
       END;
     Posn := 1;
   END;
 Move(InBuf^[Posn],Target,NoBytes);
 INC(Posn,NoBytes);
 IF Posn > SUCC(Buf) THEN
   Actual_Bytes := NoBytes -(Posn-SUCC(Buf))
 ELSE Actual_Bytes := NoBytes;
END;

Procedure PutBlock(VAR Source; NoBytes:Word; VAR Actual_Bytes:Word);
CONST
 Posn : Word= 1;

VAR

---

← →
kaZaNoVa ©   (2006-02-04 17:58) [7]

 Temp:Word;

BEGIN
 If NoBytes = 0 THEN    { Flush condition }
   BEGIN
     BlockWrite(OutFile,OutBuf^,PRED(Posn),Temp);
     EXIT;
   END;
 IF (Posn > MaxBuf) OR (Posn + NoBytes > SUCC(MaxBuf)) THEN
   BEGIN
     BlockWrite(OutFile,OutBuf^,PRED(Posn),Temp);
     Posn := 1;
   END;
 Move(Source,OutBuf^[Posn],NoBytes);
 INC(Posn,NoBytes);
 Actual_Bytes := NoBytes;
END;

{$F-}

BEGIN
 IF (paramcount <> 3) THEN
   BEGIN
     Writeln("Usage:lzhuf e(compression)|d(uncompression) infile outfile");
     halt(1);
   END;
 s := paramstr(1);
 IF NOT (s[1] IN ["D","E","d","e"]) THEN
   Halt(1);
 Assign(infile,paramstr(2));
 reset(infile,1);
 Assign(outfile,Paramstr(3));
 Rewrite(outfile,1);
 New(InBuf);
 New(OutBuf);
 IF (upcase(s[1]) = "E") THEN
   BEGIN
      Size := Filesize(InFile);
      BlockWrite(OutFile,Size,Sizeof(LongInt));
      LZHPack(Bytes_Written,GetBlock,PutBlock);
      PutBlock(Size,0,Temp);
   END
 ELSE
   BEGIN
     BlockRead(Infile,Size,Sizeof(LongInt));
     LZHUnPack(Size,GetBlock,PutBlock);
     PutBlock(Size,0,Temp);
   END;
 Dispose(OutBuf);
 Dispose(InBuf);
 Close(Infile);
 Close(OutFile);
END.

---

Страницы: 1 вся ветка

Форум: "Прочее";
Текущий архив: 2006.02.26;
Скачать: [xml.tar.bz2];

Наверх

Память: 0.53 MB
Время: 0.035 c