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