Return to set_structure.adb CVS log

Up to [local] / OpenXM_contrib / PHC / Ada / Root_Counts / Product

Import the second public release of PHCpack.

OKed by Jan Verschelde.

with unchecked_deallocation;
with text_io,integer_io;                 use text_io,integer_io;
with Symbol_Table,Symbol_Table_io;       use Symbol_Table;
with Standard_Integer_Vectors;
with Generate_Unions;

package body Set_Structure is

-- DATASTRUCTURES :

  type set is array (natural range <>) of boolean;
  type link_to_set is access set;
  procedure free is new unchecked_deallocation(set,link_to_set);

  type set_equations is array (natural range <>) of link_to_set;
  type link_to_set_equations is access set_equations;
  procedure free is new unchecked_deallocation(set_equations,
					       link_to_set_equations);

  type set_system is array (natural range <>) of link_to_set_equations;
  type link_to_set_system is access set_system;
  procedure free is new unchecked_deallocation(set_system,
					       link_to_set_system);

-- INTERNAL DATA :

  n : natural := 0;  -- the number of unknowns and equations

  ls : link_to_set_system := null;

-- CONSTRUCTORS :

  procedure Init ( ns : in Standard_Natural_Vectors.Vector ) is
  begin
    n := ns'length;
    ls := new set_system(1..n);
    for i in ls'range loop
      ls(i) := new set_equations(1..ns(i));
      for j in ls(i)'range loop
	ls(i).all(j) := new set'(1..n => false);
      end loop;
    end loop;
  end Init;

  procedure Add ( i,j,k : in natural ) is
    s : set renames ls(i).all(j).all;
  begin
    s(k) := true;
  end Add;

  procedure Remove (i,j,k : in natural) is
    s : set renames ls(i).all(j).all;
  begin
    s(k) := false;
  end Remove;

-- SELECTORS :

  function Empty return boolean is
  begin
    return (ls = null);
  end Empty;

  function Dimension return natural is
  begin
    return n;
  end Dimension;

  function Number_of_Sets (i : natural) return natural is
  begin
    return ls(i)'last;
  end Number_of_Sets;

  function Is_In (i,j,k : natural) return boolean is 
    s : set renames ls(i).all(j).all;
  begin
    return s(k);
  end Is_In;

-- COMPUTING THE UPPER BOUND :

  function Extent_Of (s : in set) return natural is

   -- DESCRIPTION : return the number of elements in s

    sum : natural := 0;
  begin
    for i in s'range loop
      if s(i)
       then sum := sum + 1;
      end if;
    end loop;
    return sum;
  end Extent_Of;

  procedure Union (s : in set; u : in out set) is

   -- DESCRIPTION : u = u U s

  begin
    for i in s'range loop
      if s(i)
       then u(i) := true;
      end if;
    end loop;
  end Union;

  function acceptable (lset_eq : link_to_set_equations;
		       k,n : natural; lset : link_to_set) return boolean is

    type arr is array (integer range <>) of boolean;
    accep : boolean := true;

    procedure check (a : in arr; continue : out boolean) is
      u : set(lset'range);
    begin
      u := lset.all;
      for i in a'range loop
        if a(i)
         then Union(lset_eq(i).all,u);
        end if;
      end loop;
      accep := ( Extent_Of(u) >= k+1 );
      continue := accep;
      u := (u'range => false);
    end check;

    procedure gen is new Generate_Unions(arr,check);

  begin
    gen(k,1,n);  -- generates all possible unions of k sets
		 -- out of the range 1..n
    return accep;
  end acceptable;

  function acceptable (lset_eq : link_to_set_equations; 
		       n : natural; lset : link_to_set) return boolean is

   -- DESCRIPTION :
   --   if acceptable(lset_eq,n)
   --    then verify if acceptable(lset_eq + lset,n+1)

  begin
    for k in 1..n loop
      if not acceptable(lset_eq,k,n,lset)
       then return false;
      end if;
    end loop;
    return true;
  end acceptable;

  procedure Compute (i,n,sum : in natural; res : in out natural;
                     lset_eq : in out link_to_set_equations) is
  begin
    if i > n
     then res := res + sum;
     else -- Pick out a set and check if it is allowed :
          for j in ls(i)'range loop
            if acceptable(lset_eq,i-1,ls(i).all(j))
             then lset_eq(i) := ls(i).all(j);
                  Compute(i+1,n,sum,res,lset_eq);
            end if;
          end loop;
    end if;
  end Compute;

  function B return natural is
    res : natural := 0;
    lset_eq : link_to_set_equations := new set_equations(1..n);
  begin
    for i in lset_eq'range loop
      lset_eq(i) := new set'(1..n => false);
    end loop;
    Compute(1,n,1,res,lset_eq);
    return res;
  end B;

  procedure Compute (i,n,sum : in natural; res : in out natural;
                     lset_eq : in out link_to_set_equations;
		     pos : in out Standard_Integer_Vectors.Vector;
		     first,last : in out List) is
  begin
    if i > n
     then res := res + sum;
	  Append(first,last,pos);
     else -- Pick out a set and check if it is allowed :
          for j in ls(i)'range loop
	    pos(i) := j;
            if acceptable(lset_eq,i-1,ls(i).all(j))
             then lset_eq(i) := ls(i).all(j);
                  Compute(i+1,n,sum,res,lset_eq,pos,first,last);
            end if;
          end loop;
    end if;
  end Compute;

  procedure B (bn : out natural; l : in out List) is
    res : natural := 0;
    lset_eq : link_to_set_equations := new set_equations(1..n);
    pos : Standard_Integer_Vectors.Vector(1..n) := (1..n => 1);
    last : List;
  begin
    for i in lset_eq'range loop
      lset_eq(i) := new set'(1..n => false);
    end loop;
    Compute(1,n,1,res,lset_eq,pos,l,last);
    bn := res;
  end B;

-- DESTRUCTOR :

  procedure Clear is
  begin
    for i in ls'range loop
      for j in ls(i)'range loop
        free(ls(i).all(j));
      end loop;
      free(ls(i));
    end loop;
    free(ls);
    n := 0; ls := null;
  end Clear;

end Set_Structure;