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