Annotation of OpenXM_contrib/PHC/Ada/Root_Counts/Product/degree_sets_tables.adb, Revision 1.1
1.1 ! maekawa 1: with Standard_Natural_Vectors; use Standard_Natural_Vectors;
! 2: with Set_Structure;
! 3:
! 4: package body Degree_Sets_Tables is
! 5:
! 6: -- AUXILIAIRIES :
! 7:
! 8: function Number_of_Sets return natural is
! 9:
! 10: res : natural := 0;
! 11:
! 12: begin
! 13: for i in 1..Set_Structure.Dimension loop
! 14: res := res + Set_Structure.Number_of_Sets(i);
! 15: end loop;
! 16: return res;
! 17: end Number_of_Sets;
! 18:
! 19: function Create_Set ( n,i,j : natural ) return Set is
! 20:
! 21: -- DESCRIPTION :
! 22: -- Returns the jth set for the ith equation in the set structure.
! 23:
! 24: res : Set := Create(n);
! 25:
! 26: begin
! 27: for k in 1..n loop
! 28: if Set_Structure.Is_In(i,j,k)
! 29: then Add(res,k);
! 30: end if;
! 31: end loop;
! 32: return res;
! 33: end Create_Set;
! 34:
! 35: function Is_In ( ase : Array_of_Sets; s : Set ) return boolean is
! 36:
! 37: -- DESCRIPTION :
! 38: -- Returns true if the given set s occurs in the array of sets.
! 39:
! 40: begin
! 41: for i in ase'range loop
! 42: if Is_Equal(ase(i),s)
! 43: then return true;
! 44: end if;
! 45: end loop;
! 46: return false;
! 47: end Is_In;
! 48:
! 49: function Different_Sets return Array_of_Sets is
! 50:
! 51: -- DESCRIPTION :
! 52: -- Returns the array of different sets of the set structure.
! 53:
! 54: n : constant natural := Set_Structure.Dimension;
! 55: nbs : constant natural := Number_Of_Sets;
! 56: res : Array_of_Sets(1..nbs);
! 57: cnt : natural := 0;
! 58:
! 59: begin
! 60: for i in 1..n loop
! 61: for j in 1..Set_Structure.Number_of_Sets(i) loop
! 62: declare
! 63: s : Set := Create_Set(n,i,j);
! 64: begin
! 65: if not Is_In(res(1..cnt),s)
! 66: then cnt := cnt + 1;
! 67: res(cnt) := s;
! 68: else Clear(s);
! 69: end if;
! 70: end;
! 71: end loop;
! 72: end loop;
! 73: return res(1..cnt);
! 74: end Different_Sets;
! 75:
! 76: function Index ( ase : Array_of_Sets; s : Set ) return natural is
! 77:
! 78: -- DESCRIPTION :
! 79: -- Returns the index of the given set in the array of sets.
! 80: -- If the set does not occur in ase, then ase'last+1 will be returned.
! 81:
! 82: begin
! 83: for i in ase'range loop
! 84: if Is_Equal(ase(i),s)
! 85: then return i;
! 86: end if;
! 87: end loop;
! 88: return ase'last+1;
! 89: end Index;
! 90:
! 91: -- CONSTRUCTOR :
! 92:
! 93: function Create return Degree_Sets_Table is
! 94:
! 95: n : constant natural := Set_Structure.Dimension;
! 96: ase : constant Array_of_Sets := Different_Sets;
! 97: res : Degree_Sets_Table(n,ase'length);
! 98:
! 99: begin
! 100: res.s := ase;
! 101: for i in res.a'range(1) loop
! 102: for j in res.a'range(2) loop
! 103: res.a(i,j) := 0;
! 104: end loop;
! 105: end loop;
! 106: for i in 1..n loop
! 107: for j in 1..Set_Structure.Number_of_Sets(i) loop
! 108: declare
! 109: s : Set := Create_Set(n,i,j);
! 110: k : natural := Index(res.s,s);
! 111: begin
! 112: res.a(i,k) := res.a(i,k) + 1;
! 113: Clear(s);
! 114: end;
! 115: end loop;
! 116: end loop;
! 117: return res;
! 118: end Create;
! 119:
! 120: -- PERMANENT COMPUTATIONS :
! 121:
! 122: function Union_Acceptable ( s : Array_of_Sets ) return boolean is
! 123:
! 124: -- DESCRIPTION :
! 125: -- Returns true if the union of all sets in s contains at least
! 126: -- as many elements as the length of s, returns false otherwise.
! 127:
! 128: res : boolean;
! 129: uni : Set := Create(s(s'first));
! 130:
! 131: begin
! 132: for i in s'first+1..s'last loop
! 133: Union(uni,s(i));
! 134: end loop;
! 135: res := (Extent_Of(uni) >= s'length);
! 136: Clear(uni);
! 137: return res;
! 138: end Union_Acceptable;
! 139:
! 140: function Partial_Acceptable ( s : Array_of_Sets; k : natural )
! 141: return boolean is
! 142:
! 143: -- DESCRIPTION :
! 144: -- Checks whether any union of k sets out of s(s'first)..s(s'last-1),
! 145: -- together with s(s'last) forms an acceptable tuple.
! 146:
! 147: res : boolean := true;
! 148: accu : Set := Create(s(s'last));
! 149:
! 150: function Partial_Acceptable ( s : Array_of_Sets; k,l,start : natural;
! 151: uni : Set ) return boolean is
! 152:
! 153: -- DESCRIPTION : recursive enumeration of all candidates.
! 154:
! 155: -- ON ENTRY :
! 156: -- l the number of sets still to choose;
! 157: -- start choose out of s(start..s'last-1);
! 158: -- uni partial union.
! 159:
! 160: res : boolean := true;
! 161:
! 162: begin
! 163: if l = 0
! 164: then res := (Extent_Of(uni) >= k+1);
! 165: else for ll in start..(s'last-l) loop
! 166: declare
! 167: newuni : Set := Create(uni);
! 168: begin
! 169: Union(newuni,s(ll));
! 170: res := Partial_Acceptable(s,k,l-1,ll+1,newuni);
! 171: exit when not res;
! 172: Clear(newuni);
! 173: end;
! 174: end loop;
! 175: end if;
! 176: -- if not res
! 177: -- then put("Not acceptable with "); put(uni); put(" for k = ");
! 178: -- put(k,1); new_line;
! 179: -- end if;
! 180: return res;
! 181: end Partial_Acceptable;
! 182:
! 183: begin
! 184: res := Partial_Acceptable(s,k,k,s'first,accu);
! 185: Clear(accu);
! 186: return res;
! 187: end Partial_Acceptable;
! 188:
! 189: function Acceptable ( s : Array_of_Sets ) return boolean is
! 190:
! 191: -- DESCRIPTION :
! 192: -- Returns true if the array of sets is an acceptable tuple.
! 193: -- The first s'last-1 sets form already an acceptable tuple and
! 194: -- are ordered according to the cardinality of their union with
! 195: -- the last set, from low to high.
! 196:
! 197: extlast : constant natural := Extent_Of(s(s'last));
! 198: res : boolean;
! 199:
! 200: begin
! 201: -- put_line("The array of sets "); put(s); new_line;
! 202: if not Union_Acceptable(s)
! 203: then res := false;
! 204: else res := true;
! 205: for k in extlast..s'last-2 loop
! 206: res := Partial_Acceptable(s,k);
! 207: exit when not res;
! 208: end loop;
! 209: end if;
! 210: -- if res
! 211: -- then put_line("is an acceptable tuple.");
! 212: -- else put_line("is not an acceptable tuple.");
! 213: -- end if;
! 214: return res;
! 215: end Acceptable;
! 216:
! 217: function Acceptable ( s : Array_of_Sets; v : Vector; i : natural )
! 218: return boolean is
! 219: -- DESCRIPTION :
! 220: -- Returns true if the choice of sets { s(v(j)) }, j=1,2,..,i, is
! 221: -- acceptable. The first i-1 sets form already an acceptable tuple.
! 222:
! 223: begin
! 224: if (i = v'first) or (Extent_Of(s(v(i))) = i)
! 225: then return true;
! 226: else declare
! 227: sv,osv : Array_of_Sets(1..i);
! 228: min,minind,extset : natural;
! 229: u : Set;
! 230: begin
! 231: for j in 1..i loop -- create tuple of sets
! 232: sv(j) := s(v(j));
! 233: end loop;
! 234: for j in 1..(i-1) loop -- order tuple of sets
! 235: u := Union(sv(j),sv(i));
! 236: min := Extent_Of(u); Clear(u);
! 237: minind := j;
! 238: for k in j+1..(i-1) loop
! 239: u := Union(sv(k),sv(i));
! 240: extset := Extent_Of(u); Clear(u);
! 241: if extset < min
! 242: then min := extset; minind := k;
! 243: end if;
! 244: end loop;
! 245: osv(j) := sv(minind);
! 246: if j /= minind
! 247: then sv(minind) := sv(j);
! 248: end if;
! 249: end loop;
! 250: osv(i) := sv(i);
! 251: return Acceptable(osv);
! 252: end;
! 253: end if;
! 254: end Acceptable;
! 255:
! 256: function Permanent ( a : matrix; s : Array_of_Sets; v : Vector;
! 257: i,n : natural ) return natural is
! 258:
! 259: -- ALGORITHM : Row expansion without memory.
! 260:
! 261: begin
! 262: if i = n+1
! 263: then return 1;
! 264: else declare
! 265: res : natural := 0;
! 266: vv : Vector(v'range) := v;
! 267: begin
! 268: for j in a'range(2) loop
! 269: if a(i,j) /= 0
! 270: then vv(i) := j;
! 271: if Acceptable(s,vv,i)
! 272: then res := res + a(i,j)*Permanent(a,s,vv,i+1,n);
! 273: end if;
! 274: end if;
! 275: end loop;
! 276: return res;
! 277: end;
! 278: end if;
! 279: end Permanent;
! 280:
! 281: function Permanent ( dst : Degree_Sets_Table ) return natural is
! 282:
! 283: v : Vector(1..dst.n) := (1..dst.n => 0);
! 284:
! 285: begin
! 286: return Permanent(dst.a,dst.s,v,1,dst.n);
! 287: end Permanent;
! 288:
! 289: -- DESTRUCTOR :
! 290:
! 291: procedure Clear ( ase : in out Array_of_Sets ) is
! 292: begin
! 293: for i in ase'range loop
! 294: Clear(ase(i));
! 295: end loop;
! 296: end Clear;
! 297:
! 298: procedure Clear ( dst : in out Degree_Sets_Table ) is
! 299: begin
! 300: Clear(dst.s);
! 301: end Clear;
! 302:
! 303: end Degree_Sets_Tables;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to degree_sets_tables.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