![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to floating_faces_of_polytope.adb CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib / PHC / Ada / Math_Lib / Supports|
Return to floating_faces_of_polytope.adb CVS log | Up to [local] / OpenXM_contrib / PHC / Ada / Math_Lib / Supports |
1.1 maekawa 1: with Standard_Integer_Vectors;
2: with Floating_Face_Enumerators; use Floating_Face_Enumerators;
3:
4: package body Floating_Faces_of_Polytope is
5:
6: -- AUXILIAIRIES :
7:
8: function Create_Edge ( pts : VecVec; i,j : integer ) return Face is
9:
10: -- DESCRIPTION :
11: -- Creates the edge spanned by pts(i) and pts(j).
12:
13: res : Face(0..1) := new VecVec(0..1);
14:
15: begin
16: res(0) := new Vector'(pts(i).all);
17: res(1) := new Vector'(pts(j).all);
18: return res;
19: end Create_Edge;
20:
21: function Create_Face ( pts : VecVec;
22: f : Standard_Integer_Vectors.Vector ) return Face is
23:
24: -- DESCRIPTION :
25: -- Returns vector of points pts(f(i)) that span the face.
26:
27: res : Face(f'range) := new VecVec(f'range);
28:
29: begin
30: for i in f'range loop
31: res(i) := new Vector'(pts(f(i)).all);
32: end loop;
33: return res;
34: end Create_Face;
35:
36: procedure Move_to_Front ( pts : in out VecVec;
37: x : in Standard_Floating_Vectors.Vector ) is
38:
39: -- DESCRIPTION :
40: -- The vector x is move to the front of the vector pts.
41:
42: begin
43: if pts(pts'first).all /= x
44: then for i in pts'first+1..pts'last loop
45: if pts(i).all = x
46: then pts(i).all := pts(pts'first).all;
47: pts(pts'first).all := x;
48: return;
49: end if;
50: end loop;
51: end if;
52: end Move_to_Front;
53:
54: -- CONSTRUCTORS :
55:
56: function Create ( k,n : positive; p : List; tol : double_float )
57: return Faces is
58:
59: res : Faces;
60:
61: begin
62: if k > n
63: then return res;
64: else
65: declare
66: m : constant natural := Length_Of(p);
67: pts : VecVec(1..m) := Shallow_Create(p);
68: res_last : Faces := res;
69: begin
70: if k = 1
71: then
72: declare
73: procedure Append_Edge ( i,j : in natural; cont : out boolean ) is
74: f : Face := Create_Edge(pts,i,j);
75: begin
76: Append(res,res_last,f); cont := true;
77: end Append_Edge;
78: procedure Enum_Edges is new Enumerate_Edges(Append_Edge);
79: begin
80: Enum_Edges(pts,tol);
81: end;
82: else
83: declare
84: procedure Append_Face ( fa : in Standard_Integer_Vectors.Vector;
85: cont : out boolean ) is
86: f : Face := Create_Face(pts,fa);
87: begin
88: Append(res,res_last,f); cont := true;
89: end Append_Face;
90: procedure Enum_Faces is new Enumerate_Faces(Append_Face);
91: begin
92: Enum_Faces(k,pts,tol);
93: end;
94: end if;
95: return res;
96: end;
97: end if;
98: end Create;
99:
100: function Create ( k,n : positive; p : List; x : Vector; tol : double_float )
101: return Faces is
102:
103: res : Faces;
104:
105: begin
106: if k > n
107: then return res;
108: else
109: declare
110: m : constant natural := Length_Of(p);
111: pts : VecVec(1..m) := Shallow_Create(p);
112: res_last : Faces := res;
113: begin
114: Move_to_Front(pts,x);
115: if k = 1
116: then
117: declare
118: procedure Append_Edge ( i,j : in natural; cont : out boolean ) is
119: f : Face;
120: begin
121: if i = pts'first
122: then f := Create_Edge(pts,i,j);
123: Append(res,res_last,f);
124: cont := true;
125: else cont := false;
126: end if;
127: end Append_Edge;
128: procedure Enum_Edges is new Enumerate_Edges(Append_Edge);
129: begin
130: Enum_Edges(pts,tol);
131: end;
132: else
133: declare
134: procedure Append_Face ( fa : in Standard_Integer_Vectors.Vector;
135: cont : out boolean ) is
136: f : Face;
137: begin
138: if fa(fa'first) = pts'first
139: then f := Create_Face(pts,fa);
140: Append(res,res_last,f);
141: cont := true;
142: else cont := false;
143: end if;
144: end Append_Face;
145: procedure Enum_Faces is new Enumerate_Faces(Append_Face);
146: begin
147: Enum_Faces(k,pts,tol);
148: end;
149: end if;
150: return res;
151: end;
152: end if;
153: end Create;
154:
155: function Create_Lower ( k,n : positive; p : List; tol : double_float )
156: return Faces is
157:
158: res : Faces;
159:
160: begin
161: if k > n
162: then return res;
163: else
164: declare
165: m : constant natural := Length_Of(p);
166: pts : VecVec(1..m) := Shallow_Create(p);
167: res_last : Faces := res;
168: begin
169: if k = 1
170: then
171: declare
172: procedure Append_Edge ( i,j : in natural; cont : out boolean ) is
173: f : Face := Create_Edge(pts,i,j);
174: begin
175: Append(res,res_last,f); cont := true;
176: end Append_Edge;
177: procedure Enum_Edges is new Enumerate_Lower_Edges(Append_Edge);
178: begin
179: Enum_Edges(pts,tol);
180: end;
181: else
182: declare
183: procedure Append_Face ( fa : in Standard_Integer_Vectors.Vector;
184: cont : out boolean ) is
185: f : Face := Create_Face(pts,fa);
186: begin
187: Append(res,res_last,f); cont := true;
188: end Append_Face;
189: procedure Enum_Faces is new Enumerate_Lower_Faces(Append_Face);
190: begin
191: Enum_Faces(k,pts,tol);
192: end;
193: end if;
194: return res;
195: end;
196: end if;
197: end Create_Lower;
198:
199: function Create_Lower ( k,n : positive; p : List; x : Vector;
200: tol : double_float ) return Faces is
201:
202: res : Faces;
203:
204: begin
205: if k > n
206: then return res;
207: else
208: declare
209: m : constant natural := Length_Of(p);
210: pts : VecVec(1..m) := Shallow_Create(p);
211: res_last : Faces := res;
212: begin
213: Move_to_Front(pts,x);
214: if k = 1
215: then
216: declare
217: procedure Append_Edge ( i,j : in natural; cont : out boolean ) is
218: f : Face := Create_Edge(pts,i,j);
219: begin
220: if i = pts'first
221: then f := Create_Edge(pts,i,j);
222: Append(res,res_last,f);
223: cont := true;
224: else cont := false;
225: end if;
226: end Append_Edge;
227: procedure Enum_Edges is new Enumerate_Lower_Edges(Append_Edge);
228: begin
229: Enum_Edges(pts,tol);
230: end;
231: else
232: declare
233: procedure Append_Face ( fa : in Standard_Integer_Vectors.Vector;
234: cont : out boolean ) is
235: f : Face;
236: begin
237: if fa(fa'first) = pts'first
238: then f := Create_Face(pts,fa);
239: Append(res,res_last,f);
240: cont := true;
241: else cont := false;
242: end if;
243: end Append_Face;
244: procedure Enum_Faces is new Enumerate_Lower_Faces(Append_Face);
245: begin
246: Enum_Faces(k,pts,tol);
247: end;
248: end if;
249: return res;
250: end;
251: end if;
252: end Create_Lower;
253:
254: procedure Construct ( first : in out Faces; fs : in Faces ) is
255:
256: tmp : Faces := fs;
257:
258: begin
259: while not Is_Null(tmp) loop
260: Construct(Head_Of(tmp),first);
261: tmp := Tail_Of(tmp);
262: end loop;
263: end Construct;
264:
265: -- SELECTORS :
266:
267: function Is_Equal ( f1,f2 : Face ) return boolean is
268:
269: found : boolean;
270:
271: begin
272: for i in f1'range loop
273: found := false;
274: for j in f2'range loop
275: found := Equal(f1(i).all,f2(j).all);
276: exit when found;
277: end loop;
278: if not found
279: then return false;
280: end if;
281: end loop;
282: return true;
283: end Is_Equal;
284:
285: function Is_In ( f : Face; x : Vector ) return boolean is
286: begin
287: for i in f'range loop
288: if f(i).all = x
289: then return true;
290: end if;
291: end loop;
292: return false;
293: end Is_In;
294:
295: function Is_In ( fs : Faces; f : Face ) return boolean is
296:
297: tmp : Faces := fs;
298:
299: begin
300: while not Is_Null(tmp) loop
301: if Is_Equal(f,Head_Of(tmp))
302: then return true;
303: else tmp := Tail_Of(tmp);
304: end if;
305: end loop;
306: return false;
307: end Is_In;
308:
309: -- DESTRUCTORS :
310:
311: procedure Deep_Clear ( f : in out Face ) is
312: begin
313: if f /= null
314: then for i in f'range loop
315: Clear(f(i));
316: end loop;
317: end if;
318: end Deep_Clear;
319:
320: procedure Shallow_Clear ( f : in out Face ) is
321: begin
322: if f /= null
323: then Clear(f.all);
324: end if;
325: end Shallow_Clear;
326:
327: procedure Deep_Clear ( fa : in out Face_Array ) is
328: begin
329: for i in fa'range loop
330: Deep_Clear(fa(i));
331: end loop;
332: end Deep_Clear;
333:
334: procedure Shallow_Clear ( fa : in out Face_Array ) is
335: begin
336: for i in fa'range loop
337: Shallow_Clear(fa(i));
338: end loop;
339: end Shallow_Clear;
340:
341: procedure Deep_Clear ( fs : in out Faces ) is
342:
343: tmp : Faces := fs;
344:
345: begin
346: while not Is_Null(tmp) loop
347: declare
348: f : Face := Head_Of(tmp);
349: begin
350: Deep_Clear(f);
351: end;
352: tmp := Tail_Of(tmp);
353: end loop;
354: Lists_of_Faces.Clear(Lists_of_Faces.List(fs));
355: end Deep_Clear;
356:
357: procedure Shallow_Clear ( fs : in out Faces ) is
358:
359: tmp : Faces := fs;
360:
361: begin
362: Lists_of_Faces.Clear(Lists_of_Faces.List(fs));
363: end Shallow_Clear;
364:
365: procedure Deep_Clear ( afs : in out Array_of_Faces ) is
366: begin
367: for i in afs'range loop
368: Deep_Clear(afs(i));
369: end loop;
370: end Deep_Clear;
371:
372: procedure Shallow_Clear ( afs : in out Array_of_Faces ) is
373: begin
374: for i in afs'range loop
375: Shallow_Clear(afs(i));
376: end loop;
377: end Shallow_Clear;
378:
379: end Floating_Faces_of_Polytope;