crest: Tree/DAG_Node.pm comparison

comparison Tree/DAG_Node.pm @ 0:acc8d8bfeb9a

Uploaded

author	jjohnson
date	Wed, 08 Feb 2012 16:59:24 -0500
parents
children

comparison

equal deleted inserted replaced

--1:000000000000
+:acc8d8bfeb9a
+require 5;
+package Tree::DAG_Node;
+use Carp ();
+use strict;
+use vars qw(@ISA $Debug $VERSION);
+$Debug = 0;
+$VERSION = '1.06';
+=head1 NAME
+Tree::DAG_Node - (super)class for representing nodes in a tree
+=head1 SYNOPSIS
+Using as a base class:
+package Game::Tree::Node; # or whatever you're doing
+use Tree::DAG_Node;
+@ISA = qw(Tree::DAG_Node);
+...your own methods overriding/extending
+the methods in Tree::DAG_Node...
+Using as a class of its own:
+use Tree::DAG_Node;
+my $root = Tree::DAG_Node->new();
+$root->name("I'm the tops");
+my $new_daughter = $root->new_daughter;
+$new_daughter->name("More");
+...
+=head1 DESCRIPTION
+This class encapsulates/makes/manipulates objects that represent nodes
+in a tree structure. The tree structure is not an object itself, but
+is emergent from the linkages you create between nodes.  This class
+provides the methods for making linkages that can be used to build up
+a tree, while preventing you from ever making any kinds of linkages
+which are not allowed in a tree (such as having a node be its own
+mother or ancestor, or having a node have two mothers).
+This is what I mean by a "tree structure", a bit redundantly stated:
+* A tree is a special case of an acyclic directed graph.
+* A tree is a network of nodes where there's exactly one root
+node (i.e., 'the top'), and the only primary relationship between nodes
+is the mother-daugher relationship.
+* No node can be its own mother, or its mother's mother, etc.
+* Each node in the tree has exactly one "parent" (node in the "up"
+direction) -- except the root, which is parentless.
+* Each node can have any number (0 to any finite number) of daughter
+nodes.  A given node's daughter nodes constitute an I<ordered> list.
+(However, you are free to consider this ordering irrelevant.
+Some applications do need daughters to be ordered, so I chose to
+consider this the general case.)
+* A node can appear in only one tree, and only once in that tree.
+Notably (notable because it doesn't follow from the two above points),
+a node cannot appear twice in its mother's daughter list.
+* In other words, there's an idea of up (toward the root) versus
+down (away from the root), and left (i.e., toward the start (index 0)
+of a given node's daughter list) versus right (toward the end of a
+given node's daughter list).
+Trees as described above have various applications, among them:
+representing syntactic constituency, in formal linguistics;
+representing contingencies in a game tree; representing abstract
+syntax in the parsing of any computer language -- whether in
+expression trees for programming languages, or constituency in the
+parse of a markup language document.  (Some of these might not use the
+fact that daughters are ordered.)
+(Note: B-Trees are a very special case of the above kinds of trees,
+and are best treated with their own class.  Check CPAN for modules
+encapsulating B-Trees; or if you actually want a database, and for
+some reason ended up looking here, go look at L<AnyDBM_File>.)
+Many base classes are not usable except as such -- but Tree::DAG_Node
+can be used as a normal class.  You can go ahead and say:
+use Tree::DAG_Node;
+my $root = Tree::DAG_Node->new();
+$root->name("I'm the tops");
+$new_daughter = Tree::DAG_Node->new();
+$new_daughter->name("More");
+$root->add_daughter($new_daughter);
+and so on, constructing and linking objects from Tree::DAG_Node and
+making useful tree structures out of them.
+=head1 A NOTE TO THE READER
+This class is big and provides lots of methods.  If your problem is
+simple (say, just representing a simple parse tree), this class might
+seem like using an atomic sledgehammer to swat a fly.  But the
+complexity of this module's bells and whistles shouldn't detract from
+the efficiency of using this class for a simple purpose.  In fact, I'd
+be very surprised if any one user ever had use for more that even a
+third of the methods in this class.  And remember: an atomic
+sledgehammer B<will> kill that fly.
+=head1 OBJECT CONTENTS
+Implementationally, each node in a tree is an object, in the sense of
+being an arbitrarily complex data structure that belongs to a class
+(presumably Tree::DAG_Node, or ones derived from it) that provides
+methods.
+The attributes of a node-object are:
+=over
+=item mother -- this node's mother.  undef if this is a root.
+=item daughters -- the (possibly empty) list of daughters of this node.
+=item name -- the name for this node.
+Need not be unique, or even printable.  This is printed in some of the
+various dumper methods, but it's up to you if you don't put anything
+meaningful or printable here.
+=item attributes -- whatever the user wants to use it for.
+Presumably a hashref to whatever other attributes the user wants to
+store without risk of colliding with the object's real attributes.
+(Example usage: attributes to an SGML tag -- you definitely wouldn't
+want the existence of a "mother=foo" pair in such a tag to collide with
+a node object's 'mother' attribute.)
+Aside from (by default) initializing it to {}, and having the access
+method called "attributes" (described a ways below), I don't do
+anything with the "attributes" in this module.  I basically intended
+this so that users who don't want/need to bother deriving a class
+from Tree::DAG_Node, could still attach whatever data they wanted in a
+node.
+=back
+"mother" and "daughters" are attributes that relate to linkage -- they
+are never written to directly, but are changed as appropriate by the
+"linkage methods", discussed below.
+The other two (and whatever others you may add in derived classes) are
+simply accessed thru the same-named methods, discussed further below.
+=head2 ABOUT THE DOCUMENTED INTERFACE
+Stick to the documented interface (and comments in the source --
+especially ones saying "undocumented!" and/or "disfavored!" -- do not
+count as documentation!), and don't rely on any behavior that's not in
+the documented interface.
+Specifically, unless the documentation for a particular method says
+"this method returns thus-and-such a value", then you should not rely on
+it returning anything meaningful.
+A I<passing> acquintance with at least the broader details of the source
+code for this class is assumed for anyone using this class as a base
+class -- especially if you're overriding existing methods, and
+B<definitely> if you're overriding linkage methods.
+=head1 MAIN CONSTRUCTOR, AND INITIALIZER
+=over
+=item the constructor CLASS->new() or CLASS->new({...options...})
+This creates a new node object, calls $object->_init({...options...})
+to provide it sane defaults (like: undef name, undef mother, no
+daughters, 'attributes' setting of a new empty hashref), and returns
+the object created.  (If you just said "CLASS->new()" or "CLASS->new",
+then it pretends you called "CLASS->new({})".)
+Currently no options for putting in {...options...} are part
+of the documented interface, but the options is here in case
+you want to add such behavior in a derived class.
+Read on if you plan on using Tree::DAG_New as a base class.
+(Otherwise feel free to skip to the description of _init.)
+There are, in my mind, two ways to do object construction:
+Way 1: create an object, knowing that it'll have certain uninteresting
+sane default values, and then call methods to change those values to
+what you want.  Example:
+$node = Tree::DAG_Node->new;
+$node->name('Supahnode!');
+$root->add_daughter($node);
+$node->add_daughters(@some_others)
+Way 2: be able to specify some/most/all the object's attributes in
+the call to the constructor.  Something like:
+$node = Tree::DAG_Node->new({
+name => 'Supahnode!',
+mother => $root,
+daughters => \@some_others
+});
+After some deliberation, I've decided that the second way is a Bad
+Thing.  First off, it is B<not> markedly more concise than the first
+way.  Second off, it often requires subtly different syntax (e.g.,
+\@some_others vs @some_others).  It just complicates things for the
+programmer and the user, without making either appreciably happier.
+(This is not to say that options in general for a constructor are bad
+-- C<random_network>, discussed far below, necessarily takes options.
+But note that those are not options for the default values of
+attributes.)
+Anyway, if you use Tree::DAG_Node as a superclass, and you add
+attributes that need to be initialized, what you need to do is provide
+an _init method that calls $this->SUPER::_init($options) to use its
+superclass's _init method, and then initializes the new attributes:
+sub _init {
+my($this, $options) = @_[0,1];
+$this->SUPER::_init($options); # call my superclass's _init to
+# init all the attributes I'm inheriting
+# Now init /my/ new attributes:
+$this->{'amigos'} = []; # for example
+}
+...or, as I prefer when I'm being a neat freak:
+sub _init {
+my($this, $options) = @_[0,1];
+$this->SUPER::_init($options);
+$this->_init_amigos($options);
+}
+sub _init_amigos {
+my $this = $_[0];
+# Or my($this,$options) = @_[0,1]; if I'm using $options
+$this->{'amigos'} = [];
+}
+In other words, I like to have each attribute initialized thru a
+method named _init_[attribute], which should expect the object as
+$_[0] and the the options hashref (or {} if none was given) as $_[1].
+If you insist on having your _init recognize options for setting
+attributes, you might as well have them dealt with by the appropriate
+_init_[attribute] method, like this:
+sub _init {
+my($this, $options) = @_[0,1];
+$this->SUPER::_init($options);
+$this->_init_amigos($options);
+}
+sub _init_amigos {
+my($this,$options) = @_[0,1]; # I need options this time
+$this->{'amigos'} = [];
+$this->amigos(@{$options->{'amigos'}}) if $options->{'amigos'};
+}
+All this bookkeeping looks silly with just one new attribute in a
+class derived straight from Tree::DAG_Node, but if there's lots of new
+attributes running around, and if you're deriving from a class derived
+from a class derived from Tree::DAG_Node, then tidy
+stratification/modularization like this can keep you sane.
+=item the constructor $obj->new() or $obj->new({...options...})
+Just another way to get at the C<new> method. This B<does not copy>
+$obj, but merely constructs a new object of the same class as it.
+Saves you the bother of going $class = ref $obj; $obj2 = $class->new;
+=cut
+sub new { # constructor
+# Presumably you won't EVER need to override this -- _init is what
+# you'd override in order to set an object's default attribute values.
+my $class = shift;
+$class = ref($class) if ref($class); # tchristic style.  why not?
+my $o = ref($_[0]) eq 'HASH' ? $_[0] : {}; # o for options hashref
+my $it = bless( {}, $class );
+print "Constructing $it in class $class\n" if $Debug;
+$it->_init( $o );
+return $it;
+}
+###########################################################################
+=item the method $node->_init({...options...})
+Initialize the object's attribute values.  See the discussion above.
+Presumably this should be called only by the guts of the C<new>
+constructor -- never by the end user.
+Currently there are no documented options for putting in
+{...options...}, but (in case you want to disregard the above rant)
+the option exists for you to use {...options...} for something useful
+in a derived class.
+Please see the source for more information.
+=item see also (below) the constructors "new_daughter" and "new_daughter_left"
+=back
+=cut
+sub _init { # method
+my $this = shift;
+my $o = ref($_[0]) eq 'HASH' ? $_[0] : {};
+# Sane initialization.
+$this->_init_mother($o);
+$this->_init_daughters($o);
+$this->_init_name($o);
+$this->_init_attributes($o);
+return;
+}
+sub _init_mother { # to be called by an _init
+my($this, $o) = @_[0,1];
+$this->{'mother'} = undef;
+# Undocumented and disfavored.  Consider this just an example.
+( $o->{'mother'} )->add_daughter($this)
+if defined($o->{'mother'}) && ref($o->{'mother'});
+# DO NOT use this option (as implemented) with new_daughter or
+#  new_daughter_left!!!!!
+# BAD THINGS MAY HAPPEN!!!
+}
+sub _init_daughters { # to be called by an _init
+my($this, $o) = @_[0,1];
+$this->{'daughters'} = [];
+# Undocumented and disfavored.  Consider this just an example.
+$this->set_daughters( @{$o->{'daughters'}} )
+if ref($o->{'daughters'}) && (@{$o->{'daughters'}});
+# DO NOT use this option (as implemented) with new_daughter or
+#  new_daughter_left!!!!!
+# BAD THINGS MAY HAPPEN!!!
+}
+sub _init_name { # to be called by an _init
+my($this, $o) = @_[0,1];
+$this->{'name'} = undef;
+# Undocumented and disfavored.  Consider this just an example.
+$this->name( $o->{'name'} ) if exists $o->{'name'};
+}
+sub _init_attributes { # to be called by an _init
+my($this, $o) = @_[0,1];
+$this->{'attributes'} = {};
+# Undocumented and disfavored.  Consider this just an example.
+$this->attributes( $o->{'attributes'} ) if exists $o->{'attributes'};
+}
+###########################################################################
+###########################################################################
+=head1 LINKAGE-RELATED METHODS
+=over
+=item $node->daughters
+This returns the (possibly empty) list of daughters for $node.
+=cut
+sub daughters { # read-only attrib-method: returns a list.
+my $this = shift;
+if(@_) { # undoc'd and disfavored to use as a write-method
+Carp::croak "Don't set daughters with doughters anymore\n";
+Carp::carp "my parameter must be a listref" unless ref($_[0]);
+$this->{'daughters'} = $_[0];
+$this->_update_daughter_links;
+}
+#return $this->{'daughters'};
+return @{$this->{'daughters'} || []};
+}
+###########################################################################
+=item $node->mother
+This returns what node is $node's mother.  This is undef if $node has
+no mother -- i.e., if it is a root.
+=cut
+sub mother { # read-only attrib-method: returns an object (the mother node)
+my $this = shift;
+Carp::croak "I'm a read-only method!" if @_;
+return $this->{'mother'};
+}
+###########################################################################
+###########################################################################
+=item $mother->add_daughters( LIST )
+This method adds the node objects in LIST to the (right) end of
+$mother's C<daughter> list.  Making a node N1 the daughter of another
+node N2 also means that N1's C<mother> attribute is "automatically" set
+to N2; it also means that N1 stops being anything else's daughter as
+it becomes N2's daughter.
+If you try to make a node its own mother, a fatal error results.  If
+you try to take one of a a node N1's ancestors and make it also a
+daughter of N1, a fatal error results.  A fatal error results if
+anything in LIST isn't a node object.
+If you try to make N1 a daughter of N2, but it's B<already> a daughter
+of N2, then this is a no-operation -- it won't move such nodes to the
+end of the list or anything; it just skips doing anything with them.
+=item $node->add_daughter( LIST )
+An exact synonym for $node->add_daughters(LIST)
+=cut
+sub add_daughters { # write-only method
+my($mother, @daughters) = @_;
+return unless @daughters; # no-op
+return
+$mother->_add_daughters_wrapper(
+sub { push @{$_[0]}, $_[1]; },
+@daughters
+);
+}
+sub add_daughter { # alias
+my($it,@them) = @_;  $it->add_daughters(@them);
+}
+=item $mother->add_daughters_left( LIST )
+This method is just like C<add_daughters>, except that it adds the
+node objects in LIST to the (left) beginning of $mother's daughter
+list, instead of the (right) end of it.
+=item $node->add_daughter_left( LIST )
+An exact synonym for $node->add_daughters_left( LIST )
+=cut
+sub add_daughters_left { # write-only method
+my($mother, @daughters) = @_;
+return unless @daughters;
+return
+$mother->_add_daughters_wrapper(
+sub { unshift @{$_[0]}, $_[1]; },
+@daughters
+);
+}
+sub add_daughter_left { # alias
+my($it,@them) = @_;  $it->add_daughters_left(@them);
+}
+=item Note:
+The above link-making methods perform basically an C<unshift> or
+C<push> on the mother node's daughter list.  To get the full range of
+list-handling functionality, copy the daughter list, and change it,
+and then call C<set_daughters> on the result:
+@them = $mother->daughters;
+@removed = splice(@them, 0,2, @new_nodes);
+$mother->set_daughters(@them);
+Or consider a structure like:
+$mother->set_daughters(
+grep($_->name =~ /NP/ ,
+$mother->daughters
+)
+);
+=cut
+###
+##  Used by the adding methods
+#    (except maybe new_daughter, and new_daughter_left)
+sub _add_daughters_wrapper {
+my($mother, $callback, @daughters) = @_;
+return unless @daughters;
+my %ancestors;
+@ancestors{ $mother->ancestors } = undef;
+# This could be made more efficient by not bothering to compile
+# the ancestor list for $mother if all the nodes to add are
+# daughterless.
+# But then you have to CHECK if they're daughterless.
+# If $mother is [big number] generations down, then it's worth checking.
+foreach my $daughter (@daughters) { # which may be ()
+Carp::croak "daughter must be a node object!" unless UNIVERSAL::can($daughter, 'is_node');
+printf "Mother  : %s (%s)\n", $mother, ref $mother if $Debug;
+printf "Daughter: %s (%s)\n", $daughter, ref $daughter if $Debug;
+printf "Adding %s to %s\n",
+($daughter->name() || $daughter),
+($mother->name()   || $mother)     if $Debug > 1;
+Carp::croak "mother can't be its own daughter!" if $mother eq $daughter;
+$daughter->cyclicity_fault(
+"$daughter (" . ($daughter->name || 'no_name') .
+") is an ancestor of $mother (" . ($mother->name || 'no_name') .
+"), so can't became its daughter."
+) if exists $ancestors{$daughter};
+my $old_mother = $daughter->{'mother'};
+next if defined($old_mother) && ref($old_mother) && $old_mother eq $mother;
+# noop if $daughter is already $mother's daughter
+$old_mother->remove_daughters($daughter)
+if defined($old_mother) && ref($old_mother);
+&{$callback}($mother->{'daughters'}, $daughter);
+}
+$mother->_update_daughter_links; # need only do this at the end
+return;
+}
+###########################################################################
+###########################################################################
+sub _update_daughter_links {
+# Eliminate any duplicates in my daughters list, and update
+#  all my daughters' links to myself.
+my $this = shift;
+my $them = $this->{'daughters'};
+# Eliminate duplicate daughters.
+my %seen = ();
+@$them = grep { ref($_) && not($seen{$_}++) } @$them;
+# not that there should ever be duplicate daughters anyhoo.
+foreach my $one (@$them) { # linkage bookkeeping
+Carp::croak "daughter <$one> isn't an object!" unless ref $one;
+$one->{'mother'} = $this;
+}
+return;
+}
+###########################################################################
+# Currently unused.
+sub _update_links { # update all descendant links for ancestorship below
+# this point
+# note: it's "descendant", not "descendent"
+# see <http://www.lenzo.com/~sburke/stuff/english_ant_and_ent.html>
+my $this = shift;
+# $this->no_cyclicity;
+$this->walk_down({
+'callback' => sub {
+my $this = $_[0];
+$this->_update_daughter_links;
+return 1;
+},
+});
+}
+###########################################################################
+###########################################################################
+=item the constructor $daughter = $mother->new_daughter, or
+=item the constructor $daughter = $mother->new_daughter({...options...})
+This B<constructs> a B<new> node (of the same class as $mother), and
+adds it to the (right) end of the daughter list of $mother. This is
+essentially the same as going
+$daughter = $mother->new;
+$mother->add_daughter($daughter);
+but is rather more efficient because (since $daughter is guaranteed new
+and isn't linked to/from anything), it doesn't have to check that
+$daughter isn't an ancestor of $mother, isn't already daughter to a
+mother it needs to be unlinked from, isn't already in $mother's
+daughter list, etc.
+As you'd expect for a constructor, it returns the node-object created.
+=cut
+# Note that if you radically change 'mother'/'daughters' bookkeeping,
+# you may have to change this routine, since it's one of the places
+# that directly writes to 'daughters' and 'mother'.
+sub new_daughter {
+my($mother, @options) = @_;
+my $daughter = $mother->new(@options);
+push @{$mother->{'daughters'}}, $daughter;
+$daughter->{'mother'} = $mother;
+return $daughter;
+}
+=item the constructor $mother->new_daughter_left, or
+=item $mother->new_daughter_left({...options...})
+This is just like $mother->new_daughter, but adds the new daughter
+to the left (start) of $mother's daughter list.
+=cut
+# Note that if you radically change 'mother'/'daughters' bookkeeping,
+# you may have to change this routine, since it's one of the places
+# that directly writes to 'daughters' and 'mother'.
+sub new_daughter_left {
+my($mother, @options) = @_;
+my $daughter = $mother->new(@options);
+unshift @{$mother->{'daughters'}}, $daughter;
+$daughter->{'mother'} = $mother;
+return $daughter;
+}
+###########################################################################
+=item $mother->remove_daughters( LIST )
+This removes the nodes listed in LIST from $mother's daughter list.
+This is a no-operation if LIST is empty.  If there are things in LIST
+that aren't a current daughter of $mother, they are ignored.
+Not to be confused with $mother->clear_daughters.
+=cut
+sub remove_daughters { # write-only method
+my($mother, @daughters) = @_;
+Carp::croak "mother must be an object!" unless ref $mother;
+return unless @daughters;
+my %to_delete;
+@daughters = grep {ref($_)
+		       and defined($_->{'mother'})
+		       and $mother eq $_->{'mother'}
+} @daughters;
+return unless @daughters;
+@to_delete{ @daughters } = undef;
+# This could be done better and more efficiently, I guess.
+foreach my $daughter (@daughters) {
+$daughter->{'mother'} = undef;
+}
+my $them = $mother->{'daughters'};
+@$them = grep { !exists($to_delete{$_}) } @$them;
+# $mother->_update_daughter_links; # unnecessary
+return;
+}
+=item $node->remove_daughter( LIST )
+An exact synonym for $node->remove_daughters( LIST )
+=cut
+sub remove_daughter { # alias
+my($it,@them) = @_;  $it->remove_daughters(@them);
+}
+=item $node->unlink_from_mother
+This removes node from the daughter list of its mother.  If it has no
+mother, this is a no-operation.
+Returns the mother unlinked from (if any).
+=cut
+sub unlink_from_mother {
+my $node = $_[0];
+my $mother = $node->{'mother'};
+$mother->remove_daughters($node) if defined($mother) && ref($mother);
+return $mother;
+}
+###########################################################################
+=item $mother->clear_daughters
+This unlinks all $mother's daughters.
+Returns the the list of what used to be $mother's daughters.
+Not to be confused with $mother->remove_daughters( LIST ).
+=cut
+sub clear_daughters { # write-only method
+my($mother) = $_[0];
+my @daughters = @{$mother->{'daughters'}};
+@{$mother->{'daughters'}} = ();
+foreach my $one (@daughters) {
+next unless UNIVERSAL::can($one, 'is_node'); # sanity check
+$one->{'mother'} = undef;
+}
+# Another, simpler, way to do it:
+#  $mother->remove_daughters($mother->daughters);
+return @daughters; # NEW
+}
+#--------------------------------------------------------------------------
+=item $mother->set_daughters( LIST )
+This unlinks all $mother's daughters, and replaces them with the
+daughters in LIST.
+Currently implemented as just $mother->clear_daughters followed by
+$mother->add_daughters( LIST ).
+=cut
+sub set_daughters { # write-only method
+my($mother, @them) = @_;
+$mother->clear_daughters;
+$mother->add_daughters(@them) if @them;
+# yup, it's that simple
+}
+#--------------------------------------------------------------------------
+=item $node->replace_with( LIST )
+This replaces $node in its mother's daughter list, by unlinking $node
+and replacing it with the items in LIST.  This returns a list consisting
+of $node followed by LIST, i.e., the nodes that replaced it.
+LIST can include $node itself (presumably at most once).  LIST can
+also be empty-list.  However, if any items in LIST are sisters to
+$node, they are ignored, and are not in the copy of LIST passed as the
+return value.
+As you might expect for any linking operation, the items in LIST
+cannot be $node's mother, or any ancestor to it; and items in LIST are,
+of course, unlinked from their mothers (if they have any) as they're
+linked to $node's mother.
+(In the special (and bizarre) case where $node is root, this simply calls
+$this->unlink_from_mother on all the items in LIST, making them roots of
+their own trees.)
+Note that the daughter-list of $node is not necessarily affected; nor
+are the daughter-lists of the items in LIST.  I mention this in case you
+think replace_with switches one node for another, with respect to its
+mother list B<and> its daughter list, leaving the rest of the tree
+unchanged. If that's what you want, replacing $Old with $New, then you
+want:
+$New->set_daughters($Old->clear_daughters);
+$Old->replace_with($New);
+(I can't say $node's and LIST-items' daughter lists are B<never>
+affected my replace_with -- they can be affected in this case:
+$N1 = ($node->daughters)[0]; # first daughter of $node
+$N2 = ($N1->daughters)[0];   # first daughter of $N1;
+$N3 = Tree::DAG_Node->random_network; # or whatever
+$node->replace_with($N1, $N2, $N3);
+As a side affect of attaching $N1 and $N2 to $node's mother, they're
+unlinked from their parents ($node, and $N1, replectively).
+But N3's daughter list is unaffected.
+In other words, this method does what it has to, as you'd expect it
+to.
+=cut
+sub replace_with { # write-only method
+my($this, @replacements) = @_;
+if(not( defined($this->{'mother'}) && ref($this->{'mother'}) )) { # if root
+foreach my $replacement (@replacements) {
+$replacement->{'mother'}->remove_daughters($replacement)
+if $replacement->{'mother'};
+}
+# make 'em roots
+} else { # I have a mother
+my $mother = $this->{'mother'};
+#@replacements = grep(($_ eq $this  ||  $_->{'mother'} ne $mother),
+#                     @replacements);
+@replacements = grep { $_ eq $this
+|| not(defined($_->{'mother'}) &&
+ref($_->{'mother'}) &&
+$_->{'mother'} eq $mother
+)
+}
+@replacements;
+# Eliminate sisters (but not self)
+# i.e., I want myself or things NOT with the same mother as myself.
+$mother->set_daughters(   # old switcheroo
+map($_ eq $this ? (@replacements) : $_ ,
+@{$mother->{'daughters'}}
+)
+);
+# and set_daughters does all the checking and possible
+# unlinking
+}
+return($this, @replacements);
+}
+=item $node->replace_with_daughters
+This replaces $node in its mother's daughter list, by unlinking $node
+and replacing it with its daughters.  In other words, $node becomes
+motherless and daughterless as its daughters move up and take its place.
+This returns a list consisting of $node followed by the nodes that were
+its daughters.
+In the special (and bizarre) case where $node is root, this simply
+unlinks its daughters from it, making them roots of their own trees.
+Effectively the same as $node->replace_with($node->daughters), but more
+efficient, since less checking has to be done.  (And I also think
+$node->replace_with_daughters is a more common operation in
+tree-wrangling than $node->replace_with(LIST), so deserves a named
+method of its own, but that's just me.)
+=cut
+# Note that if you radically change 'mother'/'daughters' bookkeeping,
+# you may have to change this routine, since it's one of the places
+# that directly writes to 'daughters' and 'mother'.
+sub replace_with_daughters { # write-only method
+my($this) = $_[0]; # takes no params other than the self
+my $mother = $this->{'mother'};
+return($this, $this->clear_daughters)
+unless defined($mother) && ref($mother);
+my @daughters = $this->clear_daughters;
+my $sib_r = $mother->{'daughters'};
+@$sib_r = map($_ eq $this ? (@daughters) : $_,
+@$sib_r   # old switcheroo
+);
+foreach my $daughter (@daughters) {
+$daughter->{'mother'} = $mother;
+}
+return($this, @daughters);
+}
+#--------------------------------------------------------------------------
+=item $node->add_left_sisters( LIST )
+This adds the elements in LIST (in that order) as immediate left sisters of
+$node.  In other words, given that B's mother's daughter-list is (A,B,C,D),
+calling B->add_left_sisters(X,Y) makes B's mother's daughter-list
+(A,X,Y,B,C,D).
+If LIST is empty, this is a no-op, and returns empty-list.
+This is basically implemented as a call to $node->replace_with(LIST,
+$node), and so all replace_with's limitations and caveats apply.
+The return value of $node->add_left_sisters( LIST ) is the elements of
+LIST that got added, as returned by replace_with -- minus the copies
+of $node you'd get from a straight call to $node->replace_with(LIST,
+$node).
+=cut
+sub add_left_sisters { # write-only method
+my($this, @new) = @_;
+return() unless @new;
+@new = $this->replace_with(@new, $this);
+shift @new; pop @new; # kill the copies of $this
+return @new;
+}
+=item $node->add_left_sister( LIST )
+An exact synonym for $node->add_left_sisters(LIST)
+=cut
+sub add_left_sister { # alias
+my($it,@them) = @_;  $it->add_left_sisters(@them);
+}
+=item $node->add_right_sisters( LIST )
+Just like add_left_sisters (which see), except that the the elements
+in LIST (in that order) as immediate B<right> sisters of $node;
+In other words, given that B's mother's daughter-list is (A,B,C,D),
+calling B->add_right_sisters(X,Y) makes B's mother's daughter-list
+(A,B,X,Y,C,D).
+=cut
+sub add_right_sisters { # write-only method
+my($this, @new) = @_;
+return() unless @new;
+@new = $this->replace_with($this, @new);
+shift @new; shift @new; # kill the copies of $this
+return @new;
+}
+=item $node->add_right_sister( LIST )
+An exact synonym for $node->add_right_sisters(LIST)
+=cut
+sub add_right_sister { # alias
+my($it,@them) = @_;  $it->add_right_sisters(@them);
+}
+###########################################################################
+=back
+=cut
+###########################################################################
+###########################################################################
+=head1 OTHER ATTRIBUTE METHODS
+=over
+=item $node->name or $node->name(SCALAR)
+In the first form, returns the value of the node object's "name"
+attribute.  In the second form, sets it to the value of SCALAR.
+=cut
+sub name { # read/write attribute-method.  returns/expects a scalar
+my $this = shift;
+$this->{'name'} = $_[0] if @_;
+return $this->{'name'};
+}
+###########################################################################
+=item $node->attributes or $node->attributes(SCALAR)
+In the first form, returns the value of the node object's "attributes"
+attribute.  In the second form, sets it to the value of SCALAR.  I
+intend this to be used to store a reference to a (presumably
+anonymous) hash the user can use to store whatever attributes he
+doesn't want to have to store as object attributes.  In this case, you
+needn't ever set the value of this.  (_init has already initialized it
+to {}.)  Instead you can just do...
+$node->attributes->{'foo'} = 'bar';
+...to write foo => bar.
+=cut
+sub attributes { # read/write attribute-method
+# expects a ref, presumably a hashref
+my $this = shift;
+if(@_) {
+Carp::carp "my parameter must be a reference" unless ref($_[0]);
+$this->{'attributes'} = $_[0];
+}
+return $this->{'attributes'};
+}
+=item $node->attribute or $node->attribute(SCALAR)
+An exact synonym for $node->attributes or $node->attributes(SCALAR)
+=cut
+sub attribute { # alias
+my($it,@them) = @_;  $it->attributes(@them);
+}
+###########################################################################
+# Secret Stuff.
+sub no_cyclicity { # croak iff I'm in a CYCLIC class.
+my($it) = $_[0];
+# If, God forbid, I use this to make a cyclic class, then I'd
+# expand the functionality of this routine to actually look for
+# cyclicity.  Or something like that.  Maybe.
+$it->cyclicity_fault("You can't do that in a cyclic class!")
+if $it->cyclicity_allowed;
+return;
+}
+sub cyclicity_fault {
+my($it, $bitch) = @_[0,1];
+Carp::croak "Cyclicity fault: $bitch"; # never return
+}
+sub cyclicity_allowed {
+return 0;
+}
+###########################################################################
+# More secret stuff.  Currently unused.
+sub inaugurate_root { # no-op
+my($it, $tree) = @_[0,1];
+# flag this node as being the root of the tree $tree.
+return;
+}
+sub decommission_root { # no-op
+# flag this node as no longer being the root of the tree $tree.
+return;
+}
+###########################################################################
+###########################################################################
+=back
+=head1 OTHER METHODS TO DO WITH RELATIONSHIPS
+=over
+=item $node->is_node
+This always returns true.  More pertinently, $object->can('is_node')
+is true (regardless of what C<is_node> would do if called) for objects
+belonging to this class or for any class derived from it.
+=cut
+sub is_node { return 1; } # always true.
+# NEVER override this with anything that returns false in the belief
+#  that this'd signal "not a node class".  The existence of this method
+#  is what I test for, with the various "can()" uses in this class.
+###########################################################################
+=item $node->ancestors
+Returns the list of this node's ancestors, starting with its mother,
+then grandmother, and ending at the root.  It does this by simply
+following the 'mother' attributes up as far as it can.  So if $item IS
+the root, this returns an empty list.
+Consider that scalar($node->ancestors) returns the ply of this node
+within the tree -- 2 for a granddaughter of the root, etc., and 0 for
+root itself.
+=cut
+sub ancestors {
+my $this = shift;
+my $mama = $this->{'mother'}; # initial condition
+return () unless ref($mama); # I must be root!
+# $this->no_cyclicity; # avoid infinite loops
+# Could be defined recursively, as:
+# if(ref($mama = $this->{'mother'})){
+#   return($mama, $mama->ancestors);
+# } else {
+#   return ();
+# }
+# But I didn't think of that until I coded the stuff below, which is
+# faster.
+my @ancestors = ( $mama ); # start off with my mama
+while(defined( $mama = $mama->{'mother'} ) && ref($mama)) {
+# Walk up the tree
+push(@ancestors, $mama);
+# This turns into an infinite loop if someone gets stupid
+#  and makes this tree cyclic!  Don't do it!
+}
+return @ancestors;
+}
+###########################################################################
+=item $node->root
+Returns the root of whatever tree $node is a member of.  If $node is
+the root, then the result is $node itself.
+=cut
+sub root {
+my $it = $_[0];
+my @ancestors = ($it, $it->ancestors);
+return $ancestors[-1];
+}
+###########################################################################
+=item $node->is_daughter_of($node2)
+Returns true iff $node is a daughter of $node2.
+Currently implemented as just a test of ($it->mother eq $node2).
+=cut
+sub is_daughter_of {
+my($it,$mama) = @_[0,1];
+return $it->{'mother'} eq $mama;
+}
+###########################################################################
+=item $node->self_and_descendants
+Returns a list consisting of itself (as element 0) and all the
+descendants of $node.  Returns just itself if $node is a
+terminal_node.
+(Note that it's spelled "descendants", not "descendents".)
+=cut
+sub self_and_descendants {
+# read-only method:  return a list of myself and any/all descendants
+my $node = shift;
+my @List = ();
+# $node->no_cyclicity;
+$node->walk_down({ 'callback' => sub { push @List, $_[0]; return 1;}});
+Carp::croak "Spork Error 919: \@List has no contents!?!?" unless @List;
+# impossible
+return @List;
+}
+###########################################################################
+=item $node->descendants
+Returns a list consisting of all the descendants of $node.  Returns
+empty-list if $node is a terminal_node.
+(Note that it's spelled "descendants", not "descendents".)
+=cut
+sub descendants {
+# read-only method:  return a list of my descendants
+my $node = shift;
+my @list = $node->self_and_descendants;
+shift @list; # lose myself.
+return @list;
+}
+###########################################################################
+=item $node->leaves_under
+Returns a list (going left-to-right) of all the leaf nodes under
+$node.  ("Leaf nodes" are also called "terminal nodes" -- i.e., nodes
+that have no daughters.)  Returns $node in the degenerate case of
+$node being a leaf itself.
+=cut
+sub leaves_under {
+# read-only method:  return a list of all leaves under myself.
+# Returns myself in the degenerate case of being a leaf myself.
+my $node = shift;
+my @List = ();
+# $node->no_cyclicity;
+$node->walk_down({ 'callback' =>
+sub {
+my $node = $_[0];
+my @daughters = @{$node->{'daughters'}};
+push(@List, $node) unless @daughters;
+return 1;
+}
+});
+Carp::croak "Spork Error 861: \@List has no contents!?!?" unless @List;
+# impossible
+return @List;
+}
+###########################################################################
+=item $node->depth_under
+Returns an integer representing the number of branches between this
+$node and the most distant leaf under it.  (In other words, this
+returns the ply of subtree starting of $node.  Consider
+scalar($it->ancestors) if you want the ply of a node within the whole
+tree.)
+=cut
+sub depth_under {
+my $node = shift;
+my $max_depth = 0;
+$node->walk_down({
+'_depth' => 0,
+'callback' => sub {
+my $depth = $_[1]->{'_depth'};
+$max_depth = $depth if $depth > $max_depth;
+return 1;
+},
+});
+return $max_depth;
+}
+###########################################################################
+=item $node->generation
+Returns a list of all nodes (going left-to-right) that are in $node's
+generation -- i.e., that are the some number of nodes down from
+the root.  $root->generation is just $root.
+Of course, $node is always in its own generation.
+=item $node->generation_under(NODE2)
+Like $node->generation, but returns only the nodes in $node's generation
+that are also descendants of NODE2 -- in other words,
+@us = $node->generation_under( $node->mother->mother );
+is all $node's first cousins (to borrow yet more kinship terminology) --
+assuming $node does indeed have a grandmother.  Actually "cousins" isn't
+quite an apt word, because C<@us> ends up including $node's siblings and
+$node.
+Actually, C<generation_under> is just an alias to C<generation>, but I
+figure that this:
+@us = $node->generation_under($way_upline);
+is a bit more readable than this:
+@us = $node->generation($way_upline);
+But it's up to you.
+$node->generation_under($node) returns just $node.
+If you call $node->generation_under($node) but NODE2 is not $node or an
+ancestor of $node, it behaves as if you called just $node->generation().
+=cut
+sub generation {
+my($node, $limit) = @_[0,1];
+# $node->no_cyclicity;
+return $node
+if $node eq $limit || not(
+			      defined($node->{'mother'}) &&
+			      ref($node->{'mother'})
+			     ); # bailout
+return map(@{$_->{'daughters'}}, $node->{'mother'}->generation($limit));
+# recurse!
+# Yup, my generation is just all the daughters of my mom's generation.
+}
+sub generation_under {
+my($node, @rest) = @_;
+return $node->generation(@rest);
+}
+###########################################################################
+=item $node->self_and_sisters
+Returns a list of all nodes (going left-to-right) that have the same
+mother as $node -- including $node itself. This is just like
+$node->mother->daughters, except that that fails where $node is root,
+whereas $root->self_and_siblings, as a special case, returns $root.
+(Contrary to how you may interpret how this method is named, "self" is
+not (necessarily) the first element of what's returned.)
+=cut
+sub self_and_sisters {
+my $node = $_[0];
+my $mother = $node->{'mother'};
+return $node unless defined($mother) && ref($mother);  # special case
+return @{$node->{'mother'}->{'daughters'}};
+}
+###########################################################################
+=item $node->sisters
+Returns a list of all nodes (going left-to-right) that have the same
+mother as $node -- B<not including> $node itself.  If $node is root,
+this returns empty-list.
+=cut
+sub sisters {
+my $node = $_[0];
+my $mother = $node->{'mother'};
+return() unless $mother;  # special case
+return grep($_ ne $node,
+@{$node->{'mother'}->{'daughters'}}
+);
+}
+###########################################################################
+=item $node->left_sister
+Returns the node that's the immediate left sister of $node.  If $node
+is the leftmost (or only) daughter of its mother (or has no mother),
+then this returns undef.
+(See also $node->add_left_sisters(LIST).)
+=cut
+sub left_sister {
+my $it = $_[0];
+my $mother = $it->{'mother'};
+return undef unless $mother;
+my @sisters = @{$mother->{'daughters'}};
+return undef if @sisters  == 1; # I'm an only daughter
+my $left = undef;
+foreach my $one (@sisters) {
+return $left if $one eq $it;
+$left = $one;
+}
+die "SPORK ERROR 9757: I'm not in my mother's daughter list!?!?";
+}
+=item $node->left_sisters
+Returns a list of nodes that're sisters to the left of $node.  If
+$node is the leftmost (or only) daughter of its mother (or has no
+mother), then this returns an empty list.
+(See also $node->add_left_sisters(LIST).)
+=cut
+sub left_sisters {
+my $it = $_[0];
+my $mother = $it->{'mother'};
+return() unless $mother;
+my @sisters = @{$mother->{'daughters'}};
+return() if @sisters  == 1; # I'm an only daughter
+my @out = ();
+foreach my $one (@sisters) {
+return @out if $one eq $it;
+push @out, $one;
+}
+die "SPORK ERROR 9767: I'm not in my mother's daughter list!?!?";
+}
+=item $node->right_sister
+Returns the node that's the immediate right sister of $node.  If $node
+is the rightmost (or only) daughter of its mother (or has no mother),
+then this returns undef.
+(See also $node->add_right_sisters(LIST).)
+=cut
+sub right_sister {
+my $it = $_[0];
+my $mother = $it->{'mother'};
+return undef unless $mother;
+my @sisters = @{$mother->{'daughters'}};
+return undef if @sisters  == 1; # I'm an only daughter
+my $seen = 0;
+foreach my $one (@sisters) {
+return $one if $seen;
+$seen = 1 if $one eq $it;
+}
+die "SPORK ERROR 9777: I'm not in my mother's daughter list!?!?"
+unless $seen;
+return undef;
+}
+=item $node->right_sisters
+Returns a list of nodes that're sisters to the right of $node. If
+$node is the rightmost (or only) daughter of its mother (or has no
+mother), then this returns an empty list.
+(See also $node->add_right_sisters(LIST).)
+=cut
+sub right_sisters {
+my $it = $_[0];
+my $mother = $it->{'mother'};
+return() unless $mother;
+my @sisters = @{$mother->{'daughters'}};
+return() if @sisters  == 1; # I'm an only daughter
+my @out;
+my $seen = 0;
+foreach my $one (@sisters) {
+push @out, $one if $seen;
+$seen = 1 if $one eq $it;
+}
+die "SPORK ERROR 9787: I'm not in my mother's daughter list!?!?"
+unless $seen;
+return @out;
+}
+###########################################################################
+=item $node->my_daughter_index
+Returns what index this daughter is, in its mother's C<daughter> list.
+In other words, if $node is ($node->mother->daughters)[3], then
+$node->my_daughter_index returns 3.
+As a special case, returns 0 if $node has no mother.
+=cut
+sub my_daughter_index {
+# returns what number is my index in my mother's daughter list
+# special case: 0 for root.
+my $node = $_[0];
+my $ord = -1;
+my $mother = $node->{'mother'};
+return 0 unless $mother;
+my @sisters = @{$mother->{'daughters'}};
+die "SPORK ERROR 6512:  My mother has no kids!!!" unless @sisters;
+Find_Self:
+for(my $i = 0; $i < @sisters; $i++) {
+if($sisters[$i] eq $node) {
+$ord = $i;
+last Find_Self;
+}
+}
+die "SPORK ERROR 2837: I'm not a daughter of my mother?!?!" if $ord == -1;
+return $ord;
+}
+###########################################################################
+=item $node->address or $anynode->address(ADDRESS)
+With the first syntax, returns the address of $node within its tree,
+based on its position within the tree.  An address is formed by noting
+the path between the root and $node, and concatenating the
+daughter-indices of the nodes this passes thru (starting with 0 for
+the root, and ending with $node).
+For example, if to get from node ROOT to node $node, you pass thru
+ROOT, A, B, and $node, then the address is determined as:
+* ROOT's my_daughter_index is 0.
+* A's my_daughter_index is, suppose, 2. (A is index 2 in ROOT's
+daughter list.)
+* B's my_daughter_index is, suppose, 0. (B is index 0 in A's
+daughter list.)
+* $node's my_daughter_index is, suppose, 4. ($node is index 4 in
+B's daughter list.)
+The address of the above-described $node is, therefore, "0:2:0:4".
+(As a somewhat special case, the address of the root is always "0";
+and since addresses start from the root, all addresses start with a
+"0".)
+The second syntax, where you provide an address, starts from the root
+of the tree $anynode belongs to, and returns the node corresponding to
+that address.  Returns undef if no node corresponds to that address.
+Note that this routine may be somewhat liberal in its interpretation
+of what can constitute an address; i.e., it accepts "0.2.0.4", besides
+"0:2:0:4".
+Also note that the address of a node in a tree is meaningful only in
+that tree as currently structured.
+(Consider how ($address1 cmp $address2) may be magically meaningful
+to you, if you mant to figure out what nodes are to the right of what
+other nodes.)
+=cut
+sub address {
+my($it, $address) = @_[0,1];
+if(defined($address) && length($address)) { # given the address, return the node.
+# invalid addresses return undef
+my $root = $it->root;
+my @parts = map {$_ + 0}
+$address =~ m/(\d+)/g; # generous!
+Carp::croak "Address \"$address\" is an ill-formed address" unless @parts;
+Carp::croak "Address \"$address\" must start with '0'" unless shift(@parts) == 0;
+my $current_node = $root;
+while(@parts) { # no-op for root
+my $ord = shift @parts;
+my @daughters = @{$current_node->{'daughters'}};
+if($#daughters < $ord) { # illegal address
+print "* $address has an out-of-range index ($ord)!" if $Debug;
+return undef;
+}
+$current_node = $daughters[$ord];
+unless(ref($current_node)) {
+print "* $address points to or thru a non-node!" if $Debug;
+return undef;
+}
+}
+return $current_node;
+} else { # given the node, return the address
+my @parts = ();
+my $current_node = $it;
+my $mother;
+while(defined( $mother = $current_node->{'mother'} ) && ref($mother)) {
+unshift @parts, $current_node->my_daughter_index;
+$current_node = $mother;
+}
+return join(':', 0, @parts);
+}
+}
+###########################################################################
+=item $node->common(LIST)
+Returns the lowest node in the tree that is ancestor-or-self to the
+nodes $node and LIST.
+If the nodes are far enough apart in the tree, the answer is just the
+root.
+If the nodes aren't all in the same tree, the answer is undef.
+As a degenerate case, if LIST is empty, returns $node.
+=cut
+sub common { # Return the lowest node common to all these nodes...
+# Called as $it->common($other) or $it->common(@others)
+my @ones = @_; # all nodes I was given
+my($first, @others) = @_;
+return $first unless @others; # degenerate case
+my %ones;
+@ones{ @ones } = undef;
+foreach my $node (@others) {
+Carp::croak "TILT: node \"$node\" is not a node"
+unless UNIVERSAL::can($node, 'is_node');
+my %first_lineage;
+@first_lineage{$first, $first->ancestors} = undef;
+my $higher = undef; # the common of $first and $node
+my @my_lineage = $node->ancestors;
+Find_Common:
+while(@my_lineage) {
+if(exists $first_lineage{$my_lineage[0]}) {
+$higher = $my_lineage[0];
+last Find_Common;
+}
+shift @my_lineage;
+}
+return undef unless $higher;
+$first = $higher;
+}
+return $first;
+}
+###########################################################################
+=item $node->common_ancestor(LIST)
+Returns the lowest node that is ancestor to all the nodes given (in
+nodes $node and LIST).  In other words, it answers the question: "What
+node in the tree, as low as possible, is ancestor to the nodes given
+($node and LIST)?"
+If the nodes are far enough apart, the answer is just the root --
+except if any of the nodes are the root itself, in which case the
+answer is undef (since the root has no ancestor).
+If the nodes aren't all in the same tree, the answer is undef.
+As a degenerate case, if LIST is empty, returns $node's mother;
+that'll be undef if $node is root.
+=cut
+sub common_ancestor {
+my @ones = @_; # all nodes I was given
+my($first, @others) = @_;
+return $first->{'mother'} unless @others;
+# which may be undef if $first is the root!
+my %ones;
+@ones{ @ones } = undef; # my arguments
+my $common = $first->common(@others);
+if(exists($ones{$common})) { # if the common is one of my nodes...
+return $common->{'mother'};
+# and this might be undef, if $common is root!
+} else {
+return $common;
+# which might be null if that's all common came up with
+}
+}
+###########################################################################
+###########################################################################
+=back
+=head1 YET MORE METHODS
+=over
+=item $node->walk_down({ callback => \&foo, callbackback => \&foo, ... })
+Performs a depth-first traversal of the structure at and under $node.
+What it does at each node depends on the value of the options hashref,
+which you must provide.  There are three options, "callback" and
+"callbackback" (at least one of which must be defined, as a sub
+reference), and "_depth".  This is what C<walk_down> does, in
+pseudocode form:
+* Start at the $node given.
+* If there's a C<callback>, call it with $node as the first argument,
+and the options hashref as the second argument (which contains the
+potentially useful C<_depth>, remember).  This function must return
+true or false -- if false, it will block the next step:
+* If $node has any daughter nodes, increment C<_depth>, and call
+$daughter->walk_down(options_hashref) for each daughter (in order, of
+course), where options_hashref is the same hashref it was called with.
+When this returns, decrements C<_depth>.
+* If there's a C<callbackback>, call just it as with C<callback> (but
+tossing out the return value).  Note that C<callback> returning false
+blocks traversal below $node, but doesn't block calling callbackback
+for $node.  (Incidentally, in the unlikely case that $node has stopped
+being a node object, C<callbackback> won't get called.)
+* Return.
+$node->walk_down is the way to recursively do things to a tree (if you
+start at the root) or part of a tree; if what you're doing is best done
+via pre-pre order traversal, use C<callback>; if what you're doing is
+best done with post-order traversal, use C<callbackback>.
+C<walk_down> is even the basis for plenty of the methods in this
+class.  See the source code for examples both simple and horrific.
+Note that if you don't specify C<_depth>, it effectively defaults to
+0.  You should set it to scalar($node->ancestors) if you want
+C<_depth> to reflect the true depth-in-the-tree for the nodes called,
+instead of just the depth below $node.  (If $node is the root, there's
+difference, of course.)
+And B<by the way>, it's a bad idea to modify the tree from the callback.
+Unpredictable things may happen.  I instead suggest having your callback
+add to a stack of things that need changing, and then, once C<walk_down>
+is all finished, changing those nodes from that stack.
+Note that the existence of C<walk_down> doesn't mean you can't write
+you own special-use traversers.
+=cut
+sub walk_down {
+my($this, $o) = @_[0,1];
+# All the can()s are in case an object changes class while I'm
+# looking at it.
+Carp::croak "I need options!" unless ref($o);
+Carp::croak "I need a callback or a callbackback" unless
+( ref($o->{'callback'}) || ref($o->{'callbackback'}) );
+# $this->no_cyclicity;
+my $callback = ref($o->{'callback'}) ? $o->{'callback'} : undef;
+my $callbackback = ref($o->{'callbackback'}) ? $o->{'callbackback'} : undef;
+my $callback_status = 1;
+print "Callback: $callback   Callbackback: $callbackback\n" if $Debug;
+printf "* Entering %s\n", ($this->name || $this) if $Debug;
+$callback_status = &{ $callback }( $this, $o ) if $callback;
+if($callback_status) {
+# Keep recursing unless callback returned false... and if there's
+# anything to recurse into, of course.
+my @daughters = UNIVERSAL::can($this, 'is_node') ? @{$this->{'daughters'}} : ();
+if(@daughters) {
+$o->{'_depth'} += 1;
+#print "Depth " , $o->{'_depth'}, "\n";
+foreach my $one (@daughters) {
+$one->walk_down($o) if UNIVERSAL::can($one, 'is_node');
+# and if it can do "is_node", it should provide a walk_down!
+}
+$o->{'_depth'} -= 1;
+}
+} else {
+printf "* Recursing below %s pruned\n", ($this->name || $this) if $Debug;
+}
+# Note that $callback_status doesn't block callbackback from being called
+if($callbackback){
+if(UNIVERSAL::can($this, 'is_node')) { # if it's still a node!
+print "* Calling callbackback\n" if $Debug;
+scalar( &{ $callbackback }( $this, $o ) );
+# scalar to give it the same context as callback
+} else {
+print "* Can't call callbackback -- $this isn't a node anymore\n"
+if $Debug;
+}
+}
+if($Debug) {
+if(UNIVERSAL::can($this, 'is_node')) { # if it's still a node!
+printf "* Leaving %s\n", ($this->name || $this)
+} else {
+print "* Leaving [no longer a node]\n";
+}
+}
+return;
+}
+###########################################################################
+=item @lines = $node->dump_names({ ...options... });
+Dumps, as an indented list, the names of the nodes starting at $node,
+and continuing under it.  Options are:
+* _depth -- A nonnegative number.  Indicating the depth to consider
+$node as being at (and so the generation under that is that plus one,
+etc.).  Defaults to 0.  You may choose to use set _depth =>
+scalar($node->ancestors).
+* tick -- a string to preface each entry with, between the
+indenting-spacing and the node's name.  Defaults to empty-string.  You
+may prefer "*" or "-> " or someting.
+* indent -- the string used to indent with.  Defaults to "  " (two
+spaces).  Another sane value might be ". " (period, space).  Setting it
+to empty-string suppresses indenting.
+The dump is not printed, but is returned as a list, where each
+item is a line, with a "\n" at the end.
+=cut
+sub dump_names {
+my($it, $o) = @_[0,1];
+$o = {} unless ref $o;
+my @out = ();
+$o->{'_depth'} ||= 0;
+$o->{'indent'} ||= '  ';
+$o->{'tick'} ||= '';
+$o->{'callback'} = sub {
+my($this, $o) = @_[0,1];
+push(@out,
+join('',
+$o->{'indent'} x $o->{'_depth'},
+$o->{'tick'},
+&Tree::DAG_Node::_dump_quote($this->name || $this),
+"\n"
+)
+);
+return 1;
+}
+;
+$it->walk_down($o);
+return @out;
+}
+###########################################################################
+###########################################################################
+=item the constructor CLASS->random_network({...options...})
+=item the method $node->random_network({...options...})
+In the first case, constructs a randomly arranged network under a new
+node, and returns the root node of that tree.  In the latter case,
+constructs the network under $node.
+Currently, this is implemented a bit half-heartedly, and
+half-wittedly.  I basically needed to make up random-looking networks
+to stress-test the various tree-dumper methods, and so wrote this.  If
+you actually want to rely on this for any application more
+serious than that, I suggest examining the source code and seeing if
+this does really what you need (say, in reliability of randomness);
+and feel totally free to suggest changes to me (especially in the form
+of "I rewrote C<random_network>, here's the code...")
+It takes four options:
+* max_node_count -- maximum number of nodes this tree will be allowed
+to have (counting the root).  Defaults to 25.
+* min_depth -- minimum depth for the tree.  Defaults to 2.  Leaves can
+be generated only after this depth is reached, so the tree will be at
+least this deep -- unless max_node_count is hit first.
+* max_depth -- maximum depth for the tree.  Defaults to 3 plus
+min_depth.  The tree will not be deeper than this.
+* max_children -- maximum number of children any mother in the tree
+can have.  Defaults to 4.
+=cut
+sub random_network { # constructor or method.
+my $class = $_[0];
+my $o = ref($_[1]) ? $_[1] : {};
+my $am_cons = 0;
+my $root;
+if(ref($class)){ # I'm a method.
+$root = $_[0]; # build under the given node, from same class.
+$class = ref $class;
+$am_cons = 0;
+} else { # I'm a constructor
+$root = $class->new; # build under a new node, with class named.
+$root->name("Root");
+$am_cons = 1;
+}
+my $min_depth = $o->{'min_depth'} || 2;
+my $max_depth = $o->{'max_depth'} || ($min_depth + 3);
+my $max_children = $o->{'max_children'} || 4;
+my $max_node_count = $o->{'max_node_count'} || 25;
+Carp::croak "max_children has to be positive" if int($max_children) < 1;
+my @mothers = ( $root );
+my @children = ( );
+my $node_count = 1; # the root
+Gen:
+foreach my $depth (1 .. $max_depth) {
+last if $node_count > $max_node_count;
+Mother:
+foreach my $mother (@mothers) {
+last Gen if $node_count > $max_node_count;
+my $children_number;
+if($depth <= $min_depth) {
+until( $children_number = int(rand(1 + $max_children)) ) {}
+} else {
+$children_number = int(rand($max_children));
+}
+Beget:
+foreach (1 .. $children_number) {
+last Gen if $node_count > $max_node_count;
+my $node = $mother->new_daughter;
+$node->name("Node$node_count");
+++$node_count;
+push(@children, $node);
+}
+}
+@mothers = @children;
+@children = ();
+last unless @mothers;
+}
+return $root;
+}
+=item the constructor CLASS->lol_to_tree($lol);
+Converts something like bracket-notation for "Chomsky trees" (or
+rather, the closest you can come with Perl
+list-of-lists(-of-lists(-of-lists))) into a tree structure.  Returns
+the root of the tree converted.
+The conversion rules are that:  1) if the last (possibly the only) item
+in a given list is a scalar, then that is used as the "name" attribute
+for the node based on this list.  2) All other items in the list
+represent daughter nodes of the current node -- recursively so, if
+they are list references; otherwise, (non-terminal) scalars are
+considered to denote nodes with that name.  So ['Foo', 'Bar', 'N'] is
+an alternate way to represent [['Foo'], ['Bar'], 'N'].
+An example will illustrate:
+use Tree::DAG_Node;
+$lol =
+[
+[
+[ [ 'Det:The' ],
+[ [ 'dog' ], 'N'], 'NP'],
+[ '/with rabies\\', 'PP'],
+'NP'
+],
+[ 'died', 'VP'],
+'S'
+];
+$tree = Tree::DAG_Node->lol_to_tree($lol);
+$diagram = $tree->draw_ascii_tree;
+print map "$_\n", @$diagram;
+...returns this tree:
+|
+<S>
+|
+/------------------\
+|                  |
+<NP>                <VP>
+|                  |
+/---------------\        <died>
+|               |
+<NP>            <PP>
+|               |
+/-------\   </with rabies\>
+|       |
+<Det:The>  <N>
+|
+<dog>
+By the way (and this rather follows from the above rules), when
+denoting a LoL tree consisting of just one node, this:
+$tree = Tree::DAG_Node->lol_to_tree( 'Lonely' );
+is okay, although it'd probably occur to you to denote it only as:
+$tree = Tree::DAG_Node->lol_to_tree( ['Lonely'] );
+which is of course fine, too.
+=cut
+sub lol_to_tree {
+my($class, $lol, $seen_r) = @_[0,1,2];
+$seen_r = {} unless ref($seen_r) eq 'HASH';
+return if ref($lol) && $seen_r->{$lol}++; # catch circularity
+$class = ref($class) || $class;
+my $node = $class->new();
+unless(ref($lol) eq 'ARRAY') {  # It's a terminal node.
+$node->name($lol) if defined $lol;
+return $node;
+}
+return $node unless @$lol;  # It's a terminal node, oddly represented
+#  It's a non-terminal node.
+my @options = @$lol;
+unless(ref($options[-1]) eq 'ARRAY') {
+# This is what separates this method from simple_lol_to_tree
+$node->name(pop(@options));
+}
+foreach my $d (@options) {  # Scan daughters (whether scalars or listrefs)
+$node->add_daughter( $class->lol_to_tree($d, $seen_r) );  # recurse!
+}
+return $node;
+}
+#--------------------------------------------------------------------------
+=item $node->tree_to_lol_notation({...options...})
+Dumps a tree (starting at $node) as the sort of LoL-like bracket
+notation you see in the above example code.  Returns just one big
+block of text.  The only option is "multiline" -- if true, it dumps
+the text as the sort of indented structure as seen above; if false
+(and it defaults to false), dumps it all on one line (with no
+indenting, of course).
+For example, starting with the tree from the above example,
+this:
+print $tree->tree_to_lol_notation, "\n";
+prints the following (which I've broken over two lines for sake of
+printablitity of documentation):
+[[[['Det:The'], [['dog'], 'N'], 'NP'], [["/with rabies\x5c"],
+'PP'], 'NP'], [['died'], 'VP'], 'S'],
+Doing this:
+print $tree->tree_to_lol_notation({ multiline => 1 });
+prints the same content, just spread over many lines, and prettily
+indented.
+=cut
+#--------------------------------------------------------------------------
+sub tree_to_lol_notation {
+my $root = $_[0];
+my($it, $o) = @_[0,1];
+$o = {} unless ref $o;
+my @out = ();
+$o->{'_depth'} ||= 0;
+$o->{'multiline'} = 0 unless exists($o->{'multiline'});
+my $line_end;
+if($o->{'multiline'}) {
+$o->{'indent'} ||= '  ';
+$line_end = "\n";
+} else {
+$o->{'indent'} ||= '';
+$line_end = '';
+}
+$o->{'callback'} = sub {
+my($this, $o) = @_[0,1];
+push(@out,
+$o->{'indent'} x $o->{'_depth'},
+"[$line_end",
+);
+return 1;
+}
+;
+$o->{'callbackback'} = sub {
+my($this, $o) = @_[0,1];
+my $name = $this->name;
+if(!defined($name)) {
+$name = 'undef';
+} else {
+$name = &Tree::DAG_Node::_dump_quote($name);
+}
+push(@out,
+$o->{'indent'} x ($o->{'_depth'} + 1),
+"$name$line_end",
+$o->{'indent'} x $o->{'_depth'},
+"], $line_end",
+);
+return 1;
+}
+;
+$it->walk_down($o);
+return join('', @out);
+}
+#--------------------------------------------------------------------------
+=item $node->tree_to_lol
+Returns that tree (starting at $node) represented as a LoL, like what
+$lol, above, holds.  (This is as opposed to C<tree_to_lol_notation>,
+which returns the viewable code like what gets evaluated and stored in
+$lol, above.)
+Lord only knows what you use this for -- maybe for feeding to
+Data::Dumper, in case C<tree_to_lol_notation> doesn't do just what you
+want?
+=cut
+sub tree_to_lol {
+# I haven't /rigorously/ tested this.
+my($it, $o) = @_[0,1]; # $o is currently unused anyway
+$o = {} unless ref $o;
+my $out = [];
+my @lol_stack = ($out);
+$o->{'callback'} = sub {
+my($this, $o) = @_[0,1];
+my $new = [];
+push @{$lol_stack[-1]}, $new;
+push(@lol_stack, $new);
+return 1;
+}
+;
+$o->{'callbackback'} = sub {
+my($this, $o) = @_[0,1];
+push @{$lol_stack[-1]}, $this->name;
+pop @lol_stack;
+return 1;
+}
+;
+$it->walk_down($o);
+die "totally bizarre error 12416" unless ref($out->[0]);
+$out = $out->[0]; # the real root
+return $out;
+}
+###########################################################################
+=item the constructor CLASS->simple_lol_to_tree($simple_lol);
+This is like lol_to_tree, except that rule 1 doesn't apply -- i.e.,
+all scalars (or really, anything not a listref) in the LoL-structure
+end up as named terminal nodes, and only terminal nodes get names
+(and, of course, that name comes from that scalar value).  This method
+is useful for making things like expression trees, or at least
+starting them off.  Consider that this:
+$tree = Tree::DAG_Node->simple_lol_to_tree(
+[ 'foo', ['bar', ['baz'], 'quux'], 'zaz', 'pati' ]
+);
+converts from something like a Lispish or Iconish tree, if you pretend
+the brackets are parentheses.
+Note that there is a (possibly surprising) degenerate case of what I'm
+calling a "simple-LoL", and it's like this:
+$tree = Tree::DAG_Node->simple_lol_to_tree('Lonely');
+This is the (only) way you can specify a tree consisting of only a
+single node, which here gets the name 'Lonely'.
+=cut
+sub simple_lol_to_tree {
+my($class, $lol, $seen_r) = @_[0,1,2];
+$class = ref($class) || $class;
+$seen_r = {} unless ref($seen_r) eq 'HASH';
+return if ref($lol) && $seen_r->{$lol}++; # catch circularity
+my $node = $class->new();
+unless(ref($lol) eq 'ARRAY') {  # It's a terminal node.
+$node->name($lol) if defined $lol;
+return $node;
+}
+#  It's a non-terminal node.
+foreach my $d (@$lol) { # scan daughters (whether scalars or listrefs)
+$node->add_daughter( $class->simple_lol_to_tree($d, $seen_r) );  # recurse!
+}
+return $node;
+}
+#--------------------------------------------------------------------------
+=item $node->tree_to_simple_lol
+Returns that tree (starting at $node) represented as a simple-LoL --
+i.e., one where non-terminal nodes are represented as listrefs, and
+terminal nodes are gotten from the contents of those nodes' "name'
+attributes.
+Note that in the case of $node being terminal, what you get back is
+the same as $node->name.
+Compare to tree_to_simple_lol_notation.
+=cut
+sub tree_to_simple_lol {
+# I haven't /rigorously/ tested this.
+my $root = $_[0];
+return $root->name unless scalar($root->daughters);
+# special case we have to nip in the bud
+my($it, $o) = @_[0,1]; # $o is currently unused anyway
+$o = {} unless ref $o;
+my $out = [];
+my @lol_stack = ($out);
+$o->{'callback'} = sub {
+my($this, $o) = @_[0,1];
+my $new;
+$new = scalar($this->daughters) ? [] : $this->name;
+# Terminal nodes are scalars, the rest are listrefs we'll fill in
+# as we recurse the tree below here.
+push @{$lol_stack[-1]}, $new;
+push(@lol_stack, $new);
+return 1;
+}
+;
+$o->{'callbackback'} = sub { pop @lol_stack; return 1; };
+$it->walk_down($o);
+die "totally bizarre error 12416" unless ref($out->[0]);
+$out = $out->[0]; # the real root
+return $out;
+}
+#--------------------------------------------------------------------------
+=item $node->tree_to_simple_lol_notation({...options...})
+A simple-LoL version of tree_to_lol_notation (which see); takes the
+same options.
+=cut
+sub tree_to_simple_lol_notation {
+my($it, $o) = @_[0,1];
+$o = {} unless ref $o;
+my @out = ();
+$o->{'_depth'} ||= 0;
+$o->{'multiline'} = 0 unless exists($o->{'multiline'});
+my $line_end;
+if($o->{'multiline'}) {
+$o->{'indent'} ||= '  ';
+$line_end = "\n";
+} else {
+$o->{'indent'} ||= '';
+$line_end = '';
+}
+$o->{'callback'} = sub {
+my($this, $o) = @_[0,1];
+if(scalar($this->daughters)) {   # Nonterminal
+push(@out,
+$o->{'indent'} x $o->{'_depth'},
+"[$line_end",
+);
+} else {   # Terminal
+my $name = $this->name;
+push @out,
+$o->{'indent'} x $o->{'_depth'},
+defined($name) ? &Tree::DAG_Node::_dump_quote($name) : 'undef',
+",$line_end";
+}
+return 1;
+}
+;
+$o->{'callbackback'} = sub {
+my($this, $o) = @_[0,1];
+push(@out,
+$o->{'indent'} x $o->{'_depth'},
+"], $line_end",
+) if scalar($this->daughters);
+return 1;
+}
+;
+$it->walk_down($o);
+return join('', @out);
+}
+###########################################################################
+#  $list_r = $root_node->draw_ascii_tree({ h_compact => 1});
+#  print map("$_\n", @$list_r);
+=item $list_r = $node->draw_ascii_tree({ ... options ... })
+Draws a nice ASCII-art representation of the tree structure
+at-and-under $node, with $node at the top.  Returns a reference to the
+list of lines (with no "\n"s or anything at the end of them) that make
+up the picture.
+Example usage:
+print map("$_\n", @{$tree->draw_ascii_tree});
+draw_ascii_tree takes parameters you set in the options hashref:
+* "no_name" -- if true, C<draw_ascii_tree> doesn't print the name of
+the node; simply prints a "*".  Defaults to 0 (i.e., print the node
+name.)
+* "h_spacing" -- number 0 or greater.  Sets the number of spaces
+inserted horizontally between nodes (and groups of nodes) in a tree.
+Defaults to 1.
+* "h_compact" -- number 0 or 1.  Sets the extent to which
+C<draw_ascii_tree> tries to save horizontal space.  Defaults to 1.  If
+I think of a better scrunching algorithm, there'll be a "2" setting
+for this.
+* "v_compact" -- number 0, 1, or 2.  Sets the degree to which
+C<draw_ascii_tree> tries to save vertical space.  Defaults to 1.
+This occasionally returns trees that are a bit cock-eyed in parts; if
+anyone can suggest a better drawing algorithm, I'd be appreciative.
+=cut
+sub draw_ascii_tree {
+# Make a "box" for this node and its possible daughters, recursively.
+# The guts of this routine are horrific AND recursive!
+# Feel free to send me better code.  I worked on this until it
+#  gave me a headache and it worked passably, and then I stopped.
+my $it = $_[0];
+my $o = ref($_[1]) ? $_[1] : {};
+my(@box, @daughter_boxes, $width, @daughters);
+@daughters = @{$it->{'daughters'}};
+# $it->no_cyclicity;
+$o->{'no_name'}   = 0 unless exists $o->{'no_name'};
+$o->{'h_spacing'} = 1 unless exists $o->{'h_spacing'};
+$o->{'h_compact'} = 1 unless exists $o->{'h_compact'};
+$o->{'v_compact'} = 1 unless exists $o->{'v_compact'};
+my $printable_name;
+if($o->{'no_name'}) {
+$printable_name = '*';
+} else {
+$printable_name = $it->name || $it;
+$printable_name =~ tr<\cm\cj\t >< >s;
+$printable_name = "<$printable_name>";
+}
+if(!scalar(@daughters)) { # I am a leaf!
+# Now add the top parts, and return.
+@box = ("|", $printable_name);
+} else {
+@daughter_boxes = map { &draw_ascii_tree($_, $o) } @daughters;
+my $max_height = 0;
+foreach my $box (@daughter_boxes) {
+my $h = @$box;
+$max_height = $h if $h > $max_height;
+}
+@box = ('') x $max_height; # establish the list
+foreach my $one (@daughter_boxes) {
+my $length = length($one->[0]);
+my $height = @$one;
+#now make all the same height.
+my $deficit = $max_height - $height;
+if($deficit > 0) {
+push @$one, ( scalar( ' ' x $length ) ) x $deficit;
+$height = scalar(@$one);
+}
+# Now tack 'em onto @box
+##########################################################
+# This used to be a sub of its own.  Ho-hum.
+my($b1, $b2) = (\@box, $one);
+my($h1, $h2) = (scalar(@$b1), scalar(@$b2));
+my(@diffs, $to_chop);
+if($o->{'h_compact'}) { # Try for h-scrunching.
+my @diffs;
+my $min_diff = length($b1->[0]); # just for starters
+foreach my $line (0 .. ($h1 - 1)) {
+my $size_l = 0; # length of terminal whitespace
+my $size_r = 0; # length of initial whitespace
+$size_l = length($1) if $b1->[$line] =~ /( +)$/s;
+$size_r = length($1) if $b2->[$line] =~ /^( +)/s;
+my $sum = $size_l + $size_r;
+$min_diff = $sum if $sum < $min_diff;
+push @diffs, [$sum, $size_l, $size_r];
+}
+$to_chop = $min_diff - $o->{'h_spacing'};
+$to_chop = 0 if $to_chop < 0;
+}
+if(not(  $o->{'h_compact'} and $to_chop  )) {
+# No H-scrunching needed/possible
+foreach my $line (0 .. ($h1 - 1)) {
+$b1->[ $line ] .= $b2->[ $line ] . (' ' x $o->{'h_spacing'});
+}
+} else {
+# H-scrunching is called for.
+foreach my $line (0 .. ($h1 - 1)) {
+my $r = $b2->[$line]; # will be the new line
+my $remaining = $to_chop;
+if($remaining) {
+my($l_chop, $r_chop) = @{$diffs[$line]}[1,2];
+if($l_chop) {
+if($l_chop > $remaining) {
+$l_chop = $remaining;
+$remaining = 0;
+} elsif($l_chop == $remaining) {
+$remaining = 0;
+} else { # remaining > l_chop
+$remaining -= $l_chop;
+}
+}
+if($r_chop) {
+if($r_chop > $remaining) {
+$r_chop = $remaining;
+$remaining = 0;
+} elsif($r_chop == $remaining) {
+$remaining = 0;
+} else { # remaining > r_chop
+$remaining -= $r_chop; # should never happen!
+}
+}
+substr($b1->[$line], -$l_chop) = '' if $l_chop;
+substr($r, 0, $r_chop) = '' if $r_chop;
+} # else no-op
+$b1->[ $line ] .= $r . (' ' x $o->{'h_spacing'});
+}
+# End of H-scrunching ickyness
+}
+# End of ye big tack-on
+}
+# End of the foreach daughter_box loop
+# remove any fencepost h_spacing
+if($o->{'h_spacing'}) {
+foreach my $line (@box) {
+substr($line, -$o->{'h_spacing'}) = '' if length($line);
+}
+}
+# end of catenation
+die "SPORK ERROR 958203: Freak!!!!!" unless @box;
+# Now tweak the pipes
+my $new_pipes = $box[0];
+my $pipe_count = $new_pipes =~ tr<|><+>;
+if($pipe_count < 2) {
+$new_pipes = "|";
+} else {
+my($init_space, $end_space);
+# Thanks to Gilles Lamiral for pointing out the need to set to '',
+#  to avoid -w warnings about undeffiness.
+if( $new_pipes =~ s<^( +)><>s ) {
+$init_space = $1;
+} else {
+$init_space = '';
+}
+if( $new_pipes =~ s<( +)$><>s ) {
+$end_space  = $1
+} else {
+$end_space = '';
+}
+$new_pipes =~ tr< ><->;
+substr($new_pipes,0,1) = "/";
+substr($new_pipes,-1,1) = "\\";
+$new_pipes = $init_space . $new_pipes . $end_space;
+# substr($new_pipes, int((length($new_pipes)), 1)) / 2) = "^"; # feh
+}
+# Now tack on the formatting for this node.
+if($o->{'v_compact'} == 2) {
+if(@daughters == 1) {
+unshift @box, "|", $printable_name;
+} else {
+unshift @box, "|", $printable_name, $new_pipes;
+}
+} elsif ($o->{'v_compact'} == 1 and @daughters == 1) {
+unshift @box, "|", $printable_name;
+} else { # general case
+unshift @box, "|", $printable_name, $new_pipes;
+}
+}
+# Flush the edges:
+my $max_width = 0;
+foreach my $line (@box) {
+my $w = length($line);
+$max_width = $w if $w > $max_width;
+}
+foreach my $one (@box) {
+my $space_to_add = $max_width - length($one);
+next unless $space_to_add;
+my $add_left = int($space_to_add / 2);
+my $add_right = $space_to_add - $add_left;
+$one = (' ' x $add_left) . $one . (' ' x $add_right);
+}
+return \@box; # must not return a null list!
+}
+###########################################################################
+=item $node->copy_tree or $node->copy_tree({...options...})
+This returns the root of a copy of the tree that $node is a member of.
+If you pass no options, copy_tree pretends you've passed {}.
+This method is currently implemented as just a call to
+$this->root->copy_at_and_under({...options...}), but magic may be
+added in the future.
+Options you specify are passed down to calls to $node->copy.
+=cut
+sub copy_tree {
+my($this, $o) = @_[0,1];
+my $root = $this->root;
+$o = {} unless ref $o;
+my $new_root = $root->copy_at_and_under($o);
+return $new_root;
+}
+=item $node->copy_at_and_under or $node->copy_at_and_under({...options...})
+This returns a copy of the subtree consisting of $node and everything
+under it.
+If you pass no options, copy_at_and_under pretends you've passed {}.
+This works by recursively building up the new tree from the leaves,
+duplicating nodes using $orig_node->copy($options_ref) and then
+linking them up into a new tree of the same shape.
+Options you specify are passed down to calls to $node->copy.
+=cut
+sub copy_at_and_under {
+my($from, $o) = @_[0,1];
+$o = {} unless ref $o;
+my @daughters = map($_->copy_at_and_under($o), @{$from->{'daughters'}});
+my $to = $from->copy($o);
+$to->set_daughters(@daughters) if @daughters;
+return $to;
+}
+=item the constructor $node->copy or $node->copy({...options...})
+Returns a copy of $node, B<minus> its daughter or mother attributes
+(which are set back to default values).
+If you pass no options, C<copy> pretends you've passed {}.
+Magic happens with the 'attributes' attribute: if it's a hashref (and
+it usually is), the new node doesn't end up with the same hashref, but
+with ref to a hash with the content duplicated from the original's
+hashref.  If 'attributes' is not a hashref, but instead an object that
+belongs to a class that provides a method called "copy", then that
+method is called, and the result saved in the clone's 'attribute'
+attribute.  Both of these kinds of magic are disabled if the options
+you pass to C<copy> (maybe via C<copy_tree>, or C<copy_at_and_under>)
+includes (C<no_attribute_copy> => 1).
+The options hashref you pass to C<copy> (derictly or indirectly) gets
+changed slightly after you call C<copy> -- it gets an entry called
+"from_to" added to it.  Chances are you would never know nor care, but
+this is reserved for possible future use.  See the source if you are
+wildly curious.
+Note that if you are using $node->copy (whether directly or via
+$node->copy_tree or $node->copy_at_or_under), and it's not properly
+copying object attributes containing references, you probably
+shouldn't fight it or try to fix it -- simply override copy_tree with:
+sub copy_tree {
+use Storable qw(dclone);
+my $this = $_[0];
+return dclone($this->root);
+# d for "deep"
+}
+or
+sub copy_tree {
+use Data::Dumper;
+my $this = $_[0];
+$Data::Dumper::Purity = 1;
+return eval(Dumper($this->root));
+}
+Both of these avoid you having to reinvent the wheel.
+How to override copy_at_or_under with something that uses Storable
+or Data::Dumper is left as an exercise to the reader.
+Consider that if in a derived class, you add attributes with really
+bizarre contents (like a unique-for-all-time-ID), you may need to
+override C<copy>.  Consider:
+sub copy {
+my($it, @etc) = @_;
+$it->SUPER::copy(@etc);
+$it->{'UID'} = &get_new_UID;
+}
+...or the like.  See the source of Tree::DAG_Node::copy for
+inspiration.
+=cut
+sub copy {
+my($from,$o) = @_[0,1];
+$o = {} unless ref $o;
+# Straight dupe, and bless into same class:
+my $to = bless { %$from }, ref($from);
+# Null out linkages.
+$to->_init_mother;
+$to->_init_daughters;
+# dupe the 'attributes' attribute:
+unless($o->{'no_attribute_copy'}) {
+my $attrib_copy = ref($to->{'attributes'});
+if($attrib_copy) {
+if($attrib_copy eq 'HASH') {
+$to->{'attributes'} = { %{$to->{'attributes'}} };
+# dupe the hashref
+} elsif ($attrib_copy = UNIVERSAL::can($to->{'attributes'}, 'copy') ) {
+# $attrib_copy now points to the copier method
+$to->{'attributes'} = &{$attrib_copy}($from);
+} # otherwise I don't know how to copy it; leave as is
+}
+}
+$o->{'from_to'}->{$from} = $to; # SECRET VOODOO
+# ...autovivifies an anon hashref for 'from_to' if need be
+# This is here in case I later want/need a table corresponding
+# old nodes to new.
+return $to;
+}
+###########################################################################
+=item $node->delete_tree
+Destroys the entire tree that $node is a member of (starting at the
+root), by nulling out each node-object's attributes (including, most
+importantly, its linkage attributes -- hopefully this is more than
+sufficient to eliminate all circularity in the data structure), and
+then moving it into the class DEADNODE.
+Use this when you're finished with the tree in question, and want to
+free up its memory.  (If you don't do this, it'll get freed up anyway
+when your program ends.)
+If you try calling any methods on any of the node objects in the tree
+you've destroyed, you'll get an error like:
+Can't locate object method "leaves_under"
+via package "DEADNODE".
+So if you see that, that's what you've done wrong.  (Actually, the
+class DEADNODE does provide one method: a no-op method "delete_tree".
+So if you want to delete a tree, but think you may have deleted it
+already, it's safe to call $node->delete_tree on it (again).)
+The C<delete_tree> method is needed because Perl's garbage collector
+would never (as currently implemented) see that it was time to
+de-allocate the memory the tree uses -- until either you call
+$node->delete_tree, or until the program stops (at "global
+destruction" time, when B<everything> is unallocated).
+Incidentally, there are better ways to do garbage-collecting on a
+tree, ways which don't require the user to explicitly call a method
+like C<delete_tree> -- they involve dummy classes, as explained at
+C<http://mox.perl.com/misc/circle-destroy.pod>
+However, introducing a dummy class concept into Tree::DAG_Node would
+be rather a distraction.  If you want to do this with your derived
+classes, via a DESTROY in a dummy class (or in a tree-metainformation
+class, maybe), then feel free to.
+The only case where I can imagine C<delete_tree> failing to totally
+void the tree, is if you use the hashref in the "attributes" attribute
+to store (presumably among other things) references to other nodes'
+"attributes" hashrefs -- which 1) is maybe a bit odd, and 2) is your
+problem, because it's your hash structure that's circular, not the
+tree's.  Anyway, consider:
+# null out all my "attributes" hashes
+$anywhere->root->walk_down({
+'callback' => sub {
+$hr = $_[0]->attributes; %$hr = (); return 1;
+}
+});
+# And then:
+$anywhere->delete_tree;
+(I suppose C<delete_tree> is a "destructor", or as close as you can
+meaningfully come for a circularity-rich data structure in Perl.)
+=cut
+sub delete_tree {
+my $it = $_[0];
+$it->root->walk_down({ # has to be callbackback, not callback
+'callbackback' => sub {
+%{$_[0]} = ();
+bless($_[0], 'DEADNODE'); # cause become dead!  cause become dead!
+return 1;
+}
+});
+return;
+# Why DEADNODE?  Because of the nice error message:
+#  "Can't locate object method "leaves_under" via package "DEADNODE"."
+# Moreover, DEADNODE doesn't provide is_node, so fails my can() tests.
+}
+sub DEADNODE::delete_tree { return; }
+# in case you kill it AGAIN!!!!!  AND AGAIN AND AGAIN!!!!!! OO-HAHAHAHA!
+###########################################################################
+# stolen from MIDI.pm
+sub _dump_quote {
+my @stuff = @_;
+return
+join(", ",
+map
+{ # the cleaner-upper function
+if(!length($_)) { # empty string
+"''";
+} elsif( m/^-?\d+(?:\.\d+)?$/s ) { # a number
+$_;
+} elsif( # text with junk in it
+s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])>
+<'\\x'.(unpack("H2",$1))>eg
+) {
+"\"$_\"";
+} else { # text with no junk in it
+s<'><\\'>g;
+"\'$_\'";
+}
+}
+@stuff
+);
+}
+###########################################################################
+=back
+=head2 When and How to Destroy
+It should be clear to you that if you've built a big parse tree or
+something, and then you're finished with it, you should call
+$some_node->delete_tree on it if you want the memory back.
+But consider this case:  you've got this tree:
+A
+/ | \
+B  C  D
+|     | \
+E     X  Y
+Let's say you decide you don't want D or any of its descendants in the
+tree, so you call D->unlink_from_mother.  This does NOT automagically
+destroy the tree D-X-Y.  Instead it merely splits the tree into two:
+A                        D
+/ \                      / \
+B   C                    X   Y
+|
+E
+To destroy D and its little tree, you have to explicitly call
+delete_tree on it.
+Note, however, that if you call C->unlink_from_mother, and if you don't
+have a link to C anywhere, then it B<does> magically go away.  This is
+because nothing links to C -- whereas with the D-X-Y tree, D links to
+X and Y, and X and Y each link back to D. Note that calling
+C->delete_tree is harmless -- after all, a tree of only one node is
+still a tree.
+So, this is a surefire way of getting rid of all $node's children and
+freeing up the memory associated with them and their descendants:
+foreach my $it ($node->clear_daughters) { $it->delete_tree }
+Just be sure not to do this:
+foreach my $it ($node->daughters) { $it->delete_tree }
+$node->clear_daughters;
+That's bad; the first call to $_->delete_tree will climb to the root
+of $node's tree, and nuke the whole tree, not just the bits under $node.
+You might as well have just called $node->delete_tree.
+(Moreavor, once $node is dead, you can't call clear_daughters on it,
+so you'll get an error there.)
+=head1 BUG REPORTS
+If you find a bug in this library, report it to me as soon as possible,
+at the address listed in the MAINTAINER section, below.  Please try to
+be as specific as possible about how you got the bug to occur.
+=head1 HELP!
+If you develop a given routine for dealing with trees in some way, and
+use it a lot, then if you think it'd be of use to anyone else, do email
+me about it; it might be helpful to others to include that routine, or
+something based on it, in a later version of this module.
+It's occurred to me that you might like to (and might yourself develop
+routines to) draw trees in something other than ASCII art.  If you do so
+-- say, for PostScript output, or for output interpretable by some
+external plotting program --  I'd be most interested in the results.
+=head1 RAMBLINGS
+This module uses "strict", but I never wrote it with -w warnings in
+mind -- so if you use -w, do not be surprised if you see complaints
+from the guts of DAG_Node.  As long as there is no way to turn off -w
+for a given module (instead of having to do it in every single
+subroutine with a "local $^W"), I'm not going to change this. However,
+I do, at points, get bursts of ambition, and I try to fix code in
+DAG_Node that generates warnings, I<as I come across them> -- which is
+only occasionally.  Feel free to email me any patches for any such
+fixes you come up with, tho.
+Currently I don't assume (or enforce) anything about the class
+membership of nodes being manipulated, other than by testing whether
+each one provides a method C<is_node>, a la:
+die "Not a node!!!" unless UNIVERSAL::can($node, "is_node");
+So, as far as I'm concerned, a given tree's nodes are free to belong to
+different classes, just so long as they provide/inherit C<is_node>, the
+few methods that this class relies on to navigate the tree, and have the
+same internal object structure, or a superset of it. Presumably this
+would be the case for any object belonging to a class derived from
+C<Tree::DAG_Node>, or belonging to C<Tree::DAG_Node> itself.
+When routines in this class access a node's "mother" attribute, or its
+"daughters" attribute, they (generally) do so directly (via
+$node->{'mother'}, etc.), for sake of efficiency.  But classes derived
+from this class should probably do this instead thru a method (via
+$node->mother, etc.), for sake of portability, abstraction, and general
+goodness.
+However, no routines in this class (aside from, necessarily, C<_init>,
+C<_init_name>, and C<name>) access the "name" attribute directly;
+routines (like the various tree draw/dump methods) get the "name" value
+thru a call to $obj->name().  So if you want the object's name to not be
+a real attribute, but instead have it derived dynamically from some feature
+of the object (say, based on some of its other attributes, or based on
+its address), you can to override the C<name> method, without causing
+problems.  (Be sure to consider the case of $obj->name as a write
+method, as it's used in C<lol_to_tree> and C<random_network>.)
+=head1 SEE ALSO
+L<HTML::Element>
+Wirth, Niklaus.  1976.  I<Algorithms + Data Structures = Programs>
+Prentice-Hall, Englewood Cliffs, NJ.
+Knuth, Donald Ervin.  1997.  I<Art of Computer Programming, Volume 1,
+Third Edition: Fundamental Algorithms>.  Addison-Wesley,  Reading, MA.
+Wirth's classic, currently and lamentably out of print, has a good
+section on trees.  I find it clearer than Knuth's (if not quite as
+encyclopedic), probably because Wirth's example code is in a
+block-structured high-level language (basically Pascal), instead
+of in assembler (MIX).
+Until some kind publisher brings out a new printing of Wirth's book,
+try poking around used bookstores (or C<www.abebooks.com>) for a copy.
+I think it was also republished in the 1980s under the title
+I<Algorithms and Data Structures>, and in a German edition called
+I<Algorithmen und Datenstrukturen>.  (That is, I'm sure books by Knuth
+were published under those titles, but I'm I<assuming> that they're just
+later printings/editions of I<Algorithms + Data Structures =
+Programs>.)
+=head1 MAINTAINER
+David Hand, C<< <cogent@cpan.org> >>
+=head1 AUTHOR
+Sean M. Burke, C<< <sburke@cpan.org> >>
+=head1 COPYRIGHT, LICENSE, AND DISCLAIMER
+Copyright 1998-2001, 2004, 2007 by Sean M. Burke and David Hand.
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+=cut
+1;
+__END__

Mercurial > repos > jjohnson > crest

comparison Tree/DAG_Node.pm @ 0:acc8d8bfeb9a