File Coverage

blib/lib/Tree/DAG_Node.pm
Criterion Covered Total %
statement 348 785 44.3
branch 140 406 34.4
condition 27 128 21.0
subroutine 39 95 41.0
pod 67 67 100.0
total 621 1481 41.9


line stmt bran cond sub pod time code
1             package Tree::DAG_Node;
2              
3 5     5   88537 use strict;
  5         7  
  5         122  
4 5     5   13 use warnings;
  5         7  
  5         108  
5 5     5   13 use warnings qw(FATAL utf8); # Fatalize encoding glitches.
  5         7  
  5         251  
6              
7             our $Debug = 0;
8             our $VERSION = '1.29';
9              
10 5     5   1586 use File::Slurp::Tiny 'read_lines';
  5         38660  
  5         32025  
11              
12             # -----------------------------------------------
13              
14             sub add_daughter { # alias
15 41     41 1 85 my($it,@them) = @_; $it->add_daughters(@them);
  41         45  
16             }
17              
18             # -----------------------------------------------
19              
20             sub add_daughters { # write-only method
21 70     70 1 54 my($mother, @daughters) = @_;
22 70 50       89 return unless @daughters; # no-op
23             return
24             $mother->_add_daughters_wrapper(
25 74     74   42 sub { push @{$_[0]}, $_[1]; },
  74         134  
26             @daughters
27 70         161 );
28             }
29              
30             # -----------------------------------------------
31              
32             sub add_daughter_left { # alias
33 0     0 1 0 my($it,@them) = @_; $it->add_daughters_left(@them);
  0         0  
34             }
35              
36             # -----------------------------------------------
37              
38             sub add_daughters_left { # write-only method
39 0     0 1 0 my($mother, @daughters) = @_;
40 0 0       0 return unless @daughters;
41             return
42             $mother->_add_daughters_wrapper(
43 0     0   0 sub { unshift @{$_[0]}, $_[1]; },
  0         0  
44             @daughters
45 0         0 );
46             }
47              
48             # -----------------------------------------------
49              
50             sub _add_daughters_wrapper {
51 70     70   75 my($mother, $callback, @daughters) = @_;
52 70 50       85 return unless @daughters;
53              
54 70         49 my %ancestors;
55 70         80 @ancestors{ $mother->ancestors } = undef;
56             # This could be made more efficient by not bothering to compile
57             # the ancestor list for $mother if all the nodes to add are
58             # daughterless.
59             # But then you have to CHECK if they're daughterless.
60             # If $mother is [big number] generations down, then it's worth checking.
61              
62 70         67 foreach my $daughter (@daughters) { # which may be ()
63 74 50       141 die "daughter must be a node object!" unless UNIVERSAL::can($daughter, 'is_node');
64              
65 74 50       94 printf "Mother : %s (%s)\n", $mother, ref $mother if $Debug;
66 74 50       97 printf "Daughter: %s (%s)\n", $daughter, ref $daughter if $Debug;
67 74 50 0     85 printf "Adding %s to %s\n",
      0        
68             ($daughter->name() || $daughter),
69             ($mother->name() || $mother) if $Debug > 1;
70              
71 74 50       115 die 'Mother (' . $mother -> name . ") can't be its own daughter\n" if $mother eq $daughter;
72              
73             die "$daughter (" . ($daughter->name || 'no_name') .
74             ") is an ancestor of $mother (" . ($mother->name || 'no_name') .
75 74 50 0     98 "), so can't became its daughter\n" if exists $ancestors{$daughter};
      0        
76              
77 74         49 my $old_mother = $daughter->{'mother'};
78              
79 74 50 66     138 next if defined($old_mother) && ref($old_mother) && $old_mother eq $mother;
      66        
80             # noop if $daughter is already $mother's daughter
81              
82 74 100 66     115 $old_mother->remove_daughters($daughter)
83             if defined($old_mother) && ref($old_mother);
84              
85 74         55 &{$callback}($mother->{'daughters'}, $daughter);
  74         81  
86             }
87 70         77 $mother->_update_daughter_links; # need only do this at the end
88              
89 70         118 return;
90             }
91              
92             # -----------------------------------------------
93              
94             sub add_left_sister { # alias
95 0     0 1 0 my($it,@them) = @_; $it->add_left_sisters(@them);
  0         0  
96             }
97              
98             # -----------------------------------------------
99              
100             sub add_left_sisters { # write-only method
101 0     0 1 0 my($this, @new) = @_;
102 0 0       0 return() unless @new;
103              
104 0         0 @new = $this->replace_with(@new, $this);
105 0         0 shift @new; pop @new; # kill the copies of $this
  0         0  
106 0         0 return @new;
107             }
108              
109             # -----------------------------------------------
110              
111             sub add_right_sister { # alias
112 0     0 1 0 my($it,@them) = @_; $it->add_right_sisters(@them);
  0         0  
113             }
114              
115             # -----------------------------------------------
116              
117             sub add_right_sisters { # write-only method
118 0     0 1 0 my($this, @new) = @_;
119 0 0       0 return() unless @new;
120 0         0 @new = $this->replace_with($this, @new);
121 0         0 shift @new; shift @new; # kill the copies of $this
  0         0  
122 0         0 return @new;
123             }
124              
125             # -----------------------------------------------
126              
127             sub address {
128 0     0 1 0 my($it, $address) = @_[0,1];
129 0 0 0     0 if(defined($address) && length($address)) { # given the address, return the node.
130             # invalid addresses return undef
131 0         0 my $root = $it->root;
132 0         0 my @parts = map {$_ + 0}
  0         0  
133             $address =~ m/(\d+)/g; # generous!
134 0 0       0 die "Address \"$address\" is an ill-formed address" unless @parts;
135 0 0       0 die "Address \"$address\" must start with '0'" unless shift(@parts) == 0;
136              
137 0         0 my $current_node = $root;
138 0         0 while(@parts) { # no-op for root
139 0         0 my $ord = shift @parts;
140 0         0 my @daughters = @{$current_node->{'daughters'}};
  0         0  
141              
142 0 0       0 if($#daughters < $ord) { # illegal address
143 0 0       0 print "* $address has an out-of-range index ($ord)!" if $Debug;
144 0         0 return undef;
145             }
146 0         0 $current_node = $daughters[$ord];
147 0 0       0 unless(ref($current_node)) {
148 0 0       0 print "* $address points to or thru a non-node!" if $Debug;
149 0         0 return undef;
150             }
151             }
152 0         0 return $current_node;
153              
154             } else { # given the node, return the address
155 0         0 my @parts = ();
156 0         0 my $current_node = $it;
157 0         0 my $mother;
158              
159 0   0     0 while(defined( $mother = $current_node->{'mother'} ) && ref($mother)) {
160 0         0 unshift @parts, $current_node->my_daughter_index;
161 0         0 $current_node = $mother;
162             }
163 0         0 return join(':', 0, @parts);
164             }
165             }
166              
167             # -----------------------------------------------
168              
169             sub ancestors {
170 138     138 1 101 my $this = shift;
171 138         99 my $mama = $this->{'mother'}; # initial condition
172 138 100       199 return () unless ref($mama); # I must be root!
173              
174             # Could be defined recursively, as:
175             # if(ref($mama = $this->{'mother'})){
176             # return($mama, $mama->ancestors);
177             # } else {
178             # return ();
179             # }
180             # But I didn't think of that until I coded the stuff below, which is
181             # faster.
182              
183 91         87 my @ancestors = ( $mama ); # start off with my mama
184 91   66     232 while(defined( $mama = $mama->{'mother'} ) && ref($mama)) {
185             # Walk up the tree
186 118         257 push(@ancestors, $mama);
187             # This turns into an infinite loop if someone gets stupid
188             # and makes this tree cyclic! Don't do it!
189             }
190 91         167 return @ancestors;
191             }
192              
193             # -----------------------------------------------
194              
195             sub attribute { # alias
196 0     0 1 0 my($it,@them) = @_; $it->attributes(@them);
  0         0  
197             }
198              
199             # -----------------------------------------------
200              
201             sub attributes { # read/write attribute-method
202             # expects a ref, presumably a hashref
203 190     190 1 234 my $this = shift;
204 190 100       234 if(@_) {
205 52 50       67 die "my parameter must be a reference" unless ref($_[0]);
206 52         44 $this->{'attributes'} = $_[0];
207             }
208 190         210 return $this->{'attributes'};
209             }
210              
211             # -----------------------------------------------
212              
213             sub clear_daughters { # write-only method
214 22     22 1 15 my($mother) = $_[0];
215 22         16 my @daughters = @{$mother->{'daughters'}};
  22         23  
216              
217 22         17 @{$mother->{'daughters'}} = ();
  22         17  
218 22         21 foreach my $one (@daughters) {
219 7 50       17 next unless UNIVERSAL::can($one, 'is_node'); # sanity check
220 7         7 $one->{'mother'} = undef;
221             }
222             # Another, simpler, way to do it:
223             # $mother->remove_daughters($mother->daughters);
224              
225 22         17 return @daughters; # NEW
226             }
227              
228             # -----------------------------------------------
229              
230             sub common { # Return the lowest node common to all these nodes...
231             # Called as $it->common($other) or $it->common(@others)
232 0     0 1 0 my @ones = @_; # all nodes I was given
233 0         0 my($first, @others) = @_;
234              
235 0 0       0 return $first unless @others; # degenerate case
236              
237 0         0 my %ones;
238 0         0 @ones{ @ones } = undef;
239              
240 0         0 foreach my $node (@others) {
241 0 0       0 die "TILT: node \"$node\" is not a node"
242             unless UNIVERSAL::can($node, 'is_node');
243 0         0 my %first_lineage;
244 0         0 @first_lineage{$first, $first->ancestors} = undef;
245 0         0 my $higher = undef; # the common of $first and $node
246 0         0 my @my_lineage = $node->ancestors;
247              
248             Find_Common:
249 0         0 while(@my_lineage) {
250 0 0       0 if(exists $first_lineage{$my_lineage[0]}) {
251 0         0 $higher = $my_lineage[0];
252 0         0 last Find_Common;
253             }
254 0         0 shift @my_lineage;
255             }
256 0 0       0 return undef unless $higher;
257 0         0 $first = $higher;
258             }
259 0         0 return $first;
260             }
261              
262             # -----------------------------------------------
263              
264             sub common_ancestor {
265 0     0 1 0 my @ones = @_; # all nodes I was given
266 0         0 my($first, @others) = @_;
267              
268 0 0       0 return $first->{'mother'} unless @others;
269             # which may be undef if $first is the root!
270              
271 0         0 my %ones;
272 0         0 @ones{ @ones } = undef; # my arguments
273              
274 0         0 my $common = $first->common(@others);
275 0 0       0 if(exists($ones{$common})) { # if the common is one of my nodes...
276 0         0 return $common->{'mother'};
277             # and this might be undef, if $common is root!
278             } else {
279 0         0 return $common;
280             # which might be null if that's all common came up with
281             }
282             }
283              
284             # -----------------------------------------------
285              
286             sub copy
287             {
288 24     24 1 24 my($from, $o) = @_[0,1];
289 24 50       27 $o = {} unless ref $o;
290              
291             # Straight dup, and bless into same class.
292              
293 24         64 my $to = bless { %$from }, ref($from);
294              
295             # Null out linkages.
296              
297 24         28 $to -> _init_mother;
298 24         24 $to -> _init_daughters;
299              
300             # Dup the 'attributes' attribute.
301              
302 24 50       28 if ($$o{'no_attribute_copy'})
303             {
304 24         21 $$to{attributes} = {};
305             }
306             else
307             {
308 0         0 my $attrib_copy = ref($to->{'attributes'});
309              
310 0 0       0 if ($attrib_copy)
311             {
312 0 0       0 if ($attrib_copy eq 'HASH')
    0          
313             {
314             # Dup the hashref.
315              
316 0         0 $$to{'attributes'} = { %{$$to{'attributes'}} };
  0         0  
317             }
318             elsif ($attrib_copy = UNIVERSAL::can($to->{'attributes'}, 'copy') )
319             {
320             # $attrib_copy now points to the copier method.
321              
322 0         0 $$to{'attributes'} = &{$attrib_copy}($from);
  0         0  
323              
324             } # Otherwise I don't know how to copy it; leave as is.
325             }
326             }
327              
328 24         35 $$o{'from_to'}{$from} = $to; # SECRET VOODOO
329              
330             # ...autovivifies an anon hashref for 'from_to' if need be
331             # This is here in case I later want/need a table corresponding
332             # old nodes to new.
333              
334 24         23 return $to;
335             }
336              
337             # -----------------------------------------------
338              
339             sub copy_at_and_under {
340 24     24 1 46 my($from, $o) = @_[0,1];
341 24 50       33 $o = {} unless ref $o;
342 24         14 my @daughters = map($_->copy_at_and_under($o), @{$from->{'daughters'}});
  24         33  
343 24         30 my $to = $from->copy($o);
344 24 100       43 $to->set_daughters(@daughters) if @daughters;
345 24         51 return $to;
346             }
347              
348             # -----------------------------------------------
349              
350             sub copy_tree {
351 0     0 1 0 my($this, $o) = @_[0,1];
352 0         0 my $root = $this->root;
353 0 0       0 $o = {} unless ref $o;
354              
355 0         0 my $new_root = $root->copy_at_and_under($o);
356              
357 0         0 return $new_root;
358             }
359              
360             # -----------------------------------------------
361              
362             sub daughters { # read-only attrib-method: returns a list.
363 25     25 1 316 my $this = shift;
364              
365 25 50       37 if(@_) { # undoc'd and disfavored to use as a write-method
366 0         0 die "Don't set daughters with daughters anymore\n";
367 0 0       0 warn "my parameter must be a listref" unless ref($_[0]);
368 0         0 $this->{'daughters'} = $_[0];
369 0         0 $this->_update_daughter_links;
370             }
371             #return $this->{'daughters'};
372 25 50       16 return @{$this->{'daughters'} || []};
  25         62  
373             }
374              
375             # ------------------------------------------------
376              
377             sub decode_lol
378             {
379 0     0 1 0 my($self, $result) = @_;
380 0         0 my(@worklist) = $result;
381              
382 0         0 my($obj);
383             my($ref_type);
384 0         0 my(@stack);
385              
386             do
387 0         0 {
388 0         0 $obj = shift @worklist;
389 0         0 $ref_type = ref $obj;
390              
391 0 0       0 if ($ref_type eq 'ARRAY')
    0          
    0          
392             {
393 0         0 unshift @worklist, @$obj;
394             }
395             elsif ($ref_type eq 'HASH')
396             {
397 0         0 push @stack, {%$obj};
398             }
399             elsif ($ref_type)
400             {
401 0         0 die "Unsupported object type $ref_type\n";
402             }
403             else
404             {
405 0         0 push @stack, $obj;
406             }
407              
408             } while (@worklist);
409              
410 0         0 return [@stack];
411              
412             } # End of decode_lol.
413              
414             # -----------------------------------------------
415              
416             sub delete_tree {
417 0     0 1 0 my $it = $_[0];
418             $it->root->walk_down({ # has to be callbackback, not callback
419             'callbackback' => sub {
420 0     0   0 %{$_[0]} = ();
  0         0  
421 0         0 bless($_[0], 'DEADNODE'); # cause become dead! cause become dead!
422 0         0 return 1;
423             }
424 0         0 });
425 0         0 return;
426             # Why DEADNODE? Because of the nice error message:
427             # "Can't locate object method "leaves_under" via package "DEADNODE"."
428             # Moreover, DEADNODE doesn't provide is_node, so fails my can() tests.
429             }
430              
431 0     0   0 sub DEADNODE::delete_tree { return; }
432             # in case you kill it AGAIN!!!!! AND AGAIN AND AGAIN!!!!!! OO-HAHAHAHA!
433              
434             # -----------------------------------------------
435              
436             sub depth_under {
437 0     0 1 0 my $node = shift;
438 0         0 my $max_depth = 0;
439             $node->walk_down({
440             '_depth' => 0,
441             'callback' => sub {
442 0     0   0 my $depth = $_[1]->{'_depth'};
443 0 0       0 $max_depth = $depth if $depth > $max_depth;
444 0         0 return 1;
445             },
446 0         0 });
447 0         0 return $max_depth;
448             }
449              
450             # -----------------------------------------------
451              
452             sub descendants {
453             # read-only method: return a list of my descendants
454 0     0 1 0 my $node = shift;
455 0         0 my @list = $node->self_and_descendants;
456 0         0 shift @list; # lose myself.
457 0         0 return @list;
458             }
459              
460             # -----------------------------------------------
461              
462             sub draw_ascii_tree {
463             # Make a "box" for this node and its possible daughters, recursively.
464              
465             # The guts of this routine are horrific AND recursive!
466              
467             # Feel free to send me better code. I worked on this until it
468             # gave me a headache and it worked passably, and then I stopped.
469              
470 46     46 1 569 my $it = $_[0];
471 46 100       53 my $o = ref($_[1]) ? $_[1] : {};
472 46         28 my(@box, @daughter_boxes, $width, @daughters);
473 46         25 @daughters = @{$it->{'daughters'}};
  46         58  
474              
475 46 100       58 $o->{'no_name'} = 0 unless exists $o->{'no_name'};
476 46 100       52 $o->{'h_spacing'} = 1 unless exists $o->{'h_spacing'};
477 46 100       51 $o->{'h_compact'} = 1 unless exists $o->{'h_compact'};
478 46 100       50 $o->{'v_compact'} = 1 unless exists $o->{'v_compact'};
479              
480 46         31 my $printable_name;
481 46 50       42 if($o->{'no_name'}) {
482 0         0 $printable_name = '*';
483             } else {
484 46 50       47 $printable_name = defined $it->name ? $it->name : $it;
485 46         44 $printable_name =~ tr<\cm\cj\t >< >s;
486 46         42 $printable_name = "<$printable_name>";
487             }
488              
489 46 100       48 if(!scalar(@daughters)) { # I am a leaf!
490             # Now add the top parts, and return.
491 16         18 @box = ("|", $printable_name);
492             } else {
493 30         20 @daughter_boxes = map { &draw_ascii_tree($_, $o) } @daughters;
  44         89  
494              
495 30         24 my $max_height = 0;
496 30         24 foreach my $box (@daughter_boxes) {
497 44         33 my $h = @$box;
498 44 100       55 $max_height = $h if $h > $max_height;
499             }
500              
501 30         37 @box = ('') x $max_height; # establish the list
502              
503 30         26 foreach my $one (@daughter_boxes) {
504 44         35 my $length = length($one->[0]);
505 44         29 my $height = @$one;
506              
507             #now make all the same height.
508 44         26 my $deficit = $max_height - $height;
509 44 100       57 if($deficit > 0) {
510 13         23 push @$one, ( scalar( ' ' x $length ) ) x $deficit;
511 13         13 $height = scalar(@$one);
512             }
513              
514              
515             # Now tack 'em onto @box
516             ##########################################################
517             # This used to be a sub of its own. Ho-hum.
518              
519 44         41 my($b1, $b2) = (\@box, $one);
520 44         37 my($h1, $h2) = (scalar(@$b1), scalar(@$b2));
521              
522 44         25 my(@diffs, $to_chop);
523 44 50       55 if($o->{'h_compact'}) { # Try for h-scrunching.
524 44         25 my @diffs;
525 44         29 my $min_diff = length($b1->[0]); # just for starters
526 44         49 foreach my $line (0 .. ($h1 - 1)) {
527 263         149 my $size_l = 0; # length of terminal whitespace
528 263         155 my $size_r = 0; # length of initial whitespace
529 263 100       441 $size_l = length($1) if $b1->[$line] =~ /( +)$/s;
530 263 100       428 $size_r = length($1) if $b2->[$line] =~ /^( +)/s;
531 263         156 my $sum = $size_l + $size_r;
532              
533 263 100       274 $min_diff = $sum if $sum < $min_diff;
534 263         305 push @diffs, [$sum, $size_l, $size_r];
535             }
536 44         31 $to_chop = $min_diff - $o->{'h_spacing'};
537 44 100       87 $to_chop = 0 if $to_chop < 0;
538             }
539              
540 44 100 66     118 if(not( $o->{'h_compact'} and $to_chop )) {
541             # No H-scrunching needed/possible
542 43         45 foreach my $line (0 .. ($h1 - 1)) {
543 250         261 $b1->[ $line ] .= $b2->[ $line ] . (' ' x $o->{'h_spacing'});
544             }
545             } else {
546             # H-scrunching is called for.
547 1         3 foreach my $line (0 .. ($h1 - 1)) {
548 13         8 my $r = $b2->[$line]; # will be the new line
549 13         11 my $remaining = $to_chop;
550 13 50       14 if($remaining) {
551 13         9 my($l_chop, $r_chop) = @{$diffs[$line]}[1,2];
  13         11  
552              
553 13 50       17 if($l_chop) {
554 0 0       0 if($l_chop > $remaining) {
    0          
555 0         0 $l_chop = $remaining;
556 0         0 $remaining = 0;
557             } elsif($l_chop == $remaining) {
558 0         0 $remaining = 0;
559             } else { # remaining > l_chop
560 0         0 $remaining -= $l_chop;
561             }
562             }
563 13 50       16 if($r_chop) {
564 0 0       0 if($r_chop > $remaining) {
    0          
565 0         0 $r_chop = $remaining;
566 0         0 $remaining = 0;
567             } elsif($r_chop == $remaining) {
568 0         0 $remaining = 0;
569             } else { # remaining > r_chop
570 0         0 $remaining -= $r_chop; # should never happen!
571             }
572             }
573              
574 13 50       14 substr($b1->[$line], -$l_chop) = '' if $l_chop;
575 13 50       16 substr($r, 0, $r_chop) = '' if $r_chop;
576             } # else no-op
577 13         16 $b1->[ $line ] .= $r . (' ' x $o->{'h_spacing'});
578             }
579             # End of H-scrunching ickyness
580             }
581             # End of ye big tack-on
582              
583             }
584             # End of the foreach daughter_box loop
585              
586             # remove any fencepost h_spacing
587 30 50       37 if($o->{'h_spacing'}) {
588 30         27 foreach my $line (@box) {
589 127 50       171 substr($line, -$o->{'h_spacing'}) = '' if length($line);
590             }
591             }
592              
593             # end of catenation
594 30 50       38 die "SPORK ERROR 958203: Freak!!!!!" unless @box;
595              
596             # Now tweak the pipes
597 30         25 my $new_pipes = $box[0];
598 30         24 my $pipe_count = $new_pipes =~ tr<|><+>;
599 30 100       32 if($pipe_count < 2) {
600 26         19 $new_pipes = "|";
601             } else {
602 4         3 my($init_space, $end_space);
603              
604             # Thanks to Gilles Lamiral for pointing out the need to set to '',
605             # to avoid -w warnings about undeffiness.
606              
607 4 50       13 if( $new_pipes =~ s<^( +)><>s ) {
608 4         5 $init_space = $1;
609             } else {
610 0         0 $init_space = '';
611             }
612              
613 4 50       12 if( $new_pipes =~ s<( +)$><>s ) {
614 4         4 $end_space = $1
615             } else {
616 0         0 $end_space = '';
617             }
618              
619 4         4 $new_pipes =~ tr< ><->;
620 4         4 substr($new_pipes,0,1) = "/";
621 4         3 substr($new_pipes,-1,1) = "\\";
622              
623 4         6 $new_pipes = $init_space . $new_pipes . $end_space;
624             # substr($new_pipes, int((length($new_pipes)), 1)) / 2) = "^"; # feh
625             }
626              
627             # Now tack on the formatting for this node.
628 30 50 66     88 if($o->{'v_compact'} == 2) {
    100          
629 0 0       0 if(@daughters == 1) {
630 0         0 unshift @box, "|", $printable_name;
631             } else {
632 0         0 unshift @box, "|", $printable_name, $new_pipes;
633             }
634             } elsif ($o->{'v_compact'} == 1 and @daughters == 1) {
635 26         40 unshift @box, "|", $printable_name;
636             } else { # general case
637 4         8 unshift @box, "|", $printable_name, $new_pipes;
638             }
639             }
640              
641             # Flush the edges:
642 46         37 my $max_width = 0;
643 46         37 foreach my $line (@box) {
644 223         121 my $w = length($line);
645 223 100       270 $max_width = $w if $w > $max_width;
646             }
647 46         35 foreach my $one (@box) {
648 223         126 my $space_to_add = $max_width - length($one);
649 223 100       254 next unless $space_to_add;
650 50         40 my $add_left = int($space_to_add / 2);
651 50         37 my $add_right = $space_to_add - $add_left;
652 50         66 $one = (' ' x $add_left) . $one . (' ' x $add_right);
653             }
654              
655 46         99 return \@box; # must not return a null list!
656             }
657              
658             # -----------------------------------------------
659              
660             sub dump_names {
661 0     0 1 0 my($it, $o) = @_[0,1];
662 0 0       0 $o = {} unless ref $o;
663 0         0 my @out = ();
664 0   0     0 $o->{'_depth'} ||= 0;
665 0   0     0 $o->{'indent'} ||= ' ';
666 0   0     0 $o->{'tick'} ||= '';
667              
668             $o->{'callback'} = sub {
669 0     0   0 my($this, $o) = @_[0,1];
670             push(@out,
671             join('',
672             $o->{'indent'} x $o->{'_depth'},
673 0 0       0 $o->{'tick'},
674             defined $this->name ? $this->name : $this,
675             "\n"
676             )
677             );
678 0         0 return 1;
679             }
680 0         0 ;
681 0         0 $it->walk_down($o);
682 0         0 return @out;
683             }
684              
685             # -----------------------------------------------
686              
687             sub format_node
688             {
689 68     68 1 50 my($self, $options, $node) = @_;
690 68         72 my($s) = $node -> name;
691 68 50       123 $s .= '. Attributes: ' . $self -> hashref2string($node -> attributes) if (! $$options{no_attributes});
692              
693 68         138 return $s;
694              
695             } # End of format_node.
696              
697             # -----------------------------------------------
698              
699             sub generation {
700 0     0 1 0 my($node, $limit) = @_[0,1];
701             return $node
702             if $node eq $limit || not(
703             defined($node->{'mother'}) &&
704 0 0 0     0 ref($node->{'mother'})
      0        
705             ); # bailout
706              
707 0         0 return map(@{$_->{'daughters'}}, $node->{'mother'}->generation($limit));
  0         0  
708             # recurse!
709             # Yup, my generation is just all the daughters of my mom's generation.
710             }
711              
712             # -----------------------------------------------
713              
714             sub generation_under {
715 0     0 1 0 my($node, @rest) = @_;
716 0         0 return $node->generation(@rest);
717             }
718              
719             # -----------------------------------------------
720              
721             sub hashref2string
722             {
723 68     68 1 50 my($self, $hashref) = @_;
724 68   50     84 $hashref ||= {};
725              
726 68         131 return '{' . join(', ', map{qq|$_ => "$$hashref{$_}"|} sort keys %$hashref) . '}';
  57         158  
727              
728             } # End of hashref2string.
729              
730             # -----------------------------------------------
731              
732             sub _init { # method
733 47     47   30 my $this = shift;
734 47 50       77 my $o = ref($_[0]) eq 'HASH' ? $_[0] : {};
735              
736             # Sane initialization.
737 47         49 $this->_init_mother($o);
738 47         53 $this->_init_daughters($o);
739 47         42 $this->_init_name($o);
740 47         48 $this->_init_attributes($o);
741              
742 47         37 return;
743             }
744              
745             # -----------------------------------------------
746              
747             sub _init_attributes { # to be called by an _init
748 47     47   41 my($this, $o) = @_[0,1];
749              
750 47         51 $this->{'attributes'} = {};
751              
752             # Undocumented and disfavored. Consider this just an example.
753 47 100       81 $this->attributes( $o->{'attributes'} ) if exists $o->{'attributes'};
754             }
755              
756             # -----------------------------------------------
757              
758             sub _init_daughters { # to be called by an _init
759 71     71   66 my($this, $o) = @_[0,1];
760              
761 71         62 $this->{'daughters'} = [];
762              
763             # Undocumented and disfavored. Consider this just an example.
764 0         0 $this->set_daughters( @{$o->{'daughters'}} )
765 71 50 33     122 if ref($o->{'daughters'}) && (@{$o->{'daughters'}});
  0         0  
766             # DO NOT use this option (as implemented) with new_daughter or
767             # new_daughter_left!!!!!
768             # BAD THINGS MAY HAPPEN!!!
769             }
770              
771             # -----------------------------------------------
772              
773             sub _init_mother { # to be called by an _init
774 71     71   75 my($this, $o) = @_[0,1];
775              
776 71         85 $this->{'mother'} = undef;
777              
778             # Undocumented and disfavored. Consider this just an example.
779             ( $o->{'mother'} )->add_daughter($this)
780 71 50 33     134 if defined($o->{'mother'}) && ref($o->{'mother'});
781             # DO NOT use this option (as implemented) with new_daughter or
782             # new_daughter_left!!!!!
783             # BAD THINGS MAY HAPPEN!!!
784             }
785              
786             # -----------------------------------------------
787              
788             sub _init_name { # to be called by an _init
789 47     47   45 my($this, $o) = @_[0,1];
790              
791 47         33 $this->{'name'} = undef;
792              
793             # Undocumented and disfavored. Consider this just an example.
794 47 100       87 $this->name( $o->{'name'} ) if exists $o->{'name'};
795             }
796              
797             # -----------------------------------------------
798              
799             sub is_daughter_of {
800 0     0 1 0 my($it,$mama) = @_[0,1];
801 0         0 return $it->{'mother'} eq $mama;
802             }
803              
804             # -----------------------------------------------
805              
806 0     0 1 0 sub is_node { return 1; } # always true.
807             # NEVER override this with anything that returns false in the belief
808             # that this'd signal "not a node class". The existence of this method
809             # is what I test for, with the various "can()" uses in this class.
810              
811             # -----------------------------------------------
812              
813             sub is_root
814             {
815 0     0 1 0 my($self) = @_;
816              
817 0 0       0 return defined $self -> mother ? 0 : 1;
818              
819             } # End of is_root.
820              
821             # -----------------------------------------------
822              
823             sub leaves_under {
824             # read-only method: return a list of all leaves under myself.
825             # Returns myself in the degenerate case of being a leaf myself.
826 0     0 1 0 my $node = shift;
827 0         0 my @List = ();
828             $node->walk_down({ 'callback' =>
829             sub {
830 0     0   0 my $node = $_[0];
831 0         0 my @daughters = @{$node->{'daughters'}};
  0         0  
832 0 0       0 push(@List, $node) unless @daughters;
833 0         0 return 1;
834             }
835 0         0 });
836 0 0       0 die "Spork Error 861: \@List has no contents!?!?" unless @List;
837             # impossible
838 0         0 return @List;
839             }
840              
841             # -----------------------------------------------
842              
843             sub left_sister {
844 0     0 1 0 my $it = $_[0];
845 0         0 my $mother = $it->{'mother'};
846 0 0       0 return undef unless $mother;
847 0         0 my @sisters = @{$mother->{'daughters'}};
  0         0  
848              
849 0 0       0 return undef if @sisters == 1; # I'm an only daughter
850              
851 0         0 my $left = undef;
852 0         0 foreach my $one (@sisters) {
853 0 0       0 return $left if $one eq $it;
854 0         0 $left = $one;
855             }
856 0         0 die "SPORK ERROR 9757: I'm not in my mother's daughter list!?!?";
857             }
858              
859             # -----------------------------------------------
860              
861             sub left_sisters {
862 0     0 1 0 my $it = $_[0];
863 0         0 my $mother = $it->{'mother'};
864 0 0       0 return() unless $mother;
865 0         0 my @sisters = @{$mother->{'daughters'}};
  0         0  
866 0 0       0 return() if @sisters == 1; # I'm an only daughter
867              
868 0         0 my @out = ();
869 0         0 foreach my $one (@sisters) {
870 0 0       0 return @out if $one eq $it;
871 0         0 push @out, $one;
872             }
873 0         0 die "SPORK ERROR 9767: I'm not in my mother's daughter list!?!?";
874             }
875              
876             # -----------------------------------------------
877              
878             sub lol_to_tree {
879 0     0 1 0 my($class, $lol, $seen_r) = @_[0,1,2];
880 0 0       0 $seen_r = {} unless ref($seen_r) eq 'HASH';
881 0 0 0     0 return if ref($lol) && $seen_r->{$lol}++; # catch circularity
882              
883 0   0     0 $class = ref($class) || $class;
884 0         0 my $node = $class->new();
885              
886 0 0       0 unless(ref($lol) eq 'ARRAY') { # It's a terminal node.
887 0 0       0 $node->name($lol) if defined $lol;
888 0         0 return $node;
889             }
890 0 0       0 return $node unless @$lol; # It's a terminal node, oddly represented
891              
892             # It's a non-terminal node.
893              
894 0         0 my @options = @$lol;
895 0 0       0 unless(ref($options[-1]) eq 'ARRAY') {
896             # This is what separates this method from simple_lol_to_tree
897 0         0 $node->name(pop(@options));
898             }
899              
900 0         0 foreach my $d (@options) { # Scan daughters (whether scalars or listrefs)
901 0         0 $node->add_daughter( $class->lol_to_tree($d, $seen_r) ); # recurse!
902             }
903              
904 0         0 return $node;
905             }
906              
907             # -----------------------------------------------
908              
909             sub mother { # read-only attrib-method: returns an object (the mother node)
910 68     68 1 41 my $this = shift;
911 68 50       86 die "I'm a read-only method!" if @_;
912 68         115 return $this->{'mother'};
913             }
914              
915             # -----------------------------------------------
916              
917             sub my_daughter_index {
918             # returns what number is my index in my mother's daughter list
919             # special case: 0 for root.
920 68     68 1 49 my $node = $_[0];
921 68         42 my $ord = -1;
922 68         47 my $mother = $node->{'mother'};
923              
924 68 100       88 return 0 unless $mother;
925 65         42 my @sisters = @{$mother->{'daughters'}};
  65         69  
926              
927 65 50       78 die "SPORK ERROR 6512: My mother has no kids!!!" unless @sisters;
928              
929             Find_Self:
930 65         100 for(my $i = 0; $i < @sisters; $i++) {
931 134 100       243 if($sisters[$i] eq $node) {
932 65         39 $ord = $i;
933 65         76 last Find_Self;
934             }
935             }
936 65 50       80 die "SPORK ERROR 2837: I'm not a daughter of my mother?!?!" if $ord == -1;
937 65         103 return $ord;
938             }
939              
940             # -----------------------------------------------
941              
942             sub name { # read/write attribute-method. returns/expects a scalar
943 371     371 1 368 my $this = shift;
944 371 100       429 $this->{'name'} = $_[0] if @_;
945 371         417 return $this->{'name'};
946             }
947              
948             # -----------------------------------------------
949              
950             sub new { # constructor
951 47     47 1 143 my $class = shift;
952 47 50       67 $class = ref($class) if ref($class); # tchristic style. why not?
953              
954 47 100       66 my $o = ref($_[0]) eq 'HASH' ? $_[0] : {}; # o for options hashref
955 47         43 my $it = bless( {}, $class );
956 47 50       62 print "Constructing $it in class $class\n" if $Debug;
957 47         58 $it->_init( $o );
958 47         56 return $it;
959             }
960              
961             # -----------------------------------------------
962              
963             sub new_daughter {
964 0     0 1 0 my($mother, @options) = @_;
965 0         0 my $daughter = $mother->new(@options);
966              
967 0         0 push @{$mother->{'daughters'}}, $daughter;
  0         0  
968 0         0 $daughter->{'mother'} = $mother;
969              
970 0         0 return $daughter;
971             }
972              
973             # -----------------------------------------------
974              
975             sub new_daughter_left {
976 0     0 1 0 my($mother, @options) = @_;
977 0         0 my $daughter = $mother->new(@options);
978              
979 0         0 unshift @{$mother->{'daughters'}}, $daughter;
  0         0  
980 0         0 $daughter->{'mother'} = $mother;
981              
982 0         0 return $daughter;
983             }
984              
985             # -----------------------------------------------
986              
987             sub node2string
988             {
989 68     68 1 49 my($self, $options, $node, $vert_dashes) = @_;
990 68   100     75 my($depth) = scalar($node -> ancestors) || 0;
991 68 100       91 my($sibling_count) = defined $node -> mother ? scalar $node -> self_and_sisters : 1;
992 68         62 my($offset) = ' ' x 5;
993 68 50       87 my(@indent) = map{$$vert_dashes[$_] || $offset} 0 .. $depth - 1;
  161         268  
994 68 100       143 @$vert_dashes =
995             (
996             @indent,
997             ($sibling_count == 1 ? $offset : ' |'),
998             );
999              
1000 68 100       100 if ($sibling_count == ($node -> my_daughter_index + 1) )
1001             {
1002 43         39 $$vert_dashes[$depth] = $offset;
1003             }
1004              
1005 68 100       170 return join('' => @indent[1 .. $#indent]) . ($depth ? ' |--- ' : '') . $self -> format_node($options, $node);
1006              
1007             } # End of node2string.
1008              
1009             # -----------------------------------------------
1010              
1011             sub quote_name
1012             {
1013 0     0 1 0 my($self, $name) = @_;
1014              
1015 0         0 return "'$name'";
1016              
1017             } # End of quote_name.
1018              
1019             # -----------------------------------------------
1020              
1021             sub random_network { # constructor or method.
1022 0     0 1 0 my $class = $_[0];
1023 0 0       0 my $o = ref($_[1]) ? $_[1] : {};
1024 0         0 my $am_cons = 0;
1025 0         0 my $root;
1026              
1027 0 0       0 if(ref($class)){ # I'm a method.
1028 0         0 $root = $_[0]; # build under the given node, from same class.
1029 0         0 $class = ref $class;
1030 0         0 $am_cons = 0;
1031             } else { # I'm a constructor
1032 0         0 $root = $class->new; # build under a new node, with class named.
1033 0         0 $root->name("Root");
1034 0         0 $am_cons = 1;
1035             }
1036              
1037 0   0     0 my $min_depth = $o->{'min_depth'} || 2;
1038 0   0     0 my $max_depth = $o->{'max_depth'} || ($min_depth + 3);
1039 0   0     0 my $max_children = $o->{'max_children'} || 4;
1040 0   0     0 my $max_node_count = $o->{'max_node_count'} || 25;
1041              
1042 0 0       0 die "max_children has to be positive" if int($max_children) < 1;
1043              
1044 0         0 my @mothers = ( $root );
1045 0         0 my @children = ( );
1046 0         0 my $node_count = 1; # the root
1047              
1048             Gen:
1049 0         0 foreach my $depth (1 .. $max_depth) {
1050 0 0       0 last if $node_count > $max_node_count;
1051             Mother:
1052 0         0 foreach my $mother (@mothers) {
1053 0 0       0 last Gen if $node_count > $max_node_count;
1054 0         0 my $children_number;
1055 0 0       0 if($depth <= $min_depth) {
1056 0         0 until( $children_number = int(rand(1 + $max_children)) ) {}
1057             } else {
1058 0         0 $children_number = int(rand($max_children));
1059             }
1060             Beget:
1061 0         0 foreach (1 .. $children_number) {
1062 0 0       0 last Gen if $node_count > $max_node_count;
1063 0         0 my $node = $mother->new_daughter;
1064 0         0 $node->name("Node$node_count");
1065 0         0 ++$node_count;
1066 0         0 push(@children, $node);
1067             }
1068             }
1069 0         0 @mothers = @children;
1070 0         0 @children = ();
1071 0 0       0 last unless @mothers;
1072             }
1073              
1074 0         0 return $root;
1075             }
1076              
1077             # -----------------------------------------------
1078              
1079             sub read_attributes
1080             {
1081 22     22 1 46 my($self, $s) = @_;
1082              
1083 22         11 my($attributes);
1084             my($name);
1085              
1086 22 50       86 if ($s =~ /^(.+)\. Attributes: ({.*})$/)
1087             {
1088 22         29 ($name, $attributes) = ($1, $self -> string2hashref($2) );
1089             }
1090             else
1091             {
1092 0         0 ($name, $attributes) = ($s, {});
1093             }
1094              
1095 22         49 return Tree::DAG_Node -> new({name => $name, attributes => $attributes});
1096              
1097             } # End of read_attributes.
1098              
1099             # -----------------------------------------------
1100              
1101             sub read_tree
1102             {
1103 1     1 1 985 my($self, $file_name) = @_;
1104 1         2 my($count) = 0;
1105 1         1 my($last_indent) = 0;
1106 1         1 my($test_string) = '--- ';
1107 1         1 my($test_length) = length $test_string;
1108              
1109 1         1 my($indent);
1110             my($node);
1111 0         0 my($offset);
1112 0         0 my($root);
1113 0         0 my(@stack);
1114 0         0 my($tos);
1115              
1116 1         4 for my $line (read_lines($file_name, binmode => ':encoding(utf-8)', chomp => 1) )
1117             {
1118 22         7964 $count++;
1119              
1120 22 100       27 if ($count == 1)
1121             {
1122 1         3 $root = $node = $self -> read_attributes($line);
1123             }
1124             else
1125             {
1126 21         45 $indent = index($line, $test_string);
1127              
1128 21 100       33 if ($indent > $last_indent)
    100          
1129             {
1130 10         6 $tos = $node;
1131              
1132 10         12 push @stack, $node, $indent;
1133             }
1134             elsif ($indent < $last_indent)
1135             {
1136 3         3 $offset = $last_indent;
1137              
1138 3         4 while ($offset > $indent)
1139             {
1140 10         8 $offset = pop @stack;
1141 10         12 $tos = pop @stack;
1142             }
1143              
1144 3         3 push @stack, $tos, $offset;
1145             }
1146              
1147             # Warning: The next line must set $node.
1148             # Don't put the RHS into the call to add_daughter()!
1149              
1150 21         36 $node = $self -> read_attributes(substr($line, $indent + $test_length) );
1151 21         29 $last_indent = $indent;
1152              
1153 21         20 $tos -> add_daughter($node);
1154             }
1155             }
1156              
1157 1         5 return $root;
1158              
1159             } # End of read_tree.
1160              
1161             # -----------------------------------------------
1162              
1163             sub remove_daughters { # write-only method
1164 13     13 1 10 my($mother, @daughters) = @_;
1165 13 50       18 die "mother must be an object!" unless ref $mother;
1166 13 50       16 return unless @daughters;
1167              
1168 13         7 my %to_delete;
1169 13         10 @daughters = grep {ref($_)
1170             and defined($_->{'mother'})
1171 13 50 33     68 and $mother eq $_->{'mother'}
1172             } @daughters;
1173 13 50       19 return unless @daughters;
1174 13         15 @to_delete{ @daughters } = undef;
1175              
1176             # This could be done better and more efficiently, I guess.
1177 13         13 foreach my $daughter (@daughters) {
1178 13         11 $daughter->{'mother'} = undef;
1179             }
1180 13         13 my $them = $mother->{'daughters'};
1181 13         15 @$them = grep { !exists($to_delete{$_}) } @$them;
  41         54  
1182              
1183             # $mother->_update_daughter_links; # unnecessary
1184 13         16 return;
1185             }
1186              
1187             # -----------------------------------------------
1188              
1189             sub remove_daughter { # alias
1190 4     4 1 7 my($it,@them) = @_; $it->remove_daughters(@them);
  4         5  
1191             }
1192              
1193             # -----------------------------------------------
1194              
1195             sub replace_with { # write-only method
1196 7     7 1 8 my($this, @replacements) = @_;
1197              
1198 7 50 33     23 if(not( defined($this->{'mother'}) && ref($this->{'mother'}) )) { # if root
1199 0         0 foreach my $replacement (@replacements) {
1200             $replacement->{'mother'}->remove_daughters($replacement)
1201 0 0       0 if $replacement->{'mother'};
1202             }
1203             # make 'em roots
1204             } else { # I have a mother
1205 7         5 my $mother = $this->{'mother'};
1206              
1207             #@replacements = grep(($_ eq $this || $_->{'mother'} ne $mother),
1208             # @replacements);
1209 7         6 @replacements = grep { $_ eq $this
1210             || not(defined($_->{'mother'}) &&
1211             ref($_->{'mother'}) &&
1212 9 50 33     63 $_->{'mother'} eq $mother
1213             )
1214             }
1215             @replacements;
1216             # Eliminate sisters (but not self)
1217             # i.e., I want myself or things NOT with the same mother as myself.
1218              
1219             $mother->set_daughters( # old switcheroo
1220             map($_ eq $this ? (@replacements) : $_ ,
1221 7 50       6 @{$mother->{'daughters'}}
  7         20  
1222             )
1223             );
1224             # and set_daughters does all the checking and possible
1225             # unlinking
1226             }
1227 7         31 return($this, @replacements);
1228             }
1229              
1230             # -----------------------------------------------
1231              
1232             sub replace_with_daughters { # write-only method
1233 0     0 1 0 my($this) = $_[0]; # takes no params other than the self
1234 0         0 my $mother = $this->{'mother'};
1235 0 0 0     0 return($this, $this->clear_daughters)
1236             unless defined($mother) && ref($mother);
1237              
1238 0         0 my @daughters = $this->clear_daughters;
1239 0         0 my $sib_r = $mother->{'daughters'};
1240 0 0       0 @$sib_r = map($_ eq $this ? (@daughters) : $_,
1241             @$sib_r # old switcheroo
1242             );
1243 0         0 foreach my $daughter (@daughters) {
1244 0         0 $daughter->{'mother'} = $mother;
1245             }
1246 0         0 return($this, @daughters);
1247             }
1248              
1249             # -----------------------------------------------
1250              
1251             sub right_sister {
1252 0     0 1 0 my $it = $_[0];
1253 0         0 my $mother = $it->{'mother'};
1254 0 0       0 return undef unless $mother;
1255 0         0 my @sisters = @{$mother->{'daughters'}};
  0         0  
1256 0 0       0 return undef if @sisters == 1; # I'm an only daughter
1257              
1258 0         0 my $seen = 0;
1259 0         0 foreach my $one (@sisters) {
1260 0 0       0 return $one if $seen;
1261 0 0       0 $seen = 1 if $one eq $it;
1262             }
1263 0 0       0 die "SPORK ERROR 9777: I'm not in my mother's daughter list!?!?"
1264             unless $seen;
1265 0         0 return undef;
1266             }
1267              
1268             # -----------------------------------------------
1269              
1270             sub right_sisters {
1271 0     0 1 0 my $it = $_[0];
1272 0         0 my $mother = $it->{'mother'};
1273 0 0       0 return() unless $mother;
1274 0         0 my @sisters = @{$mother->{'daughters'}};
  0         0  
1275 0 0       0 return() if @sisters == 1; # I'm an only daughter
1276              
1277 0         0 my @out;
1278 0         0 my $seen = 0;
1279 0         0 foreach my $one (@sisters) {
1280 0 0       0 push @out, $one if $seen;
1281 0 0       0 $seen = 1 if $one eq $it;
1282             }
1283 0 0       0 die "SPORK ERROR 9787: I'm not in my mother's daughter list!?!?"
1284             unless $seen;
1285 0         0 return @out;
1286             }
1287              
1288             # -----------------------------------------------
1289              
1290             sub root {
1291 0     0 1 0 my $it = $_[0];
1292 0         0 my @ancestors = ($it, $it->ancestors);
1293 0         0 return $ancestors[-1];
1294             }
1295              
1296             # -----------------------------------------------
1297              
1298             sub self_and_descendants {
1299             # read-only method: return a list of myself and any/all descendants
1300 0     0 1 0 my $node = shift;
1301 0         0 my @List = ();
1302 0     0   0 $node->walk_down({ 'callback' => sub { push @List, $_[0]; return 1;}});
  0         0  
  0         0  
1303 0 0       0 die "Spork Error 919: \@List has no contents!?!?" unless @List;
1304             # impossible
1305 0         0 return @List;
1306             }
1307              
1308             # -----------------------------------------------
1309              
1310             sub self_and_sisters {
1311 65     65 1 39 my $node = $_[0];
1312 65         44 my $mother = $node->{'mother'};
1313 65 50 33     181 return $node unless defined($mother) && ref($mother); # special case
1314 65         53 return @{$node->{'mother'}->{'daughters'}};
  65         103  
1315             }
1316              
1317             # -----------------------------------------------
1318              
1319             sub set_daughters { # write-only method
1320 22     22 1 23 my($mother, @them) = @_;
1321 22         22 $mother->clear_daughters;
1322 22 50       40 $mother->add_daughters(@them) if @them;
1323             # yup, it's that simple
1324             }
1325              
1326             # -----------------------------------------------
1327              
1328             sub simple_lol_to_tree {
1329 0     0 1 0 my($class, $lol, $seen_r) = @_[0,1,2];
1330 0   0     0 $class = ref($class) || $class;
1331 0 0       0 $seen_r = {} unless ref($seen_r) eq 'HASH';
1332 0 0 0     0 return if ref($lol) && $seen_r->{$lol}++; # catch circularity
1333              
1334 0         0 my $node = $class->new();
1335              
1336 0 0       0 unless(ref($lol) eq 'ARRAY') { # It's a terminal node.
1337 0 0       0 $node->name($lol) if defined $lol;
1338 0         0 return $node;
1339             }
1340              
1341             # It's a non-terminal node.
1342 0         0 foreach my $d (@$lol) { # scan daughters (whether scalars or listrefs)
1343 0         0 $node->add_daughter( $class->simple_lol_to_tree($d, $seen_r) ); # recurse!
1344             }
1345              
1346 0         0 return $node;
1347             }
1348              
1349             # -----------------------------------------------
1350              
1351             sub sisters {
1352 0     0 1 0 my $node = $_[0];
1353 0         0 my $mother = $node->{'mother'};
1354 0 0       0 return() unless $mother; # special case
1355             return grep($_ ne $node,
1356 0         0 @{$node->{'mother'}->{'daughters'}}
  0         0  
1357             );
1358             }
1359              
1360             # -----------------------------------------------
1361              
1362             sub string2hashref
1363             {
1364 22     22 1 31 my($self, $s) = @_;
1365 22   50     30 $s ||= '';
1366 22         24 my($result) = {};
1367              
1368 22         25 my($k);
1369             my($v);
1370              
1371 22 50       26 if ($s)
1372             {
1373             # Expect:
1374             # 1: The presence of the comma in "(',')" complicates things, so we can't use split(/\s*,\s*/, $s).
1375             # {x => "(',')"}
1376             # 2: The presence of "=>" complicates things, so we can't use split(/\s*=>\s*/).
1377             # {x => "=>"}
1378             # 3: So, assume ', ' is the outer separator, and then ' => ' is the inner separator.
1379              
1380             # Firstly, clean up the input, just to be safe.
1381             # None of these will match output from hashref2string($h).
1382              
1383 22         56 $s =~ s/^\s*\{*//;
1384 22         84 $s =~ s/\s*\}\s*$/\}/;
1385 22         18 my($finished) = 0;
1386              
1387             # The first '\' is for UltraEdit's syntax hiliting.
1388              
1389 22         59 my($reg_exp) =
1390             qr/
1391             ([\"'])([^"']*?)\1\s*=>\s*(["'])([^"']*?)\3,?\s*
1392             |
1393             (["'])([^"']*?)\5\s*=>\s*(.*?),?\s*
1394             |
1395             (.*?)\s*=>\s*(["'])([^"']*?)\9,?\s*
1396             |
1397             (.*?)\s*=>\s*(.*?),?\s*
1398             /sx;
1399              
1400 22         14 my(@got);
1401              
1402 22         30 while (! $finished)
1403             {
1404 43 100       141 if ($s =~ /$reg_exp/gc)
1405             {
1406 21 50       85 push @got, defined($2) ? ($2, $4) : defined($6) ? ($6, $7) : defined($8) ? ($8, $10) : ($11, $12);
    50          
    50          
1407             }
1408             else
1409             {
1410 22         33 $finished = 1;
1411             }
1412             }
1413              
1414 22         48 $result = {@got};
1415             }
1416              
1417 22         49 return $result;
1418              
1419             } # End of string2hashref.
1420              
1421             # -----------------------------------------------
1422              
1423             sub tree_to_lol {
1424             # I haven't /rigorously/ tested this.
1425 0     0 1 0 my($it, $o) = @_[0,1]; # $o is currently unused anyway
1426 0 0       0 $o = {} unless ref $o;
1427              
1428 0         0 my $out = [];
1429 0         0 my @lol_stack = ($out);
1430             $o->{'callback'} = sub {
1431 0     0   0 my($this, $o) = @_[0,1];
1432 0         0 my $new = [];
1433 0         0 push @{$lol_stack[-1]}, $new;
  0         0  
1434 0         0 push(@lol_stack, $new);
1435 0         0 return 1;
1436             }
1437 0         0 ;
1438             $o->{'callbackback'} = sub {
1439 0     0   0 my($this, $o) = @_[0,1];
1440 0 0       0 my $name = defined $this->name ? $it -> quote_name($this->name) : 'undef';
1441 0         0 push @{$lol_stack[-1]}, $name;
  0         0  
1442 0         0 pop @lol_stack;
1443 0         0 return 1;
1444             }
1445 0         0 ;
1446 0         0 $it->walk_down($o);
1447 0 0       0 die "totally bizarre error 12416" unless ref($out->[0]);
1448 0         0 $out = $out->[0]; # the real root
1449 0         0 return $out;
1450             }
1451              
1452             # -----------------------------------------------
1453              
1454             sub tree_to_lol_notation {
1455 0     0 1 0 my($it, $o) = @_[0,1];
1456 0 0       0 $o = {} unless ref $o;
1457 0         0 my @out = ();
1458 0   0     0 $o->{'_depth'} ||= 0;
1459 0 0       0 $o->{'multiline'} = 0 unless exists($o->{'multiline'});
1460              
1461 0         0 my $line_end;
1462 0 0       0 if($o->{'multiline'}) {
1463 0   0     0 $o->{'indent'} ||= ' ';
1464 0         0 $line_end = "\n";
1465             } else {
1466 0   0     0 $o->{'indent'} ||= '';
1467 0         0 $line_end = '';
1468             }
1469              
1470             $o->{'callback'} = sub {
1471 0     0   0 my($this, $o) = @_[0,1];
1472             push(@out,
1473 0         0 $o->{'indent'} x $o->{'_depth'},
1474             "[$line_end",
1475             );
1476 0         0 return 1;
1477             }
1478 0         0 ;
1479             $o->{'callbackback'} = sub {
1480 0     0   0 my($this, $o) = @_[0,1];
1481 0 0       0 my $name = defined $this->name ? $it -> quote_name($this->name) : 'undef';
1482             push(@out,
1483             $o->{'indent'} x ($o->{'_depth'} + 1),
1484             "$name$line_end",
1485 0         0 $o->{'indent'} x $o->{'_depth'},
1486             "],$line_end",
1487             );
1488 0         0 return 1;
1489             }
1490 0         0 ;
1491 0         0 $it->walk_down($o);
1492 0         0 return join('', @out);
1493             }
1494              
1495             # -----------------------------------------------
1496              
1497             sub tree_to_simple_lol {
1498             # I haven't /rigorously/ tested this.
1499 0     0 1 0 my $root = $_[0];
1500              
1501 0 0       0 return $root->name unless scalar($root->daughters);
1502             # special case we have to nip in the bud
1503              
1504 0         0 my($it, $o) = @_[0,1]; # $o is currently unused anyway
1505 0 0       0 $o = {} unless ref $o;
1506              
1507 0         0 my $out = [];
1508 0         0 my @lol_stack = ($out);
1509             $o->{'callback'} = sub {
1510 0     0   0 my($this, $o) = @_[0,1];
1511 0         0 my $new;
1512 0 0       0 my $name = defined $this->name ? $it -> quote_name($this->name) : 'undef';
1513 0 0       0 $new = scalar($this->daughters) ? [] : $name;
1514             # Terminal nodes are scalars, the rest are listrefs we'll fill in
1515             # as we recurse the tree below here.
1516 0         0 push @{$lol_stack[-1]}, $new;
  0         0  
1517 0         0 push(@lol_stack, $new);
1518 0         0 return 1;
1519             }
1520 0         0 ;
1521 0     0   0 $o->{'callbackback'} = sub { pop @lol_stack; return 1; };
  0         0  
  0         0  
1522 0         0 $it->walk_down($o);
1523 0 0       0 die "totally bizarre error 12416" unless ref($out->[0]);
1524 0         0 $out = $out->[0]; # the real root
1525 0         0 return $out;
1526             }
1527              
1528             # -----------------------------------------------
1529              
1530             sub tree_to_simple_lol_notation {
1531 0     0 1 0 my($it, $o) = @_[0,1];
1532 0 0       0 $o = {} unless ref $o;
1533 0         0 my @out = ();
1534 0   0     0 $o->{'_depth'} ||= 0;
1535 0 0       0 $o->{'multiline'} = 0 unless exists($o->{'multiline'});
1536              
1537 0         0 my $line_end;
1538 0 0       0 if($o->{'multiline'}) {
1539 0   0     0 $o->{'indent'} ||= ' ';
1540 0         0 $line_end = "\n";
1541             } else {
1542 0   0     0 $o->{'indent'} ||= '';
1543 0         0 $line_end = '';
1544             }
1545              
1546             $o->{'callback'} = sub {
1547 0     0   0 my($this, $o) = @_[0,1];
1548 0 0       0 if(scalar($this->daughters)) { # Nonterminal
1549             push(@out,
1550 0         0 $o->{'indent'} x $o->{'_depth'},
1551             "[$line_end",
1552             );
1553             } else { # Terminal
1554 0 0       0 my $name = defined $this->name ? $it -> quote_name($this->name) : 'undef';
1555             push @out,
1556 0         0 $o->{'indent'} x $o->{'_depth'},
1557             "$name,$line_end";
1558             }
1559 0         0 return 1;
1560             }
1561 0         0 ;
1562             $o->{'callbackback'} = sub {
1563 0     0   0 my($this, $o) = @_[0,1];
1564             push(@out,
1565 0 0       0 $o->{'indent'} x $o->{'_depth'},
1566             "], $line_end",
1567             ) if scalar($this->daughters);
1568 0         0 return 1;
1569             }
1570 0         0 ;
1571              
1572 0         0 $it->walk_down($o);
1573 0         0 return join('', @out);
1574             }
1575              
1576             # -----------------------------------------------
1577              
1578             sub tree2string
1579             {
1580 3     3 1 555 my($self, $options, $tree) = @_;
1581 3   100     10 $options ||= {};
1582 3   50     12 $$options{no_attributes} ||= 0;
1583 3   33     10 $tree ||= $self;
1584              
1585 3         4 my(@out);
1586             my(@vert_dashes);
1587              
1588             $tree -> walk_down
1589             ({
1590             callback =>
1591             sub
1592             {
1593 68     68   40 my($node) = @_;
1594              
1595 68         79 push @out, $self -> node2string($options, $node, \@vert_dashes);
1596              
1597 68         71 return 1,
1598             },
1599 3         20 _depth => 0,
1600             });
1601              
1602 3         23 return [@out];
1603              
1604             } # End of tree2string.
1605              
1606             # -----------------------------------------------
1607              
1608             sub unlink_from_mother {
1609 0     0 1 0 my $node = $_[0];
1610 0         0 my $mother = $node->{'mother'};
1611 0 0 0     0 $mother->remove_daughters($node) if defined($mother) && ref($mother);
1612 0         0 return $mother;
1613             }
1614              
1615             # -----------------------------------------------
1616              
1617             sub _update_daughter_links {
1618             # Eliminate any duplicates in my daughters list, and update
1619             # all my daughters' links to myself.
1620 70     70   47 my $this = shift;
1621              
1622 70         45 my $them = $this->{'daughters'};
1623              
1624             # Eliminate duplicate daughters.
1625 70         59 my %seen = ();
1626 70 50       51 @$them = grep { ref($_) && not($seen{$_}++) } @$them;
  131         469  
1627             # not that there should ever be duplicate daughters anyhoo.
1628              
1629 70         69 foreach my $one (@$them) { # linkage bookkeeping
1630 131 50       150 die "daughter <$one> isn't an object!" unless ref $one;
1631 131         109 $one->{'mother'} = $this;
1632             }
1633 70         79 return;
1634             }
1635              
1636             # -----------------------------------------------
1637              
1638             sub walk_down {
1639 159     159 1 173 my($this, $o) = @_[0,1];
1640              
1641             # All the can()s are in case an object changes class while I'm
1642             # looking at it.
1643              
1644 159 50       208 die "I need options!" unless ref($o);
1645             die "I need a callback or a callbackback" unless
1646 159 50 33     228 ( ref($o->{'callback'}) || ref($o->{'callbackback'}) );
1647              
1648 159 50       178 my $callback = ref($o->{'callback'}) ? $o->{'callback'} : undef;
1649 159 50       158 my $callbackback = ref($o->{'callbackback'}) ? $o->{'callbackback'} : undef;
1650 159         94 my $callback_status = 1;
1651              
1652 159 50       189 print "Callback: $callback Callbackback: $callbackback\n" if $Debug;
1653              
1654 159 50 0     154 printf "* Entering %s\n", ($this->name || $this) if $Debug;
1655 159 50       189 $callback_status = &{ $callback }( $this, $o ) if $callback;
  159         167  
1656              
1657 159 50       327 if($callback_status) {
1658             # Keep recursing unless callback returned false... and if there's
1659             # anything to recurse into, of course.
1660 159 50       236 my @daughters = UNIVERSAL::can($this, 'is_node') ? @{$this->{'daughters'}} : ();
  159         171  
1661 159 100       217 if(@daughters) {
1662 100         76 $o->{'_depth'} += 1;
1663             #print "Depth " , $o->{'_depth'}, "\n";
1664 100         83 foreach my $one (@daughters) {
1665 153 50       326 $one->walk_down($o) if UNIVERSAL::can($one, 'is_node');
1666             # and if it can do "is_node", it should provide a walk_down!
1667             }
1668 100         86 $o->{'_depth'} -= 1;
1669             }
1670             } else {
1671 0 0 0     0 printf "* Recursing below %s pruned\n", ($this->name || $this) if $Debug;
1672             }
1673              
1674             # Note that $callback_status doesn't block callbackback from being called
1675 159 50       174 if($callbackback){
1676 0 0       0 if(UNIVERSAL::can($this, 'is_node')) { # if it's still a node!
1677 0 0       0 print "* Calling callbackback\n" if $Debug;
1678 0         0 scalar( &{ $callbackback }( $this, $o ) );
  0         0  
1679             # scalar to give it the same context as callback
1680             } else {
1681 0 0       0 print "* Can't call callbackback -- $this isn't a node anymore\n"
1682             if $Debug;
1683             }
1684             }
1685 159 50       167 if($Debug) {
1686 0 0       0 if(UNIVERSAL::can($this, 'is_node')) { # if it's still a node!
1687 0   0     0 printf "* Leaving %s\n", ($this->name || $this)
1688             } else {
1689 0         0 print "* Leaving [no longer a node]\n";
1690             }
1691             }
1692 159         150 return;
1693             }
1694              
1695             # -----------------------------------------------
1696              
1697             1;
1698              
1699             =pod
1700              
1701             =encoding utf-8
1702              
1703             =head1 NAME
1704              
1705             Tree::DAG_Node - An N-ary tree
1706              
1707             =head1 SYNOPSIS
1708              
1709             =head2 Using as a base class
1710              
1711             package Game::Tree::Node;
1712              
1713             use parent 'Tree::DAG_Node';
1714              
1715             # Now add your own methods overriding/extending the methods in C...
1716              
1717             =head2 Using as a class on its own
1718              
1719             use Tree::DAG_Node;
1720              
1721             my($root) = Tree::DAG_Node -> new({name => 'root', attributes => {uid => 0} });
1722              
1723             $root -> add_daughter(Tree::DAG_Node -> new({name => 'one', attributes => {uid => 1} }) );
1724             $root -> add_daughter(Tree::DAG_Node -> new({name => 'two', attributes => {} }) );
1725             $root -> add_daughter(Tree::DAG_Node -> new({name => 'three'}) ); # Attrs default to {}.
1726              
1727             Or:
1728              
1729             my($count) = 0;
1730             my($tree) = Tree::DAG_Node -> new({name => 'Root', attributes => {'uid' => $count} });
1731              
1732             Or:
1733              
1734             my $root = Tree::DAG_Node -> new();
1735              
1736             $root -> name("I'm the tops");
1737             $root -> attributes({uid => 0});
1738              
1739             my $new_daughter = $root -> new_daughter;
1740              
1741             $new_daughter -> name('Another node');
1742             $new_daughter -> attributes({uid => 1});
1743             ...
1744              
1745             Lastly, for fancy wrappers - called _add_daughter() - around C, see these modules:
1746             L and L. Both of these modules use L.
1747              
1748             See scripts/*.pl for other samples.
1749              
1750             =head2 Using with utf-8 data
1751              
1752             read_tree($file_name) works with utf-8 data. See t/read.tree.t and t/tree.utf8.attributes.txt.
1753             Such a file can be created by redirecting the output of tree2string() to a file of type utf-8.
1754              
1755             See the docs for L for the difference between utf8 and utf-8. In brief, use utf-8.
1756              
1757             See also scripts/write_tree.pl and scripts/read.tree.pl and scripts/read.tree.log.
1758              
1759             =head1 DESCRIPTION
1760              
1761             This class encapsulates/makes/manipulates objects that represent nodes
1762             in a tree structure. The tree structure is not an object itself, but
1763             is emergent from the linkages you create between nodes. This class
1764             provides the methods for making linkages that can be used to build up
1765             a tree, while preventing you from ever making any kinds of linkages
1766             which are not allowed in a tree (such as having a node be its own
1767             mother or ancestor, or having a node have two mothers).
1768              
1769             This is what I mean by a "tree structure", a bit redundantly stated:
1770              
1771             =over 4
1772              
1773             =item o A tree is a special case of an acyclic directed graph
1774              
1775             =item o A tree is a network of nodes where there's exactly one root node
1776              
1777             Also, the only primary relationship between nodes is the mother-daughter relationship.
1778              
1779             =item o No node can be its own mother, or its mother's mother, etc
1780              
1781             =item o Each node in the tree has exactly one parent
1782              
1783             Except for the root of course, which is parentless.
1784              
1785             =item o Each node can have any number (0 .. N) daughter nodes
1786              
1787             A given node's daughter nodes constitute an I list.
1788              
1789             However, you are free to consider this ordering irrelevant.
1790             Some applications do need daughters to be ordered, so I chose to
1791             consider this the general case.
1792              
1793             =item o A node can appear in only one tree, and only once in that tree
1794              
1795             Notably (notable because it doesn't follow from the two above points),
1796             a node cannot appear twice in its mother's daughter list.
1797              
1798             =item o There's an idea of up versus down
1799              
1800             Up means towards to the root, and down means away from the root (and towards the leaves).
1801              
1802             =item o There's an idea of left versus right
1803              
1804             Left is toward the start (index 0) of a given node's daughter list, and right is toward the end of a
1805             given node's daughter list.
1806              
1807             =back
1808              
1809             Trees as described above have various applications, among them:
1810             representing syntactic constituency, in formal linguistics;
1811             representing contingencies in a game tree; representing abstract
1812             syntax in the parsing of any computer language -- whether in
1813             expression trees for programming languages, or constituency in the
1814             parse of a markup language document. (Some of these might not use the
1815             fact that daughters are ordered.)
1816              
1817             (Note: B-Trees are a very special case of the above kinds of trees,
1818             and are best treated with their own class. Check CPAN for modules
1819             encapsulating B-Trees; or if you actually want a database, and for
1820             some reason ended up looking here, go look at L.)
1821              
1822             Many base classes are not usable except as such -- but C
1823             can be used as a normal class. You can go ahead and say:
1824              
1825             use Tree::DAG_Node;
1826             my $root = Tree::DAG_Node->new();
1827             $root->name("I'm the tops");
1828             $new_daughter = Tree::DAG_Node->new();
1829             $new_daughter->name("More");
1830             $root->add_daughter($new_daughter);
1831              
1832             and so on, constructing and linking objects from C and
1833             making useful tree structures out of them.
1834              
1835             =head1 A NOTE TO THE READER
1836              
1837             This class is big and provides lots of methods. If your problem is
1838             simple (say, just representing a simple parse tree), this class might
1839             seem like using an atomic sledgehammer to swat a fly. But the
1840             complexity of this module's bells and whistles shouldn't detract from
1841             the efficiency of using this class for a simple purpose. In fact, I'd
1842             be very surprised if any one user ever had use for more that even a
1843             third of the methods in this class. And remember: an atomic
1844             sledgehammer B kill that fly.
1845              
1846             =head1 OBJECT CONTENTS
1847              
1848             Implementationally, each node in a tree is an object, in the sense of
1849             being an arbitrarily complex data structure that belongs to a class
1850             (presumably C, or ones derived from it) that provides
1851             methods.
1852              
1853             The attributes of a node-object are:
1854              
1855             =over
1856              
1857             =item o mother -- this node's mother. undef if this is a root
1858              
1859             =item o daughters -- the (possibly empty) list of daughters of this node
1860              
1861             =item o name -- the name for this node
1862              
1863             Need not be unique, or even printable. This is printed in some of the
1864             various dumper methods, but it's up to you if you don't put anything
1865             meaningful or printable here.
1866              
1867             =item o attributes -- whatever the user wants to use it for
1868              
1869             Presumably a hashref to whatever other attributes the user wants to
1870             store without risk of colliding with the object's real attributes.
1871             (Example usage: attributes to an SGML tag -- you definitely wouldn't
1872             want the existence of a "mother=foo" pair in such a tag to collide with
1873             a node object's 'mother' attribute.)
1874              
1875             Aside from (by default) initializing it to {}, and having the access
1876             method called "attributes" (described a ways below), I don't do
1877             anything with the "attributes" in this module. I basically intended
1878             this so that users who don't want/need to bother deriving a class
1879             from C, could still attach whatever data they wanted in a
1880             node.
1881              
1882             =back
1883              
1884             "mother" and "daughters" are attributes that relate to linkage -- they
1885             are never written to directly, but are changed as appropriate by the
1886             "linkage methods", discussed below.
1887              
1888             The other two (and whatever others you may add in derived classes) are
1889             simply accessed thru the same-named methods, discussed further below.
1890              
1891             =head2 About The Documented Interface
1892              
1893             Stick to the documented interface (and comments in the source --
1894             especially ones saying "undocumented!" and/or "disfavored!" -- do not
1895             count as documentation!), and don't rely on any behavior that's not in
1896             the documented interface.
1897              
1898             Specifically, unless the documentation for a particular method says
1899             "this method returns thus-and-such a value", then you should not rely on
1900             it returning anything meaningful.
1901              
1902             A I acquaintance with at least the broader details of the source
1903             code for this class is assumed for anyone using this class as a base
1904             class -- especially if you're overriding existing methods, and
1905             B if you're overriding linkage methods.
1906              
1907             =head1 MAIN CONSTRUCTOR, AND INITIALIZER
1908              
1909             =over
1910              
1911             =item the constructor CLASS->new() or CLASS->new($options)
1912              
1913             This creates a new node object, calls $object->_init($options)
1914             to provide it sane defaults (like: undef name, undef mother, no
1915             daughters, 'attributes' setting of a new empty hashref), and returns
1916             the object created. (If you just said "CLASS->new()" or "CLASS->new",
1917             then it pretends you called "CLASS->new({})".)
1918              
1919             See also the comments under L for options supported in the call to new().
1920              
1921             If you use C as a superclass, and you add
1922             attributes that need to be initialized, what you need to do is provide
1923             an _init method that calls $this->SUPER::_init($options) to use its
1924             superclass's _init method, and then initializes the new attributes:
1925              
1926             sub _init {
1927             my($this, $options) = @_[0,1];
1928             $this->SUPER::_init($options); # call my superclass's _init to
1929             # init all the attributes I'm inheriting
1930              
1931             # Now init /my/ new attributes:
1932             $this->{'amigos'} = []; # for example
1933             }
1934              
1935             =item the constructor $obj->new() or $obj->new($options)
1936              
1937             Just another way to get at the L method. This B
1938             $obj, but merely constructs a new object of the same class as it.
1939             Saves you the bother of going $class = ref $obj; $obj2 = $class->new;
1940              
1941             =item the method $node->_init($options)
1942              
1943             Initialize the object's attribute values. See the discussion above.
1944             Presumably this should be called only by the guts of the L
1945             constructor -- never by the end user.
1946              
1947             Currently there are no documented options for putting in the
1948             $options hashref, but (in case you want to disregard the above rant)
1949             the option exists for you to use $options for something useful
1950             in a derived class.
1951              
1952             Please see the source for more information.
1953              
1954             =item see also (below) the constructors "new_daughter" and "new_daughter_left"
1955              
1956             =back
1957              
1958             =head1 METHODS
1959              
1960             =head2 add_daughter(LIST)
1961              
1962             An exact synonym for L.
1963              
1964             =head2 add_daughters(LIST)
1965              
1966             This method adds the node objects in LIST to the (right) end of
1967             $mother's I list. Making a node N1 the daughter of another
1968             node N2 also means that N1's I attribute is "automatically" set
1969             to N2; it also means that N1 stops being anything else's daughter as
1970             it becomes N2's daughter.
1971              
1972             If you try to make a node its own mother, a fatal error results. If
1973             you try to take one of a node N1's ancestors and make it also a
1974             daughter of N1, a fatal error results. A fatal error results if
1975             anything in LIST isn't a node object.
1976              
1977             If you try to make N1 a daughter of N2, but it's B a daughter
1978             of N2, then this is a no-operation -- it won't move such nodes to the
1979             end of the list or anything; it just skips doing anything with them.
1980              
1981             =head2 add_daughter_left(LIST)
1982              
1983             An exact synonym for L.
1984              
1985             =head2 add_daughters_left(LIST)
1986              
1987             This method is just like L, except that it adds the
1988             node objects in LIST to the (left) beginning of $mother's daughter
1989             list, instead of the (right) end of it.
1990              
1991             =head2 add_left_sister(LIST)
1992              
1993             An exact synonym for L.
1994              
1995             =head2 add_left_sisters(LIST)
1996              
1997             This adds the elements in LIST (in that order) as immediate left sisters of
1998             $node. In other words, given that B's mother's daughter-list is (A,B,C,D),
1999             calling B->add_left_sisters(X,Y) makes B's mother's daughter-list
2000             (A,X,Y,B,C,D).
2001              
2002             If LIST is empty, this is a no-op, and returns empty-list.
2003              
2004             This is basically implemented as a call to $node->replace_with(LIST,
2005             $node), and so all replace_with's limitations and caveats apply.
2006              
2007             The return value of $node->add_left_sisters(LIST) is the elements of
2008             LIST that got added, as returned by replace_with -- minus the copies
2009             of $node you'd get from a straight call to $node->replace_with(LIST,
2010             $node).
2011              
2012             =head2 add_right_sister(LIST)
2013              
2014             An exact synonym for L.
2015              
2016             =head2 add_right_sisters(LIST)
2017              
2018             Just like add_left_sisters (which see), except that the elements
2019             in LIST (in that order) as immediate B sisters of $node;
2020              
2021             In other words, given that B's mother's daughter-list is (A,B,C,D),
2022             calling B->add_right_sisters(X,Y) makes B's mother's daughter-list
2023             (A,B,X,Y,C,D).
2024              
2025             =head2 address()
2026              
2027             =head2 address(ADDRESS)
2028              
2029             With the first syntax, returns the address of $node within its tree,
2030             based on its position within the tree. An address is formed by noting
2031             the path between the root and $node, and concatenating the
2032             daughter-indices of the nodes this passes thru (starting with 0 for
2033             the root, and ending with $node).
2034              
2035             For example, if to get from node ROOT to node $node, you pass thru
2036             ROOT, A, B, and $node, then the address is determined as:
2037              
2038             =over 4
2039              
2040             =item o ROOT's my_daughter_index is 0
2041              
2042             =item o A's my_daughter_index is, suppose, 2
2043              
2044             A is index 2 in ROOT's daughter list.
2045              
2046             =item o B's my_daughter_index is, suppose, 0
2047              
2048             B is index 0 in A's daughter list.
2049              
2050             =item o $node's my_daughter_index is, suppose, 4
2051              
2052             $node is index 4 in B's daughter list.
2053              
2054             =back
2055              
2056             The address of the above-described $node is, therefore, "0:2:0:4".
2057              
2058             (As a somewhat special case, the address of the root is always "0";
2059             and since addresses start from the root, all addresses start with a
2060             "0".)
2061              
2062             The second syntax, where you provide an address, starts from the root
2063             of the tree $anynode belongs to, and returns the node corresponding to
2064             that address. Returns undef if no node corresponds to that address.
2065             Note that this routine may be somewhat liberal in its interpretation
2066             of what can constitute an address; i.e., it accepts "0.2.0.4", besides
2067             "0:2:0:4".
2068              
2069             Also note that the address of a node in a tree is meaningful only in
2070             that tree as currently structured.
2071              
2072             (Consider how ($address1 cmp $address2) may be magically meaningful
2073             to you, if you meant to figure out what nodes are to the right of what
2074             other nodes.)
2075              
2076             =head2 ancestors()
2077              
2078             Returns the list of this node's ancestors, starting with its mother,
2079             then grandmother, and ending at the root. It does this by simply
2080             following the 'mother' attributes up as far as it can. So if $item IS
2081             the root, this returns an empty list.
2082              
2083             Consider that scalar($node->ancestors) returns the ply of this node
2084             within the tree -- 2 for a granddaughter of the root, etc., and 0 for
2085             root itself.
2086              
2087             =head2 attribute()
2088              
2089             =head2 attribute(SCALAR)
2090              
2091             Exact synonyms for L and L.
2092              
2093             =head2 attributes()
2094              
2095             =head2 attributes(SCALAR)
2096              
2097             In the first form, returns the value of the node object's "attributes"
2098             attribute. In the second form, sets it to the value of SCALAR. I
2099             intend this to be used to store a reference to a (presumably
2100             anonymous) hash the user can use to store whatever attributes he
2101             doesn't want to have to store as object attributes. In this case, you
2102             needn't ever set the value of this. (_init has already initialized it
2103             to {}.) Instead you can just do...
2104              
2105             $node->attributes->{'foo'} = 'bar';
2106              
2107             ...to write foo => bar.
2108              
2109             =head2 clear_daughters()
2110              
2111             This unlinks all $mother's daughters.
2112             Returns the list of what used to be $mother's daughters.
2113              
2114             Not to be confused with L.
2115              
2116             =head2 common(LIST)
2117              
2118             Returns the lowest node in the tree that is ancestor-or-self to the
2119             nodes $node and LIST.
2120              
2121             If the nodes are far enough apart in the tree, the answer is just the
2122             root.
2123              
2124             If the nodes aren't all in the same tree, the answer is undef.
2125              
2126             As a degenerate case, if LIST is empty, returns $node.
2127              
2128             =head2 common_ancestor(LIST)
2129              
2130             Returns the lowest node that is ancestor to all the nodes given (in
2131             nodes $node and LIST). In other words, it answers the question: "What
2132             node in the tree, as low as possible, is ancestor to the nodes given
2133             ($node and LIST)?"
2134              
2135             If the nodes are far enough apart, the answer is just the root --
2136             except if any of the nodes are the root itself, in which case the
2137             answer is undef (since the root has no ancestor).
2138              
2139             If the nodes aren't all in the same tree, the answer is undef.
2140              
2141             As a degenerate case, if LIST is empty, returns $node's mother;
2142             that'll be undef if $node is root.
2143              
2144             =head2 copy($option)
2145              
2146             Returns a copy of the calling node (the invocant). E.g.: my($copy) = $node -> copy;
2147              
2148             $option is a hashref of options, with these (key => value) pairs:
2149              
2150             =over 4
2151              
2152             =item o no_attribute_copy => $Boolean
2153              
2154             If set to 1, do not copy the node's attributes.
2155              
2156             If not specified, defaults to 0, which copies attributes.
2157              
2158             =back
2159              
2160             =head2 copy_at_and_under()
2161              
2162             =head2 copy_at_and_under($options)
2163              
2164             This returns a copy of the subtree consisting of $node and everything
2165             under it.
2166              
2167             If you pass no options, copy_at_and_under pretends you've passed {}.
2168              
2169             This works by recursively building up the new tree from the leaves,
2170             duplicating nodes using $orig_node->copy($options_ref) and then
2171             linking them up into a new tree of the same shape.
2172              
2173             Options you specify are passed down to calls to $node->copy.
2174              
2175             =head2 copy_tree()
2176              
2177             =head2 copy_tree($options)
2178              
2179             This returns the root of a copy of the tree that $node is a member of.
2180             If you pass no options, copy_tree pretends you've passed {}.
2181              
2182             This method is currently implemented as just a call to
2183             $this->root->copy_at_and_under($options), but magic may be
2184             added in the future.
2185              
2186             Options you specify are passed down to calls to $node->copy.
2187              
2188             =head2 daughters()
2189              
2190             This returns the (possibly empty) list of daughters for $node.
2191              
2192             =head2 decode_lol($lol)
2193              
2194             Returns an arrayref having decoded the deeply nested structure $lol.
2195              
2196             $lol will be the output of either tree_to_lol() or tree_to_simple_lol().
2197              
2198             See scripts/read.tree.pl, and it's output file scripts/read.tree.log.
2199              
2200             =head2 delete_tree()
2201              
2202             Destroys the entire tree that $node is a member of (starting at the
2203             root), by nulling out each node-object's attributes (including, most
2204             importantly, its linkage attributes -- hopefully this is more than
2205             sufficient to eliminate all circularity in the data structure), and
2206             then moving it into the class DEADNODE.
2207              
2208             Use this when you're finished with the tree in question, and want to
2209             free up its memory. (If you don't do this, it'll get freed up anyway
2210             when your program ends.)
2211              
2212             If you try calling any methods on any of the node objects in the tree
2213             you've destroyed, you'll get an error like:
2214              
2215             Can't locate object method "leaves_under"
2216             via package "DEADNODE".
2217              
2218             So if you see that, that's what you've done wrong. (Actually, the
2219             class DEADNODE does provide one method: a no-op method "delete_tree".
2220             So if you want to delete a tree, but think you may have deleted it
2221             already, it's safe to call $node->delete_tree on it (again).)
2222              
2223             The L method is needed because Perl's garbage collector
2224             would never (as currently implemented) see that it was time to
2225             de-allocate the memory the tree uses -- until either you call
2226             $node->delete_tree, or until the program stops (at "global
2227             destruction" time, when B is unallocated).
2228              
2229             Incidentally, there are better ways to do garbage-collecting on a
2230             tree, ways which don't require the user to explicitly call a method
2231             like L -- they involve dummy classes, as explained at
2232             L
2233              
2234             However, introducing a dummy class concept into C would
2235             be rather a distraction. If you want to do this with your derived
2236             classes, via a DESTROY in a dummy class (or in a tree-metainformation
2237             class, maybe), then feel free to.
2238              
2239             The only case where I can imagine L failing to totally
2240             void the tree, is if you use the hashref in the "attributes" attribute
2241             to store (presumably among other things) references to other nodes'
2242             "attributes" hashrefs -- which 1) is maybe a bit odd, and 2) is your
2243             problem, because it's your hash structure that's circular, not the
2244             tree's. Anyway, consider:
2245              
2246             # null out all my "attributes" hashes
2247             $anywhere->root->walk_down({
2248             'callback' => sub {
2249             $hr = $_[0]->attributes; %$hr = (); return 1;
2250             }
2251             });
2252             # And then:
2253             $anywhere->delete_tree;
2254              
2255             (I suppose L is a "destructor", or as close as you can
2256             meaningfully come for a circularity-rich data structure in Perl.)
2257              
2258             See also L.
2259              
2260             =head2 depth_under()
2261              
2262             Returns an integer representing the number of branches between this
2263             $node and the most distant leaf under it. (In other words, this
2264             returns the ply of subtree starting of $node. Consider
2265             scalar($it->ancestors) if you want the ply of a node within the whole
2266             tree.)
2267              
2268             =head2 descendants()
2269              
2270             Returns a list consisting of all the descendants of $node. Returns
2271             empty-list if $node is a terminal_node.
2272              
2273             (Note that it's spelled "descendants", not "descendents".)
2274              
2275             =head2 draw_ascii_tree([$options])
2276              
2277             Here, the [] refer to an optional parameter.
2278              
2279             Returns an arrayref of lines suitable for printing.
2280              
2281             Draws a nice ASCII-art representation of the tree structure.
2282              
2283             The tree looks like:
2284              
2285             |
2286            
2287             /-------+-----+---+---\
2288             | | | | |
2289            
2290             /---\ /---\ | | |
2291             | | | |
2292             | |
2293             | | | |
2294            
2295             | |
2296            
2297             | |
2298            
2299             | |
2300            
2301              
2302             See scripts/cut.and.paste.subtrees.pl.
2303              
2304             Example usage:
2305              
2306             print map("$_\n", @{$tree->draw_ascii_tree});
2307              
2308             I takes parameters you set in the $options hashref:
2309              
2310             =over 4
2311              
2312             =item o h_compact
2313              
2314             Takes 0 or 1. Sets the extent to which
2315             I tries to save horizontal space.
2316              
2317             If I think of a better scrunching algorithm, there'll be a "2" setting
2318             for this.
2319              
2320             Default: 1.
2321              
2322             =item o h_spacing
2323              
2324             Takes a number 0 or greater. Sets the number of spaces
2325             inserted horizontally between nodes (and groups of nodes) in a tree.
2326              
2327             Default: 1.
2328              
2329             =item o no_name
2330              
2331             If true, I doesn't print the name of
2332             the node; it simply prints a "*".
2333              
2334             Default: 0 (i.e., print the node name.)
2335              
2336             =item o v_compact
2337              
2338             Takes a number 0, 1, or 2. Sets the degree to which
2339             I tries to save vertical space. Defaults to 1.
2340              
2341             =back
2342              
2343             The code occasionally returns trees that are a bit cock-eyed in parts; if
2344             anyone can suggest a better drawing algorithm, I'd be appreciative.
2345              
2346             See also L.
2347              
2348             =head2 dump_names($options)
2349              
2350             Returns an array.
2351              
2352             Dumps, as an indented list, the names of the nodes starting at $node,
2353             and continuing under it. Options are:
2354              
2355             =over 4
2356              
2357             =item o _depth -- A nonnegative number
2358              
2359             Indicating the depth to consider $node as being at (and so the generation under that is that plus
2360             one, etc.). You may choose to use set _depth => scalar($node->ancestors).
2361              
2362             Default: 0.
2363              
2364             =item o tick -- a string to preface each entry with
2365              
2366             This string goes between the indenting-spacing and the node's name. You
2367             may prefer "*" or "-> " or something.
2368              
2369             Default: ''.
2370              
2371             =item o indent -- the string used to indent with
2372              
2373             Another sane value might be '. ' (period, space). Setting it to empty-string suppresses indenting.
2374              
2375             Default: ' ' x 2.
2376              
2377             =back
2378              
2379             The output is not printed, but is returned as a list, where each
2380             item is a line, with a "\n" at the end.
2381              
2382             =head2 format_node($options, $node)
2383              
2384             Returns a string consisting of the node's name and, optionally, it's attributes.
2385              
2386             Possible keys in the $options hashref:
2387              
2388             =over 4
2389              
2390             =item o no_attributes => $Boolean
2391              
2392             If 1, the node's attributes are not included in the string returned.
2393              
2394             Default: 0 (include attributes).
2395              
2396             =back
2397              
2398             Calls L.
2399              
2400             Called by L.
2401              
2402             You would not normally call this method.
2403              
2404             If you don't wish to supply options, use format_node({}, $node).
2405              
2406             =head2 generation()
2407              
2408             Returns a list of all nodes (going left-to-right) that are in $node's
2409             generation -- i.e., that are the some number of nodes down from
2410             the root. $root->generation() is just $root.
2411              
2412             Of course, $node is always in its own generation.
2413              
2414             =head2 generation_under($node)
2415              
2416             Like L, but returns only the nodes in $node's generation
2417             that are also descendants of $node -- in other words,
2418              
2419             @us = $node->generation_under( $node->mother->mother );
2420              
2421             is all $node's first cousins (to borrow yet more kinship terminology) --
2422             assuming $node does indeed have a grandmother. Actually "cousins" isn't
2423             quite an apt word, because C<@us> ends up including $node's siblings and
2424             $node.
2425              
2426             Actually, L is just an alias to L, but I
2427             figure that this:
2428              
2429             @us = $node->generation_under($way_upline);
2430              
2431             is a bit more readable than this:
2432              
2433             @us = $node->generation($way_upline);
2434              
2435             But it's up to you.
2436              
2437             $node->generation_under($node) returns just $node.
2438              
2439             If you call $node->generation_under($node) but NODE2 is not $node or an
2440             ancestor of $node, it behaves as if you called just $node->generation().
2441              
2442             =head2 hashref2string($hashref)
2443              
2444             Returns the given hashref as a string.
2445              
2446             Called by L.
2447              
2448             =head2 is_daughter_of($node2)
2449              
2450             Returns true iff $node is a daughter of $node2.
2451             Currently implemented as just a test of ($it->mother eq $node2).
2452              
2453             =head2 is_node()
2454              
2455             This always returns true. More pertinently, $object->can('is_node')
2456             is true (regardless of what L would do if called) for objects
2457             belonging to this class or for any class derived from it.
2458              
2459             =head2 is_root()
2460              
2461             Returns 1 if the caller is the root, and 0 if it is not.
2462              
2463             =head2 leaves_under()
2464              
2465             Returns a list (going left-to-right) of all the leaf nodes under
2466             $node. ("Leaf nodes" are also called "terminal nodes" -- i.e., nodes
2467             that have no daughters.) Returns $node in the degenerate case of
2468             $node being a leaf itself.
2469              
2470             =head2 left_sister()
2471              
2472             Returns the node that's the immediate left sister of $node. If $node
2473             is the leftmost (or only) daughter of its mother (or has no mother),
2474             then this returns undef.
2475              
2476             See also L and L.
2477              
2478             =head2 left_sisters()
2479              
2480             Returns a list of nodes that're sisters to the left of $node. If
2481             $node is the leftmost (or only) daughter of its mother (or has no
2482             mother), then this returns an empty list.
2483              
2484             See also L and L.
2485              
2486             =head2 lol_to_tree($lol)
2487              
2488             This must be called as a class method.
2489              
2490             Converts something like bracket-notation for "Chomsky trees" (or
2491             rather, the closest you can come with Perl
2492             list-of-lists(-of-lists(-of-lists))) into a tree structure. Returns
2493             the root of the tree converted.
2494              
2495             The conversion rules are that: 1) if the last (possibly the only) item
2496             in a given list is a scalar, then that is used as the "name" attribute
2497             for the node based on this list. 2) All other items in the list
2498             represent daughter nodes of the current node -- recursively so, if
2499             they are list references; otherwise, (non-terminal) scalars are
2500             considered to denote nodes with that name. So ['Foo', 'Bar', 'N'] is
2501             an alternate way to represent [['Foo'], ['Bar'], 'N'].
2502              
2503             An example will illustrate:
2504              
2505             use Tree::DAG_Node;
2506             $lol =
2507             [
2508             [
2509             [ [ 'Det:The' ],
2510             [ [ 'dog' ], 'N'], 'NP'],
2511             [ '/with rabies\\', 'PP'],
2512             'NP'
2513             ],
2514             [ 'died', 'VP'],
2515             'S'
2516             ];
2517             $tree = Tree::DAG_Node->lol_to_tree($lol);
2518             $diagram = $tree->draw_ascii_tree;
2519             print map "$_\n", @$diagram;
2520              
2521             ...returns this tree:
2522              
2523             |
2524            
2525             |
2526             /------------------\
2527             | |
2528            
2529             | |
2530             /---------------\
2531             | |
2532            
2533             | |
2534             /-------\
2535             | |
2536            
2537             |
2538            
2539              
2540             By the way (and this rather follows from the above rules), when
2541             denoting a LoL tree consisting of just one node, this:
2542              
2543             $tree = Tree::DAG_Node->lol_to_tree( 'Lonely' );
2544              
2545             is okay, although it'd probably occur to you to denote it only as:
2546              
2547             $tree = Tree::DAG_Node->lol_to_tree( ['Lonely'] );
2548              
2549             which is of course fine, too.
2550              
2551             =head2 mother()
2552              
2553             This returns what node is $node's mother. This is undef if $node has
2554             no mother -- i.e., if it is a root.
2555              
2556             See also L and L.
2557              
2558             =head2 my_daughter_index()
2559              
2560             Returns what index this daughter is, in its mother's C list.
2561             In other words, if $node is ($node->mother->daughters)[3], then
2562             $node->my_daughter_index returns 3.
2563              
2564             As a special case, returns 0 if $node has no mother.
2565              
2566             =head2 name()
2567              
2568             =head2 name(SCALAR)
2569              
2570             In the first form, returns the value of the node object's "name"
2571             attribute. In the second form, sets it to the value of SCALAR.
2572              
2573             =head2 new($hashref)
2574              
2575             These options are supported in $hashref:
2576              
2577             =over 4
2578              
2579             =item o attributes => A hashref of attributes
2580              
2581             =item o daughters => An arrayref of nodes
2582              
2583             =item o mother => A node
2584              
2585             =item o name => A string
2586              
2587             =back
2588              
2589             See also L for a long discussion on object creation.
2590              
2591             =head2 new_daughter()
2592              
2593             =head2 new_daughter($options)
2594              
2595             This B a B node (of the same class as $mother), and
2596             adds it to the (right) end of the daughter list of $mother. This is
2597             essentially the same as going
2598              
2599             $daughter = $mother->new;
2600             $mother->add_daughter($daughter);
2601              
2602             but is rather more efficient because (since $daughter is guaranteed new
2603             and isn't linked to/from anything), it doesn't have to check that
2604             $daughter isn't an ancestor of $mother, isn't already daughter to a
2605             mother it needs to be unlinked from, isn't already in $mother's
2606             daughter list, etc.
2607              
2608             As you'd expect for a constructor, it returns the node-object created.
2609              
2610             Note that if you radically change 'mother'/'daughters' bookkeeping,
2611             you may have to change this routine, since it's one of the places
2612             that directly writes to 'daughters' and 'mother'.
2613              
2614             =head2 new_daughter_left()
2615              
2616             =head2 new_daughter_left($options)
2617              
2618             This is just like $mother->new_daughter, but adds the new daughter
2619             to the left (start) of $mother's daughter list.
2620              
2621             Note that if you radically change 'mother'/'daughters' bookkeeping,
2622             you may have to change this routine, since it's one of the places
2623             that directly writes to 'daughters' and 'mother'.
2624              
2625             =head2 node2string($options, $node, $vert_dashes)
2626              
2627             Returns a string of the node's name and attributes, with a leading indent, suitable for printing.
2628              
2629             Possible keys in the $options hashref:
2630              
2631             =over 4
2632              
2633             =item o no_attributes => $Boolean
2634              
2635             If 1, the node's attributes are not included in the string returned.
2636              
2637             Default: 0 (include attributes).
2638              
2639             =back
2640              
2641             Ignore the parameter $vert_dashes. The code uses it as temporary storage.
2642              
2643             Calls L.
2644              
2645             Called by L.
2646              
2647             =head2 quote_name($name)
2648              
2649             Returns the string "'$name'", which is used in various methods for outputting node names.
2650              
2651             =head2 random_network($options)
2652              
2653             This method can be called as a class method or as an object method.
2654              
2655             In the first case, constructs a randomly arranged network under a new
2656             node, and returns the root node of that tree. In the latter case,
2657             constructs the network under $node.
2658              
2659             Currently, this is implemented a bit half-heartedly, and
2660             half-wittedly. I basically needed to make up random-looking networks
2661             to stress-test the various tree-dumper methods, and so wrote this. If
2662             you actually want to rely on this for any application more
2663             serious than that, I suggest examining the source code and seeing if
2664             this does really what you need (say, in reliability of randomness);
2665             and feel totally free to suggest changes to me (especially in the form
2666             of "I rewrote L, here's the code...")
2667              
2668             It takes four options:
2669              
2670             =over 4
2671              
2672             =item o max_node_count -- maximum number of nodes this tree will be allowed to have (counting the
2673             root)
2674              
2675             Default: 25.
2676              
2677             =item o min_depth -- minimum depth for the tree
2678              
2679             Leaves can be generated only after this depth is reached, so the tree will be at
2680             least this deep -- unless max_node_count is hit first.
2681              
2682             Default: 2.
2683              
2684             =item o max_depth -- maximum depth for the tree
2685              
2686             The tree will not be deeper than this.
2687              
2688             Default: 3 plus min_depth.
2689              
2690             =item o max_children -- maximum number of children any mother in the tree can have.
2691              
2692             Default: 4.
2693              
2694             =back
2695              
2696             =head2 read_attributes($s)
2697              
2698             Parses the string $s and extracts the name and attributes, assuming the format is as generated by
2699             L.
2700              
2701             This bascially means the attribute string was generated by L.
2702              
2703             Attributes may be absent, in which case they default to {}.
2704              
2705             Returns a new node with this name and these attributes.
2706              
2707             This method is for use by L.
2708              
2709             See t/tree.without.attributes.txt and t/tree.with.attributes.txt for sample data.
2710              
2711             =head2 read_tree($file_name)
2712              
2713             Returns the root of the tree read from $file_name.
2714              
2715             The file must have been written by re-directing the output of
2716             L to a file, since it makes assumptions about the format
2717             of the stringified attributes.
2718              
2719             read_tree() works with utf-8 data. See t/read.tree.t and t/tree.utf8.attributes.txt.
2720              
2721             Note: To call this method you need a caller. It'll be a tree of 1 node. The reason is that inside
2722             this method it calls various other methods, and for these calls it needs $self. That way, those
2723             methods can be called from anywhere, and not just from within read_tree().
2724              
2725             For reading and writing trees to databases, see L.
2726              
2727             Calls L.
2728              
2729             =head2 remove_daughter(LIST)
2730              
2731             An exact synonym for L.
2732              
2733             =head2 remove_daughters(LIST)
2734              
2735             This removes the nodes listed in LIST from $mother's daughter list.
2736             This is a no-operation if LIST is empty. If there are things in LIST
2737             that aren't a current daughter of $mother, they are ignored.
2738              
2739             Not to be confused with L.
2740              
2741             =head2 replace_with(LIST)
2742              
2743             This replaces $node in its mother's daughter list, by unlinking $node
2744             and replacing it with the items in LIST. This returns a list consisting
2745             of $node followed by LIST, i.e., the nodes that replaced it.
2746              
2747             LIST can include $node itself (presumably at most once). LIST can
2748             also be the empty list. However, if any items in LIST are sisters to
2749             $node, they are ignored, and are not in the copy of LIST passed as the
2750             return value.
2751              
2752             As you might expect for any linking operation, the items in LIST
2753             cannot be $node's mother, or any ancestor to it; and items in LIST are,
2754             of course, unlinked from their mothers (if they have any) as they're
2755             linked to $node's mother.
2756              
2757             (In the special (and bizarre) case where $node is root, this simply calls
2758             $this->unlink_from_mother on all the items in LIST, making them roots of
2759             their own trees.)
2760              
2761             Note that the daughter-list of $node is not necessarily affected; nor
2762             are the daughter-lists of the items in LIST. I mention this in case you
2763             think replace_with switches one node for another, with respect to its
2764             mother list B its daughter list, leaving the rest of the tree
2765             unchanged. If that's what you want, replacing $Old with $New, then you
2766             want:
2767              
2768             $New->set_daughters($Old->clear_daughters);
2769             $Old->replace_with($New);
2770              
2771             (I can't say $node's and LIST-items' daughter lists are B
2772             affected my replace_with -- they can be affected in this case:
2773              
2774             $N1 = ($node->daughters)[0]; # first daughter of $node
2775             $N2 = ($N1->daughters)[0]; # first daughter of $N1;
2776             $N3 = Tree::DAG_Node->random_network; # or whatever
2777             $node->replace_with($N1, $N2, $N3);
2778              
2779             As a side affect of attaching $N1 and $N2 to $node's mother, they're
2780             unlinked from their parents ($node, and $N1, respectively).
2781             But N3's daughter list is unaffected.
2782              
2783             In other words, this method does what it has to, as you'd expect it
2784             to.
2785              
2786             =head2 replace_with_daughters()
2787              
2788             This replaces $node in its mother's daughter list, by unlinking $node
2789             and replacing it with its daughters. In other words, $node becomes
2790             motherless and daughterless as its daughters move up and take its place.
2791             This returns a list consisting of $node followed by the nodes that were
2792             its daughters.
2793              
2794             In the special (and bizarre) case where $node is root, this simply
2795             unlinks its daughters from it, making them roots of their own trees.
2796              
2797             Effectively the same as $node->replace_with($node->daughters), but more
2798             efficient, since less checking has to be done. (And I also think
2799             $node->replace_with_daughters is a more common operation in
2800             tree-wrangling than $node->replace_with(LIST), so deserves a named
2801             method of its own, but that's just me.)
2802              
2803             Note that if you radically change 'mother'/'daughters' bookkeeping,
2804             you may have to change this routine, since it's one of the places
2805             that directly writes to 'daughters' and 'mother'.
2806              
2807             =head2 right_sister()
2808              
2809             Returns the node that's the immediate right sister of $node. If $node
2810             is the rightmost (or only) daughter of its mother (or has no mother),
2811             then this returns undef.
2812              
2813             See also L and L.
2814              
2815             =head2 right_sisters()
2816              
2817             Returns a list of nodes that're sisters to the right of $node. If
2818             $node is the rightmost (or only) daughter of its mother (or has no
2819             mother), then this returns an empty list.
2820              
2821             See also L and L.
2822              
2823             =head2 root()
2824              
2825             Returns the root of whatever tree $node is a member of. If $node is
2826             the root, then the result is $node itself.
2827              
2828             Not to be confused with L.
2829              
2830             =head2 self_and_descendants()
2831              
2832             Returns a list consisting of itself (as element 0) and all the
2833             descendants of $node. Returns just itself if $node is a
2834             terminal_node.
2835              
2836             (Note that it's spelled "descendants", not "descendents".)
2837              
2838             =head2 self_and_sisters()
2839              
2840             Returns a list of all nodes (going left-to-right) that have the same
2841             mother as $node -- including $node itself. This is just like
2842             $node->mother->daughters, except that that fails where $node is root,
2843             whereas $root->self_and_siblings, as a special case, returns $root.
2844              
2845             (Contrary to how you may interpret how this method is named, "self" is
2846             not (necessarily) the first element of what's returned.)
2847              
2848             =head2 set_daughters(LIST)
2849              
2850             This unlinks all $mother's daughters, and replaces them with the
2851             daughters in LIST.
2852              
2853             Currently implemented as just $mother->clear_daughters followed by
2854             $mother->add_daughters(LIST).
2855              
2856             =head2 simple_lol_to_tree($simple_lol)
2857              
2858             This must be called as a class method.
2859              
2860             This is like lol_to_tree, except that rule 1 doesn't apply -- i.e.,
2861             all scalars (or really, anything not a listref) in the LoL-structure
2862             end up as named terminal nodes, and only terminal nodes get names
2863             (and, of course, that name comes from that scalar value). This method
2864             is useful for making things like expression trees, or at least
2865             starting them off. Consider that this:
2866              
2867             $tree = Tree::DAG_Node->simple_lol_to_tree(
2868             [ 'foo', ['bar', ['baz'], 'quux'], 'zaz', 'pati' ]
2869             );
2870              
2871             converts from something like a Lispish or Iconish tree, if you pretend
2872             the brackets are parentheses.
2873              
2874             Note that there is a (possibly surprising) degenerate case of what I'm
2875             calling a "simple-LoL", and it's like this:
2876              
2877             $tree = Tree::DAG_Node->simple_lol_to_tree('Lonely');
2878              
2879             This is the (only) way you can specify a tree consisting of only a
2880             single node, which here gets the name 'Lonely'.
2881              
2882             =head2 sisters()
2883              
2884             Returns a list of all nodes (going left-to-right) that have the same
2885             mother as $node -- B $node itself. If $node is root,
2886             this returns empty-list.
2887              
2888             =head2 string2hashref($s)
2889              
2890             Returns the hashref built from the string.
2891              
2892             The string is expected to be something like
2893             '{AutoCommit => '1', PrintError => "0", ReportError => 1}'.
2894              
2895             The empty string is returned as {}.
2896              
2897             Called by L.
2898              
2899             =head2 tree_to_lol()
2900              
2901             Returns that tree (starting at $node) represented as a LoL, like what
2902             $lol, above, holds. (This is as opposed to L,
2903             which returns the viewable code like what gets evaluated and stored in
2904             $lol, above.)
2905              
2906             Undefined node names are returned as the string 'undef'.
2907              
2908             See also L.
2909              
2910             Lord only knows what you use this for -- maybe for feeding to
2911             Data::Dumper, in case L doesn't do just what you
2912             want?
2913              
2914             =head2 tree_to_lol_notation($options)
2915              
2916             Dumps a tree (starting at $node) as the sort of LoL-like bracket
2917             notation you see in the above example code. Returns just one big
2918             block of text. The only option is "multiline" -- if true, it dumps
2919             the text as the sort of indented structure as seen above; if false
2920             (and it defaults to false), dumps it all on one line (with no
2921             indenting, of course).
2922              
2923             For example, starting with the tree from the above example,
2924             this:
2925              
2926             print $tree->tree_to_lol_notation, "\n";
2927              
2928             prints the following (which I've broken over two lines for sake of
2929             printability of documentation):
2930              
2931             [[[['Det:The'], [['dog'], 'N'], 'NP'], [["/with rabies\x5c"],
2932             'PP'], 'NP'], [['died'], 'VP'], 'S'],
2933              
2934             Doing this:
2935              
2936             print $tree->tree_to_lol_notation({ multiline => 1 });
2937              
2938             prints the same content, just spread over many lines, and prettily
2939             indented.
2940              
2941             Undefined node names are returned as the string 'undef'.
2942              
2943             =head2 tree_to_simple_lol()
2944              
2945             Returns that tree (starting at $node) represented as a simple-LoL --
2946             i.e., one where non-terminal nodes are represented as listrefs, and
2947             terminal nodes are gotten from the contents of those nodes' "name'
2948             attributes.
2949              
2950             Note that in the case of $node being terminal, what you get back is
2951             the same as $node->name.
2952              
2953             Compare to tree_to_simple_lol_notation.
2954              
2955             Undefined node names are returned as the string 'undef'.
2956              
2957             See also L.
2958              
2959             =head2 tree_to_simple_lol_notation($options)
2960              
2961             A simple-LoL version of tree_to_lol_notation (which see); takes the
2962             same options.
2963              
2964             Undefined node names are returned as the string 'undef'.
2965              
2966             =head2 tree2string($options, [$some_tree])
2967              
2968             Here, the [] represent an optional parameter.
2969              
2970             Returns an arrayref of lines, suitable for printing.
2971              
2972             Draws a nice ASCII-art representation of the tree structure.
2973              
2974             The tree looks like:
2975              
2976             Root. Attributes: {}
2977             |--- Â. Attributes: {# => "ÂÂ"}
2978             | |--- â. Attributes: {# => "ââ"}
2979             | | |--- É. Attributes: {# => "ÉÉ"}
2980             | |--- ä. Attributes: {# => "ää"}
2981             | |--- é. Attributes: {# => "éé"}
2982             | |--- Ñ. Attributes: {# => "ÑÑ"}
2983             | |--- ñ. Attributes: {# => "ññ"}
2984             | |--- Ô. Attributes: {# => "ÔÔ"}
2985             | |--- ô. Attributes: {# => "ôô"}
2986             | |--- ô. Attributes: {# => "ôô"}
2987             |--- ß. Attributes: {# => "ßß"}
2988             |--- ®. Attributes: {# => "®®"}
2989             | |--- ©. Attributes: {# => "©©"}
2990             |--- £. Attributes: {# => "££"}
2991             |--- €. Attributes: {# => "€€"}
2992             |--- √. Attributes: {# => "√√"}
2993             |--- ×xX. Attributes: {# => "×xX×xX"}
2994             |--- í. Attributes: {# => "íí"}
2995             |--- ú. Attributes: {# => "úú"}
2996             |--- «. Attributes: {# => "««"}
2997             |--- ». Attributes: {# => "»»"}
2998              
2999             Or, without attributes:
3000              
3001             Root
3002             |--- Â
3003             | |--- â
3004             | | |--- É
3005             | |--- ä
3006             | |--- é
3007             | |--- Ñ
3008             | |--- ñ
3009             | |--- Ô
3010             | |--- ô
3011             | |--- ô
3012             |--- ß
3013             |--- ®
3014             | |--- ©
3015             |--- £
3016             |--- €
3017             |--- √
3018             |--- ×xX
3019             |--- í
3020             |--- ú
3021             |--- «
3022             |--- »
3023              
3024             See scripts/cut.and.paste.subtrees.pl.
3025              
3026             Example usage:
3027              
3028             print map("$_\n", @{$tree->tree2string});
3029              
3030             Can be called with $some_tree set to any $node, and will print the tree assuming $node is the root.
3031              
3032             If you don't wish to supply options, use tree2string({}, $node).
3033              
3034             Possible keys in the $options hashref (which defaults to {}):
3035              
3036             =over 4
3037              
3038             =item o no_attributes => $Boolean
3039              
3040             If 1, the node's attributes are not included in the string returned.
3041              
3042             Default: 0 (include attributes).
3043              
3044             =back
3045              
3046             Calls L.
3047              
3048             See also L.
3049              
3050             =head2 unlink_from_mother()
3051              
3052             This removes node from the daughter list of its mother. If it has no
3053             mother, this is a no-operation.
3054              
3055             Returns the mother unlinked from (if any).
3056              
3057             =head2 walk_down($options)
3058              
3059             Performs a depth-first traversal of the structure at and under $node.
3060             What it does at each node depends on the value of the options hashref,
3061             which you must provide. There are three options, "callback" and
3062             "callbackback" (at least one of which must be defined, as a sub
3063             reference), and "_depth".
3064              
3065             This is what I does, in pseudocode form:
3066              
3067             =over 4
3068              
3069             =item o Starting point
3070              
3071             Start at the $node given.
3072              
3073             =item o Callback
3074              
3075             If there's a I, call it with $node as the first argument,
3076             and the options hashref as the second argument (which contains the
3077             potentially useful I<_depth>, remember). This function must return
3078             true or false -- if false, it will block the next step:
3079              
3080             =item o Daughters
3081              
3082             If $node has any daughter nodes, increment I<_depth>, and call
3083             $daughter->walk_down($options) for each daughter (in order, of
3084             course), where options_hashref is the same hashref it was called with.
3085             When this returns, decrements I<_depth>.
3086              
3087             =item Callbackback
3088              
3089             If there's a I, call just it as with I (but
3090             tossing out the return value). Note that I returning false
3091             blocks traversal below $node, but doesn't block calling callbackback
3092             for $node. (Incidentally, in the unlikely case that $node has stopped
3093             being a node object, I won't get called.)
3094              
3095             =item o Return
3096              
3097             =back
3098              
3099             $node->walk_down($options) is the way to recursively do things to a tree (if you
3100             start at the root) or part of a tree; if what you're doing is best done
3101             via pre-pre order traversal, use I; if what you're doing is
3102             best done with post-order traversal, use I.
3103             I is even the basis for plenty of the methods in this
3104             class. See the source code for examples both simple and horrific.
3105              
3106             Note that if you don't specify I<_depth>, it effectively defaults to
3107             0. You should set it to scalar($node->ancestors) if you want
3108             I<_depth> to reflect the true depth-in-the-tree for the nodes called,
3109             instead of just the depth below $node. (If $node is the root, there's
3110             no difference, of course.)
3111              
3112             And B, it's a bad idea to modify the tree from the callback.
3113             Unpredictable things may happen. I instead suggest having your callback
3114             add to a stack of things that need changing, and then, once I
3115             is all finished, changing those nodes from that stack.
3116              
3117             Note that the existence of I doesn't mean you can't write
3118             you own special-use traversers.
3119              
3120             =head1 WHEN AND HOW TO DESTROY THE TREE
3121              
3122             It should be clear to you that if you've built a big parse tree or
3123             something, and then you're finished with it, you should call
3124             $some_node->delete_tree on it if you want the memory back.
3125              
3126             But consider this case: you've got this tree:
3127              
3128             A
3129             / | \
3130             B C D
3131             | | \
3132             E X Y
3133              
3134             Let's say you decide you don't want D or any of its descendants in the
3135             tree, so you call D->unlink_from_mother. This does NOT automagically
3136             destroy the tree D-X-Y. Instead it merely splits the tree into two:
3137              
3138             A D
3139             / \ / \
3140             B C X Y
3141             |
3142             E
3143              
3144             To destroy D and its little tree, you have to explicitly call
3145             delete_tree on it.
3146              
3147             Note, however, that if you call C->unlink_from_mother, and if you don't
3148             have a link to C anywhere, then it B magically go away. This is
3149             because nothing links to C -- whereas with the D-X-Y tree, D links to
3150             X and Y, and X and Y each link back to D. Note that calling
3151             C->delete_tree is harmless -- after all, a tree of only one node is
3152             still a tree.
3153              
3154             So, this is a surefire way of getting rid of all $node's children and
3155             freeing up the memory associated with them and their descendants:
3156              
3157             foreach my $it ($node->clear_daughters) { $it->delete_tree }
3158              
3159             Just be sure not to do this:
3160              
3161             foreach my $it ($node->daughters) { $it->delete_tree }
3162             $node->clear_daughters;
3163              
3164             That's bad; the first call to $_->delete_tree will climb to the root
3165             of $node's tree, and nuke the whole tree, not just the bits under $node.
3166             You might as well have just called $node->delete_tree.
3167             (Moreavor, once $node is dead, you can't call clear_daughters on it,
3168             so you'll get an error there.)
3169              
3170             =head1 BUG REPORTS
3171              
3172             If you find a bug in this library, report it to me as soon as possible,
3173             at the address listed in the MAINTAINER section, below. Please try to
3174             be as specific as possible about how you got the bug to occur.
3175              
3176             =head1 HELP!
3177              
3178             If you develop a given routine for dealing with trees in some way, and
3179             use it a lot, then if you think it'd be of use to anyone else, do email
3180             me about it; it might be helpful to others to include that routine, or
3181             something based on it, in a later version of this module.
3182              
3183             It's occurred to me that you might like to (and might yourself develop
3184             routines to) draw trees in something other than ASCII art. If you do so
3185             -- say, for PostScript output, or for output interpretable by some
3186             external plotting program -- I'd be most interested in the results.
3187              
3188             =head1 RAMBLINGS
3189              
3190             This module uses "strict", but I never wrote it with -w warnings in
3191             mind -- so if you use -w, do not be surprised if you see complaints
3192             from the guts of DAG_Node. As long as there is no way to turn off -w
3193             for a given module (instead of having to do it in every single
3194             subroutine with a "local $^W"), I'm not going to change this. However,
3195             I do, at points, get bursts of ambition, and I try to fix code in
3196             DAG_Node that generates warnings, I -- which is
3197             only occasionally. Feel free to email me any patches for any such
3198             fixes you come up with, tho.
3199              
3200             Currently I don't assume (or enforce) anything about the class
3201             membership of nodes being manipulated, other than by testing whether
3202             each one provides a method L, a la:
3203              
3204             die "Not a node!!!" unless UNIVERSAL::can($node, "is_node");
3205              
3206             So, as far as I'm concerned, a given tree's nodes are free to belong to
3207             different classes, just so long as they provide/inherit L, the
3208             few methods that this class relies on to navigate the tree, and have the
3209             same internal object structure, or a superset of it. Presumably this
3210             would be the case for any object belonging to a class derived from
3211             C, or belonging to C itself.
3212              
3213             When routines in this class access a node's "mother" attribute, or its
3214             "daughters" attribute, they (generally) do so directly (via
3215             $node->{'mother'}, etc.), for sake of efficiency. But classes derived
3216             from this class should probably do this instead thru a method (via
3217             $node->mother, etc.), for sake of portability, abstraction, and general
3218             goodness.
3219              
3220             However, no routines in this class (aside from, necessarily, I<_init()>,
3221             I<_init_name()>, and L) access the "name" attribute directly;
3222             routines (like the various tree draw/dump methods) get the "name" value
3223             thru a call to $obj->name(). So if you want the object's name to not be
3224             a real attribute, but instead have it derived dynamically from some feature
3225             of the object (say, based on some of its other attributes, or based on
3226             its address), you can to override the L method, without causing
3227             problems. (Be sure to consider the case of $obj->name as a write
3228             method, as it's used in I and L.)
3229              
3230             =head1 FAQ
3231              
3232             =head2 Which is the best tree processing module?
3233              
3234             C, as it happens. More details: L.
3235              
3236             =head2 How to process every node in tree?
3237              
3238             See L. $options normally looks like this, assuming we wish to pass in
3239             an arrayref as a stack:
3240              
3241             my(@stack);
3242              
3243             $tree -> walk_down
3244             ({
3245             callback =>
3246             sub
3247             {
3248             my(@node, $options) = @_;
3249              
3250             # Process $node, using $options...
3251              
3252             push @{$$options{stack} }, $node -> name;
3253              
3254             return 1; # Keep walking.
3255             },
3256             _depth => 0,
3257             stack => \@stack,
3258             });
3259              
3260             # Process @stack...
3261              
3262             =head2 How do I switch from Tree to Tree::DAG_Node?
3263              
3264             =over 4
3265              
3266             =item o The node's name
3267              
3268             In C you use $node -> value and in C it's $node -> name.
3269              
3270             =item o The node's attributes
3271              
3272             In C you use $node -> meta and in C it's $node -> attributes.
3273              
3274             =back
3275              
3276             =head2 Are there techniques for processing lists of nodes?
3277              
3278             =over 4
3279              
3280             =item o Copy the daughter list, and change it
3281              
3282             @them = $mother->daughters;
3283             @removed = splice(@them, 0, 2, @new_nodes);
3284              
3285             $mother->set_daughters(@them);
3286              
3287             =item o Select a sub-set of nodes
3288              
3289             $mother->set_daughters
3290             (
3291             grep($_->name =~ /wanted/, $mother->daughters)
3292             );
3293              
3294             =back
3295              
3296             =head2 Why did you break up the sections of methods in the POD?
3297              
3298             Because I want to list the methods in alphabetical order.
3299              
3300             =head2 Why did you move the POD to the end?
3301              
3302             Because the apostrophes in the text confused the syntax hightlighter in my editor UltraEdit.
3303              
3304             =head1 SEE ALSO
3305              
3306             =over 4
3307              
3308             =item o L, L and L
3309              
3310             Sean is also the author of these modules.
3311              
3312             =item o L
3313              
3314             Lightweight.
3315              
3316             =item o L
3317              
3318             Lightweight.
3319              
3320             =item o L
3321              
3322             Lightweight.
3323              
3324             =item o L
3325              
3326             Lightweight.
3327              
3328             =item o L
3329              
3330             Uses L.
3331              
3332             =back
3333              
3334             C itself is also lightweight.
3335              
3336             =head1 REFERENCES
3337              
3338             Wirth, Niklaus. 1976. I
3339             Prentice-Hall, Englewood Cliffs, NJ.
3340              
3341             Knuth, Donald Ervin. 1997. I
3342             Third Edition: Fundamental Algorithms>. Addison-Wesley, Reading, MA.
3343              
3344             Wirth's classic, currently and lamentably out of print, has a good
3345             section on trees. I find it clearer than Knuth's (if not quite as
3346             encyclopedic), probably because Wirth's example code is in a
3347             block-structured high-level language (basically Pascal), instead
3348             of in assembler (MIX).
3349              
3350             Until some kind publisher brings out a new printing of Wirth's book,
3351             try poking around used bookstores (or C) for a copy.
3352             I think it was also republished in the 1980s under the title
3353             I, and in a German edition called
3354             I. (That is, I'm sure books by Knuth
3355             were published under those titles, but I'm I that they're just
3356             later printings/editions of I
3357             Programs>.)
3358              
3359             =head1 MACHINE-READABLE CHANGE LOG
3360              
3361             The file Changes was converted into Changelog.ini by L.
3362              
3363             =head1 REPOSITORY
3364              
3365             L
3366              
3367             =head1 SUPPORT
3368              
3369             Email the author, or log a bug on RT:
3370              
3371             L.
3372              
3373             =head1 ACKNOWLEDGEMENTS
3374              
3375             The code to print the tree, in tree2string(), was adapted from
3376             L by the dread Stevan Little.
3377              
3378             =head1 MAINTAINER
3379              
3380             David Hand, C<< >> up to V 1.06.
3381              
3382             Ron Savage C<< >> from V 1.07.
3383              
3384             In this POD, usage of 'I' refers to Sean, up until V 1.07.
3385              
3386             =head1 AUTHOR
3387              
3388             Sean M. Burke, C<< >>
3389              
3390             =head1 COPYRIGHT, LICENSE, AND DISCLAIMER
3391              
3392             Copyright 1998-2001, 2004, 2007 by Sean M. Burke and David Hand.
3393              
3394             This program is free software. It is released under the Artistic License 2.0.
3395             See L.
3396              
3397             This program is distributed in the hope that it will be useful, but
3398             without any warranty; without even the implied warranty of
3399             merchantability or fitness for a particular purpose.
3400              
3401             =cut