lzh.pas

小区水费管理系统源代码水费收费管理系统 水费收费管理系统

begin
  //Initialize frquency tree
  for i := 0 to PRED(cNumChars) do begin
    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 TLZHStream.Reconstruct;
VAR
 i, j, k, tmp: SmallInt;
 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 TLZHStream.update(c : SmallInt);
var
  i, j, k, l: SmallInt;
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 TLZHStream.EncodeChar(c: WORD);
var
  i: Word;
  j, k: SmallInt;
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 TLZHStream.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 TLZHStream.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 TLZHStream.DecodeChar: SmallInt;
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 := SmallInt(c);
end;

function TLZHStream.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;

  DecodePosition := c OR i AND $3f;
end;


procedure TLZHStream.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 TLZHStream.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 TLZHStream.Pack(OrigSize: Longint): Longint;
var
  ct : BYTE;
  i, len, r, s, last_match_length : SmallInt;
  Got : WORD;
begin
  FAction := acCompress;

  FUnCompressedSize := OrigSize;
  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;

procedure TLZHStream.Unpack;
var
  c, i, j, k, r: SmallInt;
  c2: Byte;
  count: Longint;
  Put: Word;
begin
  FAction := acDecompress;

  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;
  end;
end;

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

procedure TLZHStream.InternalWrite(const Data; Size: Word;
  var BytesWritten: Word);
begin
  if (FAction = acCompress) and (FBytesWritten + Size > FUncompressedSize) then
    raise ElzhException.Create('Compressed file is larger than the original.');
    
  WriteData(Data, Size, BytesWritten);
  Inc(FBytesWritten, BytesWritten);
end;


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.