![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to cayley_embedding.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|
Return to cayley_embedding.adb CVS log | Up to [local] / OpenXM_contrib / PHC / Ada / Root_Counts / Dynlift |
1.1 maekawa 1: with Standard_Integer_VecVecs; use Standard_Integer_VecVecs;
2:
3: package body Cayley_Embedding is
4:
5: -- AUXILIARIES :
6:
7: function Is_Good_Point
8: ( cnt,n : natural; pt : Link_to_Vector ) return boolean is
9:
10: -- DESCRIPTION :
11: -- Returns true if the point pt is a point of the type indicated
12: -- by the parameter cnt, i.e. whether it belongs to the polytope
13: -- placed on the vertex with number cnt.
14:
15: goodpoint : boolean;
16:
17: begin
18: if cnt = 0
19: then goodpoint := true;
20: for l in pt'first..pt'last-n-1 loop
21: if pt(l) /= 0
22: then goodpoint := false;
23: end if;
24: exit when not goodpoint;
25: end loop;
26: else goodpoint := (pt(cnt) = 1);
27: end if;
28: return goodpoint;
29: end Is_Good_Point;
30:
31: procedure Project ( n : natural; v : in out Link_to_Vector ) is
32:
33: -- DESCRIPTION :
34: -- After application, v points to a vector of length n+1.
35:
36: newv : Link_to_Vector;
37:
38: begin
39: newv := new Vector(1..n+1);
40: newv(1..n+1) := v(v'last-n..v'last);
41: Clear(v);
42: v := newv;
43: end Project;
44:
45: -- TARGET ROUTINES :
46:
47: function Embedding_Before_Lifting
48: ( supports : Array_of_Lists ) return List is
49:
50: tmp,res,res_last : List;
51: r1 : constant natural := supports'length-1;
52: pt : Link_to_Vector;
53: cnt : natural := 0;
54:
55: begin
56: for k in supports'range loop
57: tmp := supports(k);
58: while not Is_Null(tmp) loop
59: pt := Head_Of(tmp);
60: declare
61: npt : Vector(pt'first..pt'last+r1);
62: begin
63: npt(npt'last-pt'length+1..npt'last) := pt.all;
64: npt(npt'first..npt'first+r1-1) := (npt'first..npt'first+r1-1 => 0);
65: if cnt > 0
66: then npt(cnt) := 1;
67: end if;
68: Append(res,res_last,npt);
69: end;
70: tmp := Tail_Of(tmp);
71: end loop;
72: cnt := cnt + 1;
73: end loop;
74: return res;
75: end Embedding_Before_Lifting;
76:
77: function Extract ( vtp,n : natural; pts : VecVec ) return List is
78:
79: res,res_last : List;
80:
81: begin
82: for k in pts'range loop
83: if Is_Good_Point(vtp,n,pts(k))
84: then Append(res,res_last,pts(k).all);
85: end if;
86: end loop;
87: return res;
88: end Extract;
89:
90: function Extract ( vtp,n : natural; pts : List ) return List is
91:
92: -- DESCRIPTION :
93: -- Extracts the points out of the list that are of the type
94: -- indicated by vtp.
95:
96: tmp,res,res_last : List;
97: pt : Link_to_Vector;
98:
99: begin
100: tmp := pts;
101: while not Is_Null(tmp) loop
102: pt := Head_Of(tmp);
103: if Is_Good_Point(vtp,n,pt)
104: then Append(res,res_last,pt.all);
105: end if;
106: tmp := Tail_Of(tmp);
107: end loop;
108: return res;
109: end Extract;
110:
111: function Extract_Mixed_Cell
112: ( n : natural; mix : Vector; s : Simplex ) return Mixed_Cell is
113:
114: res : Mixed_Cell;
115: work : Array_of_Lists(mix'range);
116: cnt : natural := 0;
117: iscell : boolean;
118: pts : constant VecVec := Vertices(s);
119:
120: begin
121: for k in mix'range loop
122: work(k) := Extract(cnt,n,pts);
123: iscell := (Length_Of(work(k)) = mix(k)+1);
124: exit when not iscell;
125: cnt := cnt + 1;
126: end loop;
127: if iscell
128: then res.pts := new Array_of_Lists'(work);
129: res.nor := new vector'(Normal(s));
130: else Deep_Clear(work);
131: end if;
132: return res;
133: end Extract_Mixed_Cell;
134:
135: function Extract_Mixed_Cells
136: ( n : natural; mix : Vector; t : Triangulation )
137: return Mixed_Subdivision is
138:
139: res,res_last : Mixed_Subdivision;
140: s : Simplex;
141: tmp : Triangulation;
142:
143: begin
144: tmp := t;
145: while not Is_Null(tmp) loop
146: s := Head_Of(tmp);
147: declare
148: mic : Mixed_Cell := Extract_Mixed_Cell(n,mix,s);
149: begin
150: if mic.nor /= null
151: then Append(res,res_last,mic);
152: end if;
153: end;
154: tmp := Tail_Of(tmp);
155: end loop;
156: return res;
157: end Extract_Mixed_Cells;
158:
159: function Extract_non_Flat_Mixed_Cells
160: ( n : natural; mix : Vector; t : Triangulation )
161: return Mixed_Subdivision is
162:
163: res,res_last : Mixed_Subdivision;
164: s : Simplex;
165: tmp : Triangulation;
166:
167: begin
168: tmp := t;
169: while not Is_Null(tmp) loop
170: s := Head_Of(tmp);
171: exit when Is_Flat(s);
172: declare
173: mic : Mixed_Cell := Extract_Mixed_Cell(n,mix,s);
174: begin
175: if mic.nor /= null
176: then Append(res,res_last,mic);
177: end if;
178: end;
179: tmp := Tail_Of(tmp);
180: end loop;
181: return res;
182: end Extract_non_Flat_Mixed_Cells;
183:
184: procedure Deflate ( n : natural; l : in out List ) is
185:
186: tmp : List := l;
187:
188: begin
189: while not Is_Null(tmp) loop
190: declare
191: pt : Link_to_Vector := Head_Of(tmp);
192: begin
193: Project(n,pt);
194: Set_Head(tmp,pt);
195: end;
196: tmp := Tail_Of(tmp);
197: end loop;
198: end Deflate;
199:
200: procedure Deflate ( n : natural; mic : in out Mixed_Cell ) is
201: begin
202: Project(n,mic.nor);
203: for k in mic.pts'range loop
204: Deflate(n,mic.pts(k));
205: end loop;
206: end Deflate;
207:
208: procedure Deflate ( n : natural; mixsub : in out Mixed_Subdivision ) is
209:
210: tmp : Mixed_Subdivision := mixsub;
211:
212: begin
213: while not Is_Null(tmp) loop
214: declare
215: mic : Mixed_Cell := Head_Of(tmp);
216: begin
217: Deflate(n,mic);
218: Set_Head(tmp,mic);
219: end;
220: tmp := Tail_Of(tmp);
221: end loop;
222: end Deflate;
223:
224: end Cayley_Embedding;