t5/az5112

Download the raw code.

#!/usr/bin/env perl6
# This is perl6 version 2012.01 built on parrot 3.11.0 revision 0


sub shorten ( @arr is copy ) {
    my $pos = @arr.end;
    my $sum = 0;

    loop ( ; $pos >= 0; $pos-- ) {
        my $value-at-pos = @arr[$pos];
        $sum += $value-at-pos;

        if $value-at-pos > 1 {
            my $new-value = $value-at-pos - 1;

            @arr.splice( $pos );
            @arr[ $pos ] = $new-value;
            $sum -= $new-value;

            while $sum {
                $new-value = $new-value < $sum ?? $new-value !! $sum;
                @arr.push( $new-value );
                $sum -= $new-value;
            }
            return @arr;
        }
    }
    return;
}

sub get-branch-lens( $remains is copy ) {
    my @res;
    my @row = $remains;

    while @row.elems {
        my @cp = @row;

        @res.push( @cp.item );
        @row = shorten( @row );
    }
    return @res;
}

sub append( @arr, @brr, $base ) {
    my @res;

    for @arr -> $a {
        for @brr -> $b {
            @res.push( ( $a, $base, $b ).join( "-" ) );
        }
    }

    if @arr.elems == 0 {
        for @brr -> $b {
            @res.push( "$b" );
        }

    }

    return @res;
}

sub generate-rooted-trees ( $start-at, $grow ) {
    if $grow == 0 {
        return [ "$start-at" ];
    }
    if $grow == 1 {
        my @vals = $start-at, $start-at + 1, $start-at;
        return [ @vals.join( "-" ) ];
    }

    my @arr = get-branch-lens( $grow );
    my @trees;

    for @arr -> @ar {
        my @growing-trees;
        my $grow-at = $start-at + 1;
        for @ar -> $a {
            my @growth = generate-rooted-trees( $grow-at, $a - 1 );
            @growing-trees = append( @growing-trees, @growth, $start-at );
            $grow-at += $a;
        }
        for @growing-trees {
            @trees.push( ($start-at, $_, $start-at).join( "-" ) );
        }
    }

    return @trees;
}

sub filter-trees ( @arr ) { # this is a joke :-)
    my %seen;
    my @res;

    for @arr -> $a {
        my %cnt = 1 => 1;

        my @nodes = $a.split( '-' );
        for @nodes -> $n {
            %cnt{ $n } += 2;
        }
        %cnt{ @nodes.end } -= 1;

        my $k = %cnt.values.sort.join( "-" );
        if not %seen.exists( $k ) {
            @res.push( $a );
            %seen{ $k } = 1;
        }
    }
    return @res;
}

sub MAIN ( Int $n ) {
    if $n <= 0 {
        exit 0;
    }
    elsif $n == 1 {
        say 1; exit 0;
    };

    my @rooted-trees = generate-rooted-trees( 2, $n.Int - 2 );
    my @unrooted-trees = filter-trees( @rooted-trees );

    for @unrooted-trees -> $t {
        say "1-$t";
    }
}

Correctness

The program fails for N = 6:

$ nom solutions/t5/az5112 6
1-2-3-4-5-6-5-4-3-2
1-2-3-4-5-4-6-4-3-2
1-2-3-4-3-5-3-6-3-2
1-2-3-4-3-5-3-2-6-2
1-2-3-2-4-2-5-2-6-2

That corresponds to these trees:

o--o--o--o--o--o

o--o--o--o--o
         |
         o

      o
      |
o--o--o--o
      |
      o

o--o--o--o
   |  |
   o  o

 o   o
  \ /
o--o--o
   |
   o

But there is a distinct sixth one, 1-2-3-4-5-4-3-6-3-2, which it should also have emitted:

o--o--o--o--o
      |
      o

The problem, in short, is that the filter-trees subroutine uses an equivalence relation which can't distinguish between this omitted tree and the second one. The equivalence relation is essentially "how many times was each node visited", which happens to be the same for these two trees.

Consistency

Nothing in particular to say here.

Clarity of intent

The code is nice, and clear. It doesn't get fancy.

The MAIN method is nice and clear because all the heavy lifting is done in routines that were defined before that.

This line seems confused beyond the reviewer's ability to explain it:

%cnt{ @nodes.end } -= 1;

Algorithmic efficiency

Not applicable as the program is incorrect.

Idiomatic use of Perl 6

The code leans more towards "generic procedural code" than towards exploiting the strengths of Perl 6 in particular.

On line 21 there's a missed opportunity to use min=.

These lines

my $pos = @arr.end;
loop ( ; $pos >= 0; $pos-- ) {

probably more idiomatically written as

for (^@arr).reverse -> $pos {

Brevity

The code lets itself breathe without being verbose.