freepascal.compiler/fcl/inc/bits.inc

{
    $Id$
    This file is part of the Free Component Library (FCL)
    Copyright (c) 1999-2000 by the Free Pascal development team

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}
{****************************************************************************}
{*                               TBits                                      *}
{****************************************************************************}

{ ************* functions to match TBits class ************* }

function TBits.getSize : longint;
begin
   result := (FSize shl BITSHIFT) - 1;
end;

procedure TBits.setSize(value : longint);
begin
   grow(value - 1);
end;

procedure TBits.SetBit(bit : longint; value : Boolean);
begin
   if value = True then
      seton(bit)
   else
      clear(bit);
end;

function TBits.OpenBit : longint;
var
   loop : longint;
   loop2 : longint;
   startIndex : longint;
begin
   result := -1; {should only occur if the whole array is set}
   for loop := 0 to FSize - 1 do
   begin
      if FBits^[loop] <> $FFFFFFFF then
      begin
         startIndex := loop * 32;
         for loop2 := startIndex to startIndex + 31 do
         begin
            if get(loop2) = False then
            begin
               result := loop2;
               break; { use this as the index to return }
            end;
         end;
         break;  {stop looking for empty bit in records }
      end;
   end;

   if result = -1 then
      if FSize < MaxBitRec then
          result := FSize * 32;  {first bit of next record}
end;

{ ******************** TBits ***************************** }

constructor TBits.Create(theSize : longint);
begin
   FSize := 0;
   FBits := nil;
   findIndex := -1;
   findState := True;  { no reason just setting it to something }
   grow(theSize);
end;

destructor TBits.Destroy;
begin
   if FBits <> nil then
      FreeMem(FBits, FSize * SizeOf(longint));
   FBits := nil;

   inherited Destroy;
end;

procedure TBits.grow(nbit : longint);
var
   newSize : longint;
   loop : longint;
begin

   if nbit >= MaxBitFlags then
      Raise EBitsError.Create('Bit index exceeds array limit');

   newSize :=  (nbit shr BITSHIFT) + 1;

   if newSize > FSize then
   begin
      ReAllocMem(FBits, newSize * SizeOf(longint));
      if FBits <> nil then
      begin
         if newSize > FSize then
            for loop := FSize to newSize - 1 do
               FBits^[loop] := 0;

         FSize := newSize;
      end;
   end;
end;

function TBits.getFSize : longint;
begin
   result := FSize;
end;

procedure TBits.seton(bit : longint);
var
   n : longint;
begin
   n := bit shr BITSHIFT;

   grow(bit);

   FBits^[n] := FBits^[n] or (longint(1) shl (bit and MASK));
end;

procedure TBits.clear(bit : longint);
var
   n : longint;
begin
   n := bit shr BITSHIFT;

   grow(bit);

   FBits^[n] := FBits^[n] and not(longint(1) shl (bit and MASK));
end;

procedure TBits.clearall;
var
   loop : longint;
begin
   for loop := 0 to FSize - 1 do
      FBits^[loop] := 0;
end;

function TBits.get(bit : longint) : Boolean;
var
   n : longint;
begin
   result := False;

   if bit >= MaxBitFlags then
      Raise EBitsError.Create('Bit index exceeds array limit');

   n := bit shr BITSHIFT;

   if (n < FSize) then
      result := (FBits^[n] and (longint(1) shl (bit and MASK))) <> 0;
end;

procedure TBits.andbits(bitset : TBits);
var
   n : longint;
   loop : longint;
begin
   if FSize < bitset.getFSize then
      n := FSize - 1
   else
      n := bitset.getFSize - 1;

   for loop := 0 to n do
      FBits^[loop] := FBits^[loop] and bitset.FBits^[loop];

   for loop := n + 1 to FSize - 1 do
      FBits^[loop] := 0;
end;

procedure TBits.notbits(bitset : TBits);
var
   n : longint;
   jj : longint;
   loop : longint;
begin
   if FSize < bitset.getFSize then
      n := FSize - 1
   else
      n := bitset.getFSize - 1;

   for loop := 0 to n do
   begin
      jj := FBits^[loop];
      FBits^[loop] := FBits^[loop] and (jj xor bitset.FBits^[loop]);
   end;
end;

procedure TBits.orbits(bitset : TBits);
var
   n : longint;
   loop : longint;
begin
   if FSize < bitset.getFSize then
      n := bitset.getFSize - 1
   else
      n := FSize - 1;

   grow(n shl BITSHIFT);

   for loop := 0 to n do
      FBits^[loop] := FBits^[loop] or bitset.FBits^[loop];
end;

procedure TBits.xorbits(bitset : TBits);
var
   n : longint;
   loop : longint;
begin
   if FSize < bitset.getFSize then
      n := bitset.getFSize - 1
   else
      n := FSize - 1;

   grow(n shl BITSHIFT);

   for loop := 0 to n do
      FBits^[loop] := FBits^[loop] xor bitset.FBits^[loop];
end;

function TBits.equals(bitset : TBits) : Boolean;
var
   n : longint;
   loop : longint;
begin
   result := False;

   if FSize < bitset.getFSize then
      n := FSize - 1
   else
      n := bitset.getFSize - 1;

   for loop := 0 to n do
      if FBits^[loop] <> bitset.FBits^[loop] then exit;

   if FSize - 1 > n then
   begin
      for loop := n to FSize - 1 do
         if FBits^[loop] <> 0 then exit;
   end
   else if bitset.getFSize - 1 > n then
      for loop := n to bitset.getFSize - 1 do
         if bitset.FBits^[loop] <> 0 then exit;

   result := True;  {passed all tests}
end;


{ us this in place of calling FindFirstBit. It sets the current }
{ index used by FindNextBit and FindPrevBit                     }

procedure TBits.SetIndex(index : longint);
begin
   findIndex := index;
end;


{ When state is set to True it looks for bits that are turned On (1) }
{ and when it is set to False it looks for bits that are turned      }
{ off (0).                                                           }

function TBits.FindFirstBit(state : boolean) : longint;
var
   loop : longint;
   loop2 : longint;
   startIndex : longint;
   compareVal : longint;
begin
   result := -1; {should only occur if none are set}

   findState := state;

   if state = False then
      compareVal := $FFFFFFFF  { looking for off bits }
   else
      compareVal := $00000000; { looking for on bits }

   for loop := 0 to FSize - 1 do
   begin
      if FBits^[loop] <> compareVal then
      begin
         startIndex := loop * 32;
         for loop2 := startIndex to startIndex + 31 do
         begin
            if get(loop2) = state then
            begin
               result := loop2;
               break; { use this as the index to return }
            end;
         end;
         break;  {stop looking for bit in records }
      end;
   end;

   findIndex := result;
end;

function TBits.FindNextBit : longint;
var
   loop : longint;
   maxVal : longint;
begin
   result := -1;  { will occur only if no other bits set to }
                  { current findState                        }

   if findIndex > -1 then { must have called FindFirstBit first }
   begin                  { or set the start index              }
      maxVal := (FSize * 32) - 1;

      for loop := findIndex + 1 to maxVal  do
      begin
         if get(loop) = findState then
         begin
            result := loop;
            break;
         end;
      end;

      findIndex := result;
   end;
end;

function TBits.FindPrevBit : longint;
var
   loop : longint;
begin
   result := -1;  { will occur only if no other bits set to }
                  { current findState                        }

   if findIndex > -1 then { must have called FindFirstBit first }
   begin                  { or set the start index              }
      for loop := findIndex - 1 downto 0  do
      begin
         if get(loop) = findState then
         begin
            result := loop;
            break;
         end;
      end;

      findIndex := result;
   end;
end;


{
  $Log$
  Revision 1.8  2000-01-07 01:24:33  peter
    * updated copyright to 2000

  Revision 1.7  2000/01/06 01:20:32  peter
    * moved out of packages/ back to topdir

  Revision 1.1  2000/01/03 19:33:06  peter
    * moved to packages dir

  Revision 1.5  1999/11/01 13:56:58  peter
    * adapted for new reallocmem

  Revision 1.4  1999/04/09 12:13:31  michael
  + Changed TBits to TbitsPlus from Michael A. Hess (renamed to Tbits)

  Revision 1.3  1998/11/04 14:36:29  michael
  Error handling always with exceptions

  Revision 1.2  1998/11/04 10:46:42  peter
    * exceptions work

  Revision 1.1  1998/05/04 14:30:11  michael
  * Split file according to Class; implemented dummys for all methods, so unit compiles.

}