![[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|
Return to degree_sets_tables.adb CVS log | Up to [local] / OpenXM_contrib / PHC / Ada / Root_Counts / Product |
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;