package Tree::DAG_Node;
use strict;
use warnings;
use warnings qw(FATAL utf8); # Fatalize encoding glitches.
our $Debug = 0;
our $VERSION = '1.27';
use File::Slurp::Tiny 'read_lines';
# -----------------------------------------------
sub add_daughter { # alias
my($it,@them) = @_; $it->add_daughters(@them);
}
# -----------------------------------------------
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_left { # alias
my($it,@them) = @_; $it->add_daughters_left(@them);
}
# -----------------------------------------------
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_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 ()
die "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;
die "Mother can't be its own daughter\n" if $mother eq $daughter;
die "$daughter (" . ($daughter->name || 'no_name') .
") is an ancestor of $mother (" . ($mother->name || 'no_name') .
"), so can't became its daughter\n" 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 add_left_sister { # alias
my($it,@them) = @_; $it->add_left_sisters(@them);
}
# -----------------------------------------------
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;
}
# -----------------------------------------------
sub add_right_sister { # alias
my($it,@them) = @_; $it->add_right_sisters(@them);
}
# -----------------------------------------------
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;
}
# -----------------------------------------------
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!
die "Address \"$address\" is an ill-formed address" unless @parts;
die "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);
}
}
# -----------------------------------------------
sub ancestors {
my $this = shift;
my $mama = $this->{'mother'}; # initial condition
return () unless ref($mama); # I must be root!
# 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;
}
# -----------------------------------------------
sub attribute { # alias
my($it,@them) = @_; $it->attributes(@them);
}
# -----------------------------------------------
sub attributes { # read/write attribute-method
# expects a ref, presumably a hashref
my $this = shift;
if(@_) {
die "my parameter must be a reference" unless ref($_[0]);
$this->{'attributes'} = $_[0];
}
return $this->{'attributes'};
}
# -----------------------------------------------
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
}
# -----------------------------------------------
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) {
die "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;
}
# -----------------------------------------------
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
}
}
# -----------------------------------------------
sub copy
{
my($from, $o) = @_[0,1];
$o = {} unless ref $o;
# Straight dup, and bless into same class.
my $to = bless { %$from }, ref($from);
# Null out linkages.
$to -> _init_mother;
$to -> _init_daughters;
# Dup the 'attributes' attribute.
if ($$o{'no_attribute_copy'})
{
$$to{attributes} = {};
}
else
{
my $attrib_copy = ref($to->{'attributes'});
if ($attrib_copy)
{
if ($attrib_copy eq 'HASH')
{
# Dup the hashref.
$$to{'attributes'} = { %{$$to{'attributes'}} };
}
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;
}
# -----------------------------------------------
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;
}
# -----------------------------------------------
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;
}
# -----------------------------------------------
sub daughters { # read-only attrib-method: returns a list.
my $this = shift;
if(@_) { # undoc'd and disfavored to use as a write-method
die "Don't set daughters with daughters anymore\n";
warn "my parameter must be a listref" unless ref($_[0]);
$this->{'daughters'} = $_[0];
$this->_update_daughter_links;
}
#return $this->{'daughters'};
return @{$this->{'daughters'} || []};
}
# ------------------------------------------------
sub decode_lol
{
my($self, $result) = @_;
my(@worklist) = $result;
my($obj);
my($ref_type);
my(@stack);
do
{
$obj = shift @worklist;
$ref_type = ref $obj;
if ($ref_type eq 'ARRAY')
{
unshift @worklist, @$obj;
}
elsif ($ref_type eq 'HASH')
{
push @stack, {%$obj};
}
elsif ($ref_type)
{
die "Unsupported object type $ref_type\n";
}
else
{
push @stack, $obj;
}
} while (@worklist);
return [@stack];
} # End of decode_lol.
# -----------------------------------------------
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!
# -----------------------------------------------
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;
}
# -----------------------------------------------
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;
}
# -----------------------------------------------
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'}};
$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 = defined $it->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!
}
# -----------------------------------------------
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'},
defined $this->name ? $this->name : $this,
"\n"
)
);
return 1;
}
;
$it->walk_down($o);
return @out;
}
# -----------------------------------------------
sub format_node
{
my($self, $options, $node) = @_;
my($s) = $node -> name;
$s .= '. Attributes: ' . $self -> hashref2string($node -> attributes) if (! $$options{no_attributes});
return $s;
} # End of format_node.
# -----------------------------------------------
sub generation {
my($node, $limit) = @_[0,1];
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);
}
# -----------------------------------------------
sub hashref2string
{
my($self, $hashref) = @_;
$hashref ||= {};
return '{' . join(', ', map{qq|$_ => "$$hashref{$_}"|} sort keys %$hashref) . '}';
} # End of hashref2string.
# -----------------------------------------------
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_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'};
}
# -----------------------------------------------
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_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_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 is_daughter_of {
my($it,$mama) = @_[0,1];
return $it->{'mother'} eq $mama;
}
# -----------------------------------------------
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.
# -----------------------------------------------
sub is_root
{
my($self) = @_;
return defined $self -> mother ? 0 : 1;
} # End of is_root.
# -----------------------------------------------
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->walk_down({ 'callback' =>
sub {
my $node = $_[0];
my @daughters = @{$node->{'daughters'}};
push(@List, $node) unless @daughters;
return 1;
}
});
die "Spork Error 861: \@List has no contents!?!?" unless @List;
# impossible
return @List;
}
# -----------------------------------------------
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!?!?";
}
# -----------------------------------------------
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!?!?";
}
# -----------------------------------------------
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;
}
# -----------------------------------------------
sub mother { # read-only attrib-method: returns an object (the mother node)
my $this = shift;
die "I'm a read-only method!" if @_;
return $this->{'mother'};
}
# -----------------------------------------------
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;
}
# -----------------------------------------------
sub name { # read/write attribute-method. returns/expects a scalar
my $this = shift;
$this->{'name'} = $_[0] if @_;
return $this->{'name'};
}
# -----------------------------------------------
sub new { # constructor
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;
}
# -----------------------------------------------
sub new_daughter {
my($mother, @options) = @_;
my $daughter = $mother->new(@options);
push @{$mother->{'daughters'}}, $daughter;
$daughter->{'mother'} = $mother;
return $daughter;
}
# -----------------------------------------------
sub new_daughter_left {
my($mother, @options) = @_;
my $daughter = $mother->new(@options);
unshift @{$mother->{'daughters'}}, $daughter;
$daughter->{'mother'} = $mother;
return $daughter;
}
# -----------------------------------------------
sub node2string
{
my($self, $options, $node, $vert_dashes) = @_;
my($depth) = scalar($node -> ancestors) || 0;
my($sibling_count) = defined $node -> mother ? scalar $node -> self_and_sisters : 1;
my($offset) = ' ' x 5;
my(@indent) = map{$$vert_dashes[$_] || $offset} 0 .. $depth - 1;
@$vert_dashes =
(
@indent,
($sibling_count == 1 ? $offset : ' |'),
);
if ($sibling_count == ($node -> my_daughter_index + 1) )
{
$$vert_dashes[$depth] = $offset;
}
return join('' => @indent[1 .. $#indent]) . ($depth ? ' |--- ' : '') . $self -> format_node($options, $node);
} # End of node2string.
# -----------------------------------------------
sub quote_name
{
my($self, $name) = @_;
return "'$name'";
} # End of quote_name.
# -----------------------------------------------
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;
die "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;
}
# -----------------------------------------------
sub read_attributes
{
my($self, $s) = @_;
my($attributes);
my($name);
if ($s =~ /^(.+)\. Attributes: ({.*})$/)
{
($name, $attributes) = ($1, $self -> string2hashref($2) );
}
else
{
($name, $attributes) = ($s, {});
}
return Tree::DAG_Node -> new({name => $name, attributes => $attributes});
} # End of read_attributes.
# -----------------------------------------------
sub read_tree
{
my($self, $file_name) = @_;
my($count) = 0;
my($last_indent) = 0;
my($test_string) = '--- ';
my($test_length) = length $test_string;
my($indent);
my($node);
my($offset);
my($root);
my(@stack);
my($tos);
for my $line (read_lines($file_name, binmode => ':encoding(utf-8)', chomp => 1) )
{
$count++;
if ($count == 1)
{
$root = $node = $self -> read_attributes($line);
}
else
{
$indent = index($line, $test_string);
if ($indent > $last_indent)
{
$tos = $node;
push @stack, $node, $indent;
}
elsif ($indent < $last_indent)
{
$offset = $last_indent;
while ($offset > $indent)
{
$offset = pop @stack;
$tos = pop @stack;
}
push @stack, $tos, $offset;
}
# Warning: The next line must set $node.
# Don't put the RHS into the call to add_daughter()!
$node = $self -> read_attributes(substr($line, $indent + $test_length) );
$last_indent = $indent;
$tos -> add_daughter($node);
}
}
return $root;
} # End of read_tree.
# -----------------------------------------------
sub remove_daughters { # write-only method
my($mother, @daughters) = @_;
die "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;
}
# -----------------------------------------------
sub remove_daughter { # alias
my($it,@them) = @_; $it->remove_daughters(@them);
}
# -----------------------------------------------
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);
}
# -----------------------------------------------
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);
}
# -----------------------------------------------
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;
}
# -----------------------------------------------
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;
}
# -----------------------------------------------
sub root {
my $it = $_[0];
my @ancestors = ($it, $it->ancestors);
return $ancestors[-1];
}
# -----------------------------------------------
sub self_and_descendants {
# read-only method: return a list of myself and any/all descendants
my $node = shift;
my @List = ();
$node->walk_down({ 'callback' => sub { push @List, $_[0]; return 1;}});
die "Spork Error 919: \@List has no contents!?!?" unless @List;
# impossible
return @List;
}
# -----------------------------------------------
sub self_and_sisters {
my $node = $_[0];
my $mother = $node->{'mother'};
return $node unless defined($mother) && ref($mother); # special case
return @{$node->{'mother'}->{'daughters'}};
}
# -----------------------------------------------
sub set_daughters { # write-only method
my($mother, @them) = @_;
$mother->clear_daughters;
$mother->add_daughters(@them) if @them;
# yup, it's that simple
}
# -----------------------------------------------
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;
}
# -----------------------------------------------
sub sisters {
my $node = $_[0];
my $mother = $node->{'mother'};
return() unless $mother; # special case
return grep($_ ne $node,
@{$node->{'mother'}->{'daughters'}}
);
}
# -----------------------------------------------
sub string2hashref
{
my($self, $s) = @_;
$s ||= '';
my($result) = {};
my($k);
my($v);
if ($s)
{
# Expect:
# 1: The presence of the comma in "(',')" complicates things, so we can't use split(/\s*,\s*/, $s).
# {x => "(',')"}
# 2: The presence of "=>" complicates things, so we can't use split(/\s*=>\s*/).
# {x => "=>"}
# 3: So, assume ', ' is the outer separator, and then ' => ' is the inner separator.
# Firstly, clean up the input, just to be safe.
# None of these will match output from hashref2string($h).
$s =~ s/^\s*\{*//;
$s =~ s/\s*\}\s*$/\}/;
my($finished) = 0;
# The first '\' is for UltraEdit's syntax hiliting.
my($reg_exp) =
qr/
([\"'])([^"']*?)\1\s*=>\s*(["'])([^"']*?)\3,?\s*
|
(["'])([^"']*?)\5\s*=>\s*(.*?),?\s*
|
(.*?)\s*=>\s*(["'])([^"']*?)\9,?\s*
|
(.*?)\s*=>\s*(.*?),?\s*
/sx;
my(@got);
while (! $finished)
{
if ($s =~ /$reg_exp/gc)
{
push @got, defined($2) ? ($2, $4) : defined($6) ? ($6, $7) : defined($8) ? ($8, $10) : ($11, $12);
}
else
{
$finished = 1;
}
}
$result = {@got};
}
return $result;
} # End of string2hashref.
# -----------------------------------------------
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];
my $name = defined $this->name ? $it -> quote_name($this->name) : 'undef';
push @{$lol_stack[-1]}, $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;
}
# -----------------------------------------------
sub tree_to_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];
push(@out,
$o->{'indent'} x $o->{'_depth'},
"[$line_end",
);
return 1;
}
;
$o->{'callbackback'} = sub {
my($this, $o) = @_[0,1];
my $name = defined $this->name ? $it -> quote_name($this->name) : 'undef';
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);
}
# -----------------------------------------------
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;
my $name = defined $this->name ? $it -> quote_name($this->name) : 'undef';
$new = scalar($this->daughters) ? [] : $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;
}
# -----------------------------------------------
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 = defined $this->name ? $it -> quote_name($this->name) : 'undef';
push @out,
$o->{'indent'} x $o->{'_depth'},
"$name,$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);
}
# -----------------------------------------------
sub tree2string
{
my($self, $options, $tree) = @_;
$options ||= {};
$$options{no_attributes} ||= 0;
$tree ||= $self;
my(@out);
my(@vert_dashes);
$tree -> walk_down
({
callback =>
sub
{
my($node) = @_;
push @out, $self -> node2string($options, $node, \@vert_dashes);
return 1,
},
_depth => 0,
});
return [@out];
} # End of tree2string.
# -----------------------------------------------
sub unlink_from_mother {
my $node = $_[0];
my $mother = $node->{'mother'};
$mother->remove_daughters($node) if defined($mother) && ref($mother);
return $mother;
}
# -----------------------------------------------
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
die "daughter <$one> isn't an object!" unless ref $one;
$one->{'mother'} = $this;
}
return;
}
# -----------------------------------------------
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.
die "I need options!" unless ref($o);
die "I need a callback or a callbackback" unless
( ref($o->{'callback'}) || ref($o->{'callbackback'}) );
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;
}
# -----------------------------------------------
1;
=pod
=encoding utf-8
=head1 NAME
Tree::DAG_Node - An N-ary tree
=head1 SYNOPSIS
=head2 Using as a base class
package Game::Tree::Node;
use parent 'Tree::DAG_Node';
# Now add your own methods overriding/extending the methods in C<Tree::DAG_Node>...
=head2 Using as a class on its own
use Tree::DAG_Node;
my($root) = Tree::DAG_Node -> new({name => 'root', attributes => {uid => 0} });
$root -> add_daughter(Tree::DAG_Node -> new({name => 'one', attributes => {uid => 1} }) );
$root -> add_daughter(Tree::DAG_Node -> new({name => 'two', attributes => {} }) );
$root -> add_daughter(Tree::DAG_Node -> new({name => 'three'}) ); # Attrs default to {}.
Or:
my $root = Tree::DAG_Node -> new();
$root -> name("I'm the tops");
$root -> attributes({uid => 0});
my $new_daughter = $root -> new_daughter;
$new_daughter -> name('Another node');
$new_daughter -> attributes({uid => 1});
...
=head2 Using with utf-8 data
read_tree($file_name) works with utf-8 data. See t/read.tree.t and t/tree.utf8.attributes.txt.
Such a file can be created by redirecting the output of tree2string() to a file of type utf-8.
See the docs for L<Encode> for the difference between utf8 and utf-8. In brief, use utf-8.
See also scripts/write_tree.pl and scripts/read.tree.pl and scripts/read.tree.log.
=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:
=over 4
=item o A tree is a special case of an acyclic directed graph
=item o A tree is a network of nodes where there's exactly one root node
Also, the only primary relationship between nodes is the mother-daughter relationship.
=item o No node can be its own mother, or its mother's mother, etc
=item o Each node in the tree has exactly one parent
Except for the root of course, which is parentless.
=item o Each node can have any number (0 .. N) 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.
=item o 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.
=item o There's an idea of up versus down
Up means towards to the root, and down means away from the root (and towards the leaves).
=item o There's an idea of left versus right
Left is toward the start (index 0) of a given node's daughter list, and right is toward the end of a
given node's daughter list.
=back
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 C<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 C<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 C<Tree::DAG_Node>, or ones derived from it) that provides
methods.
The attributes of a node-object are:
=over
=item o mother -- this node's mother. undef if this is a root
=item o daughters -- the (possibly empty) list of daughters of this node
=item o 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 o 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 C<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> acquaintance 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({})".)
See also the comments under L</new($hashref)> for options supported in the call to new().
If you use C<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
}
=item the constructor $obj->new() or $obj->new($options)
Just another way to get at the L</new($hashref)> 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;
=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 L</new($hashref)>
constructor -- never by the end user.
Currently there are no documented options for putting in the
$options hashref, 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
=head1 METHODS
=head2 add_daughter(LIST)
An exact synonym for L</add_daughters(LIST)>.
=head2 add_daughters(LIST)
This method adds the node objects in LIST to the (right) end of
$mother's I<daughter> list. Making a node N1 the daughter of another
node N2 also means that N1's I<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 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.
=head2 add_daughter_left(LIST)
An exact synonym for L</add_daughters_left(LIST)>.
=head2 add_daughters_left(LIST)
This method is just like L</add_daughters(LIST)>, 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.
=head2 add_left_sister(LIST)
An exact synonym for L</add_left_sisters(LIST)>.
=head2 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).
=head2 add_right_sister(LIST)
An exact synonym for L</add_right_sisters(LIST)>.
=head2 add_right_sisters(LIST)
Just like add_left_sisters (which see), except that 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).
=head2 address()
=head2 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:
=over 4
=item o ROOT's my_daughter_index is 0
=item o A's my_daughter_index is, suppose, 2
A is index 2 in ROOT's daughter list.
=item o B's my_daughter_index is, suppose, 0
B is index 0 in A's daughter list.
=item o $node's my_daughter_index is, suppose, 4
$node is index 4 in B's daughter list.
=back
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 meant to figure out what nodes are to the right of what
other nodes.)
=head2 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.
=head2 attribute()
=head2 attribute(SCALAR)
Exact synonyms for L</attributes()> and L</attributes(SCALAR)>.
=head2 attributes()
=head2 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.
=head2 clear_daughters()
This unlinks all $mother's daughters.
Returns the list of what used to be $mother's daughters.
Not to be confused with L</remove_daughters(LIST)>.
=head2 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.
=head2 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.
=head2 copy($option)
Returns a copy of the calling node (the invocant). E.g.: my($copy) = $node -> copy;
$option is a hashref of options, with these (key => value) pairs:
=over 4
=item o no_attribute_copy => $Boolean
If set to 1, do not copy the node's attributes.
If not specified, defaults to 0, which copies attributes.
=back
=head2 copy_at_and_under()
=head2 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.
=head2 copy_tree()
=head2 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.
=head2 daughters()
This returns the (possibly empty) list of daughters for $node.
=head2 decode_lol($lol)
Returns an arrayref having decoded the deeply nested structure $lol.
$lol will be the output of either tree_to_lol() or tree_to_simple_lol().
See scripts/read.tree.pl, and it's output file scripts/read.tree.log.
=head2 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 L</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 L</delete_tree()> -- they involve dummy classes, as explained at
L<http://mox.perl.com/misc/circle-destroy.pod>
However, introducing a dummy class concept into C<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 L</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 L</delete_tree()> is a "destructor", or as close as you can
meaningfully come for a circularity-rich data structure in Perl.)
See also L</WHEN AND HOW TO DESTROY THE TREE>.
=head2 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.)
=head2 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".)
=head2 draw_ascii_tree([$options])
Here, the [] refer to an optional parameter.
Returns an arrayref of lines suitable for printing.
Draws a nice ASCII-art representation of the tree structure.
The tree looks like:
|
<Root>
/-------+-----+---+---\
| | | | |
<I> <H> <D> <E> <B>
/---\ /---\ | | |
| | | | <F> <F> <C>
<J> <J> <J> <J> | |
| | | | <G> <G>
<K> <L> <K> <L>
| |
<M> <M>
| |
<N> <N>
| |
<O> <O>
See scripts/cut.and.paste.subtrees.pl.
Example usage:
print map("$_\n", @{$tree->draw_ascii_tree});
I<draw_ascii_tree()> takes parameters you set in the $options hashref:
=over 4
=item o h_compact
Takes 0 or 1. Sets the extent to which
I<draw_ascii_tree()> tries to save horizontal space.
If I think of a better scrunching algorithm, there'll be a "2" setting
for this.
Default: 1.
=item o h_spacing
Takes a number 0 or greater. Sets the number of spaces
inserted horizontally between nodes (and groups of nodes) in a tree.
Default: 1.
=item o no_name
If true, I<draw_ascii_tree()> doesn't print the name of
the node; it simply prints a "*".
Default: 0 (i.e., print the node name.)
=item o v_compact
Takes a number 0, 1, or 2. Sets the degree to which
I<draw_ascii_tree()> tries to save vertical space. Defaults to 1.
=back
The code occasionally returns trees that are a bit cock-eyed in parts; if
anyone can suggest a better drawing algorithm, I'd be appreciative.
See also L</tree2string($options, [$some_tree])>.
=head2 dump_names($options)
Returns an array.
Dumps, as an indented list, the names of the nodes starting at $node,
and continuing under it. Options are:
=over 4
=item o _depth -- A nonnegative number
Indicating the depth to consider $node as being at (and so the generation under that is that plus
one, etc.). You may choose to use set _depth => scalar($node->ancestors).
Default: 0.
=item o tick -- a string to preface each entry with
This string goes between the indenting-spacing and the node's name. You
may prefer "*" or "-> " or something.
Default: ''.
=item o indent -- the string used to indent with
Another sane value might be '. ' (period, space). Setting it to empty-string suppresses indenting.
Default: ' ' x 2.
=back
The output is not printed, but is returned as a list, where each
item is a line, with a "\n" at the end.
=head2 format_node($options, $node)
Returns a string consisting of the node's name and, optionally, it's attributes.
Possible keys in the $options hashref:
=over 4
=item o no_attributes => $Boolean
If 1, the node's attributes are not included in the string returned.
Default: 0 (include attributes).
=back
Calls L</hashref2string($hashref)>.
Called by L</node2string($options, $node, $vert_dashes)>.
You would not normally call this method.
If you don't wish to supply options, use format_node({}, $node).
=head2 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.
=head2 generation_under($node)
Like L</generation()>, but returns only the nodes in $node's generation
that are also descendants of $node -- 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, L</generation_under($node)> is just an alias to L</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().
=head2 hashref2string($hashref)
Returns the given hashref as a string.
Called by L</format_node($options, $node)>.
=head2 is_daughter_of($node2)
Returns true iff $node is a daughter of $node2.
Currently implemented as just a test of ($it->mother eq $node2).
=head2 is_node()
This always returns true. More pertinently, $object->can('is_node')
is true (regardless of what L</is_node()> would do if called) for objects
belonging to this class or for any class derived from it.
=head2 is_root()
Returns 1 if the caller is the root, and 0 if it is not.
=head2 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.
=head2 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 L</add_left_sisters(LIST)> and L</add_right_sisters(LIST)>.
=head2 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 L</add_left_sisters(LIST)> and L</add_right_sisters(LIST)>.
=head2 lol_to_tree($lol)
This must be called as a class method.
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.
=head2 mother()
This returns what node is $node's mother. This is undef if $node has
no mother -- i.e., if it is a root.
See also L</is_root()> and L</root()>.
=head2 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.
=head2 name()
=head2 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.
=head2 new($hashref)
These options are supported in $hashref:
=over 4
=item o attributes => A hashref of attributes
=item o daughters => An arrayref of nodes
=item o mother => A node
=item o name => A string
=back
See also L</MAIN CONSTRUCTOR, AND INITIALIZER> for a long discussion on object creation.
=head2 new_daughter()
=head2 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.
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'.
=head2 new_daughter_left()
=head2 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.
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'.
=head2 node2string($options, $node, $vert_dashes)
Returns a string of the node's name and attributes, with a leading indent, suitable for printing.
Possible keys in the $options hashref:
=over 4
=item o no_attributes => $Boolean
If 1, the node's attributes are not included in the string returned.
Default: 0 (include attributes).
=back
Ignore the parameter $vert_dashes. The code uses it as temporary storage.
Calls L</format_node($options, $node)>.
Called by L</tree2string($options, [$some_tree])>.
=head2 quote_name($name)
Returns the string "'$name'", which is used in various methods for outputting node names.
=head2 random_network($options)
This method can be called as a class method or as an object method.
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 L</random_network($options)>, here's the code...")
It takes four options:
=over 4
=item o max_node_count -- maximum number of nodes this tree will be allowed to have (counting the
root)
Default: 25.
=item o min_depth -- minimum depth for the tree
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.
Default: 2.
=item o max_depth -- maximum depth for the tree
The tree will not be deeper than this.
Default: 3 plus min_depth.
=item o max_children -- maximum number of children any mother in the tree can have.
Default: 4.
=back
=head2 read_attributes($s)
Parses the string $s and extracts the name and attributes, assuming the format is as generated by
L</tree2string($options, [$some_tree])>.
This bascially means the attribute string was generated by L</hashref2string($hashref)>.
Attributes may be absent, in which case they default to {}.
Returns a new node with this name and these attributes.
This method is for use by L</read_tree($file_name)>.
See t/tree.without.attributes.txt and t/tree.with.attributes.txt for sample data.
=head2 read_tree($file_name)
Returns the root of the tree read from $file_name.
The file must have been written by re-directing the output of
L</tree2string($options, [$some_tree])> to a file, since it makes assumptions about the format
of the stringified attributes.
read_tree() works with utf-8 data. See t/read.tree.t and t/tree.utf8.attributes.txt.
Note: To call this method you need a caller. It'll be a tree of 1 node. The reason is that inside
this method it calls various other methods, and for these calls it needs $self. That way, those
methods can be called from anywhere, and not just from within read_tree().
For reading and writing trees to databases, see L<Tree::DAG_Node::Persist>.
Calls L</string2hashref($s)>.
=head2 remove_daughter(LIST)
An exact synonym for L</remove_daughters(LIST)>.
=head2 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 L</clear_daughters()>.
=head2 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 the 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, respectively).
But N3's daughter list is unaffected.
In other words, this method does what it has to, as you'd expect it
to.
=head2 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.)
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'.
=head2 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 L</add_left_sisters(LIST)> and L</add_right_sisters(LIST)>.
=head2 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 L</add_left_sisters(LIST)> and L</add_right_sisters(LIST)>.
=head2 root()
Returns the root of whatever tree $node is a member of. If $node is
the root, then the result is $node itself.
Not to be confused with L</is_root()>.
=head2 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".)
=head2 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.)
=head2 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).
=head2 simple_lol_to_tree($simple_lol)
This must be called as a class method.
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'.
=head2 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.
=head2 string2hashref($s)
Returns the hashref built from the string.
The string is expected to be something like
'{AutoCommit => '1', PrintError => "0", ReportError => 1}'.
The empty string is returned as {}.
Called by L</read_tree($file_name)>.
=head2 tree_to_lol()
Returns that tree (starting at $node) represented as a LoL, like what
$lol, above, holds. (This is as opposed to L</tree_to_lol_notation($options)>,
which returns the viewable code like what gets evaluated and stored in
$lol, above.)
Undefined node names are returned as the string 'undef'.
See also L</decode_lol($lol)>.
Lord only knows what you use this for -- maybe for feeding to
Data::Dumper, in case L</tree_to_lol_notation($options)> doesn't do just what you
want?
=head2 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
printability 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.
Undefined node names are returned as the string 'undef'.
=head2 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.
Undefined node names are returned as the string 'undef'.
See also L</decode_lol($lol)>.
=head2 tree_to_simple_lol_notation($options)
A simple-LoL version of tree_to_lol_notation (which see); takes the
same options.
Undefined node names are returned as the string 'undef'.
=head2 tree2string($options, [$some_tree])
Here, the [] represent an optional parameter.
Returns an arrayref of lines, suitable for printing.
Draws a nice ASCII-art representation of the tree structure.
The tree looks like:
Root. Attributes: {}
|--- Â. Attributes: {# => "ÂÂ"}
| |--- â. Attributes: {# => "ââ"}
| | |--- É. Attributes: {# => "ÉÉ"}
| |--- ä. Attributes: {# => "ää"}
| |--- é. Attributes: {# => "éé"}
| |--- Ñ. Attributes: {# => "ÑÑ"}
| |--- ñ. Attributes: {# => "ññ"}
| |--- Ô. Attributes: {# => "ÔÔ"}
| |--- ô. Attributes: {# => "ôô"}
| |--- ô. Attributes: {# => "ôô"}
|--- ß. Attributes: {# => "ßß"}
|--- ®. Attributes: {# => "®®"}
| |--- ©. Attributes: {# => "©©"}
|--- £. Attributes: {# => "££"}
|--- €. Attributes: {# => "€€"}
|--- √. Attributes: {# => "√√"}
|--- ×xX. Attributes: {# => "×xX×xX"}
|--- í. Attributes: {# => "íí"}
|--- ú. Attributes: {# => "úú"}
|--- «. Attributes: {# => "««"}
|--- ». Attributes: {# => "»»"}
Or, without attributes:
Root
|--- Â
| |--- â
| | |--- É
| |--- ä
| |--- é
| |--- Ñ
| |--- ñ
| |--- Ô
| |--- ô
| |--- ô
|--- ß
|--- ®
| |--- ©
|--- £
|--- €
|--- √
|--- ×xX
|--- í
|--- ú
|--- «
|--- »
See scripts/cut.and.paste.subtrees.pl.
Example usage:
print map("$_\n", @{$tree->tree2string});
Can be called with $some_tree set to any $node, and will print the tree assuming $node is the root.
If you don't wish to supply options, use tree2string({}, $node).
Possible keys in the $options hashref (which defaults to {}):
=over 4
=item o no_attributes => $Boolean
If 1, the node's attributes are not included in the string returned.
Default: 0 (include attributes).
=back
Calls L</node2string($options, $node, $vert_dashes)>.
See also L</draw_ascii_tree([$options])>.
=head2 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).
=head2 walk_down($options)
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 I<walk_down()> does, in pseudocode form:
=over 4
=item o Starting point
Start at the $node given.
=item o Callback
If there's a I<callback>, call it with $node as the first argument,
and the options hashref as the second argument (which contains the
potentially useful I<_depth>, remember). This function must return
true or false -- if false, it will block the next step:
=item o Daughters
If $node has any daughter nodes, increment I<_depth>, and call
$daughter->walk_down($options) for each daughter (in order, of
course), where options_hashref is the same hashref it was called with.
When this returns, decrements I<_depth>.
=item Callbackback
If there's a I<callbackback>, call just it as with I<callback> (but
tossing out the return value). Note that I<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, I<callbackback> won't get called.)
=item o Return
=back
$node->walk_down($options) 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 I<callback>; if what you're doing is
best done with post-order traversal, use I<callbackback>.
I<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 I<_depth>, it effectively defaults to
0. You should set it to scalar($node->ancestors) if you want
I<_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
no 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 I<walk_down()>
is all finished, changing those nodes from that stack.
Note that the existence of I<walk_down()> doesn't mean you can't write
you own special-use traversers.
=head1 WHEN AND HOW TO DESTROY THE TREE
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 L</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 L</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, I<_init()>,
I<_init_name()>, and L</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 L</name()> method, without causing
problems. (Be sure to consider the case of $obj->name as a write
method, as it's used in I</lol_to_tree($lol)> and L</random_network($options)>.)
=head1 FAQ
=head2 Which is the best tree processing module?
C<Tree::DAG_Node>, as it happens. More details: L</SEE ALSO>.
=head2 How to process every node in tree?
See L</walk_down($options)>. $options normally looks like this, assuming we wish to pass in
an arrayref as a stack:
my(@stack);
$tree -> walk_down
({
callback =>
sub
{
my(@node, $options) = @_;
# Process $node, using $options...
push @{$$options{stack} }, $node -> name;
return 1; # Keep walking.
},
_depth => 0,
stack => \@stack,
});
# Process @stack...
=head2 How do I switch from Tree to Tree::DAG_Node?
=over 4
=item o The node's name
In C<Tree> you use $node -> value and in C<Tree::DAG_Node> it's $node -> name.
=item o The node's attributes
In C<Tree> you use $node -> meta and in C<Tree::DAG_Node> it's $node -> attributes.
=back
=head2 Are there techniques for processing lists of nodes?
=over 4
=item o Copy the daughter list, and change it
@them = $mother->daughters;
@removed = splice(@them, 0, 2, @new_nodes);
$mother->set_daughters(@them);
=item o Select a sub-set of nodes
$mother->set_daughters
(
grep($_->name =~ /wanted/, $mother->daughters)
);
=back
=head2 Why did you break up the sections of methods in the POD?
Because I want to list the methods in alphabetical order.
=head2 Why did you move the POD to the end?
Because the apostrophes in the text confused the syntax hightlighter in my editor UltraEdit.
=head1 SEE ALSO
=over 4
=item o L<HTML::Element>, L<HTML::Tree> and L<HTML::TreeBuilder>
Sean is also the author of these modules.
=item o L<Tree>
Lightweight.
=item o L<Tree::Binary>
Lightweight.
=item o L<Tree::DAG_Node::Persist>
Lightweight.
=item o L<Tree::Persist>
Lightweight.
=item o L<Forest>
Uses L<Moose>.
=back
C<Tree::DAG_Node> itself is also lightweight.
=head1 REFERENCES
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 MACHINE-READABLE CHANGE LOG
The file Changes was converted into Changelog.ini by L<Module::Metadata::Changes>.
=head1 REPOSITORY
L<https://github.com/ronsavage/Tree-DAG_Node>
=head1 SUPPORT
Email the author, or log a bug on RT:
L<https://rt.cpan.org/Public/Dist/Display.html?Name=Tree-DAG_Node>.
=head1 ACKNOWLEDGEMENTS
The code to print the tree, in tree2string(), was adapted from
L<Forest::Tree::Writer::ASCIIWithBranches> by the dread Stevan Little.
=head1 MAINTAINER
David Hand, C<< <cogent@cpan.org> >> up to V 1.06.
Ron Savage C<< <rsavage@cpan.org> >> from V 1.07.
In this POD, usage of 'I' refers to Sean, up until V 1.07.
=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. It is released under the Artistic License 2.0.
See L<http://opensource.org/licenses/Artistic-2.0>.
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