{
Copyright (C) 1991-99 Free Software Foundation, Inc.

Authors: Frank Heckenbach <frank@pascal.gnu.de>
         Jukka Virtanen <jtv@hut.fi>

Set operations
Not used currently because the routines are inlined by the compiler.

The sets are stored as bitmaps consisting of TSetElement's.
No type and range checking is done here. It's left to the compiler.
Results are silently truncated.

This file is part of GNU Pascal Library. The GNU Pascal Library is free
software; you can redistribute it and/or modify it under the terms of
the GNU Library General Public License as published by the Free Software
Foundation; either version 2 of the License, or (at your option) any
later version.

The GNU Pascal Library 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.  See the GNU
Library General Public License for more details.

You should have received a copy of the GNU Library General Public
License along with the GNU Pascal Library; see the file COPYING.LIB.  If
not, write to the Free Software Foundation, Inc., 675 Mass Ave,
Cambridge, MA 02139, USA.
}

unit Sets;

interface

uses GPC;

type
  TSetElement = MedCard;
  PSet = ^TSet;
  TSet = array [0 .. MaxVarSize] of TSetElement;

function  SetCard (SetA : PSet; LowA, HighA : Integer) : SizeType;                                                                             asmname '_p_set_card';
function  SetEqual (SetA : PSet; LowA, HighA : Integer; SetB : PSet; LowB, HighB : Integer) : Boolean;                                         asmname '_p_set_equal';
function  SetLessEqual (SetA : PSet; LowA, HighA : Integer; SetB : PSet; LowB, HighB : Integer) : Boolean;                                     asmname '_p_set_le';
function  SetIn (SetA : PSet; LowA, HighA, Element : Integer) : Boolean;                                                                       asmname '_p_set_in';
procedure SetCopy (SetA : PSet; LowA, HighA : Integer; SetR : PSet; LowR, HighR : Integer);                                                    asmname '_p_set_copy';
procedure SetIntersection (SetA : PSet; LowA, HighA : Integer; SetB : PSet; LowB, HighB : Integer; SetR : PSet; LowR, HighR : Integer);        asmname '_p_set_intersection';
procedure SetUnion (SetA : PSet; LowA, HighA : Integer; SetB : PSet; LowB, HighB : Integer; SetR : PSet; LowR, HighR : Integer);               asmname '_p_set_union';
procedure SetDifference (SetA : PSet; LowA, HighA : Integer; SetB : PSet; LowB, HighB : Integer; SetR : PSet; LowR, HighR : Integer);          asmname '_p_set_diff';
procedure SetSymmetricDifference (SetA : PSet; LowA, HighA : Integer; SetB : PSet; LowB, HighB : Integer; SetR : PSet; LowR, HighR : Integer); asmname '_p_set_symdiff';
procedure SetInclude (SetR : PSet; LowR, HighR, Element : Integer);                                                                            asmname '_p_set_include';
procedure SetExclude (SetR : PSet; LowR, HighR, Element : Integer);                                                                            asmname '_p_set_exclude';
procedure SetSetRange (SetA : PSet; LowA, HighA, RangeFirst, RangeLast : Integer);                                                             asmname '_p_set_set_range';

implementation

{$if 0} { Not used currently because the routines are inlined by the compiler }

{$B-,I-} (*@@$R-*)

const
  BitsPerElement = BitSizeOf (TSetElement);

  AllBitsSet = not TSetElement (0);

type
  TempType = packed array [1 .. BitSizeOf (Integer)] of 0 .. BitsPerElement - 1;

const
  Log2BitsPerElement = BitSizeOf (TempType) div BitSizeOf (Integer); {-: :-}

{ Returns the word number in which the n'th member is in when starting from 0 }
(*@@maur3.pas inline*) function WordNumberAbs (n : Integer) : SizeType;
begin
  WordNumberAbs := n shr Log2BitsPerElement
end;

{ Returns the word number from start of set in which the n'th member is in }
(*@@inline*) function WordNumber (n, aLow : Integer) : SizeType;
begin
   WordNumber := WordNumberAbs (n) - WordNumberAbs (aLow)
end;

{ Returns the number of words in a set }
(*@@inline*) function NumWords (aLow, aHigh : Integer) : SizeType;
begin
  NumWords := WordNumber (aHigh, aLow) + 1
end;

{ Returns the number of bytes in a set }
(*@@inline*) function NumBytes (aLow, aHigh : Integer) : SizeType;
begin
  NumBytes := NumWords (aLow, aHigh) * SizeOf (TSetElement)
end;

{ Returns the bit number in WordNumber in which the n'th member is }
(*@@inline*) function BitNumber (n : Integer) : Integer;
begin
  BitNumber := n and (BitsPerElement - 1)
end;

{ Return the number of words needeed to adjust set A to B }
(*@@inline*) function VectorAdjust (LowA, LowB : Integer) : SizeType;
begin
  VectorAdjust := WordNumberAbs (LowB) - WordNumberAbs (LowA)
end;

(*@@inline*) procedure ClearFirstBits (var Element : TSetElement; ClearToExcl : Integer);
begin
  Element := Element and AllBitsSet shl ClearToExcl
end;

(*@@inline*) procedure ClearLastBits (var Element : TSetElement; ClearFrom : Integer);
begin
  Element := Element and not (AllBitsSet shl ClearFrom)
end;

(*@@inline*) procedure ClearBits (var Element : TSetElement; ClearFirstToExcl, ClearLastFrom : Integer);
begin
  Element := Element and (not (AllBitsSet shl (ClearLastFrom - ClearFirstToExcl)) shl ClearFirstToExcl)
end;

procedure ClearOutside (SetA : PSet; LowA, HighA, ClearFirstToExcl, ClearLastFrom : Integer);
var ClearFirstWord, ClearLastWord, c : SizeType;
begin
  ClearFirstWord := WordNumber (ClearFirstToExcl, LowA);
  ClearLastWord := WordNumber (ClearLastFrom, LowA);
  if (ClearFirstWord < 0) or (ClearLastWord > NumWords (LowA, HighA)) or (ClearFirstToExcl >= ClearLastFrom) then Exit;
  for c := 0 to ClearFirstWord - 1 do SetA^[c] := 0; { Clear leading words }
  if ClearFirstWord = ClearLastWord
    then ClearBits (SetA^[ClearFirstWord], BitNumber (ClearFirstToExcl), BitNumber (ClearLastFrom) + 1)
    else
      begin
        ClearFirstBits (SetA^[ClearFirstWord], BitNumber (ClearFirstToExcl)); { Clear bits in the first word }
        { The words between are OK }
        ClearLastBits (SetA^[ClearLastWord], BitNumber (ClearLastFrom) + 1) { Clear bits in the last word }
      end;
  for c := ClearLastWord + 1 to WordNumber (HighA, LowA) do SetA^[c] := 0 { Clear trailing words }
end;

function SetCard (SetA : PSet; LowA, HighA : Integer) = Count : SizeType;
var
  c : SizeType;
  Element : TSetElement;
begin
  Count := 0;
  if (HighA = - 1) and (LowA = 0) then Exit; { special node empty_set_node }
  for c := 0 to NumWords (LowA, HighA) - 1 do
    begin
      Element := SetA^[c];
      if Element <> 0 then
        if Element = AllBitsSet
          then Inc (Count, BitsPerElement)
          else
            while (Element <> 0) do
              begin
                Inc (Count, Element and 1);
                Element := Element shr 1
              end
    end
end;

{ Return True if the set is empty }
(*@@inline*) function EmptySet (SetA : PSet; LowA, HighA : Integer) : Boolean;
var c : SizeType;
begin
  if (HighA = - 1) and (LowA = 0) then return True; { special node empty_set_node }
  for c := 0 to NumWords (LowA, HighA) - 1 do
    if SetA^[c] <> 0 then return False;
  EmptySet := True
end;

function SetEqual (SetA : PSet; LowA, HighA : Integer; SetB : PSet; LowB, HighB : Integer) : Boolean;
var
  SetT : PSet;
  Temp : Integer;
  a, c, wa, wb : SizeType;
begin
  if EmptySet (SetA, LowA, HighA) then
    SetEqual := EmptySet (SetB, LowB, HighB)
  else if EmptySet (SetB, LowB, HighB) or (LowA > HighB) or (LowB > HighA) then
    SetEqual := False
  else
    begin
      if WordNumberAbs (LowA) > WordNumberAbs (LowB) then
        begin
          Temp := LowA;  LowA  := LowB;  LowB  := Temp;
          Temp := HighA; HighA := HighB; HighB := Temp;
          SetT := SetA;  SetA  := SetB;  SetB  := SetT
        end;
      SetEqual := False;
      a := VectorAdjust (LowA, LowB);
      wa := NumWords (LowA, HighA);
      wb := NumWords (LowB, HighB);
      for c := 0 to a - 1 do
        if SetA^[c] <> 0 then Exit;
      for c := 0 to Min (wa - a, wb) - 1 do
        if SetA^[c + a] <> SetB^[c] then Exit;
      for c := wa - a to wb - 1 do
        if SetB^[c] <> 0 then Exit;
      SetEqual := True
    end
end;

function SetLessEqual (SetA : PSet; LowA, HighA : Integer; SetB : PSet; LowB, HighB : Integer) : Boolean;
var
  SetT : PSet;
  Temp : Integer;
  a, c, wa, wb : SizeType;
  BBeforeA : Boolean;
begin
  if EmptySet (SetA, LowA, HighA) then
    SetLessEqual := True
  else if EmptySet (SetB, LowB, HighB) or (LowA > HighB) or (LowB > HighA) then
    SetLessEqual := False
  else
    begin
      BBeforeA := WordNumberAbs (LowA) > WordNumberAbs (LowB);
      if BBeforeA then
        begin
          Temp := LowA;  LowA  := LowB;  LowB  := Temp;
          Temp := HighA; HighA := HighB; HighB := Temp;
          SetT := SetA;  SetA  := SetB;  SetB  := SetT
        end;
      SetLessEqual := False;
      a := VectorAdjust (LowA, LowB);
      wa := NumWords (LowA, HighA);
      wb := NumWords (LowB, HighB);
      if BBeforeA
        then
          for c := wa - a to wb - 1 do
            if SetB^[c] <> 0 then Exit else
        else
          for c := 0 to a - 1 do
            if SetA^[c] <> 0 then Exit;
      for c := 0 to Min (wa - a, wb) - 1 do
        if SetA^[c + a] and not SetB^[c] <> 0 then Exit;
      SetLessEqual := True
    end
end;

function SetIn (SetA : PSet; LowA, HighA, Element : Integer) : Boolean;
begin
  SetIn := not EmptySet (SetA, LowA, HighA) and (Element >= LowA) and (Element <= HighA) and
    (SetA^[WordNumber (Element, LowA)] and (1 shl BitNumber (Element)) <> 0)
end;

procedure SetCopy (SetA : PSet; LowA, HighA : Integer; SetR : PSet; LowR, HighR : Integer);
var a, c, wa, wr : SizeType;
begin
  if EmptySet (SetA, LowA, HighA)
    then FillChar (SetR, NumBytes (LowR, HighR), 0)
    else
      begin
        wa := NumWords (LowA, HighA);
        wr := NumWords (LowR, HighR);
        a := VectorAdjust (LowA, LowR);
        for c := Max (0, - a) to Min (wr, wa - a) - 1 do
          SetR^[c] := SetA^[c + a];
        ClearOutside (SetR, LowR, HighR, LowA, HighA)
      end
end;

procedure SetIntersection (SetA : PSet; LowA, HighA : Integer; SetB : PSet; LowB, HighB : Integer; SetR : PSet; LowR, HighR : Integer);
var a, c, wb, wr : SizeType;
begin
  if EmptySet (SetB, LowB, HighB) or EmptySet (SetA, LowA, HighA)
    or (LowA > HighB) or (HighA < LowB)
    then FillChar (SetR, NumBytes (LowR, HighR), 0)
    else
      begin
        SetCopy (SetA, LowA, HighA, SetR, LowR, HighR);
        wb := NumWords (LowB, HighB);
        wr := NumWords (LowR, HighR);
        a := VectorAdjust (LowB, LowR);
        for c := Max (0, - a) to Min (wr, wb - a) - 1 do
          SetR^[c] := SetR^[c] and SetB^[c + a];
        ClearOutside (SetR, LowR, HighR, LowB, HighB)
      end
end;

procedure SetUnion (SetA : PSet; LowA, HighA : Integer; SetB : PSet; LowB, HighB : Integer; SetR : PSet; LowR, HighR : Integer);
var a, c, wb, wr : SizeType;
begin
  if EmptySet (SetA, LowA, HighA)
    then
      if EmptySet (SetB, LowB, HighB)
        then FillChar (SetR, NumBytes (LowR, HighR), 0)
        else SetCopy (SetB, LowB, HighB, SetR, LowR, HighR)
    else
      begin
        SetCopy (SetA, LowA, HighA, SetR, LowR, HighR);
        if EmptySet (SetB, LowB, HighB) then Exit;
        wb := NumWords (LowB, HighB);
        wr := NumWords (LowR, HighR);
        a := VectorAdjust (LowB, LowR);
        for c := Max (0, - a) to Min (wr, wb - a) - 1 do
          SetR^[c] := SetR^[c] or SetB^[c + a]
      end
end;

procedure SetDifference (SetA : PSet; LowA, HighA : Integer; SetB : PSet; LowB, HighB : Integer; SetR : PSet; LowR, HighR : Integer);
var a, c, wb, wr : SizeType;
begin
  if EmptySet (SetA, LowA, HighA)
    then FillChar (SetR, NumBytes (LowR, HighR), 0)
    else
      begin
        SetCopy (SetA, LowA, HighA, SetR, LowR, HighR);
        if EmptySet (SetB, LowB, HighB) then Exit;
        wb := NumWords (LowB, HighB);
        wr := NumWords (LowR, HighR);
        a := VectorAdjust (LowB, LowR);
        for c := Max (0, - a) to Min (wr, wb - a) - 1 do
          SetR^[c] := SetR^[c] and not SetB^[c + a]
      end
end;

procedure SetSymmetricDifference (SetA : PSet; LowA, HighA : Integer; SetB : PSet; LowB, HighB : Integer; SetR : PSet; LowR, HighR : Integer);
var a, c, wb, wr : SizeType;
begin
  if EmptySet (SetA, LowA, HighA)
    then SetCopy (SetB, LowB, HighB, SetR, LowR, HighR)
    else
      begin
        SetCopy (SetA, LowA, HighA, SetR, LowR, HighR);
        if EmptySet (SetB, LowB, HighB) then Exit;
        wb := NumWords (LowB, HighB);
        wr := NumWords (LowR, HighR);
        a := VectorAdjust (LowB, LowR);
        for c := Max (0, - a) to Min (wr, wb - a) - 1 do
          SetR^[c] := SetR^[c] xor SetB^[c + a]
      end
end;

procedure SetInclude (SetR : PSet; LowR, HighR, Element : Integer);
var n : SizeType;
begin
  if (Element < LowR) or (Element > HighR) then Exit;
  n := WordNumber(Element, LowR);
  SetR^[n] := SetR^[n] or 1 shl BitNumber(Element)
end;

procedure SetExclude (SetR : PSet; LowR, HighR, Element : Integer);
var n : SizeType;
begin
  if (Element < LowR) or (Element > HighR) then Exit;
  n := WordNumber(Element, LowR);
  SetR^[n] := SetR^[n] and not 1 shl BitNumber(Element)
end;

procedure SetSetRange (SetA : PSet; LowA, HighA, RangeFirst, RangeLast : Integer);
var RangeFirstWord, RangeLastWord, c : SizeType;
begin
  RangeFirstWord := WordNumber (RangeFirst, LowA);
  RangeLastWord := WordNumber (RangeLast + 1, LowA);
  if (RangeFirstWord < 0) or (RangeLastWord > NumWords (LowA, HighA)) or (RangeFirst > RangeLast) then Exit;
  for c := 0 to RangeFirstWord - 1 do SetA^[c] := 0; { Clear leading words }
  if RangeFirstWord = RangeLastWord
    then SetA^[RangeFirstWord] := not (AllBitsSet shl ((BitNumber (RangeLast + 1) + 1) - BitNumber (RangeFirst))) shl BitNumber (RangeFirst)
    else
      begin
        SetA^[RangeFirstWord] := AllBitsSet shl BitNumber (RangeFirst);
        SetA^[RangeLastWord]  := not (AllBitsSet shl (BitNumber (RangeLast + 1) + 1))
      end;
  for c := RangeFirstWord + 1 to RangeLastWord - 1 do SetA^[c] := 0; { Clear words in between }
  for c := RangeLastWord + 1 to WordNumber (HighA, LowA) do SetA^[c] := 0 { Clear trailing words }
end;

{$endif}

end.
