Annotation of OpenXM_contrib/PHC/Ada/Schubert/ts_posets.adb, Revision 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