Annotation of OpenXM_contrib/PHC/Ada/Root_Counts/Stalift/floating_lifting_utilities.adb, Revision 1.1.1.1
1.1 maekawa 1: package body Floating_Lifting_Utilities is
2:
3: function Adaptive_Lifting ( l : Array_of_Lists ) return Vector is
4:
5: res : Vector(l'range);
6: fac : constant double_float := 3.0; -- multiplication factor
7: max : constant double_float := 23.0; -- upper bound for lifting
8:
9: begin
10: for i in l'range loop
11: res(i) := fac*double_float(Length_Of(l(i)));
12: if res(i) > max
13: then res(i) := max;
14: end if;
15: end loop;
16: return res;
17: end Adaptive_Lifting;
18:
19: procedure Search_Lifting ( l : in List; pt : in Vector;
20: found : out boolean; lif : out double_float ) is
21:
22: tmp : List := l;
23: lpt : Link_to_Vector;
24:
25: begin
26: found := false;
27: while not Is_Null(tmp) loop
28: lpt := Head_Of(tmp);
29: if Equal(lpt(pt'range),pt)
30: then found := true;
31: lif := lpt(lpt'last);
32: exit;
33: else tmp := Tail_Of(tmp);
34: end if;
35: end loop;
36: end Search_Lifting;
37:
38: function Search_and_Lift ( l : List; pt : Vector ) return Vector is
39:
40: tmp : List := l;
41: lpt : Link_to_Vector;
42:
43: begin
44: while not Is_Null(tmp) loop
45: lpt := Head_Of(tmp);
46: if Equal(lpt(pt'range),pt)
47: then return lpt.all;
48: else tmp := Tail_Of(tmp);
49: end if;
50: end loop;
51: return pt;
52: end Search_and_Lift;
53:
54: function Search_and_Lift ( mic : Mixed_Cell; k : natural; pt : Vector )
55: return Vector is
56: begin
57: return Search_and_Lift(mic.pts(k),pt);
58: end Search_and_Lift;
59:
60: function Occured_Lifting ( mixsub : Mixed_Subdivision; k : natural;
61: pt : Vector ) return Vector is
62:
63: tmp : Mixed_Subdivision := mixsub;
64:
65: begin
66: while not Is_Null(tmp) loop
67: declare
68: lpt : constant Vector := Search_and_Lift(Head_Of(tmp),k,pt);
69: begin
70: if lpt'last > pt'last
71: then return lpt;
72: else tmp := Tail_Of(tmp);
73: end if;
74: end;
75: end loop;
76: return pt;
77: end Occured_Lifting;
78:
79: function Occured_Lifting
80: ( n : natural; mix : Standard_Integer_Vectors.Vector;
81: points : Array_of_Lists; mixsub : Mixed_Subdivision )
82: return Array_of_Lists is
83:
84: res,res_last : Array_of_Lists(mix'range);
85: cnt : natural := 1;
86: tmp : List;
87:
88: begin
89: for k in mix'range loop
90: res_last(k) := res(k);
91: tmp := points(cnt);
92: while not Is_Null(tmp) loop
93: declare
94: pt : Link_to_Vector := Head_Of(tmp);
95: lpt : constant Vector := Occured_Lifting(mixsub,k,pt.all);
96: begin
97: if lpt'last > pt'last
98: then Append(res(k),res_last(k),lpt);
99: end if;
100: end;
101: tmp := Tail_Of(tmp);
102: end loop;
103: cnt := cnt + mix(k);
104: end loop;
105: return res;
106: end Occured_Lifting;
107:
108: function Induced_Lifting ( mixsub : Mixed_Subdivision; k : natural;
109: pt : Vector ) return Vector is
110:
111: tmp : Mixed_Subdivision := mixsub;
112: res : Vector(pt'first..pt'last+1);
113:
114: begin
115: while not Is_Null(tmp) loop
116: declare
117: mic : Mixed_Cell := Head_Of(tmp);
118: lpt : constant Vector := Search_and_Lift(mic,k,pt);
119: begin
120: if lpt'length = pt'length+1
121: then return lpt;
122: else tmp := Tail_Of(tmp);
123: end if;
124: end;
125: end loop;
126: res(pt'range) := pt;
127: res(res'last) := 1.0;
128: res(res'last) := Conservative_Lifting(mixsub,k,res);
129: return res;
130: end Induced_Lifting;
131:
132: function Induced_Lifting
133: ( n : natural; mix : Standard_Integer_Vectors.Vector;
134: points : Array_of_Lists; mixsub : Mixed_Subdivision )
135: return Array_of_Lists is
136:
137: res,res_last : Array_of_Lists(mix'range);
138: cnt : natural := 1;
139: tmp : List;
140:
141: begin
142: for k in mix'range loop
143: res_last(k) := res(k);
144: tmp := points(cnt);
145: while not Is_Null(tmp) loop
146: declare
147: pt : Link_to_Vector := Head_Of(tmp);
148: lpt : constant Vector := Induced_Lifting(mixsub,k,pt.all);
149: begin
150: Append(res(k),res_last(k),lpt);
151: end;
152: tmp := Tail_Of(tmp);
153: end loop;
154: cnt := cnt + mix(k);
155: end loop;
156: return res;
157: end Induced_Lifting;
158:
159: function Conservative_Lifting
160: ( mic : Mixed_Cell; k : natural; point : Vector )
161: return double_float is
162:
163: sp : double_float := mic.nor*Head_Of(mic.pts(k));
164: spp : double_float:= mic.nor.all*point;
165: res : double_float;
166:
167: begin
168: if sp < spp
169: then return point(point'last);
170: else if mic.nor(mic.nor'last) = 0.0
171: then res := point(point'last);
172: else spp := spp - point(point'last)*mic.nor(mic.nor'last);
173: res := (sp - spp)/mic.nor(mic.nor'last) + 1.0;
174: end if;
175: return res;
176: end if;
177: end Conservative_Lifting;
178:
179: function Conservative_Lifting ( mixsub : Mixed_Subdivision; k : natural;
180: point : Vector ) return double_float is
181:
182: tmp : Mixed_Subdivision := mixsub;
183: pt : Vector(point'range) := point;
184: res : double_float;
185:
186: begin
187: while not Is_Null(tmp) loop
188: pt(pt'last) := Conservative_Lifting(Head_Of(tmp),k,pt);
189: tmp := Tail_Of(tmp);
190: end loop;
191: res := pt(pt'last);
192: Clear(pt);
193: return res;
194: end Conservative_Lifting;
195:
196: end Floating_Lifting_Utilities;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to floating_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