t5/zbiciak

Download the raw code.

#!/usr/local/bin/perl6

# Use Algorithm O from Knuth 7.2.1.6 to generate all "free trees".
#
# Algorithm O generates oriented forests.  A modification described in
# exercise 90 from 7.2.1.6 indicates how to modify this algorithm to
# generate free trees, which is the name Knuth uses for unrooted trees.
sub Modified_Algorithm_7216O(Int $nodes)
{
    my (@p, Int $i, Int $j, Int $k, Int $d, Int $m, Int $kk);

    # O1. [Initialize]  Set p[k] = k - 1 for 0 <= k <= n.
    #                   Let m = floor(n/2).  Set p[m+1] = 0.
    #                   Set p[2m+1] = 0 if n is odd. (?)
    $m = $nodes div 2;
    @p = -1 ..^ $nodes;
    @p[  $m + 1] = 0;
#   @p[2*$m + 1] = 0 if !($nodes %% 2);  # Is this an error in Knuth?

    while (1)
    {
        # O2. [Visit]   Visit the forest represented by parent pointers 
        #               p[1] .. p[n].  If you include node 0 (with parent
        #               -1), this represents a unique "free tree".
        emit(@p[0..$nodes]);

        # O3. [Easy case?]  If p[n] > 0, set p[n] = p[p[n]] and
        #                   return to step O2.
        if (@p[$nodes] > 0) {
            @p[$nodes] = @p[@p[$nodes]];
            next;
        }

        # O4. [Find j and k.]   Find the largest k < n such that p[k] != 0.
        #                       Terminate the algorithm if k = 0; otherwise
        #                       set j = p[k] and d = k - j;

        for 0 ..^ $nodes -> $kk {
            $k = $kk if @p[$kk] != 0;
        }

        return if $k == 0;

        $j = @p[$k];
        $d = $k - $j;

        # O4'. [Extension]  Set i = j.  While p[i] != 0, set i = p[i];
        #                   Then i is the root of the tree containing j
        #                   and k.
        $i = $j;
        while (@p[$i] != 0) { $i = @p[$i]; }

        # O5'. [Extension]  If k = i + m and i < j, set j = i and d = m.
        if $k == $i + $m && $i < $j {
            $j = $i;
            $d = $m;
        }

        # O5. [Clone.]  If p[k-d] = p[j], set p[k] = p[j]; otherwise set
        #               p[k] = p[k-d] + d.
        #
        #               Return to O2 if k = n, otherwise set k = k + 1
        #               and repeat this step.
        repeat {
            @p[$k] = @p[$k - $d] == @p[$j] ?? @p[$j] !! @p[$k - $d] + $d;
        } while ($k++ != $nodes);
        $k = $nodes;
    }
}

# Find and print the traversal path through the tree given the parents
# table computed by the modified Algorithm 7.2.1.6O.
sub emit(@parents)
{
    my %p_tree = @parents.pairs;
    my %tree; 

    %tree.push( %p_tree.invert );   # Convert parent pointers to children.
    %tree.delete(-1);               # Don't need -1 node.

    my $visited = 0;

    sub recurse($node)
    {
        my $name = ++$visited;
        my @path = ( $name );

        if %tree{$node}.defined {
            for @( %tree{$node} ) {
                push @path, recurse($_), $name;
            } 
        }
        return @path;
    }

    my  @path = recurse(0);
    pop @path;              # Omit last step that takes us back to 1

    say @path.join("-");
}


sub MAIN($nodes)
{
    Modified_Algorithm_7216O($nodes.Int - 1);
}

Correctness

The program is incorrect, which is a shame, because it's really nice. I guess the lesson here is "Never go against Donald Knuth when correctness is on the line."

The fix is not as simple as just removing the commented-out line. Things are still wrong after that.

Consistency

Inconsistent use of parentheses around some conditions and not others.

Clarity of intent

Very nicely and carefully laid out. The relationship with the original algorithm from the book is immediate.

Algorithmic efficiency

Not applicable since the program is incorrect.

Idiomatic use of Perl 6

while (1) perhaps better written loop.

Brevity

One of the shortest programs in terms of lines. Definitely the shortest in terms of lines of code.