tpsystools_4.04/source/StBits.pas

// Upgraded to Delphi 2009: Sebastian Zierer

(* ***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (the "License"); you may not use this file except in compliance with
 * the License. You may obtain a copy of the License at
 * http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS IS" basis,
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 * for the specific language governing rights and limitations under the
 * License.
 *
 * The Original Code is TurboPower SysTools
 *
 * The Initial Developer of the Original Code is
 * TurboPower Software
 *
 * Portions created by the Initial Developer are Copyright (C) 1996-2002
 * the Initial Developer. All Rights Reserved.
 *
 * Contributor(s):
 *
 * ***** END LICENSE BLOCK ***** *)

{*********************************************************}
{* SysTools: StBits.pas 4.04                             *}
{*********************************************************}
{* SysTools: Bit set class                               *}
{*********************************************************}

{$I StDefine.inc}

{Notes:
  CopyBits, OrBits, AndBits, and SubBits require that the parameter B have
  the same Max value as the current object, or an exception is generated.

  Use the inherited Count property to get the number of bits currently set.

  TStBits takes advantage of the suballocator whenever the bit set is
  small enough to allow it. Changing the Max property of the class
  allocates a new data area, copies the old data into it, and then
  deallocates the old data area.

  Supports up to 2**34 bits, if they will fit into memory.

  When Windows 3.1 is used, it requires enhanced mode operation.
}

unit StBits;

interface

uses
  Windows, Classes, SysUtils,
  
  StBase, StConst;

type
  TStBits = class;

  TBitIterateFunc =
    function(Container : TStBits; N : LongInt; OtherData : Pointer) : Boolean;

  TStBits = class(TStContainer)
  {.Z+}
  protected
    {property instance variables}
    FMax : LongInt;          {highest element number}

    {private instance variables}
    btBlockSize : LongInt;   {bytes allocated to data area}
    btBits : PByte;          {pointer to data area}

    {undocumented protected methods}
    procedure btSetMax(Max : LongInt);
    procedure btRecount;
    function btByte(I : LongInt) : PByte;

  {.Z-}
  public
    constructor Create(Max : LongInt); virtual;
      {-Initialize an empty bitset with highest element number Max}
    destructor Destroy; override;
      {-Free a bitset}

    procedure LoadFromStream(S : TStream); override;
      {-Read a bitset from a stream}
    procedure StoreToStream(S : TStream); override;
      {-Write a bitset to a stream}

    procedure Clear; override;
      {-Clear all bits in set but leave instance intact}

    procedure CopyBits(B : TStBits);
      {-Copy all bits in B to this bitset}
    procedure SetBits;
      {-Set all bits}
    procedure InvertBits;
      {-Invert all bits}
    procedure OrBits(B : TStBits);
      {-Or the specified bitset into this one (create the union)}
    procedure AndBits(B : TStBits);
      {-And the specified bitset with this one (create the intersection)}
    procedure SubBits(B : TStBits);
      {-Subtract the specified bitset from this one (create the difference)}

    procedure SetBit(N : LongInt);
      {-Set bit N}
    procedure ClearBit(N : LongInt);
      {-Clear bit N}
    procedure ToggleBit(N : LongInt);
      {-Toggle bit N}
    procedure ControlBit(N : LongInt; State : Boolean);
      {-Set or clear bit N according to State}
    function BitIsSet(N : LongInt) : Boolean;
      {-Return True if bit N is set}

    function FirstSet : LongInt;
      {-Return the index of the first set bit, -1 if none}
    function LastSet : LongInt;
      {-Return the index of the last set bit, -1 if none}
    function FirstClear : LongInt;
      {-Return the index of the first clear bit, -1 if none}
    function LastClear : LongInt;
      {-Return the index of the last clear bit, -1 if none}
    function NextSet(N : LongInt) : LongInt;
      {-Return the index of the next set bit after N, -1 if none}
    function PrevSet(N : LongInt) : LongInt;
      {-Return the index of the previous set bit after N, -1 if none}
    function NextClear(N : LongInt) : LongInt;
      {-Return the index of the next set bit after N, -1 if none}
    function PrevClear(N : LongInt) : LongInt;
      {-Return the index of the previous set bit after N, -1 if none}

    function Iterate(Action : TBitIterateFunc;
                     UseSetBits, Up : Boolean;
                     OtherData : Pointer) : LongInt;
      {-Call Action for all the matching bits, returning the last bit visited}
    function IterateFrom(Action : TBitIterateFunc;
                         UseSetBits, Up : Boolean;
                         OtherData : Pointer;
                         From : LongInt) : LongInt;
      {-Call Action for all the matching bits starting with bit From}

    property Max : LongInt
      {-Read or write the maximum element count in the bitset}
      read FMax
      write btSetMax;

    property Items[N : LongInt] : Boolean
      {-Read or write Nth bit in set}
      read BitIsSet
      write ControlBit;
      default;
  end;


{======================================================================}


implementation

{$IFDEF ThreadSafe}
var
  ClassCritSect : TRTLCriticalSection;
{$ENDIF}

procedure EnterClassCS;
begin
{$IFDEF ThreadSafe}
  EnterCriticalSection(ClassCritSect);
{$ENDIF}
end;

procedure LeaveClassCS;
begin
{$IFDEF ThreadSafe}
  LeaveCriticalSection(ClassCritSect);
{$ENDIF}
end;

function MinLong(A, B : LongInt) : LongInt;
begin
  if A < B then
    Result := A
  else
    Result := B;
end;

function MaxLong(A, B : LongInt) : LongInt;
begin
  if A > B then
    Result := A
  else
    Result := B;
end;

{----------------------------------------------------------------------}

procedure TStBits.AndBits(B : TStBits);
var
  I : LongInt;
  P : PByte;
begin
{$IFDEF ThreadSafe}
  EnterClassCS;
  EnterCS;
  B.EnterCS;
  try
{$ENDIF}
    if (not Assigned(B)) or (B.Max <> FMax) then
      RaiseContainerError(stscBadType);
    for I := 0 to btBlockSize-1 do begin
      P := btByte(I);
      P^ := P^ and B.btByte(I)^;
    end;
    btRecount;
{$IFDEF ThreadSafe}
  finally
    B.LeaveCS;
    LeaveCS;
    LeaveClassCS;
  end;
{$ENDIF}
end;

function TStBits.BitIsSet(N : LongInt) : Boolean;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
{$IFOPT R+}
    if (N < 0) or (N > FMax) then
      RaiseContainerError(stscBadIndex);
{$ENDIF}
    Result := (btByte(N shr 3)^ and (1 shl (Byte(N) and 7)) <> 0);
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStBits.btByte(I : LongInt) : PByte;
begin
  Result := PByte(PAnsiChar(btBits)+I);
end;

procedure TStBits.btRecount;
const
  {number of bits set in every possible byte}
  BitCount : array[Byte] of Byte = (
  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);
var
  N : LongInt;
  P : PByte;
  B : Byte;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    {Clear unused bits in last byte}
    B := Byte(FMax) and 7;
    if B < 7 then begin
      P := btByte(btBlockSize-1);
      P^ := P^ and ((1 shl (B+1))-1);
    end;

    {Add up the bits in each byte}
    FCount := 0;
    for N := 0 to btBlockSize-1 do
      inc(FCount, BitCount[btByte(N)^]);
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStBits.btSetMax(Max : LongInt);
var
  BlockSize, OldBlockSize, OldMax : LongInt;
  OldBits : PByte;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    {Validate new size}
    if Max < 0 then
      RaiseContainerError(stscBadSize);
    BlockSize := (Max+8) div 8;

    {Save old size settings}
    OldBlockSize := btBlockSize;
    OldMax := FMax;

    {Assign new size settings}
    FMax := Max;
    btBlockSize := BlockSize;

    if BlockSize <> OldBlockSize then begin
      {Get new data area and transfer data}
      OldBits := btBits;
      try
        HugeGetMem(Pointer(btBits), btBlockSize);
      except
        btBlockSize := OldBlockSize;
        btBits := OldBits;
        FMax := OldMax;
        raise;
      end;

      if OldBlockSize < btBlockSize then begin
        HugeFillChar(btByte(OldBlockSize)^, btBlockSize-OldBlockSize, 0);
        BlockSize := OldBlockSize;
      end else
        BlockSize := btBlockSize;
      HugeMove(OldBits^, btBits^, BlockSize);

      {Free old data area}
      HugeFreeMem(Pointer(OldBits), OldBlockSize);
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStBits.Clear;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    HugeFillChar(btBits^, btBlockSize, 0);
    FCount := 0;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStBits.ClearBit(N : LongInt);
var
  P : PByte;
  M : Byte;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
{$IFOPT R+}
    if (N < 0) or (N > FMax) then
      RaiseContainerError(stscBadIndex);
{$ENDIF}
    P := btByte(N shr 3);
    M := 1 shl (Byte(N) and 7);
    if (P^ and M) <> 0 then begin
      P^ := P^ and not M;
      dec(FCount);
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStBits.ControlBit(N : LongInt; State : Boolean);
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if State then
      SetBit(N)
    else
      ClearBit(N);
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStBits.CopyBits(B : TStBits);
begin
{$IFDEF ThreadSafe}
  EnterClassCS;
  EnterCS;
  B.EnterCS;
  try
{$ENDIF}
    if (not Assigned(B)) or (B.Max <> FMax) then
      RaiseContainerError(stscBadType);

    HugeMove(B.btBits^, btBits^, btBlockSize);
    FCount := B.FCount;
{$IFDEF ThreadSafe}
  finally
    B.LeaveCS;
    LeaveCS;
    LeaveClassCS;
  end;
{$ENDIF}
end;

constructor TStBits.Create(Max : LongInt);
begin
  {Validate size}
  if Max < 0 then
    RaiseContainerError(stscBadSize);

  CreateContainer(TStNode, 0);

  FMax := Max;
  btBlockSize := (Max+8) div 8;
  HugeGetMem(Pointer(btBits), btBlockSize);
  Clear;
end;

destructor TStBits.Destroy;
begin
  if Assigned(btBits) then
    HugeFreeMem(Pointer(btBits), btBlockSize);

  {Prevent calling Clear}
  IncNodeProtection;
  inherited Destroy;
end;

function StopImmediately(Container : TStBits; N : LongInt;
                         OtherData : Pointer) : Boolean; far;
  {-Iterator function used to stop after first found bit}
begin
  Result := False;
end;

function TStBits.FirstClear : LongInt;
begin
  Result := IterateFrom(StopImmediately, False, True, nil, 0);
end;

function TStBits.FirstSet : LongInt;
begin
  Result := IterateFrom(StopImmediately, True, True, nil, 0);
end;

procedure TStBits.InvertBits;
var
  I : LongInt;
  P : PByte;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    for I := 0 to btBlockSize-1 do begin
      P := btByte(I);
      P^ := not P^;
    end;
    FCount := FMax-FCount+1;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStBits.Iterate(Action : TBitIterateFunc;
                         UseSetBits, Up : Boolean;
                         OtherData : Pointer) : LongInt;
begin
  if Up then
    Result := IterateFrom(Action, UseSetBits, True, OtherData, 0)
  else
    Result := IterateFrom(Action, UseSetBits, False, OtherData, FMax);
end;

function TStBits.IterateFrom(Action : TBitIterateFunc;
                             UseSetBits, Up : Boolean;
                             OtherData : Pointer;
                             From : LongInt) : LongInt;
var
  I, N, F : LongInt;
  O : ShortInt;
  B, TB : Byte;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if UseSetBits then
      TB := 0
    else
      TB := $FF;

    if Up then begin
      {do the first possibly-partial byte}
      N := MaxLong(From, 0);
      F := MinLong(btBlockSize-1, N shr 3);
      O := ShortInt(N) and 7;
      B := btByte(F)^;

      while (N <= FMax) and (O <= ShortInt(7)) do begin
        if not (UseSetBits xor ((B and (1 shl O)) <> 0)) then
          if not Action(Self, N, OtherData) then begin
            Result := N;
            Exit;
          end;
        inc(O);
        inc(N);
      end;

      {do the rest of the bytes}
      for I := F+1 to btBlockSize-1 do begin
        B := btByte(I)^;
        if B <> TB then begin
          {byte has bits of interest}
          O := 0;
          while (N <= FMax) and (O < ShortInt(8)) do begin
            if not (UseSetBits xor ((B and (1 shl O)) <> 0)) then
              if not Action(Self, N, OtherData) then begin
                Result := N;
                Exit;
              end;
            inc(O);
            inc(N);
          end;
        end else
          inc(N, 8);
      end;

    end else begin
      {do the last possibly-partial byte}
      N := MinLong(From, FMax);
      F := MaxLong(N, 0) shr 3;
      O := ShortInt(N) and 7;
      B := btByte(F)^;

      while (N >= 0) and (O >= ShortInt(0)) do begin
        if not (UseSetBits xor ((B and (1 shl O)) <> 0)) then
          if not Action(Self, N, OtherData) then begin
            Result := N;
            Exit;
          end;
        dec(O);
        dec(N);
      end;

      {do the rest of the bytes}
      for I := F-1 downto 0 do begin
        B := btByte(I)^;
        if B <> TB then begin
          {byte has bits of interest}
          O := 7;
          while (N >= 0) and (O >= ShortInt(0)) do begin
            if not (UseSetBits xor ((B and (1 shl O)) <> 0)) then
              if not Action(Self, N, OtherData) then begin
                Result := N;
                Exit;
              end;
            dec(O);
            dec(N);
          end;
        end else
          dec(N, 8);
      end;
    end;

    {Iterated all bits}
    Result := -1;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStBits.LastClear : LongInt;
begin
  Result := IterateFrom(StopImmediately, False, False, nil, FMax);
end;

function TStBits.LastSet : LongInt;
begin
  Result := IterateFrom(StopImmediately, True, False, nil, FMax);
end;

function TStBits.NextClear(N : LongInt) : LongInt;
begin
  Result := IterateFrom(StopImmediately, False, True, nil, N+1);
end;

function TStBits.NextSet(N : LongInt) : LongInt;
begin
  Result := IterateFrom(StopImmediately, True, True, nil, N+1);
end;

procedure TStBits.OrBits(B : TStBits);
var
  I : LongInt;
  P : PByte;
begin
{$IFDEF ThreadSafe}
  EnterClassCS;
  EnterCS;
  B.EnterCS;
  try
{$ENDIF}
    if (not Assigned(B)) or (B.Max <> FMax) then
      RaiseContainerError(stscBadType);
    for I := 0 to btBlockSize-1 do begin
      P := btByte(I);
      P^ := P^ or B.btByte(I)^;
    end;
    btRecount;
{$IFDEF ThreadSafe}
  finally
    B.LeaveCS;
    LeaveCS;
    LeaveClassCS;
  end;
{$ENDIF}
end;

function TStBits.PrevClear(N : LongInt) : LongInt;
begin
  Result := IterateFrom(StopImmediately, False, False, nil, N-1);
end;

function TStBits.PrevSet(N : LongInt) : LongInt;
begin
  Result := IterateFrom(StopImmediately, True, False, nil, N-1);
end;

procedure TStBits.SetBit(N : LongInt);
var
  P : PByte;
  M : Byte;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
{$IFOPT R+}
    if (N < 0) or (N > FMax) then
      RaiseContainerError(stscBadIndex);
{$ENDIF}
    P := btByte(N shr 3);
    M := 1 shl (Byte(N) and 7);
    if (P^ and M) = 0 then begin
      P^ := P^ or M;
      inc(FCount);
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStBits.SetBits;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    HugeFillChar(btBits^, btBlockSize, $FF);
    FCount := FMax+1;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStBits.SubBits(B : TStBits);
var
  I : LongInt;
  P : PByte;
begin
{$IFDEF ThreadSafe}
  EnterClassCS;
  EnterCS;
  B.EnterCS;
  try
{$ENDIF}
    if (not Assigned(B)) or (B.Max <> FMax) then
      RaiseContainerError(stscBadType);
    for I := 0 to btBlockSize-1 do begin
      P := btByte(I);
      P^ := P^ and not B.btByte(I)^;
    end;
    btRecount;
{$IFDEF ThreadSafe}
  finally
    B.LeaveCS;
    LeaveCS;
    LeaveClassCS;
  end;
{$ENDIF}
end;

procedure TStBits.ToggleBit(N : LongInt);
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if BitIsSet(N) then
      ClearBit(N)
    else
      SetBit(N);
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStBits.LoadFromStream(S : TStream);
var
  Reader : TReader;
  StreamedClass : TPersistentClass;
  StreamedClassName : String;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    Clear;
    Reader := TReader.Create(S, 1024);
    try
      with Reader do
        begin
          StreamedClassName := ReadString;
          StreamedClass := GetClass(StreamedClassName);
          if (StreamedClass = nil) then
            RaiseContainerErrorFmt(stscUnknownClass, [StreamedClassName]);
          if (not IsOrInheritsFrom(StreamedClass, Self.ClassType)) or
              (not IsOrInheritsFrom(TStBits, StreamedClass)) then
            RaiseContainerError(stscWrongClass);
          Max := ReadInteger;
          FCount := ReadInteger;
          Read(btBits^, btBlockSize);
        end;
    finally
      Reader.Free;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStBits.StoreToStream(S : TStream);
var
  Writer : TWriter;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    Writer := TWriter.Create(S, 1024);
    try
      with Writer do
        begin
          WriteString(Self.ClassName);
          WriteInteger(Max);
          WriteInteger(Count);
          Write(btBits^, btBlockSize);
        end;
    finally
      Writer.Free;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

{$IFDEF ThreadSafe}
initialization
  Windows.InitializeCriticalSection(ClassCritSect);
finalization
  Windows.DeleteCriticalSection(ClassCritSect);
{$ENDIF}
end.
1	// Upgraded to Delphi 2009: Sebastian Zierer
2
3	(* *** BEGIN LICENSE BLOCK ***
4	* Version: MPL 1.1
5	*
6	* The contents of this file are subject to the Mozilla Public License Version
7	* 1.1 (the "License"); you may not use this file except in compliance with
8	* the License. You may obtain a copy of the License at
9	* http://www.mozilla.org/MPL/
10	*
11	* Software distributed under the License is distributed on an "AS IS" basis,
12	* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
13	* for the specific language governing rights and limitations under the
14	* License.
15	*
16	* The Original Code is TurboPower SysTools
17	*
18	* The Initial Developer of the Original Code is
19	* TurboPower Software
20	*
21	* Portions created by the Initial Developer are Copyright (C) 1996-2002
22	* the Initial Developer. All Rights Reserved.
23	*
24	* Contributor(s):
25	*
26	* *** END LICENSE BLOCK *** *)
27
28	{*********************************************************}
29	{* SysTools: StBits.pas 4.04 *}
30	{*********************************************************}
31	{* SysTools: Bit set class *}
32	{*********************************************************}
33
34	{$I StDefine.inc}
35
36	{Notes:
37	CopyBits, OrBits, AndBits, and SubBits require that the parameter B have
38	the same Max value as the current object, or an exception is generated.
39
40	Use the inherited Count property to get the number of bits currently set.
41
42	TStBits takes advantage of the suballocator whenever the bit set is
43	small enough to allow it. Changing the Max property of the class
44	allocates a new data area, copies the old data into it, and then
45	deallocates the old data area.
46
47	Supports up to 2**34 bits, if they will fit into memory.
48
49	When Windows 3.1 is used, it requires enhanced mode operation.
50	}
51
52	unit StBits;
53
54	interface
55
56	uses
57	Windows, Classes, SysUtils,
58
59	StBase, StConst;
60
61	type
62	TStBits = class;
63
64	TBitIterateFunc =
65	function(Container : TStBits; N : LongInt; OtherData : Pointer) : Boolean;
66
67	TStBits = class(TStContainer)
68	{.Z+}
69	protected
70	{property instance variables}
71	FMax : LongInt; {highest element number}
72
73	{private instance variables}
74	btBlockSize : LongInt; {bytes allocated to data area}
75	btBits : PByte; {pointer to data area}
76
77	{undocumented protected methods}
78	procedure btSetMax(Max : LongInt);
79	procedure btRecount;
80	function btByte(I : LongInt) : PByte;
81
82	{.Z-}
83	public
84	constructor Create(Max : LongInt); virtual;
85	{-Initialize an empty bitset with highest element number Max}
86	destructor Destroy; override;
87	{-Free a bitset}
88
89	procedure LoadFromStream(S : TStream); override;
90	{-Read a bitset from a stream}
91	procedure StoreToStream(S : TStream); override;
92	{-Write a bitset to a stream}
93
94	procedure Clear; override;
95	{-Clear all bits in set but leave instance intact}
96
97	procedure CopyBits(B : TStBits);
98	{-Copy all bits in B to this bitset}
99	procedure SetBits;
100	{-Set all bits}
101	procedure InvertBits;
102	{-Invert all bits}
103	procedure OrBits(B : TStBits);
104	{-Or the specified bitset into this one (create the union)}
105	procedure AndBits(B : TStBits);
106	{-And the specified bitset with this one (create the intersection)}
107	procedure SubBits(B : TStBits);
108	{-Subtract the specified bitset from this one (create the difference)}
109
110	procedure SetBit(N : LongInt);
111	{-Set bit N}
112	procedure ClearBit(N : LongInt);
113	{-Clear bit N}
114	procedure ToggleBit(N : LongInt);
115	{-Toggle bit N}
116	procedure ControlBit(N : LongInt; State : Boolean);
117	{-Set or clear bit N according to State}
118	function BitIsSet(N : LongInt) : Boolean;
119	{-Return True if bit N is set}
120
121	function FirstSet : LongInt;
122	{-Return the index of the first set bit, -1 if none}
123	function LastSet : LongInt;
124	{-Return the index of the last set bit, -1 if none}
125	function FirstClear : LongInt;
126	{-Return the index of the first clear bit, -1 if none}
127	function LastClear : LongInt;
128	{-Return the index of the last clear bit, -1 if none}
129	function NextSet(N : LongInt) : LongInt;
130	{-Return the index of the next set bit after N, -1 if none}
131	function PrevSet(N : LongInt) : LongInt;
132	{-Return the index of the previous set bit after N, -1 if none}
133	function NextClear(N : LongInt) : LongInt;
134	{-Return the index of the next set bit after N, -1 if none}
135	function PrevClear(N : LongInt) : LongInt;
136	{-Return the index of the previous set bit after N, -1 if none}
137
138	function Iterate(Action : TBitIterateFunc;
139	UseSetBits, Up : Boolean;
140	OtherData : Pointer) : LongInt;
141	{-Call Action for all the matching bits, returning the last bit visited}
142	function IterateFrom(Action : TBitIterateFunc;
143	UseSetBits, Up : Boolean;
144	OtherData : Pointer;
145	From : LongInt) : LongInt;
146	{-Call Action for all the matching bits starting with bit From}
147
148	property Max : LongInt
149	{-Read or write the maximum element count in the bitset}
150	read FMax
151	write btSetMax;
152
153	property Items[N : LongInt] : Boolean
154	{-Read or write Nth bit in set}
155	read BitIsSet
156	write ControlBit;
157	default;
158	end;
159
160
161	{======================================================================}
162
163
164	implementation
165
166	{$IFDEF ThreadSafe}
167	var
168	ClassCritSect : TRTLCriticalSection;
169	{$ENDIF}
170
171	procedure EnterClassCS;
172	begin
173	{$IFDEF ThreadSafe}
174	EnterCriticalSection(ClassCritSect);
175	{$ENDIF}
176	end;
177
178	procedure LeaveClassCS;
179	begin
180	{$IFDEF ThreadSafe}
181	LeaveCriticalSection(ClassCritSect);
182	{$ENDIF}
183	end;
184
185	function MinLong(A, B : LongInt) : LongInt;
186	begin
187	if A < B then
188	Result := A
189	else
190	Result := B;
191	end;
192
193	function MaxLong(A, B : LongInt) : LongInt;
194	begin
195	if A > B then
196	Result := A
197	else
198	Result := B;
199	end;
200
201	{----------------------------------------------------------------------}
202
203	procedure TStBits.AndBits(B : TStBits);
204	var
205	I : LongInt;
206	P : PByte;
207	begin
208	{$IFDEF ThreadSafe}
209	EnterClassCS;
210	EnterCS;
211	B.EnterCS;
212	try
213	{$ENDIF}
214	if (not Assigned(B)) or (B.Max <> FMax) then
215	RaiseContainerError(stscBadType);
216	for I := 0 to btBlockSize-1 do begin
217	P := btByte(I);
218	P^ := P^ and B.btByte(I)^;
219	end;
220	btRecount;
221	{$IFDEF ThreadSafe}
222	finally
223	B.LeaveCS;
224	LeaveCS;
225	LeaveClassCS;
226	end;
227	{$ENDIF}
228	end;
229
230	function TStBits.BitIsSet(N : LongInt) : Boolean;
231	begin
232	{$IFDEF ThreadSafe}
233	EnterCS;
234	try
235	{$ENDIF}
236	{$IFOPT R+}
237	if (N < 0) or (N > FMax) then
238	RaiseContainerError(stscBadIndex);
239	{$ENDIF}
240	Result := (btByte(N shr 3)^ and (1 shl (Byte(N) and 7)) <> 0);
241	{$IFDEF ThreadSafe}
242	finally
243	LeaveCS;
244	end;
245	{$ENDIF}
246	end;
247
248	function TStBits.btByte(I : LongInt) : PByte;
249	begin
250	Result := PByte(PAnsiChar(btBits)+I);
251	end;
252
253	procedure TStBits.btRecount;
254	const
255	{number of bits set in every possible byte}
256	BitCount : array[Byte] of Byte = (
257	0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4,
258	1, 2, 2, 3, 2, 3, 3, 4, 2, 3, 3, 4, 3, 4, 4, 5,
259	1, 2, 2, 3, 2, 3, 3, 4, 2, 3, 3, 4, 3, 4, 4, 5,
260	2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
261	1, 2, 2, 3, 2, 3, 3, 4, 2, 3, 3, 4, 3, 4, 4, 5,
262	2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
263	2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
264	3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7,
265	1, 2, 2, 3, 2, 3, 3, 4, 2, 3, 3, 4, 3, 4, 4, 5,
266	2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
267	2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
268	3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7,
269	2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
270	3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7,
271	3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7,
272	4, 5, 5, 6, 5, 6, 6, 7, 5, 6, 6, 7, 6, 7, 7, 8);
273	var
274	N : LongInt;
275	P : PByte;
276	B : Byte;
277	begin
278	{$IFDEF ThreadSafe}
279	EnterCS;
280	try
281	{$ENDIF}
282	{Clear unused bits in last byte}
283	B := Byte(FMax) and 7;
284	if B < 7 then begin
285	P := btByte(btBlockSize-1);
286	P^ := P^ and ((1 shl (B+1))-1);
287	end;
288
289	{Add up the bits in each byte}
290	FCount := 0;
291	for N := 0 to btBlockSize-1 do
292	inc(FCount, BitCount[btByte(N)^]);
293	{$IFDEF ThreadSafe}
294	finally
295	LeaveCS;
296	end;
297	{$ENDIF}
298	end;
299
300	procedure TStBits.btSetMax(Max : LongInt);
301	var
302	BlockSize, OldBlockSize, OldMax : LongInt;
303	OldBits : PByte;
304	begin
305	{$IFDEF ThreadSafe}
306	EnterCS;
307	try
308	{$ENDIF}
309	{Validate new size}
310	if Max < 0 then
311	RaiseContainerError(stscBadSize);
312	BlockSize := (Max+8) div 8;
313
314	{Save old size settings}
315	OldBlockSize := btBlockSize;
316	OldMax := FMax;
317
318	{Assign new size settings}
319	FMax := Max;
320	btBlockSize := BlockSize;
321
322	if BlockSize <> OldBlockSize then begin
323	{Get new data area and transfer data}
324	OldBits := btBits;
325	try
326	HugeGetMem(Pointer(btBits), btBlockSize);
327	except
328	btBlockSize := OldBlockSize;
329	btBits := OldBits;
330	FMax := OldMax;
331	raise;
332	end;
333
334	if OldBlockSize < btBlockSize then begin
335	HugeFillChar(btByte(OldBlockSize)^, btBlockSize-OldBlockSize, 0);
336	BlockSize := OldBlockSize;
337	end else
338	BlockSize := btBlockSize;
339	HugeMove(OldBits^, btBits^, BlockSize);
340
341	{Free old data area}
342	HugeFreeMem(Pointer(OldBits), OldBlockSize);
343	end;
344	{$IFDEF ThreadSafe}
345	finally
346	LeaveCS;
347	end;
348	{$ENDIF}
349	end;
350
351	procedure TStBits.Clear;
352	begin
353	{$IFDEF ThreadSafe}
354	EnterCS;
355	try
356	{$ENDIF}
357	HugeFillChar(btBits^, btBlockSize, 0);
358	FCount := 0;
359	{$IFDEF ThreadSafe}
360	finally
361	LeaveCS;
362	end;
363	{$ENDIF}
364	end;
365
366	procedure TStBits.ClearBit(N : LongInt);
367	var
368	P : PByte;
369	M : Byte;
370	begin
371	{$IFDEF ThreadSafe}
372	EnterCS;
373	try
374	{$ENDIF}
375	{$IFOPT R+}
376	if (N < 0) or (N > FMax) then
377	RaiseContainerError(stscBadIndex);
378	{$ENDIF}
379	P := btByte(N shr 3);
380	M := 1 shl (Byte(N) and 7);
381	if (P^ and M) <> 0 then begin
382	P^ := P^ and not M;
383	dec(FCount);
384	end;
385	{$IFDEF ThreadSafe}
386	finally
387	LeaveCS;
388	end;
389	{$ENDIF}
390	end;
391
392	procedure TStBits.ControlBit(N : LongInt; State : Boolean);
393	begin
394	{$IFDEF ThreadSafe}
395	EnterCS;
396	try
397	{$ENDIF}
398	if State then
399	SetBit(N)
400	else
401	ClearBit(N);
402	{$IFDEF ThreadSafe}
403	finally
404	LeaveCS;
405	end;
406	{$ENDIF}
407	end;
408
409	procedure TStBits.CopyBits(B : TStBits);
410	begin
411	{$IFDEF ThreadSafe}
412	EnterClassCS;
413	EnterCS;
414	B.EnterCS;
415	try
416	{$ENDIF}
417	if (not Assigned(B)) or (B.Max <> FMax) then
418	RaiseContainerError(stscBadType);
419
420	HugeMove(B.btBits^, btBits^, btBlockSize);
421	FCount := B.FCount;
422	{$IFDEF ThreadSafe}
423	finally
424	B.LeaveCS;
425	LeaveCS;
426	LeaveClassCS;
427	end;
428	{$ENDIF}
429	end;
430
431	constructor TStBits.Create(Max : LongInt);
432	begin
433	{Validate size}
434	if Max < 0 then
435	RaiseContainerError(stscBadSize);
436
437	CreateContainer(TStNode, 0);
438
439	FMax := Max;
440	btBlockSize := (Max+8) div 8;
441	HugeGetMem(Pointer(btBits), btBlockSize);
442	Clear;
443	end;
444
445	destructor TStBits.Destroy;
446	begin
447	if Assigned(btBits) then
448	HugeFreeMem(Pointer(btBits), btBlockSize);
449
450	{Prevent calling Clear}
451	IncNodeProtection;
452	inherited Destroy;
453	end;
454
455	function StopImmediately(Container : TStBits; N : LongInt;
456	OtherData : Pointer) : Boolean; far;
457	{-Iterator function used to stop after first found bit}
458	begin
459	Result := False;
460	end;
461
462	function TStBits.FirstClear : LongInt;
463	begin
464	Result := IterateFrom(StopImmediately, False, True, nil, 0);
465	end;
466
467	function TStBits.FirstSet : LongInt;
468	begin
469	Result := IterateFrom(StopImmediately, True, True, nil, 0);
470	end;
471
472	procedure TStBits.InvertBits;
473	var
474	I : LongInt;
475	P : PByte;
476	begin
477	{$IFDEF ThreadSafe}
478	EnterCS;
479	try
480	{$ENDIF}
481	for I := 0 to btBlockSize-1 do begin
482	P := btByte(I);
483	P^ := not P^;
484	end;
485	FCount := FMax-FCount+1;
486	{$IFDEF ThreadSafe}
487	finally
488	LeaveCS;
489	end;
490	{$ENDIF}
491	end;
492
493	function TStBits.Iterate(Action : TBitIterateFunc;
494	UseSetBits, Up : Boolean;
495	OtherData : Pointer) : LongInt;
496	begin
497	if Up then
498	Result := IterateFrom(Action, UseSetBits, True, OtherData, 0)
499	else
500	Result := IterateFrom(Action, UseSetBits, False, OtherData, FMax);
501	end;
502
503	function TStBits.IterateFrom(Action : TBitIterateFunc;
504	UseSetBits, Up : Boolean;
505	OtherData : Pointer;
506	From : LongInt) : LongInt;
507	var
508	I, N, F : LongInt;
509	O : ShortInt;
510	B, TB : Byte;
511	begin
512	{$IFDEF ThreadSafe}
513	EnterCS;
514	try
515	{$ENDIF}
516	if UseSetBits then
517	TB := 0
518	else
519	TB := $FF;
520
521	if Up then begin
522	{do the first possibly-partial byte}
523	N := MaxLong(From, 0);
524	F := MinLong(btBlockSize-1, N shr 3);
525	O := ShortInt(N) and 7;
526	B := btByte(F)^;
527
528	while (N <= FMax) and (O <= ShortInt(7)) do begin
529	if not (UseSetBits xor ((B and (1 shl O)) <> 0)) then
530	if not Action(Self, N, OtherData) then begin
531	Result := N;
532	Exit;
533	end;
534	inc(O);
535	inc(N);
536	end;
537
538	{do the rest of the bytes}
539	for I := F+1 to btBlockSize-1 do begin
540	B := btByte(I)^;
541	if B <> TB then begin
542	{byte has bits of interest}
543	O := 0;
544	while (N <= FMax) and (O < ShortInt(8)) do begin
545	if not (UseSetBits xor ((B and (1 shl O)) <> 0)) then
546	if not Action(Self, N, OtherData) then begin
547	Result := N;
548	Exit;
549	end;
550	inc(O);
551	inc(N);
552	end;
553	end else
554	inc(N, 8);
555	end;
556
557	end else begin
558	{do the last possibly-partial byte}
559	N := MinLong(From, FMax);
560	F := MaxLong(N, 0) shr 3;
561	O := ShortInt(N) and 7;
562	B := btByte(F)^;
563
564	while (N >= 0) and (O >= ShortInt(0)) do begin
565	if not (UseSetBits xor ((B and (1 shl O)) <> 0)) then
566	if not Action(Self, N, OtherData) then begin
567	Result := N;
568	Exit;
569	end;
570	dec(O);
571	dec(N);
572	end;
573
574	{do the rest of the bytes}
575	for I := F-1 downto 0 do begin
576	B := btByte(I)^;
577	if B <> TB then begin
578	{byte has bits of interest}
579	O := 7;
580	while (N >= 0) and (O >= ShortInt(0)) do begin
581	if not (UseSetBits xor ((B and (1 shl O)) <> 0)) then
582	if not Action(Self, N, OtherData) then begin
583	Result := N;
584	Exit;
585	end;
586	dec(O);
587	dec(N);
588	end;
589	end else
590	dec(N, 8);
591	end;
592	end;
593
594	{Iterated all bits}
595	Result := -1;
596	{$IFDEF ThreadSafe}
597	finally
598	LeaveCS;
599	end;
600	{$ENDIF}
601	end;
602
603	function TStBits.LastClear : LongInt;
604	begin
605	Result := IterateFrom(StopImmediately, False, False, nil, FMax);
606	end;
607
608	function TStBits.LastSet : LongInt;
609	begin
610	Result := IterateFrom(StopImmediately, True, False, nil, FMax);
611	end;
612
613	function TStBits.NextClear(N : LongInt) : LongInt;
614	begin
615	Result := IterateFrom(StopImmediately, False, True, nil, N+1);
616	end;
617
618	function TStBits.NextSet(N : LongInt) : LongInt;
619	begin
620	Result := IterateFrom(StopImmediately, True, True, nil, N+1);
621	end;
622
623	procedure TStBits.OrBits(B : TStBits);
624	var
625	I : LongInt;
626	P : PByte;
627	begin
628	{$IFDEF ThreadSafe}
629	EnterClassCS;
630	EnterCS;
631	B.EnterCS;
632	try
633	{$ENDIF}
634	if (not Assigned(B)) or (B.Max <> FMax) then
635	RaiseContainerError(stscBadType);
636	for I := 0 to btBlockSize-1 do begin
637	P := btByte(I);
638	P^ := P^ or B.btByte(I)^;
639	end;
640	btRecount;
641	{$IFDEF ThreadSafe}
642	finally
643	B.LeaveCS;
644	LeaveCS;
645	LeaveClassCS;
646	end;
647	{$ENDIF}
648	end;
649
650	function TStBits.PrevClear(N : LongInt) : LongInt;
651	begin
652	Result := IterateFrom(StopImmediately, False, False, nil, N-1);
653	end;
654
655	function TStBits.PrevSet(N : LongInt) : LongInt;
656	begin
657	Result := IterateFrom(StopImmediately, True, False, nil, N-1);
658	end;
659
660	procedure TStBits.SetBit(N : LongInt);
661	var
662	P : PByte;
663	M : Byte;
664	begin
665	{$IFDEF ThreadSafe}
666	EnterCS;
667	try
668	{$ENDIF}
669	{$IFOPT R+}
670	if (N < 0) or (N > FMax) then
671	RaiseContainerError(stscBadIndex);
672	{$ENDIF}
673	P := btByte(N shr 3);
674	M := 1 shl (Byte(N) and 7);
675	if (P^ and M) = 0 then begin
676	P^ := P^ or M;
677	inc(FCount);
678	end;
679	{$IFDEF ThreadSafe}
680	finally
681	LeaveCS;
682	end;
683	{$ENDIF}
684	end;
685
686	procedure TStBits.SetBits;
687	begin
688	{$IFDEF ThreadSafe}
689	EnterCS;
690	try
691	{$ENDIF}
692	HugeFillChar(btBits^, btBlockSize, $FF);
693	FCount := FMax+1;
694	{$IFDEF ThreadSafe}
695	finally
696	LeaveCS;
697	end;
698	{$ENDIF}
699	end;
700
701	procedure TStBits.SubBits(B : TStBits);
702	var
703	I : LongInt;
704	P : PByte;
705	begin
706	{$IFDEF ThreadSafe}
707	EnterClassCS;
708	EnterCS;
709	B.EnterCS;
710	try
711	{$ENDIF}
712	if (not Assigned(B)) or (B.Max <> FMax) then
713	RaiseContainerError(stscBadType);
714	for I := 0 to btBlockSize-1 do begin
715	P := btByte(I);
716	P^ := P^ and not B.btByte(I)^;
717	end;
718	btRecount;
719	{$IFDEF ThreadSafe}
720	finally
721	B.LeaveCS;
722	LeaveCS;
723	LeaveClassCS;
724	end;
725	{$ENDIF}
726	end;
727
728	procedure TStBits.ToggleBit(N : LongInt);
729	begin
730	{$IFDEF ThreadSafe}
731	EnterCS;
732	try
733	{$ENDIF}
734	if BitIsSet(N) then
735	ClearBit(N)
736	else
737	SetBit(N);
738	{$IFDEF ThreadSafe}
739	finally
740	LeaveCS;
741	end;
742	{$ENDIF}
743	end;
744
745	procedure TStBits.LoadFromStream(S : TStream);
746	var
747	Reader : TReader;
748	StreamedClass : TPersistentClass;
749	StreamedClassName : String;
750	begin
751	{$IFDEF ThreadSafe}
752	EnterCS;
753	try
754	{$ENDIF}
755	Clear;
756	Reader := TReader.Create(S, 1024);
757	try
758	with Reader do
759	begin
760	StreamedClassName := ReadString;
761	StreamedClass := GetClass(StreamedClassName);
762	if (StreamedClass = nil) then
763	RaiseContainerErrorFmt(stscUnknownClass, [StreamedClassName]);
764	if (not IsOrInheritsFrom(StreamedClass, Self.ClassType)) or
765	(not IsOrInheritsFrom(TStBits, StreamedClass)) then
766	RaiseContainerError(stscWrongClass);
767	Max := ReadInteger;
768	FCount := ReadInteger;
769	Read(btBits^, btBlockSize);
770	end;
771	finally
772	Reader.Free;
773	end;
774	{$IFDEF ThreadSafe}
775	finally
776	LeaveCS;
777	end;
778	{$ENDIF}
779	end;
780
781	procedure TStBits.StoreToStream(S : TStream);
782	var
783	Writer : TWriter;
784	begin
785	{$IFDEF ThreadSafe}
786	EnterCS;
787	try
788	{$ENDIF}
789	Writer := TWriter.Create(S, 1024);
790	try
791	with Writer do
792	begin
793	WriteString(Self.ClassName);
794	WriteInteger(Max);
795	WriteInteger(Count);
796	Write(btBits^, btBlockSize);
797	end;
798	finally
799	Writer.Free;
800	end;
801	{$IFDEF ThreadSafe}
802	finally
803	LeaveCS;
804	end;
805	{$ENDIF}
806	end;
807
808	{$IFDEF ThreadSafe}
809	initialization
810	Windows.InitializeCriticalSection(ClassCritSect);
811	finalization
812	Windows.DeleteCriticalSection(ClassCritSect);
813	{$ENDIF}
814	end.