Annotation of OpenXM_contrib/PHC/Ada/Root_Counts/Dynlift/unfolding_subdivisions.adb, Revision 1.1.1.1
1.1 maekawa 1: with Integer_Support_Functions; use Integer_Support_Functions;
2: with Flatten_Mixed_Subdivisions; use Flatten_Mixed_Subdivisions;
3:
4: package body Unfolding_Subdivisions is
5:
6: function Different_Normals ( mixsub : Mixed_Subdivision ) return List is
7:
8: tmp : Mixed_Subdivision := mixsub;
9: res,res_last : List;
10:
11: begin
12: while not Is_Null(tmp) loop
13: Append_Diff(res,res_last,Head_Of(tmp).nor.all);
14: tmp := Tail_Of(tmp);
15: end loop;
16: return res;
17: end Different_Normals;
18:
19: function Extract ( normal : Vector; mixsub : Mixed_Subdivision )
20: return Mixed_Subdivision is
21:
22: tmp : Mixed_Subdivision := mixsub;
23: res,res_last : Mixed_Subdivision;
24:
25: begin
26: while not Is_Null(tmp) loop
27: declare
28: mic : Mixed_Cell := Head_Of(tmp);
29: begin
30: if mic.nor.all = normal
31: then Append(res,res_last,mic);
32: end if;
33: end;
34: tmp := Tail_Of(tmp);
35: end loop;
36: return res;
37: end Extract;
38:
39: function Merge_Same_Normal ( mixsub : Mixed_Subdivision )
40: return Mixed_Cell is
41:
42: -- DESCRIPTION :
43: -- All cells with the same inner normal will be put in one cell,
44: -- that will be contained in the mixed subdivision on return.
45:
46: -- REQUIRED :
47: -- not Is_Null(mixsub) and all mixed cells have the same inner normal.
48:
49: tmp : Mixed_Subdivision;
50: resmic,mic : Mixed_Cell;
51:
52: begin
53: mic := Head_Of(mixsub);
54: resmic.nor := new Standard_Integer_Vectors.Vector'(mic.nor.all);
55: resmic.pts := new Array_of_Lists'(mic.pts.all);
56: tmp := Tail_Of(mixsub);
57: while not Is_Null(tmp) loop
58: mic := Head_Of(tmp);
59: declare
60: last : List;
61: begin
62: for k in mic.pts'range loop
63: last := resmic.pts(k);
64: while not Is_Null(Tail_Of(last)) loop
65: last := Tail_Of(last);
66: end loop;
67: Deep_Concat_Diff(resmic.pts(k),last,mic.pts(k));
68: end loop;
69: end;
70: tmp := Tail_Of(tmp);
71: end loop;
72: return resmic;
73: end Merge_Same_Normal;
74:
75: function Merge_Same_Normal ( mixsub : Mixed_Subdivision )
76: return Mixed_Subdivision is
77:
78: -- REQUIRED :
79: -- not Is_Null(mixsub) and all mixed cells have the same inner normal.
80:
81: resmic : Mixed_Cell := Merge_Same_Normal(mixsub);
82: ressub : Mixed_Subdivision;
83:
84: begin
85: Construct(resmic,ressub);
86: return ressub;
87: end Merge_Same_Normal;
88:
89: function Merge ( mixsub : Mixed_Subdivision ) return Mixed_Subdivision is
90:
91: -- NOTE :
92: -- Cells with an unique normal are simply taken over in the result,
93: -- cells with the same normal are merged, hereby the refinement of these
94: -- cells is destroyed. Though, one could do better...
95:
96: begin
97: if Is_Null(mixsub)
98: then return mixsub;
99: else
100: declare
101: tmp : Mixed_Subdivision := mixsub;
102: res,res_last : Mixed_Subdivision;
103: mic : Mixed_Cell;
104: begin
105: while not Is_Null(tmp) loop
106: mic := Head_Of(tmp);
107: if not Is_In(res,mic.nor.all)
108: then
109: if not Is_In(Tail_Of(tmp),mic.nor.all)
110: then Append(res,res_last,mic);
111: else declare
112: tmpmic : Mixed_Subdivision := Extract(mic.nor.all,tmp);
113: bigmic : Mixed_Cell := Merge_Same_Normal(tmpmic);
114: begin
115: Append(res,res_last,bigmic);
116: end;
117: end if;
118: end if;
119: tmp := Tail_Of(tmp);
120: end loop;
121: return res;
122: end;
123: end if;
124: end Merge;
125:
126: function Relift ( l : List; point : Vector ) return List is
127:
128: tmp,res : List;
129: pt : Link_to_Vector;
130:
131: begin
132: Copy(l,res);
133: tmp := res;
134: while not Is_Null(tmp) loop
135: pt := Head_Of(tmp);
136: if pt.all = point
137: then pt(pt'last) := 1;
138: else pt(pt'last) := 0;
139: end if;
140: Set_Head(tmp,pt);
141: tmp := Tail_Of(tmp);
142: end loop;
143: return res;
144: end Relift;
145:
146: function Relift ( pts : Array_of_Lists; point : Vector )
147: return Array_of_Lists is
148:
149: res : Array_of_Lists(pts'range);
150:
151: begin
152: for i in pts'range loop
153: res(i) := Relift(pts(i),point);
154: end loop;
155: return res;
156: end Relift;
157:
158: function Relift ( mic : Mixed_Cell; point : Vector ) return Mixed_Cell is
159:
160: res : Mixed_Cell;
161:
162: begin
163: res.pts := new Array_of_Lists'(Relift(mic.pts.all,point));
164: res.nor := new Standard_Integer_Vectors.Vector'(point'range => 0);
165: Compute_Inner_Normal(res);
166: return res;
167: end Relift;
168:
169: function Relift ( mixsub : Mixed_Subdivision; point : Vector )
170: return Mixed_Subdivision is
171:
172: tmp,res,res_last : Mixed_Subdivision;
173:
174: begin
175: tmp := mixsub;
176: while not Is_Null(tmp) loop
177: Append(res,res_last,Relift(Head_Of(tmp),point));
178: tmp := Tail_Of(tmp);
179: end loop;
180: return res;
181: end Relift;
182:
183: function Is_In_Point ( pt : Link_to_Vector; l : List ) return boolean is
184:
185: -- DESCRIPTION :
186: -- Returns true if the first n coordinates of pt belong to l.
187:
188: tmp : List := l;
189: lpt : Link_to_Vector;
190:
191: begin
192: while not Is_Null(tmp) loop
193: lpt := Head_Of(tmp);
194: if lpt(lpt'first..lpt'last-1) = pt(pt'first..pt'last-1)
195: then return true;
196: else tmp := Tail_Of(tmp);
197: end if;
198: end loop;
199: return false;
200: end Is_In_Point;
201:
202: function Different_Points ( l1,l2 : List ) return natural is
203:
204: -- DESCRIPTION :
205: -- Return the number of different points of the list l2 w.r.t. l1.
206:
207: res : natural := 0;
208: tmp : List := l2;
209:
210: begin
211: while not Is_Null(tmp) loop
212: if not Is_In_Point(Head_Of(tmp),l1)
213: then res := res + 1;
214: end if;
215: tmp := Tail_Of(tmp);
216: end loop;
217: return res;
218: end Different_Points;
219:
220: function Different_Points ( l1,l2 : List ) return List is
221:
222: -- DESCRIPTION :
223: -- Return the list of different points of the list l2 w.r.t. l1.
224:
225: res,res_last : List;
226: tmp : List := l2;
227:
228: begin
229: while not Is_Null(tmp) loop
230: if not Is_In_Point(Head_Of(tmp),l1)
231: then Append(res,res_last,Head_Of(tmp).all);
232: end if;
233: tmp := Tail_Of(tmp);
234: end loop;
235: return res;
236: end Different_Points;
237:
238: function Different_Points ( pts : Array_of_Lists; mic : Mixed_Cell )
239: return natural is
240:
241: -- DESCRIPTION :
242: -- Return the number of different points of the cell mic w.r.t. pts.
243:
244: res : natural := 0;
245:
246: begin
247: for i in pts'range loop
248: res := res + Different_Points(pts(i),mic.pts(i));
249: end loop;
250: return res;
251: end Different_Points;
252:
253: function Different_Points ( pts : Array_of_Lists; mic : Mixed_Cell )
254: return Array_of_Lists is
255:
256: -- DESCRIPTION :
257: -- Return the different points of the cell mic w.r.t. pts.
258:
259: res : Array_of_Lists(pts'range);
260:
261: begin
262: for i in pts'range loop
263: res(i) := Different_Points(pts(i),mic.pts(i));
264: end loop;
265: return res;
266: end Different_Points;
267:
268: procedure Add ( l : in out List; pts : in List ) is
269:
270: -- DESCRIPTION :
271: -- Adds the points in pts to l.
272:
273: tmp : List := pts;
274: pt : Link_to_Vector;
275:
276: begin
277: while not Is_Null(tmp) loop
278: pt := Head_Of(tmp);
279: declare
280: npt : Link_to_Vector := new Vector'(pt.all);
281: begin
282: Construct(npt,l);
283: end;
284: tmp := Tail_Of(tmp);
285: end loop;
286: end Add;
287:
288: procedure Add ( l : in out Array_of_Lists; pts : in Array_of_Lists ) is
289:
290: -- DESCRIPTION :
291: -- Adds the points in pts to l.
292:
293: begin
294: for i in l'range loop
295: Add(l(i),pts(i));
296: end loop;
297: end Add;
298:
299: procedure Put_Next_to_Front ( mixsub : in out Mixed_Subdivision;
300: pts : in Array_of_Lists ) is
301:
302: -- DESCRIPTION :
303: -- Selects the next mixed cell to be processed, and puts in front
304: -- of the list of cells mixsub.
305:
306: mic1 : Mixed_Cell := Head_Of(mixsub);
307: min1 : natural := Different_Points(pts,mic1);
308: tmp : Mixed_Subdivision := Tail_Of(mixsub);
309: min : natural;
310: mic : Mixed_Cell;
311:
312: begin
313: while not Is_Null(tmp) loop
314: mic := Head_Of(tmp);
315: min := Different_Points(pts,mic);
316: if min < min1
317: then min1 := min;
318: Set_Head(mixsub,mic);
319: Set_Head(tmp,mic1);
320: end if;
321: tmp := Tail_Of(tmp);
322: end loop;
323: end Put_Next_to_Front;
324:
325: procedure Relift ( l : in out List; ref : in List ) is
326:
327: -- DESCRIPTION :
328: -- Gives all points in l, which belong to ref, lifting value 1.
329:
330: tmp : List := l;
331: pt : Link_to_Vector;
332:
333: begin
334: while not Is_Null(tmp) loop
335: pt := Head_Of(tmp);
336: if Is_In(ref,pt)
337: then pt(pt'last) := 1;
338: else pt(pt'last) := 0;
339: end if;
340: Set_Head(tmp,pt);
341: tmp := Tail_Of(tmp);
342: end loop;
343: end Relift;
344:
345: procedure Relift ( l : in out List ) is
346:
347: -- DESCRIPTION :
348: -- Gives all points lifting value 1.
349:
350: tmp : List := l;
351: pt : Link_to_Vector;
352:
353: begin
354: while not Is_Null(tmp) loop
355: pt := Head_Of(tmp);
356: pt(pt'last) := 1;
357: Set_Head(tmp,pt);
358: tmp := Tail_Of(tmp);
359: end loop;
360: end Relift;
361:
362: procedure Relift ( l : in out Array_of_Lists; ref : in Array_of_Lists ) is
363:
364: -- DESCRIPTION :
365: -- Gives all points in l, which belong to ref, lifting value 1.
366:
367: begin
368: for i in l'range loop
369: Relift(l(i),ref(i));
370: end loop;
371: end Relift;
372:
373: procedure Relift ( l : in out Array_of_Lists ) is
374:
375: -- DESCRIPTION :
376: -- Gives all points lifting value 1.
377:
378: begin
379: for i in l'range loop
380: Relift(l(i));
381: end loop;
382: end Relift;
383:
384: procedure Relift ( mic : in out Mixed_Cell; pts : in out Array_of_Lists ) is
385:
386: -- DESCRIPTION :
387: -- Gives the points in mic, which belong to pts lifting 1,
388: -- and computes the new inner normal.
389:
390: begin
391: Relift(mic.pts.all,pts);
392: Relift(pts);
393: end Relift;
394:
395: procedure Orientate_Inner_Normal
396: ( mic : in out Mixed_Cell; pts : in Array_of_Lists ) is
397:
398: -- DESCRIPTION :
399: -- Orientates the normal of mic w.r.t. the points in pts.
400:
401: done : boolean := false;
402:
403: begin
404: for i in pts'range loop
405: if Minimal_Support(mic.pts(i),mic.nor.all)
406: > Minimal_Support(pts(i),mic.nor.all)
407: then Min(mic.nor);
408: done := true;
409: end if;
410: exit when done;
411: end loop;
412: end Orientate_Inner_Normal;
413:
414: procedure Unfolding ( mixsub : in out Mixed_Subdivision ) is
415:
416: tmp : Mixed_Subdivision;
417:
418: begin
419: if not Is_Null(mixsub)
420: then
421: declare
422: mic : Mixed_Cell := Head_Of(mixsub);
423: pts : Array_of_Lists(mic.pts'range);
424: begin
425: Flatten(mic);
426: Copy(mic.pts.all,pts);
427: Process(mic,pts);
428: tmp := Tail_Of(mixsub);
429: while not Is_Null(tmp) loop
430: Put_Next_to_Front(tmp,pts);
431: mic := Head_Of(tmp);
432: declare
433: newpts : Array_of_Lists(pts'range);
434: begin
435: newpts := Different_Points(pts,mic);
436: Relift(mic,newpts);
437: Compute_Inner_Normal(mic);
438: -- Orientate_Inner_Normal(mic,pts);
439: Process(mic,newpts);
440: Add(pts,newpts);
441: Deep_Clear(newpts);
442: end;
443: tmp := Tail_Of(tmp);
444: end loop;
445: end;
446: end if;
447: end Unfolding;
448:
449: end Unfolding_Subdivisions;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to unfolding_subdivisions.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 / Dynlift