File Coverage

blib/lib/Tree/Ops.pm
Criterion Covered Total %
statement 431 436 98.8
branch 140 172 81.4
condition 28 40 70.0
subroutine 104 104 100.0
pod 75 76 98.6
total 778 828 93.9


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 = 20201030;
9             require v5.26;
10 1     1   1258 use warnings FATAL => qw(all);
  1         9  
  1         94  
11 1     1   7 use strict;
  1         2  
  1         32  
12 1     1   6 use Carp;
  1         2  
  1         85  
13 1     1   576 use Data::Dump qw(dump);
  1         9910  
  1         70  
14 1     1   4498 use Data::Table::Text qw(:all);
  1         137986  
  1         1711  
15 1     1   13 use feature qw(current_sub say);
  1         2  
  1         146  
16 1     1   768 use experimental qw(smartmatch);
  1         3642  
  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 263     263 1 776 {my ($key, $value) = @_; # Key, value
24 263         713 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 426     426 1 564 {my ($tree) = @_; # Tree
35 426         489 my $active; # Latest active child
36 426         865 for(my $l = $tree; $l; $l = $l->lastChild) {$active = $l} # Skip down edge of parse tree to deepest active child.
  1331         23060  
37 426         1858 $active
38             }
39              
40             sub setParentOfChild($$) #P Set the parent of a child and return the child.
41 227     227 1 415 {my ($child, $parent) = @_; # Child, parent
42 227         3530 $child->parent = $parent; # Parent child
43 227         1041 $child
44             }
45              
46             sub open($;$$) # Add a child and make it the currently active scope into which new children will be added.
47 213     213 1 359 {my ($tree, $key, $value) = @_; # Tree, key, value to be recorded in the interior child being opened
48 213         370 my $parent = activeScope $tree; # Active parent
49 213         440 my $child = new $key, $value; # New child
50 213         16871 push $parent->children->@*, $child; # Place new child last under parent
51 213         4141 $parent->lastChild = $child; # Make child active
52 213         866 setParentOfChild $child, $parent # Parent child
53             }
54              
55             sub close($) # Close the current scope returning to the previous scope.
56 210     210 1 325 {my ($tree) = @_; # Tree
57 210         314 my $parent = activeScope $tree; # Locate active scope
58 210 100       3332 delete $parent->parent->{lastChild} if $parent->parent; # Close scope
59 210         4530 $parent
60             }
61              
62             sub single($;$$) # Add one child in the current scope.
63 129     129 1 234 {my ($tree, $key, $value) = @_; # Tree, key, value to be recorded in the child being created
64 129         334 $tree->open($key, $value); # Open scope
65 129         276 $tree->close; # Close scope immediately
66             }
67              
68             sub include($$) # Include the specified tree in the currently open scope.
69 1     1 1 3 {my ($tree, $include) = @_; # Tree being built, tree to include
70 1         5 my $parent = activeScope $tree; # Active parent
71 1         18 my $n = new $include->key, $include->value; # New intermediate child
72 1         83 $n->children = $include->children; # Include children
73 1         23 $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 returning the children created in alphabetic order - useful for testing.
78 20     20 1 51 {my ($letters) = @_; # String of letters and ( ).
79 20         62 my $t = new(my $s = 'a');
80 20         1558 my @l = split //, $letters;
81              
82 20         41 my @c; # Last letter seen
83 20         88 for my $l(split(//, $letters), '') # Each letter
84 371         611 {my $c = shift @c; # Last letter
85 371 50       826 if ($l eq '(') {$t->open ($c) if $c} # Open new scope
  77 100       215  
    100          
86 77 100       241 elsif ($l eq ')') {$t->single($c) if $c; $t->close} # Close scope
  77         149  
87 217 100       466 else {$t->single($c) if $c; @c = $l} # Save current letter as last letter
  217         526  
88             }
89              
90 20         90 sort {$a->key cmp $b->key} $t->by # Sorted results
  514         9432  
91             }
92              
93             #D1 Navigation # Navigate through a tree.
94              
95             sub first($) # Get the first child under the specified parent.
96 84     84 1 227 {my ($parent) = @_; # Parent
97 84         1298 $parent->children->[0]
98             }
99              
100             sub last($) # Get the last child under the specified parent.
101 68     68 1 167 {my ($parent) = @_; # Parent
102 68         1072 $parent->children->[-1]
103             }
104              
105             sub indexOfChildInParent($) #P Get the index of a child within the specified parent.
106 152     152 1 262 {my ($child) = @_; # Child
107 152 50       2361 return undef unless my $parent = $child->parent; # Parent
108 152         2787 my $c = $parent->children; # Siblings
109 152 100       753 for(keys @$c) {return $_ if $$c[$_] == $child} # Locate child and return index
  295         1359  
110             undef # Root has no index
111 0         0 }
112              
113             sub next($) # Get the next sibling following the specified child.
114 54     54 1 109 {my ($child) = @_; # Child
115 54 100       849 return undef unless my $parent = $child->parent; # Parent
116 50         897 my $c = $parent->children; # Siblings
117 50 100 66     333 return undef if @$c == 0 or $$c[-1] == $child; # No next child
118 49         118 $$c[+1 + indexOfChildInParent $child] # Next child
119             }
120              
121             sub prev($) # Get the previous sibling of the specified child.
122 64     64 1 115 {my ($child) = @_; # Child
123 64 100       1028 return undef unless my $parent = $child->parent; # Parent
124 56         1009 my $c = $parent->children; # Siblings
125 56 100 66     374 return undef if @$c == 0 or $$c[0] == $child; # No previous child
126 55         129 $$c[-1 + indexOfChildInParent $child] # Previous child
127             }
128              
129             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.
130 19     19 1 84 {my ($parent) = @_; # Parent
131 19         30 my $f;
132 19         42 for(my $p = $parent; $p; $p = $p->first) {$f = $p} # Go first most
  44         184  
133 19         157 $f
134             }
135              
136             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.
137 20     20 1 44 {my ($child) = @_; # Current leaf
138 20 100       333 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.
139 9         48 my $p = $child; # Traverse upwards and then right
140 9         25 $p = $p->parent while $p->isLast; # Traverse upwards
141 9 100       64 return undef unless $p = $p->next; # Traverse right else we are at the root
142 7         17 firstMost $p # First most child
143             }
144              
145             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.
146 21     21 1 45 {my ($child) = @_; # Current leaf
147 21         35 my $p = $child; # Traverse upwards and then left
148 21         51 $p = $p->parent while $p->isFirst; # Traverse upwards
149 21 100       143 return undef unless $p = $p->prev; # Traverse left else we are at the root
150 15         36 lastMost $p # Last most child
151             }
152              
153             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.
154 17     17 1 32 {my ($parent) = @_; # Parent
155 17         23 my $f;
156 17         41 for(my $p = $parent; $p; $p = $p->last) {$f = $p} # Go last most
  32         120  
157 17         139 $f
158             }
159              
160             sub topMost($) # Return the top most parent in the tree containing the specified child.
161 1     1 1 3 {my ($child) = @_; # Child
162 1 100       5 for(my $p = $child; $p;) {return $p unless my $q = $p->parent; $p = $q} # Go up
  4         67  
  3         16  
163 0         0 confess "Child required";
164             }
165              
166             sub mostRecentCommonAncestor($$) # Find the most recent common ancestor of the specified children.
167 2     2 1 8 {my ($first, $second) = @_; # First child, second child
168 2 50       9 return $first if $first == $second; # Same first and second child
169 2         6 my @f = context $first; # Context of first child
170 2         6 my @s = context $second; # Context of second child
171 2   33     4 my $c; $c = pop @f, pop @s while @f and @s and $f[-1] == $s[-1]; # Remove common ancestors
  2   66     23  
172 2         10 $c
173             }
174              
175             sub go($@) # Return the child at the end of the path starting at the specified parent. A path is a list of zero based children numbers. Return B if the path is not valid.
176 10     10 1 23 {my ($parent, @path) = @_; # Parent, list of zero based children numbers
177 10         14 my $p = $parent; # Start
178 10 50       12 my $q; defined($q = $p->children->[$_]) ? $p = $q : return undef for @path; # Down # Same first and second child
  10         149  
179 10         339 $p
180             }
181              
182             #D1 Location # Verify the current location.
183              
184             sub context($) # Get the context of the current child.
185 21     21 1 39 {my ($child) = @_; # Child
186 21         29 my @c; # Context
187 21         46 for(my $c = $child; $c; $c = $c->parent) {push @c, $c} # Walk up
  88         1574  
188             @c
189 21         162 }
190              
191             sub isFirst($) # Return the specified child if that child is first under its parent, else return B.
192 80     80 1 678 {my ($child) = @_; # Child
193 80 100       1258 return undef unless my $parent = $child->parent; # Parent
194 72 100       1357 $parent->children->[0] == $child ? $child : undef # There will be at least one child
195             }
196              
197             sub isLast($) # Return the specified child if that child is last under its parent, else return B.
198 64     64 1 527 {my ($child) = @_; # Child
199 64 100       1007 return undef unless my $parent = $child->parent; # Parent
200 60         1101 my $c = $parent->children;
201 60 100       1015 $parent->children->[-1] == $child ? $child : undef # There will be at least one child
202             }
203              
204             sub isTop($) # Return the specified parent if that parent is the top most parent in the tree.
205 2     2 1 6 {my ($parent) = @_; # Parent
206 2 100       36 $parent->parent ? undef : $parent
207             }
208              
209             sub singleChildOfParent($) # Return the only child of this parent if the parent has an only child, else B
210 1     1 1 4 {my ($parent) = @_; # Parent
211 1 50       18 $parent->children->@* == 1 ? $parent->children->[0] : undef # Return only child if it exists
212             }
213              
214             sub empty($) # Return the specified parent if it has no children else B
215 2     2 1 5 {my ($parent) = @_; # Parent
216 2 100       34 $parent->children->@* == 0 ? $parent : undef
217             }
218              
219             #D1 Put # Insert children into a tree.
220              
221             sub putFirst($$) # Place a new child first under the specified parent and return the child.
222 4     4 1 85 {my ($parent, $child) = @_; # Parent, child
223 4         75 unshift $parent->children->@*, $child; # Place child
224 4         27 setParentOfChild $child, $parent # Parent child
225             }
226              
227             sub putLast($$) # Place a new child last under the specified parent and return the child.
228 6     6 1 84 {my ($parent, $child) = @_; # Parent, child
229 6         101 push $parent->children->@*, $child; # Place child
230 6         35 setParentOfChild $child, $parent # Parent child
231             }
232              
233             sub putNext($$) # Place a new child after the specified child.
234 2     2 1 75 {my ($child, $new) = @_; # Existing child, new child
235 2 50       7 return undef unless defined(my $i = indexOfChildInParent $child); # Locate child within parent
236 2         42 splice $child->parent->children->@*, $i, 1, $child, $new; # Place new child
237 2         79 setParentOfChild $new, $child->parent # Parent child
238             }
239              
240             sub putPrev($$) # Place a new child before the specified child.
241 2     2 1 75 {my ($child, $new) = @_; # Child, new child
242 2 50       7 return undef unless defined(my $i = indexOfChildInParent($child)); # Locate child within parent
243 2         35 splice $child->parent->children->@*, $i, 1, $new, $child; # Place new child
244 2         72 setParentOfChild $new, $child->parent # Parent child
245             }
246              
247             #D1 Steps # Move the start or end of a scope forwards or backwards as suggested by Alex Monroe.
248              
249             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.
250 1     1 1 4 {my ($parent) = @_; # Parent
251 1 50       4 return undef unless my $f = $parent->first; # First child
252 1         12 putPrev $parent, cut $f; # Place first child
253 1         16 $parent
254             }
255              
256             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.
257 3     3 1 8 {my ($parent) = @_; # Parent
258 3 50       8 return undef unless my $n = $parent->next; # Next sibling
259 3         15 putLast $parent, cut $n; # Place next sibling as first child
260 3         22 $parent
261             }
262              
263             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.
264 2     2 1 7 {my ($parent) = @_; # Parent
265 2 50       7 return undef unless my $p = $parent->prev; # Previous sibling
266 2         7 putFirst $parent, cut $p; # Place previous sibling as first child
267 2         32 $parent
268             }
269              
270             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.
271 1     1 1 3 {my ($parent) = @_; # Parent
272 1 50       4 return undef unless my $l = $parent->last; # Last child sibling
273 1         10 putNext $parent, cut $l; # Place last child as first sibling
274 1         16 $parent
275             }
276              
277             #D1 Edit # Edit a tree in situ.
278              
279             sub cut($) # Cut out a child and all its content and children, return it ready for reinsertion else where.
280 10     10 1 22 {my ($child) = @_; # Child
281 10 50       184 return $child unless my $parent = $child->parent; # The whole tree
282 10         193 splice $parent->children->@*, indexOfChildInParent($child), 1; # Remove child
283 10         59 $child
284             }
285              
286             sub dup($) # Duplicate a specified parent and all its descendants returning the root of the resulting tree.
287 1     1 1 51 {my ($parent) = @_; # Parent
288              
289             sub # Duplicate a child
290 8     8   95 {my ($old) = @_; # Existing child
291 8         131 my $new = new $old->key, $old->value; # New child
292 8         599 push $new->children->@*, __SUB__->($_) for $old->children->@*; # Duplicate children of child
293 8         91 $new
294 1         10 }->($parent) # Start duplication at parent
295             }
296              
297             sub transcribe($) # Duplicate a specified parent and all its descendants recording the mapping in a temporary {transcribed} field in the tree being transcribed. Returns the root parent of the tree being duplicated.
298 1     1 1 2 {my ($parent) = @_; # Parent
299              
300             sub # Duplicate a child
301 8     8   116 {my ($old) = @_; # Existing child
302 8         163 my $new = new $old->key, $old->value; # New child
303 8         477 $old->{transcribedTo} = $new; # To where we went
304 8         12 $new->{transcribedFrom} = $old; # From where we came
305 8         138 push $new->children->@*, __SUB__->($_) for $old->children->@*; # Duplicate children of child and record transcription
306 8         104 $new
307 1         7 }->($parent) # Start duplication at parent
308             }
309              
310             sub unwrap($) # Unwrap the specified child and return that child.
311 5     5 1 28 {my ($child) = @_; # Child
312 5 50       13 return undef unless defined(my $i = indexOfChildInParent $child); # Locate child within parent
313 5         84 my $parent = $child->parent; # Parent
314 5         87 $_->parent = $parent for $child->children->@*; # Reparent unwrapped children of child
315 5         139 delete $child ->{parent}; # Remove parent of unwrapped child
316 5         77 splice $parent->children->@*, $i, 1, $child->children->@*; # Remove child
317 5         84 $parent
318             }
319              
320             sub wrap($;$$) # Wrap the specified child with a new parent and return the new parent optionally setting its L[key] and L[value].
321 5     5 1 93 {my ($child, $key, $value) = @_; # Child to wrap, optional key, optional value
322 5 50       14 return undef unless defined(my $i = indexOfChildInParent $child); # Locate child within existing parent
323 5         84 my $parent = $child->parent; # Existing parent
324 5         23 my $new = new $key, $value; # Create new parent
325 5         395 $new->parent = $parent; # Parent new parent
326 5         92 $new->children = [$child]; # Set children for new parent
327 5         89 splice $parent->children->@*, $i, 1, $new; # Place new parent in existing parent
328 5         94 $child->parent = $new # Reparent child to new parent
329             }
330              
331             sub wrapChildren($;$$) # Wrap the children of the specified parent with a new intermediate parent that becomes the child of the specified parent, optionally setting the L[key] and the L[value] for the new parent. Return the new parent.
332 1     1 1 3 {my ($parent, $key, $value) = @_; # Child to wrap, optional key for new wrapping parent, optional value for new wrapping parent
333 1         5 my $new = new $key, $value; # Create new parent
334 1         85 $new->children = $parent->children; # Move children;
335 1         23 $parent->children = [$new]; # Grand parent
336 1         19 $new->parent = $parent; # Parent new parent
337 1         19 $_->parent = $new for $new->children->@*; # Reparent new children
338 1         53 $new # New parent
339             }
340              
341             sub merge($) # Unwrap the children of the specified parent with the whose L[key] fields L that of their parent. Returns the specified parent regardless.
342 1     1 1 3 {my ($parent) = @_; # Merging parent
343 1         18 for my $c($parent->children->@*) # Children of parent
344 4 100       74 {unwrap $c if $c->key ~~ $parent->key; # Unwrap child if like parent
345             }
346             $parent
347 1         22 }
348              
349             sub mergeLikePrev($) # Merge the preceding sibling of the specified child if that sibling exists and the L[key] data of the two siblings L. Returns the specified child regardless. From a proposal made by Micaela Monroe.
350 1     1 1 7 {my ($child) = @_; # Child
351 1 50       5 return $child unless my $prev = $child->prev; # No merge possible if child is first
352 1         5 $child->putFirst($prev->cut)->unwrap # Children to be merged
353             }
354              
355             sub mergeLikeNext($) # Merge the following sibling of the specified child if that sibling exists and the L[key] data of the two siblings L. Returns the specified child regardless. From a proposal made by Micaela Monroe.
356 1     1 1 8 {my ($child) = @_; # Child
357 1 50       5 return $child unless my $next = $child->next; # No merge possible if child is last
358 1         4 $child->putLast($next->cut)->unwrap # Children to be merged
359             }
360              
361             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.
362 1     1 1 4 {my ($parent) = @_; # Parent to make into a grand parent
363 1         19 wrap $_, $parent->key for $parent->children->@*; # Grandparent each child
364 1         20 $parent
365             }
366              
367             #D1 Traverse # Traverse a tree.
368              
369             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.
370 24     24 1 57 {my ($tree, $sub) = @_; # Tree, optional sub to process each child
371 24   100 239   185 $sub //= sub{@_}; # Default sub
  239         471  
372              
373 24         37 my @r; # Results
374             sub # Traverse
375 262     262   3123 {my ($child) = @_; # Child
376 262         4085 __SUB__->($_) for $child->children->@*; # Children of child
377 262         2714 push @r, &$sub($child); # Process child saving result
378 24         106 }->($tree); # Start at root of tree
379              
380             @r
381 24         779 }
382              
383             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.
384 7     7 1 20 {my ($tree, $select) = @_; # Tree, method to select a child
385 7         15 my $ref = ref $select; # Selector type
386             my $sel = # Selection method
387 10     10   39 $ref =~ m(array)i ? sub{grep{$_[0] eq $_} @$select} : # Array
  20         46  
388 10     10   44 $ref =~ m(hash)i ? sub{$$select{$_[0]}} : # Hash
389 17     17   117 $ref =~ m(exp)i ? sub{$_[0] =~ m($select)} : # Regular expression
390 17     17   298 $ref =~ m(code)i ? sub{&$select($_[0])} : # Sub
391 7 100   7   59 sub{$_[0] eq $select}; # Scalar
  7 100       41  
    100          
    100          
392 7         13 my @s; # Selection
393              
394             sub # Traverse
395 61     61   330 {my ($child) = @_; # Child
396 61 100       991 push @s, $child if &$sel($child->key); # Select child if it matches
397 61         975 __SUB__->($_) for $child->children->@*; # Each child
398 7         33 }->($tree); # Start at root
399              
400             @s
401 7         177 }
402              
403             #D1 Partitions # Various partitions of the tree
404              
405             sub leaves($) # The set of all children without further children, i.e. each leaf of the tree.
406 2     2 1 6 {my ($tree) = @_; # Tree
407 2         5 my @leaves; # Leaves
408             sub # Traverse
409 20     20   29 {my ($child) = @_; # Child
410 20 100       319 if (my @c = $child->children->@*) # Children of child
411 11         74 {__SUB__->($_) for @c; # Process children of child
412             }
413             else
414 9         55 {push @leaves, $child; # Save leaf
415             }
416 2         17 }->($tree); # Start at root of tree
417              
418             @leaves
419 2         17 }
420              
421             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.
422 7     7 1 15 {my ($tree, $preorder, $reverse) = @_; # Tree, pre-order if true else post-order, reversed if true
423 7         12 my @parents; # Parents
424             sub # Traverse
425 73     73   175 {my ($child) = @_; # Child
426 73 100       1159 if (my @c = $child->children->@*) # Children of child
427 36 100       199 {@c = reverse @c if $reverse; # Reverse if requested
428 36 100       63 push @parents, $child if $preorder; # Pre-order
429 36         106 __SUB__->($_) for @c; # Process children of child
430 36 100       169 push @parents, $child unless $preorder; # Post-order
431             }
432 7         40 }->($tree); # Start at root of tree
433              
434             @parents
435 7         76 }
436              
437             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.
438 1     1 1 3 {my ($tree) = @_; # Tree
439 1         4 parentsOrdered($tree, 1, 0);
440             }
441              
442             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.
443 4     4 1 9 {my ($tree) = @_; # Tree
444 4         9 parentsOrdered($tree, 0, 0);
445             }
446              
447             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.
448 1     1 1 4 {my ($tree) = @_; # Tree
449 1         4 parentsOrdered($tree, 1, 1);
450             }
451              
452             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.
453 1     1 1 4 {my ($tree) = @_; # Tree
454 1         4 &parentsOrdered($tree, 0, 1);
455             }
456              
457             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.
458 2     2 1 6 {my ($tree) = @_; # Tree
459 2         8 &parentsPostOrder(@_);
460             }
461              
462             #D1 Order # Check the order and relative position of children in a tree.
463              
464             sub above($$) # Return the first child if it is above the second child else return B.
465 4     4 1 8 {my ($first, $second) = @_; # First child, second child
466 4 50       13 return undef if $first == $second; # A child cannot be above itself
467 4         49 my @f = context $first; # Context of first child
468 4         9 my @s = context $second; # Context of second child
469 4   66     52 pop @f, pop @s while @f and @s and $f[-1] == $s[-1]; # Find first different ancestor
      100        
470 4 100       26 !@f ? $first : undef # First is above second if the ancestors of first are also ancestors of second
471             }
472              
473             sub below($$) # Return the first child if it is below the second child else return B.
474 2     2 1 5 {my ($first, $second) = @_; # First child, second child
475 2 100       6 above($second, $first) ? $first : undef
476             }
477              
478             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.
479 4     4 1 37 {my ($first, $second) = @_; # First child, second child
480 4         11 my @f = context $first; # Context of first child
481 4         9 my @s = context $second; # Context of second child
482 4   66     48 pop @f, pop @s while @f and @s and $f[-1] == $s[-1]; # Find first different ancestor
      100        
483 4 100 66     22 return undef unless @f and @s; # Not strictly after
484 2 50       8 indexOfChildInParent($f[-1]) > indexOfChildInParent($s[-1]) ? $first : undef # First child relative to second child at first common ancestor
485             }
486              
487             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.
488 2     2 1 6 {my ($first, $second) = @_; # First child, second child
489 2 100       5 after($second, $first) ? $first : undef
490             }
491              
492             #D1 Paths # Find paths between nodes
493              
494             sub path($) # Return the list of zero based child indexes for the path from the root of the tree containing the specified child to the specified child for use by the L[go] method.
495 1     1 1 4 {my ($child) = @_; # Child
496 1         2 my @p; # Path
497 1         19 for(my $p = $child; my $q = $p->parent; $p = $q) # Go up
498 3         18 {unshift @p, indexOfChildInParent $p # Record path
499             }
500             @p
501 1         10 }
502              
503             sub pathFrom($$) # Return the list of zero based child indexes for the path from the specified ancestor to the specified child for use by the L[go] method else confess if the ancestor is not, in fact, an ancestor.
504 9     9 1 20 {my ($child, $ancestor) = @_; # Child, ancestor
505 9 100       40 return () if $child == $ancestor; # Easy case
506 8         14 my @p; # Path
507 8         134 for(my $p = $child; my $q = $p->parent; $p = $q) # Go up
508 15         83 {unshift @p, indexOfChildInParent $p; # Record path
509 15 100       260 return @p if $q == $ancestor; # Stop at ancestor
510             }
511 0         0 confess "Not an ancestor"
512             }
513              
514             sub siblingsBefore($) # Return a list of siblings before the specified child.
515 1     1 1 4 {my ($child) = @_; # Child
516 1 50       19 return () unless my $parent = $child->parent; # Parent
517 1         26 my @c = $parent->children->@*; # Children
518 1         7 my $i = indexOfChildInParent $child; # Our position
519 1         24 @c[0..$i-1]
520             }
521              
522             sub siblingsAfter($) # Return a list of siblings after the specified child.
523 1     1 1 3 {my ($child) = @_; # Child
524 1 50       18 return () unless my $parent = $child->parent; # Parent
525 1         22 my @c = $parent->children->@*; # Children
526 1         7 my $i = indexOfChildInParent $child; # Our position
527 1         9 @c[$i+1..$#c]
528             }
529              
530             sub siblingsStrictlyBetween($$) # Return a list of the siblings strictly between two children of the same parent else return B.
531 2     2 1 7 {my ($start, $finish) = @_; # Start child, finish child
532 2 50       36 return () unless my $parent = $start->parent; # Parent
533 2 100       44 confess "Must be siblings" unless $parent == $finish->parent; # Check both children have the same parent
534 1         22 my @c = $parent->children->@*; # All siblings
535 1   66     14 shift @c while @c and $c[0] != $start; # Remove all siblings up to the start child
536 1   66     7 pop @c while @c and $c[-1] != $finish; # Remove all siblings after the finish child
537 1 50       3 shift @c; pop @c if @c; # Remove first and last child to make range strictly between
  1         4  
538             @c # Siblings strictly between start and finish
539 1         5 }
540              
541             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.
542 2     2 1 6 {my ($child, $ancestor) = @_; # Child, ancestor
543 2         5 my @p; # Path
544 2         8 for(my $p = $child; $p; $p = $p->parent) # Go up
545 8         31 {push @p, $p; # Record path
546 8 100       136 last if $p == $ancestor # Stop if we encounter the specified ancestor
547             }
548 2 100 66     32 return @p if !@p or $p[-1] == $ancestor; # Found the ancestor
549             undef # No such ancestor
550 1         5 }
551              
552             sub nextPreOrderPath($) # Return a list of children visited between the specified child and the next child in pre-order.
553 22     22 1 42 {my ($start) = @_; # The child at the start of the path
554 22 100       366 return ($start->first) if $start->children->@*; # First child if possible
555 13         58 my $p = $start; # Traverse upwards and then right
556 13         17 my @p; # Path
557 13         32 push @p, $p = $p->parent while $p->isLast; # Traverse upwards
558 13 100       85 $p->next ? (@p, $p->next) : () # Traverse right else we are at the root
559             }
560              
561             sub nextPostOrderPath($) # Return a list of children visited between the specified child and the next child in post-order.
562 22     22 1 43 {my ($start) = @_; # The child at the start of the path
563 22         31 my $p = $start; # Traverse upwards and then right, then first most
564 22         26 my @p; # Path
565 22 100       359 if (!$p->parent) # Starting at the root which is last in a post order traversal
566 2         16 {push @p, $p while $p = $p->first;
567             return @p
568 2         45 }
569 20 100       98 return (@p, $p->parent) if $p->isLast; # Traverse upwards
570 11 50       74 if (my $q = $p->next) # Traverse right
571 11         25 {for( ; $q; $q = $q->first) {push @p, $q} # Traverse first most
  13         34  
572             return @p
573 11         218 }
574 0         0 ($p) # Back at the root
575             }
576              
577             sub prevPostOrderPath($) # Return a list of children visited between the specified child and the previous child in post-order.
578 22     22 1 41 {my ($start) = @_; # The child at the start of the path
579 22 100       355 return ($start->last) if $start->children->@*; # Last child if possible
580 13         75 my $p = $start; # Traverse upwards and then left
581 13         19 my @p; # Path
582 13         28 push @p, $p = $p->parent while $p->isFirst; # Traverse upwards
583 13 100       89 $p->prev ? (@p, $p->prev) : () # Traverse left else we are at the root
584             }
585              
586             sub prevPreOrderPath($) # Return a list of children visited between the specified child and the previous child in pre-order.
587 22     22 1 36 {my ($start) = @_; # The child at the start of the path
588 22         32 my $p = $start; # Traverse upwards and then left, then last most
589 22         30 my @p; # Path
590 22 100       358 if (!$p->parent) # Starting at the root which is last in a post order traversal
591 2         18 {push @p, $p while $p = $p->last;
592             return @p
593 2         43 }
594 20 100       102 return (@p, $p->parent) if $p->isFirst; # Traverse upwards
595 11 50       79 if (my $q = $p->prev) # Traverse left
596 11         25 {for( ; $q; $q = $q->last) {push @p, $q} # Traverse last most
  18         64  
597             return @p
598 11         219 }
599 0         0 ($p) # Back at the root
600             }
601              
602             #D1 Print # Print a tree.
603              
604             sub printTree($$$$) #P String representation as a horizontal tree.
605 37     37 1 92 {my ($tree, $print, $preorder, $reverse) = @_; # Tree, optional print method, pre-order, reverse
606 37         60 my @s; # String representation
607              
608             sub # Print a child
609 355     355   572 {my ($child, $depth) = @_; # Child, depth
610 355         5713 my $key = $child->key; # Key
611 355         6238 my $value = $child->value; # Value
612 355 50       1806 my $k = join '', ' ' x $depth, $print ? &$print($key) : $key; # Print key
613 355 50       647 my $v = !defined($value) ? '' : ref($value) ? dump($value) : $value; # Print value
    100          
614 355 100       963 push @s, [$k, $v] if $preorder;
615 355 100       5752 my @c = $child->children->@*; @c = reverse @c if $reverse;
  355         1600  
616 355         1079 __SUB__->($_, $depth+1) for @c; # Print children of child
617 355 100       883 push @s, [$k, $v] unless $preorder;
618 37         257 }->($tree, 0); # Print root
619              
620 37         477 my $r = formatTableBasic [[qw(Key Value)], @s]; # Print tree
621 37 50       15115 owf($logFile, $r) if -e $logFile; # Log the result if requested
622 37         408 $r
623             }
624              
625             sub printPreOrder($;$) # Print tree in normal pre-order.
626 34     34 1 61 {my ($tree, $print) = @_; # Tree, optional print method
627 34         85 printTree($tree, $print, 1, 0);
628             }
629              
630             sub printPostOrder($;$) # Print tree in normal post-order.
631 1     1 1 5 {my ($tree, $print) = @_; # Tree, optional print method
632 1         4 printTree($tree, $print, 0, 0);
633             }
634              
635             sub printReversePreOrder($;$) # Print tree in reverse pre-order
636 1     1 1 4 {my ($tree, $print) = @_; # Tree, optional print method
637 1         4 printTree($tree, $print, 1, 1);
638             }
639              
640             sub printReversePostOrder($;$) # Print tree in reverse post-order
641 1     1 1 3 {my ($tree, $print) = @_; # Tree, optional print method
642 1         4 printTree($tree, $print, 0, 1);
643             }
644              
645             sub print($;$) # Print tree in normal pre-order.
646 33     33 1 75 {my ($tree, $print) = @_; # Tree, optional print method
647 33         89 &printPreOrder(@_);
648             }
649              
650             sub brackets($;$$) # Bracketed string representation of a tree.
651 7     7 1 16 {my ($tree, $print, $separator) = @_; # Tree, optional print method, optional child separator
652 7   50     31 my $t = $separator // ''; # Default child separator
653             sub # Print a child
654 62     62   97 {my ($child) = @_; # Child
655 62         983 my $key = $child->key; # Key
656 62 50       254 my $p = $print ? &$print($key) : $key; # Printed child
657 62         994 my $c = $child->children; # Children of child
658 62 100       363 return $p unless @$c; # Return child immediately if no children to format
659 31         62 join '', $p, '(', join($t, map {__SUB__->($_)} @$c), ')' # String representation
  55         141  
660 7         43 }->($tree) # Print root
661             }
662              
663             sub xml($;$) # Print a tree as as xml.
664 1     1 1 4 {my ($tree, $print) = @_; # Tree, optional print method
665             sub # Print a child
666 12     12   19 {my ($child) = @_; # Child
667 12         190 my $key = $child->key; # Key
668 12 50       54 my $p = $print ? &$print($key) : $key; # Printed child
669 12         182 my $c = $child->children; # Children of child
670 12 100       77 return "<$p/>" unless @$c; # Singleton
671 6         14 join '', "<$p>", (map {__SUB__->($_)} @$c), "" # String representation
  11         26  
672 1         9 }->($tree) # Print root
673             }
674              
675             #D1 Data Structures # Data structures use by this package.
676              
677             #D0
678             #-------------------------------------------------------------------------------
679             # Export
680             #-------------------------------------------------------------------------------
681              
682 1     1   6737 use Exporter qw(import);
  1         2  
  1         42  
683              
684 1     1   7 use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  1         4  
  1         807  
685              
686             @ISA = qw(Exporter);
687             @EXPORT_OK = qw(
688             );
689             %EXPORT_TAGS = (all=>[@EXPORT, @EXPORT_OK]);
690              
691             # podDocumentation
692              
693             =pod
694              
695             =encoding utf-8
696              
697             =head1 Name
698              
699             Tree::Ops - Tree operations.
700              
701             =head1 Synopsis
702              
703             Create a tree:
704              
705             my $a = Tree::Ops::new 'a', 'A';
706              
707             for(1..2)
708             {$a->open ('b', "B$_");
709             $a->single('c', "C$_");
710             $a->close;
711             }
712             $a->single ('d', 'D');
713             $a->single ('e', 'E');
714              
715             Print it:
716              
717             is_deeply $a->print, <
718             Key Value
719             a A
720             b B1
721             c C1
722             b B2
723             c C2
724             d D
725             e E
726             END
727              
728             Navigate through the tree:
729              
730             is_deeply $a->lastMost->prev->prev->first->key, 'c';
731             is_deeply $a->first->next->last->parent->first->value, 'C2';
732              
733             Traverse the tree:
734              
735             is_deeply [map{$_->value} $a->by], [qw(C1 B1 C2 B2 D E A)];
736              
737             Select items from the tree:
738              
739             is_deeply [map{$_->value} $a->select('b')], [qw(B1 B2)];
740             is_deeply [map{$_->value} $a->select(qr(b|c))], [qw(B1 C1 B2 C2)];
741             is_deeply [map{$_->value} $a->select(sub{$_[0] eq 'd'})], [qw(D)];
742              
743             Reorganize the tree:
744              
745             $a->first->next->stepEnd->stepEnd->first->next->stepBack;
746             is_deeply $a->print, <
747             Key Value
748             a A
749             b B1
750             c C1
751             b B2
752             d D
753             c C2
754             e E
755             END
756              
757             =head1 Description
758              
759             Tree operations.
760              
761              
762             Version 20201030.
763              
764              
765             The following sections describe the methods in each functional area of this
766             module. For an alphabetic listing of all methods by name see L.
767              
768              
769              
770             =head1 Build
771              
772             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.
773              
774             =head2 new($key, $value)
775              
776             Create a new child optionally recording the specified key or value.
777              
778             Parameter Description
779             1 $key Key
780             2 $value Value
781              
782             B
783              
784              
785            
786             my $a = Tree::Ops::new 'a', 'A'; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
787              
788             for(1..2)
789             {$a->open ('b', "B$_");
790             $a->single('c', "C$_");
791             ok $a->activeScope->key eq 'b';
792             $a->close;
793             }
794             $a->single ('d', 'D');
795             $a->single ('e', 'E');
796             is_deeply $a->print, <
797             Key Value
798             a A
799             b B1
800             c C1
801             b B2
802             c C2
803             d D
804             e E
805             END
806            
807             is_deeply [map{$_->value} $a->by], [qw(C1 B1 C2 B2 D E A)];
808            
809             is_deeply $a->lastMost->prev->prev->first->key, 'c';
810             is_deeply $a->first->next->last->parent->first->value, 'C2';
811            
812             is_deeply [map{$_->value} $a->select('b')], [qw(B1 B2)];
813             is_deeply [map{$_->value} $a->select(qr(b|c))], [qw(B1 C1 B2 C2)];
814             is_deeply [map{$_->value} $a->select(sub{$_[0] eq 'd'})], [qw(D)];
815            
816             $a->first->next->stepEnd->stepEnd->first->next->stepBack;
817             is_deeply $a->print, <
818             Key Value
819             a A
820             b B1
821             c C1
822             b B2
823             d D
824             c C2
825             e E
826             END
827            
828              
829             This is a static method and so should either be imported or invoked as:
830              
831             Tree::Ops::new
832              
833              
834             =head2 activeScope($tree)
835              
836             Locate the active scope in a tree.
837              
838             Parameter Description
839             1 $tree Tree
840              
841             B
842              
843              
844             my $a = Tree::Ops::new 'a', 'A';
845             for(1..2)
846             {$a->open ('b', "B$_");
847             $a->single('c', "C$_");
848            
849             ok $a->activeScope->key eq 'b'; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
850              
851             $a->close;
852             }
853             $a->single ('d', 'D');
854             $a->single ('e', 'E');
855             is_deeply $a->print, <
856             Key Value
857             a A
858             b B1
859             c C1
860             b B2
861             c C2
862             d D
863             e E
864             END
865            
866             is_deeply [map{$_->value} $a->by], [qw(C1 B1 C2 B2 D E A)];
867            
868             is_deeply $a->lastMost->prev->prev->first->key, 'c';
869             is_deeply $a->first->next->last->parent->first->value, 'C2';
870            
871             is_deeply [map{$_->value} $a->select('b')], [qw(B1 B2)];
872             is_deeply [map{$_->value} $a->select(qr(b|c))], [qw(B1 C1 B2 C2)];
873             is_deeply [map{$_->value} $a->select(sub{$_[0] eq 'd'})], [qw(D)];
874            
875             $a->first->next->stepEnd->stepEnd->first->next->stepBack;
876             is_deeply $a->print, <
877             Key Value
878             a A
879             b B1
880             c C1
881             b B2
882             d D
883             c C2
884             e E
885             END
886            
887              
888             =head2 open($tree, $key, $value)
889              
890             Add a child and make it the currently active scope into which new children will be added.
891              
892             Parameter Description
893             1 $tree Tree
894             2 $key Key
895             3 $value Value to be recorded in the interior child being opened
896              
897             B
898              
899              
900             my $a = Tree::Ops::new 'a', 'A';
901             for(1..2)
902            
903             {$a->open ('b', "B$_"); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
904              
905             $a->single('c', "C$_");
906             ok $a->activeScope->key eq 'b';
907             $a->close;
908             }
909             $a->single ('d', 'D');
910             $a->single ('e', 'E');
911             is_deeply $a->print, <
912             Key Value
913             a A
914             b B1
915             c C1
916             b B2
917             c C2
918             d D
919             e E
920             END
921            
922             is_deeply [map{$_->value} $a->by], [qw(C1 B1 C2 B2 D E A)];
923            
924             is_deeply $a->lastMost->prev->prev->first->key, 'c';
925             is_deeply $a->first->next->last->parent->first->value, 'C2';
926            
927             is_deeply [map{$_->value} $a->select('b')], [qw(B1 B2)];
928             is_deeply [map{$_->value} $a->select(qr(b|c))], [qw(B1 C1 B2 C2)];
929             is_deeply [map{$_->value} $a->select(sub{$_[0] eq 'd'})], [qw(D)];
930            
931             $a->first->next->stepEnd->stepEnd->first->next->stepBack;
932             is_deeply $a->print, <
933             Key Value
934             a A
935             b B1
936             c C1
937             b B2
938             d D
939             c C2
940             e E
941             END
942            
943              
944             =head2 close($tree)
945              
946             Close the current scope returning to the previous scope.
947              
948             Parameter Description
949             1 $tree Tree
950              
951             B
952              
953              
954             my $a = Tree::Ops::new 'a', 'A';
955             for(1..2)
956             {$a->open ('b', "B$_");
957             $a->single('c', "C$_");
958             ok $a->activeScope->key eq 'b';
959            
960             $a->close; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
961              
962             }
963             $a->single ('d', 'D');
964             $a->single ('e', 'E');
965             is_deeply $a->print, <
966             Key Value
967             a A
968             b B1
969             c C1
970             b B2
971             c C2
972             d D
973             e E
974             END
975            
976             is_deeply [map{$_->value} $a->by], [qw(C1 B1 C2 B2 D E A)];
977            
978             is_deeply $a->lastMost->prev->prev->first->key, 'c';
979             is_deeply $a->first->next->last->parent->first->value, 'C2';
980            
981             is_deeply [map{$_->value} $a->select('b')], [qw(B1 B2)];
982             is_deeply [map{$_->value} $a->select(qr(b|c))], [qw(B1 C1 B2 C2)];
983             is_deeply [map{$_->value} $a->select(sub{$_[0] eq 'd'})], [qw(D)];
984            
985             $a->first->next->stepEnd->stepEnd->first->next->stepBack;
986             is_deeply $a->print, <
987             Key Value
988             a A
989             b B1
990             c C1
991             b B2
992             d D
993             c C2
994             e E
995             END
996            
997              
998             =head2 single($tree, $key, $value)
999              
1000             Add one child in the current scope.
1001              
1002             Parameter Description
1003             1 $tree Tree
1004             2 $key Key
1005             3 $value Value to be recorded in the child being created
1006              
1007             B
1008              
1009              
1010             my $a = Tree::Ops::new 'a', 'A';
1011             for(1..2)
1012             {$a->open ('b', "B$_");
1013            
1014             $a->single('c', "C$_"); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1015              
1016             ok $a->activeScope->key eq 'b';
1017             $a->close;
1018             }
1019            
1020             $a->single ('d', 'D'); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1021              
1022            
1023             $a->single ('e', 'E'); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1024              
1025             is_deeply $a->print, <
1026             Key Value
1027             a A
1028             b B1
1029             c C1
1030             b B2
1031             c C2
1032             d D
1033             e E
1034             END
1035            
1036             is_deeply [map{$_->value} $a->by], [qw(C1 B1 C2 B2 D E A)];
1037            
1038             is_deeply $a->lastMost->prev->prev->first->key, 'c';
1039             is_deeply $a->first->next->last->parent->first->value, 'C2';
1040            
1041             is_deeply [map{$_->value} $a->select('b')], [qw(B1 B2)];
1042             is_deeply [map{$_->value} $a->select(qr(b|c))], [qw(B1 C1 B2 C2)];
1043             is_deeply [map{$_->value} $a->select(sub{$_[0] eq 'd'})], [qw(D)];
1044            
1045             $a->first->next->stepEnd->stepEnd->first->next->stepBack;
1046             is_deeply $a->print, <
1047             Key Value
1048             a A
1049             b B1
1050             c C1
1051             b B2
1052             d D
1053             c C2
1054             e E
1055             END
1056            
1057              
1058             =head2 include($tree, $include)
1059              
1060             Include the specified tree in the currently open scope.
1061              
1062             Parameter Description
1063             1 $tree Tree being built
1064             2 $include Tree to include
1065              
1066             B
1067              
1068              
1069             my ($i) = fromLetters 'b(cd)';
1070            
1071             my $a = Tree::Ops::new 'A';
1072             $a->open ('B');
1073            
1074             $a->include($i); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1075              
1076             $a->close;
1077            
1078             is_deeply $a->print, <
1079             Key Value
1080             A
1081             B
1082             a
1083             b
1084             c
1085             d
1086             END
1087            
1088              
1089             =head2 fromLetters($letters)
1090              
1091             Create a tree from a string of letters returning the children created in alphabetic order - useful for testing.
1092              
1093             Parameter Description
1094             1 $letters String of letters and ( ).
1095              
1096             B
1097              
1098              
1099            
1100             my ($a) = fromLetters(q(bc(d)e)); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1101              
1102            
1103             is_deeply $a->print, <
1104             Key Value
1105             a
1106             b
1107             c
1108             d
1109             e
1110             END
1111            
1112              
1113             =head1 Navigation
1114              
1115             Navigate through a tree.
1116              
1117             =head2 first($parent)
1118              
1119             Get the first child under the specified parent.
1120              
1121             Parameter Description
1122             1 $parent Parent
1123              
1124             B
1125              
1126              
1127             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = fromLetters 'b(c)d(efgh(i(j)))';
1128             is_deeply $c->parent, $b;
1129            
1130             is_deeply $a->first, $b; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1131              
1132             is_deeply $a->last, $d;
1133             is_deeply $e->next, $f;
1134             is_deeply $f->prev, $e;
1135            
1136              
1137             =head2 last($parent)
1138              
1139             Get the last child under the specified parent.
1140              
1141             Parameter Description
1142             1 $parent Parent
1143              
1144             B
1145              
1146              
1147             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = fromLetters 'b(c)d(efgh(i(j)))';
1148             is_deeply $c->parent, $b;
1149             is_deeply $a->first, $b;
1150            
1151             is_deeply $a->last, $d; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1152              
1153             is_deeply $e->next, $f;
1154             is_deeply $f->prev, $e;
1155            
1156              
1157             =head2 next($child)
1158              
1159             Get the next sibling following the specified child.
1160              
1161             Parameter Description
1162             1 $child Child
1163              
1164             B
1165              
1166              
1167             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = fromLetters 'b(c)d(efgh(i(j)))';
1168             is_deeply $c->parent, $b;
1169             is_deeply $a->first, $b;
1170             is_deeply $a->last, $d;
1171            
1172             is_deeply $e->next, $f; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1173              
1174             is_deeply $f->prev, $e;
1175            
1176              
1177             =head2 prev($child)
1178              
1179             Get the previous sibling of the specified child.
1180              
1181             Parameter Description
1182             1 $child Child
1183              
1184             B
1185              
1186              
1187             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = fromLetters 'b(c)d(efgh(i(j)))';
1188             is_deeply $c->parent, $b;
1189             is_deeply $a->first, $b;
1190             is_deeply $a->last, $d;
1191             is_deeply $e->next, $f;
1192            
1193             is_deeply $f->prev, $e; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1194              
1195            
1196              
1197             =head2 firstMost($parent)
1198              
1199             Return the first most descendant child in the tree starting at this parent or else return B if this parent has no children.
1200              
1201             Parameter Description
1202             1 $parent Parent
1203              
1204             B
1205              
1206              
1207             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $x, $y) =
1208             fromLetters 'b(c)y(x)d(efgh(i(j)))';
1209            
1210             is_deeply $a->print, <
1211             Key Value
1212             a
1213             b
1214             c
1215             y
1216             x
1217             d
1218             e
1219             f
1220             g
1221             h
1222             i
1223             j
1224             END
1225            
1226             is_deeply $a->xml,
1227             '';
1228            
1229             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves];
1230             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder];
1231             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder];
1232             is_deeply [$a->parents], [$a->parentsPostOrder];
1233            
1234             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder];
1235             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder];
1236            
1237             ok !$j->parents;
1238            
1239             ok $a->lastMost == $j;
1240             ok !$a->prevMost;
1241             ok $j->prevMost == $g;
1242             ok $i->prevMost == $g;
1243             ok $h->prevMost == $g;
1244             ok $g->prevMost == $f;
1245             ok $f->prevMost == $e;
1246             ok $e->prevMost == $x;
1247             ok $d->prevMost == $x;
1248             ok $x->prevMost == $c;
1249             ok $y->prevMost == $c;
1250             ok !$c->prevMost;
1251             ok !$b->prevMost;
1252             ok !$a->prevMost;
1253            
1254            
1255             ok $a->firstMost == $c; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1256              
1257             ok $a->nextMost == $c;
1258             ok $b->nextMost == $c;
1259             ok $c->nextMost == $x;
1260             ok $y->nextMost == $x;
1261             ok $x->nextMost == $e;
1262             ok $d->nextMost == $e;
1263             ok $e->nextMost == $f;
1264             ok $f->nextMost == $g;
1265             ok $g->nextMost == $j;
1266             ok $h->nextMost == $j;
1267             ok $i->nextMost == $j;
1268             ok !$j->nextMost;
1269            
1270             ok $i->topMost == $a;
1271            
1272              
1273             =head2 nextMost($child)
1274              
1275             Return the next child with no children, i.e. the next leaf of the tree, else return B if there is no such child.
1276              
1277             Parameter Description
1278             1 $child Current leaf
1279              
1280             B
1281              
1282              
1283             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $x, $y) =
1284             fromLetters 'b(c)y(x)d(efgh(i(j)))';
1285            
1286             is_deeply $a->print, <
1287             Key Value
1288             a
1289             b
1290             c
1291             y
1292             x
1293             d
1294             e
1295             f
1296             g
1297             h
1298             i
1299             j
1300             END
1301            
1302             is_deeply $a->xml,
1303             '';
1304            
1305             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves];
1306             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder];
1307             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder];
1308             is_deeply [$a->parents], [$a->parentsPostOrder];
1309            
1310             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder];
1311             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder];
1312            
1313             ok !$j->parents;
1314            
1315             ok $a->lastMost == $j;
1316             ok !$a->prevMost;
1317             ok $j->prevMost == $g;
1318             ok $i->prevMost == $g;
1319             ok $h->prevMost == $g;
1320             ok $g->prevMost == $f;
1321             ok $f->prevMost == $e;
1322             ok $e->prevMost == $x;
1323             ok $d->prevMost == $x;
1324             ok $x->prevMost == $c;
1325             ok $y->prevMost == $c;
1326             ok !$c->prevMost;
1327             ok !$b->prevMost;
1328             ok !$a->prevMost;
1329            
1330             ok $a->firstMost == $c;
1331            
1332             ok $a->nextMost == $c; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1333              
1334            
1335             ok $b->nextMost == $c; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1336              
1337            
1338             ok $c->nextMost == $x; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1339              
1340            
1341             ok $y->nextMost == $x; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1342              
1343            
1344             ok $x->nextMost == $e; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1345              
1346            
1347             ok $d->nextMost == $e; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1348              
1349            
1350             ok $e->nextMost == $f; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1351              
1352            
1353             ok $f->nextMost == $g; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1354              
1355            
1356             ok $g->nextMost == $j; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1357              
1358            
1359             ok $h->nextMost == $j; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1360              
1361            
1362             ok $i->nextMost == $j; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1363              
1364            
1365             ok !$j->nextMost; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1366              
1367            
1368             ok $i->topMost == $a;
1369            
1370              
1371             =head2 prevMost($child)
1372              
1373             Return the previous child with no children, i.e. the previous leaf of the tree, else return B if there is no such child.
1374              
1375             Parameter Description
1376             1 $child Current leaf
1377              
1378             B
1379              
1380              
1381             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $x, $y) =
1382             fromLetters 'b(c)y(x)d(efgh(i(j)))';
1383            
1384             is_deeply $a->print, <
1385             Key Value
1386             a
1387             b
1388             c
1389             y
1390             x
1391             d
1392             e
1393             f
1394             g
1395             h
1396             i
1397             j
1398             END
1399            
1400             is_deeply $a->xml,
1401             '';
1402            
1403             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves];
1404             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder];
1405             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder];
1406             is_deeply [$a->parents], [$a->parentsPostOrder];
1407            
1408             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder];
1409             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder];
1410            
1411             ok !$j->parents;
1412            
1413             ok $a->lastMost == $j;
1414            
1415             ok !$a->prevMost; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1416              
1417            
1418             ok $j->prevMost == $g; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1419              
1420            
1421             ok $i->prevMost == $g; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1422              
1423            
1424             ok $h->prevMost == $g; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1425              
1426            
1427             ok $g->prevMost == $f; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1428              
1429            
1430             ok $f->prevMost == $e; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1431              
1432            
1433             ok $e->prevMost == $x; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1434              
1435            
1436             ok $d->prevMost == $x; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1437              
1438            
1439             ok $x->prevMost == $c; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1440              
1441            
1442             ok $y->prevMost == $c; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1443              
1444            
1445             ok !$c->prevMost; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1446              
1447            
1448             ok !$b->prevMost; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1449              
1450            
1451             ok !$a->prevMost; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1452              
1453            
1454             ok $a->firstMost == $c;
1455             ok $a->nextMost == $c;
1456             ok $b->nextMost == $c;
1457             ok $c->nextMost == $x;
1458             ok $y->nextMost == $x;
1459             ok $x->nextMost == $e;
1460             ok $d->nextMost == $e;
1461             ok $e->nextMost == $f;
1462             ok $f->nextMost == $g;
1463             ok $g->nextMost == $j;
1464             ok $h->nextMost == $j;
1465             ok $i->nextMost == $j;
1466             ok !$j->nextMost;
1467            
1468             ok $i->topMost == $a;
1469            
1470              
1471             =head2 lastMost($parent)
1472              
1473             Return the last most descendant child in the tree starting at this parent or else return B if this parent has no children.
1474              
1475             Parameter Description
1476             1 $parent Parent
1477              
1478             B
1479              
1480              
1481             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $x, $y) =
1482             fromLetters 'b(c)y(x)d(efgh(i(j)))';
1483            
1484             is_deeply $a->print, <
1485             Key Value
1486             a
1487             b
1488             c
1489             y
1490             x
1491             d
1492             e
1493             f
1494             g
1495             h
1496             i
1497             j
1498             END
1499            
1500             is_deeply $a->xml,
1501             '';
1502            
1503             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves];
1504             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder];
1505             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder];
1506             is_deeply [$a->parents], [$a->parentsPostOrder];
1507            
1508             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder];
1509             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder];
1510            
1511             ok !$j->parents;
1512            
1513            
1514             ok $a->lastMost == $j; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1515              
1516             ok !$a->prevMost;
1517             ok $j->prevMost == $g;
1518             ok $i->prevMost == $g;
1519             ok $h->prevMost == $g;
1520             ok $g->prevMost == $f;
1521             ok $f->prevMost == $e;
1522             ok $e->prevMost == $x;
1523             ok $d->prevMost == $x;
1524             ok $x->prevMost == $c;
1525             ok $y->prevMost == $c;
1526             ok !$c->prevMost;
1527             ok !$b->prevMost;
1528             ok !$a->prevMost;
1529            
1530             ok $a->firstMost == $c;
1531             ok $a->nextMost == $c;
1532             ok $b->nextMost == $c;
1533             ok $c->nextMost == $x;
1534             ok $y->nextMost == $x;
1535             ok $x->nextMost == $e;
1536             ok $d->nextMost == $e;
1537             ok $e->nextMost == $f;
1538             ok $f->nextMost == $g;
1539             ok $g->nextMost == $j;
1540             ok $h->nextMost == $j;
1541             ok $i->nextMost == $j;
1542             ok !$j->nextMost;
1543            
1544             ok $i->topMost == $a;
1545            
1546              
1547             =head2 topMost($child)
1548              
1549             Return the top most parent in the tree containing the specified child.
1550              
1551             Parameter Description
1552             1 $child Child
1553              
1554             B
1555              
1556              
1557             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $x, $y) =
1558             fromLetters 'b(c)y(x)d(efgh(i(j)))';
1559            
1560             is_deeply $a->print, <
1561             Key Value
1562             a
1563             b
1564             c
1565             y
1566             x
1567             d
1568             e
1569             f
1570             g
1571             h
1572             i
1573             j
1574             END
1575            
1576             is_deeply $a->xml,
1577             '';
1578            
1579             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves];
1580             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder];
1581             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder];
1582             is_deeply [$a->parents], [$a->parentsPostOrder];
1583            
1584             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder];
1585             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder];
1586            
1587             ok !$j->parents;
1588            
1589             ok $a->lastMost == $j;
1590             ok !$a->prevMost;
1591             ok $j->prevMost == $g;
1592             ok $i->prevMost == $g;
1593             ok $h->prevMost == $g;
1594             ok $g->prevMost == $f;
1595             ok $f->prevMost == $e;
1596             ok $e->prevMost == $x;
1597             ok $d->prevMost == $x;
1598             ok $x->prevMost == $c;
1599             ok $y->prevMost == $c;
1600             ok !$c->prevMost;
1601             ok !$b->prevMost;
1602             ok !$a->prevMost;
1603            
1604             ok $a->firstMost == $c;
1605             ok $a->nextMost == $c;
1606             ok $b->nextMost == $c;
1607             ok $c->nextMost == $x;
1608             ok $y->nextMost == $x;
1609             ok $x->nextMost == $e;
1610             ok $d->nextMost == $e;
1611             ok $e->nextMost == $f;
1612             ok $f->nextMost == $g;
1613             ok $g->nextMost == $j;
1614             ok $h->nextMost == $j;
1615             ok $i->nextMost == $j;
1616             ok !$j->nextMost;
1617            
1618            
1619             ok $i->topMost == $a; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1620              
1621            
1622              
1623             =head2 mostRecentCommonAncestor($first, $second)
1624              
1625             Find the most recent common ancestor of the specified children.
1626              
1627             Parameter Description
1628             1 $first First child
1629             2 $second Second child
1630              
1631             B
1632              
1633              
1634             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $k) =
1635             fromLetters 'b(c(d(e))f(g(h)i)j)k';
1636            
1637             is_deeply $a->print, <
1638             Key Value
1639             a
1640             b
1641             c
1642             d
1643             e
1644             f
1645             g
1646             h
1647             i
1648             j
1649             k
1650             END
1651            
1652            
1653             ok $e->mostRecentCommonAncestor($h) == $b; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1654              
1655            
1656             ok $e->mostRecentCommonAncestor($k) == $a; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1657              
1658            
1659              
1660             =head2 go($parent, @path)
1661              
1662             Return the child at the end of the path starting at the specified parent. A path is a list of zero based children numbers. Return B if the path is not valid.
1663              
1664             Parameter Description
1665             1 $parent Parent
1666             2 @path List of zero based children numbers
1667              
1668             B
1669              
1670              
1671             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = fromLetters 'b(cd(e(fg)h)i)j';
1672            
1673             is_deeply $a->print, <
1674             Key Value
1675             a
1676             b
1677             c
1678             d
1679             e
1680             f
1681             g
1682             h
1683             i
1684             j
1685             END
1686            
1687            
1688             ok $a->go(0,1,0,1) == $g; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1689              
1690            
1691             ok $d->go(0,0) == $f; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1692              
1693            
1694             is_deeply [$e->path], [0,1,0];
1695             is_deeply [$g->pathFrom($d)], [0,1];
1696            
1697             is_deeply $b->dup->print, <
1698             Key Value
1699             b
1700             c
1701             d
1702             e
1703             f
1704             g
1705             h
1706             i
1707             END
1708            
1709             my $B = $b->transcribe;
1710            
1711             $b->by(sub
1712             {my ($c) = @_;
1713             my @path = $c->pathFrom($b);
1714            
1715             my $C = $B->go(@path); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1716              
1717             is_deeply $c->key, $C->key;
1718             is_deeply $c->{transcribedTo}, $C;
1719             is_deeply $C->{transcribedFrom}, $c;
1720             });
1721            
1722             is_deeply $B->print, <
1723             Key Value
1724             b
1725             c
1726             d
1727             e
1728             f
1729             g
1730             h
1731             i
1732             END
1733            
1734              
1735             =head1 Location
1736              
1737             Verify the current location.
1738              
1739             =head2 context($child)
1740              
1741             Get the context of the current child.
1742              
1743             Parameter Description
1744             1 $child Child
1745              
1746             B
1747              
1748              
1749             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $s, $t, $x, $y, $z) =
1750             fromLetters 'b(c)y(x)z(st)d(efgh(i(j))))';
1751            
1752            
1753             is_deeply [$x->context], [$x, $y, $a]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1754              
1755            
1756             is_deeply join(' ', $a->by(sub{$_[0]->key})), "c b x y s t z e f g j i h d a";
1757             is_deeply join(' ', map{$_->key} $a->by), "c b x y s t z e f g j i h d a";
1758            
1759             is_deeply $a->print, <
1760             Key Value
1761             a
1762             b
1763             c
1764             y
1765             x
1766             z
1767             s
1768             t
1769             d
1770             e
1771             f
1772             g
1773             h
1774             i
1775             j
1776             END
1777            
1778             $z->cut;
1779             is_deeply $a->print, <
1780             Key Value
1781             a
1782             b
1783             c
1784             y
1785             x
1786             d
1787             e
1788             f
1789             g
1790             h
1791             i
1792             j
1793             END
1794            
1795              
1796             =head2 isFirst($child)
1797              
1798             Return the specified child if that child is first under its parent, else return B.
1799              
1800             Parameter Description
1801             1 $child Child
1802              
1803             B
1804              
1805              
1806             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = fromLetters 'b(c)d(efgh(i(j)))';
1807            
1808             is_deeply $a->print, <
1809             Key Value
1810             a
1811             b
1812             c
1813             d
1814             e
1815             f
1816             g
1817             h
1818             i
1819             j
1820             END
1821            
1822             is_deeply $b->singleChildOfParent, $c;
1823            
1824             is_deeply $e->isFirst, $e; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1825              
1826            
1827             ok !$f->isFirst; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1828              
1829             ok !$g->isLast;
1830             is_deeply $h->isLast, $h;
1831             ok $j->empty;
1832             ok !$i->empty;
1833             ok $a->isTop;
1834             ok !$b->isTop;
1835            
1836              
1837             =head2 isLast($child)
1838              
1839             Return the specified child if that child is last under its parent, else return B.
1840              
1841             Parameter Description
1842             1 $child Child
1843              
1844             B
1845              
1846              
1847             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = fromLetters 'b(c)d(efgh(i(j)))';
1848            
1849             is_deeply $a->print, <
1850             Key Value
1851             a
1852             b
1853             c
1854             d
1855             e
1856             f
1857             g
1858             h
1859             i
1860             j
1861             END
1862            
1863             is_deeply $b->singleChildOfParent, $c;
1864             is_deeply $e->isFirst, $e;
1865             ok !$f->isFirst;
1866            
1867             ok !$g->isLast; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1868              
1869            
1870             is_deeply $h->isLast, $h; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1871              
1872             ok $j->empty;
1873             ok !$i->empty;
1874             ok $a->isTop;
1875             ok !$b->isTop;
1876            
1877              
1878             =head2 isTop($parent)
1879              
1880             Return the specified parent if that parent is the top most parent in the tree.
1881              
1882             Parameter Description
1883             1 $parent Parent
1884              
1885             B
1886              
1887              
1888             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = fromLetters 'b(c)d(efgh(i(j)))';
1889            
1890             is_deeply $a->print, <
1891             Key Value
1892             a
1893             b
1894             c
1895             d
1896             e
1897             f
1898             g
1899             h
1900             i
1901             j
1902             END
1903            
1904             is_deeply $b->singleChildOfParent, $c;
1905             is_deeply $e->isFirst, $e;
1906             ok !$f->isFirst;
1907             ok !$g->isLast;
1908             is_deeply $h->isLast, $h;
1909             ok $j->empty;
1910             ok !$i->empty;
1911            
1912             ok $a->isTop; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1913              
1914            
1915             ok !$b->isTop; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1916              
1917            
1918              
1919             =head2 singleChildOfParent($parent)
1920              
1921             Return the only child of this parent if the parent has an only child, else B
1922              
1923             Parameter Description
1924             1 $parent Parent
1925              
1926             B
1927              
1928              
1929             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = fromLetters 'b(c)d(efgh(i(j)))';
1930            
1931             is_deeply $a->print, <
1932             Key Value
1933             a
1934             b
1935             c
1936             d
1937             e
1938             f
1939             g
1940             h
1941             i
1942             j
1943             END
1944            
1945            
1946             is_deeply $b->singleChildOfParent, $c; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1947              
1948             is_deeply $e->isFirst, $e;
1949             ok !$f->isFirst;
1950             ok !$g->isLast;
1951             is_deeply $h->isLast, $h;
1952             ok $j->empty;
1953             ok !$i->empty;
1954             ok $a->isTop;
1955             ok !$b->isTop;
1956            
1957              
1958             =head2 empty($parent)
1959              
1960             Return the specified parent if it has no children else B
1961              
1962             Parameter Description
1963             1 $parent Parent
1964              
1965             B
1966              
1967              
1968             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = fromLetters 'b(c)d(efgh(i(j)))';
1969            
1970             is_deeply $a->print, <
1971             Key Value
1972             a
1973             b
1974             c
1975             d
1976             e
1977             f
1978             g
1979             h
1980             i
1981             j
1982             END
1983            
1984             is_deeply $b->singleChildOfParent, $c;
1985             is_deeply $e->isFirst, $e;
1986             ok !$f->isFirst;
1987             ok !$g->isLast;
1988             is_deeply $h->isLast, $h;
1989            
1990             ok $j->empty; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1991              
1992            
1993             ok !$i->empty; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
1994              
1995             ok $a->isTop;
1996             ok !$b->isTop;
1997            
1998              
1999             =head1 Put
2000              
2001             Insert children into a tree.
2002              
2003             =head2 putFirst($parent, $child)
2004              
2005             Place a new child first under the specified parent and return the child.
2006              
2007             Parameter Description
2008             1 $parent Parent
2009             2 $child Child
2010              
2011             B
2012              
2013              
2014             my ($a, $b, $c, $d, $e) = fromLetters 'b(c)d(e)';
2015            
2016             is_deeply $a->print, <
2017             Key Value
2018             a
2019             b
2020             c
2021             d
2022             e
2023             END
2024            
2025             my $z = $b->putNext(new 'z');
2026             is_deeply $a->print, <
2027             Key Value
2028             a
2029             b
2030             c
2031             z
2032             d
2033             e
2034             END
2035            
2036             my $y = $d->putPrev(new 'y');
2037             is_deeply $a->print, <
2038             Key Value
2039             a
2040             b
2041             c
2042             z
2043             y
2044             d
2045             e
2046             END
2047            
2048             $z->putLast(new 't');
2049             is_deeply $a->print, <
2050             Key Value
2051             a
2052             b
2053             c
2054             z
2055             t
2056             y
2057             d
2058             e
2059             END
2060            
2061            
2062             $z->putFirst(new 's'); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2063              
2064             is_deeply $a->print, <
2065             Key Value
2066             a
2067             b
2068             c
2069             z
2070             s
2071             t
2072             y
2073             d
2074             e
2075             END
2076            
2077              
2078             =head2 putLast($parent, $child)
2079              
2080             Place a new child last under the specified parent and return the child.
2081              
2082             Parameter Description
2083             1 $parent Parent
2084             2 $child Child
2085              
2086             B
2087              
2088              
2089             my ($a, $b, $c, $d, $e) = fromLetters 'b(c)d(e)';
2090            
2091             is_deeply $a->print, <
2092             Key Value
2093             a
2094             b
2095             c
2096             d
2097             e
2098             END
2099            
2100             my $z = $b->putNext(new 'z');
2101             is_deeply $a->print, <
2102             Key Value
2103             a
2104             b
2105             c
2106             z
2107             d
2108             e
2109             END
2110            
2111             my $y = $d->putPrev(new 'y');
2112             is_deeply $a->print, <
2113             Key Value
2114             a
2115             b
2116             c
2117             z
2118             y
2119             d
2120             e
2121             END
2122            
2123            
2124             $z->putLast(new 't'); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2125              
2126             is_deeply $a->print, <
2127             Key Value
2128             a
2129             b
2130             c
2131             z
2132             t
2133             y
2134             d
2135             e
2136             END
2137            
2138             $z->putFirst(new 's');
2139             is_deeply $a->print, <
2140             Key Value
2141             a
2142             b
2143             c
2144             z
2145             s
2146             t
2147             y
2148             d
2149             e
2150             END
2151            
2152              
2153             =head2 putNext($child, $new)
2154              
2155             Place a new child after the specified child.
2156              
2157             Parameter Description
2158             1 $child Existing child
2159             2 $new New child
2160              
2161             B
2162              
2163              
2164             my ($a, $b, $c, $d, $e) = fromLetters 'b(c)d(e)';
2165            
2166             is_deeply $a->print, <
2167             Key Value
2168             a
2169             b
2170             c
2171             d
2172             e
2173             END
2174            
2175            
2176             my $z = $b->putNext(new 'z'); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2177              
2178             is_deeply $a->print, <
2179             Key Value
2180             a
2181             b
2182             c
2183             z
2184             d
2185             e
2186             END
2187            
2188             my $y = $d->putPrev(new 'y');
2189             is_deeply $a->print, <
2190             Key Value
2191             a
2192             b
2193             c
2194             z
2195             y
2196             d
2197             e
2198             END
2199            
2200             $z->putLast(new 't');
2201             is_deeply $a->print, <
2202             Key Value
2203             a
2204             b
2205             c
2206             z
2207             t
2208             y
2209             d
2210             e
2211             END
2212            
2213             $z->putFirst(new 's');
2214             is_deeply $a->print, <
2215             Key Value
2216             a
2217             b
2218             c
2219             z
2220             s
2221             t
2222             y
2223             d
2224             e
2225             END
2226            
2227              
2228             =head2 putPrev($child, $new)
2229              
2230             Place a new child before the specified child.
2231              
2232             Parameter Description
2233             1 $child Child
2234             2 $new New child
2235              
2236             B
2237              
2238              
2239             my ($a, $b, $c, $d, $e) = fromLetters 'b(c)d(e)';
2240            
2241             is_deeply $a->print, <
2242             Key Value
2243             a
2244             b
2245             c
2246             d
2247             e
2248             END
2249            
2250             my $z = $b->putNext(new 'z');
2251             is_deeply $a->print, <
2252             Key Value
2253             a
2254             b
2255             c
2256             z
2257             d
2258             e
2259             END
2260            
2261            
2262             my $y = $d->putPrev(new 'y'); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2263              
2264             is_deeply $a->print, <
2265             Key Value
2266             a
2267             b
2268             c
2269             z
2270             y
2271             d
2272             e
2273             END
2274            
2275             $z->putLast(new 't');
2276             is_deeply $a->print, <
2277             Key Value
2278             a
2279             b
2280             c
2281             z
2282             t
2283             y
2284             d
2285             e
2286             END
2287            
2288             $z->putFirst(new 's');
2289             is_deeply $a->print, <
2290             Key Value
2291             a
2292             b
2293             c
2294             z
2295             s
2296             t
2297             y
2298             d
2299             e
2300             END
2301            
2302              
2303             =head1 Steps
2304              
2305             Move the start or end of a scope forwards or backwards as suggested by Alex Monroe.
2306              
2307             =head2 step($parent)
2308              
2309             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.
2310              
2311             Parameter Description
2312             1 $parent Parent
2313              
2314             B
2315              
2316              
2317             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = fromLetters 'b(c)d(efgh(i(j)))';
2318            
2319             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
2320            
2321            
2322             $d->step; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2323              
2324             is_deeply $a->brackets, 'a(b(c)ed(fgh(i(j))))';
2325            
2326             $d->stepBack;
2327             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
2328            
2329             $b->stepEnd;
2330             is_deeply $a->brackets, 'a(b(cd(efgh(i(j)))))';
2331            
2332             $b->stepEndBack;
2333             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
2334            
2335              
2336             =head2 stepEnd($parent)
2337              
2338             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.
2339              
2340             Parameter Description
2341             1 $parent Parent
2342              
2343             B
2344              
2345              
2346             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = fromLetters 'b(c)d(efgh(i(j)))';
2347            
2348             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
2349            
2350             $d->step;
2351             is_deeply $a->brackets, 'a(b(c)ed(fgh(i(j))))';
2352            
2353             $d->stepBack;
2354             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
2355            
2356            
2357             $b->stepEnd; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2358              
2359             is_deeply $a->brackets, 'a(b(cd(efgh(i(j)))))';
2360            
2361             $b->stepEndBack;
2362             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
2363            
2364              
2365             =head2 stepBack()
2366              
2367             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.
2368              
2369              
2370             B
2371              
2372              
2373             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = fromLetters 'b(c)d(efgh(i(j)))';
2374            
2375             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
2376            
2377             $d->step;
2378             is_deeply $a->brackets, 'a(b(c)ed(fgh(i(j))))';
2379            
2380            
2381             $d->stepBack; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2382              
2383             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
2384            
2385             $b->stepEnd;
2386             is_deeply $a->brackets, 'a(b(cd(efgh(i(j)))))';
2387            
2388             $b->stepEndBack;
2389             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
2390            
2391              
2392             =head2 stepEndBack()
2393              
2394             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.
2395              
2396              
2397             B
2398              
2399              
2400             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = fromLetters 'b(c)d(efgh(i(j)))';
2401            
2402             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
2403            
2404             $d->step;
2405             is_deeply $a->brackets, 'a(b(c)ed(fgh(i(j))))';
2406            
2407             $d->stepBack;
2408             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
2409            
2410             $b->stepEnd;
2411             is_deeply $a->brackets, 'a(b(cd(efgh(i(j)))))';
2412            
2413            
2414             $b->stepEndBack; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2415              
2416             is_deeply $a->brackets, 'a(b(c)d(efgh(i(j))))';
2417            
2418              
2419             =head1 Edit
2420              
2421             Edit a tree in situ.
2422              
2423             =head2 cut($child)
2424              
2425             Cut out a child and all its content and children, return it ready for reinsertion else where.
2426              
2427             Parameter Description
2428             1 $child Child
2429              
2430             B
2431              
2432              
2433             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $s, $t, $x, $y, $z) =
2434             fromLetters 'b(c)y(x)z(st)d(efgh(i(j))))';
2435            
2436             is_deeply [$x->context], [$x, $y, $a];
2437            
2438             is_deeply join(' ', $a->by(sub{$_[0]->key})), "c b x y s t z e f g j i h d a";
2439             is_deeply join(' ', map{$_->key} $a->by), "c b x y s t z e f g j i h d a";
2440            
2441             is_deeply $a->print, <
2442             Key Value
2443             a
2444             b
2445             c
2446             y
2447             x
2448             z
2449             s
2450             t
2451             d
2452             e
2453             f
2454             g
2455             h
2456             i
2457             j
2458             END
2459            
2460            
2461             $z->cut; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2462              
2463             is_deeply $a->print, <
2464             Key Value
2465             a
2466             b
2467             c
2468             y
2469             x
2470             d
2471             e
2472             f
2473             g
2474             h
2475             i
2476             j
2477             END
2478            
2479              
2480             =head2 dup($parent)
2481              
2482             Duplicate a specified parent and all its descendants returning the root of the resulting tree.
2483              
2484             Parameter Description
2485             1 $parent Parent
2486              
2487             B
2488              
2489              
2490             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = fromLetters 'b(cd(e(fg)h)i)j';
2491            
2492             is_deeply $a->print, <
2493             Key Value
2494             a
2495             b
2496             c
2497             d
2498             e
2499             f
2500             g
2501             h
2502             i
2503             j
2504             END
2505            
2506             ok $a->go(0,1,0,1) == $g;
2507             ok $d->go(0,0) == $f;
2508            
2509             is_deeply [$e->path], [0,1,0];
2510             is_deeply [$g->pathFrom($d)], [0,1];
2511            
2512            
2513             is_deeply $b->dup->print, <
2514              
2515             Key Value
2516             b
2517             c
2518             d
2519             e
2520             f
2521             g
2522             h
2523             i
2524             END
2525            
2526             my $B = $b->transcribe;
2527            
2528             $b->by(sub
2529             {my ($c) = @_;
2530             my @path = $c->pathFrom($b);
2531             my $C = $B->go(@path);
2532             is_deeply $c->key, $C->key;
2533             is_deeply $c->{transcribedTo}, $C;
2534             is_deeply $C->{transcribedFrom}, $c;
2535             });
2536            
2537             is_deeply $B->print, <
2538             Key Value
2539             b
2540             c
2541             d
2542             e
2543             f
2544             g
2545             h
2546             i
2547             END
2548            
2549              
2550             =head2 transcribe($parent)
2551              
2552             Duplicate a specified parent and all its descendants recording the mapping in a temporary {transcribed} field in the tree being transcribed. Returns the root parent of the tree being duplicated.
2553              
2554             Parameter Description
2555             1 $parent Parent
2556              
2557             B
2558              
2559              
2560             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = fromLetters 'b(cd(e(fg)h)i)j';
2561            
2562             is_deeply $a->print, <
2563             Key Value
2564             a
2565             b
2566             c
2567             d
2568             e
2569             f
2570             g
2571             h
2572             i
2573             j
2574             END
2575            
2576             ok $a->go(0,1,0,1) == $g;
2577             ok $d->go(0,0) == $f;
2578            
2579             is_deeply [$e->path], [0,1,0];
2580             is_deeply [$g->pathFrom($d)], [0,1];
2581            
2582             is_deeply $b->dup->print, <
2583             Key Value
2584             b
2585             c
2586             d
2587             e
2588             f
2589             g
2590             h
2591             i
2592             END
2593            
2594            
2595             my $B = $b->transcribe; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2596              
2597            
2598             $b->by(sub
2599             {my ($c) = @_;
2600             my @path = $c->pathFrom($b);
2601             my $C = $B->go(@path);
2602             is_deeply $c->key, $C->key;
2603             is_deeply $c->{transcribedTo}, $C;
2604             is_deeply $C->{transcribedFrom}, $c;
2605             });
2606            
2607             is_deeply $B->print, <
2608             Key Value
2609             b
2610             c
2611             d
2612             e
2613             f
2614             g
2615             h
2616             i
2617             END
2618            
2619              
2620             =head2 unwrap($child)
2621              
2622             Unwrap the specified child and return that child.
2623              
2624             Parameter Description
2625             1 $child Child
2626              
2627             B
2628              
2629              
2630             my ($a, $b, $c, $d, $e, $f, $g) = fromLetters 'b(c(de)f)g';
2631            
2632             is_deeply $a->print, <
2633             Key Value
2634             a
2635             b
2636             c
2637             d
2638             e
2639             f
2640             g
2641             END
2642            
2643             $c->wrap('z');
2644            
2645             is_deeply $a->print, <
2646             Key Value
2647             a
2648             b
2649             z
2650             c
2651             d
2652             e
2653             f
2654             g
2655             END
2656            
2657            
2658             $c->parent->unwrap; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2659              
2660            
2661             is_deeply $a->print, <
2662             Key Value
2663             a
2664             b
2665             c
2666             d
2667             e
2668             f
2669             g
2670             END
2671            
2672             $c->wrapChildren("Z");
2673            
2674             is_deeply $a->print, <
2675             Key Value
2676             a
2677             b
2678             c
2679             Z
2680             d
2681             e
2682             f
2683             g
2684             END
2685            
2686              
2687             =head2 wrap($child, $key, $value)
2688              
2689             Wrap the specified child with a new parent and return the new parent optionally setting its L and L.
2690              
2691             Parameter Description
2692             1 $child Child to wrap
2693             2 $key Optional key
2694             3 $value Optional value
2695              
2696             B
2697              
2698              
2699             my ($a, $b, $c, $d, $e, $f, $g) = fromLetters 'b(c(de)f)g';
2700            
2701             is_deeply $a->print, <
2702             Key Value
2703             a
2704             b
2705             c
2706             d
2707             e
2708             f
2709             g
2710             END
2711            
2712            
2713             $c->wrap('z'); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2714              
2715            
2716             is_deeply $a->print, <
2717             Key Value
2718             a
2719             b
2720             z
2721             c
2722             d
2723             e
2724             f
2725             g
2726             END
2727            
2728             $c->parent->unwrap;
2729            
2730             is_deeply $a->print, <
2731             Key Value
2732             a
2733             b
2734             c
2735             d
2736             e
2737             f
2738             g
2739             END
2740            
2741             $c->wrapChildren("Z");
2742            
2743             is_deeply $a->print, <
2744             Key Value
2745             a
2746             b
2747             c
2748             Z
2749             d
2750             e
2751             f
2752             g
2753             END
2754            
2755              
2756             =head2 wrapChildren($parent, $key, $value)
2757              
2758             Wrap the children of the specified parent with a new intermediate parent that becomes the child of the specified parent, optionally setting the L and the L for the new parent. Return the new parent.
2759              
2760             Parameter Description
2761             1 $parent Child to wrap
2762             2 $key Optional key for new wrapping parent
2763             3 $value Optional value for new wrapping parent
2764              
2765             B
2766              
2767              
2768             my ($a, $b, $c, $d, $e, $f, $g) = fromLetters 'b(c(de)f)g';
2769            
2770             is_deeply $a->print, <
2771             Key Value
2772             a
2773             b
2774             c
2775             d
2776             e
2777             f
2778             g
2779             END
2780            
2781             $c->wrap('z');
2782            
2783             is_deeply $a->print, <
2784             Key Value
2785             a
2786             b
2787             z
2788             c
2789             d
2790             e
2791             f
2792             g
2793             END
2794            
2795             $c->parent->unwrap;
2796            
2797             is_deeply $a->print, <
2798             Key Value
2799             a
2800             b
2801             c
2802             d
2803             e
2804             f
2805             g
2806             END
2807            
2808            
2809             $c->wrapChildren("Z"); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2810              
2811            
2812             is_deeply $a->print, <
2813             Key Value
2814             a
2815             b
2816             c
2817             Z
2818             d
2819             e
2820             f
2821             g
2822             END
2823            
2824              
2825             =head2 merge($parent)
2826              
2827             Unwrap the children of the specified parent with the whose L fields L that of their parent. Returns the specified parent regardless.
2828              
2829             Parameter Description
2830             1 $parent Merging parent
2831              
2832             B
2833              
2834              
2835             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = fromLetters 'b(c)d(efgh(i(j)))';
2836            
2837             is_deeply $a->print, <
2838             Key Value
2839             a
2840             b
2841             c
2842             d
2843             e
2844             f
2845             g
2846             h
2847             i
2848             j
2849             END
2850            
2851             $d->split;
2852             is_deeply $a->print, <
2853             Key Value
2854             a
2855             b
2856             c
2857             d
2858             d
2859             e
2860             d
2861             f
2862             d
2863             g
2864             d
2865             h
2866             i
2867             j
2868             END
2869            
2870             $f->parent->mergeLikePrev;
2871             is_deeply $a->print, <
2872             Key Value
2873             a
2874             b
2875             c
2876             d
2877             d
2878             e
2879             f
2880             d
2881             g
2882             d
2883             h
2884             i
2885             j
2886             END
2887            
2888             $g->parent->mergeLikeNext;
2889             is_deeply $a->print, <
2890             Key Value
2891             a
2892             b
2893             c
2894             d
2895             d
2896             e
2897             f
2898             d
2899             g
2900             h
2901             i
2902             j
2903             END
2904            
2905            
2906             $d->merge; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2907              
2908             is_deeply $a->print, <
2909             Key Value
2910             a
2911             b
2912             c
2913             d
2914             e
2915             f
2916             g
2917             h
2918             i
2919             j
2920             END
2921            
2922              
2923             =head2 mergeLikePrev($child)
2924              
2925             Merge the preceding sibling of the specified child if that sibling exists and the L data of the two siblings L. Returns the specified child regardless. From a proposal made by Micaela Monroe.
2926              
2927             Parameter Description
2928             1 $child Child
2929              
2930             B
2931              
2932              
2933             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = fromLetters 'b(c)d(efgh(i(j)))';
2934            
2935             is_deeply $a->print, <
2936             Key Value
2937             a
2938             b
2939             c
2940             d
2941             e
2942             f
2943             g
2944             h
2945             i
2946             j
2947             END
2948            
2949             $d->split;
2950             is_deeply $a->print, <
2951             Key Value
2952             a
2953             b
2954             c
2955             d
2956             d
2957             e
2958             d
2959             f
2960             d
2961             g
2962             d
2963             h
2964             i
2965             j
2966             END
2967            
2968            
2969             $f->parent->mergeLikePrev; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
2970              
2971             is_deeply $a->print, <
2972             Key Value
2973             a
2974             b
2975             c
2976             d
2977             d
2978             e
2979             f
2980             d
2981             g
2982             d
2983             h
2984             i
2985             j
2986             END
2987            
2988             $g->parent->mergeLikeNext;
2989             is_deeply $a->print, <
2990             Key Value
2991             a
2992             b
2993             c
2994             d
2995             d
2996             e
2997             f
2998             d
2999             g
3000             h
3001             i
3002             j
3003             END
3004            
3005             $d->merge;
3006             is_deeply $a->print, <
3007             Key Value
3008             a
3009             b
3010             c
3011             d
3012             e
3013             f
3014             g
3015             h
3016             i
3017             j
3018             END
3019            
3020              
3021             =head2 mergeLikeNext($child)
3022              
3023             Merge the following sibling of the specified child if that sibling exists and the L data of the two siblings L. Returns the specified child regardless. From a proposal made by Micaela Monroe.
3024              
3025             Parameter Description
3026             1 $child Child
3027              
3028             B
3029              
3030              
3031             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = fromLetters 'b(c)d(efgh(i(j)))';
3032            
3033             is_deeply $a->print, <
3034             Key Value
3035             a
3036             b
3037             c
3038             d
3039             e
3040             f
3041             g
3042             h
3043             i
3044             j
3045             END
3046            
3047             $d->split;
3048             is_deeply $a->print, <
3049             Key Value
3050             a
3051             b
3052             c
3053             d
3054             d
3055             e
3056             d
3057             f
3058             d
3059             g
3060             d
3061             h
3062             i
3063             j
3064             END
3065            
3066             $f->parent->mergeLikePrev;
3067             is_deeply $a->print, <
3068             Key Value
3069             a
3070             b
3071             c
3072             d
3073             d
3074             e
3075             f
3076             d
3077             g
3078             d
3079             h
3080             i
3081             j
3082             END
3083            
3084            
3085             $g->parent->mergeLikeNext; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3086              
3087             is_deeply $a->print, <
3088             Key Value
3089             a
3090             b
3091             c
3092             d
3093             d
3094             e
3095             f
3096             d
3097             g
3098             h
3099             i
3100             j
3101             END
3102            
3103             $d->merge;
3104             is_deeply $a->print, <
3105             Key Value
3106             a
3107             b
3108             c
3109             d
3110             e
3111             f
3112             g
3113             h
3114             i
3115             j
3116             END
3117            
3118              
3119             =head2 split($parent)
3120              
3121             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.
3122              
3123             Parameter Description
3124             1 $parent Parent to make into a grand parent
3125              
3126             B
3127              
3128              
3129             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = fromLetters 'b(c)d(efgh(i(j)))';
3130            
3131             is_deeply $a->print, <
3132             Key Value
3133             a
3134             b
3135             c
3136             d
3137             e
3138             f
3139             g
3140             h
3141             i
3142             j
3143             END
3144            
3145            
3146             $d->split; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3147              
3148             is_deeply $a->print, <
3149             Key Value
3150             a
3151             b
3152             c
3153             d
3154             d
3155             e
3156             d
3157             f
3158             d
3159             g
3160             d
3161             h
3162             i
3163             j
3164             END
3165            
3166             $f->parent->mergeLikePrev;
3167             is_deeply $a->print, <
3168             Key Value
3169             a
3170             b
3171             c
3172             d
3173             d
3174             e
3175             f
3176             d
3177             g
3178             d
3179             h
3180             i
3181             j
3182             END
3183            
3184             $g->parent->mergeLikeNext;
3185             is_deeply $a->print, <
3186             Key Value
3187             a
3188             b
3189             c
3190             d
3191             d
3192             e
3193             f
3194             d
3195             g
3196             h
3197             i
3198             j
3199             END
3200            
3201             $d->merge;
3202             is_deeply $a->print, <
3203             Key Value
3204             a
3205             b
3206             c
3207             d
3208             e
3209             f
3210             g
3211             h
3212             i
3213             j
3214             END
3215            
3216              
3217             =head1 Traverse
3218              
3219             Traverse a tree.
3220              
3221             =head2 by($tree, $sub)
3222              
3223             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.
3224              
3225             Parameter Description
3226             1 $tree Tree
3227             2 $sub Optional sub to process each child
3228              
3229             B
3230              
3231              
3232             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $s, $t, $x, $y, $z) =
3233             fromLetters 'b(c)y(x)z(st)d(efgh(i(j))))';
3234            
3235             is_deeply [$x->context], [$x, $y, $a];
3236            
3237            
3238             is_deeply join(' ', $a->by(sub{$_[0]->key})), "c b x y s t z e f g j i h d a"; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3239              
3240            
3241             is_deeply join(' ', map{$_->key} $a->by), "c b x y s t z e f g j i h d a"; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3242              
3243            
3244             is_deeply $a->print, <
3245             Key Value
3246             a
3247             b
3248             c
3249             y
3250             x
3251             z
3252             s
3253             t
3254             d
3255             e
3256             f
3257             g
3258             h
3259             i
3260             j
3261             END
3262            
3263             $z->cut;
3264             is_deeply $a->print, <
3265             Key Value
3266             a
3267             b
3268             c
3269             y
3270             x
3271             d
3272             e
3273             f
3274             g
3275             h
3276             i
3277             j
3278             END
3279            
3280              
3281             =head2 select($tree, $select)
3282              
3283             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.
3284              
3285             Parameter Description
3286             1 $tree Tree
3287             2 $select Method to select a child
3288              
3289             B
3290              
3291              
3292             my $a = Tree::Ops::new 'a', 'A';
3293             for(1..2)
3294             {$a->open ('b', "B$_");
3295             $a->single('c', "C$_");
3296             ok $a->activeScope->key eq 'b';
3297             $a->close;
3298             }
3299             $a->single ('d', 'D');
3300             $a->single ('e', 'E');
3301             is_deeply $a->print, <
3302             Key Value
3303             a A
3304             b B1
3305             c C1
3306             b B2
3307             c C2
3308             d D
3309             e E
3310             END
3311            
3312             is_deeply [map{$_->value} $a->by], [qw(C1 B1 C2 B2 D E A)];
3313            
3314             is_deeply $a->lastMost->prev->prev->first->key, 'c';
3315             is_deeply $a->first->next->last->parent->first->value, 'C2';
3316            
3317            
3318             is_deeply [map{$_->value} $a->select('b')], [qw(B1 B2)]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3319              
3320            
3321             is_deeply [map{$_->value} $a->select(qr(b|c))], [qw(B1 C1 B2 C2)]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3322              
3323            
3324             is_deeply [map{$_->value} $a->select(sub{$_[0] eq 'd'})], [qw(D)]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3325              
3326            
3327             $a->first->next->stepEnd->stepEnd->first->next->stepBack;
3328             is_deeply $a->print, <
3329             Key Value
3330             a A
3331             b B1
3332             c C1
3333             b B2
3334             d D
3335             c C2
3336             e E
3337             END
3338            
3339              
3340             =head1 Partitions
3341              
3342             Various partitions of the tree
3343              
3344             =head2 leaves($tree)
3345              
3346             The set of all children without further children, i.e. each leaf of the tree.
3347              
3348             Parameter Description
3349             1 $tree Tree
3350              
3351             B
3352              
3353              
3354             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $x, $y) =
3355             fromLetters 'b(c)y(x)d(efgh(i(j)))';
3356            
3357             is_deeply $a->print, <
3358             Key Value
3359             a
3360             b
3361             c
3362             y
3363             x
3364             d
3365             e
3366             f
3367             g
3368             h
3369             i
3370             j
3371             END
3372            
3373             is_deeply $a->xml,
3374             '';
3375            
3376            
3377             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3378              
3379             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder];
3380             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder];
3381             is_deeply [$a->parents], [$a->parentsPostOrder];
3382            
3383             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder];
3384             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder];
3385            
3386             ok !$j->parents;
3387            
3388             ok $a->lastMost == $j;
3389             ok !$a->prevMost;
3390             ok $j->prevMost == $g;
3391             ok $i->prevMost == $g;
3392             ok $h->prevMost == $g;
3393             ok $g->prevMost == $f;
3394             ok $f->prevMost == $e;
3395             ok $e->prevMost == $x;
3396             ok $d->prevMost == $x;
3397             ok $x->prevMost == $c;
3398             ok $y->prevMost == $c;
3399             ok !$c->prevMost;
3400             ok !$b->prevMost;
3401             ok !$a->prevMost;
3402            
3403             ok $a->firstMost == $c;
3404             ok $a->nextMost == $c;
3405             ok $b->nextMost == $c;
3406             ok $c->nextMost == $x;
3407             ok $y->nextMost == $x;
3408             ok $x->nextMost == $e;
3409             ok $d->nextMost == $e;
3410             ok $e->nextMost == $f;
3411             ok $f->nextMost == $g;
3412             ok $g->nextMost == $j;
3413             ok $h->nextMost == $j;
3414             ok $i->nextMost == $j;
3415             ok !$j->nextMost;
3416            
3417             ok $i->topMost == $a;
3418            
3419              
3420             =head2 parentsPreOrder($tree)
3421              
3422             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.
3423              
3424             Parameter Description
3425             1 $tree Tree
3426              
3427             B
3428              
3429              
3430             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $x, $y) =
3431             fromLetters 'b(c)y(x)d(efgh(i(j)))';
3432            
3433             is_deeply $a->print, <
3434             Key Value
3435             a
3436             b
3437             c
3438             y
3439             x
3440             d
3441             e
3442             f
3443             g
3444             h
3445             i
3446             j
3447             END
3448            
3449             is_deeply $a->xml,
3450             '';
3451            
3452             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves];
3453            
3454             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3455              
3456             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder];
3457             is_deeply [$a->parents], [$a->parentsPostOrder];
3458            
3459             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder];
3460             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder];
3461            
3462             ok !$j->parents;
3463            
3464             ok $a->lastMost == $j;
3465             ok !$a->prevMost;
3466             ok $j->prevMost == $g;
3467             ok $i->prevMost == $g;
3468             ok $h->prevMost == $g;
3469             ok $g->prevMost == $f;
3470             ok $f->prevMost == $e;
3471             ok $e->prevMost == $x;
3472             ok $d->prevMost == $x;
3473             ok $x->prevMost == $c;
3474             ok $y->prevMost == $c;
3475             ok !$c->prevMost;
3476             ok !$b->prevMost;
3477             ok !$a->prevMost;
3478            
3479             ok $a->firstMost == $c;
3480             ok $a->nextMost == $c;
3481             ok $b->nextMost == $c;
3482             ok $c->nextMost == $x;
3483             ok $y->nextMost == $x;
3484             ok $x->nextMost == $e;
3485             ok $d->nextMost == $e;
3486             ok $e->nextMost == $f;
3487             ok $f->nextMost == $g;
3488             ok $g->nextMost == $j;
3489             ok $h->nextMost == $j;
3490             ok $i->nextMost == $j;
3491             ok !$j->nextMost;
3492            
3493             ok $i->topMost == $a;
3494            
3495              
3496             =head2 parentsPostOrder($tree)
3497              
3498             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.
3499              
3500             Parameter Description
3501             1 $tree Tree
3502              
3503             B
3504              
3505              
3506             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $x, $y) =
3507             fromLetters 'b(c)y(x)d(efgh(i(j)))';
3508            
3509             is_deeply $a->print, <
3510             Key Value
3511             a
3512             b
3513             c
3514             y
3515             x
3516             d
3517             e
3518             f
3519             g
3520             h
3521             i
3522             j
3523             END
3524            
3525             is_deeply $a->xml,
3526             '';
3527            
3528             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves];
3529             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder];
3530            
3531             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3532              
3533            
3534             is_deeply [$a->parents], [$a->parentsPostOrder]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3535              
3536            
3537             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder];
3538             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder];
3539            
3540             ok !$j->parents;
3541            
3542             ok $a->lastMost == $j;
3543             ok !$a->prevMost;
3544             ok $j->prevMost == $g;
3545             ok $i->prevMost == $g;
3546             ok $h->prevMost == $g;
3547             ok $g->prevMost == $f;
3548             ok $f->prevMost == $e;
3549             ok $e->prevMost == $x;
3550             ok $d->prevMost == $x;
3551             ok $x->prevMost == $c;
3552             ok $y->prevMost == $c;
3553             ok !$c->prevMost;
3554             ok !$b->prevMost;
3555             ok !$a->prevMost;
3556            
3557             ok $a->firstMost == $c;
3558             ok $a->nextMost == $c;
3559             ok $b->nextMost == $c;
3560             ok $c->nextMost == $x;
3561             ok $y->nextMost == $x;
3562             ok $x->nextMost == $e;
3563             ok $d->nextMost == $e;
3564             ok $e->nextMost == $f;
3565             ok $f->nextMost == $g;
3566             ok $g->nextMost == $j;
3567             ok $h->nextMost == $j;
3568             ok $i->nextMost == $j;
3569             ok !$j->nextMost;
3570            
3571             ok $i->topMost == $a;
3572            
3573              
3574             =head2 parentsReversePreOrder($tree)
3575              
3576             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.
3577              
3578             Parameter Description
3579             1 $tree Tree
3580              
3581             B
3582              
3583              
3584             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $x, $y) =
3585             fromLetters 'b(c)y(x)d(efgh(i(j)))';
3586            
3587             is_deeply $a->print, <
3588             Key Value
3589             a
3590             b
3591             c
3592             y
3593             x
3594             d
3595             e
3596             f
3597             g
3598             h
3599             i
3600             j
3601             END
3602            
3603             is_deeply $a->xml,
3604             '';
3605            
3606             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves];
3607             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder];
3608             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder];
3609             is_deeply [$a->parents], [$a->parentsPostOrder];
3610            
3611            
3612             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3613              
3614             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder];
3615            
3616             ok !$j->parents;
3617            
3618             ok $a->lastMost == $j;
3619             ok !$a->prevMost;
3620             ok $j->prevMost == $g;
3621             ok $i->prevMost == $g;
3622             ok $h->prevMost == $g;
3623             ok $g->prevMost == $f;
3624             ok $f->prevMost == $e;
3625             ok $e->prevMost == $x;
3626             ok $d->prevMost == $x;
3627             ok $x->prevMost == $c;
3628             ok $y->prevMost == $c;
3629             ok !$c->prevMost;
3630             ok !$b->prevMost;
3631             ok !$a->prevMost;
3632            
3633             ok $a->firstMost == $c;
3634             ok $a->nextMost == $c;
3635             ok $b->nextMost == $c;
3636             ok $c->nextMost == $x;
3637             ok $y->nextMost == $x;
3638             ok $x->nextMost == $e;
3639             ok $d->nextMost == $e;
3640             ok $e->nextMost == $f;
3641             ok $f->nextMost == $g;
3642             ok $g->nextMost == $j;
3643             ok $h->nextMost == $j;
3644             ok $i->nextMost == $j;
3645             ok !$j->nextMost;
3646            
3647             ok $i->topMost == $a;
3648            
3649              
3650             =head2 parentsReversePostOrder($tree)
3651              
3652             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.
3653              
3654             Parameter Description
3655             1 $tree Tree
3656              
3657             B
3658              
3659              
3660             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $x, $y) =
3661             fromLetters 'b(c)y(x)d(efgh(i(j)))';
3662            
3663             is_deeply $a->print, <
3664             Key Value
3665             a
3666             b
3667             c
3668             y
3669             x
3670             d
3671             e
3672             f
3673             g
3674             h
3675             i
3676             j
3677             END
3678            
3679             is_deeply $a->xml,
3680             '';
3681            
3682             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves];
3683             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder];
3684             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder];
3685             is_deeply [$a->parents], [$a->parentsPostOrder];
3686            
3687             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder];
3688            
3689             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3690              
3691            
3692             ok !$j->parents;
3693            
3694             ok $a->lastMost == $j;
3695             ok !$a->prevMost;
3696             ok $j->prevMost == $g;
3697             ok $i->prevMost == $g;
3698             ok $h->prevMost == $g;
3699             ok $g->prevMost == $f;
3700             ok $f->prevMost == $e;
3701             ok $e->prevMost == $x;
3702             ok $d->prevMost == $x;
3703             ok $x->prevMost == $c;
3704             ok $y->prevMost == $c;
3705             ok !$c->prevMost;
3706             ok !$b->prevMost;
3707             ok !$a->prevMost;
3708            
3709             ok $a->firstMost == $c;
3710             ok $a->nextMost == $c;
3711             ok $b->nextMost == $c;
3712             ok $c->nextMost == $x;
3713             ok $y->nextMost == $x;
3714             ok $x->nextMost == $e;
3715             ok $d->nextMost == $e;
3716             ok $e->nextMost == $f;
3717             ok $f->nextMost == $g;
3718             ok $g->nextMost == $j;
3719             ok $h->nextMost == $j;
3720             ok $i->nextMost == $j;
3721             ok !$j->nextMost;
3722            
3723             ok $i->topMost == $a;
3724            
3725              
3726             =head2 parents($tree)
3727              
3728             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.
3729              
3730             Parameter Description
3731             1 $tree Tree
3732              
3733             B
3734              
3735              
3736             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $x, $y) =
3737             fromLetters 'b(c)y(x)d(efgh(i(j)))';
3738            
3739             is_deeply $a->print, <
3740             Key Value
3741             a
3742             b
3743             c
3744             y
3745             x
3746             d
3747             e
3748             f
3749             g
3750             h
3751             i
3752             j
3753             END
3754            
3755             is_deeply $a->xml,
3756             '';
3757            
3758             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves];
3759             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder];
3760             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder];
3761            
3762             is_deeply [$a->parents], [$a->parentsPostOrder]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3763              
3764            
3765             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder];
3766             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder];
3767            
3768            
3769             ok !$j->parents; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3770              
3771            
3772             ok $a->lastMost == $j;
3773             ok !$a->prevMost;
3774             ok $j->prevMost == $g;
3775             ok $i->prevMost == $g;
3776             ok $h->prevMost == $g;
3777             ok $g->prevMost == $f;
3778             ok $f->prevMost == $e;
3779             ok $e->prevMost == $x;
3780             ok $d->prevMost == $x;
3781             ok $x->prevMost == $c;
3782             ok $y->prevMost == $c;
3783             ok !$c->prevMost;
3784             ok !$b->prevMost;
3785             ok !$a->prevMost;
3786            
3787             ok $a->firstMost == $c;
3788             ok $a->nextMost == $c;
3789             ok $b->nextMost == $c;
3790             ok $c->nextMost == $x;
3791             ok $y->nextMost == $x;
3792             ok $x->nextMost == $e;
3793             ok $d->nextMost == $e;
3794             ok $e->nextMost == $f;
3795             ok $f->nextMost == $g;
3796             ok $g->nextMost == $j;
3797             ok $h->nextMost == $j;
3798             ok $i->nextMost == $j;
3799             ok !$j->nextMost;
3800            
3801             ok $i->topMost == $a;
3802            
3803              
3804             =head1 Order
3805              
3806             Check the order and relative position of children in a tree.
3807              
3808             =head2 above($first, $second)
3809              
3810             Return the first child if it is above the second child else return B.
3811              
3812             Parameter Description
3813             1 $first First child
3814             2 $second Second child
3815              
3816             B
3817              
3818              
3819             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $k, $l, $m, $n) =
3820             fromLetters('b(c(d(efgh(i(j)k)l)m)n');
3821            
3822             is_deeply $a->print, <
3823             Key Value
3824             a
3825             b
3826             c
3827             d
3828             e
3829             f
3830             g
3831             h
3832             i
3833             j
3834             k
3835             l
3836             m
3837             n
3838             END
3839            
3840            
3841             ok $c->above($j) == $c; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3842              
3843            
3844             ok !$m->above($j); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3845              
3846            
3847             ok $i->below($b) == $i;
3848             ok !$i->below($n);
3849            
3850             ok $n->after($e) == $n;
3851             ok !$k->after($c);
3852            
3853             ok $c->before($n) == $c;
3854             ok !$c->before($m);
3855            
3856             is_deeply [map{$_->key} $j->lineage($d)], [qw(j i h d)];
3857             ok !$d->lineage($m);
3858            
3859              
3860             =head2 below($first, $second)
3861              
3862             Return the first child if it is below the second child else return B.
3863              
3864             Parameter Description
3865             1 $first First child
3866             2 $second Second child
3867              
3868             B
3869              
3870              
3871             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $k, $l, $m, $n) =
3872             fromLetters('b(c(d(efgh(i(j)k)l)m)n');
3873            
3874             is_deeply $a->print, <
3875             Key Value
3876             a
3877             b
3878             c
3879             d
3880             e
3881             f
3882             g
3883             h
3884             i
3885             j
3886             k
3887             l
3888             m
3889             n
3890             END
3891            
3892             ok $c->above($j) == $c;
3893             ok !$m->above($j);
3894            
3895            
3896             ok $i->below($b) == $i; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3897              
3898            
3899             ok !$i->below($n); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3900              
3901            
3902             ok $n->after($e) == $n;
3903             ok !$k->after($c);
3904            
3905             ok $c->before($n) == $c;
3906             ok !$c->before($m);
3907            
3908             is_deeply [map{$_->key} $j->lineage($d)], [qw(j i h d)];
3909             ok !$d->lineage($m);
3910            
3911              
3912             =head2 after($first, $second)
3913              
3914             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.
3915              
3916             Parameter Description
3917             1 $first First child
3918             2 $second Second child
3919              
3920             B
3921              
3922              
3923             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $k, $l, $m, $n) =
3924             fromLetters('b(c(d(efgh(i(j)k)l)m)n');
3925            
3926             is_deeply $a->print, <
3927             Key Value
3928             a
3929             b
3930             c
3931             d
3932             e
3933             f
3934             g
3935             h
3936             i
3937             j
3938             k
3939             l
3940             m
3941             n
3942             END
3943            
3944             ok $c->above($j) == $c;
3945             ok !$m->above($j);
3946            
3947             ok $i->below($b) == $i;
3948             ok !$i->below($n);
3949            
3950            
3951             ok $n->after($e) == $n; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3952              
3953            
3954             ok !$k->after($c); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
3955              
3956            
3957             ok $c->before($n) == $c;
3958             ok !$c->before($m);
3959            
3960             is_deeply [map{$_->key} $j->lineage($d)], [qw(j i h d)];
3961             ok !$d->lineage($m);
3962            
3963              
3964             =head2 before($first, $second)
3965              
3966             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.
3967              
3968             Parameter Description
3969             1 $first First child
3970             2 $second Second child
3971              
3972             B
3973              
3974              
3975             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $k, $l, $m, $n) =
3976             fromLetters('b(c(d(efgh(i(j)k)l)m)n');
3977            
3978             is_deeply $a->print, <
3979             Key Value
3980             a
3981             b
3982             c
3983             d
3984             e
3985             f
3986             g
3987             h
3988             i
3989             j
3990             k
3991             l
3992             m
3993             n
3994             END
3995            
3996             ok $c->above($j) == $c;
3997             ok !$m->above($j);
3998            
3999             ok $i->below($b) == $i;
4000             ok !$i->below($n);
4001            
4002             ok $n->after($e) == $n;
4003             ok !$k->after($c);
4004            
4005            
4006             ok $c->before($n) == $c; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
4007              
4008            
4009             ok !$c->before($m); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
4010              
4011            
4012             is_deeply [map{$_->key} $j->lineage($d)], [qw(j i h d)];
4013             ok !$d->lineage($m);
4014            
4015              
4016             =head1 Paths
4017              
4018             Find paths between nodes
4019              
4020             =head2 path($child)
4021              
4022             Return the list of zero based child indexes for the path from the root of the tree containing the specified child to the specified child for use by the L method.
4023              
4024             Parameter Description
4025             1 $child Child
4026              
4027             B
4028              
4029              
4030             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = fromLetters 'b(cd(e(fg)h)i)j';
4031            
4032             is_deeply $a->print, <
4033             Key Value
4034             a
4035             b
4036             c
4037             d
4038             e
4039             f
4040             g
4041             h
4042             i
4043             j
4044             END
4045            
4046             ok $a->go(0,1,0,1) == $g;
4047             ok $d->go(0,0) == $f;
4048            
4049            
4050             is_deeply [$e->path], [0,1,0]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
4051              
4052             is_deeply [$g->pathFrom($d)], [0,1];
4053            
4054             is_deeply $b->dup->print, <
4055             Key Value
4056             b
4057             c
4058             d
4059             e
4060             f
4061             g
4062             h
4063             i
4064             END
4065            
4066             my $B = $b->transcribe;
4067            
4068             $b->by(sub
4069             {my ($c) = @_;
4070            
4071             my @path = $c->pathFrom($b); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
4072              
4073            
4074             my $C = $B->go(@path); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
4075              
4076             is_deeply $c->key, $C->key;
4077             is_deeply $c->{transcribedTo}, $C;
4078             is_deeply $C->{transcribedFrom}, $c;
4079             });
4080            
4081             is_deeply $B->print, <
4082             Key Value
4083             b
4084             c
4085             d
4086             e
4087             f
4088             g
4089             h
4090             i
4091             END
4092            
4093              
4094             =head2 pathFrom($child, $ancestor)
4095              
4096             Return the list of zero based child indexes for the path from the specified ancestor to the specified child for use by the L method else confess if the ancestor is not, in fact, an ancestor.
4097              
4098             Parameter Description
4099             1 $child Child
4100             2 $ancestor Ancestor
4101              
4102             B
4103              
4104              
4105             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = fromLetters 'b(cd(e(fg)h)i)j';
4106            
4107             is_deeply $a->print, <
4108             Key Value
4109             a
4110             b
4111             c
4112             d
4113             e
4114             f
4115             g
4116             h
4117             i
4118             j
4119             END
4120            
4121             ok $a->go(0,1,0,1) == $g;
4122             ok $d->go(0,0) == $f;
4123            
4124             is_deeply [$e->path], [0,1,0];
4125            
4126             is_deeply [$g->pathFrom($d)], [0,1]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
4127              
4128            
4129             is_deeply $b->dup->print, <
4130             Key Value
4131             b
4132             c
4133             d
4134             e
4135             f
4136             g
4137             h
4138             i
4139             END
4140            
4141             my $B = $b->transcribe;
4142            
4143             $b->by(sub
4144             {my ($c) = @_;
4145            
4146             my @path = $c->pathFrom($b); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
4147              
4148             my $C = $B->go(@path);
4149             is_deeply $c->key, $C->key;
4150             is_deeply $c->{transcribedTo}, $C;
4151             is_deeply $C->{transcribedFrom}, $c;
4152             });
4153            
4154             is_deeply $B->print, <
4155             Key Value
4156             b
4157             c
4158             d
4159             e
4160             f
4161             g
4162             h
4163             i
4164             END
4165            
4166              
4167             =head2 siblingsBefore($child)
4168              
4169             Return a list of siblings before the specified child.
4170              
4171             Parameter Description
4172             1 $child Child
4173              
4174             B
4175              
4176              
4177             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = fromLetters 'b(cde(f)ghi)j';
4178             is_deeply $a->print, <
4179             Key Value
4180             a
4181             b
4182             c
4183             d
4184             e
4185             f
4186             g
4187             h
4188             i
4189             j
4190             END
4191            
4192             is_deeply [$d->siblingsStrictlyBetween($h)], [$e, $g];
4193             is_deeply [$d->siblingsAfter], [$e, $g, $h, $i];
4194            
4195             is_deeply [$g->siblingsBefore], [$c, $d, $e]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
4196              
4197             eval {$e->siblingsStrictlyBetween($f)};
4198             ok $@ =~ m(Must be siblings);
4199            
4200              
4201             =head2 siblingsAfter($child)
4202              
4203             Return a list of siblings after the specified child.
4204              
4205             Parameter Description
4206             1 $child Child
4207              
4208             B
4209              
4210              
4211             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = fromLetters 'b(cde(f)ghi)j';
4212             is_deeply $a->print, <
4213             Key Value
4214             a
4215             b
4216             c
4217             d
4218             e
4219             f
4220             g
4221             h
4222             i
4223             j
4224             END
4225            
4226             is_deeply [$d->siblingsStrictlyBetween($h)], [$e, $g];
4227            
4228             is_deeply [$d->siblingsAfter], [$e, $g, $h, $i]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
4229              
4230             is_deeply [$g->siblingsBefore], [$c, $d, $e];
4231             eval {$e->siblingsStrictlyBetween($f)};
4232             ok $@ =~ m(Must be siblings);
4233            
4234              
4235             =head2 siblingsStrictlyBetween($start, $finish)
4236              
4237             Return a list of the siblings strictly between two children of the same parent else return B.
4238              
4239             Parameter Description
4240             1 $start Start child
4241             2 $finish Finish child
4242              
4243             B
4244              
4245              
4246             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j) = fromLetters 'b(cde(f)ghi)j';
4247             is_deeply $a->print, <
4248             Key Value
4249             a
4250             b
4251             c
4252             d
4253             e
4254             f
4255             g
4256             h
4257             i
4258             j
4259             END
4260            
4261            
4262             is_deeply [$d->siblingsStrictlyBetween($h)], [$e, $g]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
4263              
4264             is_deeply [$d->siblingsAfter], [$e, $g, $h, $i];
4265             is_deeply [$g->siblingsBefore], [$c, $d, $e];
4266            
4267             eval {$e->siblingsStrictlyBetween($f)}; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
4268              
4269             ok $@ =~ m(Must be siblings);
4270            
4271              
4272             =head2 lineage($child, $ancestor)
4273              
4274             Return the path from the specified child to the specified ancestor else return B if the child is not a descendant of the ancestor.
4275              
4276             Parameter Description
4277             1 $child Child
4278             2 $ancestor Ancestor
4279              
4280             B
4281              
4282              
4283             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $k, $l, $m, $n) =
4284             fromLetters('b(c(d(efgh(i(j)k)l)m)n');
4285            
4286             is_deeply $a->print, <
4287             Key Value
4288             a
4289             b
4290             c
4291             d
4292             e
4293             f
4294             g
4295             h
4296             i
4297             j
4298             k
4299             l
4300             m
4301             n
4302             END
4303            
4304             ok $c->above($j) == $c;
4305             ok !$m->above($j);
4306            
4307             ok $i->below($b) == $i;
4308             ok !$i->below($n);
4309            
4310             ok $n->after($e) == $n;
4311             ok !$k->after($c);
4312            
4313             ok $c->before($n) == $c;
4314             ok !$c->before($m);
4315            
4316            
4317             is_deeply [map{$_->key} $j->lineage($d)], [qw(j i h d)]; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
4318              
4319            
4320             ok !$d->lineage($m); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
4321              
4322            
4323              
4324             =head2 nextPreOrderPath($start)
4325              
4326             Return a list of children visited between the specified child and the next child in pre-order.
4327              
4328             Parameter Description
4329             1 $start The child at the start of the path
4330              
4331             B
4332              
4333              
4334             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $k, $l, $m, $n, $o, $p, $q, $r) =
4335             fromLetters 'b(c(d(e(fg)hi(j(kl)m)n)op)q)r';
4336             my @p = [$a];
4337            
4338             for(1..99)
4339            
4340             {my @n = $p[-1][-1]->nextPreOrderPath; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
4341              
4342             last unless @n;
4343             push @p, [@n];
4344             }
4345            
4346             is_deeply $a->print, <
4347             Key Value
4348             a
4349             b
4350             c
4351             d
4352             e
4353             f
4354             g
4355             h
4356             i
4357             j
4358             k
4359             l
4360             m
4361             n
4362             o
4363             p
4364             q
4365             r
4366             END
4367            
4368             my @pre = map{[map{$_->key} @$_]} @p;
4369             is_deeply scalar(@pre), scalar(['a'..'r']->@*);
4370             is_deeply [@pre],
4371             [["a"],
4372             ["b"],
4373             ["c"],
4374             ["d"],
4375             ["e"],
4376             ["f"],
4377             ["g"],
4378             ["e", "h"],
4379             ["i"],
4380             ["j"],
4381             ["k"],
4382             ["l"],
4383             ["j", "m"],
4384             ["i", "n"],
4385             ["d", "o"],
4386             ["p"],
4387             ["c", "q"],
4388             ["b", "r"]];
4389            
4390              
4391             =head2 nextPostOrderPath($start)
4392              
4393             Return a list of children visited between the specified child and the next child in post-order.
4394              
4395             Parameter Description
4396             1 $start The child at the start of the path
4397              
4398             B
4399              
4400              
4401             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $k, $l, $m, $n, $o, $p, $q, $r) =
4402             fromLetters 'b(c(d(e(fg)hi(j(kl)m)n)op)q)r';
4403            
4404             my @n = $a;
4405             my @p;
4406             for(1..99)
4407            
4408             {@n = $n[-1]->nextPostOrderPath; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
4409              
4410             last unless @n;
4411             push @p, [@n];
4412             last if $n[-1] == $a;
4413             }
4414            
4415             is_deeply $a->print, <
4416             Key Value
4417             a
4418             b
4419             c
4420             d
4421             e
4422             f
4423             g
4424             h
4425             i
4426             j
4427             k
4428             l
4429             m
4430             n
4431             o
4432             p
4433             q
4434             r
4435             END
4436            
4437             my @post = map{[map{$_->key} @$_]} @p;
4438             is_deeply scalar(@post), scalar(['a'..'r']->@*);
4439             is_deeply [@post],
4440             [["b" .. "f"],
4441             ["g"],
4442             ["e"],
4443             ["h"],
4444             ["i", "j", "k"],
4445             ["l"],
4446             ["j"],
4447             ["m"],
4448             ["i"],
4449             ["n"],
4450             ["d"],
4451             ["o"],
4452             ["p"],
4453             ["c"],
4454             ["q"],
4455             ["b"],
4456             ["r"],
4457             ["a"]];
4458            
4459              
4460             =head2 prevPostOrderPath($start)
4461              
4462             Return a list of children visited between the specified child and the previous child in post-order.
4463              
4464             Parameter Description
4465             1 $start The child at the start of the path
4466              
4467             B
4468              
4469              
4470             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $k, $l, $m, $n, $o, $p, $q, $r) =
4471             fromLetters 'b(c(d(e(fg)hi(j(kl)m)n)op)q)r';
4472             my @p = [$a];
4473            
4474             for(1..99)
4475            
4476             {my @n = $p[-1][-1]->prevPostOrderPath; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
4477              
4478             last unless @n;
4479             push @p, [@n];
4480             }
4481            
4482             is_deeply $a->print, <
4483             Key Value
4484             a
4485             b
4486             c
4487             d
4488             e
4489             f
4490             g
4491             h
4492             i
4493             j
4494             k
4495             l
4496             m
4497             n
4498             o
4499             p
4500             q
4501             r
4502             END
4503            
4504             my @post = map{[map{$_->key} @$_]} @p;
4505             is_deeply scalar(@post), scalar(['a'..'r']->@*);
4506             is_deeply [@post],
4507             [["a"],
4508             ["r"],
4509             ["b"],
4510             ["q"],
4511             ["c"],
4512             ["p"],
4513             ["o"],
4514             ["d"],
4515             ["n"],
4516             ["i"],
4517             ["m"],
4518             ["j"],
4519             ["l"],
4520             ["k"],
4521             ["j", "i", "h"],
4522             ["e"],
4523             ["g"],
4524             ["f"]];
4525            
4526              
4527             =head2 prevPreOrderPath($start)
4528              
4529             Return a list of children visited between the specified child and the previous child in pre-order.
4530              
4531             Parameter Description
4532             1 $start The child at the start of the path
4533              
4534             B
4535              
4536              
4537             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $k, $l, $m, $n, $o, $p, $q, $r) =
4538             fromLetters 'b(c(d(e(fg)hi(j(kl)m)n)op)q)r';
4539            
4540             my @n = $a;
4541             my @p;
4542             for(1..99)
4543            
4544             {@n = $n[-1]->prevPreOrderPath; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
4545              
4546             last unless @n;
4547             push @p, [@n];
4548             last if $n[-1] == $a;
4549             }
4550            
4551             is_deeply $a->print, <
4552             Key Value
4553             a
4554             b
4555             c
4556             d
4557             e
4558             f
4559             g
4560             h
4561             i
4562             j
4563             k
4564             l
4565             m
4566             n
4567             o
4568             p
4569             q
4570             r
4571             END
4572            
4573             my @pre = map{[map{$_->key} @$_]} @p;
4574             is_deeply scalar(@pre), scalar(['a'..'r']->@*);
4575             is_deeply [@pre],
4576             [["r"],
4577             ["b", "q"],
4578             ["c", "p"],
4579             ["o"],
4580             ["d", "n"],
4581             ["i", "m"],
4582             ["j", "l"],
4583             ["k"],
4584             ["j"],
4585             ["i"],
4586             ["h"],
4587             ["e", "g"],
4588             ["f"],
4589             ["e"],
4590             ["d"],
4591             ["c"],
4592             ["b"],
4593             ["a"]];
4594            
4595              
4596             =head1 Print
4597              
4598             Print a tree.
4599              
4600             =head2 printPreOrder($tree, $print)
4601              
4602             Print tree in normal pre-order.
4603              
4604             Parameter Description
4605             1 $tree Tree
4606             2 $print Optional print method
4607              
4608             B
4609              
4610              
4611             my ($a, $b, $c, $d) = fromLetters 'b(c)d';
4612             my sub test(@) {join ' ', map{join '', $_->key} @_}
4613            
4614            
4615             is_deeply $a->printPreOrder, <
4616              
4617             Key Value
4618             a
4619             b
4620             c
4621             d
4622             END
4623            
4624             is_deeply test($a->nextPreOrderPath), 'b';
4625             is_deeply test($b->nextPreOrderPath), 'c';
4626             is_deeply test($c->nextPreOrderPath), 'b d';
4627             is_deeply test($d->nextPreOrderPath), '';
4628            
4629             is_deeply $a->printPostOrder, <
4630             Key Value
4631             c
4632             b
4633             d
4634             a
4635             END
4636            
4637             is_deeply test($a->nextPostOrderPath), 'b c';
4638             is_deeply test($c->nextPostOrderPath), 'b';
4639             is_deeply test($b->nextPostOrderPath), 'd';
4640             is_deeply test($d->nextPostOrderPath), 'a';
4641            
4642             is_deeply $a->printReversePreOrder, <
4643             Key Value
4644             a
4645             d
4646             b
4647             c
4648             END
4649             is_deeply test($a->prevPreOrderPath), 'd';
4650             is_deeply test($d->prevPreOrderPath), 'b c';
4651             is_deeply test($c->prevPreOrderPath), 'b';
4652             is_deeply test($b->prevPreOrderPath), 'a';
4653            
4654             is_deeply $a->printReversePostOrder, <
4655             Key Value
4656             d
4657             c
4658             b
4659             a
4660             END
4661            
4662             is_deeply test($a->prevPostOrderPath), 'd';
4663             is_deeply test($d->prevPostOrderPath), 'b';
4664             is_deeply test($b->prevPostOrderPath), 'c';
4665             is_deeply test($c->prevPostOrderPath), '';
4666            
4667              
4668             =head2 printPostOrder($tree, $print)
4669              
4670             Print tree in normal post-order.
4671              
4672             Parameter Description
4673             1 $tree Tree
4674             2 $print Optional print method
4675              
4676             B
4677              
4678              
4679             my ($a, $b, $c, $d) = fromLetters 'b(c)d';
4680             my sub test(@) {join ' ', map{join '', $_->key} @_}
4681            
4682             is_deeply $a->printPreOrder, <
4683             Key Value
4684             a
4685             b
4686             c
4687             d
4688             END
4689            
4690             is_deeply test($a->nextPreOrderPath), 'b';
4691             is_deeply test($b->nextPreOrderPath), 'c';
4692             is_deeply test($c->nextPreOrderPath), 'b d';
4693             is_deeply test($d->nextPreOrderPath), '';
4694            
4695            
4696             is_deeply $a->printPostOrder, <
4697              
4698             Key Value
4699             c
4700             b
4701             d
4702             a
4703             END
4704            
4705             is_deeply test($a->nextPostOrderPath), 'b c';
4706             is_deeply test($c->nextPostOrderPath), 'b';
4707             is_deeply test($b->nextPostOrderPath), 'd';
4708             is_deeply test($d->nextPostOrderPath), 'a';
4709            
4710             is_deeply $a->printReversePreOrder, <
4711             Key Value
4712             a
4713             d
4714             b
4715             c
4716             END
4717             is_deeply test($a->prevPreOrderPath), 'd';
4718             is_deeply test($d->prevPreOrderPath), 'b c';
4719             is_deeply test($c->prevPreOrderPath), 'b';
4720             is_deeply test($b->prevPreOrderPath), 'a';
4721            
4722             is_deeply $a->printReversePostOrder, <
4723             Key Value
4724             d
4725             c
4726             b
4727             a
4728             END
4729            
4730             is_deeply test($a->prevPostOrderPath), 'd';
4731             is_deeply test($d->prevPostOrderPath), 'b';
4732             is_deeply test($b->prevPostOrderPath), 'c';
4733             is_deeply test($c->prevPostOrderPath), '';
4734            
4735              
4736             =head2 printReversePreOrder($tree, $print)
4737              
4738             Print tree in reverse pre-order
4739              
4740             Parameter Description
4741             1 $tree Tree
4742             2 $print Optional print method
4743              
4744             B
4745              
4746              
4747             my ($a, $b, $c, $d) = fromLetters 'b(c)d';
4748             my sub test(@) {join ' ', map{join '', $_->key} @_}
4749            
4750             is_deeply $a->printPreOrder, <
4751             Key Value
4752             a
4753             b
4754             c
4755             d
4756             END
4757            
4758             is_deeply test($a->nextPreOrderPath), 'b';
4759             is_deeply test($b->nextPreOrderPath), 'c';
4760             is_deeply test($c->nextPreOrderPath), 'b d';
4761             is_deeply test($d->nextPreOrderPath), '';
4762            
4763             is_deeply $a->printPostOrder, <
4764             Key Value
4765             c
4766             b
4767             d
4768             a
4769             END
4770            
4771             is_deeply test($a->nextPostOrderPath), 'b c';
4772             is_deeply test($c->nextPostOrderPath), 'b';
4773             is_deeply test($b->nextPostOrderPath), 'd';
4774             is_deeply test($d->nextPostOrderPath), 'a';
4775            
4776            
4777             is_deeply $a->printReversePreOrder, <
4778              
4779             Key Value
4780             a
4781             d
4782             b
4783             c
4784             END
4785             is_deeply test($a->prevPreOrderPath), 'd';
4786             is_deeply test($d->prevPreOrderPath), 'b c';
4787             is_deeply test($c->prevPreOrderPath), 'b';
4788             is_deeply test($b->prevPreOrderPath), 'a';
4789            
4790             is_deeply $a->printReversePostOrder, <
4791             Key Value
4792             d
4793             c
4794             b
4795             a
4796             END
4797            
4798             is_deeply test($a->prevPostOrderPath), 'd';
4799             is_deeply test($d->prevPostOrderPath), 'b';
4800             is_deeply test($b->prevPostOrderPath), 'c';
4801             is_deeply test($c->prevPostOrderPath), '';
4802            
4803              
4804             =head2 printReversePostOrder($tree, $print)
4805              
4806             Print tree in reverse post-order
4807              
4808             Parameter Description
4809             1 $tree Tree
4810             2 $print Optional print method
4811              
4812             B
4813              
4814              
4815             my ($a, $b, $c, $d) = fromLetters 'b(c)d';
4816             my sub test(@) {join ' ', map{join '', $_->key} @_}
4817            
4818             is_deeply $a->printPreOrder, <
4819             Key Value
4820             a
4821             b
4822             c
4823             d
4824             END
4825            
4826             is_deeply test($a->nextPreOrderPath), 'b';
4827             is_deeply test($b->nextPreOrderPath), 'c';
4828             is_deeply test($c->nextPreOrderPath), 'b d';
4829             is_deeply test($d->nextPreOrderPath), '';
4830            
4831             is_deeply $a->printPostOrder, <
4832             Key Value
4833             c
4834             b
4835             d
4836             a
4837             END
4838            
4839             is_deeply test($a->nextPostOrderPath), 'b c';
4840             is_deeply test($c->nextPostOrderPath), 'b';
4841             is_deeply test($b->nextPostOrderPath), 'd';
4842             is_deeply test($d->nextPostOrderPath), 'a';
4843            
4844             is_deeply $a->printReversePreOrder, <
4845             Key Value
4846             a
4847             d
4848             b
4849             c
4850             END
4851             is_deeply test($a->prevPreOrderPath), 'd';
4852             is_deeply test($d->prevPreOrderPath), 'b c';
4853             is_deeply test($c->prevPreOrderPath), 'b';
4854             is_deeply test($b->prevPreOrderPath), 'a';
4855            
4856            
4857             is_deeply $a->printReversePostOrder, <
4858              
4859             Key Value
4860             d
4861             c
4862             b
4863             a
4864             END
4865            
4866             is_deeply test($a->prevPostOrderPath), 'd';
4867             is_deeply test($d->prevPostOrderPath), 'b';
4868             is_deeply test($b->prevPostOrderPath), 'c';
4869             is_deeply test($c->prevPostOrderPath), '';
4870            
4871              
4872             =head2 print($tree, $print)
4873              
4874             Print tree in normal pre-order.
4875              
4876             Parameter Description
4877             1 $tree Tree
4878             2 $print Optional print method
4879              
4880             B
4881              
4882              
4883             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $x, $y) =
4884             fromLetters 'b(c)y(x)d(efgh(i(j)))';
4885            
4886            
4887             is_deeply $a->print, <
4888              
4889             Key Value
4890             a
4891             b
4892             c
4893             y
4894             x
4895             d
4896             e
4897             f
4898             g
4899             h
4900             i
4901             j
4902             END
4903            
4904             is_deeply $a->xml,
4905             '';
4906            
4907             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves];
4908             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder];
4909             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder];
4910             is_deeply [$a->parents], [$a->parentsPostOrder];
4911            
4912             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder];
4913             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder];
4914            
4915             ok !$j->parents;
4916            
4917             ok $a->lastMost == $j;
4918             ok !$a->prevMost;
4919             ok $j->prevMost == $g;
4920             ok $i->prevMost == $g;
4921             ok $h->prevMost == $g;
4922             ok $g->prevMost == $f;
4923             ok $f->prevMost == $e;
4924             ok $e->prevMost == $x;
4925             ok $d->prevMost == $x;
4926             ok $x->prevMost == $c;
4927             ok $y->prevMost == $c;
4928             ok !$c->prevMost;
4929             ok !$b->prevMost;
4930             ok !$a->prevMost;
4931            
4932             ok $a->firstMost == $c;
4933             ok $a->nextMost == $c;
4934             ok $b->nextMost == $c;
4935             ok $c->nextMost == $x;
4936             ok $y->nextMost == $x;
4937             ok $x->nextMost == $e;
4938             ok $d->nextMost == $e;
4939             ok $e->nextMost == $f;
4940             ok $f->nextMost == $g;
4941             ok $g->nextMost == $j;
4942             ok $h->nextMost == $j;
4943             ok $i->nextMost == $j;
4944             ok !$j->nextMost;
4945            
4946             ok $i->topMost == $a;
4947            
4948              
4949             =head2 brackets($tree, $print, $separator)
4950              
4951             Bracketed string representation of a tree.
4952              
4953             Parameter Description
4954             1 $tree Tree
4955             2 $print Optional print method
4956             3 $separator Optional child separator
4957              
4958             B
4959              
4960              
4961             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $x, $y) =
4962             fromLetters 'b(c)y(x)d(efgh(i(j)))';
4963            
4964             is_deeply $a->print, <
4965             Key Value
4966             a
4967             b
4968             c
4969             y
4970             x
4971             d
4972             e
4973             f
4974             g
4975             h
4976             i
4977             j
4978             END
4979            
4980             is_deeply $a->xml,
4981             '';
4982            
4983             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves];
4984             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder];
4985             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder];
4986             is_deeply [$a->parents], [$a->parentsPostOrder];
4987            
4988             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder];
4989             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder];
4990            
4991             ok !$j->parents;
4992            
4993             ok $a->lastMost == $j;
4994             ok !$a->prevMost;
4995             ok $j->prevMost == $g;
4996             ok $i->prevMost == $g;
4997             ok $h->prevMost == $g;
4998             ok $g->prevMost == $f;
4999             ok $f->prevMost == $e;
5000             ok $e->prevMost == $x;
5001             ok $d->prevMost == $x;
5002             ok $x->prevMost == $c;
5003             ok $y->prevMost == $c;
5004             ok !$c->prevMost;
5005             ok !$b->prevMost;
5006             ok !$a->prevMost;
5007            
5008             ok $a->firstMost == $c;
5009             ok $a->nextMost == $c;
5010             ok $b->nextMost == $c;
5011             ok $c->nextMost == $x;
5012             ok $y->nextMost == $x;
5013             ok $x->nextMost == $e;
5014             ok $d->nextMost == $e;
5015             ok $e->nextMost == $f;
5016             ok $f->nextMost == $g;
5017             ok $g->nextMost == $j;
5018             ok $h->nextMost == $j;
5019             ok $i->nextMost == $j;
5020             ok !$j->nextMost;
5021            
5022             ok $i->topMost == $a;
5023            
5024              
5025             =head2 xml($tree, $print)
5026              
5027             Print a tree as as xml.
5028              
5029             Parameter Description
5030             1 $tree Tree
5031             2 $print Optional print method
5032              
5033             B
5034              
5035              
5036             my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $x, $y) =
5037             fromLetters 'b(c)y(x)d(efgh(i(j)))';
5038            
5039             is_deeply $a->print, <
5040             Key Value
5041             a
5042             b
5043             c
5044             y
5045             x
5046             d
5047             e
5048             f
5049             g
5050             h
5051             i
5052             j
5053             END
5054            
5055            
5056             is_deeply $a->xml, # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲
5057              
5058             '';
5059            
5060             is_deeply [$c, $x, $e, $f, $g, $j], [$a->leaves];
5061             is_deeply [$a, $b, $y, $d, $h, $i], [$a->parentsPreOrder];
5062             is_deeply [$b, $y, $i, $h, $d, $a], [$a->parentsPostOrder];
5063             is_deeply [$a->parents], [$a->parentsPostOrder];
5064            
5065             is_deeply [$a, $d, $h, $i, $y, $b], [$a->parentsReversePreOrder];
5066             is_deeply [$i, $h, $d, $y, $b, $a], [$a->parentsReversePostOrder];
5067            
5068             ok !$j->parents;
5069            
5070             ok $a->lastMost == $j;
5071             ok !$a->prevMost;
5072             ok $j->prevMost == $g;
5073             ok $i->prevMost == $g;
5074             ok $h->prevMost == $g;
5075             ok $g->prevMost == $f;
5076             ok $f->prevMost == $e;
5077             ok $e->prevMost == $x;
5078             ok $d->prevMost == $x;
5079             ok $x->prevMost == $c;
5080             ok $y->prevMost == $c;
5081             ok !$c->prevMost;
5082             ok !$b->prevMost;
5083             ok !$a->prevMost;
5084            
5085             ok $a->firstMost == $c;
5086             ok $a->nextMost == $c;
5087             ok $b->nextMost == $c;
5088             ok $c->nextMost == $x;
5089             ok $y->nextMost == $x;
5090             ok $x->nextMost == $e;
5091             ok $d->nextMost == $e;
5092             ok $e->nextMost == $f;
5093             ok $f->nextMost == $g;
5094             ok $g->nextMost == $j;
5095             ok $h->nextMost == $j;
5096             ok $i->nextMost == $j;
5097             ok !$j->nextMost;
5098            
5099             ok $i->topMost == $a;
5100            
5101              
5102             =head1 Data Structures
5103              
5104             Data structures use by this package.
5105              
5106              
5107             =head2 Tree::Ops Definition
5108              
5109              
5110             Child in the tree.
5111              
5112              
5113              
5114              
5115             =head3 Output fields
5116              
5117              
5118             =head4 children
5119              
5120             Children of this child.
5121              
5122             =head4 key
5123              
5124             Key for this child - any thing that can be compared with the L operator.
5125              
5126             =head4 lastChild
5127              
5128             Last active child chain - enables us to find the currently open scope from the start if the tree.
5129              
5130             =head4 parent
5131              
5132             Parent for this child.
5133              
5134             =head4 value
5135              
5136             Value for this child.
5137              
5138              
5139              
5140             =head1 Private Methods
5141              
5142             =head2 setParentOfChild($child, $parent)
5143              
5144             Set the parent of a child and return the child.
5145              
5146             Parameter Description
5147             1 $child Child
5148             2 $parent Parent
5149              
5150             =head2 indexOfChildInParent($child)
5151              
5152             Get the index of a child within the specified parent.
5153              
5154             Parameter Description
5155             1 $child Child
5156              
5157             =head2 parentsOrdered($tree, $preorder, $reverse)
5158              
5159             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.
5160              
5161             Parameter Description
5162             1 $tree Tree
5163             2 $preorder Pre-order if true else post-order
5164             3 $reverse Reversed if true
5165              
5166             =head2 printTree($tree, $print, $preorder, $reverse)
5167              
5168             String representation as a horizontal tree.
5169              
5170             Parameter Description
5171             1 $tree Tree
5172             2 $print Optional print method
5173             3 $preorder Pre-order
5174             4 $reverse Reverse
5175              
5176              
5177             =head1 Index
5178              
5179              
5180             1 L - Return the first child if it is above the second child else return B.
5181              
5182             2 L - Locate the active scope in a tree.
5183              
5184             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.
5185              
5186             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.
5187              
5188             5 L - Return the first child if it is below the second child else return B.
5189              
5190             6 L - Bracketed string representation of a tree.
5191              
5192             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.
5193              
5194             8 L - Close the current scope returning to the previous scope.
5195              
5196             9 L - Get the context of the current child.
5197              
5198             10 L - Cut out a child and all its content and children, return it ready for reinsertion else where.
5199              
5200             11 L - Duplicate a specified parent and all its descendants returning the root of the resulting tree.
5201              
5202             12 L - Return the specified parent if it has no children else B
5203              
5204             13 L - Get the first child under the specified parent.
5205              
5206             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.
5207              
5208             15 L - Create a tree from a string of letters returning the children created in alphabetic order - useful for testing.
5209              
5210             16 L - Return the child at the end of the path starting at the specified parent.
5211              
5212             17 L - Include the specified tree in the currently open scope.
5213              
5214             18 L - Get the index of a child within the specified parent.
5215              
5216             19 L - Return the specified child if that child is first under its parent, else return B.
5217              
5218             20 L - Return the specified child if that child is last under its parent, else return B.
5219              
5220             21 L - Return the specified parent if that parent is the top most parent in the tree.
5221              
5222             22 L - Get the last child under the specified parent.
5223              
5224             23 L - Return the last most descendant child in the tree starting at this parent or else return B if this parent has no children.
5225              
5226             24 L - The set of all children without further children, i.
5227              
5228             25 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.
5229              
5230             26 L - Unwrap the children of the specified parent with the whose L fields L that of their parent.
5231              
5232             27 L - Merge the following sibling of the specified child if that sibling exists and the L data of the two siblings L.
5233              
5234             28 L - Merge the preceding sibling of the specified child if that sibling exists and the L data of the two siblings L.
5235              
5236             29 L - Find the most recent common ancestor of the specified children.
5237              
5238             30 L - Create a new child optionally recording the specified key or value.
5239              
5240             31 L - Get the next sibling following the specified child.
5241              
5242             32 L - Return the next child with no children, i.
5243              
5244             33 L - Return a list of children visited between the specified child and the next child in post-order.
5245              
5246             34 L - Return a list of children visited between the specified child and the next child in pre-order.
5247              
5248             35 L - Add a child and make it the currently active scope into which new children will be added.
5249              
5250             36 L - The set of all parents in the tree, i.
5251              
5252             37 L - The set of all parents in the tree, i.
5253              
5254             38 L - The set of all parents in the tree, i.
5255              
5256             39 L - The set of all parents in the tree, i.
5257              
5258             40 L - The set of all parents in the tree, i.
5259              
5260             41 L - The set of all parents in the tree, i.
5261              
5262             42 L - Return the list of zero based child indexes for the path from the root of the tree containing the specified child to the specified child for use by the L method.
5263              
5264             43 L - Return the list of zero based child indexes for the path from the specified ancestor to the specified child for use by the L method else confess if the ancestor is not, in fact, an ancestor.
5265              
5266             44 L - Get the previous sibling of the specified child.
5267              
5268             45 L - Return the previous child with no children, i.
5269              
5270             46 L - Return a list of children visited between the specified child and the previous child in post-order.
5271              
5272             47 L - Return a list of children visited between the specified child and the previous child in pre-order.
5273              
5274             48 L - Print tree in normal pre-order.
5275              
5276             49 L - Print tree in normal post-order.
5277              
5278             50 L - Print tree in normal pre-order.
5279              
5280             51 L - Print tree in reverse post-order
5281              
5282             52 L - Print tree in reverse pre-order
5283              
5284             53 L - String representation as a horizontal tree.
5285              
5286             54 L - Place a new child first under the specified parent and return the child.
5287              
5288             55 L - Place a new child last under the specified parent and return the child.
5289              
5290             56 L - Place a new child after the specified child.
5291              
5292             57 L - Place a new child before the specified child.
5293              
5294             58 L - Select matching children in a tree in post-order.
5295              
5296             59 L - Set the parent of a child and return the child.
5297              
5298             60 L - Return a list of siblings after the specified child.
5299              
5300             61 L - Return a list of siblings before the specified child.
5301              
5302             62 L - Return a list of the siblings strictly between two children of the same parent else return B.
5303              
5304             63 L - Add one child in the current scope.
5305              
5306             64 L - Return the only child of this parent if the parent has an only child, else B
5307              
5308             65 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.
5309              
5310             66 L - Make the first child of the specified parent the parents previous sibling and return the parent.
5311              
5312             67 L - Make the previous sibling of the specified parent the parents first child and return the parent.
5313              
5314             68 L - Make the next sibling of the specified parent the parents last child and return the parent.
5315              
5316             69 L - Make the last child of the specified parent the parents next sibling and return the parent.
5317              
5318             70 L - Return the top most parent in the tree containing the specified child.
5319              
5320             71 L - Duplicate a specified parent and all its descendants recording the mapping in a temporary {transcribed} field in the tree being transcribed.
5321              
5322             72 L - Unwrap the specified child and return that child.
5323              
5324             73 L - Wrap the specified child with a new parent and return the new parent optionally setting its L and L.
5325              
5326             74 L - Wrap the children of the specified parent with a new intermediate parent that becomes the child of the specified parent, optionally setting the L and the L for the new parent.
5327              
5328             75 L - Print a tree as as xml.
5329              
5330             =head1 Installation
5331              
5332             This module is written in 100% Pure Perl and, thus, it is easy to read,
5333             comprehend, use, modify and install via B:
5334              
5335             sudo cpan install Tree::Ops
5336              
5337             =head1 Author
5338              
5339             L
5340              
5341             L
5342              
5343             =head1 Copyright
5344              
5345             Copyright (c) 2016-2019 Philip R Brenan.
5346              
5347             This module is free software. It may be used, redistributed and/or modified
5348             under the same terms as Perl itself.
5349              
5350             =cut
5351              
5352              
5353              
5354             # Tests and documentation
5355              
5356             sub test
5357 1     1 0 7 {my $p = __PACKAGE__;
5358 1         10 binmode($_, ":utf8") for *STDOUT, *STDERR;
5359 1 50       113 return if eval "eof(${p}::DATA)";
5360 1         59 my $s = eval "join('', <${p}::DATA>)";
5361 1 50       10 $@ and die $@;
5362 1     1   7 eval $s;
  1     1   3  
  1     1   35  
  1     1   5  
  1         2  
  1         26  
  1         5  
  1         2  
  1         7  
  1         730  
  1         64459  
  1         9  
  1         74  
5363 1 50       11 $@ and die $@;
5364 1         141 1
5365             }
5366              
5367             test unless caller;
5368              
5369             1;
5370             # podDocumentation
5371             __DATA__