Annotation of OpenXM_contrib/PHC/Ada/Schubert/pieri_trees.adb, Revision 1.1
1.1 ! maekawa 1: with unchecked_deallocation;
! 2:
! 3: package body Pieri_Trees is
! 4:
! 5: -- UTILITIES FOR CREATION OF Pieri Trees :
! 6:
! 7: function Index_of_Increase ( nd : Pieri_Node ) return natural is
! 8:
! 9: -- DESCRIPTION :
! 10: -- Returns the index of increase between the current node nd and the
! 11: -- ancestor node. If the current node is the root, then the index
! 12: -- of increase equals zero.
! 13:
! 14: bnd : Link_to_Pieri_Node;
! 15:
! 16: begin
! 17: if nd.ancestor = null
! 18: then return 0;
! 19: else bnd := nd.ancestor;
! 20: for i in nd.node'range loop
! 21: if bnd.node(i) = nd.node(i)-1
! 22: then return i;
! 23: end if;
! 24: end loop;
! 25: return 0;
! 26: end if;
! 27: end Index_of_increase;
! 28:
! 29: function Branching_Level ( l : natural; r : Vector ) return boolean is
! 30:
! 31: -- DESCRIPTION :
! 32: -- Returns true if the current level l is a level where decreasing
! 33: -- is allowed.
! 34:
! 35: bl : natural := 1;
! 36:
! 37: begin
! 38: for i in r'first..r'last-1 loop
! 39: bl := bl + r(i);
! 40: if bl = l
! 41: then return true;
! 42: elsif bl > l
! 43: then return false;
! 44: end if;
! 45: end loop;
! 46: return false;
! 47: end Branching_Level;
! 48:
! 49: procedure Create_Next ( n,d,l,h : in natural; r : in Vector;
! 50: nd : in out Link_to_Pieri_Node ) is
! 51:
! 52: -- DESCRIPTION :
! 53: -- Creates next level of nodes in the Pieri Tree.
! 54:
! 55: -- ON ENTRY :
! 56: -- n maximal entry in a bracket, dimension of whole space;
! 57: -- d number of entries in bracket;
! 58: -- l current level, must be strictly lower than h;
! 59: -- h height of the Pieri tree;
! 60: -- nd current node.
! 61:
! 62: -- ON RETURN :
! 63: -- nd node with updated links.
! 64:
! 65: indinc : constant natural := Index_of_Increase(nd.all);
! 66:
! 67: begin
! 68: if Branching_Level(l,r) -- test if jumping-branching node
! 69: then nd.i := 0;
! 70: nd.c := nd.ancestor.c + 1;
! 71: end if;
! 72: if nd.node(d) < n -- create right node
! 73: then declare
! 74: rnd : Pieri_Node(d);
! 75: lnd : Link_to_Pieri_Node;
! 76: begin
! 77: rnd.node := nd.node; -- adjust entries
! 78: rnd.node(d) := rnd.node(d)+1;
! 79: rnd.c := nd.c;
! 80: rnd.i := nd.i + 1;
! 81: rnd.h := nd.h + 1;
! 82: lnd := new Pieri_Node'(rnd);
! 83: lnd.ancestor := nd; -- establish connections
! 84: nd.children(d) := lnd;
! 85: if l < h -- go to next level
! 86: then Create_Next(n,d,l+1,h,r,lnd);
! 87: end if;
! 88: end;
! 89: end if;
! 90: for i in nd.node'first..(nd.node'last-1) loop
! 91: if nd.node(i) < nd.node(i+1) - 1
! 92: then if ((i >= indinc)
! 93: or else ((nd.i = 0) and (nd.c > 0))) -- jumping-branching
! 94: then declare -- create node
! 95: rnd : Pieri_Node(d);
! 96: lnd : Link_to_Pieri_Node;
! 97: begin
! 98: rnd.node := nd.node; -- adjust entries
! 99: rnd.node(i) := rnd.node(i)+1;
! 100: rnd.c := nd.c;
! 101: rnd.i := nd.i + 1;
! 102: rnd.h := nd.h + 1;
! 103: lnd := new Pieri_Node'(rnd);
! 104: lnd.ancestor := nd; -- establish connections
! 105: nd.children(i) := lnd;
! 106: if l < h -- go to next level
! 107: then Create_Next(n,d,l+1,h,r,lnd);
! 108: end if;
! 109: end;
! 110: end if;
! 111: end if;
! 112: end loop;
! 113: end Create_Next;
! 114:
! 115: -- CREATOR :
! 116:
! 117: function Create ( n,d : natural; r : Vector ) return Pieri_Tree is
! 118:
! 119: res : Pieri_Tree(d,r'last);
! 120: hei : natural;
! 121: pnd : Pieri_Node(d);
! 122:
! 123: begin
! 124: res.branches := r;
! 125: for i in pnd.node'range loop -- root node = [1 2 .. d]
! 126: pnd.node(i) := i;
! 127: end loop;
! 128: pnd.c := 0;
! 129: pnd.i := 0;
! 130: pnd.h := 0;
! 131: res.root := new Pieri_Node'(pnd);
! 132: res.root.ancestor := null;
! 133: hei := Height(res);
! 134: if hei > 0
! 135: then Create_Next(n,d,1,hei,r,res.root); -- create children
! 136: end if;
! 137: return res;
! 138: end Create;
! 139:
! 140: -- SELECTORS :
! 141:
! 142: function Height ( t : Pieri_Tree ) return natural is
! 143:
! 144: res : natural := 0;
! 145:
! 146: begin
! 147: for i in t.branches'range loop
! 148: res := res + t.branches(i);
! 149: end loop;
! 150: return res;
! 151: end Height;
! 152:
! 153: function Is_Leaf ( nd : Pieri_Node ) return boolean is
! 154: begin
! 155: for i in nd.children'range loop
! 156: if nd.children(i) /= null
! 157: then return false;
! 158: end if;
! 159: end loop;
! 160: return true;
! 161: end Is_Leaf;
! 162:
! 163: function Jump ( b1,b2 : Bracket ) return natural is
! 164: begin
! 165: for i in reverse b1'range loop
! 166: if b1(i) < b2(i)
! 167: then return i;
! 168: end if;
! 169: end loop;
! 170: return 0;
! 171: end Jump;
! 172:
! 173: function Jump ( nd : Pieri_Node ) return natural is
! 174: begin
! 175: if nd.ancestor = null
! 176: then return 0;
! 177: else return Jump(nd.ancestor.node,nd.node);
! 178: end if;
! 179: end Jump;
! 180:
! 181: function Lower_Jump_Decrease ( nd : Pieri_Node ) return Bracket is
! 182: begin
! 183: if ((nd.i = 0) or else (nd.c = 0))
! 184: then return nd.node;
! 185: elsif nd.ancestor /= null
! 186: then return Lower_Jump_Decrease(nd.ancestor.all);
! 187: else return nd.node;
! 188: end if;
! 189: end Lower_Jump_Decrease;
! 190:
! 191: function Lowest_Jump_Decrease ( nd : Pieri_Node ) return Bracket is
! 192: begin
! 193: if (nd.c = 0) or ((nd.i = 0) and (nd.c = 1))
! 194: then return nd.node;
! 195: elsif nd.ancestor /= null
! 196: then return Lowest_Jump_Decrease(nd.ancestor.all);
! 197: else return nd.node;
! 198: end if;
! 199: end Lowest_Jump_Decrease;
! 200:
! 201: function Upper_Jump_Decrease ( nd : Pieri_Node ) return Bracket is
! 202: begin
! 203: if ((nd.i = 0) or else (nd.c = 0))
! 204: then return nd.node;
! 205: elsif nd.children(nd.node'last) /= null
! 206: then return Upper_Jump_Decrease(nd.children(nd.node'last).all);
! 207: else return nd.node;
! 208: end if;
! 209: end Upper_Jump_Decrease;
! 210:
! 211: procedure Enumerate_Nodes ( t : in Pieri_Tree; level : in natural ) is
! 212:
! 213: continue : boolean := true;
! 214:
! 215: procedure Visit_Nodes ( nd : in Link_to_Pieri_Node ) is
! 216: begin
! 217: if nd.h = level
! 218: then Visit_Node(nd,continue);
! 219: else for i in nd.children'range loop
! 220: if nd.children(i) /= null
! 221: then Visit_Nodes(nd.children(i));
! 222: end if;
! 223: exit when not continue;
! 224: end loop;
! 225: end if;
! 226: end Visit_Nodes;
! 227:
! 228: begin
! 229: if t.root /= null
! 230: then Visit_Nodes(t.root);
! 231: end if;
! 232: end Enumerate_Nodes;
! 233:
! 234: procedure Enumerate_Chains ( t : in Pieri_Tree ) is
! 235:
! 236: b : Bracket_Array(1..Height(t));
! 237: continue : boolean := true;
! 238:
! 239: procedure Visit_Nodes ( nd : in Pieri_Node; ind : in natural ) is
! 240: begin
! 241: b(ind) := new Bracket'(nd.node);
! 242: if ind = b'last
! 243: then Visit_Chain(b,continue);
! 244: else for i in nd.children'range loop
! 245: if nd.children(i) /= null
! 246: then Visit_Nodes(nd.children(i).all,ind+1);
! 247: end if;
! 248: exit when not continue;
! 249: end loop;
! 250: end if;
! 251: end Visit_Nodes;
! 252:
! 253: begin
! 254: if t.root /= null
! 255: then Visit_Nodes(t.root.all,1);
! 256: end if;
! 257: end Enumerate_Chains;
! 258:
! 259: procedure Enumerate_Paired_Chains ( t1,t2 : in Pieri_Tree ) is
! 260:
! 261: continue : boolean := true;
! 262:
! 263: procedure Outer_Chain ( ob : in Bracket_Array; cont : out boolean ) is
! 264:
! 265: procedure Inner_Chain ( ib : in Bracket_Array; cont : out boolean ) is
! 266: begin
! 267: Visit_Paired_Chain(ob,ib,continue);
! 268: cont := continue;
! 269: end Inner_Chain;
! 270: procedure Inner_Chains is new Enumerate_Chains(Inner_Chain);
! 271:
! 272: begin
! 273: Inner_Chains(t2);
! 274: cont := continue;
! 275: end Outer_Chain;
! 276: procedure Outer_Chains is new Enumerate_Chains(Outer_Chain);
! 277:
! 278: begin
! 279: Outer_Chains(t1);
! 280: end Enumerate_Paired_Chains;
! 281:
! 282: function Pieri_Condition ( n : natural; b1,b2 : Bracket ) return boolean is
! 283: begin
! 284: for i in b2'range loop
! 285: if b2(i) > n+1 - b1(b1'last+1-i) -- negation of weak inequality
! 286: then return false;
! 287: end if;
! 288: end loop;
! 289: for i in b1'first..b1'last-1 loop
! 290: if n+1-b1(b1'last+1-i) >= b2(i+1) -- negation of strong inequality
! 291: then return false;
! 292: end if;
! 293: end loop;
! 294: return true;
! 295: end Pieri_Condition;
! 296:
! 297: -- DESTRUCTOR :
! 298:
! 299: procedure Clear ( nd : in out Link_to_Pieri_Node ) is
! 300:
! 301: procedure free is new unchecked_deallocation(Pieri_Node,Link_to_Pieri_Node);
! 302:
! 303: begin
! 304: if nd /= null
! 305: then free(nd);
! 306: end if;
! 307: end Clear;
! 308:
! 309: procedure Clear_Children ( nd : in out Link_to_Pieri_Node ) is
! 310:
! 311: -- DESCRIPTION :
! 312: -- Deallocation of the memory of all the children, before the memory
! 313: -- occupied by the current node nd is released. Applied recursively.
! 314:
! 315: begin
! 316: for i in nd.children'range loop
! 317: if nd.children(i) /= null
! 318: then Clear_Children(nd.children(i));
! 319: end if;
! 320: end loop;
! 321: Clear(nd);
! 322: end Clear_Children;
! 323:
! 324: procedure Clear ( t : in out Pieri_Tree ) is
! 325: begin
! 326: Clear_Children(t.root);
! 327: end Clear;
! 328:
! 329: end Pieri_Trees;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to pieri_trees.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