Annotation of OpenXM_contrib/PHC/Ada/Schubert/ts_posets.adb, Revision 1.1.1.1
1.1 maekawa 1: with text_io,integer_io; use text_io,integer_io;
2: with Communications_with_User; use Communications_with_User;
3: with Brackets,Brackets_io; use Brackets,Brackets_io;
4: with Localization_Posets; use Localization_Posets;
5: with Localization_Posets_io; use Localization_Posets_io;
6: with Drivers_for_Input_Planes; use Drivers_for_Input_Planes;
7:
8: procedure ts_posets is
9:
10: -- DESCRIPTION :
11: -- Test on the construction of localization posets.
12:
13: function Determine_Root ( m,p : natural ) return Node is
14:
15: -- DESCRIPTION :
16: -- Proposes the trivial root to the user, allowing the user to
17: -- modify this choice.
18:
19: root : Node(p) := Trivial_Root(m,p);
20: ans : character;
21:
22: begin
23: loop
24: put("Top and bottom pivots of root are ");
25: put(root.top); put(" and ");
26: put(root.bottom); put_line(".");
27: put("Level of the root : "); put(root.level,1); new_line;
28: put("Do you want to use another root ? (y/n) "); get(ans);
29: exit when (ans /= 'y');
30: put("Give top pivots : "); get(root.top);
31: put("Give bottom pivots : "); get(root.bottom);
32: put("Give level of root : "); get(root.level);
33: end loop;
34: return root;
35: end Determine_Root;
36:
37: procedure Write_Poset
38: ( file : in file_type;
39: lnkroot : in Link_to_Node; m,p,q : in natural ) is
40:
41: -- DESCRIPTION :
42: -- Creates the posets and writes them onto the file.
43:
44: nq : constant natural := m*p + q*(m+p);
45: level_poset : Array_of_Nodes(0..nq);
46: index_poset : Array_of_Array_of_Nodes(0..nq);
47: nbp : natural;
48:
49: begin
50: level_poset := Create_Leveled_Poset(lnkroot);
51: Count_Roots(level_poset);
52: index_poset := Create_Indexed_Poset(level_poset);
53: put(file,index_poset);
54: nbp := Root_Count_Sum(level_poset);
55: put(file,"The number of paths : "); put(file,nbp,1); new_line(file);
56: end Write_Poset;
57:
58: procedure Create_Top_Hypersurface_Poset ( m,p : in natural ) is
59:
60: -- DESCRIPTION :
61: -- Create the poset by incrementing only top pivots.
62:
63: root : Node(p) := Trivial_Root(m,p);
64: lnkroot : Link_to_Node := new Node'(root);
65:
66: begin
67: Top_Create(lnkroot,m+p);
68: put_line("The poset created from the top : ");
69: Write_Poset(Standard_Output,lnkroot,m,p,0);
70: end Create_Top_Hypersurface_Poset;
71:
72: procedure Create_Top_Hypersurface_Poset ( m,p,q : in natural ) is
73:
74: -- DESCRIPTION :
75: -- Create the poset by incrementing only top pivots.
76:
77: root : Node(p) := Trivial_Root(m,p,q);
78: lnkroot : Link_to_Node := new Node'(root);
79:
80: begin
81: Q_Top_Create(lnkroot,root.bottom(p),m+p);
82: put_line("The poset created from the top : ");
83: Write_Poset(Standard_Output,lnkroot,m,p,q);
84: end Create_Top_Hypersurface_Poset;
85:
86: procedure Create_Bottom_Hypersurface_Poset ( m,p : in natural ) is
87:
88: -- DESCRIPTION :
89: -- Create the poset by decrementing only bottom pivots.
90:
91: root : Node(p) := Trivial_Root(m,p);
92: lnkroot : Link_to_Node := new Node'(root);
93:
94: begin
95: Bottom_Create(lnkroot);
96: put_line("The poset created from the bottom : ");
97: Write_Poset(Standard_Output,lnkroot,m,p,0);
98: end Create_Bottom_Hypersurface_Poset;
99:
100: procedure Create_Bottom_Hypersurface_Poset ( m,p,q : in natural ) is
101:
102: -- DESCRIPTION :
103: -- Create the poset by decrementing only bottom pivots.
104:
105: root : Node(p) := Trivial_Root(m,p,q);
106: lnkroot : Link_to_Node := new Node'(root);
107:
108: begin
109: Q_Bottom_Create(lnkroot,m+p);
110: put_line("The poset created from the bottom : ");
111: Write_Poset(Standard_Output,lnkroot,m,p,q);
112: end Create_Bottom_Hypersurface_Poset;
113:
114: procedure Create_Mixed_Hypersurface_Poset ( m,p : in natural ) is
115:
116: -- DESCRIPTION :
117: -- Create the poset by incrementing top and decrementing bottom pivots.
118:
119: root : Node(p) := Trivial_Root(m,p);
120: lnkroot : Link_to_Node := new Node'(root);
121:
122: begin
123: Top_Bottom_Create(lnkroot,m+p);
124: put_line("The poset created in a mixed fashion : ");
125: Write_Poset(Standard_Output,lnkroot,m,p,0);
126: end Create_Mixed_Hypersurface_Poset;
127:
128: procedure Create_Mixed_Hypersurface_Poset ( m,p,q : in natural ) is
129:
130: -- DESCRIPTION :
131: -- Create the poset by incrementing top and decrementing bottom pivots.
132:
133: root : Node(p) := Trivial_Root(m,p,q);
134: lnkroot : Link_to_Node := new Node'(root);
135:
136: begin
137: Q_Top_Bottom_Create(lnkroot,root.bottom(p),m+p);
138: put_line("The poset created in a mixed fashion : ");
139: Write_Poset(Standard_Output,lnkroot,m,p,q);
140: end Create_Mixed_Hypersurface_Poset;
141:
142: procedure Create_Top_General_Poset ( m,p : in natural ) is
143:
144: -- DESCRIPTION :
145: -- Creates a poset for counting general subspace intersections,
146: -- by consistently incrementing the top pivots.
147:
148: root : Node(p) := Trivial_Root(m,p);
149: lnkroot : Link_to_Node := new Node'(root);
150: codim : constant Bracket := Read_Codimensions(m,p,0);
151:
152: begin
153: Top_Create(lnkroot,codim,m+p);
154: put_line("The poset created from the top : ");
155: Write_Poset(Standard_Output,lnkroot,m,p,0);
156: end Create_Top_General_Poset;
157:
158: procedure Create_Bottom_General_Poset ( m,p : in natural ) is
159:
160: -- DESCRIPTION :
161: -- Creates a poset for counting general subspace intersections,
162: -- by consistently incrementing the top pivots.
163:
164: root : Node(p) := Trivial_Root(m,p);
165: lnkroot : Link_to_Node := new Node'(root);
166: codim : constant Bracket := Read_Codimensions(m,p,0);
167:
168: begin
169: Bottom_Create(lnkroot,codim);
170: put_line("The poset created from the bottom : ");
171: Write_Poset(Standard_Output,lnkroot,m,p,0);
172: end Create_Bottom_General_Poset;
173:
174: procedure Create_Mixed_General_Poset ( m,p : in natural ) is
175:
176: -- DESCRIPTION :
177: -- Creates a poset for counting general subspace intersections,
178: -- by incrementing the top and decrementing the bottom pivots.
179:
180: root : Node(p) := Trivial_Root(m,p);
181: lnkroot : Link_to_Node := new Node'(root);
182: codim : constant Bracket := Read_Codimensions(m,p,0);
183:
184: begin
185: Top_Bottom_Create(lnkroot,codim,m+p);
186: put_line("The poset created in a mixed fashion : ");
187: Write_Poset(Standard_Output,lnkroot,m,p,0);
188: end Create_Mixed_General_Poset;
189:
190: procedure Create_Top_General_Poset ( m,p,q : in natural ) is
191:
192: -- DESCRIPTION :
193: -- Creates a poset for counting general subspace intersections,
194: -- by consistently incrementing the top pivots.
195:
196: root : Node(p) := Trivial_Root(m,p,q);
197: lnkroot : Link_to_Node := new Node'(root);
198: codim : constant Bracket := Read_Codimensions(m,p,q);
199:
200: begin
201: Q_Top_Create(lnkroot,codim,root.bottom(p),m+p);
202: put_line("The poset created from the top : ");
203: Write_Poset(Standard_Output,lnkroot,m,p,q);
204: end Create_Top_General_Poset;
205:
206: procedure Create_Bottom_General_Poset ( m,p,q : in natural ) is
207:
208: -- DESCRIPTION :
209: -- Creates a poset for counting general subspace intersections,
210: -- by consistently incrementing the top pivots.
211:
212: root : Node(p) := Trivial_Root(m,p,q);
213: lnkroot : Link_to_Node := new Node'(root);
214: codim : constant Bracket := Read_Codimensions(m,p,q);
215:
216: begin
217: Q_Bottom_Create(lnkroot,codim,m+p);
218: put_line("The poset created from the bottom : ");
219: Write_Poset(Standard_Output,lnkroot,m,p,q);
220: end Create_Bottom_General_Poset;
221:
222: procedure Create_Mixed_General_Poset ( m,p,q : in natural ) is
223:
224: -- DESCRIPTION :
225: -- Creates a poset for counting general subspace intersections,
226: -- by incrementing the top and decrementing the bottom pivots.
227:
228: root : Node(p) := Trivial_Root(m,p,q);
229: lnkroot : Link_to_Node := new Node'(root);
230: codim : constant Bracket := Read_Codimensions(m,p,q);
231:
232: begin
233: Q_Top_Bottom_Create(lnkroot,codim,root.bottom(p),m+p);
234: put_line("The poset created in a mixed fashion : ");
235: Write_Poset(Standard_Output,lnkroot,m,p,q);
236: end Create_Mixed_General_Poset;
237:
238: procedure Test_Root_Counts
239: ( file : in file_type;
240: m,p,q : in natural; codim : in Bracket; bug : out boolean ) is
241:
242: -- DESCRIPTION :
243: -- Computes the root count in various ways for the given vector
244: -- of co-dimensions. Compares the results and reports bugs.
245:
246: mpq : constant natural := m*p + q*(m+p);
247: top_root0,bot_root0,mix_root0 : Node(p);
248: lnk_top_root0 : Link_to_Node := new Node'(top_root0);
249: lnk_bot_root0 : Link_to_Node := new Node'(bot_root0);
250: lnk_mix_root0 : Link_to_Node := new Node'(mix_root0);
251: top_poset0,bot_poset0,mix_poset0 : Array_of_Nodes(0..mpq);
252: top_rootq,bot_rootq,mix_rootq : Node(p);
253: lnk_top_rootq : Link_to_Node := new Node'(top_rootq);
254: lnk_bot_rootq : Link_to_Node := new Node'(bot_rootq);
255: lnk_mix_rootq : Link_to_Node := new Node'(mix_rootq);
256: top_posetq,bot_posetq,mix_posetq : Array_of_Nodes(0..mpq);
257:
258: begin
259: bug := false;
260: if q = 0
261: then top_root0 := Trivial_Root(m,p);
262: bot_root0 := Trivial_Root(m,p);
263: mix_root0 := Trivial_Root(m,p);
264: lnk_top_root0 := new Node'(top_root0);
265: lnk_bot_root0 := new Node'(bot_root0);
266: lnk_mix_root0 := new Node'(mix_root0);
267: Top_Create(lnk_top_root0,codim,m+p);
268: Bottom_Create(lnk_bot_root0,codim);
269: Top_Bottom_Create(lnk_mix_root0,codim,m+p);
270: top_poset0 := Create_Leveled_Poset(lnk_top_root0);
271: bot_poset0 := Create_Leveled_Poset(lnk_bot_root0);
272: mix_poset0 := Create_Leveled_Poset(lnk_mix_root0);
273: Count_Roots(top_poset0);
274: Count_Roots(bot_poset0);
275: Count_Roots(mix_poset0);
276: end if;
277: top_rootq := Trivial_Root(m,p,q);
278: bot_rootq := Trivial_Root(m,p,q);
279: mix_rootq := Trivial_Root(m,p,q);
280: lnk_top_rootq := new Node'(top_rootq);
281: lnk_bot_rootq := new Node'(bot_rootq);
282: lnk_mix_rootq := new Node'(mix_rootq);
283: Q_Top_Create(lnk_top_rootq,codim,top_rootq.bottom(p),m+p);
284: Q_Bottom_Create(lnk_bot_rootq,codim,m+p);
285: Q_Top_Bottom_Create(lnk_mix_rootq,codim,mix_rootq.bottom(p),m+p);
286: top_posetq := Create_Leveled_Poset(lnk_top_rootq);
287: bot_posetq := Create_Leveled_Poset(lnk_bot_rootq);
288: mix_posetq := Create_Leveled_Poset(lnk_mix_rootq);
289: Count_Roots(top_posetq);
290: Count_Roots(bot_posetq);
291: Count_Roots(mix_posetq);
292: if q = 0
293: then
294: put(file,top_poset0(mpq).roco,1);
295: if top_poset0(mpq).roco = bot_poset0(mpq).roco
296: then
297: put(file," = ");
298: put(file,bot_poset0(mpq).roco,1); bug := false;
299: if bot_poset0(mpq).roco = mix_poset0(mpq).roco
300: then
301: bug := false;
302: put(file," = "); put(file,mix_poset0(mpq).roco,1);
303: else
304: bug := true;
305: put(file," <> "); put(file,mix_poset0(mpq).roco,1);
306: put_line(file," BUG !!!");
307: put_line(file,"The poset created incrementing top pivots : ");
308: Write_Poset(file,lnk_top_root0,m,p,q);
309: put_line(file,"The poset created decrementing bottom pivots : ");
310: Write_Poset(file,lnk_bot_root0,m,p,q);
311: put_line(file,"The poset created in a mixed fashion : ");
312: Write_Poset(file,lnk_mix_root0,m,p,q);
313: end if;
314: else
315: bug := true;
316: put(file," <> "); put(file,bot_poset0(mpq).roco,1);
317: put_line(file," BUG !!!");
318: put_line(file,"The poset created incrementing top pivots : ");
319: Write_Poset(file,lnk_top_root0,m,p,q);
320: put_line(file,"The poset created decrementing bottom pivots : ");
321: Write_Poset(file,lnk_bot_root0,m,p,q);
322: end if;
323: end if;
324: if q = 0
325: then
326: if top_posetq(mpq).roco /= top_poset0(mpq).roco
327: then
328: bug := true;
329: put(file," <> "); put(file,top_posetq(mpq).roco,1);
330: put_line(file," BUG !!!");
331: put_line(file,"The poset created without q = 0 : ");
332: Write_Poset(file,lnk_top_root0,m,p,q);
333: put_line(file,"The poset created with q = 0 : ");
334: Write_Poset(file,lnk_bot_rootq,m,p,q);
335: else
336: put(file," = ");
337: end if;
338: end if;
339: if not bug
340: then
341: put(file,top_posetq(mpq).roco,1);
342: if top_posetq(mpq).roco = bot_posetq(mpq).roco
343: then
344: put(file," = ");
345: put(file,bot_posetq(mpq).roco,1); bug := false;
346: if bot_posetq(mpq).roco = mix_posetq(mpq).roco
347: then
348: bug := false;
349: put(file," = "); put(file,mix_posetq(mpq).roco,1); new_line(file);
350: else
351: bug := true;
352: put(file," <> "); put(file,mix_posetq(mpq).roco,1);
353: put_line(file," BUG !!!");
354: put_line(file,"The poset created incrementing top pivots : ");
355: Write_Poset(file,lnk_top_rootq,m,p,q);
356: put_line(file,"The poset created decrementing bottom pivots : ");
357: Write_Poset(file,lnk_bot_rootq,m,p,q);
358: put_line(file,"The poset created in a mixed fashion : ");
359: Write_Poset(file,lnk_mix_rootq,m,p,q);
360: end if;
361: else
362: bug := true;
363: put(file," <> "); put(file,bot_posetq(mpq).roco,1);
364: put_line(file," BUG !!!");
365: put_line(file,"The poset created incrementing top pivots : ");
366: Write_Poset(file,lnk_top_rootq,m,p,q);
367: put_line(file,"The poset created decrementing bottom pivots : ");
368: Write_Poset(file,lnk_bot_rootq,m,p,q);
369: end if;
370: end if;
371: Clear(top_poset0); Clear(bot_poset0); Clear(mix_poset0);
372: Clear(top_posetq); Clear(bot_posetq); Clear(mix_posetq);
373: end Test_Root_Counts;
374:
375: procedure Enumerate_Partitions
376: ( file : in file_type; m,p,q : in natural ) is
377:
378: -- DESCRIPTION :
379: -- Test the root counts for all partitions of m*p + q*(m+p).
380: -- The results are written on file.
381:
382: n : constant natural := m*p + q*(m+p);
383: accu : Bracket(1..n);
384: bug : boolean := false;
385:
386: procedure Enumerate ( k,nk : in natural ) is
387: begin
388: if nk = 0
389: then put(file,n,1); put(file," = ");
390: for i in 1..k-2 loop
391: put(file,accu(i),1); put(file," + ");
392: end loop;
393: put(file,accu(k-1),1); put(file," : ");
394: Test_Root_Counts(file,m,p,q,accu(1..k-1),bug);
395: else for i in 1..nk loop
396: exit when (i > m);
397: accu(k) := i;
398: Enumerate(k+1,nk-i);
399: exit when bug;
400: end loop;
401: end if;
402: end Enumerate;
403:
404: begin
405: Enumerate(1,n);
406: end Enumerate_Partitions;
407:
408: procedure Main is
409:
410: m,p,q : natural;
411: ans : character;
412: file : file_type;
413:
414: begin
415: loop
416: new_line;
417: put_line("MENU for posets for counting p-planes in (m+p)-space : ");
418: put_line(" 0. exit this program.");
419: put_line("-------- the case q = 0 ------------------------------------");
420: put_line(" 1. k_i == 1 consistently incrementing the top pivots.");
421: put_line(" 2. consistently decrementing the bottom pivots.");
422: put_line(" 3. mixed top-bottom sequence for poset creation.");
423: put_line(" 4. k_i >= 1 consistently incrementing the top pivots.");
424: put_line(" 5. consistently decrementing the bottom pivots.");
425: put_line(" 6. mixed top-bottom sequence for poset creation.");
426: put_line(" 7. Enumerate all partitions of m*p and test root counts.");
427: put_line("-------- the case q >= 0 -----------------------------------");
428: put_line(" 8. k_i == 1 consistently incrementing top pivots.");
429: put_line(" 9. consistently decrementing bottom pivots.");
430: put_line(" A. mixed top-bottom sequence for pivots.");
431: put_line(" B. k_i >= 1 consistently incrementing top pivots.");
432: put_line(" C. consistently decrementing bottom pivots.");
433: put_line(" D. mixed top-bottom sequence for pivots.");
434: put_line(" E. Test root counts for all partitions of m*p + q*(m+p).");
435: put_line("------------------------------------------------------------");
436: put("Type 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, A, B, C, D, or E to choose : ");
437: Ask_Alternative(ans,"0123456789ABCDE");
438: exit when ans = '0';
439: if ans = '7' or ans = 'E'
440: then new_line;
441: put_line("Reading the name of the output file.");
442: Read_Name_and_Create_File(file);
443: end if;
444: new_line;
445: put("Give p, the number of entries in bracket : "); get(p);
446: put("Give m, the complementary dimension : "); get(m);
447: new_line;
448: case ans is
449: when '1' => Create_Top_Hypersurface_Poset(m,p);
450: when '2' => Create_Bottom_Hypersurface_Poset(m,p);
451: when '3' => Create_Mixed_Hypersurface_Poset(m,p);
452: when '4' => Create_Top_General_Poset(m,p);
453: when '5' => Create_Bottom_General_Poset(m,p);
454: when '6' => Create_Mixed_General_Poset(m,p);
455: when '7' => Enumerate_Partitions(file,m,p,0);
456: when '8' => put("Give q, the degree of the maps : "); get(q);
457: Create_Top_Hypersurface_Poset(m,p,q);
458: when '9' => put("Give q, the degree of the maps : "); get(q);
459: Create_Bottom_Hypersurface_Poset(m,p,q);
460: when 'A' => put("Give q, the degree of the maps : "); get(q);
461: Create_Mixed_Hypersurface_Poset(m,p,q);
462: when 'B' => put("Give q, the degree of the maps : "); get(q);
463: Create_Top_General_Poset(m,p,q);
464: when 'C' => put("Give q, the degree of the maps : "); get(q);
465: Create_Bottom_General_Poset(m,p,q);
466: when 'D' => put("Give q, the degree of the maps : "); get(q);
467: Create_Mixed_General_Poset(m,p,q);
468: when 'E' => put("Give q, the degree of the maps : "); get(q);
469: Enumerate_Partitions(file,m,p,q);
470: when others => put_line("Option not recognized. Please try again.");
471: end case;
472: end loop;
473: end Main;
474:
475: begin
476: new_line;
477: put_line("Test on localization posets for linear subspace intersections.");
478: Main;
479: end ts_posets;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to ts_posets.adb CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib / PHC / Ada / Schubert