Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

Re: recursive creation of attached objects?

by tobyink (Abbot)
on Sep 14, 2012 at 08:52 UTC ( #993685=note: print w/ replies, xml ) Need Help??


in reply to recursive creation of attached objects?

use 5.010; use strict; use warnings FATAL => 'all'; { package Tree; use MooseX::Role::Parameterized; use Moose::Util::TypeConstraints qw(union role_type); use Scalar::Does; use List::Util qw(max); parameter child_names => (isa => 'ArrayRef[Str]', required => 1); role { my @child_names = @{ shift->child_names }; # We allow each child to be undef, a string, or another Tree # Strings are arguably a bad idea. Instead we should create # Tree objects with a "payload". (See below.) has $_ => ( is => 'rw', trigger => sub { my ($self, $new, $old) = @_; $old->_clear_parent if does $old, 'Tree'; $new->_set_parent($self) if does $new, 'Tree'; }, isa => union(qw( Undef Str ), role_type('Tree')), ) for @child_names; has parent => ( does => 'Tree', reader => 'parent', writer => '_set_parent', clearer => '_clear_parent', predicate => 'has_parent', ); method mk_balanced => sub { my ($class, $depth) = @_; my $self = $class->new; return $self unless $depth; $self->children( map { $class->mk_balanced($depth - 1) } @child_names ); return $self; }; method is_orphan => sub { not shift->has_parent; }; method child_depth => sub { my $self = shift; return 1 + max map { does($_, 'Tree') ? $_->child_depth : (defined $_ + ? 0 : -1) } $self->children; }; method parent_height => sub { my $self = shift; return 0 if $self->is_orphan; return 1 + $self->parent->parent_height; }; method children => sub { my $self = shift; if (@_) { for (@child_names) { $self->$_(shift); } } return map { $self->$_ } @child_names; }; method has_children => sub { grep defined, shift->children; }; method to_string => sub { my $self = shift; return "(leaf node)" unless $self->has_children; my @child = map { does($_, 'Tree') ? $_->to_string : (defined $_ ? + qq("$_") : '(undef)') } $self->children; # indent by three spaces s/^/ /mg for @child; return join "\n", "(node)", @child; }; } } { package Tree::Binary; use Moose; with Tree => { child_names => [qw( a b )] }; } say "Make a balanced binary tree, 3 layers deep"; my $tree = Tree::Binary->mk_balanced(3); say "Tree depth is ", $tree->child_depth; say $tree->to_string; say "----"; say "Extend one of the leaf nodes"; $tree->b->a->a( Tree::Binary->mk_balanced(2) ); say "Tree depth is ", $tree->child_depth; say $tree->to_string; say "----"; say "Now let's try a ternary tree"; { package Tree::Ternary; use Moose; with Tree => { child_names => [qw( a b c )] }; } my $ternary = Tree::Ternary->mk_balanced(2); say "Tree depth is ", $ternary->child_depth; say $ternary->to_string; say "----"; say "Trees where each node has a payload."; { package Tree::Binary::WithString; use Moose; extends 'Tree::Binary'; has payload => (is => 'rw', isa => 'Str', required => 1); around to_string => sub { my ($orig, $self) = @_; my $string = $self->$orig; $string =~ s/\((.*node)\)/"($1 \"".$self->payload."\")"/e; return $string; }; } my $people = Tree::Binary::WithString->new(payload => 'People'); $people->children( Tree::Binary::WithString->new(payload => 'Men'), Tree::Binary::WithString->new(payload => 'Women'), ); say $people->to_string; say "----";

updated to add example with payloads

perl -E'sub Monkey::do{say$_,for@_,do{($monkey=[caller(0)]->[3])=~s{::}{ }and$monkey}}"Monkey say"->Monkey::do'


Comment on Re: recursive creation of attached objects?
Download Code

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://993685]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others having an uproarious good time at the Monastery: (7)
As of 2015-08-01 01:44 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (285 votes), past polls