[SPOILER] Perl QOTW #23

Below is my first cut.  I started with the base cases for n=0 and n=1,
and beyond that, I placed parens before, after, and around parens($n-1).
I thought assigning () to hash slices was a nice touch given the
program's goal.

I then saw Colin's and Daniel's posts about Catalan numbers and realized
there were a few cases I was missing, so I tried to bolt on a fix for
odd $n.

------------------------------------------------------

#! /usr/local/bin/perl

use warnings;
use strict;

sub usage {
    "Usage: $0 n\n" .
    "  where n is a decimal integer\n"
}

# memoizing doesn't seem to help
#memoize 'parens';

sub parens {
    my $n = shift;

    return ""   if $n <= 0;
    return "()" if $n == 1;

    my %uniq;
    @uniq{ "()$_", "($_)", "$_()" } = () for parens($n-1);

    if ($n & 1) {
        @uniq{ "()$_$_", "$_()$_", "$_$_()" } = () for parens(int($n/2));
    }
    else {
        $uniq{"$_$_"} = () for parens($n/2);
    }

    keys %uniq;
}

$0 =~ s,^.*[/\\],,;

my $n = @ARGV ? shift : "";

die usage unless $n =~ /^-?\d+$/;

print $_, "\n" for sort +parens $n;

------------------------------------------------------

I realized that I still wasn't seeing the expected number of lines of
output, so I wrote a branch-and-bound search:

------------------------------------------------------

#! /usr/local/bin/perl

use warnings;
use strict;

sub usage {
    "Usage: $0 n\n" .
    "  where n is a decimal integer\n"
}

sub valid {
    my $str = shift;

    my $l = 0;
    my $r = 0;

    for (split //, $str) {
        if ($_ eq "(") {
            ++$l;
        }
        elsif ($_ eq ")") {
            ++$r;
        }

        return if $r > $l;
    }

    #print "valid [$str]: l=$l, r=$r\n";
    $l == $r;
}

sub sofar {
    my $str = shift;

    my $l = 0;
    my $r = 0;

    for (split //, $str) {
        if ($_ eq "(") {
            ++$l;
        }
        elsif ($_ eq ")") {
            ++$r;
        }

        return if $r > $l;
    }

    #print "sofar [$str]: l=$l, r=$r\n";
    $l >= $r;
}

sub balanced {
    my $n    = shift;
    my $seen = shift;
    my $acc  = shift || "";

    #print "acc = [$acc], n=$n\n";

    if (length($acc) == $n*2) {
        ++$seen->{$acc} if $acc && valid($acc);

        return;
    }

    foreach my $p ("(", ")") {
        my $try = $acc . $p;

        balanced($n,$seen,$try) if sofar $try;
    }
}

$0 =~ s,^.*[/\\],,;

my $n = @ARGV ? shift : "";

die usage unless $n =~ /^-?\d+$/;

my $seen = {};
balanced $n, $seen;

print $_, "\n" for sort keys %$seen;

------------------------------------------------------

I then realized that $n was the number of nodes in a graph and that
by playing with edges and walking the "forest," I could get different
strings of balanced parentheses:

------------------------------------------------------

#! /usr/local/bin/perl

use warnings;
use strict;

sub usage {
    "Usage: $0 n\n" .
    "  where n is a decimal integer\n"
}

sub walk {
    my @forest = @{ shift @_ };

    return ""   if @forest == 0;
    return "()" if @forest == 1 and not @{ $forest[0] };

    join "", map "(" . walk($_) . ")", @forest;
}

sub move_left {
    my @f    = @{ shift @_ };
    my $uniq = shift;

    ++$uniq->{ walk \@f };

    foreach my $i (1 .. $#f) {
        my @new = @f;

        $new[$i-1] = [ @{ $f[$i-1] }, $f[$i] ];
        splice @new, $i, 1;
        ++$uniq->{ walk \@new };

        move_left(\@new, $uniq);
    }

}

sub parens {
    my $n = shift;

    return ""   if $n <= 0;
    return "()" if $n == 1;

    move_left [ map [], 1..$n ], \my %uniq;

    keys %uniq;
}

$0 =~ s,^.*[/\\],,;

my $n = @ARGV ? shift : "";

die usage unless $n =~ /^-?\d+$/;

print $_, "\n" for sort +parens $n;

------------------------------------------------------

My next move was to inline code and convert recursion to iteration in
an attempt to improved performance:

------------------------------------------------------

#! /usr/local/bin/perl

use warnings;
use strict;

sub usage {
    "Usage: $0 n\n" .
    "  where n is a decimal integer\n"
}

sub parens {
    my $n = shift;

    return if $n <= 0;

    if ($n == 1) {
        print "()\n";
        return;
    }

    my %uniq;  # valid strings

    my @agenda = [ map [], 1..$n ];

    my $STOP = 42;

    while (@agenda) {
        my $f = shift @agenda;

        my $trav;
        my @walk = @$f;
        while (@walk) {
            my $item = shift @walk;

            if ($item == $STOP) {
                $trav .= ")";
            }
            else {
                $trav .= "(";

                unshift @walk => @$item, $STOP;
            }
        }

        next if $uniq{$trav}++;
        print $trav, "\n";

        foreach my $i (1 .. $#$f) {
            my @new = @$f;

            $new[$i-1] = [ @{ $new[$i-1] }, $new[$i] ];
            splice @new, $i, 1;

            unshift @agenda => \@new;
        }
    }

    return;
}

$0 =~ s,^.*[/\\],,;

my $n = @ARGV ? shift : "";

die usage unless $n =~ /^-?\d+$/;

parens $n;

------------------------------------------------------

I also realized that all the creating of anonymous array refs was
killing performance, so my final approach was to start with a valid
string and perform transformations that would yield valid strings:

------------------------------------------------------

#! /usr/local/bin/perl

use warnings;
use strict;

sub usage {
    "Usage: $0 n\n" .
    "  where n is a decimal integer\n"
}

sub parens {
    my $n = shift;

    return if $n <= 0;

    if ($n == 1) {
        print "()\n";
        return;
    }

    my %uniq;  # valid strings

    my @agenda = join " " => map "()", 1..$n;

    (my $copy = $agenda[0]) =~ tr/ //d;
    print $copy, "\n";

    my($f,$orig);

    while (@agenda) {
        $f = pop @agenda;

        $orig = $f;
        while ($f =~ s/\G(\(\S*\)) +\((\S*)\)(?: +|$)/($1 $2) /) {
            ($copy = $f) =~ tr/ //d;
            unless ($uniq{$copy}++) {
                print $copy, "\n";
                push @agenda, $f;
            }

            $f = $orig;
            pos($f) = $-[2] - 1;
        }
    }

    return;
}

$0 =~ s,^.*[/\\],,;

my $n = @ARGV ? shift : "";

die usage unless $n =~ /^-?\d+$/;

parens $n;

------------------------------------------------------

Performance isn't great, but I was pleased with the technique of backing
up pos($f) and using \G in the pattern to effect an overlapping match.

Enjoy,
Greg