Annotation of OpenXM_contrib/PHC/Ada/Root_Counts/Stalift/integer_lifting_utilities.adb, Revision 1.1.1.1
1.1 maekawa 1: with Integer_Vectors_Utilities; use Integer_Vectors_Utilities;
2: -- with Power_Lists; use Power_Lists;
3:
4: package body Integer_Lifting_Utilities is
5:
6: function Adaptive_Lifting ( l : Array_of_Lists ) return Vector is
7:
8: res : Vector(l'range);
9: fac : constant natural := 3; -- multiplication factor
10: max : constant natural := 23; -- upper bound for lifting
11:
12: begin
13: for i in l'range loop
14: res(i) := fac*Length_Of(l(i));
15: if res(i) > max
16: then res(i) := max;
17: end if;
18: end loop;
19: return res;
20: end Adaptive_Lifting;
21:
22: -- function Select_Subsystem ( p : Laur_Sys; mix : Vector; mic : Mixed_Cell )
23: -- return Laur_Sys is
24: --
25: -- res : Laur_Sys(p'range);
26: -- cnt : natural := 0;
27: --
28: -- begin
29: -- for k in mix'range loop
30: -- for l in 1..mix(k) loop
31: -- cnt := cnt + 1;
32: -- res(cnt) := Select_Terms(p(cnt),mic.pts(k));
33: -- end loop;
34: -- end loop;
35: -- return res;
36: -- end Select_Subsystem;
37:
38: function Perform_Lifting ( n : natural; l : List; p : Poly ) return Poly is
39:
40: res : Poly := Null_Poly;
41: tmp : List := l;
42:
43: begin
44: while not Is_Null(tmp) loop
45: declare
46: d : Link_to_Vector := Head_Of(tmp);
47: dr : Link_to_Vector := Reduce(d,n+1);
48: t : Term;
49: begin
50: t.cf := Coeff(p,Degrees(dr));
51: t.dg := Degrees(d);
52: Add(res,t);
53: Clear(dr);
54: end;
55: tmp := Tail_Of(tmp);
56: end loop;
57: return res;
58: end Perform_Lifting;
59:
60: function Perform_Lifting
61: ( n : natural; mix : Vector; lifted : Array_of_Lists;
62: p : Laur_Sys ) return Laur_Sys is
63:
64: res : Laur_Sys(p'range);
65: cnt : natural := 1;
66:
67: begin
68: for k in mix'range loop
69: for l in 1..mix(k) loop
70: res(cnt) := Perform_Lifting(n,lifted(k),p(cnt));
71: cnt := cnt+1;
72: end loop;
73: end loop;
74: return res;
75: end Perform_Lifting;
76:
77: function Copy_Lifting ( lifted : List; pt : Link_to_Vector )
78: return Link_to_Vector is
79:
80: -- DESCRIPTION :
81: -- Searches the correspoinding point in the list lifted and returns
82: -- the lifted point. If the corresponding point has not been found,
83: -- then the original point pt will be returned.
84:
85: tmp : List := lifted;
86: lpt,res : Link_to_Vector;
87:
88: begin
89: while not Is_Null(tmp) loop
90: lpt := Head_Of(tmp);
91: if Equal(lpt(pt'range),pt.all)
92: then res := new Standard_Integer_Vectors.Vector'(lpt.all);
93: return res;
94: else tmp := Tail_Of(tmp);
95: end if;
96: end loop;
97: return pt;
98: end Copy_Lifting;
99:
100: function Copy_Lifting ( lifted,pts : List ) return List is
101:
102: -- DESCRIPTION :
103: -- Copies the lifting on the points lifted to the points in pts,
104: -- i.e., each point in pts will get the same lifting as the corresponding
105: -- lifted point in the list lifted.
106:
107: res : List;
108: tmp : List := pts;
109:
110: begin
111: while not Is_Null(tmp) loop
112: Construct(Copy_Lifting(lifted,Head_Of(tmp)),res);
113: tmp := Tail_Of(tmp);
114: end loop;
115: return res;
116: end Copy_Lifting;
117:
118: procedure Search_Lifting ( l : in List; pt : in Vector;
119: found : out boolean; lif : out integer ) is
120:
121: tmp : List := l;
122: lpt : Link_to_Vector;
123:
124: begin
125: found := false;
126: while not Is_Null(tmp) loop
127: lpt := Head_Of(tmp);
128: if Equal(lpt(pt'range),pt)
129: then found := true;
130: lif := lpt(lpt'last);
131: exit;
132: else tmp := Tail_Of(tmp);
133: end if;
134: end loop;
135: end Search_Lifting;
136:
137: function Search_and_Lift ( l : List; pt : Vector ) return Vector is
138:
139: tmp : List := l;
140: lpt : Link_to_Vector;
141:
142: begin
143: while not Is_Null(tmp) loop
144: lpt := Head_Of(tmp);
145: if Equal(lpt(pt'range),pt)
146: then return lpt.all;
147: else tmp := Tail_Of(tmp);
148: end if;
149: end loop;
150: return pt;
151: end Search_and_Lift;
152:
153: function Search_and_Lift ( mic : Mixed_Cell; k : natural; pt : Vector )
154: return Vector is
155: begin
156: return Search_and_Lift(mic.pts(k),pt);
157: end Search_and_Lift;
158:
159: function Induced_Lifting ( mixsub : Mixed_Subdivision; k : natural;
160: pt : Vector ) return Vector is
161:
162: tmp : Mixed_Subdivision := mixsub;
163: res : Vector(pt'first..pt'last+1);
164:
165: begin
166: while not Is_Null(tmp) loop
167: declare
168: mic : Mixed_Cell := Head_Of(tmp);
169: lpt : constant Vector := Search_and_Lift(mic,k,pt);
170: begin
171: if lpt'length = pt'length+1
172: then return lpt;
173: else tmp := Tail_Of(tmp);
174: end if;
175: end;
176: end loop;
177: res(pt'range) := pt;
178: res(res'last) := 1;
179: res(res'last) := Conservative_Lifting(mixsub,k,res);
180: return res;
181: end Induced_Lifting;
182:
183: function Induced_Lifting
184: ( n : natural; mix : Vector; points : Array_of_Lists;
185: mixsub : Mixed_Subdivision ) return Array_of_Lists is
186:
187: res,res_last : Array_of_Lists(mix'range);
188: cnt : natural := 1;
189: tmp : List;
190:
191: begin
192: for k in mix'range loop
193: res_last(k) := res(k);
194: tmp := points(cnt);
195: while not Is_Null(tmp) loop
196: declare
197: pt : Link_to_Vector := Head_Of(tmp);
198: lpt : constant Vector := Induced_Lifting(mixsub,k,pt.all);
199: begin
200: Append(res(k),res_last(k),lpt);
201: end;
202: tmp := Tail_Of(tmp);
203: end loop;
204: cnt := cnt + mix(k);
205: end loop;
206: return res;
207: end Induced_Lifting;
208:
209: procedure Constant_Lifting
210: ( l : in List; liftval : in natural;
211: lifted,lifted_last : in out List ) is
212:
213: tmp : List := l;
214: pt : Link_to_Vector;
215:
216: begin
217: while not Is_Null(tmp) loop
218: pt := Head_Of(tmp);
219: declare
220: lpt : Link_to_Vector := new Vector(pt'first..pt'last+1);
221: begin
222: lpt(pt'range) := pt.all;
223: lpt(lpt'last) := liftval;
224: Append(lifted,lifted_last,lpt);
225: end;
226: tmp := Tail_Of(tmp);
227: end loop;
228: end Constant_Lifting;
229:
230: procedure Constant_Lifting
231: ( al : in Array_of_Lists; liftval : in natural;
232: lifted,lifted_last : in out Array_of_Lists ) is
233: begin
234: for i in al'range loop
235: Constant_Lifting(al(i),liftval,lifted(i),lifted_last(i));
236: end loop;
237: end Constant_Lifting;
238:
239: function Conservative_Lifting
240: ( mic : Mixed_Cell; k : natural; point : Vector )
241: return integer is
242:
243: sp : integer := mic.nor*Head_Of(mic.pts(k));
244: spp : integer := mic.nor.all*point;
245: res : integer;
246:
247: begin
248: if sp < spp
249: then return point(point'last);
250: else if mic.nor(mic.nor'last) = 0
251: then res := point(point'last);
252: else spp := spp - point(point'last)*mic.nor(mic.nor'last);
253: res := (sp - spp)/mic.nor(mic.nor'last) + 1;
254: end if;
255: return res;
256: end if;
257: end Conservative_Lifting;
258:
259: function Conservative_Lifting ( mixsub : Mixed_Subdivision; k : natural;
260: point : Vector ) return integer is
261:
262: tmp : Mixed_Subdivision := mixsub;
263: pt : Vector(point'range) := point;
264: res : integer;
265:
266: begin
267: while not Is_Null(tmp) loop
268: pt(pt'last) := Conservative_Lifting(Head_Of(tmp),k,pt);
269: tmp := Tail_Of(tmp);
270: end loop;
271: res := pt(pt'last);
272: Clear(pt);
273: return res;
274: end Conservative_Lifting;
275:
276: function Lower_Lifting ( mic : Mixed_Cell; k : natural; point : Vector )
277: return integer is
278: begin
279: if Is_In(mic.pts(k),point)
280: then return 0;
281: else declare
282: pt : Vector(point'range) := point;
283: begin
284: pt(pt'last) := 0;
285: return Conservative_Lifting(mic,k,pt);
286: end;
287: end if;
288: end Lower_Lifting;
289:
290: function Lower_Lifting ( mixsub : Mixed_Subdivision; k : natural;
291: point : Vector ) return integer is
292:
293: lif : integer := point(point'last);
294: tmp : Mixed_Subdivision := mixsub;
295: max : integer := 0;
296:
297: begin
298: while not Is_Null(tmp) loop
299: lif := Lower_Lifting(Head_Of(tmp),k,point);
300: if lif > max
301: then max := lif;
302: end if;
303: exit when max = point(point'last);
304: tmp := Tail_Of(tmp);
305: end loop;
306: return max;
307: end Lower_Lifting;
308:
309: end Integer_Lifting_Utilities;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to integer_lifting_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 / Stalift