Beefy Boxes and Bandwidth Generously Provided by pair Networks
Think about Loose Coupling
 
PerlMonks  

Challenge: Dumping trees.

by BrowserUk (Patriarch)
on Oct 13, 2012 at 00:13 UTC ( [id://998803]=perlmeditation: print w/replies, xml ) Need Help??

I've historically found writing code for manipulating tree structures awkward; and a primary reason for it is that when things go wrong, visualising why is hampered by the lack of a mechanism for creating convenient, compact and readable dumps of the structures.

Data::Dump, Data::Dumper et al. do a perfectly fine job of dumping the structure in terms of the arrays (or hashes) that hold the tree, but are pretty useless when if comes to visualising the tree structure itself: levels; depth; width; changes from one iteration to the next etc. And I usually find myself resorting to manually manipulating a dump in order to work out what is going on.

For example, a not very complicated, array-based binary tree might get dumped like this:

[ [ [[[[["a", "b"], "c"], ["d", "e"]], [[["f", "g"], "h"], [["i", +"j"], ["k", ["l", "m"]]]]], ["n", [[["o", "p"], "q"], ["r", "s"]]]], ["t", ["u", "v"]] ], [["w", ["x", "y"]], "z"] ]

Try working out how deep; or wide; or which nodes are at the same level; from that. Not to mention seeing what changed between this dump and the previous -- when (for example) re-balancing the tree.

With hand manipulating this you can come up with something like:

Which allows those questions to be answered, but it is hardly concise or convenient; and makes comparing multiple iterations of changes very awkward.

The same tree can be represented this way:

___________/\_________ +___ ________________/\____________ +__/\_ _____________/\______________ /\ / +\ \ ________/\________ ___/\___ / \ / + \ z __/\__ _____/\____ / __/\__ t /\ w + /\ /\ \ /\ __/\__ n /\ \ u v +x y / \ /\ / \ / /\ / \ /\ /\ c d e /\ h /\ / \ /\ q r s a b f g i j k /\ o p l m

which is far nicer.

I've spent the last couple of days trying to code this but haven't yet succeeded. Any offers?

(NOTE: I'm looking for a compact dump to a terminal; not presentation quality graphics here. Ie. I'm not looking for GraphViz or similar, so please don't tell me about those.)


With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
"Science is about questioning the status quo. Questioning authority".
In the absence of evidence, opinion is indistinguishable from prejudice.

RIP Neil Armstrong

Replies are listed 'Best First'.
Re: Challenge: Dumping trees.
by moritz (Cardinal) on Oct 13, 2012 at 09:28 UTC

    I'm not sure, but maybe such a structure is easier to create:

    ┼┬┬┬┬┬a
    │││││└b
    ││││└c
    │││└┬d
    │││ └e
    ││├┬┬┬f
    │││││└g
    ││││└h
    │││└┬┬i
    │││ │└j
    ....
    

    My inspiration is https://github.com/perl6/std/blob/master/viv#L187 which produces parse trees like

    └─VAST::statementlist, BEG: 0, END: 7
      ├─VAST::statement, BEG: 0, END: 7
      │ └─VAST::term__S_identifier, BEG: 0, END: 7, SYM: identifier, _from: 7,
      │   │   _pos: 7, _specific: 1, dba: term, prec: z=
      │   ├─VAST::identifier, BEG: 0, END: 3, TEXT: say
      │   └─VAST::args, BEG: 3, END: 7, invocant: undef
      │     └─VAST::arglist, BEG: 4, END: 7, WS: 1
      │       └─VAST::term__S_value, BEG: 4, END: 6, SYM: value, WS: 1,
      │         │   _specific: 1
      │         └─VAST::value__S_number, BEG: 4, END: 6, SYM: number, WS: 1,
      │           │   _specific: 1
      │           └─VAST::number, BEG: 4, END: 6, WS: 1
      │             └─VAST::integer, BEG: 4, END: 6, WS: 1
      │               └─VAST::decint, BEG: 4, END: 6, TEXT: 42, WS: 1
      └─VAST::eat_terminator, BEG: 7, END: 7, TEXT: , WS: 1
    

    Update: just today a Perl 6 solution for Visualize a tree on rosettacode was entered, it produces similar output:

    root
    ├─a
    │ └─a1
    │   └─a11
    └─b
      ├─b1
      │ └─b11
      ├─b2
      └─b3
    

    Shouldn't be to hard to port to Perl 5.

Re: Challenge: Dumping trees.
by Anonymous Monk on Oct 13, 2012 at 15:42 UTC
      Naturally nodes with a width greater than 2 chars breaks it :)

      Thank you anonymonk. That handles everything I've thrown at it -- which it a darn sight more than I can say for my attempts so far.

      It occasionally produces an oddity -- see the 'wxyz' nodes in the second example and the '1' node in the last two examples -- but they are still clear enough for my purposes.

      C:\test>genBiaryTree -W=1 -S=2 | junk.pl ______________________________________________________ +________________________________________________/\_ _______/\_____________________________________________________ +_____________________________________________ /\ _/\___ + _____________________________/\_ Y Z _/\ _/\_ ____________________________________ +______________/\_ /\ _/\ d /\ /\ ___________/\_____________ + /\___ W X /\ c e f g h ___/\_____ _______/\____ + H _/\_ a b /\_ _/\___ ___/\_____ __/\________________ +_______ /\ /\_ i /\ _/\ _/\ /\_ ___/\ /\ _______________ +______/\_____ I J K /\___ j k /\ n /\ q r /\ /\_ x y / /\_ + ___/\ L _/\___ l m o p s t u /\ z 1 /\____________ +___ /\_ G /\ _/\_________ v w 2 ___________ +__/\_ D /\ M N /\ _____/\ /\_________ + /\ E F O P _/\___ V 3 _______/\ +_ B C /\ _/\ /\_ +/\ Q R /\ U 4 /\___ 9 + A S T 5 _/\ /\ 8 6 7 C:\test>genBiaryTree -W=1 -S=3 | junk.pl _____________________________/\___________________________________ +___________________________________________________ _/\___________________ + ___________________________________/\ /\ _________/\_______ _________________ +______________/\_______________________________ Z a b _____/\_______ _____/\ ____/\________________ +_____ _______________/\_ _/\___ _____/\ /\_ q ___/\ _______________ +____/\_______ _____/\_ /\ /\ _/\ /\_ l m /\_ _/\_ _/ /\___ + ___/\ _______/\___ /\_________ X Y c d /\ g h /\_ n /\ _____/\ //\ 1 _/\___ + _/\_ G /\_____ _/\ P _/\_ e f i /\ o p /\___ v wyxz /\ _/\______ +_ /\ /\ H ___/\ /\ O ___/\ /\ j k r _/\ 2 3 /\ _____ +/\_ C D E F /\_ L M N _/\_ U V W /\ u 4 5 /\_ + /\ I /\ /\ /\ s t 6 /\_ + A B J K Q R S T 7 /\ 8 9 C:\test>genBiaryTree -W=1 -S=4 | junk.pl ____________________________________ +__________/\_____________________________________ ___________________________/\_______________ + _____/\_ _/\_____________________ ___________/\___________________ +_ _____________________________/\_ /\ _/\ _/\_ _/\_________ _____________ +/\_______ /\_______________________ /\_ Y Z /\ c _______/\ /\_ /\ _/\ ____/\___________ + _____/\ F _________/\___ V /\ a b ___/\_ n o /\ r s ___/\ y /\__ _________/\ + /\_ E _______/\_____ _/\ W X ___/\_ /\_ p q _/\_ x z _/\ /\_ 9 + A /\_ _/\___ ___/\_ /\ U _/\_ /\ j /\_ /\ /\ \ 2 3 /\_ + B /\ _/\ _/\_ /\_ /\ S T /\ /\ h i k /\ t u v w 1 4 /\_ + C D /\ I /\ /\ N /\ Q R d e f g l m 5 /\_ + G H J K L M O P 6 /\ 7 8 C:\test>genBiaryTree -W=1 -S=40 | junk.pl ______________________________/\________ +_ _______________/\_________ ___ +/\_______________ _/\_ _______/\_ ___/\_ + ___________/\_____ _____/\ /\_ /\___ /\_______ /\_ /\ + _/\_______ _/\_________ _/\_ g h /\___ p _/\_ u _/\_ 5 /\ 8 9 + /\ ___/\_ _/\ _______/\_________ _/\ /\_ i _/\___ /\ /\ ___/\ /\__ 6 7 + A B _/\_ /\ /\ K /\___ ___/\___ /\ c d /\ /\ _/\_ q r s t /\_ y z _/\___ + /\ /\ G H I J L _/\_ ___/\_ _/\_ a b e f j k /\ /\ v /\ \ _/\ + C D E F /\ /\ /\_ /\ /\ /\_ l m n o w x 1 /\ 4 + M N O P Q /\ T U V W X /\ 2 3 + R S Y Z C:\test>genBiaryTree -W=1 -S=400 | junk.pl _____________________________/\_____________________________ +___________________________ _______/\_______ + _________________________/\_ /\_____ ___/\_______ ______________________ +/\___________ /\_______________ a ___/\ _/\_ ___/\_ _____/\________________ + _/\_ N ___________/\_ /\_ e /\ /\ _/\_ /\_ /\_ ___/\___ + _______/\ /\_____ _/\_ /\_ b /\ f g h i /\ /\ n /\_____ u /\_ _______/\_ _/\ + /\___ F G ___/\_ /\ /\_____ W /\_ c d j k l m o _/\_ v /\ /\_____ /\ /\ 9 + A _/\_ /\_ /\_ O P Q ___/\_ X /\ _/\ /\ w x _/ _/\ 5 6 7 8 + /\ /\ H /\ K /\ /\_ /\ Y Z /\ r s t /\ _/\ 4 + B C D E I J L M R /\ U V p q y z /\ 3 + S T 1 2 C:\test>genBiaryTree -W=1 -S=400000 | junk.pl + _________________________________/\___ __________________ +________/\___________________ _/\_ _______________________________________________/\_________________ +_______ ___/\_________ /\ /\_ _/\_________________________ _________________ +______/\ ___/\_ _/\_ V W X /\ /\ ___/\___ \ _ + D ___/\_ /\ ___/\ /\ Y Z a b _____/\_ _/\_______ /\______________ +_ ___/\_ /\ M N _/\_ S T U _______/\_ /\ /\ _/\_______ 1 ___________ +/\___ _/\_ /\ K L /\ /\ ___/\_ /\_ n o p q _/\ _/\ _/\_____ + _/\ /\ /\ I J O P Q R _/\_ /\_ k /\ _/\ u ___/\ z /\ ___/\_ + /\ C E F G H /\ /\ g /\_ l m /\ t /\_ y 2 3 /\_ /\_ + A B c d e f h /\ r s v /\ 4 /\ 7 /\ i j w x 5 6 8 9 C:\test>genBiaryTree -W=1 -S=99999400000 | junk.pl _________________/\_________________ ___/\_______________ _____________/\_____ _/\_ _________/\ _/\___ ___/\_________________ +_______________________________________________ _/\ /\ ___/\_______ n /\ _/\___ /\_ + _____/\_ /\ c d e /\_ _/\ o p /\ _/\___ x /\ + ___________________/\___ /\_ a b f /\ ___/\ m q r /\ _/\ y z + ___________/\_____________ _/\ X /\ g h /\_ l s t /\ w + _____/\_____ _______/\_ /\ W Y Z i /\ u v _____ +__/\___ ___/\_ ___/\_____ /\_ U V j k _/\____ +_ _/\ /\_ /\_ /\_ _/\ R /\ ___/\ ___ +/\ /\ D E /\ H /\ K /\ _/\ Q S T _/\_ 6 /\_ + A B C F G I J L M /\ P _/\ /\ 7 /\ + N O _/\ 3 4 5 8 9 \ 2 1

      I'm going to try and adapt it to produce a slightly different style of output that I think results in nicer -- cleaner, more easily read -- output. Eg. Instead of:

      _____/\_____ ___________/\_ ___/\ _______________/\_ /\_ /\_ z ___/\_____ /\_____ t /\ w /\ _/\_ _/\___ n _/\_ u v x y _/\ /\ _/\ _/\_ _/\ /\ /\ c d e /\ h /\ /\_ /\ q r s a b f g i j k /\ o p l m

      This:

      _______ ___________/ \___ ___________/ \_ _/ \ _______/ \_____ / \_ / \_ z _/ \___ / \_ t / \ w / \ _/ \_ _/ \__ n _/ \_ u v x y _/ \ / \ _/ \ _/ \ _/ \ / \ / \ c d e / \ h / \ /\_ / \ q r s a b f g i j k / \ o p l m

      Also, one possibility for handling node 'names' of more than 1 or 2 chars; though I'm not sure it really works as is?:

      _______ ___________/ \___ ___________/ \_ _/ \ _______/ \_____ / \_ / \_ z _/ \___ / \_ t / \ w / \ u _/ \_ _/ \__ n _/ \_ a u v h x y l _/ \ / \ _/ \ _/ \ o _/ \ / \ n n i i r a u / \ c d e / \ h / \ /\_ v / \ q r s g i c s a n a b h e c f g o i j k / \ e o p u o i o f t k y k l r a l h o o t n u i l m m s a e m e o o e e p a r t o x l e d l l i i b c p b e r r r y y h v l a t f l i i o m k e a a e o r m a o i r g e a w r r c a e o o t t

      With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
      Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
      "Science is about questioning the status quo. Questioning authority".
      In the absence of evidence, opinion is indistinguishable from prejudice.

      RIP Neil Armstrong

      Upon further testing, the anomalies I noted in Re^2: Challenge: Dumping trees. were actually more prevalent and distracting than I first thought; and I failed in my attempts to cure them in your code.

      I also finally succeeded in getting my attempt to work properly. In part, because of a couple of things I learnt from studying your code. Thank you.


      With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
      Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
      "Science is about questioning the status quo. Questioning authority".
      In the absence of evidence, opinion is indistinguishable from prejudice.

      RIP Neil Armstrong

Re: Challenge: Dumping trees.
by jmcnamara (Monsignor) on Oct 13, 2012 at 09:13 UTC

    One option may be Data::Dumper::Perltidy:

    #!/usr/bin/perl use strict; use warnings; use Data::Dumper::Perltidy; $Data::Dumper::Perltidy::ARGV = '-i=4 -boc -nopro'; my $data = [ [ [[[[["a", "b"], "c"], ["d", "e"]], [[["f", "g"], "h"], [[" +i", "j"], ["k", ["l", "m"]]]]], ["n", [[["o", "p"], "q"], ["r", "s"]]]], ["t", ["u", "v"]] ], [["w", ["x", "y"]], "z"] ]; print Dumper $data; __END__

    Which gives a structure similar to your hand manipulated example:

    The perltidy options are explained in the Perltidy manpage.

    Update: actually this isn't much of an improvement over the base Data::Dumper formatting due to the -boc option but without it Perl::Tidy compacts the branches too much. So, it probably isn't useful in this case.

    --
    John.

Re: Challenge: Dumping trees.
by Anonymous Monk on Oct 13, 2012 at 02:58 UTC
Re: Challenge: Dumping trees.
by hdb (Monsignor) on Sep 21, 2013 at 20:36 UTC

    I am not sure if I add a new approach as I have not studied all posts in this thread in much detail. My code is just a bit shorter and I think a pretty direct approach to the problem.

    use strict; use warnings; sub prepare { my( $subtree, $level, $col, $graph ) = @_; my $lcol = 0; if( ref($subtree) ) { $lcol = prepare( $subtree->[0], $level+1, $col, $graph ); # par +se left side of tree, keep top position $lcol and $graph->[$level]->[$_] = '_' for $lcol..$$col-1; # dra +w horizontal line $graph->[$level]->[$$col++] = '/'; $lcol = $$col; # new + root of the tree $graph->[$level]->[$$col++] = '\\'; my $rcol = prepare( $subtree->[1], $level+1, $col, $graph ); # par +se right side of the tree, keep its top position $rcol and $graph->[$level]->[$_] = '_' for $lcol+1..$rcol-1; # dra +w horizontal line } else { $graph->[$level]->[$$col++] = $subtree; # lea +f } return $lcol; # ret +urn column of root } my $root = do { my $r; my @a = ( 'a'..'z', 1..9, 'A'..'Z' ); $r = int( rand $#a ), splice @a, $r, 2, [ @a[ $r, $r+1 ]] while @a + > 1; $a[0]; }; my @graph; my $col = 0; prepare( $root, 0, \$col, \@graph ); for my $row ( @graph ) { print $_ // ' ' for @$row; print "\n"; }

    UPDATE: Here is some sample output for a smaller tree:

    _____/\_ +_ __________________________/\__ +/\__ ____________________/\________ /\ x + /\ __/\________ _____/\___________ v w + y z __/\ _____/\__ /\__ __/\__ __/\ e /\__ /\__ m /\ _____/\ /\ __/\ d f /\ i /\__ n o /\__ s t u /\ c g h j /\ p /\ a b k l q r

      On first blush, that appears to be astonishingly ... astonishing. Um. That's not good English is it. I'll try again.

      After scant consideration, that appears to be remarkably ... remarkable. D'oh!

      I will adapt it to produce my preferred, revised format -- contrast original format with my revised, preferred format so that I can compare like-for-like with my final version.

      Then I'll get back to you.

      Meantime, that's impressive!

      Weirdly, I especially like the comments. If that sounds strange, trust me, it is even stranger, given that I (generally) hate comments.


      With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
      Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
      "Science is about questioning the status quo. Questioning authority".
      In the absence of evidence, opinion is indistinguishable from prejudice.

        For that you require a left/right flag to indicate which side of a subtree you are in. The logic is probably even simpler:

        use strict; use warnings; use constant { LEFT => 0, RIGHT => 1 }; sub prepare { my( $subtree, $lr, $level, $col, $graph ) = @_; if( ref($subtree) ) { my $lcol = prepare( $subtree->[LEFT ], LEFT, $level+1, $col, $gra +ph ); $$col+=2; my $rcol = prepare( $subtree->[RIGHT], RIGHT, $level+1, $col, $gra +ph ); $graph->[$level]->[$lcol] = '/'; $graph->[$level-1]->[$_] = '_' for $lcol+1..$rcol-1; $graph->[$level]->[$rcol] = '\\'; return $lr == LEFT ? $rcol : $lcol; # intentionally the other way + round !! } else { $graph->[$level]->[$$col] = $subtree; return $$col; } } my $root = do { my $r; my @a = ( 'a'..'z', 1..9, 'A'..'Z' ); $r = int( rand $#a ), splice @a, $r, 2, [ @a[ $r, $r+1 ]] while @a > + 1; $a[0]; }; my @graph; my $col = 0; prepare( $root, LEFT, 1, \$col, \@graph ); # need to start with $level + = 1 ! for my $row ( @graph ) { print $_ // ' ' for @$row; print "\n"; }

        and it looks like this:

        _____________ _____________/ \_______ +__________ _____/ \_________ _/ + \___________________________ _____________/ \_______ _/ \ / \ ___ +__________/ \_________ _________/ \ _/ \_ / \___ 4 5 6 _/ + \_______ ___/ \_ _/ \_____ o _/ \_ _/ \ x / \_ / \_ + ___/ \_ _/ \_ _/ \ _/ \_ ___/ \_ / \ / \_ / \ w y _/ \_ 7 / \_ + ___/ \___ / \_ / \ _/ \_ / \ Z / \ / \ _/ \_ _/ \_ p q r / \ u v / \ / \ 8 / +\ / \_ / \_ J / \___ Q R / \ / \_ X Y a b c d / \_ / \ / \ / \_ s t z 1 2 3 9 +A B _/ \ F _/ \ K / \_ S T U / \ e / \ h i j k l / \ + / \ E / \ I L _/ \_ V W f g m n + C D G H / \ / \ + M N O P

        UPDATE:

        Replacing the 2 in line $$col+=2; with a larger number makes the tree wider which might be useful for readability.

        Replacing the line $graph->[$level]->[$$col] = $subtree; with $graph->[$level++]->[$$col] = $_ for split //, $subtree; will print leaf values vertically.

Re: Challenge: Dumping trees.
by remiah (Hermit) on Oct 14, 2012 at 06:25 UTC

    Hello BrowserUK.

    I know this is not terminal one but html output is handy for me.

    #!/usr/bin/perl #HTML version use strict;use warnings; use ArrayRef2HTMLTree; my $t=[ [ [[[[["a", "b"], "c"], ["d", "e"]], [[["f", "g"], "h"], [["i", + "j"], ["k", ["l", "m"]]]]], ["n", [[["o", "p"], "q"], ["r", "s"]]]], ["t", ["u +", "v"]] ], [["w", ["x", "y"]], "z"] ]; my $ht = ArrayRef2HTMLTree->new(font_size=>'8pt',line_height=>'10px'); print $ht->to_html($t);
    And my package.
    # package ArrayRef2HTMLTree; use strict; use warnings; our $HTML; sub new{ my $class=shift; my %args=@_; $args{line_height}='10px' if(! exists $args{line_height}); $args{font_size}='8pt' if(! exists $args{font_size}); return bless \%args ,$class; } sub to_html{ my $self=shift; my $t=shift; my $tree=join('', '<ul class="tree">' , "\n" , traverse($t,0) , "\ +n", '</ul>', "\n"); my $html=$HTML; $html =~ s/#TREE#/$tree/s; $html =~ s/#LINE-HEIGHT#/$self->{line_height}/s; $html =~ s/#FONT-SIZE#/$self->{font_size}/s; return $html; } sub traverse { my ($t,$depth)=@_; my $tab="\t"x$depth; if (ref($t) eq 'ARRAY'){ return $tab , "<li>($depth)<ul>" , "\n" , (map{ traverse($_,$depth+1) } @$t) , $tab, "</ul></li>" , "\n"; } else { return "$tab<li>$t</li>\n"; } } $HTML=<<'HTML'; <html><head><style> body{ background-color: #FFFFFF; /*&#30333;*/ } ul.tree, ul.tree ul{ list-style-type: none; background: url(data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAEA +AAAKAQMAAABPHKYJAAAAA1BMVEWIiIhYZW6zAAAACXB padding:0; margin:0; } ul.tree ul{ margin-left: 10px; border: lightgreen 0px solid; } ul.tree li{ margin:0px; padding: 0 10px; border: green 0px solid; line-height: #LINE-HEIGHT#; background: url(data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgA +AAAUAQMAAACK1e4oAAAABlBMVEUAAwCIiIgd2JB2AAA color: #696969; font-size: #FONT-SIZE#; } ul.tree li:last-child{ background: #fff url('data:image/png;base64,iVBORw0KGgoAAAANSUhEUg +AAAAgAAAAUAQMAAACK1e4oAAAABlBMVEUAAwCIiIgd2 } </style></head> <body> #TREE# </body> </html> HTML 1;
    regards.

Re: Challenge: Dumping trees.
by tybalt89 (Monsignor) on Nov 29, 2022 at 21:02 UTC

    Just because it looked like fun, and so far there are no examples of horizontal word trees.

    #!/usr/bin/perl use strict; use warnings; # https://perlmonks.org/?node_id=998803 my $tree = [ [ [[[[["a", "b"], "c"], ["d", "e"]], [[["f", "g"], "h"], +[["i", "j"], ["k", ["l", "m"]]]]], ["n", [[["o", "p"], "q"], ["r", "s +"]]]], ["t", ["u", "v"]] ], [["w", ["x", "y"]], "z"] ]; $tree = [ [ [[[[["alpha", "bravo"], "charlie"], ["delta", "echo"]], [[ +["foxtrot", "golf"], "hotel"], [["indigo", "juliet"], ["kilo", ["lima +", "mike"]]]]], ["november", [[["oscar", "papa"], "quebec"], ["romeo" +, "sierra"]]]], ["tango", ["uniform", "victor"]] ], [["whiskey", ["xr +ay", "yankee"]], "zulu"] ]; print tree( $tree ); sub half { ' ' x ( length(shift) >> 1 ) } sub tree { my $tree = shift; ref $tree or return "$tree\n" =~ s/ +/ /gr; # horizontal word ref $tree or return $tree =~ s/./$&\n/gr; # vertical word my ($padl, $padr) = map $_->[0] =~ tr// /cr, # pads my ($left, $right) = map [ tree($_) =~ /.+/g ], @$tree; use List::AllUtils qw( pairwise ); local $_ = join '', pairwise # paste two blocks side by side { "@{[($a // $padl)]} @{[($b // $padr)]}\n" } @$left, @$right; return s{^(?=( *)(\S.*?) {2,}(\S.*?)( *\n))}{ my $span = ' ' x ($+[3] - $-[2] - 2 - length half($2) . half($3)); "$1 " . half($2) . $span =~ tr/ /_/r . half($3) . " $4" . $1 . half($2) . "/$span\\" . half($3) . $4 }er; }

    Outputs:

    + ____________________________ +_______________________________________ + / + \ + ________________________________________________________________ +_______ ______________ + / + \ / \ _____________________________ +______________________________________ + ___________ __________ zulu / + \ + / \ / \ _______________________________________ + _______________________ t +ango _______ whiskey _____ / \ + / \ + / \ / \ _______________ _____________________ +__ november _______________ + uniform victor xray yankee / \ / + \ / \ + __________ _____ _________ ____ +__________ _________ ______ + / \ / \ / \ / + \ / \ / \ + ______ charlie delta echo ______ hotel ______ + _______ _____ quebec romeo sierra + / \ / \ / \ + / \ / \ + alpha bravo foxtrot golf indigo juli +et kilo ____ oscar papa + + / \ + + lima mike

    By commenting out the "horizontal word" line it produces:

    ________________________ +_ / + \ ____________________________ _ +_____ / \ / + \ ___________________________ ___ ___ + z / \ / \ / +\ u ________________ _________ t __ w +__ l / \ / \ a / \ h / + \ u _____ _________ n _____ n u v i x + y / \ / \ o / \ g n i s r + a ___ __ ___ _____ v ___ __ o i c k a + n / \ / \ / \ / \ e / \ / \ f t e y + k __ c d e __ h __ ___ m __ q r s o o y + e / \ h e c / \ o / \ / \ b / \ u o i r r + e a b a l h f g t i j k __ e o p e m e m + l r r t o o o e n u i / \ r s a b e r + p a l a x l l d l l l m c p e o r + h v i t f i i o i i a a c a + a o e r g e m k r + o o t a e + t
Re: Challenge: Dumping trees.
by brx (Pilgrim) on Nov 07, 2012 at 20:38 UTC

    I know it's a little bit late...

    use strict; my $sp = 1; my $tree = [ [ [[[[["alpha", "bravo"], "charlie"], ["delta", "echo"]], [[["fo +xtrot", "golf"], "hotel"], [["indigo", "juliet"], ["kilo", ["lima", " +mike"]]]]], ["november", [[["oscar", "papa"], "quebec"], ["romeo", "sierra +"]]]], ["tango", ["uniform", "victor"]] ], [["whiskey", ["xray", "yankee"]], "zulu"] ]; my $lowerline = 0; my $nodecount =0; sub scantree { my ($node,$level) = @_; if (ref($node)) { $level++; scantree($_,$level) for (@$node); } else { $nodecount++; my $ground = $level + length($node); $lowerline = $ground if ($ground > $lowerline); } } scantree($tree,0); # get number of columns and lines ($nodecount(* $sp +) and $lowerline) my @output = (" " x ((1+$sp)*$nodecount)) x ($lowerline+1); $nodecount = 0; #reset sub show { my ($node,$level,$rl) = @_; if (ref($node)) { my $left=0; #0 is right // 1 is left my @po; for my $n (@$node) { $po[$left] = show($n,$level+1,$left); $left++; } # ____ # /size\ my $size = $po[1]-$po[0]-1; substr($output[$level] , $po[0]+1, $size, "_" x $size); substr($output[$level+1], $po[0] , 1 , "/"); substr($output[$level+1], $po[1] , 1 , "\\"); return($po[1-$rl]); #child return "hook" position to parent } else { $nodecount++; my $p = ($nodecount-1)*($sp+1); for my $l (1 .. length($node)) { substr($output[$level+$l], $p+$sp, 1, substr($node,$l-1,1) +); #write $node vertically } return ($p+$sp); # child returns his position to parent } } show($tree,0,0); my $out = join "\n",@output; print "$out\n"; __END__ #lowcost new view : my $col = length (($out=~/.(.*)/)[0]); my $numlines = $out=~ tr/\n//; for my $x (0 .. $col) { for my $y (0 .. $numlines) { my $ch = substr($out,$x+$y*($col+2),1); $ch =~ tr/_/|/; print $ch; } print "\n"; } __DATA__ $sp=1 _______ ___________/ \___ ___________/ \_ _/ \ _______/ \_____ / \_ / \_ z _/ \___ / \_ t / \ w / \ u _/ \_ _/ \_ n _/ \_ a u v h x y l _/ \ / \ _/ \ _/ \_ o _/ \ / \ n n i i r a u / \ c d e / \ h / \ / \_ v / \ q r s g i c s a n a b h e c f g o i j k / \ e o p u o i o f t k y k l r a l h o o t n u i l m m s a e m e o o e e p a r t o x l e d l l i i b c p b e r r r y e h v l a t f l i i o m k e a a e o r m a o i r g e a e r r c a e o o t t ----- $sp=2 __________ +_ _________________/ + \_____ _________________/ \__ _ +_/ \ ___________/ \________ / \__ / + \__ z __/ \_____ / \__ t / \ w + / \ u __/ \__ __/ \__ n __/ \__ a u v h + x y l __/ \ / \ __/ \ __/ \__ o __/ \ / \ n n i i + r a u / \ c d e / \ h / \ / \__ v / \ q r s g i c s + a n a b h e c f g o i j k / \ e o p u o i o f t k + y k l r a l h o o t n u i l m m s a e m e o o e + e p a r t o x l e d l l i i b c p b e r r r y + e h v l a t f l i i o m k e a a e o r m a o i r g e a e r r c a e o o t t ----- $sp=3 + _______________ ______________ +_________/ \_______ _______________________/ + \___ ___/ \ _______________/ \___________ + / \___ / \___ z ___/ \_______ / \__ +_ t / \ w / \ u ___/ \___ ___/ \___ n ___/ + \___ a u v h x y l ___/ \ / \ ___/ \ ___/ \___ o ___/ \ + / \ n n i i r a u / \ c d e / \ h / \ / \___ v / \ q + r s g i c s a n a b h e c f g o i j k / \ e o p u + o i o f t k y k l r a l h o o t n u i l m m s a e + m e o o e e p a r t o x l e d l l i i b c p b + e r r r y e h v l a t f l i i o m k e a a e + o r m a o i r g e a e r r c + a e o o t t ----- $sp=0 ___ _____/ \_ _____/ \ / \ ___/ \__ /\ /\ z / \_ / \ t/\w/\u /\ / \ n /\ auvhxyl /\/\ /\ /\ o /\/\nniirau /\cde/\h/\/\ v/\qrsgicsan abhecfgoijk/\eopuoioftkyk lralhootnuilmmsaeme ooe e partoxledlliibcpber rry e hvla tfliiomkeaaeor m aoi r ge aerr c a e o ot t ---- lowcost new view ($sp=1) /alpha | /\bravo | /\charlie | /\/delta | | | \echo | | /foxtrot | | | /\golf | | /\/\hotel | | | | /indigo | | | | \/\juliet | | | \/kilo | | | \/lima | | | \mike | /\/november | | | | /oscar | | | | | /\papa | | | | \/\quebec | | | \/romeo | | | \sierra | /\/tango | | | \/uniform | | | \victor | | /whiskey | | \/\/xray | | | \yankee | \zulu
    English is not my mother tongue.
    Les tongues de ma mère sont "made in France".

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: perlmeditation [id://998803]
Approved by Athanasius
Front-paged by Athanasius
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others wandering the Monastery: (4)
As of 2024-03-19 09:39 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found