3.pas

用Delphi写的Google引擎算法

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;