winconvert.pas

这是VCLSKIN v4.22 的所有的源代码

Function TLZH.GetBit(GetBytes:GetBytesProc): Int16;	{ get one bit }
VAR
  i: BYTE;
  i2 : Int16;
  Wresult : Word;
BEGIN
  WHILE (getlen <= 8) DO BEGIN
    GetBytes(i,1,Wresult);
    If Wresult = 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 := Int16((i2 < 0));

END;

Function TLZH.GetByte(GetBytes:GetBytesProc): Int16;	{ get a byte }
VAR
  j : BYTE;
  i,Wresult : WORD;
BEGIN
  WHILE (getlen <= 8) DO BEGIN
    GetBytes(j,1,Wresult);
    If Wresult = 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 := Int16(i SHR 8);
END;

PROCEDURE TLZH.Putcode(l : Int16; 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 TLZH.StartHuff;
VAR
  i, j : Int16;
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 TLZH.reconst;
VAR
 i, j, k, tmp : Int16;
 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 TLZH.update(c : Int16);
VAR
  i, j, k, l : Int16;
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;

PROCEDURE TLZH.EncodeChar(c: WORD;PutBytes:PutBytesProc);
VAR
  i : WORD;
  j, k : Int16;
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;

Procedure TLZH.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 TLZH.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 TLZH.DecodeChar(GetBytes:GetBytesProc): Int16;
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 := Int16(c);
END;

Function TLZH.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 TLZH.InitLZH;
BEGIN
  getbuf := 0;
  getlen := 0;
  putlen := 0;
  putbuf := 0;
  textsize := 0;
  codesize := 0;
  printcount := 0;
  match_position := 0;
  match_length := 0;
  try
    New(lson);
    New(dad);
    New(rson);
    New(text_buf);
    New(freq);
    New(prnt);
    New(son);
  except
    Raise ElzhException.Create('LZH : Cannot get memory for dictionary tables');
  end;
END;

Procedure TLZH.EndLZH;

BEGIN
  try
    Dispose(son);
    Dispose(prnt);
    Dispose(freq);
    Dispose(text_buf);
    Dispose(rson);
    Dispose(dad);
    Dispose(lson);
  except
    Raise ElzhException.Create('LZH : Error freeing memory for dictionary tables');
  end;
END;

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

   InitLZH;

   try
     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 begin
       InsertNode(r - i);
     end;
     InsertNode(r);
     REPEAT
       IF (match_length > len) THEN begin
         match_length := len;
       end;
       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 begin
             text_buf^[s + N] := ct;
           end;
           s := SUCC(s) AND PRED(N);
           r := SUCC(r) AND PRED(N);
           InsertNode(r);
           inc(i);
         END;
       END; { endwhile }
       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; { endwhile }
     UNTIL (len <= 0);  { end repeat }
     EncodeEnd(PutBytes);

   finally
     EndLZH;
   end;

   Bytes_Written := TextSize;

END;

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

BEGIN

   InitLZH;

   try
     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                {c >= 256 }
               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;  { for }
       END;  { if c < 256 }
     END; {endwhile count < textsize }

   finally
     ENDLZH;
   end;
end;

// Return as many bytes to the LZH compression buffer as requested.
procedure TLZH.GetBlockStream(var DTA; NBytes: Word; var Bytes_Got: Word);
begin
     //copy from stream into lzh compression buffer
     Bytes_Got := NBytes;
     if (StreamIn.Size - StreamIn.Position) < NBytes then
        Bytes_Got := StreamIn.Size - StreamIn.Position;
     StreamIn.ReadBuffer(DTA, Bytes_Got);
end;

procedure TLZH.PutBlockStream(var DTA; NBytes: Word; var Bytes_Got: Word);
begin
     //write from lzh decompression buffer to stream
     Bytes_Got := NBytes;
     StreamOut.WriteBuffer(DTA, Bytes_Got);
end;

END.