Annotation of OpenXM_contrib/PHC/Ada/Schubert/pieri_root_counts.adb, Revision 1.1
1.1 ! maekawa 1: with unchecked_deallocation;
! 2: with integer_io; use integer_io;
! 3: with Brackets; use Brackets;
! 4: with Brackets_io; use Brackets_io;
! 5: with Pieri_Trees_io; use Pieri_Trees_io;
! 6:
! 7: package body Pieri_Root_Counts is
! 8:
! 9: procedure free is new unchecked_deallocation(Nodal_Pair,Link_to_Nodal_Pair);
! 10:
! 11: type Boolean_Array is array ( integer range <> ) of boolean;
! 12:
! 13: function Create ( n,d : natural; t1,t2 : Pieri_Tree )
! 14: return List_of_Paired_Nodes is
! 15:
! 16: res,res_last : List_of_Paired_Nodes;
! 17: h1 : constant natural := Height(t1);
! 18: h2 : constant natural := Height(t2);
! 19: b1,b2 : Bracket(1..d);
! 20: firstlnd : Link_to_Pieri_Node;
! 21: cnt : natural := 0;
! 22:
! 23: procedure Check_Pair ( lnd : in Link_to_Pieri_Node;
! 24: continue : out boolean ) is
! 25: begin
! 26: b2 := lnd.node;
! 27: if Pieri_Condition(n,b1,b2)
! 28: then declare
! 29: lpnd : Paired_Nodes;
! 30: begin
! 31: lpnd.left := firstlnd;
! 32: lpnd.right := lnd;
! 33: Append(res,res_last,lpnd);
! 34: end ;
! 35: end if;
! 36: continue := true;
! 37: end Check_Pair;
! 38: procedure Check_Pairs is new Enumerate_Nodes(Check_Pair);
! 39:
! 40: procedure Count_First ( lnd : in Link_to_Pieri_Node;
! 41: continue : out boolean ) is
! 42: begin
! 43: b1 := lnd.node;
! 44: firstlnd := lnd;
! 45: Check_Pairs(t2,h2);
! 46: continue := true;
! 47: end Count_First;
! 48: procedure First_Leaves is new Enumerate_Nodes(Count_First);
! 49:
! 50: begin
! 51: First_Leaves(t1,h1);
! 52: return res;
! 53: end Create;
! 54:
! 55: function Create ( pnd : Paired_Nodes ) return Paired_Chain is
! 56:
! 57: res : Paired_Chain(1..Height(pnd));
! 58: ind : natural := res'last;
! 59:
! 60: begin
! 61: res(ind) := pnd;
! 62: while not At_First_Branch_Point(res(ind)) loop -- fill in
! 63: ind := ind - 1;
! 64: res(ind) := Ancestor(res(ind+1));
! 65: end loop;
! 66: if ind = 1
! 67: then return res;
! 68: else for i in 1..res'last-ind+1 loop -- shift down
! 69: res(i) := res(i+ind-1);
! 70: end loop;
! 71: return res(1..res'last-ind+1);
! 72: end if;
! 73: end Create;
! 74:
! 75: procedure Connect ( ancnp,np : in out Link_to_Nodal_Pair ) is
! 76:
! 77: -- DESCRIPTION :
! 78: -- Connects the ancestor paired nodes with the paired nodes np.
! 79:
! 80: ancpnd : Paired_Nodes := Ancestor(np.pnd);
! 81: j1 : constant natural := Jump(ancpnd.left.node,np.pnd.left.node);
! 82: j2 : constant natural := Jump(ancpnd.right.node,np.pnd.right.node);
! 83:
! 84: begin
! 85: ancnp.pnd := ancpnd;
! 86: ancnp.children(j1,j2) := np;
! 87: np.ancestor := ancnp;
! 88: end Connect;
! 89:
! 90: procedure Initial_Branch ( root,np : in out Link_to_Nodal_Pair ) is
! 91:
! 92: -- DESCRIPTION :
! 93: -- Constructs the initial branch in the tree of paired nodes.
! 94:
! 95: begin
! 96: if At_First_Branch_Point(np.pnd)
! 97: then root := np;
! 98: else declare
! 99: acc : Link_to_Nodal_Pair := new Nodal_Pair(np.d);
! 100: begin
! 101: acc.sols := 1;
! 102: Connect(acc,np);
! 103: Initial_Branch(root,acc);
! 104: end;
! 105: end if;
! 106: end Initial_Branch;
! 107:
! 108: procedure Merge ( root : in Nodal_Pair;
! 109: current : in out Link_to_Nodal_Pair; k : in natural;
! 110: chain : in Paired_Chain ) is
! 111:
! 112: -- DESCRIPTION :
! 113: -- Merges the chain with the root of the tree, at level k.
! 114:
! 115: j1,j2 : natural;
! 116:
! 117: begin
! 118: j1 := Jump(chain(k).left.node,chain(k+1).left.node);
! 119: j2 := Jump(chain(k).right.node,chain(k+1).right.node);
! 120: if current.children(j1,j2) = null
! 121: then declare
! 122: newnp : Link_to_Nodal_Pair := new Nodal_Pair(current.d);
! 123: begin
! 124: newnp.pnd := chain(k+1);
! 125: if Is_In(root,newnp.pnd)
! 126: then newnp.sols := 0;
! 127: else newnp.sols := 1;
! 128: end if;
! 129: current.children(j1,j2) := newnp;
! 130: newnp.ancestor := current;
! 131: end;
! 132: else if current.children(j1,j2).sols > 0
! 133: then current.children(j1,j2).sols
! 134: := current.children(j1,j2).sols + 1;
! 135: end if;
! 136: end if;
! 137: if k+1 < chain'last
! 138: then Merge(root,current.children(j1,j2),k+1,chain);
! 139: end if;
! 140: end Merge;
! 141:
! 142: function Create ( d : natural; lp : List_of_Paired_Nodes )
! 143: return Nodal_Pair is
! 144:
! 145: root : Nodal_Pair(d);
! 146: lroot : Link_to_Nodal_Pair := new Nodal_Pair'(root);
! 147: first : Link_to_Nodal_Pair := new Nodal_Pair(d);
! 148: tmp : List_of_Paired_Nodes := Tail_Of(lp);
! 149:
! 150: begin
! 151: first.pnd := Head_Of(lp);
! 152: first.sols := 1;
! 153: lroot.sols := 1;
! 154: Initial_Branch(lroot,first);
! 155: while not Is_Null(tmp) loop
! 156: declare
! 157: pnd : Paired_Nodes := Head_Of(tmp);
! 158: chn : constant Paired_Chain := Create(pnd);
! 159: begin
! 160: lroot.sols := lroot.sols + 1;
! 161: Merge(lroot.all,lroot,1,chn);
! 162: end;
! 163: tmp := Tail_Of(tmp);
! 164: end loop;
! 165: return lroot.all;
! 166: end Create;
! 167:
! 168: -- SELECTORS :
! 169:
! 170: function Height ( pnd : Paired_Nodes ) return natural is
! 171: begin
! 172: if pnd.left.h >= pnd.right.h
! 173: then return pnd.left.h;
! 174: else return pnd.right.h;
! 175: end if;
! 176: end Height;
! 177:
! 178: function Equal ( pnd1,pnd2 : Paired_Nodes ) return boolean is
! 179: begin
! 180: return (Is_Equal(pnd1.left.node,pnd2.left.node)
! 181: and Is_Equal(pnd1.right.node,pnd2.right.node));
! 182: end Equal;
! 183:
! 184: function At_First_Branch_Point ( pnd : Paired_Nodes ) return boolean is
! 185: begin
! 186: if pnd.left.h /= pnd.right.h
! 187: then return false;
! 188: elsif ((pnd.left.c > 1) or (pnd.right.c > 1))
! 189: then return false;
! 190: else return (((pnd.left.i = 0) and (pnd.left.c = 1))
! 191: or else ((pnd.right.i = 0) and (pnd.right.c = 1)));
! 192: end if;
! 193: end At_First_Branch_Point;
! 194:
! 195: function At_Leaves ( pnd : Paired_Nodes ) return boolean is
! 196: begin
! 197: return (Is_Leaf(pnd.left.all) and Is_Leaf(pnd.right.all));
! 198: end At_Leaves;
! 199:
! 200: function Ancestor ( pnd : Paired_Nodes ) return Paired_Nodes is
! 201:
! 202: res : Paired_Nodes;
! 203:
! 204: begin
! 205: if pnd.left.h = pnd.right.h
! 206: then res.left := pnd.left.ancestor;
! 207: res.right := pnd.right.ancestor;
! 208: elsif pnd.left.h > pnd.right.h
! 209: then res.left := pnd.left.ancestor;
! 210: res.right := pnd.right;
! 211: else res.left := pnd.left;
! 212: res.right := pnd.right.ancestor;
! 213: end if;
! 214: return res;
! 215: end Ancestor;
! 216:
! 217: function First_Branch_Point ( pnd : Paired_Nodes ) return Paired_Nodes is
! 218: begin
! 219: if At_First_Branch_Point(pnd)
! 220: then return pnd;
! 221: else return First_Branch_Point(Ancestor(pnd));
! 222: end if;
! 223: end First_Branch_Point;
! 224:
! 225: function Height ( np : Nodal_Pair ) return natural is
! 226: begin
! 227: if np.pnd.left.h >= np.pnd.right.h
! 228: then return np.pnd.left.h;
! 229: else return np.pnd.right.h;
! 230: end if;
! 231: end Height;
! 232:
! 233: function Is_In ( root : Nodal_Pair; pnd : Paired_Nodes ) return boolean is
! 234: begin
! 235: if Equal(root.pnd,pnd)
! 236: then return true;
! 237: else for j1 in root.children'range(1) loop
! 238: for j2 in root.children'range(2) loop
! 239: if root.children(j1,j2) /= null
! 240: then if Is_In(root.children(j1,j2).all,pnd)
! 241: then return true;
! 242: end if;
! 243: end if;
! 244: end loop;
! 245: end loop;
! 246: end if;
! 247: return false;
! 248: end Is_In;
! 249:
! 250: function Number_of_Paths ( root : Nodal_Pair ) return natural is
! 251:
! 252: res : natural := root.sols;
! 253:
! 254: begin
! 255: for j1 in root.children'range(1) loop
! 256: for j2 in root.children'range(2) loop
! 257: if root.children(j1,j2) /= null
! 258: then if not At_Leaves(root.children(j1,j2).pnd)
! 259: then res := res + Number_of_Paths(root.children(j1,j2).all);
! 260: end if;
! 261: end if;
! 262: end loop;
! 263: end loop;
! 264: return res;
! 265: end Number_of_Paths;
! 266:
! 267: -- FORMATTED OUTPUT :
! 268:
! 269: procedure Write ( file : in file_type; chn : in Paired_Chain ) is
! 270: begin
! 271: for i in chn'first..(chn'last-1) loop
! 272: put(file,"("); put(file,chn(i).left.node);
! 273: put(file,","); put(file,chn(i).right.node); put(file,") < ");
! 274: end loop;
! 275: put(file,"("); put(file,chn(chn'last).left.node);
! 276: put(file,","); put(file,chn(chn'last).right.node); put_line(file,")");
! 277: end Write;
! 278:
! 279: function Last_Child ( np : Nodal_Pair; i,j : natural ) return boolean is
! 280:
! 281: -- DESCRIPTION :
! 282: -- Returns true if the (i,j)th child is the last child of the node.
! 283:
! 284: begin
! 285: for j1 in j+1..np.children'last(2) loop
! 286: if np.children(i,j1) /= null
! 287: then return false;
! 288: end if;
! 289: end loop;
! 290: for i1 in i+1..np.children'last(1) loop
! 291: for j1 in np.children'range(2) loop
! 292: if np.children(i1,j1) /= null
! 293: then return false;
! 294: end if;
! 295: end loop;
! 296: end loop;
! 297: return true;
! 298: end Last_Child;
! 299:
! 300: procedure Write_Labels ( file : in file_type; np : in Nodal_Pair;
! 301: j1,j2,h : in natural; last : in Boolean_Array ) is
! 302:
! 303: -- DESCRIPTION :
! 304: -- Writes the contents of the nodal pair with the jumps, taking into
! 305: -- account which children appeared last.
! 306: -- The current node is at height h in the nodal pair tree.
! 307:
! 308: first : Paired_Nodes := First_Branch_Point(np.pnd);
! 309:
! 310: begin
! 311: if h /= 0
! 312: then put(file," ");
! 313: end if;
! 314: for i in 1..h-1 loop
! 315: if last(i)
! 316: then put(file," ");
! 317: else put(file,"| ");
! 318: end if;
! 319: end loop;
! 320: if h /= 0
! 321: then put(file,"!-+(");
! 322: put(file,j1,1); put(file,","); put(file,j2,1);
! 323: put(file,")");
! 324: end if;
! 325: put(file,"("); put(file,np.pnd.left.node);
! 326: put(file,","); put(file,np.pnd.right.node);
! 327: put(file,") ");
! 328: put(file,np.sols,1);
! 329: new_line(file);
! 330: end Write_Labels;
! 331:
! 332: procedure Write_Nodes ( file : in file_type; np : in Nodal_Pair;
! 333: j1,j2,h : in natural; last : in out Boolean_Array ) is
! 334:
! 335: -- DESCRIPTION :
! 336: -- Writes the contents of the nodal pair, followed by the children.
! 337:
! 338: begin
! 339: Write_Labels(file,np,j1,j2,h,last);
! 340: for jj1 in np.children'range(1) loop
! 341: for jj2 in np.children'range(2) loop
! 342: if np.children(jj1,jj2) /= null
! 343: then last(h+1) := Last_Child(np,jj1,jj2);
! 344: Write_Nodes(file,np.children(jj1,jj2).all,jj1,jj2,h+1,last);
! 345: end if;
! 346: end loop;
! 347: end loop;
! 348: end Write_Nodes;
! 349:
! 350: procedure Write ( file : in file_type; root : in Nodal_Pair ) is
! 351:
! 352: last : Boolean_Array(1..Height(root)+1);
! 353:
! 354: begin
! 355: Write_Nodes(file,root,1,1,0,last);
! 356: end Write;
! 357:
! 358: end Pieri_Root_Counts;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to pieri_root_counts.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