Annotation of OpenXM_contrib/PHC/Ada/Root_Counts/Product/set_structure.adb, Revision 1.1.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