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