2 package Tree::DAG_Node;
5 use vars qw(@ISA $Debug $VERSION);
12 Tree::DAG_Node - (super)class for representing nodes in a tree
16 Using as a base class:
18 package Game::Tree::Node; # or whatever you're doing
20 @ISA = qw(Tree::DAG_Node);
21 ...your own methods overriding/extending
22 the methods in Tree::DAG_Node...
24 Using as a class of its own:
27 my $root = Tree::DAG_Node->new();
28 $root->name("I'm the tops");
29 my $new_daughter = $root->new_daughter;
30 $new_daughter->name("More");
35 This class encapsulates/makes/manipulates objects that represent nodes
36 in a tree structure. The tree structure is not an object itself, but
37 is emergent from the linkages you create between nodes. This class
38 provides the methods for making linkages that can be used to build up
39 a tree, while preventing you from ever making any kinds of linkages
40 which are not allowed in a tree (such as having a node be its own
41 mother or ancestor, or having a node have two mothers).
43 This is what I mean by a "tree structure", a bit redundantly stated:
45 * A tree is a special case of an acyclic directed graph.
47 * A tree is a network of nodes where there's exactly one root
48 node (i.e., 'the top'), and the only primary relationship between nodes
49 is the mother-daugher relationship.
51 * No node can be its own mother, or its mother's mother, etc.
53 * Each node in the tree has exactly one "parent" (node in the "up"
54 direction) -- except the root, which is parentless.
56 * Each node can have any number (0 to any finite number) of daughter
57 nodes. A given node's daughter nodes constitute an I<ordered> list.
58 (However, you are free to consider this ordering irrelevant.
59 Some applications do need daughters to be ordered, so I chose to
60 consider this the general case.)
62 * A node can appear in only one tree, and only once in that tree.
63 Notably (notable because it doesn't follow from the two above points),
64 a node cannot appear twice in its mother's daughter list.
66 * In other words, there's an idea of up (toward the root) versus
67 down (away from the root), and left (i.e., toward the start (index 0)
68 of a given node's daughter list) versus right (toward the end of a
69 given node's daughter list).
71 Trees as described above have various applications, among them:
72 representing syntactic constituency, in formal linguistics;
73 representing contingencies in a game tree; representing abstract
74 syntax in the parsing of any computer language -- whether in
75 expression trees for programming languages, or constituency in the
76 parse of a markup language document. (Some of these might not use the
77 fact that daughters are ordered.)
79 (Note: B-Trees are a very special case of the above kinds of trees,
80 and are best treated with their own class. Check CPAN for modules
81 encapsulating B-Trees; or if you actually want a database, and for
82 some reason ended up looking here, go look at L<AnyDBM_File>.)
84 Many base classes are not usable except as such -- but Tree::DAG_Node
85 can be used as a normal class. You can go ahead and say:
88 my $root = Tree::DAG_Node->new();
89 $root->name("I'm the tops");
90 $new_daughter = Tree::DAG_Node->new();
91 $new_daughter->name("More");
92 $root->add_daughter($new_daughter);
94 and so on, constructing and linking objects from Tree::DAG_Node and
95 making useful tree structures out of them.
97 =head1 A NOTE TO THE READER
99 This class is big and provides lots of methods. If your problem is
100 simple (say, just representing a simple parse tree), this class might
101 seem like using an atomic sledgehammer to swat a fly. But the
102 complexity of this module's bells and whistles shouldn't detract from
103 the efficiency of using this class for a simple purpose. In fact, I'd
104 be very surprised if any one user ever had use for more that even a
105 third of the methods in this class. And remember: an atomic
106 sledgehammer B<will> kill that fly.
108 =head1 OBJECT CONTENTS
110 Implementationally, each node in a tree is an object, in the sense of
111 being an arbitrarily complex data structure that belongs to a class
112 (presumably Tree::DAG_Node, or ones derived from it) that provides
115 The attributes of a node-object are:
119 =item mother -- this node's mother. undef if this is a root.
121 =item daughters -- the (possibly empty) list of daughters of this node.
123 =item name -- the name for this node.
125 Need not be unique, or even printable. This is printed in some of the
126 various dumper methods, but it's up to you if you don't put anything
127 meaningful or printable here.
129 =item attributes -- whatever the user wants to use it for.
131 Presumably a hashref to whatever other attributes the user wants to
132 store without risk of colliding with the object's real attributes.
133 (Example usage: attributes to an SGML tag -- you definitely wouldn't
134 want the existence of a "mother=foo" pair in such a tag to collide with
135 a node object's 'mother' attribute.)
137 Aside from (by default) initializing it to {}, and having the access
138 method called "attributes" (described a ways below), I don't do
139 anything with the "attributes" in this module. I basically intended
140 this so that users who don't want/need to bother deriving a class
141 from Tree::DAG_Node, could still attach whatever data they wanted in a
146 "mother" and "daughters" are attributes that relate to linkage -- they
147 are never written to directly, but are changed as appropriate by the
148 "linkage methods", discussed below.
150 The other two (and whatever others you may add in derived classes) are
151 simply accessed thru the same-named methods, discussed further below.
153 =head2 ABOUT THE DOCUMENTED INTERFACE
155 Stick to the documented interface (and comments in the source --
156 especially ones saying "undocumented!" and/or "disfavored!" -- do not
157 count as documentation!), and don't rely on any behavior that's not in
158 the documented interface.
160 Specifically, unless the documentation for a particular method says
161 "this method returns thus-and-such a value", then you should not rely on
162 it returning anything meaningful.
164 A I<passing> acquintance with at least the broader details of the source
165 code for this class is assumed for anyone using this class as a base
166 class -- especially if you're overriding existing methods, and
167 B<definitely> if you're overriding linkage methods.
169 =head1 MAIN CONSTRUCTOR, AND INITIALIZER
173 =item the constructor CLASS->new() or CLASS->new({...options...})
175 This creates a new node object, calls $object->_init({...options...})
176 to provide it sane defaults (like: undef name, undef mother, no
177 daughters, 'attributes' setting of a new empty hashref), and returns
178 the object created. (If you just said "CLASS->new()" or "CLASS->new",
179 then it pretends you called "CLASS->new({})".)
181 Currently no options for putting in {...options...} are part
182 of the documented interface, but the options is here in case
183 you want to add such behavior in a derived class.
185 Read on if you plan on using Tree::DAG_New as a base class.
186 (Otherwise feel free to skip to the description of _init.)
188 There are, in my mind, two ways to do object construction:
190 Way 1: create an object, knowing that it'll have certain uninteresting
191 sane default values, and then call methods to change those values to
192 what you want. Example:
194 $node = Tree::DAG_Node->new;
195 $node->name('Supahnode!');
196 $root->add_daughter($node);
197 $node->add_daughters(@some_others)
199 Way 2: be able to specify some/most/all the object's attributes in
200 the call to the constructor. Something like:
202 $node = Tree::DAG_Node->new({
203 name => 'Supahnode!',
205 daughters => \@some_others
208 After some deliberation, I've decided that the second way is a Bad
209 Thing. First off, it is B<not> markedly more concise than the first
210 way. Second off, it often requires subtly different syntax (e.g.,
211 \@some_others vs @some_others). It just complicates things for the
212 programmer and the user, without making either appreciably happier.
214 (This is not to say that options in general for a constructor are bad
215 -- C<random_network>, discussed far below, necessarily takes options.
216 But note that those are not options for the default values of
219 Anyway, if you use Tree::DAG_Node as a superclass, and you add
220 attributes that need to be initialized, what you need to do is provide
221 an _init method that calls $this->SUPER::_init($options) to use its
222 superclass's _init method, and then initializes the new attributes:
225 my($this, $options) = @_[0,1];
226 $this->SUPER::_init($options); # call my superclass's _init to
227 # init all the attributes I'm inheriting
229 # Now init /my/ new attributes:
230 $this->{'amigos'} = []; # for example
233 ...or, as I prefer when I'm being a neat freak:
236 my($this, $options) = @_[0,1];
237 $this->SUPER::_init($options);
239 $this->_init_amigos($options);
244 # Or my($this,$options) = @_[0,1]; if I'm using $options
245 $this->{'amigos'} = [];
249 In other words, I like to have each attribute initialized thru a
250 method named _init_[attribute], which should expect the object as
251 $_[0] and the the options hashref (or {} if none was given) as $_[1].
252 If you insist on having your _init recognize options for setting
253 attributes, you might as well have them dealt with by the appropriate
254 _init_[attribute] method, like this:
257 my($this, $options) = @_[0,1];
258 $this->SUPER::_init($options);
260 $this->_init_amigos($options);
264 my($this,$options) = @_[0,1]; # I need options this time
265 $this->{'amigos'} = [];
266 $this->amigos(@{$options->{'amigos'}}) if $options->{'amigos'};
269 All this bookkeeping looks silly with just one new attribute in a
270 class derived straight from Tree::DAG_Node, but if there's lots of new
271 attributes running around, and if you're deriving from a class derived
272 from a class derived from Tree::DAG_Node, then tidy
273 stratification/modularization like this can keep you sane.
275 =item the constructor $obj->new() or $obj->new({...options...})
277 Just another way to get at the C<new> method. This B<does not copy>
278 $obj, but merely constructs a new object of the same class as it.
279 Saves you the bother of going $class = ref $obj; $obj2 = $class->new;
283 sub new { # constructor
284 # Presumably you won't EVER need to override this -- _init is what
285 # you'd override in order to set an object's default attribute values.
287 $class = ref($class) if ref($class); # tchristic style. why not?
289 my $o = ref($_[0]) eq 'HASH' ? $_[0] : {}; # o for options hashref
290 my $it = bless( {}, $class );
291 print "Constructing $it in class $class\n" if $Debug;
296 ###########################################################################
298 =item the method $node->_init({...options...})
300 Initialize the object's attribute values. See the discussion above.
301 Presumably this should be called only by the guts of the C<new>
302 constructor -- never by the end user.
304 Currently there are no documented options for putting in
305 {...options...}, but (in case you want to disregard the above rant)
306 the option exists for you to use {...options...} for something useful
309 Please see the source for more information.
311 =item see also (below) the constructors "new_daughter" and "new_daughter_left"
319 my $o = ref($_[0]) eq 'HASH' ? $_[0] : {};
321 # Sane initialization.
322 $this->_init_mother($o);
323 $this->_init_daughters($o);
324 $this->_init_name($o);
325 $this->_init_attributes($o);
330 sub _init_mother { # to be called by an _init
331 my($this, $o) = @_[0,1];
333 $this->{'mother'} = undef;
335 # Undocumented and disfavored. Consider this just an example.
336 ( $o->{'mother'} )->add_daughter($this)
337 if defined($o->{'mother'}) && ref($o->{'mother'});
338 # DO NOT use this option (as implemented) with new_daughter or
339 # new_daughter_left!!!!!
340 # BAD THINGS MAY HAPPEN!!!
343 sub _init_daughters { # to be called by an _init
344 my($this, $o) = @_[0,1];
346 $this->{'daughters'} = [];
348 # Undocumented and disfavored. Consider this just an example.
349 $this->set_daughters( @{$o->{'daughters'}} )
350 if ref($o->{'daughters'}) && (@{$o->{'daughters'}});
351 # DO NOT use this option (as implemented) with new_daughter or
352 # new_daughter_left!!!!!
353 # BAD THINGS MAY HAPPEN!!!
356 sub _init_name { # to be called by an _init
357 my($this, $o) = @_[0,1];
359 $this->{'name'} = undef;
361 # Undocumented and disfavored. Consider this just an example.
362 $this->name( $o->{'name'} ) if exists $o->{'name'};
365 sub _init_attributes { # to be called by an _init
366 my($this, $o) = @_[0,1];
368 $this->{'attributes'} = {};
370 # Undocumented and disfavored. Consider this just an example.
371 $this->attributes( $o->{'attributes'} ) if exists $o->{'attributes'};
374 ###########################################################################
375 ###########################################################################
377 =head1 LINKAGE-RELATED METHODS
381 =item $node->daughters
383 This returns the (possibly empty) list of daughters for $node.
387 sub daughters { # read-only attrib-method: returns a list.
390 if(@_) { # undoc'd and disfavored to use as a write-method
391 Carp::croak "Don't set daughters with doughters anymore\n";
392 Carp::carp "my parameter must be a listref" unless ref($_[0]);
393 $this->{'daughters'} = $_[0];
394 $this->_update_daughter_links;
396 #return $this->{'daughters'};
397 return @{$this->{'daughters'} || []};
400 ###########################################################################
404 This returns what node is $node's mother. This is undef if $node has
405 no mother -- i.e., if it is a root.
409 sub mother { # read-only attrib-method: returns an object (the mother node)
411 Carp::croak "I'm a read-only method!" if @_;
412 return $this->{'mother'};
415 ###########################################################################
416 ###########################################################################
418 =item $mother->add_daughters( LIST )
420 This method adds the node objects in LIST to the (right) end of
421 $mother's C<daughter> list. Making a node N1 the daughter of another
422 node N2 also means that N1's C<mother> attribute is "automatically" set
423 to N2; it also means that N1 stops being anything else's daughter as
424 it becomes N2's daughter.
426 If you try to make a node its own mother, a fatal error results. If
427 you try to take one of a a node N1's ancestors and make it also a
428 daughter of N1, a fatal error results. A fatal error results if
429 anything in LIST isn't a node object.
431 If you try to make N1 a daughter of N2, but it's B<already> a daughter
432 of N2, then this is a no-operation -- it won't move such nodes to the
433 end of the list or anything; it just skips doing anything with them.
435 =item $node->add_daughter( LIST )
437 An exact synonym for $node->add_daughters(LIST)
441 sub add_daughters { # write-only method
442 my($mother, @daughters) = @_;
443 return unless @daughters; # no-op
445 $mother->_add_daughters_wrapper(
446 sub { push @{$_[0]}, $_[1]; },
451 sub add_daughter { # alias
452 my($it,@them) = @_; $it->add_daughters(@them);
455 =item $mother->add_daughters_left( LIST )
457 This method is just like C<add_daughters>, except that it adds the
458 node objects in LIST to the (left) beginning of $mother's daughter
459 list, instead of the (right) end of it.
461 =item $node->add_daughter_left( LIST )
463 An exact synonym for $node->add_daughters_left( LIST )
467 sub add_daughters_left { # write-only method
468 my($mother, @daughters) = @_;
469 return unless @daughters;
471 $mother->_add_daughters_wrapper(
472 sub { unshift @{$_[0]}, $_[1]; },
477 sub add_daughter_left { # alias
478 my($it,@them) = @_; $it->add_daughters_left(@them);
483 The above link-making methods perform basically an C<unshift> or
484 C<push> on the mother node's daughter list. To get the full range of
485 list-handling functionality, copy the daughter list, and change it,
486 and then call C<set_daughters> on the result:
488 @them = $mother->daughters;
489 @removed = splice(@them, 0,2, @new_nodes);
490 $mother->set_daughters(@them);
492 Or consider a structure like:
494 $mother->set_daughters(
495 grep($_->name =~ /NP/ ,
504 ## Used by the adding methods
505 # (except maybe new_daughter, and new_daughter_left)
507 sub _add_daughters_wrapper {
508 my($mother, $callback, @daughters) = @_;
509 return unless @daughters;
512 @ancestors{ $mother->ancestors } = undef;
513 # This could be made more efficient by not bothering to compile
514 # the ancestor list for $mother if all the nodes to add are
516 # But then you have to CHECK if they're daughterless.
517 # If $mother is [big number] generations down, then it's worth checking.
519 foreach my $daughter (@daughters) { # which may be ()
520 Carp::croak "daughter must be a node object!" unless UNIVERSAL::can($daughter, 'is_node');
522 printf "Mother : %s (%s)\n", $mother, ref $mother if $Debug;
523 printf "Daughter: %s (%s)\n", $daughter, ref $daughter if $Debug;
524 printf "Adding %s to %s\n",
525 ($daughter->name() || $daughter),
526 ($mother->name() || $mother) if $Debug > 1;
528 Carp::croak "mother can't be its own daughter!" if $mother eq $daughter;
530 $daughter->cyclicity_fault(
531 "$daughter (" . ($daughter->name || 'no_name') .
532 ") is an ancestor of $mother (" . ($mother->name || 'no_name') .
533 "), so can't became its daughter."
534 ) if exists $ancestors{$daughter};
536 my $old_mother = $daughter->{'mother'};
538 next if defined($old_mother) && ref($old_mother) && $old_mother eq $mother;
539 # noop if $daughter is already $mother's daughter
541 $old_mother->remove_daughters($daughter)
542 if defined($old_mother) && ref($old_mother);
544 &{$callback}($mother->{'daughters'}, $daughter);
546 $mother->_update_daughter_links; # need only do this at the end
551 ###########################################################################
552 ###########################################################################
554 sub _update_daughter_links {
555 # Eliminate any duplicates in my daughters list, and update
556 # all my daughters' links to myself.
559 my $them = $this->{'daughters'};
561 # Eliminate duplicate daughters.
563 @$them = grep { ref($_) && not($seen{$_}++) } @$them;
564 # not that there should ever be duplicate daughters anyhoo.
566 foreach my $one (@$them) { # linkage bookkeeping
567 Carp::croak "daughter <$one> isn't an object!" unless ref $one;
568 $one->{'mother'} = $this;
573 ###########################################################################
577 sub _update_links { # update all descendant links for ancestorship below
579 # note: it's "descendant", not "descendent"
580 # see <http://www.lenzo.com/~sburke/stuff/english_ant_and_ent.html>
582 # $this->no_cyclicity;
586 $this->_update_daughter_links;
592 ###########################################################################
593 ###########################################################################
595 =item the constructor $daughter = $mother->new_daughter, or
597 =item the constructor $daughter = $mother->new_daughter({...options...})
599 This B<constructs> a B<new> node (of the same class as $mother), and
600 adds it to the (right) end of the daughter list of $mother. This is
601 essentially the same as going
603 $daughter = $mother->new;
604 $mother->add_daughter($daughter);
606 but is rather more efficient because (since $daughter is guaranteed new
607 and isn't linked to/from anything), it doesn't have to check that
608 $daughter isn't an ancestor of $mother, isn't already daughter to a
609 mother it needs to be unlinked from, isn't already in $mother's
612 As you'd expect for a constructor, it returns the node-object created.
616 # Note that if you radically change 'mother'/'daughters' bookkeeping,
617 # you may have to change this routine, since it's one of the places
618 # that directly writes to 'daughters' and 'mother'.
621 my($mother, @options) = @_;
622 my $daughter = $mother->new(@options);
624 push @{$mother->{'daughters'}}, $daughter;
625 $daughter->{'mother'} = $mother;
630 =item the constructor $mother->new_daughter_left, or
632 =item $mother->new_daughter_left({...options...})
634 This is just like $mother->new_daughter, but adds the new daughter
635 to the left (start) of $mother's daughter list.
639 # Note that if you radically change 'mother'/'daughters' bookkeeping,
640 # you may have to change this routine, since it's one of the places
641 # that directly writes to 'daughters' and 'mother'.
643 sub new_daughter_left {
644 my($mother, @options) = @_;
645 my $daughter = $mother->new(@options);
647 unshift @{$mother->{'daughters'}}, $daughter;
648 $daughter->{'mother'} = $mother;
653 ###########################################################################
655 =item $mother->remove_daughters( LIST )
657 This removes the nodes listed in LIST from $mother's daughter list.
658 This is a no-operation if LIST is empty. If there are things in LIST
659 that aren't a current daughter of $mother, they are ignored.
661 Not to be confused with $mother->clear_daughters.
665 sub remove_daughters { # write-only method
666 my($mother, @daughters) = @_;
667 Carp::croak "mother must be an object!" unless ref $mother;
668 return unless @daughters;
671 @daughters = grep {ref($_)
672 and defined($_->{'mother'})
673 and $mother eq $_->{'mother'}
675 return unless @daughters;
676 @to_delete{ @daughters } = undef;
678 # This could be done better and more efficiently, I guess.
679 foreach my $daughter (@daughters) {
680 $daughter->{'mother'} = undef;
682 my $them = $mother->{'daughters'};
683 @$them = grep { !exists($to_delete{$_}) } @$them;
685 # $mother->_update_daughter_links; # unnecessary
689 =item $node->remove_daughter( LIST )
691 An exact synonym for $node->remove_daughters( LIST )
695 sub remove_daughter { # alias
696 my($it,@them) = @_; $it->remove_daughters(@them);
699 =item $node->unlink_from_mother
701 This removes node from the daughter list of its mother. If it has no
702 mother, this is a no-operation.
704 Returns the mother unlinked from (if any).
708 sub unlink_from_mother {
710 my $mother = $node->{'mother'};
711 $mother->remove_daughters($node) if defined($mother) && ref($mother);
715 ###########################################################################
717 =item $mother->clear_daughters
719 This unlinks all $mother's daughters.
720 Returns the the list of what used to be $mother's daughters.
722 Not to be confused with $mother->remove_daughters( LIST ).
726 sub clear_daughters { # write-only method
728 my @daughters = @{$mother->{'daughters'}};
730 @{$mother->{'daughters'}} = ();
731 foreach my $one (@daughters) {
732 next unless UNIVERSAL::can($one, 'is_node'); # sanity check
733 $one->{'mother'} = undef;
735 # Another, simpler, way to do it:
736 # $mother->remove_daughters($mother->daughters);
738 return @daughters; # NEW
740 #--------------------------------------------------------------------------
742 =item $mother->set_daughters( LIST )
744 This unlinks all $mother's daughters, and replaces them with the
747 Currently implemented as just $mother->clear_daughters followed by
748 $mother->add_daughters( LIST ).
752 sub set_daughters { # write-only method
753 my($mother, @them) = @_;
754 $mother->clear_daughters;
755 $mother->add_daughters(@them) if @them;
756 # yup, it's that simple
759 #--------------------------------------------------------------------------
761 =item $node->replace_with( LIST )
763 This replaces $node in its mother's daughter list, by unlinking $node
764 and replacing it with the items in LIST. This returns a list consisting
765 of $node followed by LIST, i.e., the nodes that replaced it.
767 LIST can include $node itself (presumably at most once). LIST can
768 also be empty-list. However, if any items in LIST are sisters to
769 $node, they are ignored, and are not in the copy of LIST passed as the
772 As you might expect for any linking operation, the items in LIST
773 cannot be $node's mother, or any ancestor to it; and items in LIST are,
774 of course, unlinked from their mothers (if they have any) as they're
775 linked to $node's mother.
777 (In the special (and bizarre) case where $node is root, this simply calls
778 $this->unlink_from_mother on all the items in LIST, making them roots of
781 Note that the daughter-list of $node is not necessarily affected; nor
782 are the daughter-lists of the items in LIST. I mention this in case you
783 think replace_with switches one node for another, with respect to its
784 mother list B<and> its daughter list, leaving the rest of the tree
785 unchanged. If that's what you want, replacing $Old with $New, then you
788 $New->set_daughters($Old->clear_daughters);
789 $Old->replace_with($New);
791 (I can't say $node's and LIST-items' daughter lists are B<never>
792 affected my replace_with -- they can be affected in this case:
794 $N1 = ($node->daughters)[0]; # first daughter of $node
795 $N2 = ($N1->daughters)[0]; # first daughter of $N1;
796 $N3 = Tree::DAG_Node->random_network; # or whatever
797 $node->replace_with($N1, $N2, $N3);
799 As a side affect of attaching $N1 and $N2 to $node's mother, they're
800 unlinked from their parents ($node, and $N1, replectively).
801 But N3's daughter list is unaffected.
803 In other words, this method does what it has to, as you'd expect it
808 sub replace_with { # write-only method
809 my($this, @replacements) = @_;
811 if(not( defined($this->{'mother'}) && ref($this->{'mother'}) )) { # if root
812 foreach my $replacement (@replacements) {
813 $replacement->{'mother'}->remove_daughters($replacement)
814 if $replacement->{'mother'};
817 } else { # I have a mother
818 my $mother = $this->{'mother'};
820 #@replacements = grep(($_ eq $this || $_->{'mother'} ne $mother),
822 @replacements = grep { $_ eq $this
823 || not(defined($_->{'mother'}) &&
824 ref($_->{'mother'}) &&
825 $_->{'mother'} eq $mother
829 # Eliminate sisters (but not self)
830 # i.e., I want myself or things NOT with the same mother as myself.
832 $mother->set_daughters( # old switcheroo
833 map($_ eq $this ? (@replacements) : $_ ,
834 @{$mother->{'daughters'}}
837 # and set_daughters does all the checking and possible
840 return($this, @replacements);
843 =item $node->replace_with_daughters
845 This replaces $node in its mother's daughter list, by unlinking $node
846 and replacing it with its daughters. In other words, $node becomes
847 motherless and daughterless as its daughters move up and take its place.
848 This returns a list consisting of $node followed by the nodes that were
851 In the special (and bizarre) case where $node is root, this simply
852 unlinks its daughters from it, making them roots of their own trees.
854 Effectively the same as $node->replace_with($node->daughters), but more
855 efficient, since less checking has to be done. (And I also think
856 $node->replace_with_daughters is a more common operation in
857 tree-wrangling than $node->replace_with(LIST), so deserves a named
858 method of its own, but that's just me.)
862 # Note that if you radically change 'mother'/'daughters' bookkeeping,
863 # you may have to change this routine, since it's one of the places
864 # that directly writes to 'daughters' and 'mother'.
866 sub replace_with_daughters { # write-only method
867 my($this) = $_[0]; # takes no params other than the self
868 my $mother = $this->{'mother'};
869 return($this, $this->clear_daughters)
870 unless defined($mother) && ref($mother);
872 my @daughters = $this->clear_daughters;
873 my $sib_r = $mother->{'daughters'};
874 @$sib_r = map($_ eq $this ? (@daughters) : $_,
875 @$sib_r # old switcheroo
877 foreach my $daughter (@daughters) {
878 $daughter->{'mother'} = $mother;
880 return($this, @daughters);
883 #--------------------------------------------------------------------------
885 =item $node->add_left_sisters( LIST )
887 This adds the elements in LIST (in that order) as immediate left sisters of
888 $node. In other words, given that B's mother's daughter-list is (A,B,C,D),
889 calling B->add_left_sisters(X,Y) makes B's mother's daughter-list
892 If LIST is empty, this is a no-op, and returns empty-list.
894 This is basically implemented as a call to $node->replace_with(LIST,
895 $node), and so all replace_with's limitations and caveats apply.
897 The return value of $node->add_left_sisters( LIST ) is the elements of
898 LIST that got added, as returned by replace_with -- minus the copies
899 of $node you'd get from a straight call to $node->replace_with(LIST,
904 sub add_left_sisters { # write-only method
905 my($this, @new) = @_;
906 return() unless @new;
908 @new = $this->replace_with(@new, $this);
909 shift @new; pop @new; # kill the copies of $this
913 =item $node->add_left_sister( LIST )
915 An exact synonym for $node->add_left_sisters(LIST)
919 sub add_left_sister { # alias
920 my($it,@them) = @_; $it->add_left_sisters(@them);
923 =item $node->add_right_sisters( LIST )
925 Just like add_left_sisters (which see), except that the the elements
926 in LIST (in that order) as immediate B<right> sisters of $node;
928 In other words, given that B's mother's daughter-list is (A,B,C,D),
929 calling B->add_right_sisters(X,Y) makes B's mother's daughter-list
934 sub add_right_sisters { # write-only method
935 my($this, @new) = @_;
936 return() unless @new;
937 @new = $this->replace_with($this, @new);
938 shift @new; shift @new; # kill the copies of $this
942 =item $node->add_right_sister( LIST )
944 An exact synonym for $node->add_right_sisters(LIST)
948 sub add_right_sister { # alias
949 my($it,@them) = @_; $it->add_right_sisters(@them);
952 ###########################################################################
958 ###########################################################################
959 ###########################################################################
961 =head1 OTHER ATTRIBUTE METHODS
965 =item $node->name or $node->name(SCALAR)
967 In the first form, returns the value of the node object's "name"
968 attribute. In the second form, sets it to the value of SCALAR.
972 sub name { # read/write attribute-method. returns/expects a scalar
974 $this->{'name'} = $_[0] if @_;
975 return $this->{'name'};
979 ###########################################################################
981 =item $node->attributes or $node->attributes(SCALAR)
983 In the first form, returns the value of the node object's "attributes"
984 attribute. In the second form, sets it to the value of SCALAR. I
985 intend this to be used to store a reference to a (presumably
986 anonymous) hash the user can use to store whatever attributes he
987 doesn't want to have to store as object attributes. In this case, you
988 needn't ever set the value of this. (_init has already initialized it
989 to {}.) Instead you can just do...
991 $node->attributes->{'foo'} = 'bar';
993 ...to write foo => bar.
997 sub attributes { # read/write attribute-method
998 # expects a ref, presumably a hashref
1001 Carp::carp "my parameter must be a reference" unless ref($_[0]);
1002 $this->{'attributes'} = $_[0];
1004 return $this->{'attributes'};
1007 =item $node->attribute or $node->attribute(SCALAR)
1009 An exact synonym for $node->attributes or $node->attributes(SCALAR)
1013 sub attribute { # alias
1014 my($it,@them) = @_; $it->attributes(@them);
1017 ###########################################################################
1020 sub no_cyclicity { # croak iff I'm in a CYCLIC class.
1022 # If, God forbid, I use this to make a cyclic class, then I'd
1023 # expand the functionality of this routine to actually look for
1024 # cyclicity. Or something like that. Maybe.
1026 $it->cyclicity_fault("You can't do that in a cyclic class!")
1027 if $it->cyclicity_allowed;
1031 sub cyclicity_fault {
1032 my($it, $bitch) = @_[0,1];
1033 Carp::croak "Cyclicity fault: $bitch"; # never return
1036 sub cyclicity_allowed {
1040 ###########################################################################
1041 # More secret stuff. Currently unused.
1043 sub inaugurate_root { # no-op
1044 my($it, $tree) = @_[0,1];
1045 # flag this node as being the root of the tree $tree.
1049 sub decommission_root { # no-op
1050 # flag this node as no longer being the root of the tree $tree.
1054 ###########################################################################
1055 ###########################################################################
1059 =head1 OTHER METHODS TO DO WITH RELATIONSHIPS
1063 =item $node->is_node
1065 This always returns true. More pertinently, $object->can('is_node')
1066 is true (regardless of what C<is_node> would do if called) for objects
1067 belonging to this class or for any class derived from it.
1071 sub is_node { return 1; } # always true.
1072 # NEVER override this with anything that returns false in the belief
1073 # that this'd signal "not a node class". The existence of this method
1074 # is what I test for, with the various "can()" uses in this class.
1076 ###########################################################################
1078 =item $node->ancestors
1080 Returns the list of this node's ancestors, starting with its mother,
1081 then grandmother, and ending at the root. It does this by simply
1082 following the 'mother' attributes up as far as it can. So if $item IS
1083 the root, this returns an empty list.
1085 Consider that scalar($node->ancestors) returns the ply of this node
1086 within the tree -- 2 for a granddaughter of the root, etc., and 0 for
1093 my $mama = $this->{'mother'}; # initial condition
1094 return () unless ref($mama); # I must be root!
1096 # $this->no_cyclicity; # avoid infinite loops
1098 # Could be defined recursively, as:
1099 # if(ref($mama = $this->{'mother'})){
1100 # return($mama, $mama->ancestors);
1104 # But I didn't think of that until I coded the stuff below, which is
1107 my @ancestors = ( $mama ); # start off with my mama
1108 while(defined( $mama = $mama->{'mother'} ) && ref($mama)) {
1110 push(@ancestors, $mama);
1111 # This turns into an infinite loop if someone gets stupid
1112 # and makes this tree cyclic! Don't do it!
1117 ###########################################################################
1121 Returns the root of whatever tree $node is a member of. If $node is
1122 the root, then the result is $node itself.
1128 my @ancestors = ($it, $it->ancestors);
1129 return $ancestors[-1];
1132 ###########################################################################
1134 =item $node->is_daughter_of($node2)
1136 Returns true iff $node is a daughter of $node2.
1137 Currently implemented as just a test of ($it->mother eq $node2).
1141 sub is_daughter_of {
1142 my($it,$mama) = @_[0,1];
1143 return $it->{'mother'} eq $mama;
1146 ###########################################################################
1148 =item $node->self_and_descendants
1150 Returns a list consisting of itself (as element 0) and all the
1151 descendants of $node. Returns just itself if $node is a
1154 (Note that it's spelled "descendants", not "descendents".)
1158 sub self_and_descendants {
1159 # read-only method: return a list of myself and any/all descendants
1162 # $node->no_cyclicity;
1163 $node->walk_down({ 'callback' => sub { push @List, $_[0]; return 1;}});
1164 Carp::croak "Spork Error 919: \@List has no contents!?!?" unless @List;
1169 ###########################################################################
1171 =item $node->descendants
1173 Returns a list consisting of all the descendants of $node. Returns
1174 empty-list if $node is a terminal_node.
1176 (Note that it's spelled "descendants", not "descendents".)
1181 # read-only method: return a list of my descendants
1183 my @list = $node->self_and_descendants;
1184 shift @list; # lose myself.
1188 ###########################################################################
1190 =item $node->leaves_under
1192 Returns a list (going left-to-right) of all the leaf nodes under
1193 $node. ("Leaf nodes" are also called "terminal nodes" -- i.e., nodes
1194 that have no daughters.) Returns $node in the degenerate case of
1195 $node being a leaf itself.
1200 # read-only method: return a list of all leaves under myself.
1201 # Returns myself in the degenerate case of being a leaf myself.
1204 # $node->no_cyclicity;
1205 $node->walk_down({ 'callback' =>
1208 my @daughters = @{$node->{'daughters'}};
1209 push(@List, $node) unless @daughters;
1213 Carp::croak "Spork Error 861: \@List has no contents!?!?" unless @List;
1218 ###########################################################################
1220 =item $node->depth_under
1222 Returns an integer representing the number of branches between this
1223 $node and the most distant leaf under it. (In other words, this
1224 returns the ply of subtree starting of $node. Consider
1225 scalar($it->ancestors) if you want the ply of a node within the whole
1236 my $depth = $_[1]->{'_depth'};
1237 $max_depth = $depth if $depth > $max_depth;
1244 ###########################################################################
1246 =item $node->generation
1248 Returns a list of all nodes (going left-to-right) that are in $node's
1249 generation -- i.e., that are the some number of nodes down from
1250 the root. $root->generation is just $root.
1252 Of course, $node is always in its own generation.
1254 =item $node->generation_under(NODE2)
1256 Like $node->generation, but returns only the nodes in $node's generation
1257 that are also descendants of NODE2 -- in other words,
1259 @us = $node->generation_under( $node->mother->mother );
1261 is all $node's first cousins (to borrow yet more kinship terminology) --
1262 assuming $node does indeed have a grandmother. Actually "cousins" isn't
1263 quite an apt word, because C<@us> ends up including $node's siblings and
1266 Actually, C<generation_under> is just an alias to C<generation>, but I
1269 @us = $node->generation_under($way_upline);
1271 is a bit more readable than this:
1273 @us = $node->generation($way_upline);
1277 $node->generation_under($node) returns just $node.
1279 If you call $node->generation_under($node) but NODE2 is not $node or an
1280 ancestor of $node, it behaves as if you called just $node->generation().
1285 my($node, $limit) = @_[0,1];
1286 # $node->no_cyclicity;
1288 if $node eq $limit || not(
1289 defined($node->{'mother'}) &&
1290 ref($node->{'mother'})
1293 return map(@{$_->{'daughters'}}, $node->{'mother'}->generation($limit));
1295 # Yup, my generation is just all the daughters of my mom's generation.
1298 sub generation_under {
1299 my($node, @rest) = @_;
1300 return $node->generation(@rest);
1303 ###########################################################################
1305 =item $node->self_and_sisters
1307 Returns a list of all nodes (going left-to-right) that have the same
1308 mother as $node -- including $node itself. This is just like
1309 $node->mother->daughters, except that that fails where $node is root,
1310 whereas $root->self_and_siblings, as a special case, returns $root.
1312 (Contrary to how you may interpret how this method is named, "self" is
1313 not (necessarily) the first element of what's returned.)
1317 sub self_and_sisters {
1319 my $mother = $node->{'mother'};
1320 return $node unless defined($mother) && ref($mother); # special case
1321 return @{$node->{'mother'}->{'daughters'}};
1324 ###########################################################################
1326 =item $node->sisters
1328 Returns a list of all nodes (going left-to-right) that have the same
1329 mother as $node -- B<not including> $node itself. If $node is root,
1330 this returns empty-list.
1336 my $mother = $node->{'mother'};
1337 return() unless $mother; # special case
1338 return grep($_ ne $node,
1339 @{$node->{'mother'}->{'daughters'}}
1343 ###########################################################################
1345 =item $node->left_sister
1347 Returns the node that's the immediate left sister of $node. If $node
1348 is the leftmost (or only) daughter of its mother (or has no mother),
1349 then this returns undef.
1351 (See also $node->add_left_sisters(LIST).)
1357 my $mother = $it->{'mother'};
1358 return undef unless $mother;
1359 my @sisters = @{$mother->{'daughters'}};
1361 return undef if @sisters == 1; # I'm an only daughter
1364 foreach my $one (@sisters) {
1365 return $left if $one eq $it;
1368 die "SPORK ERROR 9757: I'm not in my mother's daughter list!?!?";
1372 =item $node->left_sisters
1374 Returns a list of nodes that're sisters to the left of $node. If
1375 $node is the leftmost (or only) daughter of its mother (or has no
1376 mother), then this returns an empty list.
1378 (See also $node->add_left_sisters(LIST).)
1384 my $mother = $it->{'mother'};
1385 return() unless $mother;
1386 my @sisters = @{$mother->{'daughters'}};
1387 return() if @sisters == 1; # I'm an only daughter
1390 foreach my $one (@sisters) {
1391 return @out if $one eq $it;
1394 die "SPORK ERROR 9767: I'm not in my mother's daughter list!?!?";
1397 =item $node->right_sister
1399 Returns the node that's the immediate right sister of $node. If $node
1400 is the rightmost (or only) daughter of its mother (or has no mother),
1401 then this returns undef.
1403 (See also $node->add_right_sisters(LIST).)
1409 my $mother = $it->{'mother'};
1410 return undef unless $mother;
1411 my @sisters = @{$mother->{'daughters'}};
1412 return undef if @sisters == 1; # I'm an only daughter
1415 foreach my $one (@sisters) {
1416 return $one if $seen;
1417 $seen = 1 if $one eq $it;
1419 die "SPORK ERROR 9777: I'm not in my mother's daughter list!?!?"
1424 =item $node->right_sisters
1426 Returns a list of nodes that're sisters to the right of $node. If
1427 $node is the rightmost (or only) daughter of its mother (or has no
1428 mother), then this returns an empty list.
1430 (See also $node->add_right_sisters(LIST).)
1436 my $mother = $it->{'mother'};
1437 return() unless $mother;
1438 my @sisters = @{$mother->{'daughters'}};
1439 return() if @sisters == 1; # I'm an only daughter
1443 foreach my $one (@sisters) {
1444 push @out, $one if $seen;
1445 $seen = 1 if $one eq $it;
1447 die "SPORK ERROR 9787: I'm not in my mother's daughter list!?!?"
1452 ###########################################################################
1454 =item $node->my_daughter_index
1456 Returns what index this daughter is, in its mother's C<daughter> list.
1457 In other words, if $node is ($node->mother->daughters)[3], then
1458 $node->my_daughter_index returns 3.
1460 As a special case, returns 0 if $node has no mother.
1464 sub my_daughter_index {
1465 # returns what number is my index in my mother's daughter list
1466 # special case: 0 for root.
1469 my $mother = $node->{'mother'};
1471 return 0 unless $mother;
1472 my @sisters = @{$mother->{'daughters'}};
1474 die "SPORK ERROR 6512: My mother has no kids!!!" unless @sisters;
1477 for(my $i = 0; $i < @sisters; $i++) {
1478 if($sisters[$i] eq $node) {
1483 die "SPORK ERROR 2837: I'm not a daughter of my mother?!?!" if $ord == -1;
1487 ###########################################################################
1489 =item $node->address or $anynode->address(ADDRESS)
1491 With the first syntax, returns the address of $node within its tree,
1492 based on its position within the tree. An address is formed by noting
1493 the path between the root and $node, and concatenating the
1494 daughter-indices of the nodes this passes thru (starting with 0 for
1495 the root, and ending with $node).
1497 For example, if to get from node ROOT to node $node, you pass thru
1498 ROOT, A, B, and $node, then the address is determined as:
1500 * ROOT's my_daughter_index is 0.
1502 * A's my_daughter_index is, suppose, 2. (A is index 2 in ROOT's
1505 * B's my_daughter_index is, suppose, 0. (B is index 0 in A's
1508 * $node's my_daughter_index is, suppose, 4. ($node is index 4 in
1511 The address of the above-described $node is, therefore, "0:2:0:4".
1513 (As a somewhat special case, the address of the root is always "0";
1514 and since addresses start from the root, all addresses start with a
1517 The second syntax, where you provide an address, starts from the root
1518 of the tree $anynode belongs to, and returns the node corresponding to
1519 that address. Returns undef if no node corresponds to that address.
1520 Note that this routine may be somewhat liberal in its interpretation
1521 of what can constitute an address; i.e., it accepts "0.2.0.4", besides
1524 Also note that the address of a node in a tree is meaningful only in
1525 that tree as currently structured.
1527 (Consider how ($address1 cmp $address2) may be magically meaningful
1528 to you, if you mant to figure out what nodes are to the right of what
1534 my($it, $address) = @_[0,1];
1535 if(defined($address) && length($address)) { # given the address, return the node.
1536 # invalid addresses return undef
1537 my $root = $it->root;
1538 my @parts = map {$_ + 0}
1539 $address =~ m/(\d+)/g; # generous!
1540 Carp::croak "Address \"$address\" is an ill-formed address" unless @parts;
1541 Carp::croak "Address \"$address\" must start with '0'" unless shift(@parts) == 0;
1543 my $current_node = $root;
1544 while(@parts) { # no-op for root
1545 my $ord = shift @parts;
1546 my @daughters = @{$current_node->{'daughters'}};
1548 if($#daughters < $ord) { # illegal address
1549 print "* $address has an out-of-range index ($ord)!" if $Debug;
1552 $current_node = $daughters[$ord];
1553 unless(ref($current_node)) {
1554 print "* $address points to or thru a non-node!" if $Debug;
1558 return $current_node;
1560 } else { # given the node, return the address
1562 my $current_node = $it;
1565 while(defined( $mother = $current_node->{'mother'} ) && ref($mother)) {
1566 unshift @parts, $current_node->my_daughter_index;
1567 $current_node = $mother;
1569 return join(':', 0, @parts);
1573 ###########################################################################
1575 =item $node->common(LIST)
1577 Returns the lowest node in the tree that is ancestor-or-self to the
1578 nodes $node and LIST.
1580 If the nodes are far enough apart in the tree, the answer is just the
1583 If the nodes aren't all in the same tree, the answer is undef.
1585 As a degenerate case, if LIST is empty, returns $node.
1589 sub common { # Return the lowest node common to all these nodes...
1590 # Called as $it->common($other) or $it->common(@others)
1591 my @ones = @_; # all nodes I was given
1592 my($first, @others) = @_;
1594 return $first unless @others; # degenerate case
1597 @ones{ @ones } = undef;
1599 foreach my $node (@others) {
1600 Carp::croak "TILT: node \"$node\" is not a node"
1601 unless UNIVERSAL::can($node, 'is_node');
1603 @first_lineage{$first, $first->ancestors} = undef;
1604 my $higher = undef; # the common of $first and $node
1605 my @my_lineage = $node->ancestors;
1608 while(@my_lineage) {
1609 if(exists $first_lineage{$my_lineage[0]}) {
1610 $higher = $my_lineage[0];
1615 return undef unless $higher;
1622 ###########################################################################
1624 =item $node->common_ancestor(LIST)
1626 Returns the lowest node that is ancestor to all the nodes given (in
1627 nodes $node and LIST). In other words, it answers the question: "What
1628 node in the tree, as low as possible, is ancestor to the nodes given
1631 If the nodes are far enough apart, the answer is just the root --
1632 except if any of the nodes are the root itself, in which case the
1633 answer is undef (since the root has no ancestor).
1635 If the nodes aren't all in the same tree, the answer is undef.
1637 As a degenerate case, if LIST is empty, returns $node's mother;
1638 that'll be undef if $node is root.
1642 sub common_ancestor {
1643 my @ones = @_; # all nodes I was given
1644 my($first, @others) = @_;
1646 return $first->{'mother'} unless @others;
1647 # which may be undef if $first is the root!
1650 @ones{ @ones } = undef; # my arguments
1652 my $common = $first->common(@others);
1653 if(exists($ones{$common})) { # if the common is one of my nodes...
1654 return $common->{'mother'};
1655 # and this might be undef, if $common is root!
1658 # which might be null if that's all common came up with
1662 ###########################################################################
1663 ###########################################################################
1667 =head1 YET MORE METHODS
1671 =item $node->walk_down({ callback => \&foo, callbackback => \&foo, ... })
1673 Performs a depth-first traversal of the structure at and under $node.
1674 What it does at each node depends on the value of the options hashref,
1675 which you must provide. There are three options, "callback" and
1676 "callbackback" (at least one of which must be defined, as a sub
1677 reference), and "_depth". This is what C<walk_down> does, in
1680 * Start at the $node given.
1682 * If there's a C<callback>, call it with $node as the first argument,
1683 and the options hashref as the second argument (which contains the
1684 potentially useful C<_depth>, remember). This function must return
1685 true or false -- if false, it will block the next step:
1687 * If $node has any daughter nodes, increment C<_depth>, and call
1688 $daughter->walk_down(options_hashref) for each daughter (in order, of
1689 course), where options_hashref is the same hashref it was called with.
1690 When this returns, decrements C<_depth>.
1692 * If there's a C<callbackback>, call just it as with C<callback> (but
1693 tossing out the return value). Note that C<callback> returning false
1694 blocks traversal below $node, but doesn't block calling callbackback
1695 for $node. (Incidentally, in the unlikely case that $node has stopped
1696 being a node object, C<callbackback> won't get called.)
1700 $node->walk_down is the way to recursively do things to a tree (if you
1701 start at the root) or part of a tree; if what you're doing is best done
1702 via pre-pre order traversal, use C<callback>; if what you're doing is
1703 best done with post-order traversal, use C<callbackback>.
1704 C<walk_down> is even the basis for plenty of the methods in this
1705 class. See the source code for examples both simple and horrific.
1707 Note that if you don't specify C<_depth>, it effectively defaults to
1708 0. You should set it to scalar($node->ancestors) if you want
1709 C<_depth> to reflect the true depth-in-the-tree for the nodes called,
1710 instead of just the depth below $node. (If $node is the root, there's
1711 difference, of course.)
1713 And B<by the way>, it's a bad idea to modify the tree from the callback.
1714 Unpredictable things may happen. I instead suggest having your callback
1715 add to a stack of things that need changing, and then, once C<walk_down>
1716 is all finished, changing those nodes from that stack.
1718 Note that the existence of C<walk_down> doesn't mean you can't write
1719 you own special-use traversers.
1724 my($this, $o) = @_[0,1];
1726 # All the can()s are in case an object changes class while I'm
1729 Carp::croak "I need options!" unless ref($o);
1730 Carp::croak "I need a callback or a callbackback" unless
1731 ( ref($o->{'callback'}) || ref($o->{'callbackback'}) );
1733 # $this->no_cyclicity;
1734 my $callback = ref($o->{'callback'}) ? $o->{'callback'} : undef;
1735 my $callbackback = ref($o->{'callbackback'}) ? $o->{'callbackback'} : undef;
1736 my $callback_status = 1;
1738 print "Callback: $callback Callbackback: $callbackback\n" if $Debug;
1740 printf "* Entering %s\n", ($this->name || $this) if $Debug;
1741 $callback_status = &{ $callback }( $this, $o ) if $callback;
1743 if($callback_status) {
1744 # Keep recursing unless callback returned false... and if there's
1745 # anything to recurse into, of course.
1746 my @daughters = UNIVERSAL::can($this, 'is_node') ? @{$this->{'daughters'}} : ();
1748 $o->{'_depth'} += 1;
1749 #print "Depth " , $o->{'_depth'}, "\n";
1750 foreach my $one (@daughters) {
1751 $one->walk_down($o) if UNIVERSAL::can($one, 'is_node');
1752 # and if it can do "is_node", it should provide a walk_down!
1754 $o->{'_depth'} -= 1;
1757 printf "* Recursing below %s pruned\n", ($this->name || $this) if $Debug;
1760 # Note that $callback_status doesn't block callbackback from being called
1762 if(UNIVERSAL::can($this, 'is_node')) { # if it's still a node!
1763 print "* Calling callbackback\n" if $Debug;
1764 scalar( &{ $callbackback }( $this, $o ) );
1765 # scalar to give it the same context as callback
1767 print "* Can't call callbackback -- $this isn't a node anymore\n"
1772 if(UNIVERSAL::can($this, 'is_node')) { # if it's still a node!
1773 printf "* Leaving %s\n", ($this->name || $this)
1775 print "* Leaving [no longer a node]\n";
1781 ###########################################################################
1783 =item @lines = $node->dump_names({ ...options... });
1785 Dumps, as an indented list, the names of the nodes starting at $node,
1786 and continuing under it. Options are:
1788 * _depth -- A nonnegative number. Indicating the depth to consider
1789 $node as being at (and so the generation under that is that plus one,
1790 etc.). Defaults to 0. You may choose to use set _depth =>
1791 scalar($node->ancestors).
1793 * tick -- a string to preface each entry with, between the
1794 indenting-spacing and the node's name. Defaults to empty-string. You
1795 may prefer "*" or "-> " or someting.
1797 * indent -- the string used to indent with. Defaults to " " (two
1798 spaces). Another sane value might be ". " (period, space). Setting it
1799 to empty-string suppresses indenting.
1801 The dump is not printed, but is returned as a list, where each
1802 item is a line, with a "\n" at the end.
1807 my($it, $o) = @_[0,1];
1808 $o = {} unless ref $o;
1810 $o->{'_depth'} ||= 0;
1811 $o->{'indent'} ||= ' ';
1812 $o->{'tick'} ||= '';
1814 $o->{'callback'} = sub {
1815 my($this, $o) = @_[0,1];
1818 $o->{'indent'} x $o->{'_depth'},
1820 &Tree::DAG_Node::_dump_quote($this->name || $this),
1831 ###########################################################################
1832 ###########################################################################
1834 =item the constructor CLASS->random_network({...options...})
1836 =item the method $node->random_network({...options...})
1838 In the first case, constructs a randomly arranged network under a new
1839 node, and returns the root node of that tree. In the latter case,
1840 constructs the network under $node.
1842 Currently, this is implemented a bit half-heartedly, and
1843 half-wittedly. I basically needed to make up random-looking networks
1844 to stress-test the various tree-dumper methods, and so wrote this. If
1845 you actually want to rely on this for any application more
1846 serious than that, I suggest examining the source code and seeing if
1847 this does really what you need (say, in reliability of randomness);
1848 and feel totally free to suggest changes to me (especially in the form
1849 of "I rewrote C<random_network>, here's the code...")
1851 It takes four options:
1853 * max_node_count -- maximum number of nodes this tree will be allowed
1854 to have (counting the root). Defaults to 25.
1856 * min_depth -- minimum depth for the tree. Defaults to 2. Leaves can
1857 be generated only after this depth is reached, so the tree will be at
1858 least this deep -- unless max_node_count is hit first.
1860 * max_depth -- maximum depth for the tree. Defaults to 3 plus
1861 min_depth. The tree will not be deeper than this.
1863 * max_children -- maximum number of children any mother in the tree
1864 can have. Defaults to 4.
1868 sub random_network { # constructor or method.
1870 my $o = ref($_[1]) ? $_[1] : {};
1874 if(ref($class)){ # I'm a method.
1875 $root = $_[0]; # build under the given node, from same class.
1876 $class = ref $class;
1878 } else { # I'm a constructor
1879 $root = $class->new; # build under a new node, with class named.
1880 $root->name("Root");
1884 my $min_depth = $o->{'min_depth'} || 2;
1885 my $max_depth = $o->{'max_depth'} || ($min_depth + 3);
1886 my $max_children = $o->{'max_children'} || 4;
1887 my $max_node_count = $o->{'max_node_count'} || 25;
1889 Carp::croak "max_children has to be positive" if int($max_children) < 1;
1891 my @mothers = ( $root );
1893 my $node_count = 1; # the root
1896 foreach my $depth (1 .. $max_depth) {
1897 last if $node_count > $max_node_count;
1899 foreach my $mother (@mothers) {
1900 last Gen if $node_count > $max_node_count;
1901 my $children_number;
1902 if($depth <= $min_depth) {
1903 until( $children_number = int(rand(1 + $max_children)) ) {}
1905 $children_number = int(rand($max_children));
1908 foreach (1 .. $children_number) {
1909 last Gen if $node_count > $max_node_count;
1910 my $node = $mother->new_daughter;
1911 $node->name("Node$node_count");
1913 push(@children, $node);
1916 @mothers = @children;
1918 last unless @mothers;
1924 =item the constructor CLASS->lol_to_tree($lol);
1926 Converts something like bracket-notation for "Chomsky trees" (or
1927 rather, the closest you can come with Perl
1928 list-of-lists(-of-lists(-of-lists))) into a tree structure. Returns
1929 the root of the tree converted.
1931 The conversion rules are that: 1) if the last (possibly the only) item
1932 in a given list is a scalar, then that is used as the "name" attribute
1933 for the node based on this list. 2) All other items in the list
1934 represent daughter nodes of the current node -- recursively so, if
1935 they are list references; otherwise, (non-terminal) scalars are
1936 considered to denote nodes with that name. So ['Foo', 'Bar', 'N'] is
1937 an alternate way to represent [['Foo'], ['Bar'], 'N'].
1939 An example will illustrate:
1946 [ [ 'dog' ], 'N'], 'NP'],
1947 [ '/with rabies\\', 'PP'],
1953 $tree = Tree::DAG_Node->lol_to_tree($lol);
1954 $diagram = $tree->draw_ascii_tree;
1955 print map "$_\n", @$diagram;
1957 ...returns this tree:
1962 /------------------\
1966 /---------------\ <died>
1970 /-------\ </with rabies\>
1976 By the way (and this rather follows from the above rules), when
1977 denoting a LoL tree consisting of just one node, this:
1979 $tree = Tree::DAG_Node->lol_to_tree( 'Lonely' );
1981 is okay, although it'd probably occur to you to denote it only as:
1983 $tree = Tree::DAG_Node->lol_to_tree( ['Lonely'] );
1985 which is of course fine, too.
1990 my($class, $lol, $seen_r) = @_[0,1,2];
1991 $seen_r = {} unless ref($seen_r) eq 'HASH';
1992 return if ref($lol) && $seen_r->{$lol}++; # catch circularity
1994 $class = ref($class) || $class;
1995 my $node = $class->new();
1997 unless(ref($lol) eq 'ARRAY') { # It's a terminal node.
1998 $node->name($lol) if defined $lol;
2001 return $node unless @$lol; # It's a terminal node, oddly represented
2003 # It's a non-terminal node.
2005 my @options = @$lol;
2006 unless(ref($options[-1]) eq 'ARRAY') {
2007 # This is what separates this method from simple_lol_to_tree
2008 $node->name(pop(@options));
2011 foreach my $d (@options) { # Scan daughters (whether scalars or listrefs)
2012 $node->add_daughter( $class->lol_to_tree($d, $seen_r) ); # recurse!
2018 #--------------------------------------------------------------------------
2020 =item $node->tree_to_lol_notation({...options...})
2022 Dumps a tree (starting at $node) as the sort of LoL-like bracket
2023 notation you see in the above example code. Returns just one big
2024 block of text. The only option is "multiline" -- if true, it dumps
2025 the text as the sort of indented structure as seen above; if false
2026 (and it defaults to false), dumps it all on one line (with no
2027 indenting, of course).
2029 For example, starting with the tree from the above example,
2032 print $tree->tree_to_lol_notation, "\n";
2034 prints the following (which I've broken over two lines for sake of
2035 printablitity of documentation):
2037 [[[['Det:The'], [['dog'], 'N'], 'NP'], [["/with rabies\x5c"],
2038 'PP'], 'NP'], [['died'], 'VP'], 'S'],
2042 print $tree->tree_to_lol_notation({ multiline => 1 });
2044 prints the same content, just spread over many lines, and prettily
2049 #--------------------------------------------------------------------------
2051 sub tree_to_lol_notation {
2053 my($it, $o) = @_[0,1];
2054 $o = {} unless ref $o;
2056 $o->{'_depth'} ||= 0;
2057 $o->{'multiline'} = 0 unless exists($o->{'multiline'});
2060 if($o->{'multiline'}) {
2061 $o->{'indent'} ||= ' ';
2064 $o->{'indent'} ||= '';
2068 $o->{'callback'} = sub {
2069 my($this, $o) = @_[0,1];
2071 $o->{'indent'} x $o->{'_depth'},
2077 $o->{'callbackback'} = sub {
2078 my($this, $o) = @_[0,1];
2079 my $name = $this->name;
2080 if(!defined($name)) {
2083 $name = &Tree::DAG_Node::_dump_quote($name);
2086 $o->{'indent'} x ($o->{'_depth'} + 1),
2088 $o->{'indent'} x $o->{'_depth'},
2095 return join('', @out);
2098 #--------------------------------------------------------------------------
2100 =item $node->tree_to_lol
2102 Returns that tree (starting at $node) represented as a LoL, like what
2103 $lol, above, holds. (This is as opposed to C<tree_to_lol_notation>,
2104 which returns the viewable code like what gets evaluated and stored in
2107 Lord only knows what you use this for -- maybe for feeding to
2108 Data::Dumper, in case C<tree_to_lol_notation> doesn't do just what you
2114 # I haven't /rigorously/ tested this.
2115 my($it, $o) = @_[0,1]; # $o is currently unused anyway
2116 $o = {} unless ref $o;
2119 my @lol_stack = ($out);
2120 $o->{'callback'} = sub {
2121 my($this, $o) = @_[0,1];
2123 push @{$lol_stack[-1]}, $new;
2124 push(@lol_stack, $new);
2128 $o->{'callbackback'} = sub {
2129 my($this, $o) = @_[0,1];
2130 push @{$lol_stack[-1]}, $this->name;
2136 die "totally bizarre error 12416" unless ref($out->[0]);
2137 $out = $out->[0]; # the real root
2141 ###########################################################################
2143 =item the constructor CLASS->simple_lol_to_tree($simple_lol);
2145 This is like lol_to_tree, except that rule 1 doesn't apply -- i.e.,
2146 all scalars (or really, anything not a listref) in the LoL-structure
2147 end up as named terminal nodes, and only terminal nodes get names
2148 (and, of course, that name comes from that scalar value). This method
2149 is useful for making things like expression trees, or at least
2150 starting them off. Consider that this:
2152 $tree = Tree::DAG_Node->simple_lol_to_tree(
2153 [ 'foo', ['bar', ['baz'], 'quux'], 'zaz', 'pati' ]
2156 converts from something like a Lispish or Iconish tree, if you pretend
2157 the brackets are parentheses.
2159 Note that there is a (possibly surprising) degenerate case of what I'm
2160 calling a "simple-LoL", and it's like this:
2162 $tree = Tree::DAG_Node->simple_lol_to_tree('Lonely');
2164 This is the (only) way you can specify a tree consisting of only a
2165 single node, which here gets the name 'Lonely'.
2169 sub simple_lol_to_tree {
2170 my($class, $lol, $seen_r) = @_[0,1,2];
2171 $class = ref($class) || $class;
2172 $seen_r = {} unless ref($seen_r) eq 'HASH';
2173 return if ref($lol) && $seen_r->{$lol}++; # catch circularity
2175 my $node = $class->new();
2177 unless(ref($lol) eq 'ARRAY') { # It's a terminal node.
2178 $node->name($lol) if defined $lol;
2182 # It's a non-terminal node.
2183 foreach my $d (@$lol) { # scan daughters (whether scalars or listrefs)
2184 $node->add_daughter( $class->simple_lol_to_tree($d, $seen_r) ); # recurse!
2190 #--------------------------------------------------------------------------
2192 =item $node->tree_to_simple_lol
2194 Returns that tree (starting at $node) represented as a simple-LoL --
2195 i.e., one where non-terminal nodes are represented as listrefs, and
2196 terminal nodes are gotten from the contents of those nodes' "name'
2199 Note that in the case of $node being terminal, what you get back is
2200 the same as $node->name.
2202 Compare to tree_to_simple_lol_notation.
2206 sub tree_to_simple_lol {
2207 # I haven't /rigorously/ tested this.
2210 return $root->name unless scalar($root->daughters);
2211 # special case we have to nip in the bud
2213 my($it, $o) = @_[0,1]; # $o is currently unused anyway
2214 $o = {} unless ref $o;
2217 my @lol_stack = ($out);
2218 $o->{'callback'} = sub {
2219 my($this, $o) = @_[0,1];
2221 $new = scalar($this->daughters) ? [] : $this->name;
2222 # Terminal nodes are scalars, the rest are listrefs we'll fill in
2223 # as we recurse the tree below here.
2224 push @{$lol_stack[-1]}, $new;
2225 push(@lol_stack, $new);
2229 $o->{'callbackback'} = sub { pop @lol_stack; return 1; };
2231 die "totally bizarre error 12416" unless ref($out->[0]);
2232 $out = $out->[0]; # the real root
2236 #--------------------------------------------------------------------------
2238 =item $node->tree_to_simple_lol_notation({...options...})
2240 A simple-LoL version of tree_to_lol_notation (which see); takes the
2245 sub tree_to_simple_lol_notation {
2246 my($it, $o) = @_[0,1];
2247 $o = {} unless ref $o;
2249 $o->{'_depth'} ||= 0;
2250 $o->{'multiline'} = 0 unless exists($o->{'multiline'});
2253 if($o->{'multiline'}) {
2254 $o->{'indent'} ||= ' ';
2257 $o->{'indent'} ||= '';
2261 $o->{'callback'} = sub {
2262 my($this, $o) = @_[0,1];
2263 if(scalar($this->daughters)) { # Nonterminal
2265 $o->{'indent'} x $o->{'_depth'},
2269 my $name = $this->name;
2271 $o->{'indent'} x $o->{'_depth'},
2272 defined($name) ? &Tree::DAG_Node::_dump_quote($name) : 'undef',
2278 $o->{'callbackback'} = sub {
2279 my($this, $o) = @_[0,1];
2281 $o->{'indent'} x $o->{'_depth'},
2283 ) if scalar($this->daughters);
2289 return join('', @out);
2292 ###########################################################################
2293 # $list_r = $root_node->draw_ascii_tree({ h_compact => 1});
2294 # print map("$_\n", @$list_r);
2296 =item $list_r = $node->draw_ascii_tree({ ... options ... })
2298 Draws a nice ASCII-art representation of the tree structure
2299 at-and-under $node, with $node at the top. Returns a reference to the
2300 list of lines (with no "\n"s or anything at the end of them) that make
2305 print map("$_\n", @{$tree->draw_ascii_tree});
2307 draw_ascii_tree takes parameters you set in the options hashref:
2309 * "no_name" -- if true, C<draw_ascii_tree> doesn't print the name of
2310 the node; simply prints a "*". Defaults to 0 (i.e., print the node
2313 * "h_spacing" -- number 0 or greater. Sets the number of spaces
2314 inserted horizontally between nodes (and groups of nodes) in a tree.
2317 * "h_compact" -- number 0 or 1. Sets the extent to which
2318 C<draw_ascii_tree> tries to save horizontal space. Defaults to 1. If
2319 I think of a better scrunching algorithm, there'll be a "2" setting
2322 * "v_compact" -- number 0, 1, or 2. Sets the degree to which
2323 C<draw_ascii_tree> tries to save vertical space. Defaults to 1.
2325 This occasionally returns trees that are a bit cock-eyed in parts; if
2326 anyone can suggest a better drawing algorithm, I'd be appreciative.
2330 sub draw_ascii_tree {
2331 # Make a "box" for this node and its possible daughters, recursively.
2333 # The guts of this routine are horrific AND recursive!
2335 # Feel free to send me better code. I worked on this until it
2336 # gave me a headache and it worked passably, and then I stopped.
2339 my $o = ref($_[1]) ? $_[1] : {};
2340 my(@box, @daughter_boxes, $width, @daughters);
2341 @daughters = @{$it->{'daughters'}};
2343 # $it->no_cyclicity;
2345 $o->{'no_name'} = 0 unless exists $o->{'no_name'};
2346 $o->{'h_spacing'} = 1 unless exists $o->{'h_spacing'};
2347 $o->{'h_compact'} = 1 unless exists $o->{'h_compact'};
2348 $o->{'v_compact'} = 1 unless exists $o->{'v_compact'};
2351 if($o->{'no_name'}) {
2352 $printable_name = '*';
2354 $printable_name = $it->name || $it;
2355 $printable_name =~ tr<\cm\cj\t >< >s;
2356 $printable_name = "<$printable_name>";
2359 if(!scalar(@daughters)) { # I am a leaf!
2360 # Now add the top parts, and return.
2361 @box = ("|", $printable_name);
2363 @daughter_boxes = map { &draw_ascii_tree($_, $o) } @daughters;
2366 foreach my $box (@daughter_boxes) {
2368 $max_height = $h if $h > $max_height;
2371 @box = ('') x $max_height; # establish the list
2373 foreach my $one (@daughter_boxes) {
2374 my $length = length($one->[0]);
2377 #now make all the same height.
2378 my $deficit = $max_height - $height;
2380 push @$one, ( scalar( ' ' x $length ) ) x $deficit;
2381 $height = scalar(@$one);
2385 # Now tack 'em onto @box
2386 ##########################################################
2387 # This used to be a sub of its own. Ho-hum.
2389 my($b1, $b2) = (\@box, $one);
2390 my($h1, $h2) = (scalar(@$b1), scalar(@$b2));
2392 my(@diffs, $to_chop);
2393 if($o->{'h_compact'}) { # Try for h-scrunching.
2395 my $min_diff = length($b1->[0]); # just for starters
2396 foreach my $line (0 .. ($h1 - 1)) {
2397 my $size_l = 0; # length of terminal whitespace
2398 my $size_r = 0; # length of initial whitespace
2399 $size_l = length($1) if $b1->[$line] =~ /( +)$/s;
2400 $size_r = length($1) if $b2->[$line] =~ /^( +)/s;
2401 my $sum = $size_l + $size_r;
2403 $min_diff = $sum if $sum < $min_diff;
2404 push @diffs, [$sum, $size_l, $size_r];
2406 $to_chop = $min_diff - $o->{'h_spacing'};
2407 $to_chop = 0 if $to_chop < 0;
2410 if(not( $o->{'h_compact'} and $to_chop )) {
2411 # No H-scrunching needed/possible
2412 foreach my $line (0 .. ($h1 - 1)) {
2413 $b1->[ $line ] .= $b2->[ $line ] . (' ' x $o->{'h_spacing'});
2416 # H-scrunching is called for.
2417 foreach my $line (0 .. ($h1 - 1)) {
2418 my $r = $b2->[$line]; # will be the new line
2419 my $remaining = $to_chop;
2421 my($l_chop, $r_chop) = @{$diffs[$line]}[1,2];
2424 if($l_chop > $remaining) {
2425 $l_chop = $remaining;
2427 } elsif($l_chop == $remaining) {
2429 } else { # remaining > l_chop
2430 $remaining -= $l_chop;
2434 if($r_chop > $remaining) {
2435 $r_chop = $remaining;
2437 } elsif($r_chop == $remaining) {
2439 } else { # remaining > r_chop
2440 $remaining -= $r_chop; # should never happen!
2444 substr($b1->[$line], -$l_chop) = '' if $l_chop;
2445 substr($r, 0, $r_chop) = '' if $r_chop;
2447 $b1->[ $line ] .= $r . (' ' x $o->{'h_spacing'});
2449 # End of H-scrunching ickyness
2451 # End of ye big tack-on
2454 # End of the foreach daughter_box loop
2456 # remove any fencepost h_spacing
2457 if($o->{'h_spacing'}) {
2458 foreach my $line (@box) {
2459 substr($line, -$o->{'h_spacing'}) = '' if length($line);
2464 die "SPORK ERROR 958203: Freak!!!!!" unless @box;
2466 # Now tweak the pipes
2467 my $new_pipes = $box[0];
2468 my $pipe_count = $new_pipes =~ tr<|><+>;
2469 if($pipe_count < 2) {
2472 my($init_space, $end_space);
2474 # Thanks to Gilles Lamiral for pointing out the need to set to '',
2475 # to avoid -w warnings about undeffiness.
2477 if( $new_pipes =~ s<^( +)><>s ) {
2483 if( $new_pipes =~ s<( +)$><>s ) {
2489 $new_pipes =~ tr< ><->;
2490 substr($new_pipes,0,1) = "/";
2491 substr($new_pipes,-1,1) = "\\";
2493 $new_pipes = $init_space . $new_pipes . $end_space;
2494 # substr($new_pipes, int((length($new_pipes)), 1)) / 2) = "^"; # feh
2497 # Now tack on the formatting for this node.
2498 if($o->{'v_compact'} == 2) {
2499 if(@daughters == 1) {
2500 unshift @box, "|", $printable_name;
2502 unshift @box, "|", $printable_name, $new_pipes;
2504 } elsif ($o->{'v_compact'} == 1 and @daughters == 1) {
2505 unshift @box, "|", $printable_name;
2506 } else { # general case
2507 unshift @box, "|", $printable_name, $new_pipes;
2513 foreach my $line (@box) {
2514 my $w = length($line);
2515 $max_width = $w if $w > $max_width;
2517 foreach my $one (@box) {
2518 my $space_to_add = $max_width - length($one);
2519 next unless $space_to_add;
2520 my $add_left = int($space_to_add / 2);
2521 my $add_right = $space_to_add - $add_left;
2522 $one = (' ' x $add_left) . $one . (' ' x $add_right);
2525 return \@box; # must not return a null list!
2528 ###########################################################################
2530 =item $node->copy_tree or $node->copy_tree({...options...})
2532 This returns the root of a copy of the tree that $node is a member of.
2533 If you pass no options, copy_tree pretends you've passed {}.
2535 This method is currently implemented as just a call to
2536 $this->root->copy_at_and_under({...options...}), but magic may be
2537 added in the future.
2539 Options you specify are passed down to calls to $node->copy.
2544 my($this, $o) = @_[0,1];
2545 my $root = $this->root;
2546 $o = {} unless ref $o;
2548 my $new_root = $root->copy_at_and_under($o);
2553 =item $node->copy_at_and_under or $node->copy_at_and_under({...options...})
2555 This returns a copy of the subtree consisting of $node and everything
2558 If you pass no options, copy_at_and_under pretends you've passed {}.
2560 This works by recursively building up the new tree from the leaves,
2561 duplicating nodes using $orig_node->copy($options_ref) and then
2562 linking them up into a new tree of the same shape.
2564 Options you specify are passed down to calls to $node->copy.
2568 sub copy_at_and_under {
2569 my($from, $o) = @_[0,1];
2570 $o = {} unless ref $o;
2571 my @daughters = map($_->copy_at_and_under($o), @{$from->{'daughters'}});
2572 my $to = $from->copy($o);
2573 $to->set_daughters(@daughters) if @daughters;
2577 =item the constructor $node->copy or $node->copy({...options...})
2579 Returns a copy of $node, B<minus> its daughter or mother attributes
2580 (which are set back to default values).
2582 If you pass no options, C<copy> pretends you've passed {}.
2584 Magic happens with the 'attributes' attribute: if it's a hashref (and
2585 it usually is), the new node doesn't end up with the same hashref, but
2586 with ref to a hash with the content duplicated from the original's
2587 hashref. If 'attributes' is not a hashref, but instead an object that
2588 belongs to a class that provides a method called "copy", then that
2589 method is called, and the result saved in the clone's 'attribute'
2590 attribute. Both of these kinds of magic are disabled if the options
2591 you pass to C<copy> (maybe via C<copy_tree>, or C<copy_at_and_under>)
2592 includes (C<no_attribute_copy> => 1).
2594 The options hashref you pass to C<copy> (derictly or indirectly) gets
2595 changed slightly after you call C<copy> -- it gets an entry called
2596 "from_to" added to it. Chances are you would never know nor care, but
2597 this is reserved for possible future use. See the source if you are
2600 Note that if you are using $node->copy (whether directly or via
2601 $node->copy_tree or $node->copy_at_or_under), and it's not properly
2602 copying object attributes containing references, you probably
2603 shouldn't fight it or try to fix it -- simply override copy_tree with:
2606 use Storable qw(dclone);
2608 return dclone($this->root);
2617 $Data::Dumper::Purity = 1;
2618 return eval(Dumper($this->root));
2621 Both of these avoid you having to reinvent the wheel.
2623 How to override copy_at_or_under with something that uses Storable
2624 or Data::Dumper is left as an exercise to the reader.
2626 Consider that if in a derived class, you add attributes with really
2627 bizarre contents (like a unique-for-all-time-ID), you may need to
2628 override C<copy>. Consider:
2632 $it->SUPER::copy(@etc);
2633 $it->{'UID'} = &get_new_UID;
2636 ...or the like. See the source of Tree::DAG_Node::copy for
2642 my($from,$o) = @_[0,1];
2643 $o = {} unless ref $o;
2645 # Straight dupe, and bless into same class:
2646 my $to = bless { %$from }, ref($from);
2648 # Null out linkages.
2650 $to->_init_daughters;
2652 # dupe the 'attributes' attribute:
2653 unless($o->{'no_attribute_copy'}) {
2654 my $attrib_copy = ref($to->{'attributes'});
2656 if($attrib_copy eq 'HASH') {
2657 $to->{'attributes'} = { %{$to->{'attributes'}} };
2659 } elsif ($attrib_copy = UNIVERSAL::can($to->{'attributes'}, 'copy') ) {
2660 # $attrib_copy now points to the copier method
2661 $to->{'attributes'} = &{$attrib_copy}($from);
2662 } # otherwise I don't know how to copy it; leave as is
2665 $o->{'from_to'}->{$from} = $to; # SECRET VOODOO
2666 # ...autovivifies an anon hashref for 'from_to' if need be
2667 # This is here in case I later want/need a table corresponding
2673 ###########################################################################
2675 =item $node->delete_tree
2677 Destroys the entire tree that $node is a member of (starting at the
2678 root), by nulling out each node-object's attributes (including, most
2679 importantly, its linkage attributes -- hopefully this is more than
2680 sufficient to eliminate all circularity in the data structure), and
2681 then moving it into the class DEADNODE.
2683 Use this when you're finished with the tree in question, and want to
2684 free up its memory. (If you don't do this, it'll get freed up anyway
2685 when your program ends.)
2687 If you try calling any methods on any of the node objects in the tree
2688 you've destroyed, you'll get an error like:
2690 Can't locate object method "leaves_under"
2691 via package "DEADNODE".
2693 So if you see that, that's what you've done wrong. (Actually, the
2694 class DEADNODE does provide one method: a no-op method "delete_tree".
2695 So if you want to delete a tree, but think you may have deleted it
2696 already, it's safe to call $node->delete_tree on it (again).)
2698 The C<delete_tree> method is needed because Perl's garbage collector
2699 would never (as currently implemented) see that it was time to
2700 de-allocate the memory the tree uses -- until either you call
2701 $node->delete_tree, or until the program stops (at "global
2702 destruction" time, when B<everything> is unallocated).
2704 Incidentally, there are better ways to do garbage-collecting on a
2705 tree, ways which don't require the user to explicitly call a method
2706 like C<delete_tree> -- they involve dummy classes, as explained at
2707 C<http://mox.perl.com/misc/circle-destroy.pod>
2709 However, introducing a dummy class concept into Tree::DAG_Node would
2710 be rather a distraction. If you want to do this with your derived
2711 classes, via a DESTROY in a dummy class (or in a tree-metainformation
2712 class, maybe), then feel free to.
2714 The only case where I can imagine C<delete_tree> failing to totally
2715 void the tree, is if you use the hashref in the "attributes" attribute
2716 to store (presumably among other things) references to other nodes'
2717 "attributes" hashrefs -- which 1) is maybe a bit odd, and 2) is your
2718 problem, because it's your hash structure that's circular, not the
2719 tree's. Anyway, consider:
2721 # null out all my "attributes" hashes
2722 $anywhere->root->walk_down({
2724 $hr = $_[0]->attributes; %$hr = (); return 1;
2728 $anywhere->delete_tree;
2730 (I suppose C<delete_tree> is a "destructor", or as close as you can
2731 meaningfully come for a circularity-rich data structure in Perl.)
2737 $it->root->walk_down({ # has to be callbackback, not callback
2738 'callbackback' => sub {
2740 bless($_[0], 'DEADNODE'); # cause become dead! cause become dead!
2745 # Why DEADNODE? Because of the nice error message:
2746 # "Can't locate object method "leaves_under" via package "DEADNODE"."
2747 # Moreover, DEADNODE doesn't provide is_node, so fails my can() tests.
2750 sub DEADNODE::delete_tree { return; }
2751 # in case you kill it AGAIN!!!!! AND AGAIN AND AGAIN!!!!!! OO-HAHAHAHA!
2753 ###########################################################################
2754 # stolen from MIDI.pm
2761 { # the cleaner-upper function
2762 if(!length($_)) { # empty string
2764 } elsif( m/^-?\d+(?:\.\d+)?$/s ) { # a number
2766 } elsif( # text with junk in it
2767 s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])>
2768 <'\\x'.(unpack("H2",$1))>eg
2771 } else { # text with no junk in it
2780 ###########################################################################
2784 =head2 When and How to Destroy
2786 It should be clear to you that if you've built a big parse tree or
2787 something, and then you're finished with it, you should call
2788 $some_node->delete_tree on it if you want the memory back.
2790 But consider this case: you've got this tree:
2798 Let's say you decide you don't want D or any of its descendants in the
2799 tree, so you call D->unlink_from_mother. This does NOT automagically
2800 destroy the tree D-X-Y. Instead it merely splits the tree into two:
2808 To destroy D and its little tree, you have to explicitly call
2811 Note, however, that if you call C->unlink_from_mother, and if you don't
2812 have a link to C anywhere, then it B<does> magically go away. This is
2813 because nothing links to C -- whereas with the D-X-Y tree, D links to
2814 X and Y, and X and Y each link back to D. Note that calling
2815 C->delete_tree is harmless -- after all, a tree of only one node is
2818 So, this is a surefire way of getting rid of all $node's children and
2819 freeing up the memory associated with them and their descendants:
2821 foreach my $it ($node->clear_daughters) { $it->delete_tree }
2823 Just be sure not to do this:
2825 foreach my $it ($node->daughters) { $it->delete_tree }
2826 $node->clear_daughters;
2828 That's bad; the first call to $_->delete_tree will climb to the root
2829 of $node's tree, and nuke the whole tree, not just the bits under $node.
2830 You might as well have just called $node->delete_tree.
2831 (Moreavor, once $node is dead, you can't call clear_daughters on it,
2832 so you'll get an error there.)
2836 If you find a bug in this library, report it to me as soon as possible,
2837 at the address listed in the MAINTAINER section, below. Please try to
2838 be as specific as possible about how you got the bug to occur.
2842 If you develop a given routine for dealing with trees in some way, and
2843 use it a lot, then if you think it'd be of use to anyone else, do email
2844 me about it; it might be helpful to others to include that routine, or
2845 something based on it, in a later version of this module.
2847 It's occurred to me that you might like to (and might yourself develop
2848 routines to) draw trees in something other than ASCII art. If you do so
2849 -- say, for PostScript output, or for output interpretable by some
2850 external plotting program -- I'd be most interested in the results.
2854 This module uses "strict", but I never wrote it with -w warnings in
2855 mind -- so if you use -w, do not be surprised if you see complaints
2856 from the guts of DAG_Node. As long as there is no way to turn off -w
2857 for a given module (instead of having to do it in every single
2858 subroutine with a "local $^W"), I'm not going to change this. However,
2859 I do, at points, get bursts of ambition, and I try to fix code in
2860 DAG_Node that generates warnings, I<as I come across them> -- which is
2861 only occasionally. Feel free to email me any patches for any such
2862 fixes you come up with, tho.
2864 Currently I don't assume (or enforce) anything about the class
2865 membership of nodes being manipulated, other than by testing whether
2866 each one provides a method C<is_node>, a la:
2868 die "Not a node!!!" unless UNIVERSAL::can($node, "is_node");
2870 So, as far as I'm concerned, a given tree's nodes are free to belong to
2871 different classes, just so long as they provide/inherit C<is_node>, the
2872 few methods that this class relies on to navigate the tree, and have the
2873 same internal object structure, or a superset of it. Presumably this
2874 would be the case for any object belonging to a class derived from
2875 C<Tree::DAG_Node>, or belonging to C<Tree::DAG_Node> itself.
2877 When routines in this class access a node's "mother" attribute, or its
2878 "daughters" attribute, they (generally) do so directly (via
2879 $node->{'mother'}, etc.), for sake of efficiency. But classes derived
2880 from this class should probably do this instead thru a method (via
2881 $node->mother, etc.), for sake of portability, abstraction, and general
2884 However, no routines in this class (aside from, necessarily, C<_init>,
2885 C<_init_name>, and C<name>) access the "name" attribute directly;
2886 routines (like the various tree draw/dump methods) get the "name" value
2887 thru a call to $obj->name(). So if you want the object's name to not be
2888 a real attribute, but instead have it derived dynamically from some feature
2889 of the object (say, based on some of its other attributes, or based on
2890 its address), you can to override the C<name> method, without causing
2891 problems. (Be sure to consider the case of $obj->name as a write
2892 method, as it's used in C<lol_to_tree> and C<random_network>.)
2898 Wirth, Niklaus. 1976. I<Algorithms + Data Structures = Programs>
2899 Prentice-Hall, Englewood Cliffs, NJ.
2901 Knuth, Donald Ervin. 1997. I<Art of Computer Programming, Volume 1,
2902 Third Edition: Fundamental Algorithms>. Addison-Wesley, Reading, MA.
2904 Wirth's classic, currently and lamentably out of print, has a good
2905 section on trees. I find it clearer than Knuth's (if not quite as
2906 encyclopedic), probably because Wirth's example code is in a
2907 block-structured high-level language (basically Pascal), instead
2908 of in assembler (MIX).
2910 Until some kind publisher brings out a new printing of Wirth's book,
2911 try poking around used bookstores (or C<www.abebooks.com>) for a copy.
2912 I think it was also republished in the 1980s under the title
2913 I<Algorithms and Data Structures>, and in a German edition called
2914 I<Algorithmen und Datenstrukturen>. (That is, I'm sure books by Knuth
2915 were published under those titles, but I'm I<assuming> that they're just
2916 later printings/editions of I<Algorithms + Data Structures =
2921 David Hand, C<< <cogent@cpan.org> >>
2925 Sean M. Burke, C<< <sburke@cpan.org> >>
2927 =head1 COPYRIGHT, LICENSE, AND DISCLAIMER
2929 Copyright 1998-2001, 2004, 2007 by Sean M. Burke and David Hand.
2931 This program is free software; you can redistribute it and/or modify it
2932 under the same terms as Perl itself.
2934 This program is distributed in the hope that it will be useful, but
2935 without any warranty; without even the implied warranty of
2936 merchantability or fitness for a particular purpose.
projects / pkg-perl / blob