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