Annotation of OpenXM_contrib/PHC/Ada/Schubert/localization_posets.adb, Revision 1.1
1.1 ! maekawa 1: with unchecked_deallocation;
! 2:
! 3: package body Localization_Posets is
! 4:
! 5: -- NOTE :
! 6: -- The field nd.roco is set to -1 if all its children have been created.
! 7: -- This flag prevents traversing the poset needlessly.
! 8:
! 9: -- CREATOR AUXILIARIES :
! 10:
! 11: function Max ( i,j : integer ) return integer is
! 12: begin
! 13: if i > j
! 14: then return i;
! 15: else return j;
! 16: end if;
! 17: end Max;
! 18:
! 19: function Last_Sibling ( root : Link_to_Node; level : natural )
! 20: return Link_to_Node is
! 21:
! 22: -- DESCRIPTION :
! 23: -- Returns the last sibling at the level, or the empty pointer if
! 24: -- there is no node at that level.
! 25:
! 26: res : Link_to_Node := null;
! 27: sibnd : Link_to_Node := Find_Node(root,level);
! 28:
! 29: procedure Search_Next ( current : in Link_to_Node ) is
! 30: begin
! 31: if current.next_sibling = null
! 32: then res := current;
! 33: else Search_Next(current.next_sibling);
! 34: end if;
! 35: end Search_Next;
! 36:
! 37: begin
! 38: if sibnd /= null
! 39: then Search_Next(sibnd);
! 40: end if;
! 41: return res;
! 42: end Last_Sibling;
! 43:
! 44: procedure Search_Sibling ( root : in Link_to_Node; nd : in Node;
! 45: lnd : out Link_to_Node; found : out boolean ) is
! 46:
! 47: -- DESCRIPTION :
! 48: -- Searches the poset for the link to a node with contents nd.
! 49: -- If found is true, then lnd is a pointer to that node, otherwise
! 50: -- lnd points to the last sibling, or is empty when there is no
! 51: -- node at level nd.level.
! 52:
! 53: sibnd : Link_to_Node := Find_Node(root,nd.level);
! 54:
! 55: procedure Search_Next ( current : in Link_to_Node ) is
! 56: begin
! 57: if Equal(current.all,nd)
! 58: then found := true;
! 59: lnd := current;
! 60: elsif current.next_sibling = null
! 61: then found := false;
! 62: lnd := current;
! 63: else Search_Next(current.next_sibling);
! 64: end if;
! 65: end Search_Next;
! 66:
! 67: begin
! 68: if sibnd = null
! 69: then lnd := sibnd; found := false;
! 70: else Search_Next(sibnd);
! 71: end if;
! 72: end Search_Sibling;
! 73:
! 74: function Create_Child ( root : Link_to_Node; child : Node; share : boolean )
! 75: return Link_to_Node is
! 76:
! 77: -- DESCRIPTION :
! 78: -- If the flag share is on, then the poset is searched for a node
! 79: -- with the same contents as the child. If a sibling is found,
! 80: -- then the pointer to this sibling is returned, otherwise the link
! 81: -- on return is a newly created link to node with contents child.
! 82: -- If the flag share is off, then the link on return points to the
! 83: -- last sibling node on that level, which has now contents child.
! 84:
! 85: res,lnd : Link_to_Node;
! 86: found : boolean;
! 87:
! 88: begin
! 89: if share
! 90: then Search_Sibling(root,child,lnd,found);
! 91: if found
! 92: then res := lnd;
! 93: end if;
! 94: else lnd := Last_Sibling(root,child.level);
! 95: found := false;
! 96: end if;
! 97: if not found
! 98: then res := new Node'(child);
! 99: if lnd /= null
! 100: then lnd.next_sibling := res;
! 101: res.prev_sibling := lnd;
! 102: end if;
! 103: end if;
! 104: return res;
! 105: end Create_Child;
! 106:
! 107: function Find_Index ( indexed_poset : Array_of_Array_of_Nodes;
! 108: nd : Link_to_Node ) return natural is
! 109:
! 110: -- DESCRIPTION :
! 111: -- Returns 0 if the node does not occur at indexed_poset(nd.level),
! 112: -- otherwise returns the index of the node nd in that array.
! 113: -- Note that the pointers are compared to deal with sharing.
! 114:
! 115: begin
! 116: if indexed_poset(nd.level) /= null
! 117: then for i in indexed_poset(nd.level)'range loop
! 118: if indexed_poset(nd.level)(i) = nd
! 119: then return i;
! 120: end if;
! 121: end loop;
! 122: end if;
! 123: return 0;
! 124: end Find_Index;
! 125:
! 126: function Labels_of_Children ( indexed_poset : Array_of_Array_of_Nodes;
! 127: nd : Node ) return Link_to_Vector is
! 128:
! 129: -- DESCRIPTION :
! 130: -- Returns the labels of the children of the current node.
! 131:
! 132: -- REQUIRED : indexed_poset(i) created for i < nd.level.
! 133:
! 134: res : Link_to_Vector;
! 135: nbc : constant natural := Number_of_Children(nd);
! 136: cnt : natural;
! 137:
! 138: begin
! 139: if nbc /= 0
! 140: then res := new Standard_Natural_Vectors.Vector(1..nbc);
! 141: cnt := 0;
! 142: for i in nd.children'range(1) loop
! 143: for j in nd.children'range(2) loop
! 144: if nd.children(i,j) /= null
! 145: then cnt := cnt+1;
! 146: res(cnt) := Find_Index(indexed_poset,nd.children(i,j));
! 147: end if;
! 148: end loop;
! 149: end loop;
! 150: end if;
! 151: return res;
! 152: end Labels_of_Children;
! 153:
! 154: -- SPECIAL TEST FOR GENERAL QUANTUM PIERI RULE :
! 155:
! 156: function Special_Plane ( piv : Bracket; lag : natural ) return Bracket is
! 157:
! 158: -- DESCRIPTION :
! 159: -- Returns the indices of the basis vectors that span the special
! 160: -- m-dimensional plane, defined by the complementary indices in piv.
! 161:
! 162: res : Bracket(1..lag-piv'last);
! 163: ind : natural := 0;
! 164: found : boolean;
! 165:
! 166: begin
! 167: for i in 1..lag loop
! 168: found := false;
! 169: for j in piv'range loop
! 170: found := (piv(j) = i);
! 171: exit when found or (piv(j) > i);
! 172: end loop;
! 173: if not found
! 174: then ind := ind+1;
! 175: res(ind) := i;
! 176: end if;
! 177: end loop;
! 178: return res;
! 179: end Special_Plane;
! 180:
! 181: function Intersect_Spaces ( b1,b2 : Bracket ) return Bracket is
! 182:
! 183: -- DESCRIPTION :
! 184: -- Returns the pivots that are common to both brackets.
! 185:
! 186: res : Bracket(b1'range);
! 187: cnt : natural := 0;
! 188: found : boolean;
! 189:
! 190: begin
! 191: for i in b1'range loop
! 192: found := false;
! 193: for j in b2'range loop
! 194: found := (b2(j) = b1(i));
! 195: exit when found;
! 196: end loop;
! 197: if found
! 198: then cnt := cnt+1;
! 199: res(cnt) := b1(i);
! 200: end if;
! 201: end loop;
! 202: return res(1..cnt);
! 203: end Intersect_Spaces;
! 204:
! 205: function Merging_Top_Pivot_Test ( piv,spc : Bracket ) return boolean is
! 206:
! 207: -- DESCRIPTION :
! 208: -- Returns true if there exists a decreasing sequence of successive
! 209: -- pivots from piv and spc that has length strictly higher than the
! 210: -- value of the last pivot used, starting at the tails of the brackets.
! 211:
! 212: max : constant natural := piv'last + spc'last;
! 213: acc : Bracket(1..max) := (1..max => 0);
! 214: acc_ind : natural := max+1;
! 215: piv_ind : natural := piv'last;
! 216: spc_ind : natural := spc'last;
! 217: stop : boolean;
! 218:
! 219: procedure Merge ( fail : out boolean ) is
! 220:
! 221: -- DESCRIPTION :
! 222: -- A consecutive pivot is added to the accumulator;
! 223: -- failure is reported when such is not possible.
! 224:
! 225: procedure Add_from_Pivots is
! 226: begin
! 227: if (acc_ind = max+1) or else (piv(piv_ind) >= acc(acc_ind) - 1)
! 228: then acc_ind := acc_ind-1;
! 229: acc(acc_ind) := piv(piv_ind);
! 230: piv_ind := piv_ind-1;
! 231: fail := false;
! 232: end if;
! 233: end Add_from_Pivots;
! 234:
! 235: procedure Add_from_Space is
! 236: begin
! 237: if (acc_ind = max+1) or else (spc(spc_ind) >= acc(acc_ind) - 1)
! 238: then acc_ind := acc_ind-1;
! 239: acc(acc_ind) := spc(spc_ind);
! 240: spc_ind := spc_ind-1;
! 241: fail := false;
! 242: end if;
! 243: end Add_from_Space;
! 244:
! 245: begin
! 246: fail := true;
! 247: if piv_ind >= piv'first
! 248: then if spc_ind >= spc'first
! 249: then if piv(piv_ind) >= spc(spc_ind)
! 250: then Add_from_Pivots;
! 251: else Add_from_Space;
! 252: end if;
! 253: else Add_from_Pivots;
! 254: end if;
! 255: else if spc_ind >= spc'first
! 256: then Add_from_Space;
! 257: end if;
! 258: end if;
! 259: end Merge;
! 260:
! 261: begin
! 262: loop
! 263: Merge(stop);
! 264: if acc(acc_ind) > (acc_ind + (acc(max) - max))
! 265: then return true;
! 266: end if;
! 267: exit when stop;
! 268: end loop;
! 269: return false;
! 270: end Merging_Top_Pivot_Test;
! 271:
! 272: function Merging_Bottom_Pivot_Test ( piv,spc : Bracket ) return boolean is
! 273:
! 274: -- DESCRIPTION :
! 275: -- Returns true if there exists a increasing sequence of successive
! 276: -- pivots from piv and spc that has length strictly higher than the
! 277: -- value of the last pivot used, starting at the heads of the brackets.
! 278:
! 279: max : constant natural := piv'last + spc'last;
! 280: acc : Bracket(1..max) := (1..max => 0);
! 281: acc_ind : natural := 0;
! 282: piv_ind : natural := piv'first;
! 283: spc_ind : natural := spc'first;
! 284: stop : boolean;
! 285:
! 286: procedure Merge ( fail : out boolean ) is
! 287:
! 288: -- DESCRIPTION :
! 289: -- A consecutive pivot is added to the accumulator;
! 290: -- failure is reported when such is not possible.
! 291:
! 292: procedure Add_from_Pivots is
! 293: begin
! 294: if (acc_ind = 0) or else (piv(piv_ind) <= acc(acc_ind) + 1)
! 295: then acc_ind := acc_ind+1;
! 296: acc(acc_ind) := piv(piv_ind);
! 297: piv_ind := piv_ind+1;
! 298: fail := false;
! 299: end if;
! 300: end Add_from_Pivots;
! 301:
! 302: procedure Add_from_Space is
! 303: begin
! 304: if (acc_ind = 0) or else (spc(spc_ind) <= acc(acc_ind) + 1)
! 305: then acc_ind := acc_ind+1;
! 306: acc(acc_ind) := spc(spc_ind);
! 307: spc_ind := spc_ind+1;
! 308: fail := false;
! 309: end if;
! 310: end Add_from_Space;
! 311:
! 312: begin
! 313: fail := true;
! 314: if piv_ind <= piv'last
! 315: then if spc_ind <= spc'last
! 316: then if piv(piv_ind) <= spc(spc_ind)
! 317: then Add_from_Pivots;
! 318: else Add_from_Space;
! 319: end if;
! 320: else Add_from_Pivots;
! 321: end if;
! 322: else if spc_ind <= spc'last
! 323: then Add_from_Space;
! 324: end if;
! 325: end if;
! 326: end Merge;
! 327:
! 328: begin
! 329: loop
! 330: Merge(stop);
! 331: if acc(acc_ind) < (acc_ind + (acc(1) - 1))
! 332: then return true;
! 333: end if;
! 334: exit when stop;
! 335: end loop;
! 336: return false;
! 337: end Merging_Bottom_Pivot_Test;
! 338:
! 339: -- CREATOR PRIMITIVES I : CHECK IF CREATION IS POSSIBLE AND ALLOWED
! 340:
! 341: function Top_Creatable ( nd : Node; n,i : natural ) return boolean is
! 342:
! 343: -- DESCRIPTION :
! 344: -- Returns true if the i-th top pivot can be incremented.
! 345: -- The n is the dimension of the working space.
! 346:
! 347: begin
! 348: if nd.bottom(i) <= nd.top(i)
! 349: then return false;
! 350: elsif i = nd.p
! 351: then return (nd.top(i) < n);
! 352: else return (nd.top(i)+1 < nd.top(i+1));
! 353: end if;
! 354: end Top_Creatable;
! 355:
! 356: function Q_Top_Creatable ( nd : Node; n,lag,i : natural ) return boolean is
! 357:
! 358: -- DESCRIPTION :
! 359: -- Returns true if the i-th top pivot can be incremented.
! 360: -- The n is the dimension of the working space.
! 361:
! 362: begin
! 363: if not Top_Creatable(nd,n,i)
! 364: then return false;
! 365: elsif i < nd.p
! 366: then return true;
! 367: else return (nd.top(nd.p) - nd.top(1) + 1 < lag);
! 368: end if;
! 369: end Q_Top_Creatable;
! 370:
! 371: function Q_Top_Creatable
! 372: ( nd : Node; modtop,space : Bracket; n,lag,pi,i : natural )
! 373: return boolean is
! 374:
! 375: -- DESCRIPTION :
! 376: -- This is the quantum analogue to implement the modular bottom-left
! 377: -- rule as needed in the general intersection case.
! 378:
! 379: -- ON ENTRY :
! 380: -- nd current node;
! 381: -- modtop top pivots of nd, modulo the lag;
! 382: -- space generators of the intersection of special m-planes;
! 383: -- n dimension of the working space;
! 384: -- lag equals m+p;
! 385: -- pi index in nd.top, permuted index i used to sort modtop;
! 386: -- i modtop(i) will be increased to derive the child.
! 387:
! 388: child : Bracket(modtop'range) := modtop;
! 389:
! 390: begin
! 391: if not Q_Top_Creatable(nd,n,lag,pi) -- valid pattern ?
! 392: then return false;
! 393: else -- valid pattern => valid child, only last entry might be zero
! 394: child(i) := modtop(i)+1;
! 395: if i = child'last and child(i) = lag+1
! 396: then for j in reverse child'first+1..child'last loop
! 397: child(j) := child(j-1);
! 398: end loop;
! 399: child(child'first) := 1;
! 400: end if;
! 401: return Merging_Top_Pivot_Test(child,space);
! 402: end if;
! 403: end Q_Top_Creatable;
! 404:
! 405: function Bottom_Creatable ( nd : Node; i : natural ) return boolean is
! 406:
! 407: -- DESCRIPTION :
! 408: -- Returns true if the i-th bottom pivot can be decremented.
! 409:
! 410: begin
! 411: if nd.bottom(i) <= nd.top(i)
! 412: then return false;
! 413: elsif i = 1
! 414: then return (nd.bottom(i) > 1);
! 415: else return (nd.bottom(i)-1 > nd.bottom(i-1));
! 416: end if;
! 417: end Bottom_Creatable;
! 418:
! 419: function Q_Bottom_Creatable ( nd : Node; lag,i : natural ) return boolean is
! 420:
! 421: -- DESCRIPTION :
! 422: -- Returns true if the i-th bottom pivot can be decremented and if
! 423: -- the spacing between first and last bottom pivot will remain < lag.
! 424:
! 425: begin
! 426: if not Bottom_Creatable(nd,i)
! 427: then return false;
! 428: elsif i > 1
! 429: then return true;
! 430: else return (nd.bottom(nd.p) - nd.bottom(1) + 1 < lag);
! 431: end if;
! 432: end Q_Bottom_Creatable;
! 433:
! 434: function Q_Bottom_Creatable
! 435: ( nd : Node; modbot,space : Bracket; lag,pi,i : natural )
! 436: return boolean is
! 437:
! 438: -- DESCRIPTION :
! 439: -- This is the quantum analogue to implement the modular bottom-left
! 440: -- rule as needed in the general intersection case.
! 441:
! 442: -- ON ENTRY :
! 443: -- nd current node;
! 444: -- modbot bottom pivots of nd, modulo the lag;
! 445: -- space generators of the intersection of special m-planes;
! 446: -- lag equals m+p;
! 447: -- pi index in nd.bottom, permuted index i used to sort modbot;
! 448: -- i modbot(i) will be decreased to derive the child.
! 449:
! 450: child : Bracket(modbot'range) := modbot;
! 451:
! 452: begin
! 453: if not Q_Bottom_Creatable(nd,lag,pi) -- valid pattern ?
! 454: then return false;
! 455: else -- valid pattern => valid child, only 1st entry might be zero
! 456: child(i) := modbot(i)-1;
! 457: if i = 1 and child(i) = 0
! 458: then for j in child'first..child'last-1 loop
! 459: child(j) := child(j+1);
! 460: end loop;
! 461: child(child'last) := lag;
! 462: end if;
! 463: return Merging_Bottom_Pivot_Test(child,space);
! 464: end if;
! 465: end Q_Bottom_Creatable;
! 466:
! 467: function Top_Bottom_Creatable ( nd : Node; n,i,j : natural )
! 468: return boolean is
! 469:
! 470: -- DESCRIPTION :
! 471: -- Returns true if the i-th top pivot can be incremented and if
! 472: -- the j-th bottom pivot can be decremented.
! 473:
! 474: begin
! 475: if not Top_Creatable(nd,n,i)
! 476: then return false;
! 477: elsif not Bottom_Creatable(nd,j)
! 478: then return false;
! 479: elsif i /= j
! 480: then return true;
! 481: else return (nd.bottom(i) - nd.top(i) > 1);
! 482: end if;
! 483: end Top_Bottom_Creatable;
! 484:
! 485: function Q_Top_Bottom_Creatable ( nd : Node; n,lag,i,j : natural )
! 486: return boolean is
! 487:
! 488: -- DESCRIPTION :
! 489: -- Returns true if the i-th top pivot can be incremented and if
! 490: -- the j-th bottom pivot can be decremented.
! 491:
! 492: begin
! 493: if not Q_Top_Creatable(nd,n,lag,i)
! 494: then return false;
! 495: elsif not Q_Bottom_Creatable(nd,lag,j)
! 496: then return false;
! 497: elsif i /= j
! 498: then return true;
! 499: else return (nd.bottom(i) - nd.top(i) > 1);
! 500: end if;
! 501: end Q_Top_Bottom_Creatable;
! 502:
! 503: function Q_Top_Bottom_Creatable
! 504: ( nd : Node; modtop,topspc,modbot,botspc : Bracket;
! 505: n,lag,pi,i,pj,j : natural ) return boolean is
! 506:
! 507: -- DESCRIPTION :
! 508: -- Returns true if the i-th top pivot can be incremented and if
! 509: -- the j-th bottom pivot can be decremented in the general quantum
! 510: -- Pieri homotopy algorithm.
! 511:
! 512: begin
! 513: if not Q_Top_Creatable(nd,modtop,topspc,n,lag,pi,i)
! 514: then return false;
! 515: elsif not Q_Bottom_Creatable(nd,modbot,botspc,lag,pj,j)
! 516: then return false;
! 517: elsif pi /= pj
! 518: then return true;
! 519: else return (nd.bottom(pi) - nd.top(pi) > 1);
! 520: end if;
! 521: end Q_Top_Bottom_Creatable;
! 522:
! 523: -- CREATOR PRIMITIVES II : DERIVE CHILD FROM NODE
! 524:
! 525: procedure Create_Top_Child ( root,nd : in out Link_to_Node;
! 526: i : in natural; share : in boolean ) is
! 527:
! 528: -- DESCRIPTION :
! 529: -- Creates a child of the given node by incrementing the i-th top pivot.
! 530:
! 531: child : Node(nd.p);
! 532:
! 533: begin
! 534: child.level := nd.level-1;
! 535: child.roco := 0;
! 536: child.bottom := nd.bottom;
! 537: child.top := nd.top;
! 538: child.top(i) := nd.top(i)+1;
! 539: nd.children(i,0) := Create_Child(root,child,share);
! 540: end Create_Top_Child;
! 541:
! 542: procedure Create_Bottom_Child ( root,nd : in out Link_to_Node;
! 543: i : in natural; share : in boolean ) is
! 544:
! 545: -- DESCRIPTION :
! 546: -- Creates a child of the node nd by decrementing the i-th bottom pivot.
! 547:
! 548: child : Node(nd.p);
! 549:
! 550: begin
! 551: child.level := nd.level-1;
! 552: child.roco := 0;
! 553: child.bottom := nd.bottom;
! 554: child.top := nd.top;
! 555: child.bottom(i) := nd.bottom(i)-1;
! 556: nd.children(0,i) := Create_Child(root,child,share);
! 557: end Create_Bottom_Child;
! 558:
! 559: procedure Create_Top_Bottom_Child
! 560: ( root,nd : in out Link_to_Node;
! 561: i,j : in natural; share : in boolean ) is
! 562:
! 563: -- DESCRIPTION :
! 564: -- Creates a child of the node nd by incrementing the i-th top pivot
! 565: -- and decrementing the i-th bottom pivot.
! 566:
! 567: child : Node(nd.p);
! 568:
! 569: begin
! 570: child.level := nd.level-2;
! 571: child.roco := 0;
! 572: child.top := nd.top;
! 573: child.top(i) := nd.top(i)+1;
! 574: child.bottom := nd.bottom;
! 575: child.bottom(j) := nd.bottom(j)-1;
! 576: nd.children(i,j) := Create_Child(root,child,share);
! 577: end Create_Top_Bottom_Child;
! 578:
! 579: -- CREATOR PRIMITIVES III : TREAT ONE/TWO DEGREE(S) OF FREEDOM
! 580:
! 581: procedure Top_Create1 ( root,nd : in out Link_to_Node; n : in natural ) is
! 582:
! 583: -- DESCRIPTION :
! 584: -- Creates new nodes by incrementing the top pivots, bounded by n.
! 585: -- The levels of the children nodes decrease by one as this is the
! 586: -- hypersurface case.
! 587:
! 588: begin
! 589: nd.tp := top;
! 590: for i in nd.top'range loop
! 591: if Top_Creatable(nd.all,n,i)
! 592: then Create_Top_Child(root,nd,i,true);
! 593: end if;
! 594: end loop;
! 595: end Top_Create1;
! 596:
! 597: procedure Q_Top_Create1 ( root,nd : in out Link_to_Node;
! 598: n,lag : in natural ) is
! 599:
! 600: -- DESCRIPTION :
! 601: -- Creates new nodes by incrementing the top pivots, for general q,
! 602: -- where we need the parameters n = dimension of working space
! 603: -- and lag = m+p, to bound the space between first and last entry.
! 604:
! 605: begin
! 606: nd.tp := top;
! 607: for i in nd.top'range loop
! 608: if Q_Top_Creatable(nd.all,n,lag,i)
! 609: then Create_Top_Child(root,nd,i,true);
! 610: end if;
! 611: end loop;
! 612: end Q_Top_Create1;
! 613:
! 614: procedure Top_Create1 ( root,nd : in out Link_to_Node;
! 615: k,n,c : in natural ) is
! 616:
! 617: -- DESCRIPTION :
! 618: -- Does k steps of the other Top_Create1 taking pivots larger than c.
! 619: -- This is the general case, for k=1 we have the hypersurface case.
! 620:
! 621: share : boolean := (k = 1);
! 622:
! 623: begin
! 624: if k > 0
! 625: then nd.tp := top;
! 626: for i in c..nd.top'last loop
! 627: if Top_Creatable(nd.all,n,i)
! 628: then Create_Top_Child(root,nd,i,share);
! 629: if k > 1
! 630: then Top_Create1(root,nd.children(i,0),k-1,n,i);
! 631: end if;
! 632: end if;
! 633: end loop;
! 634: end if;
! 635: end Top_Create1;
! 636:
! 637: procedure Q_Top_Create1 ( root,nd : in out Link_to_Node;
! 638: first : in boolean; space : in Bracket;
! 639: k,n,lag : in natural ) is
! 640:
! 641: -- DESCRIPTION :
! 642: -- Does k steps in a top-right chain on modular brackets.
! 643: -- The top-right rule is enforced by the merging pivot test involving
! 644: -- top pivots and the indices of the vectors that span the space of
! 645: -- intersection of special m-planes.
! 646:
! 647: -- ON ENTRY :
! 648: -- root root of the poset where the construction started;
! 649: -- nd current node;
! 650: -- first if true, then this is the first step in the sequence,
! 651: -- and the space has yet to be determined;
! 652: -- space contains generators of the intersection of special m-planes;
! 653: -- k number of steps still left to do;
! 654: -- n dimension of the space;
! 655: -- lag m+p.
! 656:
! 657: share : boolean := (k=1);
! 658: modtop : Bracket(nd.top'range);
! 659: perm : Standard_Natural_Vectors.Vector(modtop'range);
! 660: special : Bracket(1..lag-nd.p);
! 661:
! 662: procedure Recursive_Top_Create1 ( new_space : in Bracket ) is
! 663:
! 664: -- DESCRIPTION :
! 665: -- Additional layer needed for the determination of the updated space.
! 666:
! 667: begin
! 668: for i in modtop'range loop
! 669: if Q_Top_Creatable(nd.all,modtop,new_space,n,lag,perm(i),i)
! 670: then Create_Top_Child(root,nd,perm(i),share);
! 671: if k > 1
! 672: then Q_Top_Create1(root,nd.children(perm(i),0),
! 673: false,new_space,k-1,n,lag);
! 674: end if;
! 675: end if;
! 676: end loop;
! 677: end Recursive_Top_Create1;
! 678:
! 679: begin
! 680: if k > 0
! 681: then nd.tp := top;
! 682: Modulo(nd.top,lag,perm,modtop);
! 683: special := Special_Plane(modtop,lag);
! 684: if first
! 685: then Recursive_Top_Create1(special);
! 686: else declare
! 687: int_spc : constant Bracket
! 688: := Intersect_Spaces(space,special);
! 689: begin
! 690: Recursive_Top_Create1(int_spc);
! 691: end;
! 692: end if;
! 693: end if;
! 694: end Q_Top_Create1;
! 695:
! 696: procedure Bottom_Create1 ( root,nd : in out Link_to_Node ) is
! 697:
! 698: -- DESCRIPTION :
! 699: -- Creates new nodes by decrementing the bottom pivots.
! 700: -- The levels of the children nodes decrease by one as this is
! 701: -- the hypersurface case.
! 702:
! 703: begin
! 704: nd.tp := bottom;
! 705: for i in nd.top'range loop
! 706: if Bottom_Creatable(nd.all,i)
! 707: then Create_Bottom_Child(root,nd,i,true);
! 708: end if;
! 709: end loop;
! 710: end Bottom_Create1;
! 711:
! 712: procedure Q_Bottom_Create1
! 713: ( root,nd : in out Link_to_Node; lag : in natural ) is
! 714:
! 715: -- DESCRIPTION :
! 716: -- Creates new nodes by decrementing the bottom pivots for general q,
! 717: -- where the parameter lag > max space between first and last entry.
! 718:
! 719: begin
! 720: nd.tp := bottom;
! 721: for i in nd.top'range loop
! 722: if Q_Bottom_Creatable(nd.all,lag,i)
! 723: then Create_Bottom_Child(root,nd,i,true);
! 724: end if;
! 725: end loop;
! 726: end Q_Bottom_Create1;
! 727:
! 728: procedure Bottom_Create1 ( root,nd : in out Link_to_Node;
! 729: k,c : in natural ) is
! 730:
! 731: -- DESCRIPTION :
! 732: -- Does k steps of the other Bottom_Create1 taking pivots smaller than c.
! 733: -- This is the general case, for k=1 we have the hypersurface case.
! 734:
! 735: share : boolean := (k=1);
! 736:
! 737: begin
! 738: if k > 0
! 739: then nd.tp := bottom;
! 740: for i in nd.bottom'first..c loop
! 741: if Bottom_Creatable(nd.all,i)
! 742: then Create_Bottom_Child(root,nd,i,share);
! 743: if k > 1
! 744: then Bottom_Create1(root,nd.children(0,i),k-1,i);
! 745: end if;
! 746: end if;
! 747: end loop;
! 748: end if;
! 749: end Bottom_Create1;
! 750:
! 751: procedure Q_Bottom_Create1 ( root,nd : in out Link_to_Node;
! 752: first : in boolean; space : in Bracket;
! 753: k,lag : in natural ) is
! 754:
! 755: -- DESCRIPTION :
! 756: -- Does k steps in a bottom-left chain on modular brackets.
! 757: -- The bottom-left rule is enforced by the merging pivot test involving
! 758: -- bottom pivots and the indices of the vectors that span the space of
! 759: -- intersection of special m-planes.
! 760:
! 761: -- ON ENTRY :
! 762: -- root root of the poset where the construction started;
! 763: -- nd current node;
! 764: -- first if true, then this is the first step in the sequence,
! 765: -- and the space has yet to be determined;
! 766: -- space contains generators of the intersection of special m-planes;
! 767: -- k number of steps still left to do;
! 768: -- lag m+p.
! 769:
! 770: share : boolean := (k=1);
! 771: modbot : Bracket(nd.bottom'range);
! 772: perm : Standard_Natural_Vectors.Vector(modbot'range);
! 773: special : Bracket(1..lag-nd.p);
! 774:
! 775: procedure Recursive_Bottom_Create1 ( new_space : in Bracket ) is
! 776:
! 777: -- DESCRIPTION :
! 778: -- Additional layer needed for the determination of the updated space.
! 779:
! 780: begin
! 781: for i in modbot'range loop
! 782: if Q_Bottom_Creatable(nd.all,modbot,new_space,lag,perm(i),i)
! 783: then Create_Bottom_Child(root,nd,perm(i),share);
! 784: if k > 1
! 785: then Q_Bottom_Create1(root,nd.children(0,perm(i)),
! 786: false,new_space,k-1,lag);
! 787: end if;
! 788: end if;
! 789: end loop;
! 790: end Recursive_Bottom_Create1;
! 791:
! 792: begin
! 793: if k > 0
! 794: then nd.tp := bottom;
! 795: Modulo(nd.bottom,lag,perm,modbot);
! 796: special := Special_Plane(modbot,lag);
! 797: if first
! 798: then Recursive_Bottom_Create1(special);
! 799: else declare
! 800: int_spc : constant Bracket
! 801: := Intersect_Spaces(space,special);
! 802: begin
! 803: Recursive_Bottom_Create1(int_spc);
! 804: end;
! 805: end if;
! 806: end if;
! 807: end Q_Bottom_Create1;
! 808:
! 809: procedure Top_Bottom_Create1 ( root,nd : in out Link_to_Node;
! 810: n : in natural ) is
! 811:
! 812: -- DESCRIPTION :
! 813: -- Creates new nodes by incrementing top pivots and decrementing bottom
! 814: -- pivots, with n the maximal entry in any pivot.
! 815: -- If no top create is possible, then a bottom create will be done,
! 816: -- and we have only a bottom create when no top create is possible.
! 817:
! 818: nocreate : boolean := true;
! 819:
! 820: begin
! 821: nd.tp := mixed;
! 822: for i in nd.top'range loop -- first do top+bottom
! 823: for j in nd.bottom'range loop
! 824: if Top_Bottom_Creatable(nd.all,n,i,j)
! 825: then Create_Top_Bottom_Child(root,nd,i,j,true);
! 826: nocreate := false;
! 827: end if;
! 828: end loop;
! 829: end loop;
! 830: if nocreate -- no top+bottom create possible
! 831: then Bottom_Create1(root,nd);
! 832: if Is_Leaf(nd.all) -- no bottom create possible
! 833: then Top_Create1(root,nd,n);
! 834: end if;
! 835: end if;
! 836: end Top_Bottom_Create1;
! 837:
! 838: procedure Q_Top_Bottom_Create1 ( root,nd : in out Link_to_Node;
! 839: n,lag : in natural ) is
! 840:
! 841: -- DESCRIPTION :
! 842: -- Creates new nodes by incrementing top pivots and decrementing bottom
! 843: -- pivots, with n the maximal entry in any pivot.
! 844: -- If no top create is possible, then a bottom create will be done,
! 845: -- and we have only a bottom create when no top create is possible.
! 846:
! 847: nocreate : boolean := true;
! 848:
! 849: begin
! 850: nd.tp := mixed;
! 851: for i in nd.top'range loop -- first do top+bottom
! 852: for j in nd.bottom'range loop
! 853: if Q_Top_Bottom_Creatable(nd.all,n,lag,i,j)
! 854: then Create_Top_Bottom_Child(root,nd,i,j,true);
! 855: nocreate := false;
! 856: end if;
! 857: end loop;
! 858: end loop;
! 859: if nocreate -- no top+bottom create possible
! 860: then Q_Bottom_Create1(root,nd,lag);
! 861: if Is_Leaf(nd.all) -- no bottom create possible
! 862: then Q_Top_Create1(root,nd,n,lag);
! 863: end if;
! 864: end if;
! 865: end Q_Top_Bottom_Create1;
! 866:
! 867: procedure Top_Bottom_Create1 ( root,nd : in out Link_to_Node;
! 868: k1,k2,n,c1,c2 : in natural ) is
! 869:
! 870: -- DESCRIPTION :
! 871: -- Applies the hypersurface Top_Bottom_Create max(k1,k2) times,
! 872: -- taking top pivots in c1..p and bottom pivots in 1..c2.
! 873: -- This is the top-bottom create that takes the codimensions in pairs,
! 874: -- which allows more possibilities for sharing.
! 875:
! 876: share : constant boolean := ((k1=1) and (k2=1));
! 877:
! 878: begin
! 879: if (k1 > 0) and (k2 > 0)
! 880: then
! 881: nd.tp := mixed;
! 882: for i in c1..nd.top'last loop -- first do top+bottom
! 883: for j in nd.bottom'first..c2 loop
! 884: if Top_Bottom_Creatable(nd.all,n,i,j)
! 885: then
! 886: Create_Top_Bottom_Child(root,nd,i,j,share);
! 887: if ((k1 > 1) or (k2 > 1))
! 888: then Top_Bottom_Create1(root,nd.children(i,j),k1-1,k2-1,n,i,j);
! 889: end if;
! 890: end if;
! 891: end loop;
! 892: end loop;
! 893: end if;
! 894: if ((k1 = 0) and (k2 > 0))
! 895: then Bottom_Create1(root,nd,k2,c2);
! 896: elsif ((k1 > 0) and (k2 = 0))
! 897: then Top_Create1(root,nd,k1,n,c1);
! 898: end if;
! 899: end Top_Bottom_Create1;
! 900:
! 901: procedure Recursive_Top_Bottom_Create
! 902: ( root,nd : in out Link_to_Node;
! 903: codim : in Bracket; ind,k1,k2,n,c1,c2 : in natural;
! 904: hyper : in boolean ) is
! 905:
! 906: -- DESCRIPTION :
! 907: -- Applies the hypersurface Top_Bottom_Create max(k1,k2) times,
! 908: -- taking top pivots in c1..p and bottom pivots in 1..c2.
! 909: -- In case k1 and/or k2 are zero, new conditions will be treated.
! 910:
! 911: -- ON ENTRY :
! 912: -- root root of the localization poset;
! 913: -- nd current node;
! 914: -- codim list of co-dimension conditions;
! 915: -- ind index of lowest condition being treated;
! 916: -- k1 co-dimension condition satisfied decrementing top pivots;
! 917: -- k2 co-dimension condition satisfied incrementing bottom pivots;
! 918: -- n dimension of the working space;
! 919: -- c1 needed to enforce the top-right rule;
! 920: -- c2 needed to enforce the bottom-left rule;
! 921: -- hyper indicates whether or not in the hypersurface case.
! 922:
! 923: newhyper : boolean;
! 924:
! 925: begin
! 926: if (k1 > 0) and (k2 > 0)
! 927: then
! 928: nd.tp := mixed;
! 929: for i in c1..nd.top'last loop -- first do top+bottom
! 930: for j in nd.bottom'first..c2 loop
! 931: if Top_Bottom_Creatable(nd.all,n,i,j)
! 932: then Create_Top_Bottom_Child(root,nd,i,j,hyper);
! 933: Recursive_Top_Bottom_Create
! 934: (root,nd.children(i,j),codim,ind,k1-1,k2-1,n,i,j,false);
! 935: end if;
! 936: end loop;
! 937: end loop;
! 938: nd.roco := -1;
! 939: else
! 940: if ((k1 = 0) and (k2 > 0))
! 941: then if ind > codim'first
! 942: then Recursive_Top_Bottom_Create
! 943: (root,nd,codim,ind-1,codim(ind-1),k2,n,1,c2,false);
! 944: else Bottom_Create1(root,nd,k2,c2);
! 945: end if;
! 946: elsif ((k1 > 0) and (k2 = 0))
! 947: then if ind > codim'first
! 948: then Recursive_Top_Bottom_Create
! 949: (root,nd,codim,ind-1,k1,codim(ind-1),n,c1,nd.p,false);
! 950: else Top_Create1(root,nd,k1,n,c1);
! 951: end if;
! 952: else -- k1 = 0 and k2 = 0
! 953: if ind > codim'first + 1
! 954: then newhyper
! 955: := ((codim(ind-2) = 1) and (codim(ind-1) = 1));
! 956: Recursive_Top_Bottom_Create
! 957: (root,nd,codim,ind-2,codim(ind-2),codim(ind-1),n,1,
! 958: nd.p,newhyper);
! 959: elsif ind > codim'first
! 960: then Bottom_Create1(root,nd,codim(ind-1),nd.p);
! 961: end if;
! 962: end if;
! 963: end if;
! 964: end Recursive_Top_Bottom_Create;
! 965:
! 966: procedure Q_Recursive_Top_Bottom_Create
! 967: ( root,nd : in out Link_to_Node; codim : in Bracket;
! 968: fsttop : in boolean; topspc : in Bracket;
! 969: fstbot : in boolean; botspc : in Bracket;
! 970: ind,k1,k2,n,lag : in natural; hyper : in boolean ) is
! 971:
! 972: -- DESCRIPTION :
! 973: -- Applies the hypersurface Q_Top_Bottom_Create max(k1,k2) times,
! 974: -- simulating the bottom-left and top-right rules with the modular
! 975: -- brackets and corresponding spaces.
! 976:
! 977: -- ON ENTRY :
! 978: -- root root of the localization poset;
! 979: -- nd current node;
! 980: -- codim list of co-dimension conditions;
! 981: -- fsttop if true, then first step taken using top pivots;
! 982: -- topspc intersection of special m-planes for top pivots;
! 983: -- fstbot if true, then first step taken using bottom pivots;
! 984: -- botspc intersection of special m-planes for bottom pivots;
! 985: -- ind index of lowest condition being treated;
! 986: -- k1 co-dimension condition satisfied decrementing top pivots;
! 987: -- k2 co-dimension condition satisfied incrementing bottom pivots;
! 988: -- n dimension of the working space;
! 989: -- lag space in the poset that is of interest;
! 990: -- hyper indicates whether or not in the hypersurface case.
! 991:
! 992: newhyper : boolean;
! 993: modtop,modbot : Bracket(1..nd.p);
! 994: topprm,botprm : Standard_Natural_Vectors.Vector(1..nd.p);
! 995: top_special,bot_special : Bracket(1..lag-nd.p);
! 996:
! 997: procedure Mixed_Create ( new_top_space,new_bot_space : in Bracket ) is
! 998: begin
! 999: for i in modtop'range loop
! 1000: for j in modbot'range loop
! 1001: if Q_Top_Bottom_Creatable
! 1002: (nd.all,modtop,new_top_space,modbot,new_bot_space,
! 1003: n,lag,topprm(i),i,botprm(j),j)
! 1004: then Create_Top_Bottom_Child(root,nd,topprm(i),botprm(j),hyper);
! 1005: Q_Recursive_Top_Bottom_Create
! 1006: (root,nd.children(topprm(i),botprm(j)),codim,
! 1007: false,new_top_space,false,new_bot_space,
! 1008: ind,k1-1,k2-1,n,lag,false);
! 1009: end if;
! 1010: end loop;
! 1011: end loop;
! 1012: nd.roco := -1;
! 1013: end Mixed_Create;
! 1014:
! 1015: begin
! 1016: if (k1 > 0) and (k2 > 0) -- first do top + bottom
! 1017: then
! 1018: nd.tp := mixed;
! 1019: Modulo(nd.top,lag,topprm,modtop);
! 1020: top_special := Special_Plane(modtop,lag);
! 1021: Modulo(nd.bottom,lag,botprm,modbot);
! 1022: bot_special := Special_Plane(modbot,lag);
! 1023: if fsttop
! 1024: then if fstbot
! 1025: then Mixed_Create(top_special,bot_special);
! 1026: else declare
! 1027: int_spc : constant Bracket
! 1028: := Intersect_Spaces(botspc,bot_special);
! 1029: begin
! 1030: Mixed_Create(top_special,int_spc);
! 1031: end;
! 1032: end if;
! 1033: else if fstbot
! 1034: then declare
! 1035: int_spc : constant Bracket
! 1036: := Intersect_Spaces(topspc,top_special);
! 1037: begin
! 1038: Mixed_Create(int_spc,bot_special);
! 1039: end;
! 1040: else declare
! 1041: int_top : constant Bracket
! 1042: := Intersect_Spaces(topspc,top_special);
! 1043: int_bot : constant Bracket
! 1044: := Intersect_Spaces(botspc,bot_special);
! 1045: begin
! 1046: Mixed_Create(int_top,int_bot);
! 1047: end;
! 1048: end if;
! 1049: end if;
! 1050: else
! 1051: if ((k1 = 0) and (k2 > 0))
! 1052: then if ind > codim'first
! 1053: then Q_Recursive_Top_Bottom_Create
! 1054: (root,nd,codim,true,topspc,fstbot,botspc,
! 1055: ind-1,codim(ind-1),k2,n,lag,false);
! 1056: else Q_Bottom_Create1(root,nd,fstbot,botspc,k2,lag);
! 1057: end if;
! 1058: elsif ((k1 > 0) and (k2 = 0))
! 1059: then if ind > codim'first
! 1060: then Q_Recursive_Top_Bottom_Create
! 1061: (root,nd,codim,fsttop,topspc,true,botspc,
! 1062: ind-1,k1,codim(ind-1),n,lag,false);
! 1063: else Q_Top_Create1(root,nd,fsttop,topspc,k1,n,lag);
! 1064: end if;
! 1065: else -- k1 = 0 and k2 = 0
! 1066: if ind > codim'first + 1
! 1067: then newhyper
! 1068: := ((codim(ind-2) = 1) and (codim(ind-1) = 1));
! 1069: Q_Recursive_Top_Bottom_Create
! 1070: (root,nd,codim,true,topspc,true,botspc,
! 1071: ind-2,codim(ind-2),codim(ind-1),n,lag,newhyper);
! 1072: elsif ind > codim'first
! 1073: then Q_Bottom_Create1
! 1074: (root,nd,true,botspc,codim(ind-1),lag);
! 1075: end if;
! 1076: end if;
! 1077: end if;
! 1078: end Q_Recursive_Top_Bottom_Create;
! 1079:
! 1080: -- TARGET CREATORS :
! 1081:
! 1082: function Trivial_Root ( m,p : natural ) return Node is
! 1083:
! 1084: nd : Node(p);
! 1085:
! 1086: begin
! 1087: nd.level := m*p;
! 1088: nd.roco := 0;
! 1089: for i in 1..p loop
! 1090: nd.top(i) := i;
! 1091: nd.bottom(i) := m+i;
! 1092: end loop;
! 1093: return nd;
! 1094: end Trivial_Root;
! 1095:
! 1096: function Trivial_Root ( m,p,q : natural ) return Node is
! 1097:
! 1098: nd : Node(p);
! 1099: last : natural;
! 1100:
! 1101: begin
! 1102: if q = 0
! 1103: then nd := Trivial_Root(m,p);
! 1104: else nd := Trivial_Root(m,p,q-1);
! 1105: nd.level := nd.level + m+p;
! 1106: last := nd.bottom(1)+m+p;
! 1107: for i in 1..(p-1) loop
! 1108: nd.bottom(i) := nd.bottom(i+1);
! 1109: end loop;
! 1110: nd.bottom(p) := last;
! 1111: end if;
! 1112: return nd;
! 1113: end Trivial_Root;
! 1114:
! 1115: procedure Top_Create ( root : in out Link_to_Node; n : in natural ) is
! 1116:
! 1117: procedure Create_Next ( root,nd : in out Link_to_Node ) is
! 1118: begin
! 1119: if ((nd.level > 0) and (nd.roco >= 0))
! 1120: then Top_Create1(root,nd,n);
! 1121: for i in nd.children'range(1) loop
! 1122: if nd.children(i,0) /= null
! 1123: then Create_Next(root,nd.children(i,0));
! 1124: end if;
! 1125: end loop;
! 1126: nd.roco := -1;
! 1127: end if;
! 1128: end Create_Next;
! 1129:
! 1130: begin
! 1131: Create_Next(root,root);
! 1132: end Top_Create;
! 1133:
! 1134: procedure Q_Top_Create ( root : in out Link_to_Node; n,lag : in natural ) is
! 1135:
! 1136: procedure Create_Next ( root,nd : in out Link_to_Node ) is
! 1137: begin
! 1138: if ((nd.level > 0) and (nd.roco >= 0))
! 1139: then Q_Top_Create1(root,nd,n,lag);
! 1140: for i in nd.children'range(1) loop
! 1141: if nd.children(i,0) /= null
! 1142: then Create_Next(root,nd.children(i,0));
! 1143: end if;
! 1144: end loop;
! 1145: nd.roco := -1;
! 1146: end if;
! 1147: end Create_Next;
! 1148:
! 1149: begin
! 1150: Create_Next(root,root);
! 1151: end Q_Top_Create;
! 1152:
! 1153: procedure Top_Create ( root : in out Link_to_Node;
! 1154: k : in Bracket; n : in natural ) is
! 1155:
! 1156: procedure Create ( current : in out Link_to_Node; ind : in natural );
! 1157:
! 1158: -- DESCRIPTION :
! 1159: -- Creates k(ind) levels above the current node.
! 1160:
! 1161: procedure Create_Children ( child : in out Link_to_Node;
! 1162: cnt,ind : in natural ) is
! 1163:
! 1164: -- DESCRIPTION :
! 1165: -- Goes to the topmost child to create, counting down with cnt.
! 1166:
! 1167: begin
! 1168: if cnt = 0
! 1169: then Create(child,ind);
! 1170: else for i in child.children'range(1) loop
! 1171: if child.children(i,0) /= null
! 1172: then Create_Children(child.children(i,0),cnt-1,ind);
! 1173: end if;
! 1174: end loop;
! 1175: end if;
! 1176: end Create_Children;
! 1177:
! 1178: procedure Create ( current : in out Link_to_Node; ind : in natural ) is
! 1179: begin
! 1180: if ((current.level > 0) and (ind <= k'last) and (current.roco >= 0))
! 1181: then
! 1182: Top_Create1(root,current,k(ind),n,1);
! 1183: if ind > k'first
! 1184: then
! 1185: for i in current.children'range(1) loop
! 1186: if current.children(i,0) /= null
! 1187: then Create_Children(current.children(i,0),k(ind)-1,ind-1);
! 1188: end if;
! 1189: end loop;
! 1190: end if;
! 1191: current.roco := -1;
! 1192: end if;
! 1193: end Create;
! 1194:
! 1195: begin
! 1196: Create(root,k'last);
! 1197: end Top_Create;
! 1198:
! 1199: procedure Q_Top_Create ( root : in out Link_to_Node;
! 1200: k : in Bracket; n,lag : in natural ) is
! 1201:
! 1202: procedure Create ( current : in out Link_to_Node; ind : in natural );
! 1203:
! 1204: -- DESCRIPTION :
! 1205: -- Creates k(ind) levels above the current node.
! 1206:
! 1207: procedure Create_Children ( child : in out Link_to_Node;
! 1208: cnt,ind : in natural ) is
! 1209:
! 1210: -- DESCRIPTION :
! 1211: -- Goes to the topmost child to create, counting down with cnt.
! 1212:
! 1213: begin
! 1214: if cnt = 0
! 1215: then Create(child,ind);
! 1216: else for i in child.children'range(1) loop
! 1217: if child.children(i,0) /= null
! 1218: then Create_Children(child.children(i,0),cnt-1,ind);
! 1219: end if;
! 1220: end loop;
! 1221: end if;
! 1222: end Create_Children;
! 1223:
! 1224: procedure Create ( current : in out Link_to_Node; ind : in natural ) is
! 1225:
! 1226: space : Bracket(1..lag-current.p) := (1..lag-current.p => 0);
! 1227:
! 1228: begin
! 1229: if ((current.level > 0) and (ind <= k'last) and (current.roco >= 0))
! 1230: then
! 1231: Q_Top_Create1(root,current,true,space,k(ind),n,lag);
! 1232: if ind > k'first
! 1233: then
! 1234: for i in current.children'range(1) loop
! 1235: if current.children(i,0) /= null
! 1236: then Create_Children(current.children(i,0),k(ind)-1,ind-1);
! 1237: end if;
! 1238: end loop;
! 1239: end if;
! 1240: current.roco := -1;
! 1241: end if;
! 1242: end Create;
! 1243:
! 1244: begin
! 1245: Create(root,k'last);
! 1246: end Q_Top_Create;
! 1247:
! 1248: procedure Bottom_Create ( root : in out Link_to_Node ) is
! 1249:
! 1250: procedure Create_Next ( root,nd : in out Link_to_Node ) is
! 1251: begin
! 1252: if ((nd.level > 0) and (nd.roco >= 0))
! 1253: then Bottom_Create1(root,nd);
! 1254: for i in nd.children'range(2) loop
! 1255: if nd.children(0,i) /= null
! 1256: then Create_Next(root,nd.children(0,i));
! 1257: end if;
! 1258: end loop;
! 1259: nd.roco := -1;
! 1260: end if;
! 1261: end Create_Next;
! 1262:
! 1263: begin
! 1264: Create_Next(root,root);
! 1265: end Bottom_Create;
! 1266:
! 1267: procedure Q_Bottom_Create ( root : in out Link_to_Node; lag : in natural ) is
! 1268:
! 1269: procedure Create_Next ( root,nd : in out Link_to_Node ) is
! 1270: begin
! 1271: if ((nd.level > 0) and (nd.roco >= 0))
! 1272: then Q_Bottom_Create1(root,nd,lag);
! 1273: for i in nd.children'range(2) loop
! 1274: if nd.children(0,i) /= null
! 1275: then Create_Next(root,nd.children(0,i));
! 1276: end if;
! 1277: end loop;
! 1278: nd.roco := -1;
! 1279: end if;
! 1280: end Create_Next;
! 1281:
! 1282: begin
! 1283: Create_Next(root,root);
! 1284: end Q_Bottom_Create;
! 1285:
! 1286: procedure Bottom_Create ( root : in out Link_to_Node; k : in Bracket ) is
! 1287:
! 1288: procedure Create ( current : in out Link_to_Node; ind : in natural );
! 1289:
! 1290: -- DESCRIPTION :
! 1291: -- Creates k(ind) levels above the current node.
! 1292:
! 1293: procedure Create_Children ( child : in out Link_to_Node;
! 1294: cnt,ind : in natural ) is
! 1295:
! 1296: -- DESCRIPTION :
! 1297: -- Goes to the topmost child to create, counting down with cnt.
! 1298:
! 1299: begin
! 1300: if cnt = 0
! 1301: then Create(child,ind);
! 1302: else for i in child.children'range(1) loop
! 1303: if child.children(0,i) /= null
! 1304: then Create_Children(child.children(0,i),cnt-1,ind);
! 1305: end if;
! 1306: end loop;
! 1307: end if;
! 1308: end Create_Children;
! 1309:
! 1310: procedure Create ( current : in out Link_to_Node; ind : in natural ) is
! 1311: begin
! 1312: if ((current.level > 0) and (ind <= k'last) and (current.roco >= 0))
! 1313: then
! 1314: Bottom_Create1(root,current,k(ind),current.p);
! 1315: if ind > k'first
! 1316: then
! 1317: for i in current.children'range(1) loop
! 1318: if current.children(0,i) /= null
! 1319: then Create_Children(current.children(0,i),k(ind)-1,ind-1);
! 1320: end if;
! 1321: end loop;
! 1322: end if;
! 1323: current.roco := -1;
! 1324: end if;
! 1325: end Create;
! 1326:
! 1327: begin
! 1328: Create(root,k'last);
! 1329: end Bottom_Create;
! 1330:
! 1331: procedure Q_Bottom_Create ( root : in out Link_to_Node; k : in Bracket;
! 1332: lag : in natural ) is
! 1333:
! 1334: procedure Create ( current : in out Link_to_Node; ind : in natural );
! 1335:
! 1336: -- DESCRIPTION :
! 1337: -- Creates k(ind) levels above the current node.
! 1338:
! 1339: procedure Create_Children ( child : in out Link_to_Node;
! 1340: cnt,ind : in natural ) is
! 1341:
! 1342: -- DESCRIPTION :
! 1343: -- Goes to the topmost child to create, counting down with cnt.
! 1344:
! 1345: begin
! 1346: if cnt = 0
! 1347: then Create(child,ind);
! 1348: else for i in child.children'range(1) loop
! 1349: if child.children(0,i) /= null
! 1350: then Create_Children(child.children(0,i),cnt-1,ind);
! 1351: end if;
! 1352: end loop;
! 1353: end if;
! 1354: end Create_Children;
! 1355:
! 1356: procedure Create ( current : in out Link_to_Node; ind : in natural ) is
! 1357:
! 1358: space : Bracket(1..lag-current.p) := (1..lag-current.p => 0);
! 1359:
! 1360: begin
! 1361: if ((current.level > 0) and (ind <= k'last) and (current.roco >= 0))
! 1362: then
! 1363: Q_Bottom_Create1(root,current,true,space,k(ind),lag);
! 1364: if ind > k'first
! 1365: then
! 1366: for i in current.children'range(1) loop
! 1367: if current.children(0,i) /= null
! 1368: then Create_Children(current.children(0,i),k(ind)-1,ind-1);
! 1369: end if;
! 1370: end loop;
! 1371: end if;
! 1372: current.roco := -1;
! 1373: end if;
! 1374: end Create;
! 1375:
! 1376: begin
! 1377: Create(root,k'last);
! 1378: end Q_Bottom_Create;
! 1379:
! 1380: procedure Top_Bottom_Create ( root : in out Link_to_Node; n : in natural ) is
! 1381:
! 1382: procedure Create_Next ( root,nd : in out Link_to_Node ) is
! 1383: begin
! 1384: if ((nd.level > 0) and (nd.roco >= 0))
! 1385: then Top_Bottom_Create1(root,nd,n);
! 1386: for i in nd.children'range(1) loop
! 1387: for j in nd.children'range(2) loop
! 1388: if nd.children(i,j) /= null
! 1389: then Create_Next(root,nd.children(i,j));
! 1390: end if;
! 1391: end loop;
! 1392: end loop;
! 1393: nd.roco := -1;
! 1394: end if;
! 1395: end Create_Next;
! 1396:
! 1397: begin
! 1398: Create_Next(root,root);
! 1399: end Top_Bottom_Create;
! 1400:
! 1401: procedure Q_Top_Bottom_Create ( root : in out Link_to_Node;
! 1402: n,lag : in natural ) is
! 1403:
! 1404: procedure Create_Next ( root,nd : in out Link_to_Node ) is
! 1405: begin
! 1406: if ((nd.level > 0) and (nd.roco >= 0))
! 1407: then Q_Top_Bottom_Create1(root,nd,n,lag);
! 1408: for i in nd.children'range(1) loop
! 1409: for j in nd.children'range(2) loop
! 1410: if nd.children(i,j) /= null
! 1411: then Create_Next(root,nd.children(i,j));
! 1412: end if;
! 1413: end loop;
! 1414: end loop;
! 1415: nd.roco := -1;
! 1416: end if;
! 1417: end Create_Next;
! 1418:
! 1419: begin
! 1420: Create_Next(root,root);
! 1421: end Q_Top_Bottom_Create;
! 1422:
! 1423: procedure Old_Top_Bottom_Create ( root : in out Link_to_Node;
! 1424: k : in Bracket; n : in natural ) is
! 1425:
! 1426: -- NOTE :
! 1427: -- This top-bottom create treats the co-dimension conditions in pairs,
! 1428: -- which allows more possibilities for sharing.
! 1429:
! 1430: procedure Create ( current : in out Link_to_Node; ind : in natural );
! 1431:
! 1432: -- DESCRIPTION :
! 1433: -- Creates k(ind) levels above the current node.
! 1434:
! 1435: procedure Create_Children ( child : in out Link_to_Node;
! 1436: cnt,ind : in natural ) is
! 1437:
! 1438: -- DESCRIPTION :
! 1439: -- Goes to the topmost child to create, counting down with cnt.
! 1440:
! 1441: begin
! 1442: if cnt = 0
! 1443: then Create(child,ind);
! 1444: else for i in child.children'range(1) loop
! 1445: for j in child.children'range(2) loop
! 1446: if child.children(i,j) /= null
! 1447: then Create_Children(child.children(i,j),cnt-1,ind);
! 1448: end if;
! 1449: end loop;
! 1450: end loop;
! 1451: end if;
! 1452: end Create_Children;
! 1453:
! 1454: procedure Create ( current : in out Link_to_Node; ind : in natural ) is
! 1455:
! 1456: cnt : natural;
! 1457:
! 1458: begin
! 1459: if ((current.level > 0) and (current.roco >= 0))
! 1460: then
! 1461: if ind = k'first
! 1462: then Bottom_Create1(root,current,k(ind),current.p);
! 1463: cnt := k(ind);
! 1464: elsif ind > k'first
! 1465: then
! 1466: Top_Bottom_Create1(root,current,k(ind),k(ind-1),n,1,current.p);
! 1467: cnt := max(k(ind),k(ind-1));
! 1468: end if;
! 1469: if ind > k'first-1
! 1470: then for i in current.children'range(1) loop
! 1471: for j in current.children'range(2) loop
! 1472: if current.children(i,j) /= null
! 1473: then Create_Children(current.children(i,j),cnt-1,ind-2);
! 1474: end if;
! 1475: end loop;
! 1476: end loop;
! 1477: end if;
! 1478: current.roco := -1;
! 1479: end if;
! 1480: end Create;
! 1481:
! 1482: begin
! 1483: Create(root,k'last);
! 1484: end Old_Top_Bottom_Create;
! 1485:
! 1486: procedure Top_Bottom_Create ( root : in out Link_to_Node;
! 1487: k : in Bracket; n : in natural ) is
! 1488:
! 1489: ind : constant natural := k'last;
! 1490: hyper : boolean;
! 1491:
! 1492: begin
! 1493: if ind = k'first
! 1494: then Bottom_Create1(root,root,k(k'last),root.p);
! 1495: elsif ind > k'first
! 1496: then hyper := ((k(ind-1) = 1) and (k(ind) = 1));
! 1497: Recursive_Top_Bottom_Create
! 1498: (root,root,k,ind-1,k(ind-1),k(ind),n,1,root.p,hyper);
! 1499: end if;
! 1500: end Top_Bottom_Create;
! 1501:
! 1502: procedure Q_Top_Bottom_Create ( root : in out Link_to_Node;
! 1503: k : in Bracket; n,lag : in natural ) is
! 1504:
! 1505: ind : constant natural := k'last;
! 1506: hyper : boolean;
! 1507: space : Bracket(1..lag-root.p) := (1..lag-root.p => 0);
! 1508:
! 1509: begin
! 1510: if ind = k'first
! 1511: then Q_Bottom_Create1(root,root,true,space,k(k'last),lag);
! 1512: elsif ind > k'first
! 1513: then hyper := ((k(ind-1) = 1) and (k(ind) = 1));
! 1514: Q_Recursive_Top_Bottom_Create
! 1515: (root,root,k,true,space,true,space,
! 1516: ind-1,k(ind-1),k(ind),n,lag,hyper);
! 1517: end if;
! 1518: end Q_Top_Bottom_Create;
! 1519:
! 1520: function Create_Leveled_Poset ( root : Link_to_Node )
! 1521: return Array_of_Nodes is
! 1522:
! 1523: res : Array_of_Nodes(0..root.level);
! 1524:
! 1525: begin
! 1526: for i in res'range loop
! 1527: res(i) := Find_Node(root,i);
! 1528: end loop;
! 1529: return res;
! 1530: end Create_Leveled_Poset;
! 1531:
! 1532: function Create_Indexed_Poset ( poset : Array_of_Nodes )
! 1533: return Array_of_Array_of_Nodes is
! 1534:
! 1535: res : Array_of_Array_of_Nodes(poset'range);
! 1536: ptr : Link_to_Node;
! 1537:
! 1538: begin
! 1539: for i in poset'range loop
! 1540: if poset(i) /= null
! 1541: then res(i) := new Array_of_Nodes(1..Number_of_Siblings(poset(i)));
! 1542: ptr := poset(i);
! 1543: for j in res(i)'range loop
! 1544: res(i)(j) := ptr;
! 1545: res(i)(j).label := j;
! 1546: res(i)(j).child_labels := Labels_of_Children(res,ptr.all);
! 1547: ptr := ptr.next_sibling;
! 1548: end loop;
! 1549: end if;
! 1550: end loop;
! 1551: return res;
! 1552: end Create_Indexed_Poset;
! 1553:
! 1554: -- SELECTORS :
! 1555:
! 1556: function Equal ( nd1,nd2 : Node ) return boolean is
! 1557: begin
! 1558: if nd1.level /= nd2.level
! 1559: then return false;
! 1560: elsif not Equal(nd1.top,nd2.top)
! 1561: then return false;
! 1562: else return Equal(nd1.bottom,nd2.bottom);
! 1563: end if;
! 1564: end Equal;
! 1565:
! 1566: function Is_Leaf ( nd : Node ) return boolean is
! 1567: begin
! 1568: for i in nd.children'range(1) loop
! 1569: for j in nd.children'range(2) loop
! 1570: if nd.children(i,j) /= null
! 1571: then return false;
! 1572: end if;
! 1573: end loop;
! 1574: end loop;
! 1575: return true;
! 1576: end Is_Leaf;
! 1577:
! 1578: function Find_Node ( root : Link_to_Node; lvl : natural )
! 1579: return Link_to_Node is
! 1580:
! 1581: res,fst : Link_to_Node := null;
! 1582:
! 1583: procedure Search_First ( current : in Link_to_Node ) is
! 1584:
! 1585: -- DESCRIPTION :
! 1586: -- Scans the list of previous siblings and sets fst to the node
! 1587: -- that does not have any previous siblings.
! 1588:
! 1589: -- REQUIRED : current /= null.
! 1590:
! 1591: begin
! 1592: if current.prev_sibling = null
! 1593: then fst := current;
! 1594: else Search_First(current.prev_sibling);
! 1595: end if;
! 1596: end Search_First;
! 1597:
! 1598: begin
! 1599: if root.level = lvl
! 1600: then res := root;
! 1601: elsif root.level > lvl
! 1602: then for i in root.children'range(1) loop
! 1603: for j in root.children'range(2) loop
! 1604: if root.children(i,j) /= null
! 1605: then res := Find_Node(root.children(i,j),lvl);
! 1606: end if;
! 1607: exit when (res /= null);
! 1608: end loop;
! 1609: exit when (res /= null);
! 1610: end loop;
! 1611: end if;
! 1612: if res = null
! 1613: then fst := res;
! 1614: else Search_First(res);
! 1615: end if;
! 1616: return fst;
! 1617: end Find_Node;
! 1618:
! 1619: function Number_of_Siblings ( nd : Link_to_Node ) return natural is
! 1620: begin
! 1621: if nd = null
! 1622: then return 0;
! 1623: else return 1 + Number_of_Siblings(nd.next_sibling);
! 1624: end if;
! 1625: end Number_of_Siblings;
! 1626:
! 1627: function Number_of_Children ( nd : Node ) return natural is
! 1628:
! 1629: cnt : natural := 0;
! 1630:
! 1631: begin
! 1632: for i in nd.children'range(1) loop
! 1633: for j in nd.children'range(2) loop
! 1634: if nd.children(i,j) /= null
! 1635: then cnt := cnt + 1;
! 1636: end if;
! 1637: end loop;
! 1638: end loop;
! 1639: return cnt;
! 1640: end Number_of_Children;
! 1641:
! 1642: -- ITERATORS :
! 1643:
! 1644: procedure Enumerate_Siblings ( nd : in Node ) is
! 1645:
! 1646: cont : boolean := true;
! 1647:
! 1648: begin
! 1649: Report(nd,cont);
! 1650: if cont and nd.next_sibling /= null
! 1651: then Enumerate_Siblings(nd.next_sibling.all);
! 1652: end if;
! 1653: end Enumerate_Siblings;
! 1654:
! 1655: procedure Enumerate_Grand_Children ( nd : in Node; k : in positive ) is
! 1656:
! 1657: cont : boolean := true;
! 1658:
! 1659: procedure Enumerate_Children ( current : in node; l : in positive ) is
! 1660: begin
! 1661: for i in current.children'range(1) loop
! 1662: for j in current.children'range(1) loop
! 1663: if current.children(i,j) /= null
! 1664: then if l = 1
! 1665: then Report(current.children(i,j),cont);
! 1666: else Enumerate_Children(current.children(i,j).all,l-1);
! 1667: end if;
! 1668: end if;
! 1669: exit when not cont;
! 1670: end loop;
! 1671: exit when not cont;
! 1672: end loop;
! 1673: end Enumerate_Children;
! 1674:
! 1675: begin
! 1676: Enumerate_Children(nd,k);
! 1677: end Enumerate_Grand_Children;
! 1678:
! 1679: procedure Modify_Siblings ( nd : in out Node ) is
! 1680:
! 1681: cont : boolean := true;
! 1682:
! 1683: begin
! 1684: Modify(nd,cont);
! 1685: if cont and nd.next_sibling /= null
! 1686: then Modify_Siblings(nd.next_sibling.all);
! 1687: end if;
! 1688: end Modify_Siblings;
! 1689:
! 1690: -- COMBINATORIAL ROOT COUNTING :
! 1691:
! 1692: procedure Count_Roots ( poset : in out Array_of_Nodes ) is
! 1693:
! 1694: procedure Initialize ( nd : in out Node; continue : out boolean ) is
! 1695: begin
! 1696: nd.roco := 1;
! 1697: continue := true;
! 1698: end Initialize;
! 1699: procedure Initialize_Leaves is new Modify_Siblings(Initialize);
! 1700:
! 1701: procedure Add_Children ( nd : in out Node; continue : out boolean ) is
! 1702: begin
! 1703: nd.roco := 0;
! 1704: for i in nd.children'range(1) loop
! 1705: for j in nd.children'range(2) loop
! 1706: if nd.children(i,j) /= null
! 1707: then nd.roco := nd.roco + nd.children(i,j).roco;
! 1708: end if;
! 1709: end loop;
! 1710: end loop;
! 1711: continue := true;
! 1712: end Add_Children;
! 1713: procedure Add_Children_Counts is new Modify_Siblings(Add_Children);
! 1714:
! 1715: begin
! 1716: if poset(0) /= null
! 1717: then Initialize_Leaves(poset(0).all);
! 1718: end if;
! 1719: for i in 1..poset'last loop
! 1720: if poset(i) /= null
! 1721: then Add_Children_Counts(poset(i).all);
! 1722: end if;
! 1723: end loop;
! 1724: end Count_Roots;
! 1725:
! 1726: function Row_Root_Count_Sum
! 1727: ( poset : Array_of_Nodes; i : natural ) return natural is
! 1728:
! 1729: res : natural := 0;
! 1730:
! 1731: procedure Count ( lnd : in Link_to_Node ) is
! 1732: begin
! 1733: if lnd /= null
! 1734: then res := res + lnd.roco;
! 1735: Count(lnd.next_sibling);
! 1736: end if;
! 1737: end Count;
! 1738:
! 1739: begin
! 1740: Count(poset(i));
! 1741: return res;
! 1742: end Row_Root_Count_Sum;
! 1743:
! 1744: function Root_Count_Sum ( poset : Array_of_Nodes ) return natural is
! 1745:
! 1746: res : natural := 0;
! 1747:
! 1748: begin
! 1749: for i in 1..poset'last loop
! 1750: res := res + Row_Root_Count_Sum(poset,i);
! 1751: end loop;
! 1752: return res;
! 1753: end Root_Count_Sum;
! 1754:
! 1755: -- DESTRUCTORS :
! 1756:
! 1757: procedure free is new unchecked_deallocation(Node,Link_to_Node);
! 1758: procedure free is
! 1759: new unchecked_deallocation(Array_of_Nodes,Link_to_Array_of_Nodes);
! 1760:
! 1761: procedure Clear ( nd : in out Node ) is
! 1762: begin
! 1763: if nd.next_sibling /= null
! 1764: then Clear(nd.next_sibling);
! 1765: end if;
! 1766: end Clear;
! 1767:
! 1768: procedure Clear ( lnd : in out Link_to_Node ) is
! 1769: begin
! 1770: if lnd /= null
! 1771: then Clear(lnd.all);
! 1772: free(lnd);
! 1773: end if;
! 1774: end Clear;
! 1775:
! 1776: procedure Clear ( arrnd : in out Array_of_Nodes ) is
! 1777: begin
! 1778: for i in arrnd'range loop
! 1779: Clear(arrnd(i));
! 1780: end loop;
! 1781: end Clear;
! 1782:
! 1783: procedure Clear ( arrnd : in out Link_to_Array_of_Nodes ) is
! 1784:
! 1785: procedure free is
! 1786: new unchecked_deallocation(Array_of_Nodes,Link_to_Array_of_Nodes);
! 1787:
! 1788: begin
! 1789: if arrnd /= null
! 1790: then Clear(arrnd.all);
! 1791: free(arrnd);
! 1792: end if;
! 1793: end Clear;
! 1794:
! 1795: procedure Clear ( arrnd : in out Array_of_Array_of_Nodes ) is
! 1796: begin
! 1797: for i in arrnd'range loop
! 1798: Clear(arrnd(i));
! 1799: end loop;
! 1800: end Clear;
! 1801:
! 1802: procedure Clear ( matnd : in out Matrix_of_Nodes ) is
! 1803: begin
! 1804: for i in matnd'range(1) loop
! 1805: for j in matnd'range(2) loop
! 1806: if matnd(i,j) /= null
! 1807: then free(matnd(i,j));
! 1808: end if;
! 1809: end loop;
! 1810: end loop;
! 1811: end Clear;
! 1812:
! 1813: end Localization_Posets;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to localization_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