File Coverage

blib/lib/Tree/Ops.pm
Criterion Covered Total %
statement 390 396 98.4
branch 128 160 80.0
condition 28 40 70.0
subroutine 94 94 100.0
pod 66 67 98.5
total 706 757 93.2


line stmt bran cond sub pod time code
1             #!/usr/bin/perl -I/home/phil/perl/cpan/DataTableText/lib
2             #-------------------------------------------------------------------------------
3             # Tree operations
4             # Philip R Brenan at gmail dot com, Appa Apps Ltd Inc., 2020
5             #-------------------------------------------------------------------------------
6             # podDocumentation
7             package Tree::Ops;
8             our $VERSION = 20200720;
9             require v5.26;
10 1     1   1006 use warnings FATAL => qw(all);
  1         7  
  1         38  
11 1     1   5 use strict;
  1         2  
  1         29  
12 1     1   6 use Carp;
  1         2  
  1         91  
13 1     1   546 use Data::Dump qw(dump);
  1         8145  
  1         85  
14 1     1   3743 use Data::Table::Text qw(:all);
  1         146771  
  1         4365  
15 1     1   35 use feature qw(current_sub say);
  1         3  
  1         230  
16 1     1   1058 use experimental qw(smartmatch);
  1         4734  
  1         6  
17              
18             my $logFile = q(/home/phil/z/z/z/zzz.txt); # Log printed results if developing
19              
20             #D1 Build # Create a tree. There is no implicit ordering applied to the tree, the relationships between parents and children within the tree are as established by the user and can be reorganized at will using the methods in this module.
21              
22             sub new(;$$) #S Create a new child optionally recording the specified key or value.
23 231     231 1 453 {my ($key, $value) = @_; # Key, value
24 231         620 genHash(__PACKAGE__, # Child in the tree.
25             children => [], # Children of this child.
26             key => $key, # Key for this child - any thing that can be compared with the L operator.
27             value => $value, # Value for this child.
28             parent => undef, # Parent for this child.
29             lastChild => undef, # Last active child chain - enables us to find the currently open scope from the start if the tree.
30             );
31             }
32              
33             sub activeScope($) # Locate the active scope in a tree.
34 396     396 1 555 {my ($tree) = @_; # Tree
35 396         439 my $active; # Latest active child
36 396         823 for(my $l = $tree; $l; $l = $l->lastChild) {$active = $l} # Skip down edge of parse tree to deepest active child.
  1248         21628  
37 396         1765 $active
38             }
39              
40             sub setParentOfChild($$) #P Set the parent of a child and return the child.
41 214     214 1 357 {my ($child, $parent) = @_; # Child, parent
42 214         3281 $child->parent = $parent; # Parent child
43 214         1038 $child
44             }
45              
46             sub open($;$$) # Add a child and make it the currently active scope into which new children will be added.
47 198     198 1 322 {my ($tree, $key, $value) = @_; # Tree, key, value to be recorded in the interior child being opened
48 198         336 my $parent = activeScope $tree; # Active parent
49 198         403 my $child = new $key, $value; # New child
50 198         15264 push $parent->children->@*, $child; # Place new child last under parent
51 198         3804 $parent->lastChild = $child; # Make child active
52 198         824 setParentOfChild $child, $parent # Parent child
53             }
54              
55             sub close($) # Close the current scope returning to the previous scope.
56 195     195 1 298 {my ($tree) = @_; # Tree
57 195         305 my $parent = activeScope $tree; # Locate active scope
58 195 100       3055 delete $parent->parent->{lastChild} if $parent->parent; # Close scope
59 195         4280 $parent
60             }
61              
62             sub single($;$$) # Add one child in the current scope.
63 119     119 1 212 {my ($tree, $key, $value) = @_; # Tree, key, value to be recorded in the child being created
64 119         261 $tree->open($key, $value); # Open scope
65 119         250 $tree->close; # Close scope immediately
66             }
67              
68             sub include($$) # Include the specified tree in the currently open scope.
69 1     1 1 9 {my ($tree, $include) = @_; # Tree being built, tree to include
70 1         3 my $parent = activeScope $tree; # Active parent
71 1         19 my $n = new $include->key, $include->value; # New intermediate child
72 1         77 $n->children = $include->children; # Include children
73 1         22 $n->parent = $parent; # Parent new node
74 1         8 $parent->putLast($n) # Include node
75             }
76              
77             sub fromLetters($) # Create a tree from a string of letters - useful for testing.
78 18     18 1 46 {my ($letters) = @_; # String of letters and ( ).
79 18         54 my $t = new(my $s = 'a');
80 18         1370 my @l = split //, $letters;
81 18         34 my @c;
82 18         83 for my $l(split(//, $letters), '')
83 344         519 {my $c = shift @c;
84 344 50       738 if ($l eq '(') {$t->open ($c) if $c}
  72 100       198  
    100          
85 72 100       217 elsif ($l eq ')') {$t->single($c) if $c; $t->close}
  72         144  
86 200 100       409 else {$t->single($c) if $c; @c = $l}
  200         467  
87             }
88             $t
89 18         250 }
90              
91             #D1 Navigation # Navigate through a tree.
92              
93             sub first($) # Get the first child under the specified parent.
94 87     87 1 261 {my ($parent) = @_; # Parent
95 87         1404 $parent->children->[0]
96             }
97              
98             sub last($) # Get the last child under the specified parent.
99 68     68 1 179 {my ($parent) = @_; # Parent
100 68         1088 $parent->children->[-1]
101             }
102              
103             sub indexOfChildInParent($) #P Get the index of a child within the specified parent.
104 137     137 1 247 {my ($child) = @_; # Child
105 137 50       2183 return undef unless my $parent = $child->parent; # Parent
106 137         2576 my $c = $parent->children; # Siblings
107 137 100       642 for(keys @$c) {return $_ if $$c[$_] == $child} # Locate child and return index
  274         1224  
108             undef # Root has no index
109 0         0 }
110              
111             sub next($) # Get the next sibling following the specified child.
112 57     57 1 111 {my ($child) = @_; # Child
113 57 100       911 return undef unless my $parent = $child->parent; # Parent
114 53         994 my $c = $parent->children; # Siblings
115 53 100 66     391 return undef if @$c == 0 or $$c[-1] == $child; # No next child
116 51         111 $$c[+1 + indexOfChildInParent $child] # Next child
117             }
118              
119             sub prev($) # Get the previous sibling of the specified child.
120 64     64 1 110 {my ($child) = @_; # Child
121 64 100       1040 return undef unless my $parent = $child->parent; # Parent
122 56         1033 my $c = $parent->children; # Siblings
123 56 100 66     363 return undef if @$c == 0 or $$c[0] == $child; # No previous child
124 54         128 $$c[-1 + indexOfChildInParent $child] # Previous child
125             }
126              
127             sub firstMost($) # Return the first most descendant child in the tree starting at this parent or else return B if this parent has no children.
128 19     19 1 90 {my ($parent) = @_; # Child
129 19         24 my $f;
130 19         40 for(my $p = $parent; $p; $p = $p->first) {$f = $p} # Go first most
  44         174  
131 19         152 $f
132             }
133              
134             sub nextMost($) # Return the next child with no children, i.e. the next leaf of the tree, else return B if there is no such child.
135 20     20 1 47 {my ($child) = @_; # Current leaf
136 20 100       328 return firstMost $child if $child->children->@*; # First most child if we are not starting on a child with no children - i.e. on a leaf.
137 9         45 my $p = $child; # Traverse upwards and then right
138 9         23 $p = $p->parent while $p->isLast; # Traverse upwards
139 9 100       66 return undef unless $p = $p->next; # Traverse right else we are at the root
140 7         17 firstMost $p # First most child
141             }
142              
143             sub prevMost($) # Return the previous child with no children, i.e. the previous leaf of the tree, else return B if there is no such child.
144 21     21 1 46 {my ($child) = @_; # Current leaf
145 21         32 my $p = $child; # Traverse upwards and then left
146 21         45 $p = $p->parent while $p->isFirst; # Traverse upwards
147 21 100       140 return undef unless $p = $p->prev; # Traverse left else we are at the root
148 15         31 lastMost $p # Last most child
149             }
150              
151             sub lastMost($) # Return the last most descendant child in the tree starting at this parent or else return B if this parent has no children.
152 17     17 1 36 {my ($parent) = @_; # Child
153 17         20 my $f;
154 17         39 for(my $p = $parent; $p; $p = $p->last) {$f = $p} # Go last most
  32         116  
155 17         139 $f
156             }
157              
158             sub mostRecentCommonAncestor($$) # Find the most recent common ancestor of the specified children.
159 2     2 1 6 {my ($first, $second) = @_; # First child, second child
160 2 50       8 return $first if $first == $second; # Same first and second child
161 2         6 my @f = context $first; # Context of first child
162 2         5 my @s = context $second; # Context of second child
163 2   33     3 my $c; $c = pop @f, pop @s while @f and @s and $f[-1] == $s[-1]; # Remove common ancestors
  2   66     27  
164 2         9 $c
165             }
166              
167             #D1 Location # Verify the current location.
168              
169             sub context($) # Get the context of the current child.
170 21     21 1 35 {my ($child) = @_; # Child
171 21         28 my @c; # Context
172 21         53 for(my $c = $child; $c; $c = $c->parent) {push @c, $c} # Walk up
  88         1626  
173             @c
174 21         127 }
175              
176             sub isFirst($) # Return the specified child if that child is first under its parent, else return B.
177 80     80 1 636 {my ($child) = @_; # Child
178 80 100       1272 return undef unless my $parent = $child->parent; # Parent
179 72 100       1358 $parent->children->[0] == $child ? $child : undef # There will be at least one child
180             }
181              
182             sub isLast($) # Return the specified child if that child is last under its parent, else return B.
183 64     64 1 533 {my ($child) = @_; # Child
184 64 100       1010 return undef unless my $parent = $child->parent; # Parent
185 60         1136 my $c = $parent->children;
186 60 100       1065 $parent->children->[-1] == $child ? $child : undef # There will be at least one child
187             }
188              
189             sub singleChildOfParent($) # Return the only child of this parent if the parent has an only child, else B
190 1     1 1 3 {my ($parent) = @_; # Parent
191 1 50       19 $parent->children->@* == 1 ? $parent->children->[0] : undef # Return only child if it exists
192             }
193              
194             sub empty($) # Return the specified parent if it has no children else B
195 2     2 1 5 {my ($parent) = @_; # Parent
196 2 100       35 $parent->children->@* == 0 ? $parent : undef
197             }
198              
199             #D1 Put # Insert children into a tree.
200              
201             sub putFirst($$) # Place a new child first under the specified parent and return the child.
202 3     3 1 78 {my ($parent, $child) = @_; # Parent, child
203 3         55 unshift $parent->children->@*, $child; # Place child
204 3         21 setParentOfChild $child, $parent # Parent child
205             }
206              
207             sub putLast($$) # Place a new child last under the specified parent and return the child.
208 8     8 1 87 {my ($parent, $child) = @_; # Parent, child
209 8         133 push $parent->children->@*, $child; # Place child
210 8         44 setParentOfChild $child, $parent # Parent child
211             }
212              
213             sub putNext($$) # Place a new child after the specified child.
214 3     3 1 112 {my ($child, $new) = @_; # Existing child, new child
215 3 50       8 return undef unless defined(my $i = indexOfChildInParent $child); # Locate child within parent
216 3         51 splice $child->parent->children->@*, $i, 1, $child, $new; # Place new child
217 3         105 setParentOfChild $new, $child->parent # Parent child
218             }
219              
220             sub putPrev($$) # Place a new child before the specified child.
221 2     2 1 74 {my ($child, $new) = @_; # Child, new child
222 2 50       7 return undef unless defined(my $i = indexOfChildInParent($child)); # Locate child within parent
223 2         37 splice $child->parent->children->@*, $i, 1, $new, $child; # Place new child
224 2         73 setParentOfChild $new, $child->parent # Parent child
225             }
226              
227             #D1 Steps # Move the start or end of a scope forwards or backwards as suggested by Alex Monroe.
228              
229             sub step($) # Make the first child of the specified parent the parents previous sibling and return the parent. In effect this moves the start of the parent one step forwards.
230 1     1 1 4 {my ($parent) = @_; # Parent
231 1 50       4 return undef unless my $f = $parent->first; # First child
232 1         12 putPrev $parent, cut $f; # Place first child
233 1         16 $parent
234             }
235              
236             sub stepEnd($) # Make the next sibling of the specified parent the parents last child and return the parent. In effect this moves the end of the parent one step forwards.
237 3     3 1 7 {my ($parent) = @_; # Parent
238 3 50       9 return undef unless my $n = $parent->next; # Next sibling
239 3         9 putLast $parent, cut $n; # Place next sibling as first child
240 3         22 $parent
241             }
242              
243             sub stepBack # Make the previous sibling of the specified parent the parents first child and return the parent. In effect this moves the start of the parent one step backwards.
244 2     2 1 7 {my ($parent) = @_; # Parent
245 2 50       6 return undef unless my $p = $parent->prev; # Previous sibling
246 2         7 putFirst $parent, cut $p; # Place previous sibling as first child
247 2         32 $parent
248             }
249              
250             sub stepEndBack # Make the last child of the specified parent the parents next sibling and return the parent. In effect this moves the end of the parent one step backwards.
251 1     1 1 3 {my ($parent) = @_; # Parent
252 1 50       4 return undef unless my $l = $parent->last; # Last child sibling
253 1         9 putNext $parent, cut $l; # Place last child as first sibling
254 1         16 $parent
255             }
256              
257             #D1 Edit # Edit a tree in situ.
258              
259             sub cut($) # Cut out a child and all its content and children, return it ready for reinsertion else where.
260 11     11 1 23 {my ($child) = @_; # Child
261 11 50       196 return $child unless my $parent = $child->parent; # The whole tree
262 11         222 splice $parent->children->@*, indexOfChildInParent($child), 1; # Remove child
263 11         77 $child
264             }
265              
266             sub dup($) # Duplicate a parent and all its descendants.
267 1     1 1 4 {my ($parent) = @_; # Parent
268              
269             sub # Duplicate a child
270 2     2   30 {my ($old) = @_; # Existing child
271 2         75 my $new = new $old->key; # New child
272 2         184 push $new->children->@*, __SUB__->($_) for $old->children->@*; # Duplicate children of child
273 2         12 $new
274 1         7 }->($parent) # Start duplication at parent
275             }
276              
277             sub unwrap($) # Unwrap the specified child and return that child.
278 5     5 1 17 {my ($child) = @_; # Child
279 5 50       12 return undef unless defined(my $i = indexOfChildInParent $child); # Locate child within parent
280 5         82 my $parent = $child->parent; # Parent
281 5         91 $_->parent = $parent for $child->children->@*; # Reparent unwrapped children of child
282 5         160 delete $child ->{parent}; # Remove parent of unwrapped child
283 5         80 splice $parent->children->@*, $i, 1, $child->children->@*; # Remove child
284 5         73 $parent
285             }
286              
287             sub wrap($$) # Wrap the specified child with a new parent and return the new parent.
288 5     5 1 93 {my ($child, $key) = @_; # Child to wrap, user data for new wrapping parent
289 5 50       12 return undef unless defined(my $i = indexOfChildInParent $child); # Locate child within existing parent
290 5         86 my $parent = $child->parent; # Existing parent
291 5         22 my $new = new $key; # Create new parent
292 5         388 $new->parent = $parent; # Parent new parent
293 5         95 $new->children = [$child]; # Set children for new parent
294 5         94 splice $parent->children->@*, $i, 1, $new; # Place new parent in existing parent
295 5         99 $child->parent = $new # Reparent child to new parent
296             }
297              
298             sub merge($) # Merge the children of the specified parent with those of the surrounding parents if the L[key] data of those parents L that of the specified parent. Merged parents are unwrapped. Returns the specified parent regardless. From a proposal made by Micaela Monroe.
299 1     1 1 10 {my ($parent) = @_; # Merging parent
300 1         4 while(my $p = $parent->prev) # Preceding siblings of a parent
301 0 0       0 {last unless $p->key ~~ $parent->key; # Preceding parents that carry the same data
302 0         0 putFirst $parent, cut $p; # Place merged parent first under merging parent
303 0         0 unwrap $p; # Unwrapped merged parent
304             }
305 1         4 while(my $p = $parent->next) # Following siblings of a parent
306 3 50       50 {last unless $p->key ~~ $parent->key; # Following parents that carry the same data
307 3         26 putLast $parent, cut $p; # Place merged parent last under merging parent
308 3         8 unwrap $p; # Unwrap merged parent
309             }
310             $parent
311 1         18 }
312              
313             sub split($) # Make the specified parent a grandparent of each of its children by interposing a copy of the specified parent between the specified parent and each of its children. Return the specified parent.
314 1     1 1 2 {my ($parent) = @_; # Parent to make into a grand parent
315 1         18 wrap $_, $parent->key for $parent->children->@*; # Grandparent each child
316 1         19 $parent
317             }
318              
319             #D1 Traverse # Traverse a tree.
320              
321             sub by($;$) # Traverse a tree in post-order to process each child with the specified sub and return an array of the results of processing each child. If no sub sub is specified, the children are returned in tree order.
322 15     15 1 38 {my ($tree, $sub) = @_; # Tree, optional sub to process each child
323 15   100 141   145 $sub //= sub{@_}; # Default sub
  141         287  
324              
325 15         28 my @r; # Results
326             sub # Traverse
327 156     156   593 {my ($child) = @_; # Child
328 156         2471 __SUB__->($_) for $child->children->@*; # Children of child
329 156         669 push @r, &$sub($child); # Process child saving result
330 15         69 }->($tree); # Start at root of tree
331              
332             @r
333 15         360 }
334              
335             sub select($$) # Select matching children in a tree in post-order. A child can be selected via named value, array of values, a hash of values, a regular expression or a sub reference.
336 7     7 1 37 {my ($tree, $select) = @_; # Tree, method to select a child
337 7         15 my $ref = ref $select; # Selector type
338             my $sel = # Selection method
339 10     10   39 $ref =~ m(array)i ? sub{grep{$_[0] eq $_} @$select} : # Array
  20         46  
340 10     10   45 $ref =~ m(hash)i ? sub{$$select{$_[0]}} : # Hash
341 17     17   109 $ref =~ m(exp)i ? sub{$_[0] =~ m($select)} : # Regular expression
342 17     17   300 $ref =~ m(code)i ? sub{&$select($_[0])} : # Sub
343 7 100   7   62 sub{$_[0] eq $select}; # Scalar
  7 100       37  
    100          
    100          
344 7         14 my @s; # Selection
345              
346             sub # Traverse
347 61     61   333 {my ($child) = @_; # Child
348 61 100       991 push @s, $child if &$sel($child->key); # Select child if it matches
349 61         982 __SUB__->($_) for $child->children->@*; # Each child
350 7         36 }->($tree); # Start at root
351              
352             @s
353 7         195 }
354              
355             #D1 Partitions # Various partitions of the tree
356              
357             sub leaves($) # The set of all children without further children, i.e. each leaf of the tree.
358 2     2 1 5 {my ($tree) = @_; # Tree
359 2         3 my @leaves; # Leaves
360             sub # Traverse
361 20     20   35 {my ($child) = @_; # Child
362 20 100       343 if (my @c = $child->children->@*) # Children of child
363 11         73 {__SUB__->($_) for @c; # Process children of child
364             }
365             else
366 9         53 {push @leaves, $child; # Save leaf
367             }
368 2         11 }->($tree); # Start at root of tree
369              
370             @leaves
371 2         19 }
372              
373             sub parentsOrdered($$$) #P The set of all parents in the tree, i.e. each non leaf of the tree, i.e the interior of the tree in the specified order.
374 7     7 1 16 {my ($tree, $preorder, $reverse) = @_; # Tree, pre-order if true else post-order, reversed if true
375 7         13 my @parents; # Parents
376             sub # Traverse
377 73     73   214 {my ($child) = @_; # Child
378 73 100       1142 if (my @c = $child->children->@*) # Children of child
379 36 100       196 {@c = reverse @c if $reverse; # Reverse if requested
380 36 100       59 push @parents, $child if $preorder; # Pre-order
381 36         100 __SUB__->($_) for @c; # Process children of child
382 36 100       190 push @parents, $child unless $preorder; # Post-order
383             }
384 7         36 }->($tree); # Start at root of tree
385              
386             @parents
387 7         78 }
388              
389             sub parentsPreOrder($) # The set of all parents in the tree, i.e. each non leaf of the tree, i.e the interior of the tree in normal pre-order.
390 1     1 1 2 {my ($tree) = @_; # Tree
391 1         5 parentsOrdered($tree, 1, 0);
392             }
393              
394             sub parentsPostOrder($) # The set of all parents in the tree, i.e. each non leaf of the tree, i.e the interior of the tree in normal post-order.
395 4     4 1 7 {my ($tree) = @_; # Tree
396 4         18 parentsOrdered($tree, 0, 0);
397             }
398              
399             sub parentsReversePreOrder($) # The set of all parents in the tree, i.e. each non leaf of the tree, i.e the interior of the tree in reverse pre-order.
400 1     1 1 3 {my ($tree) = @_; # Tree
401 1         3 parentsOrdered($tree, 1, 1);
402             }
403              
404             sub parentsReversePostOrder($) # The set of all parents in the tree, i.e. each non leaf of the tree, i.e the interior of the tree in reverse post-order.
405 1     1 1 5 {my ($tree) = @_; # Tree
406 1         3 &parentsOrdered($tree, 0, 1);
407             }
408              
409             sub parents($) # The set of all parents in the tree, i.e. each non leaf of the tree, i.e the interior of the tree in normal post-order.
410 2     2 1 5 {my ($tree) = @_; # Tree
411 2         6 &parentsPostOrder(@_);
412             }
413              
414             #D1 Order # Check the order and relative position of children in a tree.
415              
416             sub above($$) # Return the first child if it is above the second child else return B.
417 4     4 1 10 {my ($first, $second) = @_; # First child, second child
418 4 50       12 return undef if $first == $second; # A child cannot be above itself
419 4         13 my @f = context $first; # Context of first child
420 4         10 my @s = context $second; # Context of second child
421 4   66     49 pop @f, pop @s while @f and @s and $f[-1] == $s[-1]; # Find first different ancestor
      100        
422 4 100       26 !@f ? $first : undef # First is above second if the ancestors of first are also ancestors of second
423             }
424              
425             sub below($$) # Return the first child if it is below the second child else return B.
426 2     2 1 6 {my ($first, $second) = @_; # First child, second child
427 2 100       5 above($second, $first) ? $first : undef
428             }
429              
430             sub after($$) # Return the first child if it occurs strictly after the second child in the tree or else B if the first child is L[above], L[below] or L[before] the second child.
431 4     4 1 10 {my ($first, $second) = @_; # First child, second child
432 4         10 my @f = context $first; # Context of first child
433 4         9 my @s = context $second; # Context of second child
434 4   66     50 pop @f, pop @s while @f and @s and $f[-1] == $s[-1]; # Find first different ancestor
      100        
435 4 100 66     24 return undef unless @f and @s; # Not strictly after
436 2 50       5 indexOfChildInParent($f[-1]) > indexOfChildInParent($s[-1]) ? $first : undef # First child relative to second child at first common ancestor
437             }
438              
439             sub before($$) # Return the first child if it occurs strictly before the second child in the tree or else B if the first child is L[above], L[below] or L[after] the second child.
440 2     2 1 5 {my ($first, $second) = @_; # First child, second child
441 2 100       6 after($second, $first) ? $first : undef
442             }
443              
444             #D1 Paths # Find paths between nodes
445              
446             sub siblingsBefore($) # Return a list of siblings before the specified child.
447 1     1 1 3 {my ($child) = @_; # Child
448 1 50       17 return () unless my $parent = $child->parent; # Parent
449 1         22 my @c = $parent->children->@*; # Children
450 1         7 my $i = indexOfChildInParent $child; # Our position
451 1         24 @c[0..$i-1]
452             }
453              
454             sub siblingsAfter($) # Return a list of siblings after the specified child.
455 1     1 1 3 {my ($child) = @_; # Child
456 1 50       18 return () unless my $parent = $child->parent; # Parent
457 1         23 my @c = $parent->children->@*; # Children
458 1         6 my $i = indexOfChildInParent $child; # Our position
459 1         25 @c[$i+1..$#c]
460             }
461              
462             sub siblingsStrictlyBetween($$) # Return a list of the siblings strictly between two children of the same parent else return B.
463 2     2 1 6 {my ($start, $finish) = @_; # Start child, finish child
464 2 50       35 return () unless my $parent = $start->parent; # Parent
465 2 100       41 confess "Must be siblings" unless $parent == $finish->parent; # Check both children have the same parent
466 1         21 my @c = $parent->children->@*; # All siblings
467 1   66     14 shift @c while @c and $c[0] != $start; # Remove all siblings up to the start child
468 1   66     1402 pop @c while @c and $c[-1] != $finish; # Remove all siblings after the finish child
469 1 50       5 shift @c; pop @c if @c; # Remove first and last child to make range strictly between
  1         3  
470             @c # Siblings strictly between start and finish
471 1         32 }
472              
473             sub lineage($$) # Return the path from the specified child to the specified ancestor else return B if the child is not a descendant of the ancestor.
474 2     2 1 7 {my ($child, $ancestor) = @_; # Child, ancestor
475 2         4 my @p; # Path
476 2         9 for(my $p = $child; $p; $p = $p->parent) # Go up
477 8         42 {push @p, $p; # Record path
478 8 100       121 last if $p == $ancestor # Stop if we encounter the specified ancestor
479             }
480 2 100 66     35 return @p if !@p or $p[-1] == $ancestor; # Found the ancestor
481             undef # No such ancestor
482 1         4 }
483              
484             sub nextPreOrderPath($) # Return a list of children visited between the specified child and the next child in pre-order.
485 22     22 1 38 {my ($start) = @_; # The child at the start of the path
486 22 100       350 return ($start->first) if $start->children->@*; # First child if possible
487 13         60 my $p = $start; # Traverse upwards and then right
488 13         18 my @p; # Path
489 13         25 push @p, $p = $p->parent while $p->isLast; # Traverse upwards
490 13 100       86 $p->next ? (@p, $p->next) : () # Traverse right else we are at the root
491             }
492              
493             sub nextPostOrderPath($) # Return a list of children visited between the specified child and the next child in post-order.
494 22     22 1 41 {my ($start) = @_; # The child at the start of the path
495 22         30 my $p = $start; # Traverse upwards and then right, then first most
496 22         27 my @p; # Path
497 22 100       348 if (!$p->parent) # Starting at the root which is last in a post order traversal
498 2         16 {push @p, $p while $p = $p->first;
499             return @p
500 2         45 }
501 20 100       94 return (@p, $p->parent) if $p->isLast; # Traverse upwards
502 11 50       69 if (my $q = $p->next) # Traverse right
503 11         35 {for( ; $q; $q = $q->first) {push @p, $q} # Traverse first most
  13         40  
504             return @p
505 11         225 }
506 0         0 ($p) # Back at the root
507             }
508              
509             sub prevPostOrderPath($) # Return a list of children visited between the specified child and the previous child in post-order.
510 22     22 1 37 {my ($start) = @_; # The child at the start of the path
511 22 100       353 return ($start->last) if $start->children->@*; # Last child if possible
512 13         60 my $p = $start; # Traverse upwards and then left
513 13         18 my @p; # Path
514 13         25 push @p, $p = $p->parent while $p->isFirst; # Traverse upwards
515 13 100       81 $p->prev ? (@p, $p->prev) : () # Traverse left else we are at the root
516             }
517              
518             sub prevPreOrderPath($) # Return a list of children visited between the specified child and the previous child in pre-order.
519 22     22 1 39 {my ($start) = @_; # The child at the start of the path
520 22         31 my $p = $start; # Traverse upwards and then left, then last most
521 22         27 my @p; # Path
522 22 100       343 if (!$p->parent) # Starting at the root which is last in a post order traversal
523 2         17 {push @p, $p while $p = $p->last;
524             return @p
525 2         43 }
526 20 100       99 return (@p, $p->parent) if $p->isFirst; # Traverse upwards
527 11 50       79 if (my $q = $p->prev) # Traverse left
528 11         20 {for( ; $q; $q = $q->last) {push @p, $q} # Traverse last most
  18         74  
529             return @p
530 11         217 }
531 0         0 ($p) # Back at the root
532             }
533              
534             #D1 Print # Print a tree.
535              
536             sub printTree($$$$) #P String representation as a horizontal tree.
537 17     17 1 36 {my ($tree, $print, $preorder, $reverse) = @_; # Tree, optional print method, pre-order, reverse
538 17         29 my @s; # String representation
539              
540             sub # Print a child
541 167     167   279 {my ($child, $depth) = @_; # Child, depth
542 167         2745 my $key = $child->key; # Key
543 167         2931 my $value = $child->value; # Value
544 167 50       822 my $k = join '', ' ' x $depth, $print ? &$print($key) : $key; # Print key
545 167 50       366 my $v = !defined($value) ? '' : ref($value) ? dump($value) : $value; # Print value
    100          
546 167 100       463 push @s, [$k, $v] if $preorder;
547 167 100       2748 my @c = $child->children->@*; @c = reverse @c if $reverse;
  167         774  
548 167         496 __SUB__->($_, $depth+1) for @c; # Print children of child
549 167 100       423 push @s, [$k, $v] unless $preorder;
550 17         137 }->($tree, 0); # Print root
551              
552 17         239 my $r = formatTableBasic [[qw(Key Value)], @s]; # Print tree
553 17 50       7297 owf($logFile, $r) if -e $logFile; # Log the result if requested
554 17         177 $r
555             }
556              
557             sub printPreOrder($;$) # Print tree in normal pre-order.
558 14     14 1 29 {my ($tree, $print) = @_; # Tree, optional print method
559 14         39 printTree($tree, $print, 1, 0);
560             }
561              
562             sub printPostOrder($;$) # Print tree in normal post-order.
563 1     1 1 4 {my ($tree, $print) = @_; # Tree, optional print method
564 1         4 printTree($tree, $print, 0, 0);
565             }
566              
567             sub printReversePreOrder($;$) # Print tree in reverse pre-order
568 1     1 1 4 {my ($tree, $print) = @_; # Tree, optional print method
569 1         4 printTree($tree, $print, 1, 1);
570             }
571              
572             sub printReversePostOrder($;$) # Print tree in reverse post-order
573 1     1 1 4 {my ($tree, $print) = @_; # Tree, optional print method
574 1         5 printTree($tree, $print, 0, 1);
575             }
576              
577             sub print($;$) # Print tree in normal pre-order.
578 13     13 1 38 {my ($tree, $print) = @_; # Tree, optional print method
579 13         43 &printPreOrder(@_);
580             }
581              
582             sub brackets($;$$) # Bracketed string representation of a tree.
583 26     26 1 61 {my ($tree, $print, $separator) = @_; # Tree, optional print method, optional child separator
584 26   50     108 my $t = $separator // ''; # Default child separator
585             sub # Print a child
586 218     218   369 {my ($child) = @_; # Child
587 218         3427 my $key = $child->key; # Key
588 218 50       859 my $p = $print ? &$print($key) : $key; # Printed child
589 218         3337 my $c = $child->children; # Children of child
590 218 100       1290 return $p unless @$c; # Return child immediately if no children to format
591 110         190 join '', $p, '(', join($t, map {__SUB__->($_)} @$c), ')' # String representation
  192         457  
592 26         142 }->($tree) # Print root
593             }
594              
595             sub xml($;$) # Print a tree as as xml.
596 1     1 1 3 {my ($tree, $print) = @_; # Tree, optional print method
597             sub # Print a child
598 12     12   17 {my ($child) = @_; # Child
599 12         188 my $key = $child->key; # Key
600 12 50       53 my $p = $print ? &$print($key) : $key; # Printed child
601 12         184 my $c = $child->children; # Children of child
602 12 100       74 return "<$p/>" unless @$c; # Singleton
603 6         14 join '', "<$p>", (map {__SUB__->($_)} @$c), "" # String representation
  11         28  
604 1         7 }->($tree) # Print root
605             }
606              
607             #D1 Data Structures # Data structures use by this package.
608              
609             #D0
610             #-------------------------------------------------------------------------------
611             # Export
612             #-------------------------------------------------------------------------------
613              
614 1     1   7307 use Exporter qw(import);
  1         3  
  1         78  
615              
616 1     1   8 use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  1         3  
  1         742  
617              
618             @ISA = qw(Exporter);
619             @EXPORT_OK = qw(
620             );
621             %EXPORT_TAGS = (all=>[@EXPORT, @EXPORT_OK]);
622              
623             # podDocumentation
624              
625             =pod
626              
627             =encoding utf-8
628              
629             =head1 Name
630              
631             Tree::Ops - Tree operations.
632              
633             =head1 Synopsis
634              
635             Create a tree:
636              
637             my $a = Tree::Ops::new 'a', 'A';
638              
639             for(1..2)
640             {$a->open ('b', "B$_");
641             $a->single('c', "C$_");
642             $a->close;
643             }
644             $a->single ('d', 'D');
645             $a->single ('e', 'E');
646              
647             Print it:
648              
649             is_deeply $a->print, <
650             Key Value
651             a A
652             b B1
653             c C1
654             b B2
655             c C2
656             d D
657             e E
658             END
659              
660             Navigate through the tree:
661              
662             is_deeply $a->lastMost->prev->prev->first->key, 'c';
663             is_deeply $a->first->next->last->parent->first->value, 'C2';
664              
665             Traverse the tree:
666              
667             is_deeply [map{$_->value} $a->by], [qw(C1 B1 C2 B2 D E A)];
668              
669             Select items from the tree:
670              
671             is_deeply [map{$_->value} $a->select('b')], [qw(B1 B2)];
672             is_deeply [map{$_->value} $a->select(qr(b|c))], [qw(B1 C1 B2 C2)];
673             is_deeply [map{$_->value} $a->select(sub{$_[0] eq 'd'})], [qw(D)];
674              
675             Reorganize the tree:
676              
677             $a->first->next->stepEnd->stepEnd->first->next->stepBack;
678             is_deeply $a->print, <
679             Key Value
680             a A
681             b B1
682             c C1
683             b B2
684             d D
685             c C2
686             e E
687             END
688              
689             =head1 Description
690              
691             Tree operations.
692              
693              
694             Version 20200720.
695              
696              
697             The following sections describe the methods in each functional area of this
698             module. For an alphabetic listing of all methods by name see L.
699              
700              
701              
702             =head1 Build
703              
704             Create a tree. There is no implicit ordering applied to the tree, the relationships between parents and children within the tree are as established by the user and can be reorganized at will using the methods in this module.
705              
706             =head2 new($key, $value)
707              
708             Create a new child optionally recording the specified key or value.
709              
710             Parameter Description
711             1 $key Key
712             2 $value Value
713              
714             B
715              
716              
717            
718             my $a = Tree::Ops::new 'a', 'A'; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
719              
720             for(1..2)
721             {$a->open ('b', "B$_");
722             $a->single('c', "C$_");
723             ok $a->activeScope->key eq 'b';
724             $a->close;
725             }
726             $a->single ('d', 'D');
727             $a->single ('e', 'E');
728             is_deeply $a->print, <
729             Key Value
730             a A
731             b B1
732             c C1
733             b B2
734             c C2
735             d D
736             e E
737             END
738            
739             is_deeply [map{$_->value} $a->by], [qw(C1 B1 C2 B2 D E A)];
740            
741             is_deeply $a->lastMost->prev->prev->first->key, 'c';
742             is_deeply $a->first->next->last->parent->first->value, 'C2';
743            
744             is_deeply [map{$_->value} $a->select('b')], [qw(B1 B2)];
745             is_deeply [map{$_->value} $a->select(qr(b|c))], [qw(B1 C1 B2 C2)];
746             is_deeply [map{$_->value} $a->select(sub{$_[0] eq 'd'})], [qw(D)];
747            
748             $a->first->next->stepEnd->stepEnd->first->next->stepBack;
749             is_deeply $a->print, <
750             Key Value
751             a A
752             b B1
753             c C1
754             b B2
755             d D
756             c C2
757             e E
758             END
759            
760              
761             This is a static method and so should either be imported or invoked as:
762              
763             Tree::Ops::new
764              
765              
766             =head2 activeScope($tree)
767              
768             Locate the active scope in a tree.
769              
770             Parameter Description
771             1 $tree Tree
772              
773             B
774              
775              
776             my $a = Tree::Ops::new 'a', 'A';
777             for(1..2)
778             {$a->open ('b', "B$_");
779             $a->single('c', "C$_");
780            
781             ok $a->activeScope->key eq 'b'; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
782              
783             $a->close;
784             }
785             $a->single ('d', 'D');
786             $a->single ('e', 'E');
787             is_deeply $a->print, <
788             Key Value
789             a A
790             b B1
791             c C1
792             b B2
793             c C2
794             d D
795             e E
796             END
797            
798             is_deeply [map{$_->value} $a->by], [qw(C1 B1 C2 B2 D E A)];
799            
800             is_deeply $a->lastMost->prev->prev->first->key, 'c';
801             is_deeply $a->first->next->last->parent->first->value, 'C2';
802            
803             is_deeply [map{$_->value} $a->select('b')], [qw(B1 B2)];
804             is_deeply [map{$_->value} $a->select(qr(b|c))], [qw(B1 C1 B2 C2)];
805             is_deeply [map{$_->value} $a->select(sub{$_[0] eq 'd'})], [qw(D)];
806            
807             $a->first->next->stepEnd->stepEnd->first->next->stepBack;
808             is_deeply $a->print, <
809             Key Value
810             a A
811             b B1
812             c C1
813             b B2
814             d D
815             c C2
816             e E
817             END
818            
819              
820             =head2 open($tree, $key, $value)
821              
822             Add a child and make it the currently active scope into which new children will be added.
823              
824             Parameter Description
825             1 $tree Tree
826             2 $key Key
827             3 $value Value to be recorded in the interior child being opened
828              
829             B
830              
831              
832             my $a = Tree::Ops::new 'a', 'A';
833             for(1..2)
834            
835             {$a->open ('b', "B$_"); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
836              
837             $a->single('c', "C$_");
838             ok $a->activeScope->key eq 'b';
839             $a->close;
840             }
841             $a->single ('d', 'D');
842             $a->single ('e', 'E');
843             is_deeply $a->print, <
844             Key Value
845             a A
846             b B1
847             c C1
848             b B2
849             c C2
850             d D
851             e E
852             END
853            
854             is_deeply [map{$_->value} $a->by], [qw(C1 B1 C2 B2 D E A)];
855            
856             is_deeply $a->lastMost->prev->prev->first->key, 'c';
857             is_deeply $a->first->next->last->parent->first->value, 'C2';
858            
859             is_deeply [map{$_->value} $a->select('b')], [qw(B1 B2)];
860             is_deeply [map{$_->value} $a->select(qr(b|c))], [qw(B1 C1 B2 C2)];
861             is_deeply [map{$_->value} $a->select(sub{$_[0] eq 'd'})], [qw(D)];
862            
863             $a->first->next->stepEnd->stepEnd->first->next->stepBack;
864             is_deeply $a->print, <
865             Key Value
866             a A
867             b B1
868             c C1
869             b B2
870             d D
871             c C2
872             e E
873             END
874            
875              
876             =head2 close($tree)
877              
878             Close the current scope returning to the previous scope.
879              
880             Parameter Description
881             1 $tree Tree
882              
883             B
884              
885              
886             my $a = Tree::Ops::new 'a', 'A';
887             for(1..2)
888             {$a->open ('b', "B$_");
889             $a->single('c', "C$_");
890             ok $a->activeScope->key eq 'b';
891            
892             $a->close; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
893              
894             }
895             $a->single ('d', 'D');
896             $a->single ('e', 'E');
897             is_deeply $a->print, <
898             Key Value
899             a A
900             b B1
901             c C1
902             b B2
903             c C2
904             d D
905             e E
906             END
907            
908             is_deeply [map{$_->value} $a->by], [qw(C1 B1 C2 B2 D E A)];
909            
910             is_deeply $a->lastMost->prev->prev->first->key, 'c';
911             is_deeply $a->first->next->last->parent->first->value, 'C2';
912            
913             is_deeply [map{$_->value} $a->select('b')], [qw(B1 B2)];
914             is_deeply [map{$_->value} $a->select(qr(b|c))], [qw(B1 C1 B2 C2)];
915             is_deeply [map{$_->value} $a->select(sub{$_[0] eq 'd'})], [qw(D)];
916            
917             $a->first->next->stepEnd->stepEnd->first->next->stepBack;
918             is_deeply $a->print, <
919             Key Value
920             a A
921             b B1
922             c C1
923             b B2
924             d D
925             c C2
926             e E
927             END
928            
929              
930             =head2 single($tree, $key, $value)
931              
932             Add one child in the current scope.
933              
934             Parameter Description
935             1 $tree Tree
936             2 $key Key
937             3 $value Value to be recorded in the child being created
938              
939             B
940              
941              
942             my $a = Tree::Ops::new 'a', 'A';
943             for(1..2)
944             {$a->open ('b', "B$_");
945            
946             $a->single('c', "C$_"); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
947              
948             ok $a->activeScope->key eq 'b';
949             $a->close;
950             }
951            
952             $a->single ('d', 'D'); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
953              
954            
955             $a->single ('e', 'E'); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
956              
957             is_deeply $a->print, <
958             Key Value
959             a A
960             b B1
961             c C1
962             b B2
963             c C2
964             d D
965             e E
966             END
967            
968             is_deeply [map{$_->value} $a->by], [qw(C1 B1 C2 B2 D E A)];
969            
970             is_deeply $a->lastMost->prev->prev->first->key, 'c';
971             is_deeply $a->first->next->last->parent->first->value, 'C2';
972            
973             is_deeply [map{$_->value} $a->select('b')], [qw(B1 B2)];
974             is_deeply [map{$_->value} $a->select(qr(b|c))], [qw(B1 C1 B2 C2)];
975             is_deeply [map{$_->value} $a->select(sub{$_[0] eq 'd'})], [qw(D)];
976            
977             $a->first->next->stepEnd->stepEnd->first->next->stepBack;
978             is_deeply $a->print, <
979             Key Value
980             a A
981             b B1
982             c C1
983             b B2
984             d D
985             c C2
986             e E
987             END
988            
989              
990             =head2 include($tree, $include)
991              
992             Include the specified tree in the currently open scope.
993              
994             Parameter Description
995             1 $tree Tree being built
996             2 $include Tree to include
997              
998             B
999              
1000              
1001            
1002             my $i = fromLetters('B(CD)');
1003             my $a = Tree::Ops::new 'a';
1004             $a->open ('b');
1005            
1006             $a->include($i->first); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1007              
1008             $a->close;
1009            
1010             is_deeply $a->print, <
1011             Key Value
1012             a
1013             b
1014             B
1015             C
1016             D
1017             END
1018            
1019              
1020             =head2 fromLetters($letters)
1021              
1022             Create a tree from a string of letters - useful for testing.
1023              
1024             Parameter Description
1025             1 $letters String of letters and ( ).
1026              
1027             B
1028              
1029              
1030            
1031             my $a = fromLetters(q(bc(d)e)); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1032              
1033            
1034             is_deeply $a->print, <
1035             Key Value
1036             a
1037             b
1038             c
1039             d
1040             e
1041             END
1042            
1043              
1044             =head1 Navigation
1045              
1046             Navigate through a tree.
1047              
1048             =head2 first($parent)
1049              
1050             Get the first child under the specified parent.
1051              
1052             Parameter Description
1053             1 $parent Parent
1054              
1055             B
1056              
1057              
1058             my %l = map{$_->key=>$_} fromLetters('b(c)d(efgh(i(j)))')->by;
1059             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = @l{'a'..'j'};
1060             is_deeply $c->parent, $b;
1061            
1062             is_deeply $a->first, $b; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1063              
1064             is_deeply $a->last, $d;
1065             is_deeply $e->next, $f;
1066             is_deeply $f->prev, $e;
1067            
1068              
1069             =head2 last($parent)
1070              
1071             Get the last child under the specified parent.
1072              
1073             Parameter Description
1074             1 $parent Parent
1075              
1076             B
1077              
1078              
1079             my %l = map{$_->key=>$_} fromLetters('b(c)d(efgh(i(j)))')->by;
1080             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = @l{'a'..'j'};
1081             is_deeply $c->parent, $b;
1082             is_deeply $a->first, $b;
1083            
1084             is_deeply $a->last, $d; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1085              
1086             is_deeply $e->next, $f;
1087             is_deeply $f->prev, $e;
1088            
1089              
1090             =head2 next($child)
1091              
1092             Get the next sibling following the specified child.
1093              
1094             Parameter Description
1095             1 $child Child
1096              
1097             B
1098              
1099              
1100             my %l = map{$_->key=>$_} fromLetters('b(c)d(efgh(i(j)))')->by;
1101             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = @l{'a'..'j'};
1102             is_deeply $c->parent, $b;
1103             is_deeply $a->first, $b;
1104             is_deeply $a->last, $d;
1105            
1106             is_deeply $e->next, $f; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1107              
1108             is_deeply $f->prev, $e;
1109            
1110              
1111             =head2 prev($child)
1112              
1113             Get the previous sibling of the specified child.
1114              
1115             Parameter Description
1116             1 $child Child
1117              
1118             B
1119              
1120              
1121             my %l = map{$_->key=>$_} fromLetters('b(c)d(efgh(i(j)))')->by;
1122             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = @l{'a'..'j'};
1123             is_deeply $c->parent, $b;
1124             is_deeply $a->first, $b;
1125             is_deeply $a->last, $d;
1126             is_deeply $e->next, $f;
1127            
1128             is_deeply $f->prev, $e; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1129              
1130            
1131              
1132             =head2 firstMost($parent)
1133              
1134             Return the first most descendant child in the tree starting at this parent or else return B if this parent has no children.
1135              
1136             Parameter Description
1137             1 $parent Child
1138              
1139             B
1140              
1141              
1142             my $a = fromLetters('b(c)y(x)d(efgh(i(j)))');
1143             is_deeply $a->print, <
1144             Key Value
1145             a
1146             b
1147             c
1148             y
1149             x
1150             d
1151             e
1152             f
1153             g
1154             h
1155             i
1156             j
1157             END
1158            
1159             is_deeply $a->xml,
1160             '';
1161            
1162             my ($c, $b, $x, $y, $e, $f, $g, $j, $i, $h, $d) = $a->by;
1163            
1164             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves];
1165             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder];
1166             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder];
1167             is_deeply [$a->parents], [$a->parentsPostOrder];
1168            
1169             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder];
1170             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder];
1171            
1172             ok !$j->parents;
1173            
1174             ok $a->lastMost == $j;
1175             ok !$a->prevMost;
1176             ok $j->prevMost == $g;
1177             ok $i->prevMost == $g;
1178             ok $h->prevMost == $g;
1179             ok $g->prevMost == $f;
1180             ok $f->prevMost == $e;
1181             ok $e->prevMost == $x;
1182             ok $d->prevMost == $x;
1183             ok $x->prevMost == $c;
1184             ok $y->prevMost == $c;
1185             ok !$c->prevMost;
1186             ok !$b->prevMost;
1187             ok !$a->prevMost;
1188            
1189            
1190             ok $a->firstMost == $c; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1191              
1192             ok $a->nextMost == $c;
1193             ok $b->nextMost == $c;
1194             ok $c->nextMost == $x;
1195             ok $y->nextMost == $x;
1196             ok $x->nextMost == $e;
1197             ok $d->nextMost == $e;
1198             ok $e->nextMost == $f;
1199             ok $f->nextMost == $g;
1200             ok $g->nextMost == $j;
1201             ok $h->nextMost == $j;
1202             ok $i->nextMost == $j;
1203             ok !$j->nextMost;
1204            
1205              
1206             =head2 nextMost($child)
1207              
1208             Return the next child with no children, i.e. the next leaf of the tree, else return B if there is no such child.
1209              
1210             Parameter Description
1211             1 $child Current leaf
1212              
1213             B
1214              
1215              
1216             my $a = fromLetters('b(c)y(x)d(efgh(i(j)))');
1217             is_deeply $a->print, <
1218             Key Value
1219             a
1220             b
1221             c
1222             y
1223             x
1224             d
1225             e
1226             f
1227             g
1228             h
1229             i
1230             j
1231             END
1232            
1233             is_deeply $a->xml,
1234             '';
1235            
1236             my ($c, $b, $x, $y, $e, $f, $g, $j, $i, $h, $d) = $a->by;
1237            
1238             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves];
1239             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder];
1240             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder];
1241             is_deeply [$a->parents], [$a->parentsPostOrder];
1242            
1243             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder];
1244             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder];
1245            
1246             ok !$j->parents;
1247            
1248             ok $a->lastMost == $j;
1249             ok !$a->prevMost;
1250             ok $j->prevMost == $g;
1251             ok $i->prevMost == $g;
1252             ok $h->prevMost == $g;
1253             ok $g->prevMost == $f;
1254             ok $f->prevMost == $e;
1255             ok $e->prevMost == $x;
1256             ok $d->prevMost == $x;
1257             ok $x->prevMost == $c;
1258             ok $y->prevMost == $c;
1259             ok !$c->prevMost;
1260             ok !$b->prevMost;
1261             ok !$a->prevMost;
1262            
1263             ok $a->firstMost == $c;
1264            
1265             ok $a->nextMost == $c; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1266              
1267            
1268             ok $b->nextMost == $c; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1269              
1270            
1271             ok $c->nextMost == $x; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1272              
1273            
1274             ok $y->nextMost == $x; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1275              
1276            
1277             ok $x->nextMost == $e; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1278              
1279            
1280             ok $d->nextMost == $e; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1281              
1282            
1283             ok $e->nextMost == $f; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1284              
1285            
1286             ok $f->nextMost == $g; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1287              
1288            
1289             ok $g->nextMost == $j; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1290              
1291            
1292             ok $h->nextMost == $j; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1293              
1294            
1295             ok $i->nextMost == $j; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1296              
1297            
1298             ok !$j->nextMost; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1299              
1300            
1301              
1302             =head2 prevMost($child)
1303              
1304             Return the previous child with no children, i.e. the previous leaf of the tree, else return B if there is no such child.
1305              
1306             Parameter Description
1307             1 $child Current leaf
1308              
1309             B
1310              
1311              
1312             my $a = fromLetters('b(c)y(x)d(efgh(i(j)))');
1313             is_deeply $a->print, <
1314             Key Value
1315             a
1316             b
1317             c
1318             y
1319             x
1320             d
1321             e
1322             f
1323             g
1324             h
1325             i
1326             j
1327             END
1328            
1329             is_deeply $a->xml,
1330             '';
1331            
1332             my ($c, $b, $x, $y, $e, $f, $g, $j, $i, $h, $d) = $a->by;
1333            
1334             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves];
1335             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder];
1336             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder];
1337             is_deeply [$a->parents], [$a->parentsPostOrder];
1338            
1339             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder];
1340             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder];
1341            
1342             ok !$j->parents;
1343            
1344             ok $a->lastMost == $j;
1345            
1346             ok !$a->prevMost; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1347              
1348            
1349             ok $j->prevMost == $g; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1350              
1351            
1352             ok $i->prevMost == $g; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1353              
1354            
1355             ok $h->prevMost == $g; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1356              
1357            
1358             ok $g->prevMost == $f; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1359              
1360            
1361             ok $f->prevMost == $e; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1362              
1363            
1364             ok $e->prevMost == $x; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1365              
1366            
1367             ok $d->prevMost == $x; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1368              
1369            
1370             ok $x->prevMost == $c; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1371              
1372            
1373             ok $y->prevMost == $c; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1374              
1375            
1376             ok !$c->prevMost; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1377              
1378            
1379             ok !$b->prevMost; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1380              
1381            
1382             ok !$a->prevMost; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1383              
1384            
1385             ok $a->firstMost == $c;
1386             ok $a->nextMost == $c;
1387             ok $b->nextMost == $c;
1388             ok $c->nextMost == $x;
1389             ok $y->nextMost == $x;
1390             ok $x->nextMost == $e;
1391             ok $d->nextMost == $e;
1392             ok $e->nextMost == $f;
1393             ok $f->nextMost == $g;
1394             ok $g->nextMost == $j;
1395             ok $h->nextMost == $j;
1396             ok $i->nextMost == $j;
1397             ok !$j->nextMost;
1398            
1399              
1400             =head2 lastMost($parent)
1401              
1402             Return the last most descendant child in the tree starting at this parent or else return B if this parent has no children.
1403              
1404             Parameter Description
1405             1 $parent Child
1406              
1407             B
1408              
1409              
1410             my $a = fromLetters('b(c)y(x)d(efgh(i(j)))');
1411             is_deeply $a->print, <
1412             Key Value
1413             a
1414             b
1415             c
1416             y
1417             x
1418             d
1419             e
1420             f
1421             g
1422             h
1423             i
1424             j
1425             END
1426            
1427             is_deeply $a->xml,
1428             '';
1429            
1430             my ($c, $b, $x, $y, $e, $f, $g, $j, $i, $h, $d) = $a->by;
1431            
1432             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves];
1433             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder];
1434             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder];
1435             is_deeply [$a->parents], [$a->parentsPostOrder];
1436            
1437             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder];
1438             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder];
1439            
1440             ok !$j->parents;
1441            
1442            
1443             ok $a->lastMost == $j; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1444              
1445             ok !$a->prevMost;
1446             ok $j->prevMost == $g;
1447             ok $i->prevMost == $g;
1448             ok $h->prevMost == $g;
1449             ok $g->prevMost == $f;
1450             ok $f->prevMost == $e;
1451             ok $e->prevMost == $x;
1452             ok $d->prevMost == $x;
1453             ok $x->prevMost == $c;
1454             ok $y->prevMost == $c;
1455             ok !$c->prevMost;
1456             ok !$b->prevMost;
1457             ok !$a->prevMost;
1458            
1459             ok $a->firstMost == $c;
1460             ok $a->nextMost == $c;
1461             ok $b->nextMost == $c;
1462             ok $c->nextMost == $x;
1463             ok $y->nextMost == $x;
1464             ok $x->nextMost == $e;
1465             ok $d->nextMost == $e;
1466             ok $e->nextMost == $f;
1467             ok $f->nextMost == $g;
1468             ok $g->nextMost == $j;
1469             ok $h->nextMost == $j;
1470             ok $i->nextMost == $j;
1471             ok !$j->nextMost;
1472            
1473              
1474             =head2 mostRecentCommonAncestor($first, $second)
1475              
1476             Find the most recent common ancestor of the specified children.
1477              
1478             Parameter Description
1479             1 $first First child
1480             2 $second Second child
1481              
1482             B
1483              
1484              
1485             my %l = map{$_->key=>$_} fromLetters('b(c(d(e))f(g(h)i)j)k')->by;
1486             my ($a, $b, $e, $h, $k) = @l{qw(a b e h k)};
1487            
1488             is_deeply $a->print, <
1489             Key Value
1490             a
1491             b
1492             c
1493             d
1494             e
1495             f
1496             g
1497             h
1498             i
1499             j
1500             k
1501             END
1502            
1503            
1504             ok $e->mostRecentCommonAncestor($h) == $b; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1505              
1506            
1507             ok $e->mostRecentCommonAncestor($k) == $a; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1508              
1509            
1510              
1511             =head1 Location
1512              
1513             Verify the current location.
1514              
1515             =head2 context($child)
1516              
1517             Get the context of the current child.
1518              
1519             Parameter Description
1520             1 $child Child
1521              
1522             B
1523              
1524              
1525             my %l = map{$_->key=>$_} fromLetters('b(c)y(x)z(st)d(efgh(i(j))))')->by;
1526             my ($a, $x, $y, $z) = @l{qw(a x y z)};
1527            
1528            
1529             is_deeply [map {$_->key} $x->context], [qw(x y a)]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1530              
1531            
1532             is_deeply join(' ', $a->by(sub{$_[0]->key})), "c b x y s t z e f g j i h d a";
1533             is_deeply join(' ', map{$_->key} $a->by), "c b x y s t z e f g j i h d a";
1534            
1535             $z->cut;
1536             is_deeply $a->brackets, 'a(b(c)y(x)d(efgh(i(j))))';
1537            
1538             $y->unwrap;
1539             is_deeply $a->brackets, 'a(b(c)xd(efgh(i(j))))';
1540            
1541             $y = $x->wrap('y');
1542             is_deeply $y->brackets, 'y(x)';
1543             is_deeply $a->brackets, 'a(b(c)y(x)d(efgh(i(j))))';
1544            
1545             $y->putNext($y->dup);
1546             is_deeply $a->brackets, 'a(b(c)y(x)y(x)d(efgh(i(j))))';
1547            
1548              
1549             =head2 isFirst($child)
1550              
1551             Return the specified child if that child is first under its parent, else return B.
1552              
1553             Parameter Description
1554             1 $child Child
1555              
1556             B
1557              
1558              
1559             my %l = map{$_->key=>$_} fromLetters('b(c)d(efgh(i(j)))')->by;
1560             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = @l{'a'..'j'};
1561            
1562             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
1563             is_deeply $b->singleChildOfParent, $c;
1564            
1565             is_deeply $e->isFirst, $e; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1566              
1567            
1568             ok !$f->isFirst; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1569              
1570             ok !$g->isLast;
1571             is_deeply $h->isLast, $h;
1572             ok $j->empty;
1573             ok !$i->empty;
1574            
1575              
1576             =head2 isLast($child)
1577              
1578             Return the specified child if that child is last under its parent, else return B.
1579              
1580             Parameter Description
1581             1 $child Child
1582              
1583             B
1584              
1585              
1586             my %l = map{$_->key=>$_} fromLetters('b(c)d(efgh(i(j)))')->by;
1587             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = @l{'a'..'j'};
1588            
1589             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
1590             is_deeply $b->singleChildOfParent, $c;
1591             is_deeply $e->isFirst, $e;
1592             ok !$f->isFirst;
1593            
1594             ok !$g->isLast; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1595              
1596            
1597             is_deeply $h->isLast, $h; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1598              
1599             ok $j->empty;
1600             ok !$i->empty;
1601            
1602              
1603             =head2 singleChildOfParent($parent)
1604              
1605             Return the only child of this parent if the parent has an only child, else B
1606              
1607             Parameter Description
1608             1 $parent Parent
1609              
1610             B
1611              
1612              
1613             my %l = map{$_->key=>$_} fromLetters('b(c)d(efgh(i(j)))')->by;
1614             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = @l{'a'..'j'};
1615            
1616             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
1617            
1618             is_deeply $b->singleChildOfParent, $c; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1619              
1620             is_deeply $e->isFirst, $e;
1621             ok !$f->isFirst;
1622             ok !$g->isLast;
1623             is_deeply $h->isLast, $h;
1624             ok $j->empty;
1625             ok !$i->empty;
1626            
1627              
1628             =head2 empty($parent)
1629              
1630             Return the specified parent if it has no children else B
1631              
1632             Parameter Description
1633             1 $parent Parent
1634              
1635             B
1636              
1637              
1638             my %l = map{$_->key=>$_} fromLetters('b(c)d(efgh(i(j)))')->by;
1639             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = @l{'a'..'j'};
1640            
1641             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
1642             is_deeply $b->singleChildOfParent, $c;
1643             is_deeply $e->isFirst, $e;
1644             ok !$f->isFirst;
1645             ok !$g->isLast;
1646             is_deeply $h->isLast, $h;
1647            
1648             ok $j->empty; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1649              
1650            
1651             ok !$i->empty; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1652              
1653            
1654              
1655             =head1 Put
1656              
1657             Insert children into a tree.
1658              
1659             =head2 putFirst($parent, $child)
1660              
1661             Place a new child first under the specified parent and return the child.
1662              
1663             Parameter Description
1664             1 $parent Parent
1665             2 $child Child
1666              
1667             B
1668              
1669              
1670             my %l = map{$_->key=>$_} fromLetters('b(c)d(e)')->by;
1671             my ($a, $b, $d) = @l{qw(a b d)};
1672            
1673             my $z = $b->putNext(new 'z');
1674             is_deeply $z->brackets, 'z';
1675             is_deeply $a->brackets, 'a(b(c)zd(e))';
1676            
1677             my $y = $d->putPrev(new 'y');
1678             is_deeply $y->brackets, 'y';
1679             is_deeply $a->brackets, 'a(b(c)zyd(e))';
1680            
1681             $z->putLast(new 't');
1682             is_deeply $z->brackets, 'z(t)';
1683             is_deeply $a->brackets, 'a(b(c)z(t)yd(e))';
1684            
1685            
1686             $z->putFirst(new 's'); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1687              
1688             is_deeply $a->brackets, 'a(b(c)z(st)yd(e))';
1689            
1690              
1691             =head2 putLast($parent, $child)
1692              
1693             Place a new child last under the specified parent and return the child.
1694              
1695             Parameter Description
1696             1 $parent Parent
1697             2 $child Child
1698              
1699             B
1700              
1701              
1702             my %l = map{$_->key=>$_} fromLetters('b(c)d(e)')->by;
1703             my ($a, $b, $d) = @l{qw(a b d)};
1704            
1705             my $z = $b->putNext(new 'z');
1706             is_deeply $z->brackets, 'z';
1707             is_deeply $a->brackets, 'a(b(c)zd(e))';
1708            
1709             my $y = $d->putPrev(new 'y');
1710             is_deeply $y->brackets, 'y';
1711             is_deeply $a->brackets, 'a(b(c)zyd(e))';
1712            
1713            
1714             $z->putLast(new 't'); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1715              
1716             is_deeply $z->brackets, 'z(t)';
1717             is_deeply $a->brackets, 'a(b(c)z(t)yd(e))';
1718            
1719             $z->putFirst(new 's');
1720             is_deeply $a->brackets, 'a(b(c)z(st)yd(e))';
1721            
1722              
1723             =head2 putNext($child, $new)
1724              
1725             Place a new child after the specified child.
1726              
1727             Parameter Description
1728             1 $child Existing child
1729             2 $new New child
1730              
1731             B
1732              
1733              
1734             my %l = map{$_->key=>$_} fromLetters('b(c)d(e)')->by;
1735             my ($a, $b, $d) = @l{qw(a b d)};
1736            
1737            
1738             my $z = $b->putNext(new 'z'); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1739              
1740             is_deeply $z->brackets, 'z';
1741             is_deeply $a->brackets, 'a(b(c)zd(e))';
1742            
1743             my $y = $d->putPrev(new 'y');
1744             is_deeply $y->brackets, 'y';
1745             is_deeply $a->brackets, 'a(b(c)zyd(e))';
1746            
1747             $z->putLast(new 't');
1748             is_deeply $z->brackets, 'z(t)';
1749             is_deeply $a->brackets, 'a(b(c)z(t)yd(e))';
1750            
1751             $z->putFirst(new 's');
1752             is_deeply $a->brackets, 'a(b(c)z(st)yd(e))';
1753            
1754              
1755             =head2 putPrev($child, $new)
1756              
1757             Place a new child before the specified child.
1758              
1759             Parameter Description
1760             1 $child Child
1761             2 $new New child
1762              
1763             B
1764              
1765              
1766             my %l = map{$_->key=>$_} fromLetters('b(c)d(e)')->by;
1767             my ($a, $b, $d) = @l{qw(a b d)};
1768            
1769             my $z = $b->putNext(new 'z');
1770             is_deeply $z->brackets, 'z';
1771             is_deeply $a->brackets, 'a(b(c)zd(e))';
1772            
1773            
1774             my $y = $d->putPrev(new 'y'); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1775              
1776             is_deeply $y->brackets, 'y';
1777             is_deeply $a->brackets, 'a(b(c)zyd(e))';
1778            
1779             $z->putLast(new 't');
1780             is_deeply $z->brackets, 'z(t)';
1781             is_deeply $a->brackets, 'a(b(c)z(t)yd(e))';
1782            
1783             $z->putFirst(new 's');
1784             is_deeply $a->brackets, 'a(b(c)z(st)yd(e))';
1785            
1786              
1787             =head1 Steps
1788              
1789             Move the start or end of a scope forwards or backwards as suggested by Alex Monroe.
1790              
1791             =head2 step($parent)
1792              
1793             Make the first child of the specified parent the parents previous sibling and return the parent. In effect this moves the start of the parent one step forwards.
1794              
1795             Parameter Description
1796             1 $parent Parent
1797              
1798             B
1799              
1800              
1801             my %l = map{$_->key=>$_} fromLetters('b(c)d(efgh(i(j)))')->by;
1802             my ($a, $b, $d) = @l{qw(a b d)};
1803            
1804             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
1805            
1806            
1807             $d->step; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1808              
1809             is_deeply $a->brackets, 'a(b(c)ed(fgh(i(j))))';
1810            
1811            
1812             $d->stepBack; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1813              
1814             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
1815            
1816            
1817             $b->stepEnd; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1818              
1819             is_deeply $a->brackets, 'a(b(cd(efgh(i(j)))))';
1820            
1821            
1822             $b->stepEndBack; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1823              
1824             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
1825            
1826              
1827             =head2 stepEnd($parent)
1828              
1829             Make the next sibling of the specified parent the parents last child and return the parent. In effect this moves the end of the parent one step forwards.
1830              
1831             Parameter Description
1832             1 $parent Parent
1833              
1834             B
1835              
1836              
1837             my %l = map{$_->key=>$_} fromLetters('b(c)d(efgh(i(j)))')->by;
1838             my ($a, $b, $d) = @l{qw(a b d)};
1839            
1840             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
1841            
1842             $d->step;
1843             is_deeply $a->brackets, 'a(b(c)ed(fgh(i(j))))';
1844            
1845             $d->stepBack;
1846             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
1847            
1848            
1849             $b->stepEnd; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1850              
1851             is_deeply $a->brackets, 'a(b(cd(efgh(i(j)))))';
1852            
1853            
1854             $b->stepEndBack; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1855              
1856             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
1857            
1858              
1859             =head2 stepBack()
1860              
1861             Make the previous sibling of the specified parent the parents first child and return the parent. In effect this moves the start of the parent one step backwards.
1862              
1863              
1864             B
1865              
1866              
1867             my %l = map{$_->key=>$_} fromLetters('b(c)d(efgh(i(j)))')->by;
1868             my ($a, $b, $d) = @l{qw(a b d)};
1869            
1870             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
1871            
1872             $d->step;
1873             is_deeply $a->brackets, 'a(b(c)ed(fgh(i(j))))';
1874            
1875            
1876             $d->stepBack; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1877              
1878             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
1879            
1880             $b->stepEnd;
1881             is_deeply $a->brackets, 'a(b(cd(efgh(i(j)))))';
1882            
1883             $b->stepEndBack;
1884             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
1885            
1886              
1887             =head2 stepEndBack()
1888              
1889             Make the last child of the specified parent the parents next sibling and return the parent. In effect this moves the end of the parent one step backwards.
1890              
1891              
1892             B
1893              
1894              
1895             my %l = map{$_->key=>$_} fromLetters('b(c)d(efgh(i(j)))')->by;
1896             my ($a, $b, $d) = @l{qw(a b d)};
1897            
1898             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
1899            
1900             $d->step;
1901             is_deeply $a->brackets, 'a(b(c)ed(fgh(i(j))))';
1902            
1903             $d->stepBack;
1904             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
1905            
1906             $b->stepEnd;
1907             is_deeply $a->brackets, 'a(b(cd(efgh(i(j)))))';
1908            
1909            
1910             $b->stepEndBack; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1911              
1912             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
1913            
1914              
1915             =head1 Edit
1916              
1917             Edit a tree in situ.
1918              
1919             =head2 cut($child)
1920              
1921             Cut out a child and all its content and children, return it ready for reinsertion else where.
1922              
1923             Parameter Description
1924             1 $child Child
1925              
1926             B
1927              
1928              
1929             my %l = map{$_->key=>$_} fromLetters('b(c)y(x)z(st)d(efgh(i(j))))')->by;
1930             my ($a, $x, $y, $z) = @l{qw(a x y z)};
1931            
1932             is_deeply [map {$_->key} $x->context], [qw(x y a)];
1933            
1934             is_deeply join(' ', $a->by(sub{$_[0]->key})), "c b x y s t z e f g j i h d a";
1935             is_deeply join(' ', map{$_->key} $a->by), "c b x y s t z e f g j i h d a";
1936            
1937            
1938             $z->cut; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1939              
1940             is_deeply $a->brackets, 'a(b(c)y(x)d(efgh(i(j))))';
1941            
1942             $y->unwrap;
1943             is_deeply $a->brackets, 'a(b(c)xd(efgh(i(j))))';
1944            
1945             $y = $x->wrap('y');
1946             is_deeply $y->brackets, 'y(x)';
1947             is_deeply $a->brackets, 'a(b(c)y(x)d(efgh(i(j))))';
1948            
1949             $y->putNext($y->dup);
1950             is_deeply $a->brackets, 'a(b(c)y(x)y(x)d(efgh(i(j))))';
1951            
1952              
1953             =head2 dup($parent)
1954              
1955             Duplicate a parent and all its descendants.
1956              
1957             Parameter Description
1958             1 $parent Parent
1959              
1960             B
1961              
1962              
1963             my %l = map{$_->key=>$_} fromLetters('b(c)y(x)z(st)d(efgh(i(j))))')->by;
1964             my ($a, $x, $y, $z) = @l{qw(a x y z)};
1965            
1966             is_deeply [map {$_->key} $x->context], [qw(x y a)];
1967            
1968             is_deeply join(' ', $a->by(sub{$_[0]->key})), "c b x y s t z e f g j i h d a";
1969             is_deeply join(' ', map{$_->key} $a->by), "c b x y s t z e f g j i h d a";
1970            
1971             $z->cut;
1972             is_deeply $a->brackets, 'a(b(c)y(x)d(efgh(i(j))))';
1973            
1974             $y->unwrap;
1975             is_deeply $a->brackets, 'a(b(c)xd(efgh(i(j))))';
1976            
1977             $y = $x->wrap('y');
1978             is_deeply $y->brackets, 'y(x)';
1979             is_deeply $a->brackets, 'a(b(c)y(x)d(efgh(i(j))))';
1980            
1981            
1982             $y->putNext($y->dup); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1983              
1984             is_deeply $a->brackets, 'a(b(c)y(x)y(x)d(efgh(i(j))))';
1985            
1986              
1987             =head2 unwrap($child)
1988              
1989             Unwrap the specified child and return that child.
1990              
1991             Parameter Description
1992             1 $child Child
1993              
1994             B
1995              
1996              
1997             my %l = map{$_->key=>$_} fromLetters('b(c)y(x)z(st)d(efgh(i(j))))')->by;
1998             my ($a, $x, $y, $z) = @l{qw(a x y z)};
1999            
2000             is_deeply [map {$_->key} $x->context], [qw(x y a)];
2001            
2002             is_deeply join(' ', $a->by(sub{$_[0]->key})), "c b x y s t z e f g j i h d a";
2003             is_deeply join(' ', map{$_->key} $a->by), "c b x y s t z e f g j i h d a";
2004            
2005             $z->cut;
2006             is_deeply $a->brackets, 'a(b(c)y(x)d(efgh(i(j))))';
2007            
2008            
2009             $y->unwrap; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2010              
2011             is_deeply $a->brackets, 'a(b(c)xd(efgh(i(j))))';
2012            
2013             $y = $x->wrap('y');
2014             is_deeply $y->brackets, 'y(x)';
2015             is_deeply $a->brackets, 'a(b(c)y(x)d(efgh(i(j))))';
2016            
2017             $y->putNext($y->dup);
2018             is_deeply $a->brackets, 'a(b(c)y(x)y(x)d(efgh(i(j))))';
2019            
2020              
2021             =head2 wrap($child, $key)
2022              
2023             Wrap the specified child with a new parent and return the new parent.
2024              
2025             Parameter Description
2026             1 $child Child to wrap
2027             2 $key User data for new wrapping parent
2028              
2029             B
2030              
2031              
2032             my %l = map{$_->key=>$_} fromLetters('b(c)y(x)z(st)d(efgh(i(j))))')->by;
2033             my ($a, $x, $y, $z) = @l{qw(a x y z)};
2034            
2035             is_deeply [map {$_->key} $x->context], [qw(x y a)];
2036            
2037             is_deeply join(' ', $a->by(sub{$_[0]->key})), "c b x y s t z e f g j i h d a";
2038             is_deeply join(' ', map{$_->key} $a->by), "c b x y s t z e f g j i h d a";
2039            
2040             $z->cut;
2041             is_deeply $a->brackets, 'a(b(c)y(x)d(efgh(i(j))))';
2042            
2043            
2044             $y->unwrap; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2045              
2046             is_deeply $a->brackets, 'a(b(c)xd(efgh(i(j))))';
2047            
2048            
2049             $y = $x->wrap('y'); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2050              
2051             is_deeply $y->brackets, 'y(x)';
2052             is_deeply $a->brackets, 'a(b(c)y(x)d(efgh(i(j))))';
2053            
2054             $y->putNext($y->dup);
2055             is_deeply $a->brackets, 'a(b(c)y(x)y(x)d(efgh(i(j))))';
2056            
2057              
2058             =head2 merge($parent)
2059              
2060             Merge the children of the specified parent with those of the surrounding parents if the L[key] data of those parents L that of the specified parent. Merged parents are unwrapped. Returns the specified parent regardless. From a proposal made by Micaela Monroe.
2061              
2062             Parameter Description
2063             1 $parent Merging parent
2064              
2065             B
2066              
2067              
2068             my %l = map{$_->key=>$_} fromLetters('b(c)d(efgh(i(j)))')->by;
2069             my ($a, $d) = @l{qw(a d)};
2070            
2071             $d->split;
2072             is_deeply $d->brackets, 'd(d(e)d(f)d(g)d(h(i(j))))';
2073             is_deeply $a->brackets, 'a(b(c)d(d(e)d(f)d(g)d(h(i(j)))))';
2074            
2075            
2076             $d->first->merge; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2077              
2078             is_deeply $d->brackets, 'd(d(efgh(i(j))))';
2079             is_deeply $a->brackets, 'a(b(c)d(d(efgh(i(j)))))';
2080            
2081             $d->first->unwrap;
2082             is_deeply $d->brackets, 'd(efgh(i(j)))';
2083             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
2084            
2085              
2086             =head2 split($parent)
2087              
2088             Make the specified parent a grandparent of each of its children by interposing a copy of the specified parent between the specified parent and each of its children. Return the specified parent.
2089              
2090             Parameter Description
2091             1 $parent Parent to make into a grand parent
2092              
2093             B
2094              
2095              
2096             my %l = map{$_->key=>$_} fromLetters('b(c)d(efgh(i(j)))')->by;
2097             my ($a, $d) = @l{qw(a d)};
2098            
2099            
2100             $d->split; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2101              
2102             is_deeply $d->brackets, 'd(d(e)d(f)d(g)d(h(i(j))))';
2103             is_deeply $a->brackets, 'a(b(c)d(d(e)d(f)d(g)d(h(i(j)))))';
2104            
2105             $d->first->merge;
2106             is_deeply $d->brackets, 'd(d(efgh(i(j))))';
2107             is_deeply $a->brackets, 'a(b(c)d(d(efgh(i(j)))))';
2108            
2109             $d->first->unwrap;
2110             is_deeply $d->brackets, 'd(efgh(i(j)))';
2111             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
2112            
2113              
2114             =head1 Traverse
2115              
2116             Traverse a tree.
2117              
2118             =head2 by($tree, $sub)
2119              
2120             Traverse a tree in post-order to process each child with the specified sub and return an array of the results of processing each child. If no sub sub is specified, the children are returned in tree order.
2121              
2122             Parameter Description
2123             1 $tree Tree
2124             2 $sub Optional sub to process each child
2125              
2126             B
2127              
2128              
2129            
2130             my %l = map{$_->key=>$_} fromLetters('b(c)y(x)z(st)d(efgh(i(j))))')->by; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2131              
2132             my ($a, $x, $y, $z) = @l{qw(a x y z)};
2133            
2134             is_deeply [map {$_->key} $x->context], [qw(x y a)];
2135            
2136            
2137             is_deeply join(' ', $a->by(sub{$_[0]->key})), "c b x y s t z e f g j i h d a"; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2138              
2139            
2140             is_deeply join(' ', map{$_->key} $a->by), "c b x y s t z e f g j i h d a"; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2141              
2142            
2143             $z->cut;
2144             is_deeply $a->brackets, 'a(b(c)y(x)d(efgh(i(j))))';
2145            
2146             $y->unwrap;
2147             is_deeply $a->brackets, 'a(b(c)xd(efgh(i(j))))';
2148            
2149             $y = $x->wrap('y');
2150             is_deeply $y->brackets, 'y(x)';
2151             is_deeply $a->brackets, 'a(b(c)y(x)d(efgh(i(j))))';
2152            
2153             $y->putNext($y->dup);
2154             is_deeply $a->brackets, 'a(b(c)y(x)y(x)d(efgh(i(j))))';
2155            
2156              
2157             =head2 select($tree, $select)
2158              
2159             Select matching children in a tree in post-order. A child can be selected via named value, array of values, a hash of values, a regular expression or a sub reference.
2160              
2161             Parameter Description
2162             1 $tree Tree
2163             2 $select Method to select a child
2164              
2165             B
2166              
2167              
2168             my $a = Tree::Ops::new 'a', 'A';
2169             for(1..2)
2170             {$a->open ('b', "B$_");
2171             $a->single('c', "C$_");
2172             ok $a->activeScope->key eq 'b';
2173             $a->close;
2174             }
2175             $a->single ('d', 'D');
2176             $a->single ('e', 'E');
2177             is_deeply $a->print, <
2178             Key Value
2179             a A
2180             b B1
2181             c C1
2182             b B2
2183             c C2
2184             d D
2185             e E
2186             END
2187            
2188             is_deeply [map{$_->value} $a->by], [qw(C1 B1 C2 B2 D E A)];
2189            
2190             is_deeply $a->lastMost->prev->prev->first->key, 'c';
2191             is_deeply $a->first->next->last->parent->first->value, 'C2';
2192            
2193            
2194             is_deeply [map{$_->value} $a->select('b')], [qw(B1 B2)]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2195              
2196            
2197             is_deeply [map{$_->value} $a->select(qr(b|c))], [qw(B1 C1 B2 C2)]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2198              
2199            
2200             is_deeply [map{$_->value} $a->select(sub{$_[0] eq 'd'})], [qw(D)]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2201              
2202            
2203             $a->first->next->stepEnd->stepEnd->first->next->stepBack;
2204             is_deeply $a->print, <
2205             Key Value
2206             a A
2207             b B1
2208             c C1
2209             b B2
2210             d D
2211             c C2
2212             e E
2213             END
2214            
2215              
2216             =head1 Partitions
2217              
2218             Various partitions of the tree
2219              
2220             =head2 leaves($tree)
2221              
2222             The set of all children without further children, i.e. each leaf of the tree.
2223              
2224             Parameter Description
2225             1 $tree Tree
2226              
2227             B
2228              
2229              
2230             my $a = fromLetters('b(c)y(x)d(efgh(i(j)))');
2231             is_deeply $a->print, <
2232             Key Value
2233             a
2234             b
2235             c
2236             y
2237             x
2238             d
2239             e
2240             f
2241             g
2242             h
2243             i
2244             j
2245             END
2246            
2247             is_deeply $a->xml,
2248             '';
2249            
2250             my ($c, $b, $x, $y, $e, $f, $g, $j, $i, $h, $d) = $a->by;
2251            
2252            
2253             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2254              
2255             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder];
2256             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder];
2257             is_deeply [$a->parents], [$a->parentsPostOrder];
2258            
2259             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder];
2260             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder];
2261            
2262             ok !$j->parents;
2263            
2264             ok $a->lastMost == $j;
2265             ok !$a->prevMost;
2266             ok $j->prevMost == $g;
2267             ok $i->prevMost == $g;
2268             ok $h->prevMost == $g;
2269             ok $g->prevMost == $f;
2270             ok $f->prevMost == $e;
2271             ok $e->prevMost == $x;
2272             ok $d->prevMost == $x;
2273             ok $x->prevMost == $c;
2274             ok $y->prevMost == $c;
2275             ok !$c->prevMost;
2276             ok !$b->prevMost;
2277             ok !$a->prevMost;
2278            
2279             ok $a->firstMost == $c;
2280             ok $a->nextMost == $c;
2281             ok $b->nextMost == $c;
2282             ok $c->nextMost == $x;
2283             ok $y->nextMost == $x;
2284             ok $x->nextMost == $e;
2285             ok $d->nextMost == $e;
2286             ok $e->nextMost == $f;
2287             ok $f->nextMost == $g;
2288             ok $g->nextMost == $j;
2289             ok $h->nextMost == $j;
2290             ok $i->nextMost == $j;
2291             ok !$j->nextMost;
2292            
2293              
2294             =head2 parentsPreOrder($tree)
2295              
2296             The set of all parents in the tree, i.e. each non leaf of the tree, i.e the interior of the tree in normal pre-order.
2297              
2298             Parameter Description
2299             1 $tree Tree
2300              
2301             B
2302              
2303              
2304             my $a = fromLetters('b(c)y(x)d(efgh(i(j)))');
2305             is_deeply $a->print, <
2306             Key Value
2307             a
2308             b
2309             c
2310             y
2311             x
2312             d
2313             e
2314             f
2315             g
2316             h
2317             i
2318             j
2319             END
2320            
2321             is_deeply $a->xml,
2322             '';
2323            
2324             my ($c, $b, $x, $y, $e, $f, $g, $j, $i, $h, $d) = $a->by;
2325            
2326             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves];
2327            
2328             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2329              
2330             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder];
2331             is_deeply [$a->parents], [$a->parentsPostOrder];
2332            
2333             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder];
2334             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder];
2335            
2336             ok !$j->parents;
2337            
2338             ok $a->lastMost == $j;
2339             ok !$a->prevMost;
2340             ok $j->prevMost == $g;
2341             ok $i->prevMost == $g;
2342             ok $h->prevMost == $g;
2343             ok $g->prevMost == $f;
2344             ok $f->prevMost == $e;
2345             ok $e->prevMost == $x;
2346             ok $d->prevMost == $x;
2347             ok $x->prevMost == $c;
2348             ok $y->prevMost == $c;
2349             ok !$c->prevMost;
2350             ok !$b->prevMost;
2351             ok !$a->prevMost;
2352            
2353             ok $a->firstMost == $c;
2354             ok $a->nextMost == $c;
2355             ok $b->nextMost == $c;
2356             ok $c->nextMost == $x;
2357             ok $y->nextMost == $x;
2358             ok $x->nextMost == $e;
2359             ok $d->nextMost == $e;
2360             ok $e->nextMost == $f;
2361             ok $f->nextMost == $g;
2362             ok $g->nextMost == $j;
2363             ok $h->nextMost == $j;
2364             ok $i->nextMost == $j;
2365             ok !$j->nextMost;
2366            
2367              
2368             =head2 parentsPostOrder($tree)
2369              
2370             The set of all parents in the tree, i.e. each non leaf of the tree, i.e the interior of the tree in normal post-order.
2371              
2372             Parameter Description
2373             1 $tree Tree
2374              
2375             B
2376              
2377              
2378             my $a = fromLetters('b(c)y(x)d(efgh(i(j)))');
2379             is_deeply $a->print, <
2380             Key Value
2381             a
2382             b
2383             c
2384             y
2385             x
2386             d
2387             e
2388             f
2389             g
2390             h
2391             i
2392             j
2393             END
2394            
2395             is_deeply $a->xml,
2396             '';
2397            
2398             my ($c, $b, $x, $y, $e, $f, $g, $j, $i, $h, $d) = $a->by;
2399            
2400             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves];
2401             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder];
2402            
2403             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2404              
2405            
2406             is_deeply [$a->parents], [$a->parentsPostOrder]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2407              
2408            
2409             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder];
2410             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder];
2411            
2412             ok !$j->parents;
2413            
2414             ok $a->lastMost == $j;
2415             ok !$a->prevMost;
2416             ok $j->prevMost == $g;
2417             ok $i->prevMost == $g;
2418             ok $h->prevMost == $g;
2419             ok $g->prevMost == $f;
2420             ok $f->prevMost == $e;
2421             ok $e->prevMost == $x;
2422             ok $d->prevMost == $x;
2423             ok $x->prevMost == $c;
2424             ok $y->prevMost == $c;
2425             ok !$c->prevMost;
2426             ok !$b->prevMost;
2427             ok !$a->prevMost;
2428            
2429             ok $a->firstMost == $c;
2430             ok $a->nextMost == $c;
2431             ok $b->nextMost == $c;
2432             ok $c->nextMost == $x;
2433             ok $y->nextMost == $x;
2434             ok $x->nextMost == $e;
2435             ok $d->nextMost == $e;
2436             ok $e->nextMost == $f;
2437             ok $f->nextMost == $g;
2438             ok $g->nextMost == $j;
2439             ok $h->nextMost == $j;
2440             ok $i->nextMost == $j;
2441             ok !$j->nextMost;
2442            
2443              
2444             =head2 parentsReversePreOrder($tree)
2445              
2446             The set of all parents in the tree, i.e. each non leaf of the tree, i.e the interior of the tree in reverse pre-order.
2447              
2448             Parameter Description
2449             1 $tree Tree
2450              
2451             B
2452              
2453              
2454             my $a = fromLetters('b(c)y(x)d(efgh(i(j)))');
2455             is_deeply $a->print, <
2456             Key Value
2457             a
2458             b
2459             c
2460             y
2461             x
2462             d
2463             e
2464             f
2465             g
2466             h
2467             i
2468             j
2469             END
2470            
2471             is_deeply $a->xml,
2472             '';
2473            
2474             my ($c, $b, $x, $y, $e, $f, $g, $j, $i, $h, $d) = $a->by;
2475            
2476             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves];
2477             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder];
2478             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder];
2479             is_deeply [$a->parents], [$a->parentsPostOrder];
2480            
2481            
2482             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2483              
2484             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder];
2485            
2486             ok !$j->parents;
2487            
2488             ok $a->lastMost == $j;
2489             ok !$a->prevMost;
2490             ok $j->prevMost == $g;
2491             ok $i->prevMost == $g;
2492             ok $h->prevMost == $g;
2493             ok $g->prevMost == $f;
2494             ok $f->prevMost == $e;
2495             ok $e->prevMost == $x;
2496             ok $d->prevMost == $x;
2497             ok $x->prevMost == $c;
2498             ok $y->prevMost == $c;
2499             ok !$c->prevMost;
2500             ok !$b->prevMost;
2501             ok !$a->prevMost;
2502            
2503             ok $a->firstMost == $c;
2504             ok $a->nextMost == $c;
2505             ok $b->nextMost == $c;
2506             ok $c->nextMost == $x;
2507             ok $y->nextMost == $x;
2508             ok $x->nextMost == $e;
2509             ok $d->nextMost == $e;
2510             ok $e->nextMost == $f;
2511             ok $f->nextMost == $g;
2512             ok $g->nextMost == $j;
2513             ok $h->nextMost == $j;
2514             ok $i->nextMost == $j;
2515             ok !$j->nextMost;
2516            
2517              
2518             =head2 parentsReversePostOrder($tree)
2519              
2520             The set of all parents in the tree, i.e. each non leaf of the tree, i.e the interior of the tree in reverse post-order.
2521              
2522             Parameter Description
2523             1 $tree Tree
2524              
2525             B
2526              
2527              
2528             my $a = fromLetters('b(c)y(x)d(efgh(i(j)))');
2529             is_deeply $a->print, <
2530             Key Value
2531             a
2532             b
2533             c
2534             y
2535             x
2536             d
2537             e
2538             f
2539             g
2540             h
2541             i
2542             j
2543             END
2544            
2545             is_deeply $a->xml,
2546             '';
2547            
2548             my ($c, $b, $x, $y, $e, $f, $g, $j, $i, $h, $d) = $a->by;
2549            
2550             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves];
2551             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder];
2552             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder];
2553             is_deeply [$a->parents], [$a->parentsPostOrder];
2554            
2555             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder];
2556            
2557             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2558              
2559            
2560             ok !$j->parents;
2561            
2562             ok $a->lastMost == $j;
2563             ok !$a->prevMost;
2564             ok $j->prevMost == $g;
2565             ok $i->prevMost == $g;
2566             ok $h->prevMost == $g;
2567             ok $g->prevMost == $f;
2568             ok $f->prevMost == $e;
2569             ok $e->prevMost == $x;
2570             ok $d->prevMost == $x;
2571             ok $x->prevMost == $c;
2572             ok $y->prevMost == $c;
2573             ok !$c->prevMost;
2574             ok !$b->prevMost;
2575             ok !$a->prevMost;
2576            
2577             ok $a->firstMost == $c;
2578             ok $a->nextMost == $c;
2579             ok $b->nextMost == $c;
2580             ok $c->nextMost == $x;
2581             ok $y->nextMost == $x;
2582             ok $x->nextMost == $e;
2583             ok $d->nextMost == $e;
2584             ok $e->nextMost == $f;
2585             ok $f->nextMost == $g;
2586             ok $g->nextMost == $j;
2587             ok $h->nextMost == $j;
2588             ok $i->nextMost == $j;
2589             ok !$j->nextMost;
2590            
2591              
2592             =head2 parents($tree)
2593              
2594             The set of all parents in the tree, i.e. each non leaf of the tree, i.e the interior of the tree in normal post-order.
2595              
2596             Parameter Description
2597             1 $tree Tree
2598              
2599             B
2600              
2601              
2602             my $a = fromLetters('b(c)y(x)d(efgh(i(j)))');
2603             is_deeply $a->print, <
2604             Key Value
2605             a
2606             b
2607             c
2608             y
2609             x
2610             d
2611             e
2612             f
2613             g
2614             h
2615             i
2616             j
2617             END
2618            
2619             is_deeply $a->xml,
2620             '';
2621            
2622             my ($c, $b, $x, $y, $e, $f, $g, $j, $i, $h, $d) = $a->by;
2623            
2624             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves];
2625            
2626             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2627              
2628            
2629             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2630              
2631            
2632             is_deeply [$a->parents], [$a->parentsPostOrder]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2633              
2634            
2635            
2636             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2637              
2638            
2639             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2640              
2641            
2642            
2643             ok !$j->parents; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2644              
2645            
2646             ok $a->lastMost == $j;
2647             ok !$a->prevMost;
2648             ok $j->prevMost == $g;
2649             ok $i->prevMost == $g;
2650             ok $h->prevMost == $g;
2651             ok $g->prevMost == $f;
2652             ok $f->prevMost == $e;
2653             ok $e->prevMost == $x;
2654             ok $d->prevMost == $x;
2655             ok $x->prevMost == $c;
2656             ok $y->prevMost == $c;
2657             ok !$c->prevMost;
2658             ok !$b->prevMost;
2659             ok !$a->prevMost;
2660            
2661             ok $a->firstMost == $c;
2662             ok $a->nextMost == $c;
2663             ok $b->nextMost == $c;
2664             ok $c->nextMost == $x;
2665             ok $y->nextMost == $x;
2666             ok $x->nextMost == $e;
2667             ok $d->nextMost == $e;
2668             ok $e->nextMost == $f;
2669             ok $f->nextMost == $g;
2670             ok $g->nextMost == $j;
2671             ok $h->nextMost == $j;
2672             ok $i->nextMost == $j;
2673             ok !$j->nextMost;
2674            
2675              
2676             =head1 Order
2677              
2678             Check the order and relative position of children in a tree.
2679              
2680             =head2 above($first, $second)
2681              
2682             Return the first child if it is above the second child else return B.
2683              
2684             Parameter Description
2685             1 $first First child
2686             2 $second Second child
2687              
2688             B
2689              
2690              
2691             my %l = map{$_->key=>$_} fromLetters('b(c(d(efgh(i(j)k)l)m)n')->by;
2692             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $k, $l, $m, $n) = @l{'a'..'n'};
2693            
2694             is_deeply $a->print, <
2695             Key Value
2696             a
2697             b
2698             c
2699             d
2700             e
2701             f
2702             g
2703             h
2704             i
2705             j
2706             k
2707             l
2708             m
2709             n
2710             END
2711            
2712            
2713             ok $c->above($j) == $c; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2714              
2715            
2716             ok !$m->above($j); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2717              
2718            
2719             ok $i->below($b) == $i;
2720             ok !$i->below($n);
2721            
2722             ok $n->after($e) == $n;
2723             ok !$k->after($c);
2724            
2725             ok $c->before($n) == $c;
2726             ok !$c->before($m);
2727            
2728             is_deeply [map{$_->key} $j->lineage($d)], [qw(j i h d)];
2729             ok !$d->lineage($m);
2730            
2731              
2732             =head2 below($first, $second)
2733              
2734             Return the first child if it is below the second child else return B.
2735              
2736             Parameter Description
2737             1 $first First child
2738             2 $second Second child
2739              
2740             B
2741              
2742              
2743             my %l = map{$_->key=>$_} fromLetters('b(c(d(efgh(i(j)k)l)m)n')->by;
2744             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $k, $l, $m, $n) = @l{'a'..'n'};
2745            
2746             is_deeply $a->print, <
2747             Key Value
2748             a
2749             b
2750             c
2751             d
2752             e
2753             f
2754             g
2755             h
2756             i
2757             j
2758             k
2759             l
2760             m
2761             n
2762             END
2763            
2764             ok $c->above($j) == $c;
2765             ok !$m->above($j);
2766            
2767            
2768             ok $i->below($b) == $i; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2769              
2770            
2771             ok !$i->below($n); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2772              
2773            
2774             ok $n->after($e) == $n;
2775             ok !$k->after($c);
2776            
2777             ok $c->before($n) == $c;
2778             ok !$c->before($m);
2779            
2780             is_deeply [map{$_->key} $j->lineage($d)], [qw(j i h d)];
2781             ok !$d->lineage($m);
2782            
2783              
2784             =head2 after($first, $second)
2785              
2786             Return the first child if it occurs strictly after the second child in the tree or else B if the first child is L, L or L the second child.
2787              
2788             Parameter Description
2789             1 $first First child
2790             2 $second Second child
2791              
2792             B
2793              
2794              
2795             my %l = map{$_->key=>$_} fromLetters('b(c(d(efgh(i(j)k)l)m)n')->by;
2796             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $k, $l, $m, $n) = @l{'a'..'n'};
2797            
2798             is_deeply $a->print, <
2799             Key Value
2800             a
2801             b
2802             c
2803             d
2804             e
2805             f
2806             g
2807             h
2808             i
2809             j
2810             k
2811             l
2812             m
2813             n
2814             END
2815            
2816             ok $c->above($j) == $c;
2817             ok !$m->above($j);
2818            
2819             ok $i->below($b) == $i;
2820             ok !$i->below($n);
2821            
2822            
2823             ok $n->after($e) == $n; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2824              
2825            
2826             ok !$k->after($c); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2827              
2828            
2829             ok $c->before($n) == $c;
2830             ok !$c->before($m);
2831            
2832             is_deeply [map{$_->key} $j->lineage($d)], [qw(j i h d)];
2833             ok !$d->lineage($m);
2834            
2835              
2836             =head2 before($first, $second)
2837              
2838             Return the first child if it occurs strictly before the second child in the tree or else B if the first child is L, L or L the second child.
2839              
2840             Parameter Description
2841             1 $first First child
2842             2 $second Second child
2843              
2844             B
2845              
2846              
2847             my %l = map{$_->key=>$_} fromLetters('b(c(d(efgh(i(j)k)l)m)n')->by;
2848             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $k, $l, $m, $n) = @l{'a'..'n'};
2849            
2850             is_deeply $a->print, <
2851             Key Value
2852             a
2853             b
2854             c
2855             d
2856             e
2857             f
2858             g
2859             h
2860             i
2861             j
2862             k
2863             l
2864             m
2865             n
2866             END
2867            
2868             ok $c->above($j) == $c;
2869             ok !$m->above($j);
2870            
2871             ok $i->below($b) == $i;
2872             ok !$i->below($n);
2873            
2874             ok $n->after($e) == $n;
2875             ok !$k->after($c);
2876            
2877            
2878             ok $c->before($n) == $c; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2879              
2880            
2881             ok !$c->before($m); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2882              
2883            
2884             is_deeply [map{$_->key} $j->lineage($d)], [qw(j i h d)];
2885             ok !$d->lineage($m);
2886            
2887              
2888             =head1 Paths
2889              
2890             Find paths between nodes
2891              
2892             =head2 siblingsBefore($child)
2893              
2894             Return a list of siblings before the specified child.
2895              
2896             Parameter Description
2897             1 $child Child
2898              
2899             B
2900              
2901              
2902             my $a = fromLetters('b(cde(f)ghi)j');
2903             my ($c, $d, $f, $e, $g, $h, $i, $b, $j) = $a->by;
2904             # ok eval qq(\$$_->key eq '$_') for 'a'..'j';
2905             is_deeply $a->print, <
2906             Key Value
2907             a
2908             b
2909             c
2910             d
2911             e
2912             f
2913             g
2914             h
2915             i
2916             j
2917             END
2918            
2919             is_deeply [$d->siblingsStrictlyBetween($h)], [$e, $g];
2920             is_deeply [$d->siblingsAfter], [$e, $g, $h, $i];
2921            
2922             is_deeply [$g->siblingsBefore], [$c, $d, $e]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2923              
2924             eval {$e->siblingsStrictlyBetween($f)};
2925             ok $@ =~ m(Must be siblings);
2926            
2927              
2928             =head2 siblingsAfter($child)
2929              
2930             Return a list of siblings after the specified child.
2931              
2932             Parameter Description
2933             1 $child Child
2934              
2935             B
2936              
2937              
2938             my $a = fromLetters('b(cde(f)ghi)j');
2939             my ($c, $d, $f, $e, $g, $h, $i, $b, $j) = $a->by;
2940             # ok eval qq(\$$_->key eq '$_') for 'a'..'j';
2941             is_deeply $a->print, <
2942             Key Value
2943             a
2944             b
2945             c
2946             d
2947             e
2948             f
2949             g
2950             h
2951             i
2952             j
2953             END
2954            
2955             is_deeply [$d->siblingsStrictlyBetween($h)], [$e, $g];
2956            
2957             is_deeply [$d->siblingsAfter], [$e, $g, $h, $i]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2958              
2959             is_deeply [$g->siblingsBefore], [$c, $d, $e];
2960             eval {$e->siblingsStrictlyBetween($f)};
2961             ok $@ =~ m(Must be siblings);
2962            
2963              
2964             =head2 siblingsStrictlyBetween($start, $finish)
2965              
2966             Return a list of the siblings strictly between two children of the same parent else return B.
2967              
2968             Parameter Description
2969             1 $start Start child
2970             2 $finish Finish child
2971              
2972             B
2973              
2974              
2975             my $a = fromLetters('b(cde(f)ghi)j');
2976             my ($c, $d, $f, $e, $g, $h, $i, $b, $j) = $a->by;
2977             # ok eval qq(\$$_->key eq '$_') for 'a'..'j';
2978             is_deeply $a->print, <
2979             Key Value
2980             a
2981             b
2982             c
2983             d
2984             e
2985             f
2986             g
2987             h
2988             i
2989             j
2990             END
2991            
2992            
2993             is_deeply [$d->siblingsStrictlyBetween($h)], [$e, $g]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2994              
2995             is_deeply [$d->siblingsAfter], [$e, $g, $h, $i];
2996             is_deeply [$g->siblingsBefore], [$c, $d, $e];
2997            
2998             eval {$e->siblingsStrictlyBetween($f)}; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2999              
3000             ok $@ =~ m(Must be siblings);
3001            
3002              
3003             =head2 lineage($child, $ancestor)
3004              
3005             Return the path from the specified child to the specified ancestor else return B if the child is not a descendant of the ancestor.
3006              
3007             Parameter Description
3008             1 $child Child
3009             2 $ancestor Ancestor
3010              
3011             B
3012              
3013              
3014             my %l = map{$_->key=>$_} fromLetters('b(c(d(efgh(i(j)k)l)m)n')->by;
3015             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $k, $l, $m, $n) = @l{'a'..'n'};
3016            
3017             is_deeply $a->print, <
3018             Key Value
3019             a
3020             b
3021             c
3022             d
3023             e
3024             f
3025             g
3026             h
3027             i
3028             j
3029             k
3030             l
3031             m
3032             n
3033             END
3034            
3035             ok $c->above($j) == $c;
3036             ok !$m->above($j);
3037            
3038             ok $i->below($b) == $i;
3039             ok !$i->below($n);
3040            
3041             ok $n->after($e) == $n;
3042             ok !$k->after($c);
3043            
3044             ok $c->before($n) == $c;
3045             ok !$c->before($m);
3046            
3047            
3048             is_deeply [map{$_->key} $j->lineage($d)], [qw(j i h d)]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3049              
3050            
3051             ok !$d->lineage($m); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3052              
3053            
3054              
3055             =head2 nextPreOrderPath($start)
3056              
3057             Return a list of children visited between the specified child and the next child in pre-order.
3058              
3059             Parameter Description
3060             1 $start The child at the start of the path
3061              
3062             B
3063              
3064              
3065             my @p = [my $a = fromLetters('b(c(d(e(fg)hi(j(kl)m)n)op)q)r')];
3066            
3067             for(1..99)
3068            
3069             {my @n = $p[-1][-1]->nextPreOrderPath; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3070              
3071             last unless @n;
3072             push @p, [@n];
3073             }
3074            
3075             is_deeply $a->print, <
3076             Key Value
3077             a
3078             b
3079             c
3080             d
3081             e
3082             f
3083             g
3084             h
3085             i
3086             j
3087             k
3088             l
3089             m
3090             n
3091             o
3092             p
3093             q
3094             r
3095             END
3096            
3097             my @pre = map{[map{$_->key} @$_]} @p;
3098             is_deeply scalar(@pre), scalar(['a'..'r']->@*);
3099             is_deeply [@pre],
3100             [["a"],
3101             ["b"],
3102             ["c"],
3103             ["d"],
3104             ["e"],
3105             ["f"],
3106             ["g"],
3107             ["e", "h"],
3108             ["i"],
3109             ["j"],
3110             ["k"],
3111             ["l"],
3112             ["j", "m"],
3113             ["i", "n"],
3114             ["d", "o"],
3115             ["p"],
3116             ["c", "q"],
3117             ["b", "r"]];
3118            
3119              
3120             =head2 nextPostOrderPath($start)
3121              
3122             Return a list of children visited between the specified child and the next child in post-order.
3123              
3124             Parameter Description
3125             1 $start The child at the start of the path
3126              
3127             B
3128              
3129              
3130             my @n = my $a = fromLetters('b(c(d(e(fg)hi(j(kl)m)n)op)q)r');
3131             my @p;
3132             for(1..99)
3133            
3134             {@n = $n[-1]->nextPostOrderPath; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3135              
3136             last unless @n;
3137             push @p, [@n];
3138             last if $n[-1] == $a;
3139             }
3140            
3141             is_deeply $a->print, <
3142             Key Value
3143             a
3144             b
3145             c
3146             d
3147             e
3148             f
3149             g
3150             h
3151             i
3152             j
3153             k
3154             l
3155             m
3156             n
3157             o
3158             p
3159             q
3160             r
3161             END
3162            
3163             my @post = map{[map{$_->key} @$_]} @p;
3164             is_deeply scalar(@post), scalar(['a'..'r']->@*);
3165             is_deeply [@post],
3166             [["b" .. "f"],
3167             ["g"],
3168             ["e"],
3169             ["h"],
3170             ["i", "j", "k"],
3171             ["l"],
3172             ["j"],
3173             ["m"],
3174             ["i"],
3175             ["n"],
3176             ["d"],
3177             ["o"],
3178             ["p"],
3179             ["c"],
3180             ["q"],
3181             ["b"],
3182             ["r"],
3183             ["a"]];
3184            
3185              
3186             =head2 prevPostOrderPath($start)
3187              
3188             Return a list of children visited between the specified child and the previous child in post-order.
3189              
3190             Parameter Description
3191             1 $start The child at the start of the path
3192              
3193             B
3194              
3195              
3196             my @p = [my $a = fromLetters('b(c(d(e(fg)hi(j(kl)m)n)op)q)r')];
3197            
3198             for(1..99)
3199            
3200             {my @n = $p[-1][-1]->prevPostOrderPath; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3201              
3202             last unless @n;
3203             push @p, [@n];
3204             }
3205            
3206             is_deeply $a->print, <
3207             Key Value
3208             a
3209             b
3210             c
3211             d
3212             e
3213             f
3214             g
3215             h
3216             i
3217             j
3218             k
3219             l
3220             m
3221             n
3222             o
3223             p
3224             q
3225             r
3226             END
3227            
3228             my @post = map{[map{$_->key} @$_]} @p;
3229             is_deeply scalar(@post), scalar(['a'..'r']->@*);
3230             is_deeply [@post],
3231             [["a"],
3232             ["r"],
3233             ["b"],
3234             ["q"],
3235             ["c"],
3236             ["p"],
3237             ["o"],
3238             ["d"],
3239             ["n"],
3240             ["i"],
3241             ["m"],
3242             ["j"],
3243             ["l"],
3244             ["k"],
3245             ["j", "i", "h"],
3246             ["e"],
3247             ["g"],
3248             ["f"]];
3249            
3250              
3251             =head2 prevPreOrderPath($start)
3252              
3253             Return a list of children visited between the specified child and the previous child in pre-order.
3254              
3255             Parameter Description
3256             1 $start The child at the start of the path
3257              
3258             B
3259              
3260              
3261             my @n = my $a = fromLetters('b(c(d(e(fg)hi(j(kl)m)n)op)q)r');
3262             my @p;
3263             for(1..99)
3264            
3265             {@n = $n[-1]->prevPreOrderPath; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3266              
3267             last unless @n;
3268             push @p, [@n];
3269             last if $n[-1] == $a;
3270             }
3271            
3272             is_deeply $a->print, <
3273             Key Value
3274             a
3275             b
3276             c
3277             d
3278             e
3279             f
3280             g
3281             h
3282             i
3283             j
3284             k
3285             l
3286             m
3287             n
3288             o
3289             p
3290             q
3291             r
3292             END
3293            
3294             my @pre = map{[map{$_->key} @$_]} @p;
3295             is_deeply scalar(@pre), scalar(['a'..'r']->@*);
3296             is_deeply [@pre],
3297             [["r"],
3298             ["b", "q"],
3299             ["c", "p"],
3300             ["o"],
3301             ["d", "n"],
3302             ["i", "m"],
3303             ["j", "l"],
3304             ["k"],
3305             ["j"],
3306             ["i"],
3307             ["h"],
3308             ["e", "g"],
3309             ["f"],
3310             ["e"],
3311             ["d"],
3312             ["c"],
3313             ["b"],
3314             ["a"]];
3315            
3316              
3317             =head1 Print
3318              
3319             Print a tree.
3320              
3321             =head2 printPreOrder($tree, $print)
3322              
3323             Print tree in normal pre-order.
3324              
3325             Parameter Description
3326             1 $tree Tree
3327             2 $print Optional print method
3328              
3329             B
3330              
3331              
3332             my ($c, $b, $d, $a) = fromLetters('b(c)d')->by;
3333             my sub test(@) {join ' ', map{join '', $_->key} @_}
3334            
3335            
3336             is_deeply $a->printPreOrder, <
3337              
3338             Key Value
3339             a
3340             b
3341             c
3342             d
3343             END
3344            
3345             is_deeply test($a->nextPreOrderPath), 'b';
3346             is_deeply test($b->nextPreOrderPath), 'c';
3347             is_deeply test($c->nextPreOrderPath), 'b d';
3348             is_deeply test($d->nextPreOrderPath), '';
3349            
3350             is_deeply $a->printPostOrder, <
3351             Key Value
3352             c
3353             b
3354             d
3355             a
3356             END
3357            
3358             is_deeply test($a->nextPostOrderPath), 'b c';
3359             is_deeply test($c->nextPostOrderPath), 'b';
3360             is_deeply test($b->nextPostOrderPath), 'd';
3361             is_deeply test($d->nextPostOrderPath), 'a';
3362            
3363             is_deeply $a->printReversePreOrder, <
3364             Key Value
3365             a
3366             d
3367             b
3368             c
3369             END
3370             is_deeply test($a->prevPreOrderPath), 'd';
3371             is_deeply test($d->prevPreOrderPath), 'b c';
3372             is_deeply test($c->prevPreOrderPath), 'b';
3373             is_deeply test($b->prevPreOrderPath), 'a';
3374            
3375             is_deeply $a->printReversePostOrder, <
3376             Key Value
3377             d
3378             c
3379             b
3380             a
3381             END
3382            
3383             is_deeply test($a->prevPostOrderPath), 'd';
3384             is_deeply test($d->prevPostOrderPath), 'b';
3385             is_deeply test($b->prevPostOrderPath), 'c';
3386             is_deeply test($c->prevPostOrderPath), '';
3387            
3388              
3389             =head2 printPostOrder($tree, $print)
3390              
3391             Print tree in normal post-order.
3392              
3393             Parameter Description
3394             1 $tree Tree
3395             2 $print Optional print method
3396              
3397             B
3398              
3399              
3400             my ($c, $b, $d, $a) = fromLetters('b(c)d')->by;
3401             my sub test(@) {join ' ', map{join '', $_->key} @_}
3402            
3403             is_deeply $a->printPreOrder, <
3404             Key Value
3405             a
3406             b
3407             c
3408             d
3409             END
3410            
3411             is_deeply test($a->nextPreOrderPath), 'b';
3412             is_deeply test($b->nextPreOrderPath), 'c';
3413             is_deeply test($c->nextPreOrderPath), 'b d';
3414             is_deeply test($d->nextPreOrderPath), '';
3415            
3416            
3417             is_deeply $a->printPostOrder, <
3418              
3419             Key Value
3420             c
3421             b
3422             d
3423             a
3424             END
3425            
3426             is_deeply test($a->nextPostOrderPath), 'b c';
3427             is_deeply test($c->nextPostOrderPath), 'b';
3428             is_deeply test($b->nextPostOrderPath), 'd';
3429             is_deeply test($d->nextPostOrderPath), 'a';
3430            
3431             is_deeply $a->printReversePreOrder, <
3432             Key Value
3433             a
3434             d
3435             b
3436             c
3437             END
3438             is_deeply test($a->prevPreOrderPath), 'd';
3439             is_deeply test($d->prevPreOrderPath), 'b c';
3440             is_deeply test($c->prevPreOrderPath), 'b';
3441             is_deeply test($b->prevPreOrderPath), 'a';
3442            
3443             is_deeply $a->printReversePostOrder, <
3444             Key Value
3445             d
3446             c
3447             b
3448             a
3449             END
3450            
3451             is_deeply test($a->prevPostOrderPath), 'd';
3452             is_deeply test($d->prevPostOrderPath), 'b';
3453             is_deeply test($b->prevPostOrderPath), 'c';
3454             is_deeply test($c->prevPostOrderPath), '';
3455            
3456              
3457             =head2 printReversePreOrder($tree, $print)
3458              
3459             Print tree in reverse pre-order
3460              
3461             Parameter Description
3462             1 $tree Tree
3463             2 $print Optional print method
3464              
3465             B
3466              
3467              
3468             my ($c, $b, $d, $a) = fromLetters('b(c)d')->by;
3469             my sub test(@) {join ' ', map{join '', $_->key} @_}
3470            
3471             is_deeply $a->printPreOrder, <
3472             Key Value
3473             a
3474             b
3475             c
3476             d
3477             END
3478            
3479             is_deeply test($a->nextPreOrderPath), 'b';
3480             is_deeply test($b->nextPreOrderPath), 'c';
3481             is_deeply test($c->nextPreOrderPath), 'b d';
3482             is_deeply test($d->nextPreOrderPath), '';
3483            
3484             is_deeply $a->printPostOrder, <
3485             Key Value
3486             c
3487             b
3488             d
3489             a
3490             END
3491            
3492             is_deeply test($a->nextPostOrderPath), 'b c';
3493             is_deeply test($c->nextPostOrderPath), 'b';
3494             is_deeply test($b->nextPostOrderPath), 'd';
3495             is_deeply test($d->nextPostOrderPath), 'a';
3496            
3497            
3498             is_deeply $a->printReversePreOrder, <
3499              
3500             Key Value
3501             a
3502             d
3503             b
3504             c
3505             END
3506             is_deeply test($a->prevPreOrderPath), 'd';
3507             is_deeply test($d->prevPreOrderPath), 'b c';
3508             is_deeply test($c->prevPreOrderPath), 'b';
3509             is_deeply test($b->prevPreOrderPath), 'a';
3510            
3511             is_deeply $a->printReversePostOrder, <
3512             Key Value
3513             d
3514             c
3515             b
3516             a
3517             END
3518            
3519             is_deeply test($a->prevPostOrderPath), 'd';
3520             is_deeply test($d->prevPostOrderPath), 'b';
3521             is_deeply test($b->prevPostOrderPath), 'c';
3522             is_deeply test($c->prevPostOrderPath), '';
3523            
3524              
3525             =head2 printReversePostOrder($tree, $print)
3526              
3527             Print tree in reverse post-order
3528              
3529             Parameter Description
3530             1 $tree Tree
3531             2 $print Optional print method
3532              
3533             B
3534              
3535              
3536             my ($c, $b, $d, $a) = fromLetters('b(c)d')->by;
3537             my sub test(@) {join ' ', map{join '', $_->key} @_}
3538            
3539             is_deeply $a->printPreOrder, <
3540             Key Value
3541             a
3542             b
3543             c
3544             d
3545             END
3546            
3547             is_deeply test($a->nextPreOrderPath), 'b';
3548             is_deeply test($b->nextPreOrderPath), 'c';
3549             is_deeply test($c->nextPreOrderPath), 'b d';
3550             is_deeply test($d->nextPreOrderPath), '';
3551            
3552             is_deeply $a->printPostOrder, <
3553             Key Value
3554             c
3555             b
3556             d
3557             a
3558             END
3559            
3560             is_deeply test($a->nextPostOrderPath), 'b c';
3561             is_deeply test($c->nextPostOrderPath), 'b';
3562             is_deeply test($b->nextPostOrderPath), 'd';
3563             is_deeply test($d->nextPostOrderPath), 'a';
3564            
3565             is_deeply $a->printReversePreOrder, <
3566             Key Value
3567             a
3568             d
3569             b
3570             c
3571             END
3572             is_deeply test($a->prevPreOrderPath), 'd';
3573             is_deeply test($d->prevPreOrderPath), 'b c';
3574             is_deeply test($c->prevPreOrderPath), 'b';
3575             is_deeply test($b->prevPreOrderPath), 'a';
3576            
3577            
3578             is_deeply $a->printReversePostOrder, <
3579              
3580             Key Value
3581             d
3582             c
3583             b
3584             a
3585             END
3586            
3587             is_deeply test($a->prevPostOrderPath), 'd';
3588             is_deeply test($d->prevPostOrderPath), 'b';
3589             is_deeply test($b->prevPostOrderPath), 'c';
3590             is_deeply test($c->prevPostOrderPath), '';
3591            
3592              
3593             =head2 print($tree, $print)
3594              
3595             Print tree in normal pre-order.
3596              
3597             Parameter Description
3598             1 $tree Tree
3599             2 $print Optional print method
3600              
3601             B
3602              
3603              
3604             my $a = fromLetters('b(c)y(x)d(efgh(i(j)))');
3605            
3606             is_deeply $a->print, <
3607              
3608             Key Value
3609             a
3610             b
3611             c
3612             y
3613             x
3614             d
3615             e
3616             f
3617             g
3618             h
3619             i
3620             j
3621             END
3622            
3623             is_deeply $a->xml,
3624             '';
3625            
3626             my ($c, $b, $x, $y, $e, $f, $g, $j, $i, $h, $d) = $a->by;
3627            
3628             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves];
3629             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder];
3630             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder];
3631             is_deeply [$a->parents], [$a->parentsPostOrder];
3632            
3633             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder];
3634             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder];
3635            
3636             ok !$j->parents;
3637            
3638             ok $a->lastMost == $j;
3639             ok !$a->prevMost;
3640             ok $j->prevMost == $g;
3641             ok $i->prevMost == $g;
3642             ok $h->prevMost == $g;
3643             ok $g->prevMost == $f;
3644             ok $f->prevMost == $e;
3645             ok $e->prevMost == $x;
3646             ok $d->prevMost == $x;
3647             ok $x->prevMost == $c;
3648             ok $y->prevMost == $c;
3649             ok !$c->prevMost;
3650             ok !$b->prevMost;
3651             ok !$a->prevMost;
3652            
3653             ok $a->firstMost == $c;
3654             ok $a->nextMost == $c;
3655             ok $b->nextMost == $c;
3656             ok $c->nextMost == $x;
3657             ok $y->nextMost == $x;
3658             ok $x->nextMost == $e;
3659             ok $d->nextMost == $e;
3660             ok $e->nextMost == $f;
3661             ok $f->nextMost == $g;
3662             ok $g->nextMost == $j;
3663             ok $h->nextMost == $j;
3664             ok $i->nextMost == $j;
3665             ok !$j->nextMost;
3666            
3667              
3668             =head2 brackets($tree, $print, $separator)
3669              
3670             Bracketed string representation of a tree.
3671              
3672             Parameter Description
3673             1 $tree Tree
3674             2 $print Optional print method
3675             3 $separator Optional child separator
3676              
3677             B
3678              
3679              
3680             my $a = fromLetters('b(c)y(x)d(efgh(i(j)))');
3681             is_deeply $a->print, <
3682             Key Value
3683             a
3684             b
3685             c
3686             y
3687             x
3688             d
3689             e
3690             f
3691             g
3692             h
3693             i
3694             j
3695             END
3696            
3697             is_deeply $a->xml,
3698             '';
3699            
3700             my ($c, $b, $x, $y, $e, $f, $g, $j, $i, $h, $d) = $a->by;
3701            
3702             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves];
3703             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder];
3704             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder];
3705             is_deeply [$a->parents], [$a->parentsPostOrder];
3706            
3707             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder];
3708             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder];
3709            
3710             ok !$j->parents;
3711            
3712             ok $a->lastMost == $j;
3713             ok !$a->prevMost;
3714             ok $j->prevMost == $g;
3715             ok $i->prevMost == $g;
3716             ok $h->prevMost == $g;
3717             ok $g->prevMost == $f;
3718             ok $f->prevMost == $e;
3719             ok $e->prevMost == $x;
3720             ok $d->prevMost == $x;
3721             ok $x->prevMost == $c;
3722             ok $y->prevMost == $c;
3723             ok !$c->prevMost;
3724             ok !$b->prevMost;
3725             ok !$a->prevMost;
3726            
3727             ok $a->firstMost == $c;
3728             ok $a->nextMost == $c;
3729             ok $b->nextMost == $c;
3730             ok $c->nextMost == $x;
3731             ok $y->nextMost == $x;
3732             ok $x->nextMost == $e;
3733             ok $d->nextMost == $e;
3734             ok $e->nextMost == $f;
3735             ok $f->nextMost == $g;
3736             ok $g->nextMost == $j;
3737             ok $h->nextMost == $j;
3738             ok $i->nextMost == $j;
3739             ok !$j->nextMost;
3740            
3741              
3742             =head2 xml($tree, $print)
3743              
3744             Print a tree as as xml.
3745              
3746             Parameter Description
3747             1 $tree Tree
3748             2 $print Optional print method
3749              
3750             B
3751              
3752              
3753             my $a = fromLetters('b(c)y(x)d(efgh(i(j)))');
3754             is_deeply $a->print, <
3755             Key Value
3756             a
3757             b
3758             c
3759             y
3760             x
3761             d
3762             e
3763             f
3764             g
3765             h
3766             i
3767             j
3768             END
3769            
3770            
3771             is_deeply $a->xml, # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3772              
3773             '';
3774            
3775             my ($c, $b, $x, $y, $e, $f, $g, $j, $i, $h, $d) = $a->by;
3776            
3777             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves];
3778             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder];
3779             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder];
3780             is_deeply [$a->parents], [$a->parentsPostOrder];
3781            
3782             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder];
3783             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder];
3784            
3785             ok !$j->parents;
3786            
3787             ok $a->lastMost == $j;
3788             ok !$a->prevMost;
3789             ok $j->prevMost == $g;
3790             ok $i->prevMost == $g;
3791             ok $h->prevMost == $g;
3792             ok $g->prevMost == $f;
3793             ok $f->prevMost == $e;
3794             ok $e->prevMost == $x;
3795             ok $d->prevMost == $x;
3796             ok $x->prevMost == $c;
3797             ok $y->prevMost == $c;
3798             ok !$c->prevMost;
3799             ok !$b->prevMost;
3800             ok !$a->prevMost;
3801            
3802             ok $a->firstMost == $c;
3803             ok $a->nextMost == $c;
3804             ok $b->nextMost == $c;
3805             ok $c->nextMost == $x;
3806             ok $y->nextMost == $x;
3807             ok $x->nextMost == $e;
3808             ok $d->nextMost == $e;
3809             ok $e->nextMost == $f;
3810             ok $f->nextMost == $g;
3811             ok $g->nextMost == $j;
3812             ok $h->nextMost == $j;
3813             ok $i->nextMost == $j;
3814             ok !$j->nextMost;
3815            
3816              
3817             =head1 Data Structures
3818              
3819             Data structures use by this package.
3820              
3821              
3822             =head2 Tree::Ops Definition
3823              
3824              
3825             Child in the tree.
3826              
3827              
3828              
3829              
3830             =head3 Output fields
3831              
3832              
3833             B - Children of this child.
3834              
3835             B - Key for this child - any thing that can be compared with the L operator.
3836              
3837             B - Last active child chain - enables us to find the currently open scope from the start if the tree.
3838              
3839             B - Parent for this child.
3840              
3841             B - Value for this child.
3842              
3843              
3844              
3845             =head1 Private Methods
3846              
3847             =head2 setParentOfChild($child, $parent)
3848              
3849             Set the parent of a child and return the child.
3850              
3851             Parameter Description
3852             1 $child Child
3853             2 $parent Parent
3854              
3855             =head2 indexOfChildInParent($child)
3856              
3857             Get the index of a child within the specified parent.
3858              
3859             Parameter Description
3860             1 $child Child
3861              
3862             =head2 parentsOrdered($tree, $preorder, $reverse)
3863              
3864             The set of all parents in the tree, i.e. each non leaf of the tree, i.e the interior of the tree in the specified order.
3865              
3866             Parameter Description
3867             1 $tree Tree
3868             2 $preorder Pre-order if true else post-order
3869             3 $reverse Reversed if true
3870              
3871             =head2 printTree($tree, $print, $preorder, $reverse)
3872              
3873             String representation as a horizontal tree.
3874              
3875             Parameter Description
3876             1 $tree Tree
3877             2 $print Optional print method
3878             3 $preorder Pre-order
3879             4 $reverse Reverse
3880              
3881              
3882             =head1 Index
3883              
3884              
3885             1 L - Return the first child if it is above the second child else return B.
3886              
3887             2 L - Locate the active scope in a tree.
3888              
3889             3 L - Return the first child if it occurs strictly after the second child in the tree or else B if the first child is L, L or L the second child.
3890              
3891             4 L - Return the first child if it occurs strictly before the second child in the tree or else B if the first child is L, L or L the second child.
3892              
3893             5 L - Return the first child if it is below the second child else return B.
3894              
3895             6 L - Bracketed string representation of a tree.
3896              
3897             7 L - Traverse a tree in post-order to process each child with the specified sub and return an array of the results of processing each child.
3898              
3899             8 L - Close the current scope returning to the previous scope.
3900              
3901             9 L - Get the context of the current child.
3902              
3903             10 L - Cut out a child and all its content and children, return it ready for reinsertion else where.
3904              
3905             11 L - Duplicate a parent and all its descendants.
3906              
3907             12 L - Return the specified parent if it has no children else B
3908              
3909             13 L - Get the first child under the specified parent.
3910              
3911             14 L - Return the first most descendant child in the tree starting at this parent or else return B if this parent has no children.
3912              
3913             15 L - Create a tree from a string of letters - useful for testing.
3914              
3915             16 L - Include the specified tree in the currently open scope.
3916              
3917             17 L - Get the index of a child within the specified parent.
3918              
3919             18 L - Return the specified child if that child is first under its parent, else return B.
3920              
3921             19 L - Return the specified child if that child is last under its parent, else return B.
3922              
3923             20 L - Get the last child under the specified parent.
3924              
3925             21 L - Return the last most descendant child in the tree starting at this parent or else return B if this parent has no children.
3926              
3927             22 L - The set of all children without further children, i.
3928              
3929             23 L - Return the path from the specified child to the specified ancestor else return B if the child is not a descendant of the ancestor.
3930              
3931             24 L - Merge the children of the specified parent with those of the surrounding parents if the L[key] data of those parents L that of the specified parent.
3932              
3933             25 L - Find the most recent common ancestor of the specified children.
3934              
3935             26 L - Create a new child optionally recording the specified key or value.
3936              
3937             27 L - Get the next sibling following the specified child.
3938              
3939             28 L - Return the next child with no children, i.
3940              
3941             29 L - Return a list of children visited between the specified child and the next child in post-order.
3942              
3943             30 L - Return a list of children visited between the specified child and the next child in pre-order.
3944              
3945             31 L - Add a child and make it the currently active scope into which new children will be added.
3946              
3947             32 L - The set of all parents in the tree, i.
3948              
3949             33 L - The set of all parents in the tree, i.
3950              
3951             34 L - The set of all parents in the tree, i.
3952              
3953             35 L - The set of all parents in the tree, i.
3954              
3955             36 L - The set of all parents in the tree, i.
3956              
3957             37 L - The set of all parents in the tree, i.
3958              
3959             38 L - Get the previous sibling of the specified child.
3960              
3961             39 L - Return the previous child with no children, i.
3962              
3963             40 L - Return a list of children visited between the specified child and the previous child in post-order.
3964              
3965             41 L - Return a list of children visited between the specified child and the previous child in pre-order.
3966              
3967             42 L - Print tree in normal pre-order.
3968              
3969             43 L - Print tree in normal post-order.
3970              
3971             44 L - Print tree in normal pre-order.
3972              
3973             45 L - Print tree in reverse post-order
3974              
3975             46 L - Print tree in reverse pre-order
3976              
3977             47 L - String representation as a horizontal tree.
3978              
3979             48 L - Place a new child first under the specified parent and return the child.
3980              
3981             49 L - Place a new child last under the specified parent and return the child.
3982              
3983             50 L - Place a new child after the specified child.
3984              
3985             51 L - Place a new child before the specified child.
3986              
3987             52 L - Select matching children in a tree in post-order.
3988              
3989             53 L - Set the parent of a child and return the child.
3990              
3991             54 L - Return a list of siblings after the specified child.
3992              
3993             55 L - Return a list of siblings before the specified child.
3994              
3995             56 L - Return a list of the siblings strictly between two children of the same parent else return B.
3996              
3997             57 L - Add one child in the current scope.
3998              
3999             58 L - Return the only child of this parent if the parent has an only child, else B
4000              
4001             59 L - Make the specified parent a grandparent of each of its children by interposing a copy of the specified parent between the specified parent and each of its children.
4002              
4003             60 L - Make the first child of the specified parent the parents previous sibling and return the parent.
4004              
4005             61 L - Make the previous sibling of the specified parent the parents first child and return the parent.
4006              
4007             62 L - Make the next sibling of the specified parent the parents last child and return the parent.
4008              
4009             63 L - Make the last child of the specified parent the parents next sibling and return the parent.
4010              
4011             64 L - Unwrap the specified child and return that child.
4012              
4013             65 L - Wrap the specified child with a new parent and return the new parent.
4014              
4015             66 L - Print a tree as as xml.
4016              
4017             =head1 Installation
4018              
4019             This module is written in 100% Pure Perl and, thus, it is easy to read,
4020             comprehend, use, modify and install via B:
4021              
4022             sudo cpan install Tree::Ops
4023              
4024             =head1 Author
4025              
4026             L
4027              
4028             L
4029              
4030             =head1 Copyright
4031              
4032             Copyright (c) 2016-2019 Philip R Brenan.
4033              
4034             This module is free software. It may be used, redistributed and/or modified
4035             under the same terms as Perl itself.
4036              
4037             =cut
4038              
4039              
4040              
4041             # Tests and documentation
4042              
4043             sub test
4044 1     1 0 7 {my $p = __PACKAGE__;
4045 1         10 binmode($_, ":utf8") for *STDOUT, *STDERR;
4046 1 50       79 return if eval "eof(${p}::DATA)";
4047 1         58 my $s = eval "join('', <${p}::DATA>)";
4048 1 50       12 $@ and die $@;
4049 1     1   7 eval $s;
  1     1   2  
  1     1   35  
  1     1   6  
  1         2  
  1         28  
  1         5  
  1         1  
  1         15  
  1         794  
  1         65847  
  1         12  
  1         73  
4050 1 50       11 $@ and die $@;
4051 1         150 1
4052             }
4053              
4054             test unless caller;
4055              
4056             1;
4057             # podDocumentation
4058             __DATA__