##
company
/ | \
sales R&D pers
/ \ / \
net store | |
research development
####
#!/usr/bin/perl -w
use strict;
use Tree::DAG_Node;
my $pm = Tree::DAG_Node->new;
$pm->name('PerlMonks');
####
my $tutorials = Tree::DAG_Node->new;
$tutorials->name('tutorials');
$tutorials->new_daughter->name('basics');
$tutorials->new_daughter->name('syntax');
$tutorials->new_daughter->name('references');
$tutorials->new_daughter->name('data');
####
$pm->add_daughter($tutorials);
####
my $reviews = Tree::DAG_Node->new;
$reviews->name('reviews');
$reviews->new_daughter->name('books');
$reviews->new_daughter->name('modules');
my $SOPW = Tree::DAG_Node->new;
$SOPW->name('SOPW');
$pm->add_daughter($reviews, $SOPW);
####
print map "$_\n", @{$pm->draw_ascii_tree};
####
$pm->new_daughter->name('Meditations');
####
print $pm->dump_names;
####
|
/---------------------------+-----------\
| | |
/--------+----------+---------\ /--------\
| | | | | |
'PerlMonks'
'tutorials'
'basics'
'syntax'
'references'
'data'
'reviews'
'books'
'modules'
'SOPW'
'Meditations'
## ##
$pm->walk_down({
callback => sub {
my $node = shift;
print " " x $_[0]->{_depth};
print "(*) "
if $node->name eq $_[0]->{treename};
print $node->name, "\n"
},
_depth => 0,
treename => 'PerlMonks'
});
####
(*) PerlMonks
tutorials
basics
syntax
references
data
reviews
books
modules
SOPW
Meditations
####
basics
syntax
references
data
tutorials
books
modules
reviews
SOPW
Meditations
(*) PerlMonks
####
sub traverse {
my $node = shift;
my $depth = scalar $node->ancestors || 0;
# a pre-order traversal. First we do something ...
print ".." x $depth, $node->name," ", $node->address, "\n";
# ... and then we recurse the subodes
traverse($_) for $node->daughters;
}
PerlMonks 0
..tutorials 0:0
....basics 0:0:0
....syntax 0:0:1
....references 0:0:2
....data 0:0:3
..reviews 0:1
....books 0:1:0
....modules 0:1:1
..SOPW 0:2
..Meditations 0:3
####
$pm->attributes (['The', ['best', 'Perl'],['site']]);
$tutorials->attributes ({
useful => 'yes',
available => ['day','night']
});
$SOPW->attributes (\&check_if_strict);
$reviews->attributes(Tree::DAG_Node->new);
$pm->walk_down({callback=>sub{
print $_[0]->name," ", ref $_[0]->attributes,"\n";
}});
####
|
/---------------------------\
| |
/---------------\ /---+---+---+---+---\
| | | | | | | |
<1> <2>
/-------\ /-------\
| | | |
/---\ /---\ /---+---\
| | | | | | |
<5> <6> <7>
##
##
my @daughters = $root->daughters; # and
my @b_daughthers = $daughters[1]->daughters; # 's daughters
my $third = $b_daughthers[2]; #
my $ls = $third->left_sister; #
my $rs = $third->right_sister; #
my @left = $third->left_sisters; # and
my @right = $third->right_sisters; # ,
my $mama = $third->mother; #
my @ancestors = $third->ancestors; #
##
##
my @descnames = map {$_->name} $node1->descendants;
# @descnames = qw(w i j x k l);
####
#!/usr/bin/perl -w
use strict;
package CompanyTree;
use Tree::DAG_Node;
our @ISA=qw(Tree::DAG_Node);
sub new {
my $class = shift;
my $options = shift;
my $self = bless $class->SUPER::new();
$self->attributes($options);
return $self;
}
####
sub employees {
my $node = shift;
my $val = shift;
$node->attributes->{employees} = $val if $val;
return $node->attributes->{employees};
}
sub budget {
my $node = shift;
my $val = shift;
$node->attributes->{budget} = $val if $val;
return $node->attributes->{budget};
}
sub by_name {
my ($self, $name) = @_;
my @found =();
my $retvalue = wantarray ? 1 : 0;
$self->walk_down({callback=>sub{
if ($_[0]->name eq $name) {
push @found, $_[0];
return $retvalue;
}
1}});
return wantarray? @found : @found ? $found[0] : undef;
}
####
sub clear_totals {
$_[0]->walk_down({ callback => sub {
my $node = shift;
if ($node->daughters) {
$node->budget(0);
$node->employees(0);
}
}})
}
sub sum_up {
$_[0]->walk_down({ callbackback=> sub {
my $node = shift;
return 1 unless $node->mother;
$node->mother->attributes->{employees}
+= $node->attributes->{employees};
$node->mother->attributes->{budget}
+= $node->attributes->{budget};
}});
}
sub print_wealth {
$_[0]->walk_down({callback=> sub {
my $node = shift;
printf "%s%.7s\templ: %2d budget: %8d\n",
" " x $_[0]->{_depth},
$node->name, $node->employees,
$node->budget
}, _depth => 0 });
}
####
package main;
my $company = CompanyTree->new({employees=>0, budget=>0});
$company->name('company');
$company->new_daughter(
{employees=>0,budget=>0})->name('sales');
$company->by_name('sales')->new_daughter(
{employees=>6,budget=>25_000})->name('net');
$company->by_name('sales')->new_daughter(
{employees=>8,budget=>65_000})->name('str');
$company->new_daughter(
{employees=>4,budget=>10_000})->name('pers');
$company->new_daughter({employees=>0,budget=>0})->name('R&D');
$company->by_name('R&D')->new_daughter(
{employees=>10,budget=>100_000})->name('res');
$company->by_name('R&D')->new_daughter(
{employees=>15,budget=>90_000})->name('dev');
$company->clear_totals;
$company->sum_up;
$company->print_wealth;
print map "$_\n", @{$company->draw_ascii_tree};
####
company empl: 43 budget: 290000
sales empl: 14 budget: 90000
net empl: 6 budget: 25000
str empl: 8 budget: 65000
pers empl: 4 budget: 10000
R&D empl: 25 budget: 190000
res empl: 10 budget: 100000
dev empl: 15 budget: 90000
####
|
/--------+---------\
| | |
/-----\ /-----\
| | | |
## ##
my $node = $root->address('0:2:1');
####
my $node = $root->address('0:2:1');
$node->mother->new_daughter_left;
# now $node's address is '0:2:2'
####
sub by_attribute {
my ($self, $key, $id) = @_;
my $found = undef;
$self->walk_down({callback=>sub{
if (ref $_[0]->attributes eq "HASH"
&& exists $_[0]->attributes->{$key}
&& $_[0]->attributes->{$key} eq $id)
{
$found = $_[0];
return 0;
}
1}});
return $found;
}
####
my $node = $root->by_attribute( 'ID', 'nutcracker');
####
#!/usr/bin/perl -w
use strict;
use Tree::DAG_Node;
my $root = Tree::DAG_Node->new;
$root->name('root');
$root->new_daughter->name($_) for ('1'..'3');
my @names = qw(abc def ghi);
my $count =0;
for my $n ($root->daughters) {
for (split //, $names[$count++]) {
$n->new_daughter->name($_)
}
}
print map "$_\n", @{$root->draw_ascii_tree};
####
|
/-----------+-----------\
| | |
<1> <2> <3>
/---+---\ /---+---\ /---+---\
| | | | | | | | |
## ##
my $node = $root->address('0:1');
$node->replace_with_daughters;
print map "$_\n", @{$root->draw_ascii_tree};
####
|
/-------+---+---+-------\
| | | | |
<1> <3>
/---+---\ /---+---\
| | | | | |
## ##
$node = $root->address('0:4');
my $dest = $root->address('0:2');
$dest->add_daughter($node);
print map "$_\n", @{$root->draw_ascii_tree};
####
|
/-------+-------+-------\
| | | |
<1>
/---+---\ |
| | | <3>
/---+---\
| | |