Parsing a Tree to a Table.

[choroba]

Recently, I noticed an interesting question on StackOverflow. It reminded me of my solution to the task "Visualize a Tree" on Rosetta Code.

I tried to solve the task. If you want to see me solving the task, watch a YouTube screencast. If you just want to see the solution (almost identical to the one in the video), check below.

<Reveal this spoiler or all in this thread>

[oiskuu]

Why is the question on hold at SO? Looks like someones homework alright, but to reverse tree visualisation is a valid problem and potentially useful to someone. Anyway, I hoped there would be some extra neat solution, then spent ten minutes correcting one silly mistake after another. Almost a one-liner:

#! /usr/bin/perl -ln
/\|\s*$/ or /.*?--(-?)|/, splice(@a,$+[0]/3), $1 ? print join "\t", @a
+[0..2], $' : push @a, $';

[choroba]

If I understand it correctly, it only works for the trees of depth 4, right?

[oiskuu]

Well, it prints as it goes, so prior knowledge of max depth is needed. (Adding this as option is trivial.)

Note that the problem description shows four output columns, and mentions large data.

[BrowserUk]

For fun.

#! perl -slw
use strict;

my @a;
my $last = 0;

while( <DATA> ) {
    m[(^[^A-Z]+)?([A-Z]+)] or next;
    my $l = length( $1//'' );
    if( @a and $l <= $last ) {
        print join "\t", @a;
        pop @a for 1 .. ($last-$l+3)/3;
    }
    push @a, $2;
    $last = $l;
}
print join "\t", @a;


__DATA__
A
|
|--B
|  |
|  |--C
|     |
|     |---PQR
|     |---XYZ
|--D
|  |
|  |---LMN
|---XYZ

[Discipulus]

hello,
about the rosetta code: it says nor the tree or the output are important. For me a tree is always an HoH and this remember me an ancient piece of code i wrote long time ago (little refurbished to run under strict... now i'm little wiser ;=) ).

use strict;
use warnings;

my %h1=('qwqw' => {'qw' => 'qww','df' => 'dfff','C1' => {'A2' => 'a2',
+'B2' => 'b2','C2' => 'c2END'}},);
my %h2=(
'AAA' => 'aaa',
'BBB' => 'bbb',
'CCC' => {'A1' => 'a1','B1' => 'b1','C1' => {'A2' => 'a2','B2' => 'b2'
+,'C2' => 'c2END'}},
'DDD' => 'ddd',
'EEE' => \%h1,
'FFF' => 'sdsfsds',
);

&ddump(\%h2);


sub ddump
{
  my $ref  = shift;
  my $deep = shift||0;
  foreach my $k (sort keys %{$ref})     {
            if (ref( ${$ref}{$k}))  {print "\t" x $deep."$k =>\n"; &dd
+ump (${$ref}{$k}, ($deep+1))}
            else {print "\t" x ($deep)."$k => ${$ref}{$k}\n";}
  }
}


PS I noticed something I do not understand: if you change $deep+1 whit ++$deep the beahaviur change: why? in docs i learn:

Note that just as in C, Perl doesn't define when the variable is incremented or decremented. You just know it will be      done sometime before or after the value is returned. This also means that modifying a variable twice in the same statement will lead to undefined behavior.
 

Is this the case?
L*

[Athanasius]

The behaviour here has nothing to do with when the increment operation is applied. $deep + 1 evaluates to 1 more than the current value of $deep, but leaves that value unchanged. ++$deep (or $deep++) changes the variable’s value by incrementing it, so that on the next iteration of the foreach loop, $deep is larger (by 1) than it was before. ++$deep is equivalent to $deep += 1 — the latter form makes the change to the variable explicit via the presence of an assignment operator.

Hope that helps,

[Discipulus]

OMG what a stupid's moment passed to me!!
thanks
L*

[hdb]

Very nice puzzle. Here is my solution:

use warnings;
use strict;

my @path;
my @data;
my $size = 0;
while(<DATA>) {
    chomp;
    $path[0]            = $1 if /^([^|]*)$/;
    $path[length($1)/3] = $2 if /^(.*\|--)([^-]+)$/;
    if( /^(.*\|--)-([^-]+)$/ ) {
        $#path = length($1)/3 - 1;
        push @data, [ @path, $2 ];
        $size = @path if $size < @path;
    }
}
splice @$_, -1, 0, ('')x(1+$size-@$_) for @data;
print join( "\t", @$_ ),"\n" for @data;

__DATA__
A
|
|--B
|  |
|  |--C
|     | 
|     |---PQR
|     |---XYZ
|--D
|  |
|  |---LMN
|---XYZ

[Discipulus]

just a convoluted tree prettyfication


use warnings;
use strict;

my @tab;

while(my $l = readline (*DATA) ) {
     @{$tab[$.-1]}= split '',$l ;
     foreach my $i (0..$#{$tab[$.-1]})  {
         unless ($. == 1) { ${$tab[$.-1]}[$i] =~ s/\|/${$tab[$.-2]}[$i
+]/g if defined ${$tab[$.-2]}[$i]  }
     }
}

foreach my $row (@tab) {
        print @{$row};
}
__DATA__
A
|
|--B
|  |
|  |--C
|     |
|     |---PQR
|     |---XYZ
|--D
|  |
|  |---LMN
|---XYZ
X
|---000


cya
L*

[LanX]

As a side note @RosettaStone: Many languages just showed their Data::Dumper equivalent! :-|

my emphasize is on readability and flexibility for alternative formats, but YMMV! =)

#!/usr/bin/perl
use warnings;
use strict;
use Data::Dump qw/pp/;
#use diagnostics;

use Test::More tests => 1;

my $input = <<'__IN__';
A 
|
|--B 
|  |
|  |--C
|     | 
|     |---PQR
|     |---XYZ
|--D
|  |
|  |---LMN
|---XYZ
__IN__

my $expected = <<'__EXP__';
Column1    Column2    Column3    Column4    
A    B    C    PQR
A    B    C    XYZ
A    D        LMN
A            XYZ
__EXP__

  
my (@path,@table);
my $max=0;



for (split /\n/, $input) {
  #print ;
  /^ (.*?) (---(\w\w\w))? $ /x;

  my $leave = $3;
  my @track = split /  |--/, $1;

  die "parsing error $_"
    unless @track;

  $path[$#track] = $1
    if ($track[-1] =~ /(\w)/ );
  
  #pp [@track], [@path], $leave;    

  if ($leave) {
    push @table, [ @path[0..$#track], $leave ];
    $max = @track if @track >$max;
  }
  
}

pp \@table;

my $out="";

$out .= "Column$_\t" for 1..$max+1;
$out .= "\n";
for (@table){
  my $width = @$_-1;
  $out .= join "\t", @$_[0..$width-1];
  $out .= "\t"x($max-$width+1);
  $out .= @$_[$width];
  $out .= "\n";
}

print $out;

is($out,$expected);

1..1
[
  ["A", "B", "C", "PQR"],
  ["A", "B", "C", "XYZ"],
  ["A", "D", "LMN"],
  ["A", "XYZ"],
]
Column1    Column2    Column3    Column4    
A    B    C    PQR
A    B    C    XYZ
A    D        LMN
A            XYZ