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