--- /dev/null
+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__
projects / dh-make-perl / blobdiff