1require 5; 2package Tree::DAG_Node; 3use Carp (); 4use strict; 5use vars qw(@ISA $Debug $VERSION); 6 7$Debug = 0; 8$VERSION = '1.06'; 9 10=head1 NAME 11 12Tree::DAG_Node - (super)class for representing nodes in a tree 13 14=head1 SYNOPSIS 15 16Using as a base class: 17 18 package Game::Tree::Node; # or whatever you're doing 19 use Tree::DAG_Node; 20 @ISA = qw(Tree::DAG_Node); 21 ...your own methods overriding/extending 22 the methods in Tree::DAG_Node... 23 24Using as a class of its own: 25 26 use Tree::DAG_Node; 27 my $root = Tree::DAG_Node->new(); 28 $root->name("I'm the tops"); 29 my $new_daughter = $root->new_daughter; 30 $new_daughter->name("More"); 31 ... 32 33=head1 DESCRIPTION 34 35This class encapsulates/makes/manipulates objects that represent nodes 36in a tree structure. The tree structure is not an object itself, but 37is emergent from the linkages you create between nodes. This class 38provides the methods for making linkages that can be used to build up 39a tree, while preventing you from ever making any kinds of linkages 40which are not allowed in a tree (such as having a node be its own 41mother or ancestor, or having a node have two mothers). 42 43This is what I mean by a "tree structure", a bit redundantly stated: 44 45* A tree is a special case of an acyclic directed graph. 46 47* A tree is a network of nodes where there's exactly one root 48node (i.e., 'the top'), and the only primary relationship between nodes 49is the mother-daugher relationship. 50 51* No node can be its own mother, or its mother's mother, etc. 52 53* Each node in the tree has exactly one "parent" (node in the "up" 54direction) -- except the root, which is parentless. 55 56* Each node can have any number (0 to any finite number) of daughter 57nodes. A given node's daughter nodes constitute an I<ordered> list. 58(However, you are free to consider this ordering irrelevant. 59Some applications do need daughters to be ordered, so I chose to 60consider this the general case.) 61 62* A node can appear in only one tree, and only once in that tree. 63Notably (notable because it doesn't follow from the two above points), 64a node cannot appear twice in its mother's daughter list. 65 66* In other words, there's an idea of up (toward the root) versus 67down (away from the root), and left (i.e., toward the start (index 0) 68of a given node's daughter list) versus right (toward the end of a 69given node's daughter list). 70 71Trees as described above have various applications, among them: 72representing syntactic constituency, in formal linguistics; 73representing contingencies in a game tree; representing abstract 74syntax in the parsing of any computer language -- whether in 75expression trees for programming languages, or constituency in the 76parse of a markup language document. (Some of these might not use the 77fact that daughters are ordered.) 78 79(Note: B-Trees are a very special case of the above kinds of trees, 80and are best treated with their own class. Check CPAN for modules 81encapsulating B-Trees; or if you actually want a database, and for 82some reason ended up looking here, go look at L<AnyDBM_File>.) 83 84Many base classes are not usable except as such -- but Tree::DAG_Node 85can be used as a normal class. You can go ahead and say: 86 87 use Tree::DAG_Node; 88 my $root = Tree::DAG_Node->new(); 89 $root->name("I'm the tops"); 90 $new_daughter = Tree::DAG_Node->new(); 91 $new_daughter->name("More"); 92 $root->add_daughter($new_daughter); 93 94and so on, constructing and linking objects from Tree::DAG_Node and 95making useful tree structures out of them. 96 97=head1 A NOTE TO THE READER 98 99This class is big and provides lots of methods. If your problem is 100simple (say, just representing a simple parse tree), this class might 101seem like using an atomic sledgehammer to swat a fly. But the 102complexity of this module's bells and whistles shouldn't detract from 103the efficiency of using this class for a simple purpose. In fact, I'd 104be very surprised if any one user ever had use for more that even a 105third of the methods in this class. And remember: an atomic 106sledgehammer B<will> kill that fly. 107 108=head1 OBJECT CONTENTS 109 110Implementationally, each node in a tree is an object, in the sense of 111being an arbitrarily complex data structure that belongs to a class 112(presumably Tree::DAG_Node, or ones derived from it) that provides 113methods. 114 115The attributes of a node-object are: 116 117=over 118 119=item mother -- this node's mother. undef if this is a root. 120 121=item daughters -- the (possibly empty) list of daughters of this node. 122 123=item name -- the name for this node. 124 125Need not be unique, or even printable. This is printed in some of the 126various dumper methods, but it's up to you if you don't put anything 127meaningful or printable here. 128 129=item attributes -- whatever the user wants to use it for. 130 131Presumably a hashref to whatever other attributes the user wants to 132store without risk of colliding with the object's real attributes. 133(Example usage: attributes to an SGML tag -- you definitely wouldn't 134want the existence of a "mother=foo" pair in such a tag to collide with 135a node object's 'mother' attribute.) 136 137Aside from (by default) initializing it to {}, and having the access 138method called "attributes" (described a ways below), I don't do 139anything with the "attributes" in this module. I basically intended 140this so that users who don't want/need to bother deriving a class 141from Tree::DAG_Node, could still attach whatever data they wanted in a 142node. 143 144=back 145 146"mother" and "daughters" are attributes that relate to linkage -- they 147are never written to directly, but are changed as appropriate by the 148"linkage methods", discussed below. 149 150The other two (and whatever others you may add in derived classes) are 151simply accessed thru the same-named methods, discussed further below. 152 153=head2 ABOUT THE DOCUMENTED INTERFACE 154 155Stick to the documented interface (and comments in the source -- 156especially ones saying "undocumented!" and/or "disfavored!" -- do not 157count as documentation!), and don't rely on any behavior that's not in 158the documented interface. 159 160Specifically, unless the documentation for a particular method says 161"this method returns thus-and-such a value", then you should not rely on 162it returning anything meaningful. 163 164A I<passing> acquintance with at least the broader details of the source 165code for this class is assumed for anyone using this class as a base 166class -- especially if you're overriding existing methods, and 167B<definitely> if you're overriding linkage methods. 168 169=head1 MAIN CONSTRUCTOR, AND INITIALIZER 170 171=over 172 173=item the constructor CLASS->new() or CLASS->new({...options...}) 174 175This creates a new node object, calls $object->_init({...options...}) 176to provide it sane defaults (like: undef name, undef mother, no 177daughters, 'attributes' setting of a new empty hashref), and returns 178the object created. (If you just said "CLASS->new()" or "CLASS->new", 179then it pretends you called "CLASS->new({})".) 180 181Currently no options for putting in {...options...} are part 182of the documented interface, but the options is here in case 183you want to add such behavior in a derived class. 184 185Read on if you plan on using Tree::DAG_New as a base class. 186(Otherwise feel free to skip to the description of _init.) 187 188There are, in my mind, two ways to do object construction: 189 190Way 1: create an object, knowing that it'll have certain uninteresting 191sane default values, and then call methods to change those values to 192what you want. Example: 193 194 $node = Tree::DAG_Node->new; 195 $node->name('Supahnode!'); 196 $root->add_daughter($node); 197 $node->add_daughters(@some_others) 198 199Way 2: be able to specify some/most/all the object's attributes in 200the call to the constructor. Something like: 201 202 $node = Tree::DAG_Node->new({ 203 name => 'Supahnode!', 204 mother => $root, 205 daughters => \@some_others 206 }); 207 208After some deliberation, I've decided that the second way is a Bad 209Thing. First off, it is B<not> markedly more concise than the first 210way. Second off, it often requires subtly different syntax (e.g., 211\@some_others vs @some_others). It just complicates things for the 212programmer and the user, without making either appreciably happier. 213 214(This is not to say that options in general for a constructor are bad 215-- C<random_network>, discussed far below, necessarily takes options. 216But note that those are not options for the default values of 217attributes.) 218 219Anyway, if you use Tree::DAG_Node as a superclass, and you add 220attributes that need to be initialized, what you need to do is provide 221an _init method that calls $this->SUPER::_init($options) to use its 222superclass's _init method, and then initializes the new attributes: 223 224 sub _init { 225 my($this, $options) = @_[0,1]; 226 $this->SUPER::_init($options); # call my superclass's _init to 227 # init all the attributes I'm inheriting 228 229 # Now init /my/ new attributes: 230 $this->{'amigos'} = []; # for example 231 } 232 233...or, as I prefer when I'm being a neat freak: 234 235 sub _init { 236 my($this, $options) = @_[0,1]; 237 $this->SUPER::_init($options); 238 239 $this->_init_amigos($options); 240 } 241 242 sub _init_amigos { 243 my $this = $_[0]; 244 # Or my($this,$options) = @_[0,1]; if I'm using $options 245 $this->{'amigos'} = []; 246 } 247 248 249In other words, I like to have each attribute initialized thru a 250method named _init_[attribute], which should expect the object as 251$_[0] and the the options hashref (or {} if none was given) as $_[1]. 252If you insist on having your _init recognize options for setting 253attributes, you might as well have them dealt with by the appropriate 254_init_[attribute] method, like this: 255 256 sub _init { 257 my($this, $options) = @_[0,1]; 258 $this->SUPER::_init($options); 259 260 $this->_init_amigos($options); 261 } 262 263 sub _init_amigos { 264 my($this,$options) = @_[0,1]; # I need options this time 265 $this->{'amigos'} = []; 266 $this->amigos(@{$options->{'amigos'}}) if $options->{'amigos'}; 267 } 268 269All this bookkeeping looks silly with just one new attribute in a 270class derived straight from Tree::DAG_Node, but if there's lots of new 271attributes running around, and if you're deriving from a class derived 272from a class derived from Tree::DAG_Node, then tidy 273stratification/modularization like this can keep you sane. 274 275=item the constructor $obj->new() or $obj->new({...options...}) 276 277Just another way to get at the C<new> method. This B<does not copy> 278$obj, but merely constructs a new object of the same class as it. 279Saves you the bother of going $class = ref $obj; $obj2 = $class->new; 280 281=cut 282 283sub new { # constructor 284 # Presumably you won't EVER need to override this -- _init is what 285 # you'd override in order to set an object's default attribute values. 286 my $class = shift; 287 $class = ref($class) if ref($class); # tchristic style. why not? 288 289 my $o = ref($_[0]) eq 'HASH' ? $_[0] : {}; # o for options hashref 290 my $it = bless( {}, $class ); 291 print "Constructing $it in class $class\n" if $Debug; 292 $it->_init( $o ); 293 return $it; 294} 295 296########################################################################### 297 298=item the method $node->_init({...options...}) 299 300Initialize the object's attribute values. See the discussion above. 301Presumably this should be called only by the guts of the C<new> 302constructor -- never by the end user. 303 304Currently there are no documented options for putting in 305{...options...}, but (in case you want to disregard the above rant) 306the option exists for you to use {...options...} for something useful 307in a derived class. 308 309Please see the source for more information. 310 311=item see also (below) the constructors "new_daughter" and "new_daughter_left" 312 313=back 314 315=cut 316 317sub _init { # method 318 my $this = shift; 319 my $o = ref($_[0]) eq 'HASH' ? $_[0] : {}; 320 321 # Sane initialization. 322 $this->_init_mother($o); 323 $this->_init_daughters($o); 324 $this->_init_name($o); 325 $this->_init_attributes($o); 326 327 return; 328} 329 330sub _init_mother { # to be called by an _init 331 my($this, $o) = @_[0,1]; 332 333 $this->{'mother'} = undef; 334 335 # Undocumented and disfavored. Consider this just an example. 336 ( $o->{'mother'} )->add_daughter($this) 337 if defined($o->{'mother'}) && ref($o->{'mother'}); 338 # DO NOT use this option (as implemented) with new_daughter or 339 # new_daughter_left!!!!! 340 # BAD THINGS MAY HAPPEN!!! 341} 342 343sub _init_daughters { # to be called by an _init 344 my($this, $o) = @_[0,1]; 345 346 $this->{'daughters'} = []; 347 348 # Undocumented and disfavored. Consider this just an example. 349 $this->set_daughters( @{$o->{'daughters'}} ) 350 if ref($o->{'daughters'}) && (@{$o->{'daughters'}}); 351 # DO NOT use this option (as implemented) with new_daughter or 352 # new_daughter_left!!!!! 353 # BAD THINGS MAY HAPPEN!!! 354} 355 356sub _init_name { # to be called by an _init 357 my($this, $o) = @_[0,1]; 358 359 $this->{'name'} = undef; 360 361 # Undocumented and disfavored. Consider this just an example. 362 $this->name( $o->{'name'} ) if exists $o->{'name'}; 363} 364 365sub _init_attributes { # to be called by an _init 366 my($this, $o) = @_[0,1]; 367 368 $this->{'attributes'} = {}; 369 370 # Undocumented and disfavored. Consider this just an example. 371 $this->attributes( $o->{'attributes'} ) if exists $o->{'attributes'}; 372} 373 374########################################################################### 375########################################################################### 376 377=head1 LINKAGE-RELATED METHODS 378 379=over 380 381=item $node->daughters 382 383This returns the (possibly empty) list of daughters for $node. 384 385=cut 386 387sub daughters { # read-only attrib-method: returns a list. 388 my $this = shift; 389 390 if(@_) { # undoc'd and disfavored to use as a write-method 391 Carp::croak "Don't set daughters with doughters anymore\n"; 392 Carp::carp "my parameter must be a listref" unless ref($_[0]); 393 $this->{'daughters'} = $_[0]; 394 $this->_update_daughter_links; 395 } 396 #return $this->{'daughters'}; 397 return @{$this->{'daughters'} || []}; 398} 399 400########################################################################### 401 402=item $node->mother 403 404This returns what node is $node's mother. This is undef if $node has 405no mother -- i.e., if it is a root. 406 407=cut 408 409sub mother { # read-only attrib-method: returns an object (the mother node) 410 my $this = shift; 411 Carp::croak "I'm a read-only method!" if @_; 412 return $this->{'mother'}; 413} 414 415########################################################################### 416########################################################################### 417 418=item $mother->add_daughters( LIST ) 419 420This method adds the node objects in LIST to the (right) end of 421$mother's C<daughter> list. Making a node N1 the daughter of another 422node N2 also means that N1's C<mother> attribute is "automatically" set 423to N2; it also means that N1 stops being anything else's daughter as 424it becomes N2's daughter. 425 426If you try to make a node its own mother, a fatal error results. If 427you try to take one of a a node N1's ancestors and make it also a 428daughter of N1, a fatal error results. A fatal error results if 429anything in LIST isn't a node object. 430 431If you try to make N1 a daughter of N2, but it's B<already> a daughter 432of N2, then this is a no-operation -- it won't move such nodes to the 433end of the list or anything; it just skips doing anything with them. 434 435=item $node->add_daughter( LIST ) 436 437An exact synonym for $node->add_daughters(LIST) 438 439=cut 440 441sub add_daughters { # write-only method 442 my($mother, @daughters) = @_; 443 return unless @daughters; # no-op 444 return 445 $mother->_add_daughters_wrapper( 446 sub { push @{$_[0]}, $_[1]; }, 447 @daughters 448 ); 449} 450 451sub add_daughter { # alias 452 my($it,@them) = @_; $it->add_daughters(@them); 453} 454 455=item $mother->add_daughters_left( LIST ) 456 457This method is just like C<add_daughters>, except that it adds the 458node objects in LIST to the (left) beginning of $mother's daughter 459list, instead of the (right) end of it. 460 461=item $node->add_daughter_left( LIST ) 462 463An exact synonym for $node->add_daughters_left( LIST ) 464 465=cut 466 467sub add_daughters_left { # write-only method 468 my($mother, @daughters) = @_; 469 return unless @daughters; 470 return 471 $mother->_add_daughters_wrapper( 472 sub { unshift @{$_[0]}, $_[1]; }, 473 @daughters 474 ); 475} 476 477sub add_daughter_left { # alias 478 my($it,@them) = @_; $it->add_daughters_left(@them); 479} 480 481=item Note: 482 483The above link-making methods perform basically an C<unshift> or 484C<push> on the mother node's daughter list. To get the full range of 485list-handling functionality, copy the daughter list, and change it, 486and then call C<set_daughters> on the result: 487 488 @them = $mother->daughters; 489 @removed = splice(@them, 0,2, @new_nodes); 490 $mother->set_daughters(@them); 491 492Or consider a structure like: 493 494 $mother->set_daughters( 495 grep($_->name =~ /NP/ , 496 $mother->daughters 497 ) 498 ); 499 500=cut 501 502 503### 504## Used by the adding methods 505# (except maybe new_daughter, and new_daughter_left) 506 507sub _add_daughters_wrapper { 508 my($mother, $callback, @daughters) = @_; 509 return unless @daughters; 510 511 my %ancestors; 512 @ancestors{ $mother->ancestors } = undef; 513 # This could be made more efficient by not bothering to compile 514 # the ancestor list for $mother if all the nodes to add are 515 # daughterless. 516 # But then you have to CHECK if they're daughterless. 517 # If $mother is [big number] generations down, then it's worth checking. 518 519 foreach my $daughter (@daughters) { # which may be () 520 Carp::croak "daughter must be a node object!" unless UNIVERSAL::can($daughter, 'is_node'); 521 522 printf "Mother : %s (%s)\n", $mother, ref $mother if $Debug; 523 printf "Daughter: %s (%s)\n", $daughter, ref $daughter if $Debug; 524 printf "Adding %s to %s\n", 525 ($daughter->name() || $daughter), 526 ($mother->name() || $mother) if $Debug > 1; 527 528 Carp::croak "mother can't be its own daughter!" if $mother eq $daughter; 529 530 $daughter->cyclicity_fault( 531 "$daughter (" . ($daughter->name || 'no_name') . 532 ") is an ancestor of $mother (" . ($mother->name || 'no_name') . 533 "), so can't became its daughter." 534 ) if exists $ancestors{$daughter}; 535 536 my $old_mother = $daughter->{'mother'}; 537 538 next if defined($old_mother) && ref($old_mother) && $old_mother eq $mother; 539 # noop if $daughter is already $mother's daughter 540 541 $old_mother->remove_daughters($daughter) 542 if defined($old_mother) && ref($old_mother); 543 544 &{$callback}($mother->{'daughters'}, $daughter); 545 } 546 $mother->_update_daughter_links; # need only do this at the end 547 548 return; 549} 550 551########################################################################### 552########################################################################### 553 554sub _update_daughter_links { 555 # Eliminate any duplicates in my daughters list, and update 556 # all my daughters' links to myself. 557 my $this = shift; 558 559 my $them = $this->{'daughters'}; 560 561 # Eliminate duplicate daughters. 562 my %seen = (); 563 @$them = grep { ref($_) && not($seen{$_}++) } @$them; 564 # not that there should ever be duplicate daughters anyhoo. 565 566 foreach my $one (@$them) { # linkage bookkeeping 567 Carp::croak "daughter <$one> isn't an object!" unless ref $one; 568 $one->{'mother'} = $this; 569 } 570 return; 571} 572 573########################################################################### 574 575# Currently unused. 576 577sub _update_links { # update all descendant links for ancestorship below 578 # this point 579 # note: it's "descendant", not "descendent" 580 # see <http://www.lenzo.com/~sburke/stuff/english_ant_and_ent.html> 581 my $this = shift; 582 # $this->no_cyclicity; 583 $this->walk_down({ 584 'callback' => sub { 585 my $this = $_[0]; 586 $this->_update_daughter_links; 587 return 1; 588 }, 589 }); 590} 591 592########################################################################### 593########################################################################### 594 595=item the constructor $daughter = $mother->new_daughter, or 596 597=item the constructor $daughter = $mother->new_daughter({...options...}) 598 599This B<constructs> a B<new> node (of the same class as $mother), and 600adds it to the (right) end of the daughter list of $mother. This is 601essentially the same as going 602 603 $daughter = $mother->new; 604 $mother->add_daughter($daughter); 605 606but is rather more efficient because (since $daughter is guaranteed new 607and isn't linked to/from anything), it doesn't have to check that 608$daughter isn't an ancestor of $mother, isn't already daughter to a 609mother it needs to be unlinked from, isn't already in $mother's 610daughter list, etc. 611 612As you'd expect for a constructor, it returns the node-object created. 613 614=cut 615 616# Note that if you radically change 'mother'/'daughters' bookkeeping, 617# you may have to change this routine, since it's one of the places 618# that directly writes to 'daughters' and 'mother'. 619 620sub new_daughter { 621 my($mother, @options) = @_; 622 my $daughter = $mother->new(@options); 623 624 push @{$mother->{'daughters'}}, $daughter; 625 $daughter->{'mother'} = $mother; 626 627 return $daughter; 628} 629 630=item the constructor $mother->new_daughter_left, or 631 632=item $mother->new_daughter_left({...options...}) 633 634This is just like $mother->new_daughter, but adds the new daughter 635to the left (start) of $mother's daughter list. 636 637=cut 638 639# Note that if you radically change 'mother'/'daughters' bookkeeping, 640# you may have to change this routine, since it's one of the places 641# that directly writes to 'daughters' and 'mother'. 642 643sub new_daughter_left { 644 my($mother, @options) = @_; 645 my $daughter = $mother->new(@options); 646 647 unshift @{$mother->{'daughters'}}, $daughter; 648 $daughter->{'mother'} = $mother; 649 650 return $daughter; 651} 652 653########################################################################### 654 655=item $mother->remove_daughters( LIST ) 656 657This removes the nodes listed in LIST from $mother's daughter list. 658This is a no-operation if LIST is empty. If there are things in LIST 659that aren't a current daughter of $mother, they are ignored. 660 661Not to be confused with $mother->clear_daughters. 662 663=cut 664 665sub remove_daughters { # write-only method 666 my($mother, @daughters) = @_; 667 Carp::croak "mother must be an object!" unless ref $mother; 668 return unless @daughters; 669 670 my %to_delete; 671 @daughters = grep {ref($_) 672 and defined($_->{'mother'}) 673 and $mother eq $_->{'mother'} 674 } @daughters; 675 return unless @daughters; 676 @to_delete{ @daughters } = undef; 677 678 # This could be done better and more efficiently, I guess. 679 foreach my $daughter (@daughters) { 680 $daughter->{'mother'} = undef; 681 } 682 my $them = $mother->{'daughters'}; 683 @$them = grep { !exists($to_delete{$_}) } @$them; 684 685 # $mother->_update_daughter_links; # unnecessary 686 return; 687} 688 689=item $node->remove_daughter( LIST ) 690 691An exact synonym for $node->remove_daughters( LIST ) 692 693=cut 694 695sub remove_daughter { # alias 696 my($it,@them) = @_; $it->remove_daughters(@them); 697} 698 699=item $node->unlink_from_mother 700 701This removes node from the daughter list of its mother. If it has no 702mother, this is a no-operation. 703 704Returns the mother unlinked from (if any). 705 706=cut 707 708sub unlink_from_mother { 709 my $node = $_[0]; 710 my $mother = $node->{'mother'}; 711 $mother->remove_daughters($node) if defined($mother) && ref($mother); 712 return $mother; 713} 714 715########################################################################### 716 717=item $mother->clear_daughters 718 719This unlinks all $mother's daughters. 720Returns the the list of what used to be $mother's daughters. 721 722Not to be confused with $mother->remove_daughters( LIST ). 723 724=cut 725 726sub clear_daughters { # write-only method 727 my($mother) = $_[0]; 728 my @daughters = @{$mother->{'daughters'}}; 729 730 @{$mother->{'daughters'}} = (); 731 foreach my $one (@daughters) { 732 next unless UNIVERSAL::can($one, 'is_node'); # sanity check 733 $one->{'mother'} = undef; 734 } 735 # Another, simpler, way to do it: 736 # $mother->remove_daughters($mother->daughters); 737 738 return @daughters; # NEW 739} 740#-------------------------------------------------------------------------- 741 742=item $mother->set_daughters( LIST ) 743 744This unlinks all $mother's daughters, and replaces them with the 745daughters in LIST. 746 747Currently implemented as just $mother->clear_daughters followed by 748$mother->add_daughters( LIST ). 749 750=cut 751 752sub set_daughters { # write-only method 753 my($mother, @them) = @_; 754 $mother->clear_daughters; 755 $mother->add_daughters(@them) if @them; 756 # yup, it's that simple 757} 758 759#-------------------------------------------------------------------------- 760 761=item $node->replace_with( LIST ) 762 763This replaces $node in its mother's daughter list, by unlinking $node 764and replacing it with the items in LIST. This returns a list consisting 765of $node followed by LIST, i.e., the nodes that replaced it. 766 767LIST can include $node itself (presumably at most once). LIST can 768also be empty-list. However, if any items in LIST are sisters to 769$node, they are ignored, and are not in the copy of LIST passed as the 770return value. 771 772As you might expect for any linking operation, the items in LIST 773cannot be $node's mother, or any ancestor to it; and items in LIST are, 774of course, unlinked from their mothers (if they have any) as they're 775linked to $node's mother. 776 777(In the special (and bizarre) case where $node is root, this simply calls 778$this->unlink_from_mother on all the items in LIST, making them roots of 779their own trees.) 780 781Note that the daughter-list of $node is not necessarily affected; nor 782are the daughter-lists of the items in LIST. I mention this in case you 783think replace_with switches one node for another, with respect to its 784mother list B<and> its daughter list, leaving the rest of the tree 785unchanged. If that's what you want, replacing $Old with $New, then you 786want: 787 788 $New->set_daughters($Old->clear_daughters); 789 $Old->replace_with($New); 790 791(I can't say $node's and LIST-items' daughter lists are B<never> 792affected my replace_with -- they can be affected in this case: 793 794 $N1 = ($node->daughters)[0]; # first daughter of $node 795 $N2 = ($N1->daughters)[0]; # first daughter of $N1; 796 $N3 = Tree::DAG_Node->random_network; # or whatever 797 $node->replace_with($N1, $N2, $N3); 798 799As a side affect of attaching $N1 and $N2 to $node's mother, they're 800unlinked from their parents ($node, and $N1, replectively). 801But N3's daughter list is unaffected. 802 803In other words, this method does what it has to, as you'd expect it 804to. 805 806=cut 807 808sub replace_with { # write-only method 809 my($this, @replacements) = @_; 810 811 if(not( defined($this->{'mother'}) && ref($this->{'mother'}) )) { # if root 812 foreach my $replacement (@replacements) { 813 $replacement->{'mother'}->remove_daughters($replacement) 814 if $replacement->{'mother'}; 815 } 816 # make 'em roots 817 } else { # I have a mother 818 my $mother = $this->{'mother'}; 819 820 #@replacements = grep(($_ eq $this || $_->{'mother'} ne $mother), 821 # @replacements); 822 @replacements = grep { $_ eq $this 823 || not(defined($_->{'mother'}) && 824 ref($_->{'mother'}) && 825 $_->{'mother'} eq $mother 826 ) 827 } 828 @replacements; 829 # Eliminate sisters (but not self) 830 # i.e., I want myself or things NOT with the same mother as myself. 831 832 $mother->set_daughters( # old switcheroo 833 map($_ eq $this ? (@replacements) : $_ , 834 @{$mother->{'daughters'}} 835 ) 836 ); 837 # and set_daughters does all the checking and possible 838 # unlinking 839 } 840 return($this, @replacements); 841} 842 843=item $node->replace_with_daughters 844 845This replaces $node in its mother's daughter list, by unlinking $node 846and replacing it with its daughters. In other words, $node becomes 847motherless and daughterless as its daughters move up and take its place. 848This returns a list consisting of $node followed by the nodes that were 849its daughters. 850 851In the special (and bizarre) case where $node is root, this simply 852unlinks its daughters from it, making them roots of their own trees. 853 854Effectively the same as $node->replace_with($node->daughters), but more 855efficient, since less checking has to be done. (And I also think 856$node->replace_with_daughters is a more common operation in 857tree-wrangling than $node->replace_with(LIST), so deserves a named 858method of its own, but that's just me.) 859 860=cut 861 862# Note that if you radically change 'mother'/'daughters' bookkeeping, 863# you may have to change this routine, since it's one of the places 864# that directly writes to 'daughters' and 'mother'. 865 866sub replace_with_daughters { # write-only method 867 my($this) = $_[0]; # takes no params other than the self 868 my $mother = $this->{'mother'}; 869 return($this, $this->clear_daughters) 870 unless defined($mother) && ref($mother); 871 872 my @daughters = $this->clear_daughters; 873 my $sib_r = $mother->{'daughters'}; 874 @$sib_r = map($_ eq $this ? (@daughters) : $_, 875 @$sib_r # old switcheroo 876 ); 877 foreach my $daughter (@daughters) { 878 $daughter->{'mother'} = $mother; 879 } 880 return($this, @daughters); 881} 882 883#-------------------------------------------------------------------------- 884 885=item $node->add_left_sisters( LIST ) 886 887This adds the elements in LIST (in that order) as immediate left sisters of 888$node. In other words, given that B's mother's daughter-list is (A,B,C,D), 889calling B->add_left_sisters(X,Y) makes B's mother's daughter-list 890(A,X,Y,B,C,D). 891 892If LIST is empty, this is a no-op, and returns empty-list. 893 894This is basically implemented as a call to $node->replace_with(LIST, 895$node), and so all replace_with's limitations and caveats apply. 896 897The return value of $node->add_left_sisters( LIST ) is the elements of 898LIST that got added, as returned by replace_with -- minus the copies 899of $node you'd get from a straight call to $node->replace_with(LIST, 900$node). 901 902=cut 903 904sub add_left_sisters { # write-only method 905 my($this, @new) = @_; 906 return() unless @new; 907 908 @new = $this->replace_with(@new, $this); 909 shift @new; pop @new; # kill the copies of $this 910 return @new; 911} 912 913=item $node->add_left_sister( LIST ) 914 915An exact synonym for $node->add_left_sisters(LIST) 916 917=cut 918 919sub add_left_sister { # alias 920 my($it,@them) = @_; $it->add_left_sisters(@them); 921} 922 923=item $node->add_right_sisters( LIST ) 924 925Just like add_left_sisters (which see), except that the the elements 926in LIST (in that order) as immediate B<right> sisters of $node; 927 928In other words, given that B's mother's daughter-list is (A,B,C,D), 929calling B->add_right_sisters(X,Y) makes B's mother's daughter-list 930(A,B,X,Y,C,D). 931 932=cut 933 934sub add_right_sisters { # write-only method 935 my($this, @new) = @_; 936 return() unless @new; 937 @new = $this->replace_with($this, @new); 938 shift @new; shift @new; # kill the copies of $this 939 return @new; 940} 941 942=item $node->add_right_sister( LIST ) 943 944An exact synonym for $node->add_right_sisters(LIST) 945 946=cut 947 948sub add_right_sister { # alias 949 my($it,@them) = @_; $it->add_right_sisters(@them); 950} 951 952########################################################################### 953 954=back 955 956=cut 957 958########################################################################### 959########################################################################### 960 961=head1 OTHER ATTRIBUTE METHODS 962 963=over 964 965=item $node->name or $node->name(SCALAR) 966 967In the first form, returns the value of the node object's "name" 968attribute. In the second form, sets it to the value of SCALAR. 969 970=cut 971 972sub name { # read/write attribute-method. returns/expects a scalar 973 my $this = shift; 974 $this->{'name'} = $_[0] if @_; 975 return $this->{'name'}; 976} 977 978 979########################################################################### 980 981=item $node->attributes or $node->attributes(SCALAR) 982 983In the first form, returns the value of the node object's "attributes" 984attribute. In the second form, sets it to the value of SCALAR. I 985intend this to be used to store a reference to a (presumably 986anonymous) hash the user can use to store whatever attributes he 987doesn't want to have to store as object attributes. In this case, you 988needn't ever set the value of this. (_init has already initialized it 989to {}.) Instead you can just do... 990 991 $node->attributes->{'foo'} = 'bar'; 992 993...to write foo => bar. 994 995=cut 996 997sub attributes { # read/write attribute-method 998 # expects a ref, presumably a hashref 999 my $this = shift; 1000 if(@_) { 1001 Carp::carp "my parameter must be a reference" unless ref($_[0]); 1002 $this->{'attributes'} = $_[0]; 1003 } 1004 return $this->{'attributes'}; 1005} 1006 1007=item $node->attribute or $node->attribute(SCALAR) 1008 1009An exact synonym for $node->attributes or $node->attributes(SCALAR) 1010 1011=cut 1012 1013sub attribute { # alias 1014 my($it,@them) = @_; $it->attributes(@them); 1015} 1016 1017########################################################################### 1018# Secret Stuff. 1019 1020sub no_cyclicity { # croak iff I'm in a CYCLIC class. 1021 my($it) = $_[0]; 1022 # If, God forbid, I use this to make a cyclic class, then I'd 1023 # expand the functionality of this routine to actually look for 1024 # cyclicity. Or something like that. Maybe. 1025 1026 $it->cyclicity_fault("You can't do that in a cyclic class!") 1027 if $it->cyclicity_allowed; 1028 return; 1029} 1030 1031sub cyclicity_fault { 1032 my($it, $bitch) = @_[0,1]; 1033 Carp::croak "Cyclicity fault: $bitch"; # never return 1034} 1035 1036sub cyclicity_allowed { 1037 return 0; 1038} 1039 1040########################################################################### 1041# More secret stuff. Currently unused. 1042 1043sub inaugurate_root { # no-op 1044 my($it, $tree) = @_[0,1]; 1045 # flag this node as being the root of the tree $tree. 1046 return; 1047} 1048 1049sub decommission_root { # no-op 1050 # flag this node as no longer being the root of the tree $tree. 1051 return; 1052} 1053 1054########################################################################### 1055########################################################################### 1056 1057=back 1058 1059=head1 OTHER METHODS TO DO WITH RELATIONSHIPS 1060 1061=over 1062 1063=item $node->is_node 1064 1065This always returns true. More pertinently, $object->can('is_node') 1066is true (regardless of what C<is_node> would do if called) for objects 1067belonging to this class or for any class derived from it. 1068 1069=cut 1070 1071sub is_node { return 1; } # always true. 1072# NEVER override this with anything that returns false in the belief 1073# that this'd signal "not a node class". The existence of this method 1074# is what I test for, with the various "can()" uses in this class. 1075 1076########################################################################### 1077 1078=item $node->ancestors 1079 1080Returns the list of this node's ancestors, starting with its mother, 1081then grandmother, and ending at the root. It does this by simply 1082following the 'mother' attributes up as far as it can. So if $item IS 1083the root, this returns an empty list. 1084 1085Consider that scalar($node->ancestors) returns the ply of this node 1086within the tree -- 2 for a granddaughter of the root, etc., and 0 for 1087root itself. 1088 1089=cut 1090 1091sub ancestors { 1092 my $this = shift; 1093 my $mama = $this->{'mother'}; # initial condition 1094 return () unless ref($mama); # I must be root! 1095 1096 # $this->no_cyclicity; # avoid infinite loops 1097 1098 # Could be defined recursively, as: 1099 # if(ref($mama = $this->{'mother'})){ 1100 # return($mama, $mama->ancestors); 1101 # } else { 1102 # return (); 1103 # } 1104 # But I didn't think of that until I coded the stuff below, which is 1105 # faster. 1106 1107 my @ancestors = ( $mama ); # start off with my mama 1108 while(defined( $mama = $mama->{'mother'} ) && ref($mama)) { 1109 # Walk up the tree 1110 push(@ancestors, $mama); 1111 # This turns into an infinite loop if someone gets stupid 1112 # and makes this tree cyclic! Don't do it! 1113 } 1114 return @ancestors; 1115} 1116 1117########################################################################### 1118 1119=item $node->root 1120 1121Returns the root of whatever tree $node is a member of. If $node is 1122the root, then the result is $node itself. 1123 1124=cut 1125 1126sub root { 1127 my $it = $_[0]; 1128 my @ancestors = ($it, $it->ancestors); 1129 return $ancestors[-1]; 1130} 1131 1132########################################################################### 1133 1134=item $node->is_daughter_of($node2) 1135 1136Returns true iff $node is a daughter of $node2. 1137Currently implemented as just a test of ($it->mother eq $node2). 1138 1139=cut 1140 1141sub is_daughter_of { 1142 my($it,$mama) = @_[0,1]; 1143 return $it->{'mother'} eq $mama; 1144} 1145 1146########################################################################### 1147 1148=item $node->self_and_descendants 1149 1150Returns a list consisting of itself (as element 0) and all the 1151descendants of $node. Returns just itself if $node is a 1152terminal_node. 1153 1154(Note that it's spelled "descendants", not "descendents".) 1155 1156=cut 1157 1158sub self_and_descendants { 1159 # read-only method: return a list of myself and any/all descendants 1160 my $node = shift; 1161 my @List = (); 1162 # $node->no_cyclicity; 1163 $node->walk_down({ 'callback' => sub { push @List, $_[0]; return 1;}}); 1164 Carp::croak "Spork Error 919: \@List has no contents!?!?" unless @List; 1165 # impossible 1166 return @List; 1167} 1168 1169########################################################################### 1170 1171=item $node->descendants 1172 1173Returns a list consisting of all the descendants of $node. Returns 1174empty-list if $node is a terminal_node. 1175 1176(Note that it's spelled "descendants", not "descendents".) 1177 1178=cut 1179 1180sub descendants { 1181 # read-only method: return a list of my descendants 1182 my $node = shift; 1183 my @list = $node->self_and_descendants; 1184 shift @list; # lose myself. 1185 return @list; 1186} 1187 1188########################################################################### 1189 1190=item $node->leaves_under 1191 1192Returns a list (going left-to-right) of all the leaf nodes under 1193$node. ("Leaf nodes" are also called "terminal nodes" -- i.e., nodes 1194that have no daughters.) Returns $node in the degenerate case of 1195$node being a leaf itself. 1196 1197=cut 1198 1199sub leaves_under { 1200 # read-only method: return a list of all leaves under myself. 1201 # Returns myself in the degenerate case of being a leaf myself. 1202 my $node = shift; 1203 my @List = (); 1204 # $node->no_cyclicity; 1205 $node->walk_down({ 'callback' => 1206 sub { 1207 my $node = $_[0]; 1208 my @daughters = @{$node->{'daughters'}}; 1209 push(@List, $node) unless @daughters; 1210 return 1; 1211 } 1212 }); 1213 Carp::croak "Spork Error 861: \@List has no contents!?!?" unless @List; 1214 # impossible 1215 return @List; 1216} 1217 1218########################################################################### 1219 1220=item $node->depth_under 1221 1222Returns an integer representing the number of branches between this 1223$node and the most distant leaf under it. (In other words, this 1224returns the ply of subtree starting of $node. Consider 1225scalar($it->ancestors) if you want the ply of a node within the whole 1226tree.) 1227 1228=cut 1229 1230sub depth_under { 1231 my $node = shift; 1232 my $max_depth = 0; 1233 $node->walk_down({ 1234 '_depth' => 0, 1235 'callback' => sub { 1236 my $depth = $_[1]->{'_depth'}; 1237 $max_depth = $depth if $depth > $max_depth; 1238 return 1; 1239 }, 1240 }); 1241 return $max_depth; 1242} 1243 1244########################################################################### 1245 1246=item $node->generation 1247 1248Returns a list of all nodes (going left-to-right) that are in $node's 1249generation -- i.e., that are the some number of nodes down from 1250the root. $root->generation is just $root. 1251 1252Of course, $node is always in its own generation. 1253 1254=item $node->generation_under(NODE2) 1255 1256Like $node->generation, but returns only the nodes in $node's generation 1257that are also descendants of NODE2 -- in other words, 1258 1259 @us = $node->generation_under( $node->mother->mother ); 1260 1261is all $node's first cousins (to borrow yet more kinship terminology) -- 1262assuming $node does indeed have a grandmother. Actually "cousins" isn't 1263quite an apt word, because C<@us> ends up including $node's siblings and 1264$node. 1265 1266Actually, C<generation_under> is just an alias to C<generation>, but I 1267figure that this: 1268 1269 @us = $node->generation_under($way_upline); 1270 1271is a bit more readable than this: 1272 1273 @us = $node->generation($way_upline); 1274 1275But it's up to you. 1276 1277$node->generation_under($node) returns just $node. 1278 1279If you call $node->generation_under($node) but NODE2 is not $node or an 1280ancestor of $node, it behaves as if you called just $node->generation(). 1281 1282=cut 1283 1284sub generation { 1285 my($node, $limit) = @_[0,1]; 1286 # $node->no_cyclicity; 1287 return $node 1288 if $node eq $limit || not( 1289 defined($node->{'mother'}) && 1290 ref($node->{'mother'}) 1291 ); # bailout 1292 1293 return map(@{$_->{'daughters'}}, $node->{'mother'}->generation($limit)); 1294 # recurse! 1295 # Yup, my generation is just all the daughters of my mom's generation. 1296} 1297 1298sub generation_under { 1299 my($node, @rest) = @_; 1300 return $node->generation(@rest); 1301} 1302 1303########################################################################### 1304 1305=item $node->self_and_sisters 1306 1307Returns a list of all nodes (going left-to-right) that have the same 1308mother as $node -- including $node itself. This is just like 1309$node->mother->daughters, except that that fails where $node is root, 1310whereas $root->self_and_siblings, as a special case, returns $root. 1311 1312(Contrary to how you may interpret how this method is named, "self" is 1313not (necessarily) the first element of what's returned.) 1314 1315=cut 1316 1317sub self_and_sisters { 1318 my $node = $_[0]; 1319 my $mother = $node->{'mother'}; 1320 return $node unless defined($mother) && ref($mother); # special case 1321 return @{$node->{'mother'}->{'daughters'}}; 1322} 1323 1324########################################################################### 1325 1326=item $node->sisters 1327 1328Returns a list of all nodes (going left-to-right) that have the same 1329mother as $node -- B<not including> $node itself. If $node is root, 1330this returns empty-list. 1331 1332=cut 1333 1334sub sisters { 1335 my $node = $_[0]; 1336 my $mother = $node->{'mother'}; 1337 return() unless $mother; # special case 1338 return grep($_ ne $node, 1339 @{$node->{'mother'}->{'daughters'}} 1340 ); 1341} 1342 1343########################################################################### 1344 1345=item $node->left_sister 1346 1347Returns the node that's the immediate left sister of $node. If $node 1348is the leftmost (or only) daughter of its mother (or has no mother), 1349then this returns undef. 1350 1351(See also $node->add_left_sisters(LIST).) 1352 1353=cut 1354 1355sub left_sister { 1356 my $it = $_[0]; 1357 my $mother = $it->{'mother'}; 1358 return undef unless $mother; 1359 my @sisters = @{$mother->{'daughters'}}; 1360 1361 return undef if @sisters == 1; # I'm an only daughter 1362 1363 my $left = undef; 1364 foreach my $one (@sisters) { 1365 return $left if $one eq $it; 1366 $left = $one; 1367 } 1368 die "SPORK ERROR 9757: I'm not in my mother's daughter list!?!?"; 1369} 1370 1371 1372=item $node->left_sisters 1373 1374Returns a list of nodes that're sisters to the left of $node. If 1375$node is the leftmost (or only) daughter of its mother (or has no 1376mother), then this returns an empty list. 1377 1378(See also $node->add_left_sisters(LIST).) 1379 1380=cut 1381 1382sub left_sisters { 1383 my $it = $_[0]; 1384 my $mother = $it->{'mother'}; 1385 return() unless $mother; 1386 my @sisters = @{$mother->{'daughters'}}; 1387 return() if @sisters == 1; # I'm an only daughter 1388 1389 my @out = (); 1390 foreach my $one (@sisters) { 1391 return @out if $one eq $it; 1392 push @out, $one; 1393 } 1394 die "SPORK ERROR 9767: I'm not in my mother's daughter list!?!?"; 1395} 1396 1397=item $node->right_sister 1398 1399Returns the node that's the immediate right sister of $node. If $node 1400is the rightmost (or only) daughter of its mother (or has no mother), 1401then this returns undef. 1402 1403(See also $node->add_right_sisters(LIST).) 1404 1405=cut 1406 1407sub right_sister { 1408 my $it = $_[0]; 1409 my $mother = $it->{'mother'}; 1410 return undef unless $mother; 1411 my @sisters = @{$mother->{'daughters'}}; 1412 return undef if @sisters == 1; # I'm an only daughter 1413 1414 my $seen = 0; 1415 foreach my $one (@sisters) { 1416 return $one if $seen; 1417 $seen = 1 if $one eq $it; 1418 } 1419 die "SPORK ERROR 9777: I'm not in my mother's daughter list!?!?" 1420 unless $seen; 1421 return undef; 1422} 1423 1424=item $node->right_sisters 1425 1426Returns a list of nodes that're sisters to the right of $node. If 1427$node is the rightmost (or only) daughter of its mother (or has no 1428mother), then this returns an empty list. 1429 1430(See also $node->add_right_sisters(LIST).) 1431 1432=cut 1433 1434sub right_sisters { 1435 my $it = $_[0]; 1436 my $mother = $it->{'mother'}; 1437 return() unless $mother; 1438 my @sisters = @{$mother->{'daughters'}}; 1439 return() if @sisters == 1; # I'm an only daughter 1440 1441 my @out; 1442 my $seen = 0; 1443 foreach my $one (@sisters) { 1444 push @out, $one if $seen; 1445 $seen = 1 if $one eq $it; 1446 } 1447 die "SPORK ERROR 9787: I'm not in my mother's daughter list!?!?" 1448 unless $seen; 1449 return @out; 1450} 1451 1452########################################################################### 1453 1454=item $node->my_daughter_index 1455 1456Returns what index this daughter is, in its mother's C<daughter> list. 1457In other words, if $node is ($node->mother->daughters)[3], then 1458$node->my_daughter_index returns 3. 1459 1460As a special case, returns 0 if $node has no mother. 1461 1462=cut 1463 1464sub my_daughter_index { 1465 # returns what number is my index in my mother's daughter list 1466 # special case: 0 for root. 1467 my $node = $_[0]; 1468 my $ord = -1; 1469 my $mother = $node->{'mother'}; 1470 1471 return 0 unless $mother; 1472 my @sisters = @{$mother->{'daughters'}}; 1473 1474 die "SPORK ERROR 6512: My mother has no kids!!!" unless @sisters; 1475 1476 Find_Self: 1477 for(my $i = 0; $i < @sisters; $i++) { 1478 if($sisters[$i] eq $node) { 1479 $ord = $i; 1480 last Find_Self; 1481 } 1482 } 1483 die "SPORK ERROR 2837: I'm not a daughter of my mother?!?!" if $ord == -1; 1484 return $ord; 1485} 1486 1487########################################################################### 1488 1489=item $node->address or $anynode->address(ADDRESS) 1490 1491With the first syntax, returns the address of $node within its tree, 1492based on its position within the tree. An address is formed by noting 1493the path between the root and $node, and concatenating the 1494daughter-indices of the nodes this passes thru (starting with 0 for 1495the root, and ending with $node). 1496 1497For example, if to get from node ROOT to node $node, you pass thru 1498ROOT, A, B, and $node, then the address is determined as: 1499 1500* ROOT's my_daughter_index is 0. 1501 1502* A's my_daughter_index is, suppose, 2. (A is index 2 in ROOT's 1503daughter list.) 1504 1505* B's my_daughter_index is, suppose, 0. (B is index 0 in A's 1506daughter list.) 1507 1508* $node's my_daughter_index is, suppose, 4. ($node is index 4 in 1509B's daughter list.) 1510 1511The address of the above-described $node is, therefore, "0:2:0:4". 1512 1513(As a somewhat special case, the address of the root is always "0"; 1514and since addresses start from the root, all addresses start with a 1515"0".) 1516 1517The second syntax, where you provide an address, starts from the root 1518of the tree $anynode belongs to, and returns the node corresponding to 1519that address. Returns undef if no node corresponds to that address. 1520Note that this routine may be somewhat liberal in its interpretation 1521of what can constitute an address; i.e., it accepts "0.2.0.4", besides 1522"0:2:0:4". 1523 1524Also note that the address of a node in a tree is meaningful only in 1525that tree as currently structured. 1526 1527(Consider how ($address1 cmp $address2) may be magically meaningful 1528to you, if you mant to figure out what nodes are to the right of what 1529other nodes.) 1530 1531=cut 1532 1533sub address { 1534 my($it, $address) = @_[0,1]; 1535 if(defined($address) && length($address)) { # given the address, return the node. 1536 # invalid addresses return undef 1537 my $root = $it->root; 1538 my @parts = map {$_ + 0} 1539 $address =~ m/(\d+)/g; # generous! 1540 Carp::croak "Address \"$address\" is an ill-formed address" unless @parts; 1541 Carp::croak "Address \"$address\" must start with '0'" unless shift(@parts) == 0; 1542 1543 my $current_node = $root; 1544 while(@parts) { # no-op for root 1545 my $ord = shift @parts; 1546 my @daughters = @{$current_node->{'daughters'}}; 1547 1548 if($#daughters < $ord) { # illegal address 1549 print "* $address has an out-of-range index ($ord)!" if $Debug; 1550 return undef; 1551 } 1552 $current_node = $daughters[$ord]; 1553 unless(ref($current_node)) { 1554 print "* $address points to or thru a non-node!" if $Debug; 1555 return undef; 1556 } 1557 } 1558 return $current_node; 1559 1560 } else { # given the node, return the address 1561 my @parts = (); 1562 my $current_node = $it; 1563 my $mother; 1564 1565 while(defined( $mother = $current_node->{'mother'} ) && ref($mother)) { 1566 unshift @parts, $current_node->my_daughter_index; 1567 $current_node = $mother; 1568 } 1569 return join(':', 0, @parts); 1570 } 1571} 1572 1573########################################################################### 1574 1575=item $node->common(LIST) 1576 1577Returns the lowest node in the tree that is ancestor-or-self to the 1578nodes $node and LIST. 1579 1580If the nodes are far enough apart in the tree, the answer is just the 1581root. 1582 1583If the nodes aren't all in the same tree, the answer is undef. 1584 1585As a degenerate case, if LIST is empty, returns $node. 1586 1587=cut 1588 1589sub common { # Return the lowest node common to all these nodes... 1590 # Called as $it->common($other) or $it->common(@others) 1591 my @ones = @_; # all nodes I was given 1592 my($first, @others) = @_; 1593 1594 return $first unless @others; # degenerate case 1595 1596 my %ones; 1597 @ones{ @ones } = undef; 1598 1599 foreach my $node (@others) { 1600 Carp::croak "TILT: node \"$node\" is not a node" 1601 unless UNIVERSAL::can($node, 'is_node'); 1602 my %first_lineage; 1603 @first_lineage{$first, $first->ancestors} = undef; 1604 my $higher = undef; # the common of $first and $node 1605 my @my_lineage = $node->ancestors; 1606 1607 Find_Common: 1608 while(@my_lineage) { 1609 if(exists $first_lineage{$my_lineage[0]}) { 1610 $higher = $my_lineage[0]; 1611 last Find_Common; 1612 } 1613 shift @my_lineage; 1614 } 1615 return undef unless $higher; 1616 $first = $higher; 1617 } 1618 return $first; 1619} 1620 1621 1622########################################################################### 1623 1624=item $node->common_ancestor(LIST) 1625 1626Returns the lowest node that is ancestor to all the nodes given (in 1627nodes $node and LIST). In other words, it answers the question: "What 1628node in the tree, as low as possible, is ancestor to the nodes given 1629($node and LIST)?" 1630 1631If the nodes are far enough apart, the answer is just the root -- 1632except if any of the nodes are the root itself, in which case the 1633answer is undef (since the root has no ancestor). 1634 1635If the nodes aren't all in the same tree, the answer is undef. 1636 1637As a degenerate case, if LIST is empty, returns $node's mother; 1638that'll be undef if $node is root. 1639 1640=cut 1641 1642sub common_ancestor { 1643 my @ones = @_; # all nodes I was given 1644 my($first, @others) = @_; 1645 1646 return $first->{'mother'} unless @others; 1647 # which may be undef if $first is the root! 1648 1649 my %ones; 1650 @ones{ @ones } = undef; # my arguments 1651 1652 my $common = $first->common(@others); 1653 if(exists($ones{$common})) { # if the common is one of my nodes... 1654 return $common->{'mother'}; 1655 # and this might be undef, if $common is root! 1656 } else { 1657 return $common; 1658 # which might be null if that's all common came up with 1659 } 1660} 1661 1662########################################################################### 1663########################################################################### 1664 1665=back 1666 1667=head1 YET MORE METHODS 1668 1669=over 1670 1671=item $node->walk_down({ callback => \&foo, callbackback => \&foo, ... }) 1672 1673Performs a depth-first traversal of the structure at and under $node. 1674What it does at each node depends on the value of the options hashref, 1675which you must provide. There are three options, "callback" and 1676"callbackback" (at least one of which must be defined, as a sub 1677reference), and "_depth". This is what C<walk_down> does, in 1678pseudocode form: 1679 1680* Start at the $node given. 1681 1682* If there's a C<callback>, call it with $node as the first argument, 1683and the options hashref as the second argument (which contains the 1684potentially useful C<_depth>, remember). This function must return 1685true or false -- if false, it will block the next step: 1686 1687* If $node has any daughter nodes, increment C<_depth>, and call 1688$daughter->walk_down(options_hashref) for each daughter (in order, of 1689course), where options_hashref is the same hashref it was called with. 1690When this returns, decrements C<_depth>. 1691 1692* If there's a C<callbackback>, call just it as with C<callback> (but 1693tossing out the return value). Note that C<callback> returning false 1694blocks traversal below $node, but doesn't block calling callbackback 1695for $node. (Incidentally, in the unlikely case that $node has stopped 1696being a node object, C<callbackback> won't get called.) 1697 1698* Return. 1699 1700$node->walk_down is the way to recursively do things to a tree (if you 1701start at the root) or part of a tree; if what you're doing is best done 1702via pre-pre order traversal, use C<callback>; if what you're doing is 1703best done with post-order traversal, use C<callbackback>. 1704C<walk_down> is even the basis for plenty of the methods in this 1705class. See the source code for examples both simple and horrific. 1706 1707Note that if you don't specify C<_depth>, it effectively defaults to 17080. You should set it to scalar($node->ancestors) if you want 1709C<_depth> to reflect the true depth-in-the-tree for the nodes called, 1710instead of just the depth below $node. (If $node is the root, there's 1711difference, of course.) 1712 1713And B<by the way>, it's a bad idea to modify the tree from the callback. 1714Unpredictable things may happen. I instead suggest having your callback 1715add to a stack of things that need changing, and then, once C<walk_down> 1716is all finished, changing those nodes from that stack. 1717 1718Note that the existence of C<walk_down> doesn't mean you can't write 1719you own special-use traversers. 1720 1721=cut 1722 1723sub walk_down { 1724 my($this, $o) = @_[0,1]; 1725 1726 # All the can()s are in case an object changes class while I'm 1727 # looking at it. 1728 1729 Carp::croak "I need options!" unless ref($o); 1730 Carp::croak "I need a callback or a callbackback" unless 1731 ( ref($o->{'callback'}) || ref($o->{'callbackback'}) ); 1732 1733 # $this->no_cyclicity; 1734 my $callback = ref($o->{'callback'}) ? $o->{'callback'} : undef; 1735 my $callbackback = ref($o->{'callbackback'}) ? $o->{'callbackback'} : undef; 1736 my $callback_status = 1; 1737 1738 print "Callback: $callback Callbackback: $callbackback\n" if $Debug; 1739 1740 printf "* Entering %s\n", ($this->name || $this) if $Debug; 1741 $callback_status = &{ $callback }( $this, $o ) if $callback; 1742 1743 if($callback_status) { 1744 # Keep recursing unless callback returned false... and if there's 1745 # anything to recurse into, of course. 1746 my @daughters = UNIVERSAL::can($this, 'is_node') ? @{$this->{'daughters'}} : (); 1747 if(@daughters) { 1748 $o->{'_depth'} += 1; 1749 #print "Depth " , $o->{'_depth'}, "\n"; 1750 foreach my $one (@daughters) { 1751 $one->walk_down($o) if UNIVERSAL::can($one, 'is_node'); 1752 # and if it can do "is_node", it should provide a walk_down! 1753 } 1754 $o->{'_depth'} -= 1; 1755 } 1756 } else { 1757 printf "* Recursing below %s pruned\n", ($this->name || $this) if $Debug; 1758 } 1759 1760 # Note that $callback_status doesn't block callbackback from being called 1761 if($callbackback){ 1762 if(UNIVERSAL::can($this, 'is_node')) { # if it's still a node! 1763 print "* Calling callbackback\n" if $Debug; 1764 scalar( &{ $callbackback }( $this, $o ) ); 1765 # scalar to give it the same context as callback 1766 } else { 1767 print "* Can't call callbackback -- $this isn't a node anymore\n" 1768 if $Debug; 1769 } 1770 } 1771 if($Debug) { 1772 if(UNIVERSAL::can($this, 'is_node')) { # if it's still a node! 1773 printf "* Leaving %s\n", ($this->name || $this) 1774 } else { 1775 print "* Leaving [no longer a node]\n"; 1776 } 1777 } 1778 return; 1779} 1780 1781########################################################################### 1782 1783=item @lines = $node->dump_names({ ...options... }); 1784 1785Dumps, as an indented list, the names of the nodes starting at $node, 1786and continuing under it. Options are: 1787 1788* _depth -- A nonnegative number. Indicating the depth to consider 1789$node as being at (and so the generation under that is that plus one, 1790etc.). Defaults to 0. You may choose to use set _depth => 1791scalar($node->ancestors). 1792 1793* tick -- a string to preface each entry with, between the 1794indenting-spacing and the node's name. Defaults to empty-string. You 1795may prefer "*" or "-> " or someting. 1796 1797* indent -- the string used to indent with. Defaults to " " (two 1798spaces). Another sane value might be ". " (period, space). Setting it 1799to empty-string suppresses indenting. 1800 1801The dump is not printed, but is returned as a list, where each 1802item is a line, with a "\n" at the end. 1803 1804=cut 1805 1806sub dump_names { 1807 my($it, $o) = @_[0,1]; 1808 $o = {} unless ref $o; 1809 my @out = (); 1810 $o->{'_depth'} ||= 0; 1811 $o->{'indent'} ||= ' '; 1812 $o->{'tick'} ||= ''; 1813 1814 $o->{'callback'} = sub { 1815 my($this, $o) = @_[0,1]; 1816 push(@out, 1817 join('', 1818 $o->{'indent'} x $o->{'_depth'}, 1819 $o->{'tick'}, 1820 &Tree::DAG_Node::_dump_quote($this->name || $this), 1821 "\n" 1822 ) 1823 ); 1824 return 1; 1825 } 1826 ; 1827 $it->walk_down($o); 1828 return @out; 1829} 1830 1831########################################################################### 1832########################################################################### 1833 1834=item the constructor CLASS->random_network({...options...}) 1835 1836=item the method $node->random_network({...options...}) 1837 1838In the first case, constructs a randomly arranged network under a new 1839node, and returns the root node of that tree. In the latter case, 1840constructs the network under $node. 1841 1842Currently, this is implemented a bit half-heartedly, and 1843half-wittedly. I basically needed to make up random-looking networks 1844to stress-test the various tree-dumper methods, and so wrote this. If 1845you actually want to rely on this for any application more 1846serious than that, I suggest examining the source code and seeing if 1847this does really what you need (say, in reliability of randomness); 1848and feel totally free to suggest changes to me (especially in the form 1849of "I rewrote C<random_network>, here's the code...") 1850 1851It takes four options: 1852 1853* max_node_count -- maximum number of nodes this tree will be allowed 1854to have (counting the root). Defaults to 25. 1855 1856* min_depth -- minimum depth for the tree. Defaults to 2. Leaves can 1857be generated only after this depth is reached, so the tree will be at 1858least this deep -- unless max_node_count is hit first. 1859 1860* max_depth -- maximum depth for the tree. Defaults to 3 plus 1861min_depth. The tree will not be deeper than this. 1862 1863* max_children -- maximum number of children any mother in the tree 1864can have. Defaults to 4. 1865 1866=cut 1867 1868sub random_network { # constructor or method. 1869 my $class = $_[0]; 1870 my $o = ref($_[1]) ? $_[1] : {}; 1871 my $am_cons = 0; 1872 my $root; 1873 1874 if(ref($class)){ # I'm a method. 1875 $root = $_[0]; # build under the given node, from same class. 1876 $class = ref $class; 1877 $am_cons = 0; 1878 } else { # I'm a constructor 1879 $root = $class->new; # build under a new node, with class named. 1880 $root->name("Root"); 1881 $am_cons = 1; 1882 } 1883 1884 my $min_depth = $o->{'min_depth'} || 2; 1885 my $max_depth = $o->{'max_depth'} || ($min_depth + 3); 1886 my $max_children = $o->{'max_children'} || 4; 1887 my $max_node_count = $o->{'max_node_count'} || 25; 1888 1889 Carp::croak "max_children has to be positive" if int($max_children) < 1; 1890 1891 my @mothers = ( $root ); 1892 my @children = ( ); 1893 my $node_count = 1; # the root 1894 1895 Gen: 1896 foreach my $depth (1 .. $max_depth) { 1897 last if $node_count > $max_node_count; 1898 Mother: 1899 foreach my $mother (@mothers) { 1900 last Gen if $node_count > $max_node_count; 1901 my $children_number; 1902 if($depth <= $min_depth) { 1903 until( $children_number = int(rand(1 + $max_children)) ) {} 1904 } else { 1905 $children_number = int(rand($max_children)); 1906 } 1907 Beget: 1908 foreach (1 .. $children_number) { 1909 last Gen if $node_count > $max_node_count; 1910 my $node = $mother->new_daughter; 1911 $node->name("Node$node_count"); 1912 ++$node_count; 1913 push(@children, $node); 1914 } 1915 } 1916 @mothers = @children; 1917 @children = (); 1918 last unless @mothers; 1919 } 1920 1921 return $root; 1922} 1923 1924=item the constructor CLASS->lol_to_tree($lol); 1925 1926Converts something like bracket-notation for "Chomsky trees" (or 1927rather, the closest you can come with Perl 1928list-of-lists(-of-lists(-of-lists))) into a tree structure. Returns 1929the root of the tree converted. 1930 1931The conversion rules are that: 1) if the last (possibly the only) item 1932in a given list is a scalar, then that is used as the "name" attribute 1933for the node based on this list. 2) All other items in the list 1934represent daughter nodes of the current node -- recursively so, if 1935they are list references; otherwise, (non-terminal) scalars are 1936considered to denote nodes with that name. So ['Foo', 'Bar', 'N'] is 1937an alternate way to represent [['Foo'], ['Bar'], 'N']. 1938 1939An example will illustrate: 1940 1941 use Tree::DAG_Node; 1942 $lol = 1943 [ 1944 [ 1945 [ [ 'Det:The' ], 1946 [ [ 'dog' ], 'N'], 'NP'], 1947 [ '/with rabies\\', 'PP'], 1948 'NP' 1949 ], 1950 [ 'died', 'VP'], 1951 'S' 1952 ]; 1953 $tree = Tree::DAG_Node->lol_to_tree($lol); 1954 $diagram = $tree->draw_ascii_tree; 1955 print map "$_\n", @$diagram; 1956 1957...returns this tree: 1958 1959 | 1960 <S> 1961 | 1962 /------------------\ 1963 | | 1964 <NP> <VP> 1965 | | 1966 /---------------\ <died> 1967 | | 1968 <NP> <PP> 1969 | | 1970 /-------\ </with rabies\> 1971 | | 1972 <Det:The> <N> 1973 | 1974 <dog> 1975 1976By the way (and this rather follows from the above rules), when 1977denoting a LoL tree consisting of just one node, this: 1978 1979 $tree = Tree::DAG_Node->lol_to_tree( 'Lonely' ); 1980 1981is okay, although it'd probably occur to you to denote it only as: 1982 1983 $tree = Tree::DAG_Node->lol_to_tree( ['Lonely'] ); 1984 1985which is of course fine, too. 1986 1987=cut 1988 1989sub lol_to_tree { 1990 my($class, $lol, $seen_r) = @_[0,1,2]; 1991 $seen_r = {} unless ref($seen_r) eq 'HASH'; 1992 return if ref($lol) && $seen_r->{$lol}++; # catch circularity 1993 1994 $class = ref($class) || $class; 1995 my $node = $class->new(); 1996 1997 unless(ref($lol) eq 'ARRAY') { # It's a terminal node. 1998 $node->name($lol) if defined $lol; 1999 return $node; 2000 } 2001 return $node unless @$lol; # It's a terminal node, oddly represented 2002 2003 # It's a non-terminal node. 2004 2005 my @options = @$lol; 2006 unless(ref($options[-1]) eq 'ARRAY') { 2007 # This is what separates this method from simple_lol_to_tree 2008 $node->name(pop(@options)); 2009 } 2010 2011 foreach my $d (@options) { # Scan daughters (whether scalars or listrefs) 2012 $node->add_daughter( $class->lol_to_tree($d, $seen_r) ); # recurse! 2013 } 2014 2015 return $node; 2016} 2017 2018#-------------------------------------------------------------------------- 2019 2020=item $node->tree_to_lol_notation({...options...}) 2021 2022Dumps a tree (starting at $node) as the sort of LoL-like bracket 2023notation you see in the above example code. Returns just one big 2024block of text. The only option is "multiline" -- if true, it dumps 2025the text as the sort of indented structure as seen above; if false 2026(and it defaults to false), dumps it all on one line (with no 2027indenting, of course). 2028 2029For example, starting with the tree from the above example, 2030this: 2031 2032 print $tree->tree_to_lol_notation, "\n"; 2033 2034prints the following (which I've broken over two lines for sake of 2035printablitity of documentation): 2036 2037 [[[['Det:The'], [['dog'], 'N'], 'NP'], [["/with rabies\x5c"], 2038 'PP'], 'NP'], [['died'], 'VP'], 'S'], 2039 2040Doing this: 2041 2042 print $tree->tree_to_lol_notation({ multiline => 1 }); 2043 2044prints the same content, just spread over many lines, and prettily 2045indented. 2046 2047=cut 2048 2049#-------------------------------------------------------------------------- 2050 2051sub tree_to_lol_notation { 2052 my $root = $_[0]; 2053 my($it, $o) = @_[0,1]; 2054 $o = {} unless ref $o; 2055 my @out = (); 2056 $o->{'_depth'} ||= 0; 2057 $o->{'multiline'} = 0 unless exists($o->{'multiline'}); 2058 2059 my $line_end; 2060 if($o->{'multiline'}) { 2061 $o->{'indent'} ||= ' '; 2062 $line_end = "\n"; 2063 } else { 2064 $o->{'indent'} ||= ''; 2065 $line_end = ''; 2066 } 2067 2068 $o->{'callback'} = sub { 2069 my($this, $o) = @_[0,1]; 2070 push(@out, 2071 $o->{'indent'} x $o->{'_depth'}, 2072 "[$line_end", 2073 ); 2074 return 1; 2075 } 2076 ; 2077 $o->{'callbackback'} = sub { 2078 my($this, $o) = @_[0,1]; 2079 my $name = $this->name; 2080 if(!defined($name)) { 2081 $name = 'undef'; 2082 } else { 2083 $name = &Tree::DAG_Node::_dump_quote($name); 2084 } 2085 push(@out, 2086 $o->{'indent'} x ($o->{'_depth'} + 1), 2087 "$name$line_end", 2088 $o->{'indent'} x $o->{'_depth'}, 2089 "], $line_end", 2090 ); 2091 return 1; 2092 } 2093 ; 2094 $it->walk_down($o); 2095 return join('', @out); 2096} 2097 2098#-------------------------------------------------------------------------- 2099 2100=item $node->tree_to_lol 2101 2102Returns that tree (starting at $node) represented as a LoL, like what 2103$lol, above, holds. (This is as opposed to C<tree_to_lol_notation>, 2104which returns the viewable code like what gets evaluated and stored in 2105$lol, above.) 2106 2107Lord only knows what you use this for -- maybe for feeding to 2108Data::Dumper, in case C<tree_to_lol_notation> doesn't do just what you 2109want? 2110 2111=cut 2112 2113sub tree_to_lol { 2114 # I haven't /rigorously/ tested this. 2115 my($it, $o) = @_[0,1]; # $o is currently unused anyway 2116 $o = {} unless ref $o; 2117 2118 my $out = []; 2119 my @lol_stack = ($out); 2120 $o->{'callback'} = sub { 2121 my($this, $o) = @_[0,1]; 2122 my $new = []; 2123 push @{$lol_stack[-1]}, $new; 2124 push(@lol_stack, $new); 2125 return 1; 2126 } 2127 ; 2128 $o->{'callbackback'} = sub { 2129 my($this, $o) = @_[0,1]; 2130 push @{$lol_stack[-1]}, $this->name; 2131 pop @lol_stack; 2132 return 1; 2133 } 2134 ; 2135 $it->walk_down($o); 2136 die "totally bizarre error 12416" unless ref($out->[0]); 2137 $out = $out->[0]; # the real root 2138 return $out; 2139} 2140 2141########################################################################### 2142 2143=item the constructor CLASS->simple_lol_to_tree($simple_lol); 2144 2145This is like lol_to_tree, except that rule 1 doesn't apply -- i.e., 2146all scalars (or really, anything not a listref) in the LoL-structure 2147end up as named terminal nodes, and only terminal nodes get names 2148(and, of course, that name comes from that scalar value). This method 2149is useful for making things like expression trees, or at least 2150starting them off. Consider that this: 2151 2152 $tree = Tree::DAG_Node->simple_lol_to_tree( 2153 [ 'foo', ['bar', ['baz'], 'quux'], 'zaz', 'pati' ] 2154 ); 2155 2156converts from something like a Lispish or Iconish tree, if you pretend 2157the brackets are parentheses. 2158 2159Note that there is a (possibly surprising) degenerate case of what I'm 2160calling a "simple-LoL", and it's like this: 2161 2162 $tree = Tree::DAG_Node->simple_lol_to_tree('Lonely'); 2163 2164This is the (only) way you can specify a tree consisting of only a 2165single node, which here gets the name 'Lonely'. 2166 2167=cut 2168 2169sub simple_lol_to_tree { 2170 my($class, $lol, $seen_r) = @_[0,1,2]; 2171 $class = ref($class) || $class; 2172 $seen_r = {} unless ref($seen_r) eq 'HASH'; 2173 return if ref($lol) && $seen_r->{$lol}++; # catch circularity 2174 2175 my $node = $class->new(); 2176 2177 unless(ref($lol) eq 'ARRAY') { # It's a terminal node. 2178 $node->name($lol) if defined $lol; 2179 return $node; 2180 } 2181 2182 # It's a non-terminal node. 2183 foreach my $d (@$lol) { # scan daughters (whether scalars or listrefs) 2184 $node->add_daughter( $class->simple_lol_to_tree($d, $seen_r) ); # recurse! 2185 } 2186 2187 return $node; 2188} 2189 2190#-------------------------------------------------------------------------- 2191 2192=item $node->tree_to_simple_lol 2193 2194Returns that tree (starting at $node) represented as a simple-LoL -- 2195i.e., one where non-terminal nodes are represented as listrefs, and 2196terminal nodes are gotten from the contents of those nodes' "name' 2197attributes. 2198 2199Note that in the case of $node being terminal, what you get back is 2200the same as $node->name. 2201 2202Compare to tree_to_simple_lol_notation. 2203 2204=cut 2205 2206sub tree_to_simple_lol { 2207 # I haven't /rigorously/ tested this. 2208 my $root = $_[0]; 2209 2210 return $root->name unless scalar($root->daughters); 2211 # special case we have to nip in the bud 2212 2213 my($it, $o) = @_[0,1]; # $o is currently unused anyway 2214 $o = {} unless ref $o; 2215 2216 my $out = []; 2217 my @lol_stack = ($out); 2218 $o->{'callback'} = sub { 2219 my($this, $o) = @_[0,1]; 2220 my $new; 2221 $new = scalar($this->daughters) ? [] : $this->name; 2222 # Terminal nodes are scalars, the rest are listrefs we'll fill in 2223 # as we recurse the tree below here. 2224 push @{$lol_stack[-1]}, $new; 2225 push(@lol_stack, $new); 2226 return 1; 2227 } 2228 ; 2229 $o->{'callbackback'} = sub { pop @lol_stack; return 1; }; 2230 $it->walk_down($o); 2231 die "totally bizarre error 12416" unless ref($out->[0]); 2232 $out = $out->[0]; # the real root 2233 return $out; 2234} 2235 2236#-------------------------------------------------------------------------- 2237 2238=item $node->tree_to_simple_lol_notation({...options...}) 2239 2240A simple-LoL version of tree_to_lol_notation (which see); takes the 2241same options. 2242 2243=cut 2244 2245sub tree_to_simple_lol_notation { 2246 my($it, $o) = @_[0,1]; 2247 $o = {} unless ref $o; 2248 my @out = (); 2249 $o->{'_depth'} ||= 0; 2250 $o->{'multiline'} = 0 unless exists($o->{'multiline'}); 2251 2252 my $line_end; 2253 if($o->{'multiline'}) { 2254 $o->{'indent'} ||= ' '; 2255 $line_end = "\n"; 2256 } else { 2257 $o->{'indent'} ||= ''; 2258 $line_end = ''; 2259 } 2260 2261 $o->{'callback'} = sub { 2262 my($this, $o) = @_[0,1]; 2263 if(scalar($this->daughters)) { # Nonterminal 2264 push(@out, 2265 $o->{'indent'} x $o->{'_depth'}, 2266 "[$line_end", 2267 ); 2268 } else { # Terminal 2269 my $name = $this->name; 2270 push @out, 2271 $o->{'indent'} x $o->{'_depth'}, 2272 defined($name) ? &Tree::DAG_Node::_dump_quote($name) : 'undef', 2273 ",$line_end"; 2274 } 2275 return 1; 2276 } 2277 ; 2278 $o->{'callbackback'} = sub { 2279 my($this, $o) = @_[0,1]; 2280 push(@out, 2281 $o->{'indent'} x $o->{'_depth'}, 2282 "], $line_end", 2283 ) if scalar($this->daughters); 2284 return 1; 2285 } 2286 ; 2287 2288 $it->walk_down($o); 2289 return join('', @out); 2290} 2291 2292########################################################################### 2293# $list_r = $root_node->draw_ascii_tree({ h_compact => 1}); 2294# print map("$_\n", @$list_r); 2295 2296=item $list_r = $node->draw_ascii_tree({ ... options ... }) 2297 2298Draws a nice ASCII-art representation of the tree structure 2299at-and-under $node, with $node at the top. Returns a reference to the 2300list of lines (with no "\n"s or anything at the end of them) that make 2301up the picture. 2302 2303Example usage: 2304 2305 print map("$_\n", @{$tree->draw_ascii_tree}); 2306 2307draw_ascii_tree takes parameters you set in the options hashref: 2308 2309* "no_name" -- if true, C<draw_ascii_tree> doesn't print the name of 2310the node; simply prints a "*". Defaults to 0 (i.e., print the node 2311name.) 2312 2313* "h_spacing" -- number 0 or greater. Sets the number of spaces 2314inserted horizontally between nodes (and groups of nodes) in a tree. 2315Defaults to 1. 2316 2317* "h_compact" -- number 0 or 1. Sets the extent to which 2318C<draw_ascii_tree> tries to save horizontal space. Defaults to 1. If 2319I think of a better scrunching algorithm, there'll be a "2" setting 2320for this. 2321 2322* "v_compact" -- number 0, 1, or 2. Sets the degree to which 2323C<draw_ascii_tree> tries to save vertical space. Defaults to 1. 2324 2325This occasionally returns trees that are a bit cock-eyed in parts; if 2326anyone can suggest a better drawing algorithm, I'd be appreciative. 2327 2328=cut 2329 2330sub draw_ascii_tree { 2331 # Make a "box" for this node and its possible daughters, recursively. 2332 2333 # The guts of this routine are horrific AND recursive! 2334 2335 # Feel free to send me better code. I worked on this until it 2336 # gave me a headache and it worked passably, and then I stopped. 2337 2338 my $it = $_[0]; 2339 my $o = ref($_[1]) ? $_[1] : {}; 2340 my(@box, @daughter_boxes, $width, @daughters); 2341 @daughters = @{$it->{'daughters'}}; 2342 2343 # $it->no_cyclicity; 2344 2345 $o->{'no_name'} = 0 unless exists $o->{'no_name'}; 2346 $o->{'h_spacing'} = 1 unless exists $o->{'h_spacing'}; 2347 $o->{'h_compact'} = 1 unless exists $o->{'h_compact'}; 2348 $o->{'v_compact'} = 1 unless exists $o->{'v_compact'}; 2349 2350 my $printable_name; 2351 if($o->{'no_name'}) { 2352 $printable_name = '*'; 2353 } else { 2354 $printable_name = $it->name || $it; 2355 $printable_name =~ tr<\cm\cj\t >< >s; 2356 $printable_name = "<$printable_name>"; 2357 } 2358 2359 if(!scalar(@daughters)) { # I am a leaf! 2360 # Now add the top parts, and return. 2361 @box = ("|", $printable_name); 2362 } else { 2363 @daughter_boxes = map { &draw_ascii_tree($_, $o) } @daughters; 2364 2365 my $max_height = 0; 2366 foreach my $box (@daughter_boxes) { 2367 my $h = @$box; 2368 $max_height = $h if $h > $max_height; 2369 } 2370 2371 @box = ('') x $max_height; # establish the list 2372 2373 foreach my $one (@daughter_boxes) { 2374 my $length = length($one->[0]); 2375 my $height = @$one; 2376 2377 #now make all the same height. 2378 my $deficit = $max_height - $height; 2379 if($deficit > 0) { 2380 push @$one, ( scalar( ' ' x $length ) ) x $deficit; 2381 $height = scalar(@$one); 2382 } 2383 2384 2385 # Now tack 'em onto @box 2386 ########################################################## 2387 # This used to be a sub of its own. Ho-hum. 2388 2389 my($b1, $b2) = (\@box, $one); 2390 my($h1, $h2) = (scalar(@$b1), scalar(@$b2)); 2391 2392 my(@diffs, $to_chop); 2393 if($o->{'h_compact'}) { # Try for h-scrunching. 2394 my @diffs; 2395 my $min_diff = length($b1->[0]); # just for starters 2396 foreach my $line (0 .. ($h1 - 1)) { 2397 my $size_l = 0; # length of terminal whitespace 2398 my $size_r = 0; # length of initial whitespace 2399 $size_l = length($1) if $b1->[$line] =~ /( +)$/s; 2400 $size_r = length($1) if $b2->[$line] =~ /^( +)/s; 2401 my $sum = $size_l + $size_r; 2402 2403 $min_diff = $sum if $sum < $min_diff; 2404 push @diffs, [$sum, $size_l, $size_r]; 2405 } 2406 $to_chop = $min_diff - $o->{'h_spacing'}; 2407 $to_chop = 0 if $to_chop < 0; 2408 } 2409 2410 if(not( $o->{'h_compact'} and $to_chop )) { 2411 # No H-scrunching needed/possible 2412 foreach my $line (0 .. ($h1 - 1)) { 2413 $b1->[ $line ] .= $b2->[ $line ] . (' ' x $o->{'h_spacing'}); 2414 } 2415 } else { 2416 # H-scrunching is called for. 2417 foreach my $line (0 .. ($h1 - 1)) { 2418 my $r = $b2->[$line]; # will be the new line 2419 my $remaining = $to_chop; 2420 if($remaining) { 2421 my($l_chop, $r_chop) = @{$diffs[$line]}[1,2]; 2422 2423 if($l_chop) { 2424 if($l_chop > $remaining) { 2425 $l_chop = $remaining; 2426 $remaining = 0; 2427 } elsif($l_chop == $remaining) { 2428 $remaining = 0; 2429 } else { # remaining > l_chop 2430 $remaining -= $l_chop; 2431 } 2432 } 2433 if($r_chop) { 2434 if($r_chop > $remaining) { 2435 $r_chop = $remaining; 2436 $remaining = 0; 2437 } elsif($r_chop == $remaining) { 2438 $remaining = 0; 2439 } else { # remaining > r_chop 2440 $remaining -= $r_chop; # should never happen! 2441 } 2442 } 2443 2444 substr($b1->[$line], -$l_chop) = '' if $l_chop; 2445 substr($r, 0, $r_chop) = '' if $r_chop; 2446 } # else no-op 2447 $b1->[ $line ] .= $r . (' ' x $o->{'h_spacing'}); 2448 } 2449 # End of H-scrunching ickyness 2450 } 2451 # End of ye big tack-on 2452 2453 } 2454 # End of the foreach daughter_box loop 2455 2456 # remove any fencepost h_spacing 2457 if($o->{'h_spacing'}) { 2458 foreach my $line (@box) { 2459 substr($line, -$o->{'h_spacing'}) = '' if length($line); 2460 } 2461 } 2462 2463 # end of catenation 2464 die "SPORK ERROR 958203: Freak!!!!!" unless @box; 2465 2466 # Now tweak the pipes 2467 my $new_pipes = $box[0]; 2468 my $pipe_count = $new_pipes =~ tr<|><+>; 2469 if($pipe_count < 2) { 2470 $new_pipes = "|"; 2471 } else { 2472 my($init_space, $end_space); 2473 2474 # Thanks to Gilles Lamiral for pointing out the need to set to '', 2475 # to avoid -w warnings about undeffiness. 2476 2477 if( $new_pipes =~ s<^( +)><>s ) { 2478 $init_space = $1; 2479 } else { 2480 $init_space = ''; 2481 } 2482 2483 if( $new_pipes =~ s<( +)$><>s ) { 2484 $end_space = $1 2485 } else { 2486 $end_space = ''; 2487 } 2488 2489 $new_pipes =~ tr< ><->; 2490 substr($new_pipes,0,1) = "/"; 2491 substr($new_pipes,-1,1) = "\\"; 2492 2493 $new_pipes = $init_space . $new_pipes . $end_space; 2494 # substr($new_pipes, int((length($new_pipes)), 1)) / 2) = "^"; # feh 2495 } 2496 2497 # Now tack on the formatting for this node. 2498 if($o->{'v_compact'} == 2) { 2499 if(@daughters == 1) { 2500 unshift @box, "|", $printable_name; 2501 } else { 2502 unshift @box, "|", $printable_name, $new_pipes; 2503 } 2504 } elsif ($o->{'v_compact'} == 1 and @daughters == 1) { 2505 unshift @box, "|", $printable_name; 2506 } else { # general case 2507 unshift @box, "|", $printable_name, $new_pipes; 2508 } 2509 } 2510 2511 # Flush the edges: 2512 my $max_width = 0; 2513 foreach my $line (@box) { 2514 my $w = length($line); 2515 $max_width = $w if $w > $max_width; 2516 } 2517 foreach my $one (@box) { 2518 my $space_to_add = $max_width - length($one); 2519 next unless $space_to_add; 2520 my $add_left = int($space_to_add / 2); 2521 my $add_right = $space_to_add - $add_left; 2522 $one = (' ' x $add_left) . $one . (' ' x $add_right); 2523 } 2524 2525 return \@box; # must not return a null list! 2526} 2527 2528########################################################################### 2529 2530=item $node->copy_tree or $node->copy_tree({...options...}) 2531 2532This returns the root of a copy of the tree that $node is a member of. 2533If you pass no options, copy_tree pretends you've passed {}. 2534 2535This method is currently implemented as just a call to 2536$this->root->copy_at_and_under({...options...}), but magic may be 2537added in the future. 2538 2539Options you specify are passed down to calls to $node->copy. 2540 2541=cut 2542 2543sub copy_tree { 2544 my($this, $o) = @_[0,1]; 2545 my $root = $this->root; 2546 $o = {} unless ref $o; 2547 2548 my $new_root = $root->copy_at_and_under($o); 2549 2550 return $new_root; 2551} 2552 2553=item $node->copy_at_and_under or $node->copy_at_and_under({...options...}) 2554 2555This returns a copy of the subtree consisting of $node and everything 2556under it. 2557 2558If you pass no options, copy_at_and_under pretends you've passed {}. 2559 2560This works by recursively building up the new tree from the leaves, 2561duplicating nodes using $orig_node->copy($options_ref) and then 2562linking them up into a new tree of the same shape. 2563 2564Options you specify are passed down to calls to $node->copy. 2565 2566=cut 2567 2568sub copy_at_and_under { 2569 my($from, $o) = @_[0,1]; 2570 $o = {} unless ref $o; 2571 my @daughters = map($_->copy_at_and_under($o), @{$from->{'daughters'}}); 2572 my $to = $from->copy($o); 2573 $to->set_daughters(@daughters) if @daughters; 2574 return $to; 2575} 2576 2577=item the constructor $node->copy or $node->copy({...options...}) 2578 2579Returns a copy of $node, B<minus> its daughter or mother attributes 2580(which are set back to default values). 2581 2582If you pass no options, C<copy> pretends you've passed {}. 2583 2584Magic happens with the 'attributes' attribute: if it's a hashref (and 2585it usually is), the new node doesn't end up with the same hashref, but 2586with ref to a hash with the content duplicated from the original's 2587hashref. If 'attributes' is not a hashref, but instead an object that 2588belongs to a class that provides a method called "copy", then that 2589method is called, and the result saved in the clone's 'attribute' 2590attribute. Both of these kinds of magic are disabled if the options 2591you pass to C<copy> (maybe via C<copy_tree>, or C<copy_at_and_under>) 2592includes (C<no_attribute_copy> => 1). 2593 2594The options hashref you pass to C<copy> (derictly or indirectly) gets 2595changed slightly after you call C<copy> -- it gets an entry called 2596"from_to" added to it. Chances are you would never know nor care, but 2597this is reserved for possible future use. See the source if you are 2598wildly curious. 2599 2600Note that if you are using $node->copy (whether directly or via 2601$node->copy_tree or $node->copy_at_or_under), and it's not properly 2602copying object attributes containing references, you probably 2603shouldn't fight it or try to fix it -- simply override copy_tree with: 2604 2605 sub copy_tree { 2606 use Storable qw(dclone); 2607 my $this = $_[0]; 2608 return dclone($this->root); 2609 # d for "deep" 2610 } 2611 2612or 2613 2614 sub copy_tree { 2615 use Data::Dumper; 2616 my $this = $_[0]; 2617 $Data::Dumper::Purity = 1; 2618 return eval(Dumper($this->root)); 2619 } 2620 2621Both of these avoid you having to reinvent the wheel. 2622 2623How to override copy_at_or_under with something that uses Storable 2624or Data::Dumper is left as an exercise to the reader. 2625 2626Consider that if in a derived class, you add attributes with really 2627bizarre contents (like a unique-for-all-time-ID), you may need to 2628override C<copy>. Consider: 2629 2630 sub copy { 2631 my($it, @etc) = @_; 2632 $it->SUPER::copy(@etc); 2633 $it->{'UID'} = &get_new_UID; 2634 } 2635 2636...or the like. See the source of Tree::DAG_Node::copy for 2637inspiration. 2638 2639=cut 2640 2641sub copy { 2642 my($from,$o) = @_[0,1]; 2643 $o = {} unless ref $o; 2644 2645 # Straight dupe, and bless into same class: 2646 my $to = bless { %$from }, ref($from); 2647 2648 # Null out linkages. 2649 $to->_init_mother; 2650 $to->_init_daughters; 2651 2652 # dupe the 'attributes' attribute: 2653 unless($o->{'no_attribute_copy'}) { 2654 my $attrib_copy = ref($to->{'attributes'}); 2655 if($attrib_copy) { 2656 if($attrib_copy eq 'HASH') { 2657 $to->{'attributes'} = { %{$to->{'attributes'}} }; 2658 # dupe the hashref 2659 } elsif ($attrib_copy = UNIVERSAL::can($to->{'attributes'}, 'copy') ) { 2660 # $attrib_copy now points to the copier method 2661 $to->{'attributes'} = &{$attrib_copy}($from); 2662 } # otherwise I don't know how to copy it; leave as is 2663 } 2664 } 2665 $o->{'from_to'}->{$from} = $to; # SECRET VOODOO 2666 # ...autovivifies an anon hashref for 'from_to' if need be 2667 # This is here in case I later want/need a table corresponding 2668 # old nodes to new. 2669 return $to; 2670} 2671 2672 2673########################################################################### 2674 2675=item $node->delete_tree 2676 2677Destroys the entire tree that $node is a member of (starting at the 2678root), by nulling out each node-object's attributes (including, most 2679importantly, its linkage attributes -- hopefully this is more than 2680sufficient to eliminate all circularity in the data structure), and 2681then moving it into the class DEADNODE. 2682 2683Use this when you're finished with the tree in question, and want to 2684free up its memory. (If you don't do this, it'll get freed up anyway 2685when your program ends.) 2686 2687If you try calling any methods on any of the node objects in the tree 2688you've destroyed, you'll get an error like: 2689 2690 Can't locate object method "leaves_under" 2691 via package "DEADNODE". 2692 2693So if you see that, that's what you've done wrong. (Actually, the 2694class DEADNODE does provide one method: a no-op method "delete_tree". 2695So if you want to delete a tree, but think you may have deleted it 2696already, it's safe to call $node->delete_tree on it (again).) 2697 2698The C<delete_tree> method is needed because Perl's garbage collector 2699would never (as currently implemented) see that it was time to 2700de-allocate the memory the tree uses -- until either you call 2701$node->delete_tree, or until the program stops (at "global 2702destruction" time, when B<everything> is unallocated). 2703 2704Incidentally, there are better ways to do garbage-collecting on a 2705tree, ways which don't require the user to explicitly call a method 2706like C<delete_tree> -- they involve dummy classes, as explained at 2707C<http://mox.perl.com/misc/circle-destroy.pod> 2708 2709However, introducing a dummy class concept into Tree::DAG_Node would 2710be rather a distraction. If you want to do this with your derived 2711classes, via a DESTROY in a dummy class (or in a tree-metainformation 2712class, maybe), then feel free to. 2713 2714The only case where I can imagine C<delete_tree> failing to totally 2715void the tree, is if you use the hashref in the "attributes" attribute 2716to store (presumably among other things) references to other nodes' 2717"attributes" hashrefs -- which 1) is maybe a bit odd, and 2) is your 2718problem, because it's your hash structure that's circular, not the 2719tree's. Anyway, consider: 2720 2721 # null out all my "attributes" hashes 2722 $anywhere->root->walk_down({ 2723 'callback' => sub { 2724 $hr = $_[0]->attributes; %$hr = (); return 1; 2725 } 2726 }); 2727 # And then: 2728 $anywhere->delete_tree; 2729 2730(I suppose C<delete_tree> is a "destructor", or as close as you can 2731meaningfully come for a circularity-rich data structure in Perl.) 2732 2733=cut 2734 2735sub delete_tree { 2736 my $it = $_[0]; 2737 $it->root->walk_down({ # has to be callbackback, not callback 2738 'callbackback' => sub { 2739 %{$_[0]} = (); 2740 bless($_[0], 'DEADNODE'); # cause become dead! cause become dead! 2741 return 1; 2742 } 2743 }); 2744 return; 2745 # Why DEADNODE? Because of the nice error message: 2746 # "Can't locate object method "leaves_under" via package "DEADNODE"." 2747 # Moreover, DEADNODE doesn't provide is_node, so fails my can() tests. 2748} 2749 2750sub DEADNODE::delete_tree { return; } 2751 # in case you kill it AGAIN!!!!! AND AGAIN AND AGAIN!!!!!! OO-HAHAHAHA! 2752 2753########################################################################### 2754# stolen from MIDI.pm 2755 2756sub _dump_quote { 2757 my @stuff = @_; 2758 return 2759 join(", ", 2760 map 2761 { # the cleaner-upper function 2762 if(!length($_)) { # empty string 2763 "''"; 2764 } elsif( m/^-?\d+(?:\.\d+)?$/s ) { # a number 2765 $_; 2766 } elsif( # text with junk in it 2767 s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])> 2768 <'\\x'.(unpack("H2",$1))>eg 2769 ) { 2770 "\"$_\""; 2771 } else { # text with no junk in it 2772 s<'><\\'>g; 2773 "\'$_\'"; 2774 } 2775 } 2776 @stuff 2777 ); 2778} 2779 2780########################################################################### 2781 2782=back 2783 2784=head2 When and How to Destroy 2785 2786It should be clear to you that if you've built a big parse tree or 2787something, and then you're finished with it, you should call 2788$some_node->delete_tree on it if you want the memory back. 2789 2790But consider this case: you've got this tree: 2791 2792 A 2793 / | \ 2794 B C D 2795 | | \ 2796 E X Y 2797 2798Let's say you decide you don't want D or any of its descendants in the 2799tree, so you call D->unlink_from_mother. This does NOT automagically 2800destroy the tree D-X-Y. Instead it merely splits the tree into two: 2801 2802 A D 2803 / \ / \ 2804 B C X Y 2805 | 2806 E 2807 2808To destroy D and its little tree, you have to explicitly call 2809delete_tree on it. 2810 2811Note, however, that if you call C->unlink_from_mother, and if you don't 2812have a link to C anywhere, then it B<does> magically go away. This is 2813because nothing links to C -- whereas with the D-X-Y tree, D links to 2814X and Y, and X and Y each link back to D. Note that calling 2815C->delete_tree is harmless -- after all, a tree of only one node is 2816still a tree. 2817 2818So, this is a surefire way of getting rid of all $node's children and 2819freeing up the memory associated with them and their descendants: 2820 2821 foreach my $it ($node->clear_daughters) { $it->delete_tree } 2822 2823Just be sure not to do this: 2824 2825 foreach my $it ($node->daughters) { $it->delete_tree } 2826 $node->clear_daughters; 2827 2828That's bad; the first call to $_->delete_tree will climb to the root 2829of $node's tree, and nuke the whole tree, not just the bits under $node. 2830You might as well have just called $node->delete_tree. 2831(Moreavor, once $node is dead, you can't call clear_daughters on it, 2832so you'll get an error there.) 2833 2834=head1 BUG REPORTS 2835 2836If you find a bug in this library, report it to me as soon as possible, 2837at the address listed in the MAINTAINER section, below. Please try to 2838be as specific as possible about how you got the bug to occur. 2839 2840=head1 HELP! 2841 2842If you develop a given routine for dealing with trees in some way, and 2843use it a lot, then if you think it'd be of use to anyone else, do email 2844me about it; it might be helpful to others to include that routine, or 2845something based on it, in a later version of this module. 2846 2847It's occurred to me that you might like to (and might yourself develop 2848routines to) draw trees in something other than ASCII art. If you do so 2849-- say, for PostScript output, or for output interpretable by some 2850external plotting program -- I'd be most interested in the results. 2851 2852=head1 RAMBLINGS 2853 2854This module uses "strict", but I never wrote it with -w warnings in 2855mind -- so if you use -w, do not be surprised if you see complaints 2856from the guts of DAG_Node. As long as there is no way to turn off -w 2857for a given module (instead of having to do it in every single 2858subroutine with a "local $^W"), I'm not going to change this. However, 2859I do, at points, get bursts of ambition, and I try to fix code in 2860DAG_Node that generates warnings, I<as I come across them> -- which is 2861only occasionally. Feel free to email me any patches for any such 2862fixes you come up with, tho. 2863 2864Currently I don't assume (or enforce) anything about the class 2865membership of nodes being manipulated, other than by testing whether 2866each one provides a method C<is_node>, a la: 2867 2868 die "Not a node!!!" unless UNIVERSAL::can($node, "is_node"); 2869 2870So, as far as I'm concerned, a given tree's nodes are free to belong to 2871different classes, just so long as they provide/inherit C<is_node>, the 2872few methods that this class relies on to navigate the tree, and have the 2873same internal object structure, or a superset of it. Presumably this 2874would be the case for any object belonging to a class derived from 2875C<Tree::DAG_Node>, or belonging to C<Tree::DAG_Node> itself. 2876 2877When routines in this class access a node's "mother" attribute, or its 2878"daughters" attribute, they (generally) do so directly (via 2879$node->{'mother'}, etc.), for sake of efficiency. But classes derived 2880from this class should probably do this instead thru a method (via 2881$node->mother, etc.), for sake of portability, abstraction, and general 2882goodness. 2883 2884However, no routines in this class (aside from, necessarily, C<_init>, 2885C<_init_name>, and C<name>) access the "name" attribute directly; 2886routines (like the various tree draw/dump methods) get the "name" value 2887thru a call to $obj->name(). So if you want the object's name to not be 2888a real attribute, but instead have it derived dynamically from some feature 2889of the object (say, based on some of its other attributes, or based on 2890its address), you can to override the C<name> method, without causing 2891problems. (Be sure to consider the case of $obj->name as a write 2892method, as it's used in C<lol_to_tree> and C<random_network>.) 2893 2894=head1 SEE ALSO 2895 2896L<HTML::Element> 2897 2898Wirth, Niklaus. 1976. I<Algorithms + Data Structures = Programs> 2899Prentice-Hall, Englewood Cliffs, NJ. 2900 2901Knuth, Donald Ervin. 1997. I<Art of Computer Programming, Volume 1, 2902Third Edition: Fundamental Algorithms>. Addison-Wesley, Reading, MA. 2903 2904Wirth's classic, currently and lamentably out of print, has a good 2905section on trees. I find it clearer than Knuth's (if not quite as 2906encyclopedic), probably because Wirth's example code is in a 2907block-structured high-level language (basically Pascal), instead 2908of in assembler (MIX). 2909 2910Until some kind publisher brings out a new printing of Wirth's book, 2911try poking around used bookstores (or C<www.abebooks.com>) for a copy. 2912I think it was also republished in the 1980s under the title 2913I<Algorithms and Data Structures>, and in a German edition called 2914I<Algorithmen und Datenstrukturen>. (That is, I'm sure books by Knuth 2915were published under those titles, but I'm I<assuming> that they're just 2916later printings/editions of I<Algorithms + Data Structures = 2917Programs>.) 2918 2919=head1 MAINTAINER 2920 2921David Hand, C<< <cogent@cpan.org> >> 2922 2923=head1 AUTHOR 2924 2925Sean M. Burke, C<< <sburke@cpan.org> >> 2926 2927=head1 COPYRIGHT, LICENSE, AND DISCLAIMER 2928 2929Copyright 1998-2001, 2004, 2007 by Sean M. Burke and David Hand. 2930 2931This program is free software; you can redistribute it and/or modify it 2932under the same terms as Perl itself. 2933 2934This program is distributed in the hope that it will be useful, but 2935without any warranty; without even the implied warranty of 2936merchantability or fitness for a particular purpose. 2937 2938=cut 2939 29401; 2941 2942__END__ 2943