www.pudn.com > GOOGLE.rar > 3.pas, change:2002-04-09,size:6927b


 
type 
  TRLEData = packed record 
    rdLen : byte; 
    rdVal : byte; 
  end; 
  TRLEPacker = class 
    private 
      FRLEData : array[0..7] of TRLEData; 
      FRLEInx  : integer; 
      FBuffer  : PByteArray; 
      FBufInx  : integer; 
    protected 
      procedure rpWriteEncoding(aCount : integer); 
    public 
      constructoe Create(aBufSize : integer); 
      destructor  Destroy : override; 
      procedure   Add(aLen : byte; aValue : byte); 
      procedure   MarkComplete; 
      procedure   CopyBuffer(var aDest); 
      property    BufferLen : integer read FBufInx; 
    end; 
 
constructor TRLEPacker.Create(aBufSize : integer); 
begin 
  inherited Create; 
  GetMem(FBuffer , aBufSize); 
end; 
 
destructor TRLEPacker.Destroy; 
begin 
  if (FBuffer <> nil) then 
    FreeMem(FBuffer); 
  inherited Destroy; 
end; 
 
procedure TRLEPacker.CopyBuffer(var aDest); 
begin 
  Move(FBuffer^ , aDest, FBufInx); 
end; 
 
procedure TRLEPacker.Add(aLen : byte; aAalue : byte); 
begin 
  FRLEDara[FRLEInx].rdLen := aLen; 
  FRLEData[FRLEInx].rdVal := aValue; 
  inc(FRLEInx); 
    if (FRLEInx = 8 ) then 
      rpWriteEncoding(8); 
end; 
 
procedure TRLEPacker.MarkComplete; 
begin 
  {add the sentinel to indicate end-off-compressed-data(a code for a length of zerodoes this)} 
  Add(0,0); 
  {write out any final encoding} 
  if (FRLEInx <> 0) then 
    rpWriteEncoding(FRLEInx); 
end; 
 
procedure TRLEPacker.rpWriteEncoding(aCount : integer); 
var 
  i : integer; 
  ControlByte : byte; 
begin 
  {initialize the control byte} 
  ControlByte := 0; 
  {for all the encodings, set the relevant bit of the control byte if a run, leave it clear otherwise (note: the end-of-data sentinel has a length of zero and this code treats it as an actual length)} 
  for i := 0 to pred(aCount) do  
    begin 
      ControlByte := ControlByte shl 1; 
      if (FRLEData[i].rdLen <> 1) then inc(ControlByte); 
    end; 
  {if the number of encoding is less than 8, set the rest of the bits as clear} 
  if (aCount <> 8) then 
    for i := aCount to 7 do 
      ControlByte := ControlByte shl 1; 
  {write out the control byte} 
  FBuffer^[FBufInx] := ControlByte; 
  inc(FBufInx); 
  {write out the encodings, either as run length followed by the byte or as the byte itself if the runlength were 1} 
  for i := 0 to pred(aCount) do  
    begin 
      case FRLEData[i].rdLen of 
        0 : begin 
              FBuffer^[FBufInx] := 0; 
              inc(FBufInx); 
            end; 
        1 : begin 
              FBuffer^[FBufInx[ := FRLEData[i].rdVal; 
              inc(FBufInx); 
            end; 
        else  {any other value :2..255} 
            FBuffer^[FBufInx] := FRLEData[i].rdLen; 
            inc(FBufInx); 
            FBuffer^[FBufInx] := FRLEData[i].rdVal; 
            inc(FBufInx); 
      end; 
    end; 
  FRLEInx := 0; 
end; 
 
procedure TaaBitSet.bsPack; 
var 
  i      : integer; 
  B      : byte; 
  PrevB  : byte; 
  RunLEn : byte; 
  PAcker : TRLEPacker; 
begin 
  {allocate a packer object with a buffer big enough for the worst case, in which all runs are of length one¡ªthat is, packing will grow the data by 1 byte for each 8 unapcked bytes, plus one byte over for the sentinel} 
  Packer := TRLEPacker.Create(FBitArraySize + ((FBitArraysize + 8) div 8)); 
  try 
    {set it up so previous byte is the first byte and current run length is zero: marks loop code easier} 
    PrevB := FBitArray^[0]; 
    RunLen := 0; 
    {process the rest of the bytes} 
    for i := 0 to pred(FBitArraySize) do 
      begin 
        {get the next byte} 
        B := FBitArray^[i]; 
        {if it is different from the previous byte, close off the previous run and start a new one} 
        if (B <> PrevB) then  
          begin 
            Packer.Add(RunLen , PrevB); 
            PrevB := B; 
            RunLen := 1; 
          end 
        {otherwise, continue this run} 
        else 
          begin 
            {if we've already reached 255 bytes in this run before adding this byte, close it off and start a new one} 
            if (RunLen = 255) then 
              begin 
                Packer.Add(RunLen , PrevB); 
                RunLen := 0; 
              end; 
            inc(RunLen); 
          end; 
      end; 
    {close off the final run} 
    Packer.Add(RunLen , PrevB); 
    {mark the packer object as being complete (this adds the sentinel and calculates the compressed buffer size} 
    Packer.MarkComplete; 
    {reallocate our buffer and copy over the compressed data} 
    FBitArraySize := PAcker.BufferLen; 
    ReallocMem(FBitArray , FBitArraySize); 
    Packer.CopyBuffer(FBitArray^); 
    FPacked := ture; 
  finally 
    Packer.Free; 
  end; 
end; 
 
procedure TaaBitSet.bsUnpack; 
var 
  i      : integer; 
  Buf    : PButeArray; 
  RunLen : integer; 
  InInx  : integer; 
  OutInx : integer; 
  Done   : boolean; 
  Value  : byte; 
  Mask   : byte; 
  ControlByte : byte; 
begin 
  {allocate output buffer large enough to hold all the bits} 
  GetMem(Buf , (FBitCount + 7) div 8); 
  try 
    {initialize for the loop} 
    Done := false; 
    InInx := 0; 
    OutInx := 0; 
    {continue unpacking until the end of compressed data is found} 
    repeat 
      {set the mask for the control byte} 
      Mask := $80; 
      {read the control byte} 
      ControlByte := FBitArray^[InInx]; 
      inc(InInx); 
      {repeat until all the bits in the control byte have been used} 
      while (Mask <> 0) do 
        begin 
          {if the control bit says that the next byte is literal, copy it over to the output buffer} 
          if ((ControlByte and Mask) = 0) then 
            begin 
              Buf^[OutInx] := FBitArray^[InInx]; 
              inc(OutInx); 
              inc(InInx); 
            end 
          {otherwise it's an FLE instruction; get the run length and the value to copy and duplivate it {note: a runlength of zero indicates the end of the compressed data)} 
          else 
            begin 
              RunLen := FBitArray^[InInx]; 
              inc(InInx); 
              if (RunLen = 0) then  
                begin 
                  Done := true; 
                  Break; 
                end 
              else 
                begin 
                  Value := FBitArray^[InInx]; 
                  inc(InInx); 
                  for i := 1 to RunLen do 
                    begin 
                      Buf^[OutInx] := Value; 
                      inc(OutInx); 
                    end; 
                end; 
            end; 
          {set mask to get the next bit}  
          Mask L= Mask shr 1; 
        end; 
      until Done; 
      {throw away the old packed buffer, and set it (and other fields) for the new unpacked one} 
      FreeMem(FBitArray); 
      FBitArray := Buf; 
      FBitArraySize := (FBitCount + 7) div 8; 
      FPacked := false; 
    except 
      FreeMem(Buf); 
      raise; 
    end; 
end;