Annotation of OpenXM_contrib/PHC/Ada/Root_Counts/Implift/arrays_of_lists_utilities.adb, Revision 1.1.1.1
1.1 maekawa 1: with Integer_Support_Functions; use Integer_Support_Functions;
2: with Transformations; use Transformations;
3: with Transforming_Integer_Vector_Lists; use Transforming_Integer_Vector_Lists;
4: with Lists_of_Vectors_Utilities; use Lists_of_Vectors_Utilities;
5:
6: package body Arrays_of_Lists_Utilities is
7:
8: function All_Equal ( al : Array_of_Lists ) return boolean is
9: begin
10: for i in (al'first+1)..al'last loop
11: if not Is_Equal(al(al'first),al(i))
12: then return false;
13: end if;
14: end loop;
15: return true;
16: end All_Equal;
17:
18: function Interchange2 ( al : Array_of_Lists ) return Array_of_Lists is
19:
20: res : Array_of_Lists(al'range);
21: index : integer;
22:
23: begin
24: if Length_Of(al(al'first)) <= 2
25: then res := al;
26: else index := al'first;
27: for i in al'first+1..al'last loop
28: if Length_Of(al(i)) <= 2
29: then index := i;
30: else res(i) := al(i);
31: end if;
32: exit when index > al'first;
33: end loop;
34: if index = al'first
35: then res(index) := al(index);
36: else res(index) := al(al'first);
37: res(res'first) := al(index);
38: res(index+1..res'last) := al(index+1..al'last);
39: end if;
40: end if;
41: return res;
42: end Interchange2;
43:
44: function Index2 ( al : Array_of_Lists ) return integer is
45: begin
46: for i in al'range loop
47: if Length_Of(al(i)) <= 2
48: then return i;
49: end if;
50: end loop;
51: return al'first;
52: end Index2;
53:
54: procedure Mixture ( al : in Array_of_Lists;
55: perm,mix : out Link_to_Vector ) is
56:
57: wrkper,wrkmix : vector(al'range); -- intermediate results
58: nbd : natural := 0; -- # different sets
59: ind,min : integer;
60:
61: procedure Sort ( indal,indmix : in natural ) is
62:
63: -- DESCRIPTION :
64: -- Puts all lists which are equal to al(perm(index)) together.
65:
66: -- ON ENTRY :
67: -- indal the current entry in al;
68: -- indmix the current entry in wrkmix.
69:
70: begin
71: for j in indal+1..al'last loop
72: if Is_Equal(al(wrkper(indal)),al(wrkper(j)))
73: then if j /= indal + wrkmix(indmix)
74: then declare
75: pos : natural := indal + wrkmix(indmix);
76: tmppos : natural;
77: begin
78: tmppos := wrkper(j);
79: wrkper(j) := wrkper(pos);
80: wrkper(pos) := tmppos;
81: end;
82: end if;
83: wrkmix(indmix) := wrkmix(indmix) + 1;
84: end if;
85: end loop;
86: end Sort;
87:
88: procedure Permute ( ind,nb : in natural ) is
89:
90: -- DESCRIPTION :
91: -- Changes the permutation vector such that the entry given by
92: -- the index stands in front. The number of different supports is
93: -- given by the parameter nb.
94:
95: newper : vector(wrkper'range);
96: cntnew : natural := newper'first + wrkmix(ind);
97: cntwrk : natural := wrkper'first;
98:
99: begin
100: for i in 1..nb loop
101: if i /= ind
102: then for j in 0..wrkmix(i)-1 loop
103: newper(cntnew+j) := wrkper(cntwrk+j);
104: end loop;
105: cntnew := cntnew + wrkmix(i);
106: else for j in 0..wrkmix(ind)-1 loop
107: newper(newper'first+j) := wrkper(cntwrk+j);
108: end loop;
109: end if;
110: cntwrk := cntwrk + wrkmix(i);
111: end loop;
112: wrkper := newper;
113: end Permute;
114:
115: begin
116: -- INITIALIZATIONS :
117: for i in wrkper'range loop
118: wrkper(i) := i;
119: end loop;
120: wrkmix := (wrkmix'range => 1);
121: -- SORTING THE SETS :
122: ind := al'first;
123: while ind <= al'last loop
124: nbd := nbd + 1;
125: Sort(ind,nbd);
126: ind := ind + wrkmix(nbd);
127: end loop;
128: -- MINIMAL OCCURENCE SHOULD APPEAR FIRST :
129: ind := wrkmix'first;
130: min := wrkmix(ind);
131: for i in wrkmix'first+1..nbd loop
132: if wrkmix(i) < min
133: then min := wrkmix(i); ind := i;
134: end if;
135: end loop;
136: -- put("The type of mixture : " ); put(wrkmix(wrkmix'first..nbd)); new_line;
137: -- put("The permutation vector : "); put(wrkper); new_line;
138: if ind /= wrkmix'first
139: then Permute(ind,nbd);
140: wrkmix(ind) := wrkmix(wrkmix'first);
141: wrkmix(wrkmix'first) := min;
142: end if;
143: -- put("The type of mixture : " ); put(wrkmix(wrkmix'first..nbd)); new_line;
144: -- put("The permutation vector : "); put(wrkper); new_line;
145: -- RETURNING THE RESULTS :
146: perm := new Vector'(wrkper);
147: mix := new Vector'(wrkmix(wrkmix'first..nbd));
148: end Mixture;
149:
150: function Permute ( perm : Vector; al : in Array_of_Lists )
151: return Array_of_Lists is
152:
153: res : Array_of_Lists(al'range);
154:
155: begin
156: for i in al'range loop
157: res(i) := al(perm(i));
158: end loop;
159: return res;
160: end Permute;
161:
162: function Different_Points ( al : Array_of_Lists ) return List is
163:
164: tmp,res,res_last : List;
165:
166: begin
167: for i in (al'first+1)..al'last loop
168: tmp := al(i);
169: while not Is_Null(tmp) loop
170: declare
171: lv : Link_to_Vector := Head_Of(tmp);
172: begin
173: if not Is_In(res,lv.all)
174: then Append(res,res_last,lv.all);
175: end if;
176: end;
177: tmp := Tail_Of(tmp);
178: end loop;
179: end loop;
180: return res;
181: end Different_Points;
182:
183: function Different_Points ( al : Array_of_Lists ) return Array_of_Lists is
184:
185: res : Array_of_Lists(al'range);
186:
187: begin
188: res(res'first) := al(al'first);
189: for i in (al'first+1)..al'last loop
190: res(i) := Different_Points(al(i));
191: end loop;
192: return res;
193: end Different_Points;
194:
195: procedure Remove_Duplicates ( al : in out Array_of_Lists ) is
196: begin
197: for i in al'range loop
198: Remove_Duplicates(al(i));
199: end loop;
200: end Remove_Duplicates;
201:
202: procedure Shift ( al : in out Array_of_Lists; shiftvecs : in VecVec ) is
203: begin
204: for k in al'range loop
205: Shift(al(k),shiftvecs(k));
206: end loop;
207: end Shift;
208:
209: function Shift ( al : Array_of_Lists; shiftvecs : VecVec )
210: return Array_of_Lists is
211:
212: res : Array_of_Lists(al'range);
213:
214: begin
215: for k in res'range loop
216: res(k) := Shift(al(k),shiftvecs(k));
217: end loop;
218: return res;
219: end Shift;
220:
221: procedure Projection ( al : in Array_of_Lists; v : in Vector;
222: ind : integer; res : in out Array_of_Lists;
223: degenerate : out boolean ) is
224:
225: pv : integer;
226: t : Transfo := Build_Transfo(v,ind);
227:
228: procedure Clean ( i : in integer ) is
229: begin
230: for j in res'first..i loop
231: Deep_Clear(res(j));
232: end loop;
233: Clear(t);
234: end Clean;
235:
236: begin
237: degenerate := false;
238: for i in res'range loop
239: declare
240: pvl : List;
241: l : List renames al(i+1);
242: begin
243: pv := Maximal_Support(l,v);
244: pvl := Face(l,v,pv);
245: if Length_Of(pvl) <= 1
246: then degenerate := true;
247: Deep_Clear(pvl); Clean(i);
248: return;
249: else res(i) := Transform_and_Reduce(t,ind,pvl);
250: Remove_Duplicates(res(i));
251: if Length_Of(res(i)) <= 1
252: then degenerate := true;
253: Deep_Clear(pvl); Clean(i);
254: return;
255: end if;
256: end if;
257: Deep_Clear(pvl);
258: end;
259: end loop;
260: Clear(t);
261: end Projection;
262:
263: end Arrays_of_Lists_Utilities;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to arrays_of_lists_utilities.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 / Implift