cmplzh.pas

Delphi控件

    freq[i] := 1;
    Child[i] := i + cTableSize;
    Parent[i + cTableSize] := i;
  end;

  i := 0;
  j := cNumChars;
  while (j <= cRootPos) do 
  begin
    freq[j] := freq[i] + freq[i + 1];
    Child[j] := i;
    Parent[i] := j;
    Parent[i + 1] := j;
    inc(i, 2);
    inc(j);
  end;

  freq[cTableSize] := $ffff;
  Parent[cRootPos] := 0;
end;

procedure TAbstractLZH.Reconstruct;
var
  i, j, k, tmp: Int16;
  f, l: Word;
begin
  //Half the existing values
  j := 0;
  for i := 0 to PRED(cTableSize) do 
  begin
    if (Child[i] >= cTableSize) then 
    begin
      freq[j] := SUCC(freq[i]) div 2;    {@@ Bug Fix MOD -> DIV @@}
      Child[j] := Child[i];
      inc(j);
    end;
  end;

  //Make a tree : first, connect children nodes
  i := 0;
  j := cNumChars;
  while (j < cTableSize) 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(Child[k], Child[tmp], l);
    Child[k] := i;
    inc(i, 2);
    inc(j);
  end;

  //Connect parent nodes
  for i := 0 to PRED(cTableSize) do 
  begin
    k := Child[i];
    if (k >= cTableSize) then
      Parent[k] := i
    else 
    begin
      Parent[k] := i;
      Parent[SUCC(k)] := i;
    end;
  end;
end;


procedure TAbstractLZH.update(c: Int16);
var
  i, j, k, l: Int16;
begin
  if (freq[cRootPos] = cMaximumFreq) then Reconstruct;

  c := Parent[c + cTableSize];
  repeat
    inc(freq[c]);
    k := freq[c];

    //Wwap 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 := Child[c];
      Parent[i] := l;
      if (i < cTableSize) then Parent[SUCC(i)] := l;

      j := Child[l];
      Child[l] := i;

      Parent[j] := c;
      if (j < cTableSize) then Parent[SUCC(j)] := c;
      Child[c] := j;

      c := l;
    end;
    c := Parent[c];
  until (c = 0); //Repeat until root has been reached
end;


procedure TAbstractLZH.EncodeChar(c: WORD);
var
  i: Word;
  j, k: Int16;
begin
  i := 0;
  j := 0;
  k := Parent[c + cTableSize];

  //Search connections from leaf node to the root
  repeat
    i := i shr 1;
    //IF node's address is odd, output 1, otherwise 0

    if Boolean(k and 1) then inc(i, $8000);
    inc(j);
    k := Parent[k];
  until (k = cRootPos);

  Putcode(j, i);
  code := i;
  len := j;
  update(c);
end;



procedure TAbstractLZH.EncodePosition(c: WORD);
var
  i, j: WORD;
begin
  //Output upper 6 bits with encoding
  i := c shr 6;
  j := cEncTableCode[i];
  Putcode(cEncTableLen[i], j shl 8);

  //Output lower 6 bits directly
  Putcode(6, (c and $3f) shl 10);
end;

procedure TAbstractLZH.EncodeEnd;
var
  Temp: Byte;
  Got: Word;
begin
  if Boolean(putlen) then 
  begin
    Temp := Lo(putbuf shr 8);
    InternalWrite(Temp, 1, Got);
    inc(codesize);
  end;
end;

function TAbstractLZH.DecodeChar: Int16;
var
  c: WORD;
begin
  c := Child[cRootPos];
  //Start searching tree from the root to leaves.
  //choose node #(son[]) IF input bit = 0
  //ELSE choose #(son[]+1) (input bit = 1)
  while (c < cTableSize) do 
  begin
    c := c + GetBit;
    c := Child[c];
  end;

  c := c - cTableSize;
  update(c);
  Decodechar := Int16(c);
end;

function TAbstractLZH.DecodePosition: Word;
var
  i, j, c: Word;
begin
  //Decode upper 6 bits from given table
  i := GetByte;
  c := WORD(cDecTableCode[i] shl 6);
  j := cDecTableLen[i];

  //Input lower 6 bits directly
  dec(j, 2);
  while j <> 0 do 
  begin
    i := (i shl 1) + GetBit;
    DEC(J);
  end;

  Result := c or i and $3f;
end;


procedure TAbstractLZH.InitLZH;
begin
  getbuf := 0;
  getlen := 0;
  putlen := 0;
  putbuf := 0;
  OrigSize := 0;
  codesize := 0;
  printcount := 0;
  MatchPos := 0;
  MatchLen := 0;
  FBytesWritten := 0;
  FBytesRead := 0;
  try
    New(LeftLeaf);
    New(ParentLeaf);
    New(RightLeaf);
    New(TextBuff);
    New(freq);
    New(Parent);
    New(Child);
  except
    raise ElzhException.Create('LZH : Cannot get memory for dictionary tables');
  end;
end;


procedure TAbstractLZH.EndLZH;
begin
  try
    Dispose(Child);
    Dispose(Parent);
    Dispose(freq);
    Dispose(TextBuff);
    Dispose(RightLeaf);
    Dispose(ParentLeaf);
    Dispose(LeftLeaf);
  except
    raise ElzhException.Create('LZH : Error freeing memory for dictionary tables');
  end;
end;


function TAbstractLZH.Pack(OrigSize: Longint): Longint;
var
  ct: BYTE;
  i, len, r, s, last_match_length: Int16;
  Got: WORD;
begin
  InternalWrite(OrigSize, Sizeof(Longint), Got);
  
  InitLZH;
  try
    OrigSize := 0;      { rewind and rescan }

    StartHuff;
    InitTree;

    s := 0;
    r := cStringBufferSize - cLookAheadSize;
    FillChar(TextBuff[0], r, ' ');
    len := 0;
    Got := 1;
    while (len < cLookAheadSize) and (Got <> 0) do 
    begin
      InternalRead(ct, 1, Got);
      if Got <> 0 then 
      begin
        TextBuff[r + len] := ct;
        inc(len);
      end;
    end;

    OrigSize := len;
    for i := 1 to cLookAheadSize do InsertNode(r - i);

    InsertNode(r);

    repeat
      if (MatchLen > len) then MatchLen := len;

      if (MatchLen <= cThreshHold) then 
      begin
        MatchLen := 1;
        EncodeChar(TextBuff[r]);
      end 
      else 
      begin
        EncodeChar(255 - cThreshHold + MatchLen);
        EncodePosition(MatchPos);
      end;

      last_match_length := MatchLen;
      i := 0;
      Got := 1;

      while (i < last_match_length) and (Got <> 0) do 
      begin
        InternalRead(ct, 1, Got);
        if Got <> 0 then 
        begin
          DeleteNode(s);
          TextBuff[s] := ct;
          if (s < PRED(cLookAheadSize)) then 
          begin
            TextBuff[s + cStringBufferSize] := ct;
          end;
          s := SUCC(s) and PRED(cStringBufferSize);
          r := SUCC(r) and PRED(cStringBufferSize);
          InsertNode(r);
          inc(i);
        end
      end;
      inc(OrigSize, i);

      while (i < last_match_length) do 
      begin
        inc(i);
        DeleteNode(s);
        s := SUCC(s) and PRED(cStringBufferSize);
        r := SUCC(r) and PRED(cStringBufferSize);
        dec(len);
        if Boolean(len) then InsertNode(r);
      end;
    until (len <= 0);

    EncodeEnd;
  finally
    Result := FBytesWritten;
    EndLZH;
  end;
end;

function TAbstractLZH.Unpack: Longint;
var
  c, i, j, k, r: Int16;
  c2: Byte;
  Count: Longint;
  Put: Word;
begin
  InitLZH;
  try
    StartHuff;
    r := cStringBufferSize - cLookAheadSize;
    FillChar(TextBuff[0], r, ' ');

    Count := 0;
    InternalRead(OrigSize, Sizeof(Longint), Put);
    while Count < OrigSize do 
    begin
      c := DecodeChar;
      if (c < 256) then 
      begin
        c2 := Lo(c);
        InternalWrite(c2, 1, Put);
        TextBuff[r] := c;
        INC(r);
        r := r and PRED(cStringBufferSize);
        inc(Count);
      end 
      else 
      begin //c >= 256
        i := (r - SUCC(DecodePosition)) and PRED(cStringBufferSize);
        j := c - 255 + cThreshHold;
        for k := 0 to PRED(j) do 
        begin
          c := TextBuff[(i + k) and PRED(cStringBufferSize)];
          c2 := Lo(c);
          InternalWrite(c2, 1, Put);
          TextBuff[r] := c;
          inc(r);
          r := r and PRED(cStringBufferSize);
          INC(Count);
        end;
      end;
    end;
  finally
    ENDLZH;
    Result := FBytesWritten;
  end;
end;

procedure TAbstractLZH.InternalRead(var Data; Size: Word;
  var BytesRead: Word);
begin
  ReadData(Data, Size, BytesRead);
  Inc(FBytesRead, BytesRead);
end;

procedure TAbstractLZH.InternalWrite(const Data; Size: Word;
  var BytesWritten: Word);
begin
  WriteData(Data, Size, BytesWritten);
  Inc(FBytesWritten, BytesWritten);
end;


{ TLZHStream }

constructor TLZHStream.Create(Source, Dest: TStream);
begin
  inherited Create;
  FSource := Source;
  FDest := Dest;
end;

procedure TLZHStream.ReadData(var Data; Size: Word; var BytesRead: Word);
begin
  BytesRead := FSource.Read(Data, Size);
end;

procedure TLZHStream.WriteData(const Data; Size: Word; var BytesWritten: Word);
begin
  BytesWritten := FDest.Write(Data, Size);
end;


end.