📄 winconvert.pas
字号:
{$A+} { word align }
{$O+} { ?? ?? }
unit WinConvert;
(*
* 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!!)
* Added Delphi exception handling may 09 1996 Danny Heijl
* Danny.Heijl@cevi.be
* Added support for Delphi streams Aug. 05 1999
* Bruno Depero (bdepero@usa.net) and
* Kim Madsen (kbm@optical.dk)
*)
{
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. }
{$R-} { NO range checking !! }
interface
uses Sysutils,Classes;
{$IFDEF WIN32}
type Int16 = SmallInt;
{$ELSE}
type Int16 = Integer;
{$ENDIF}
{.$DEFINE DEBUG}
{$IFDEF DEBUG}
{$D+}
{$ENDIF}
TYPE
ElzhException = Class(Exception);
TWriteProc = procedure(VAR DTA; NBytes:WORD; VAR Bytes_Put : WORD) of object;
PutBytesProc = TwriteProc;
{
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.
}
TReadProc = procedure(VAR DTA; NBytes:WORD; VAR Bytes_Got : WORD) of object;
GetBytesProc = TReadProc;
{
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.
}
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);
TYPE
Freqtype = Array[0..T] OF WORD;
FreqPtr = ^freqtype;
PntrType = Array[0..PRED(T+N_Char)] OF Int16;
pntrPtr = ^pntrType;
SonType = Array[0..PRED(T)] OF Int16;
SonPtr = ^SonType;
TextBufType = Array[0..N+F-2] OF BYTE;
TBufPtr = ^TextBufType;
WordRay = Array[0..N] OF Int16;
WordRayPtr = ^WordRay;
BWordRay = Array[0..N+256] OF Int16;
BWordRayPtr = ^BWordRay;
{PG 17/09/98}
TLZH = class
Private
code, len : WORD;
Procedure InitTree; { Initializing tree }
Procedure InsertNode(r : Int16); { Inserting node to the tree }
Procedure DeleteNode(p: Int16); { Deleting node from the tree }
Function GetBit(GetBytes:GetBytesProc): Int16; { get one bit }
Function GetByte(GetBytes:GetBytesProc): Int16; { get a byte }
Procedure update(c : Int16);
Procedure StartHuff;
PROCEDURE Putcode(l : Int16; c: WORD;PutBytes:PutBytesProc); { output c bits }
PROCEDURE reconst;
PROCEDURE EncodeChar(c: WORD;PutBytes:PutBytesProc);
Procedure EncodePosition(c : WORD;PutBytes:PutBytesProc);
Procedure EncodeEnd(PutBytes:PutBytesProc);
FUNCTION DecodeChar(GetBytes:GetBytesProc): Int16;
Function DecodePosition(GetBytes:GetBytesProc) : WORD;
Procedure InitLZH;
Procedure EndLZH;
Public
StreamIn,StreamOut:TStream;
getbuf : WORD;
getlen : BYTE;
putlen : BYTE;
putbuf : WORD;
textsize : longint;
codesize : longINT;
printcount : longint ;
match_position : Int16 ;
match_length : Int16;
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 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,
failure to do so will have adverse results.
}
procedure GetBlockStream(var DTA; NBytes: Word; var Bytes_Got: Word);
procedure PutBlockStream(var DTA; NBytes: Word; var Bytes_Got: Word);
End;
implementation
Procedure TLZH.InitTree; { Initializing tree }
VAR
i : Int16;
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 TLZH.InsertNode(r : Int16); { Inserting node to the tree }
VAR
tmp,i, p, cmp : Int16;
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 begin
p := rson^[p]
end
ELSE BEGIN
rson^[p] := r;
dad^[r] := p;
exit;
END;
END
ELSE BEGIN
IF (lson^[p] <> NUL) THEN begin
p := lson^[p]
end
ELSE BEGIN
lson^[p] := r;
dad^[r] := p;
exit;
END;
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 begin
match_position := c;
end;
END;
END; { if i > threshold }
END; { WHILE match_length < F }
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 begin
rson^[dad^[p]] := r;
end
ELSE begin
lson^[dad^[p]] := r;
end;
dad^[p] := NUL; { remove p }
END;
Procedure TLZH.DeleteNode(p: Int16); { Deleting node from the tree }
VAR
q : Int16;
BEGIN
IF (dad^[p] = NUL) THEN exit; { unregistered }
IF (rson^[p] = NUL) THEN begin
q := lson^[p];
end
ELSE begin
IF (lson^[p] = NUL) THEN begin
q := rson^[p];
end
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;
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 }
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -