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	torben	2671	// 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.