Annotation of OpenXM_contrib/PHC/Ada/Root_Counts/Product/set_structure.adb, Revision 1.1
1.1 ! maekawa 1: with unchecked_deallocation;
! 2: with text_io,integer_io; use text_io,integer_io;
! 3: with Symbol_Table,Symbol_Table_io; use Symbol_Table;
! 4: with Standard_Integer_Vectors;
! 5: with Generate_Unions;
! 6:
! 7: package body Set_Structure is
! 8:
! 9: -- DATASTRUCTURES :
! 10:
! 11: type set is array (natural range <>) of boolean;
! 12: type link_to_set is access set;
! 13: procedure free is new unchecked_deallocation(set,link_to_set);
! 14:
! 15: type set_equations is array (natural range <>) of link_to_set;
! 16: type link_to_set_equations is access set_equations;
! 17: procedure free is new unchecked_deallocation(set_equations,
! 18: link_to_set_equations);
! 19:
! 20: type set_system is array (natural range <>) of link_to_set_equations;
! 21: type link_to_set_system is access set_system;
! 22: procedure free is new unchecked_deallocation(set_system,
! 23: link_to_set_system);
! 24:
! 25: -- INTERNAL DATA :
! 26:
! 27: n : natural := 0; -- the number of unknowns and equations
! 28:
! 29: ls : link_to_set_system := null;
! 30:
! 31: -- CONSTRUCTORS :
! 32:
! 33: procedure Init ( ns : in Standard_Natural_Vectors.Vector ) is
! 34: begin
! 35: n := ns'length;
! 36: ls := new set_system(1..n);
! 37: for i in ls'range loop
! 38: ls(i) := new set_equations(1..ns(i));
! 39: for j in ls(i)'range loop
! 40: ls(i).all(j) := new set'(1..n => false);
! 41: end loop;
! 42: end loop;
! 43: end Init;
! 44:
! 45: procedure Add ( i,j,k : in natural ) is
! 46: s : set renames ls(i).all(j).all;
! 47: begin
! 48: s(k) := true;
! 49: end Add;
! 50:
! 51: procedure Remove (i,j,k : in natural) is
! 52: s : set renames ls(i).all(j).all;
! 53: begin
! 54: s(k) := false;
! 55: end Remove;
! 56:
! 57: -- SELECTORS :
! 58:
! 59: function Empty return boolean is
! 60: begin
! 61: return (ls = null);
! 62: end Empty;
! 63:
! 64: function Dimension return natural is
! 65: begin
! 66: return n;
! 67: end Dimension;
! 68:
! 69: function Number_of_Sets (i : natural) return natural is
! 70: begin
! 71: return ls(i)'last;
! 72: end Number_of_Sets;
! 73:
! 74: function Is_In (i,j,k : natural) return boolean is
! 75: s : set renames ls(i).all(j).all;
! 76: begin
! 77: return s(k);
! 78: end Is_In;
! 79:
! 80: -- COMPUTING THE UPPER BOUND :
! 81:
! 82: function Extent_Of (s : in set) return natural is
! 83:
! 84: -- DESCRIPTION : return the number of elements in s
! 85:
! 86: sum : natural := 0;
! 87: begin
! 88: for i in s'range loop
! 89: if s(i)
! 90: then sum := sum + 1;
! 91: end if;
! 92: end loop;
! 93: return sum;
! 94: end Extent_Of;
! 95:
! 96: procedure Union (s : in set; u : in out set) is
! 97:
! 98: -- DESCRIPTION : u = u U s
! 99:
! 100: begin
! 101: for i in s'range loop
! 102: if s(i)
! 103: then u(i) := true;
! 104: end if;
! 105: end loop;
! 106: end Union;
! 107:
! 108: function acceptable (lset_eq : link_to_set_equations;
! 109: k,n : natural; lset : link_to_set) return boolean is
! 110:
! 111: type arr is array (integer range <>) of boolean;
! 112: accep : boolean := true;
! 113:
! 114: procedure check (a : in arr; continue : out boolean) is
! 115: u : set(lset'range);
! 116: begin
! 117: u := lset.all;
! 118: for i in a'range loop
! 119: if a(i)
! 120: then Union(lset_eq(i).all,u);
! 121: end if;
! 122: end loop;
! 123: accep := ( Extent_Of(u) >= k+1 );
! 124: continue := accep;
! 125: u := (u'range => false);
! 126: end check;
! 127:
! 128: procedure gen is new Generate_Unions(arr,check);
! 129:
! 130: begin
! 131: gen(k,1,n); -- generates all possible unions of k sets
! 132: -- out of the range 1..n
! 133: return accep;
! 134: end acceptable;
! 135:
! 136: function acceptable (lset_eq : link_to_set_equations;
! 137: n : natural; lset : link_to_set) return boolean is
! 138:
! 139: -- DESCRIPTION :
! 140: -- if acceptable(lset_eq,n)
! 141: -- then verify if acceptable(lset_eq + lset,n+1)
! 142:
! 143: begin
! 144: for k in 1..n loop
! 145: if not acceptable(lset_eq,k,n,lset)
! 146: then return false;
! 147: end if;
! 148: end loop;
! 149: return true;
! 150: end acceptable;
! 151:
! 152: procedure Compute (i,n,sum : in natural; res : in out natural;
! 153: lset_eq : in out link_to_set_equations) is
! 154: begin
! 155: if i > n
! 156: then res := res + sum;
! 157: else -- Pick out a set and check if it is allowed :
! 158: for j in ls(i)'range loop
! 159: if acceptable(lset_eq,i-1,ls(i).all(j))
! 160: then lset_eq(i) := ls(i).all(j);
! 161: Compute(i+1,n,sum,res,lset_eq);
! 162: end if;
! 163: end loop;
! 164: end if;
! 165: end Compute;
! 166:
! 167: function B return natural is
! 168: res : natural := 0;
! 169: lset_eq : link_to_set_equations := new set_equations(1..n);
! 170: begin
! 171: for i in lset_eq'range loop
! 172: lset_eq(i) := new set'(1..n => false);
! 173: end loop;
! 174: Compute(1,n,1,res,lset_eq);
! 175: return res;
! 176: end B;
! 177:
! 178: procedure Compute (i,n,sum : in natural; res : in out natural;
! 179: lset_eq : in out link_to_set_equations;
! 180: pos : in out Standard_Integer_Vectors.Vector;
! 181: first,last : in out List) is
! 182: begin
! 183: if i > n
! 184: then res := res + sum;
! 185: Append(first,last,pos);
! 186: else -- Pick out a set and check if it is allowed :
! 187: for j in ls(i)'range loop
! 188: pos(i) := j;
! 189: if acceptable(lset_eq,i-1,ls(i).all(j))
! 190: then lset_eq(i) := ls(i).all(j);
! 191: Compute(i+1,n,sum,res,lset_eq,pos,first,last);
! 192: end if;
! 193: end loop;
! 194: end if;
! 195: end Compute;
! 196:
! 197: procedure B (bn : out natural; l : in out List) is
! 198: res : natural := 0;
! 199: lset_eq : link_to_set_equations := new set_equations(1..n);
! 200: pos : Standard_Integer_Vectors.Vector(1..n) := (1..n => 1);
! 201: last : List;
! 202: begin
! 203: for i in lset_eq'range loop
! 204: lset_eq(i) := new set'(1..n => false);
! 205: end loop;
! 206: Compute(1,n,1,res,lset_eq,pos,l,last);
! 207: bn := res;
! 208: end B;
! 209:
! 210: -- DESTRUCTOR :
! 211:
! 212: procedure Clear is
! 213: begin
! 214: for i in ls'range loop
! 215: for j in ls(i)'range loop
! 216: free(ls(i).all(j));
! 217: end loop;
! 218: free(ls(i));
! 219: end loop;
! 220: free(ls);
! 221: n := 0; ls := null;
! 222: end Clear;
! 223:
! 224: end Set_Structure;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to set_structure.adb CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib / PHC / Ada / Root_Counts / Product