Bit management under Delphi

I absolutely hate bit management under Delphi. So I wrote this class to solve the problem once and for all. Not just fidling with bits inside a fixed datatype (like a byte or a word) but for memory allocations of any size. It should work fine under Lazarus/freepascal as well.

Here you go

  unit bitbuffer;

  interface

  //##########################################################################
  //  Class:      TBitBuffer
  //  Author:     Jon Lennart Aasenden
  //  Purpose:
  //    -General purpose class for manupulating large buffers on bit level
  //    -Possible to store bitbuffer to stream
  //    -Class methods for general bit manipulation on memory segements
  //     larger than fixed datatypes
  //    -Possible to search buffer for unset bits
  //    -Keeps track of unset bits (perfect for database record mapping)
  //##########################################################################

  uses sysutils, classes;

  type

  EBitBuffer  = Class(Exception);

  TBitOffsetArray = packed array of system.NativeUInt;

  TBitBuffer = Class(TObject)
  Private
    FData:      PByte;
    FDataLng:   NativeInt;
    FDataLen:   NativeInt;
    FBitsMax:   NativeUInt;
    FReadyByte: NativeUInt;
    FAddr:      PByte;
    BitOfs:     0..255;
    FByte:      Byte;
    Function    GetByte(Const Index:NativeInt):Byte;
    Procedure   SetByte(Const Index:NativeInt;Const Value:Byte);
    Function    GetBit(Const Index:NativeUInt):Boolean;
    Procedure   SetBit(Const Index:NativeUInt;Const Value:Boolean);
  Public
    Property    Data:PByte read FData;
    Property    Size:NativeInt read FDataLen;
    Property    Count:NativeUInt read FBitsMax;
    Property    Bytes[Const Index:NativeInt]:Byte
                Read GetByte write SetByte;
    Property    Bits[Const Index:NativeUInt]:Boolean
                Read GetBit write SetBit;default;

    Procedure   Allocate(MaxBits:NativeUInt);
    Procedure   Release;
    Function    Empty:Boolean;
    Procedure   Zero;

    class function  BitsOf(Const aBytes:NativeInt):NativeUInt;
    class function  BytesOf(aBits:NativeUInt):NativeInt;

    class function  BitsSetInByte(Const Value:Byte):NativeInt;
    class Function  BitGet(Const Index:NativeInt;Const Buffer):Boolean;
    class procedure BitSet(Const Index:NativeInt;var Buffer;
                    Const Value:Boolean);

    procedure   SaveToStream(Const stream:TStream);virtual;
    Procedure   LoadFromStream(Const stream:TStream);virtual;

    Procedure   SetBitRange(First,Last:NativeUInt;
                Const Bitvalue:Boolean);
    Procedure   SetBits(Const Value:TBitOffsetArray;
                Const BitValue:Boolean);
    Function    FindIdleBit(var Value:NativeUInt;
                Const FromStart:Boolean=False):Boolean;
    Destructor  Destroy;Override;
  End;

  implementation

  const

  ERR_BitBuffer_InvalidBitIndex  =
  'Invalid bit index, expected 0..%d not %d';

  ERR_BitBuffer_InvalidByteIndex =
  'Invalid byte index, expected 0..%d not %d';

  ERR_BitBuffer_BitBufferEmpty =
  'Bitbuffer is empty error';

  ERR_ERR_BitBuffer_INVALIDOFFSET  =
  'Invalid bit offset, expected 0..%d, not %d';

  CNT_BitBuffer_ByteTable:  array [0..255] of NativeInt =
  (0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4,
  1, 2, 2, 3, 2, 3, 3, 4, 2, 3, 3, 4, 3, 4, 4, 5,
  1, 2, 2, 3, 2, 3, 3, 4, 2, 3, 3, 4, 3, 4, 4, 5,
  2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
  1, 2, 2, 3, 2, 3, 3, 4, 2, 3, 3, 4, 3, 4, 4, 5,
  2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
  2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
  3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7,
  1, 2, 2, 3, 2, 3, 3, 4, 2, 3, 3, 4, 3, 4, 4, 5,
  2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
  2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
  3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7,
  2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
  3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7,
  3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7,
  4, 5, 5, 6, 5, 6, 6, 7, 5, 6, 6, 7, 6, 7, 7, 8);

  //##########################################################################
  // TBitBuffer
  //##########################################################################

  Destructor TBitBuffer.Destroy;
  Begin
    If not Empty then
    Release;
    inherited;
  end;

  class function TBitBuffer.BitsOf(Const aBytes:NativeInt):NativeUInt;
  Begin
    result:=aBytes shl 3;
  end;

  class function TBitBuffer.BytesOf(aBits:NativeUInt):NativeInt;

    Function QToNearest(Const Value,Factor:NativeInt):NativeInt;
    var
      FTemp: Integer;
    Begin
      Result:=Value;
      FTemp:=Value mod Factor;
      If FTemp>0 then
      inc(Result,Factor - FTemp);
    end;

  Begin
    aBits:=QToNearest(aBits,8);
    result:=aBits shr 3;
    if (result shl 3) < aBits then
    inc(result);
  end;

  class function TBitBuffer.BitsSetInByte(Const Value:Byte):NativeInt;
  begin
    result:=CNT_BitBuffer_ByteTable[Value];
  end;

  class Function TBitBuffer.BitGet(Const Index:NativeInt;Const Buffer):Boolean;
  var
    FValue: Byte;
    FAddr:  PByte;
    BitOfs: 0..255;
  Begin
    If Index>=0 then
    Begin
      BitOfs:=Index mod 8;
      FAddr:=PTR(NativeInt(@Buffer) + Index shr 3);
      FValue:=FAddr^;
      Result:=(FValue and (1 shl (BitOfs mod 8))) <> 0;
    end else
    Raise EBitBuffer.CreateFmt
    (ERR_ERR_BitBuffer_INVALIDOFFSET,[maxint-1,index]);
  end;

  class Procedure TBitBuffer.BitSet(Const Index:NativeInt;
            var Buffer;Const Value:Boolean);
  var
    FByte:    Byte;
    FAddr:    PByte;
    BitOfs:   0..255;
    FCurrent: Boolean;
  Begin
    If Index>=0 then
    Begin
      FAddr:=PTR(NativeInt(@Buffer) + Index shr 3);
      FByte:=FAddr^;
      BitOfs := Index mod 8;
      FCurrent:=(FByte and (1 shl (BitOfs mod 8))) <> 0;

      case value of
      true:
        begin
          (* set bit if not already set *)
          If FCurrent=False then
          FByte:=(FByte or (1 shl (BitOfs mod 8)));
          FAddr^:=FByte;
        end;
      false:
        begin
          (* clear bit if already set *)
          If FCurrent then
          FByte:=(FByte and not (1 shl (BitOfs mod 8)));
          FAddr^:=FByte;
        end;
      end;

    end else
    Raise EBitBuffer.CreateFmt
    (ERR_ERR_BitBuffer_INVALIDOFFSET,[maxint-1,index]);
  end;

  procedure TBitBuffer.SaveToStream(Const stream:TStream);
  var
    mWriter:  TWriter;
  begin
    mWriter:=TWriter.Create(stream,1024);
    try
      mWriter.WriteInteger(FDataLen);
      mWriter.Write(FData^,FDataLen);
    finally
      mwriter.FlushBuffer;
      mWriter.Free;
    end;
  end;

  Procedure TBitBuffer.LoadFromStream(Const stream:TStream);
  var
    mReader:  TReader;
    mlen: NativeInt;
  Begin
    Release;
    mReader:=TReader.Create(stream,1024);
    try
      mLen:=mReader.ReadInteger;
      if mLen>0 then
      begin
        Allocate(BitsOf(mLen));
        mReader.Read(FData^,mLen);
      end;
    finally
      mReader.Free;
    end;
  end;

  Function TBitBuffer.Empty:Boolean;
  Begin
    result:=FData=NIL;
  end;

  Function TBitBuffer.GetByte(Const Index:NativeInt):Byte;
  Begin
    If FData<>NIL then
    Begin
      If (index>=0) and (Index<FDataLen) then
      result:=PByte(PTR(FDataLng + index))^ else
      Raise EBitBuffer.CreateFmt
      (ERR_BitBuffer_InvalidByteIndex,[FDataLen-1,index]);
    end else
    Raise EBitBuffer.Create(ERR_BitBuffer_BitBufferEmpty);
  end;

  Procedure TBitBuffer.SetByte(Const Index:NativeInt;Const Value:Byte);
  Begin
    If FData<>NIL then
    Begin
      If (index>=0) and (Index<FDataLen) then
      PByte(PTR(FDataLng + index))^:=Value else
      Raise EBitBuffer.CreateFmt
      (ERR_BitBuffer_InvalidByteIndex,[FDataLen-1,index]);
    end else
    Raise EBitBuffer.Create(ERR_BitBuffer_BitBufferEmpty);
  end;

  Procedure TBitBuffer.SetBitRange(First,Last:NativeUInt;
            Const Bitvalue:Boolean);
  var
    x:        NativeUInt;
    FLongs:   NativeInt;
    FSingles: NativeInt;
    FCount:   NativeUInt;

    Procedure QSwap(Var Primary,Secondary:NativeUInt);
    var
      FTemp: NativeUInt;
    Begin
      FTemp:=Primary;
      Primary:=Secondary;
      Secondary:=FTemp;
    end;

  Function  QDiff(Const Primary,Secondary:NativeUInt;
            Const Exclusive:Boolean=False):NativeUInt;
  Begin
    If Primary<>Secondary then
    Begin
      If Primary>Secondary then
      result:=Primary-Secondary else
      result:=Secondary-Primary;

      If Exclusive then
      If (Primary<1) or (Secondary<1) then
      inc(result);

      If result<0 then
      result:=abs(result);
    end else
    result:=0;
  end;

  Begin
    If FData<>NIL then
    Begin
      If  First<FBitsMax then
      Begin
        If Last<FBitsMax then
        Begin
          (* Conditional swap *)
          If First>Last then
          QSwap(First,Last);

          (* get totals, take ZERO into account *)
          FCount:=QDiff(First,Last,True);

          (* use refactoring & loop reduction *)
          FLongs:=NativeInt(FCount shr 3);

          x:=First;

          while FLongs>0 do
          Begin
            SetBit(x,Bitvalue);inc(x);
            SetBit(x,Bitvalue);inc(x);
            SetBit(x,Bitvalue);inc(x);
            SetBit(x,Bitvalue);inc(x);
            SetBit(x,Bitvalue);inc(x);
            SetBit(x,Bitvalue);inc(x);
            SetBit(x,Bitvalue);inc(x);
            SetBit(x,Bitvalue);inc(x);
            dec(FLongs);
          end;

          (* process singles *)
          FSingles:=NativeInt(FCount mod 8);
          while FSingles>0 do
          Begin
            SetBit(x,Bitvalue);inc(x);
            dec(FSingles);
          end;

        end else
        Begin
          If First=Last then
          SetBit(First,True) else
          Raise EBitBuffer.CreateFmt
          (ERR_BitBuffer_InvalidBitIndex,[FBitsMax,Last]);
        end;
      end else
      Raise EBitBuffer.CreateFmt(ERR_BitBuffer_InvalidBitIndex,
      [FBitsMax,First]);
    end else
    Raise EBitBuffer.Create(ERR_BitBuffer_BitBufferEmpty);
  end;

  Procedure TBitBuffer.SetBits(Const Value:TBitOffsetArray;
            Const BitValue:Boolean);
  var
    x:      NativeInt;
    FCount: NativeInt;
  Begin
    If FData<>NIL then
    Begin
      FCount:=length(Value);
      If FCount>0 then
      Begin
        for x:=low(Value) to High(Value) do
        SetBit(Value[x],BitValue);
      end;
    end else
    Raise EBitBuffer.Create(ERR_BitBuffer_BitBufferEmpty);
  end;

  Function  TBitBuffer.FindIdleBit(var Value:NativeUInt;
            Const FromStart:Boolean=False):Boolean;
  var
    FOffset:  NativeUInt;
    FBit:     NativeUInt;
    FAddr:    PByte;
    x:        NativeInt;
  Begin
    result:=FData<>NIL;
    if result then
    Begin
      (* Initialize *)
      FAddr:=FData;
      FOffset:=0;

      If FromStart then
      FReadyByte:=0;

      If FReadyByte<1 then
      Begin
        (* find byte with idle bit *)
        While FOffset<NativeUInt(FDataLen) do
        Begin
          If BitsSetInByte(FAddr^)=8 then
          Begin
            inc(FOffset);
            inc(FAddr);
          end else
          break;
        end;
      end else
      inc(FOffset,FReadyByte);

      (* Last byte exhausted? *)
      result:=FOffset<NativeUInt(FDataLen);
      If result then
      Begin
        (* convert to bit index *)
        FBit:=FOffset shl 3;

        (* scan byte with free bit in it *)
        for x:=1 to 8 do
        Begin
          If not GetBit(FBit) then
          Begin
            Value:=FBit;

            (* more than 1 bit available in byte? remember that *)
            FAddr:=FData;
            inc(FAddr,FOffset);
            If BitsSetInByte(FAddr^)>7 then
            FReadyByte:=0 else
            FReadyByte:=FOffset;

            Break;
          end;
          inc(FBit);
        end;
      end;

    end;
  end;

  Function TBitBuffer.GetBit(Const Index:NativeUInt):Boolean;
  begin
    If FData<>NIL then
    Begin
      If index<FBitsMax then
      Begin
        FAddr:=PTR(FDataLng + NativeInt(index shr 3));
        BitOfs:=Index mod 8;
        Result:=(FAddr^ and (1 shl (BitOfs mod 8))) <> 0;
      end else
      Raise EBitBuffer.CreateFmt
      (ERR_BitBuffer_InvalidBitIndex,[Count-1,index]);
    end else
    Raise EBitBuffer.Create(ERR_BitBuffer_BitBufferEmpty);
  end;

  Procedure TBitBuffer.SetBit(Const Index:NativeUInt;Const Value:Boolean);
  begin
    If FData<>NIL then
    Begin
      If index<FBitsMax then
      Begin
        FByte:=PByte(FDataLng + NativeInt(index shr 3))^;
        BitOfs:=Index mod 8;

        If Value then
        Begin
          (* set bit if not already set *)
          If (FByte and (1 shl (BitOfs mod 8)))=0 then
          Begin
            FByte:=(FByte or (1 shl (BitOfs mod 8)));
            PByte(FDataLng + NativeInt(index shr 3))^:=FByte;

            (* if this was the "ready" byte, then
               reset it to zero *)
            If (Index shr 3=FReadyByte)
            and (FReadyByte>0) then
            Begin
              If BitsSetInByte(FByte)>7 then
              FReadyByte:=0;
            end;

          end;
        end else
        Begin
          (* clear bit if not already clear *)
          If (FByte and (1 shl (BitOfs mod 8)))<>0 then
          Begin
            FByte:=(FByte and not (1 shl (BitOfs mod 8)));
            PByte(FDataLng + NativeInt(index shr 3))^:=FByte;

            (* remember this byte pos *)
            FReadyByte:=Index shr 3;
          end;
        end;

      end else
      Raise EBitBuffer.CreateFmt
      (ERR_BitBuffer_InvalidBitIndex,[Count-1,index]);
    end else
    Raise EBitBuffer.Create(ERR_BitBuffer_BitBufferEmpty);
  end;

  Procedure TBitBuffer.Allocate(MaxBits:NativeUInt);
  Begin
    (* release buffer if not empty *)
    If FData<>NIL then
    Release;

    If Maxbits>0 then
    Begin
      (* Allocate new buffer *)
      try
        FReadyByte:=0;
        FDataLen:=BytesOf(maxBits);
        FData:=AllocMem(FDataLen);
        FDataLng:=NativeUInt(FData);
        FBitsMax:=BitsOf(FDataLen);
      except
        on e: exception do
        Begin
          FData:=NIL;
          FDataLen:=0;
          FBitsMax:=0;
          FDataLng:=0;
          Raise;
        end;
      end;

    end;
  end;

  Procedure TBitBuffer.Release;
  Begin
    If FData<>NIL then
    Begin
      try
        FreeMem(FData);
      finally
        FReadyByte:=0;
        FData:=NIL;
        FDataLen:=0;
        FBitsMax:=0;
        FDataLng:=0;
      end;
    end;
  end;

  Procedure TBitBuffer.Zero;
  Begin
    If FData<>NIL then
    Fillchar(FData^,FDataLen,byte(0)) else
    Raise EBitBuffer.Create(ERR_BitBuffer_BitBufferEmpty);
  end;

  end.