[SPOILER] Re: Perl Quiz of the Week #23

On Thu, Sep 02, 2004 at 11:05:03PM -0700, Yitzchak Scott-Thoennes <[email protected]> wrote:
> It's going to be a long 60 hours; I've got a simple recursive solution
> (that I haven't had the patience to see if it will finish 15 pairs), a
> somewhat faster iterative by generation solution (that runs out of
> memory for 16 pairs), and am working on a memory-friendly subroutine
> that looks up the Nth string of a given width, that I'm hoping to
> transmogrify into a memory-friendly but fast-enough full solution.

Simple recursive:

========================================
use strict;
use warnings;

my $count = shift;
die "Usage: parens PAIRS\n",
    "Prints all strings of PAIRS balanced pairs of parentheses\n"
    if @ARGV or !defined($count) or $count !~ /^\d+\z/;

$, = "\n";
print parens($count), "" if $count;

sub parens {
    my $count = $_[0] or return "";

    my @strings;

    # generate the combinations for each possible number of pairs
    # that can follow the leftmost parentheses (from the first open
    # parenthesis to its matching close parentheses.)

    for my $after (0..$count-1) {

        # determine all possible strings that can appear after
        # or within the leftmost parentheses, and generate all
        # possible combinations of the two sets

        my @after = parens($after);
        for my $within (parens($count-1-$after)) {
            push @strings, map "($within)$_", @after;
        }
    }
    @strings;
}
========================================

Iterative by generations (runs out of memory at 400Mb doing 15 pairs),
quite a bit faster:

========================================
use strict;
use warnings;

my $count = shift;
die "Usage: parens PAIRS\n",
    "Prints all strings of PAIRS balanced pairs of parentheses\n"
    if @ARGV or !defined($count) or $count !~ /^\d+\z/;

my @generation = [""];
push @generation, strings($_) for 1..$count;

$\ = "\n";
if ($count) {
   print for @{strings($count)};
}

sub strings {
    my $count = shift;
    my @strings;

    # generate the combinations for each possible number of pairs
    # that can follow the leftmost parentheses (from the first open
    # parenthesis to its matching close parentheses.)

    for my $pairs_after (0..$count-1) {

        # determine all possible strings that can appear after
        # or within the leftmost parentheses, and generate all
        # possible combinations of the two sets

        my $after = $generation[$pairs_after];
        for my $within (@{$generation[$count-1-$pairs_after]}) {
            push @strings, "($within)$_" for @$after;
        }
    }

    \@strings;
}
========================================

I got it to do 15 pairs by duplicating the code in strings() in the main code
with replacing push with print; here's a slightly more complicated (and slow)
way of doing that without duplicating the code:

========================================
use strict;
use warnings;

my $count = shift;
die "Usage: parens PAIRS\n",
    "Prints all strings of PAIRS balanced pairs of parentheses\n"
    if @ARGV or !defined($count) or $count !~ /^\d+\z/;

my @generation = [""];
strings($_, $generation[$_]) for 1..$count-1;

$\ = "\n";
tie my @out, 'Out';
strings($count, \@out);

sub strings {
    my $count = shift;

    # generate the combinations for each possible number of pairs
    # that can follow the leftmost parentheses (from the first open
    # parenthesis to its matching close parentheses.)

    for my $pairs_after (0..$count-1) {

        # determine all possible strings that can appear after
        # or within the leftmost parentheses, and generate all
        # possible combinations of the two sets

        my $after = $generation[$pairs_after];
        for my $within (@{$generation[$count-1-$pairs_after]}) {
            push @{$_[0]}, "($within)$_" for @$after;
        }
    }
}

package Out;
sub TIEARRAY { bless {} }
sub FETCHSIZE { 42 }
sub PUSH { print $_[1] }

========================================

I don't know why FETCHSIZE is required.

Here's one that takes no memory to speak of, and is quite slow.  It does
have the advantage of starting to output right away, and could be changed
to resume output at an arbitrary line:

========================================

use strict;
use warnings;
use List::Util 'sum';

# slow, but doesn't use any memory to speak of; works for up to 19 pairs
# with 32-bit ints or 35 pairs with 64-bit ints

my $count = shift;
die "Usage: parens PAIRS\n",
    "Prints all strings of PAIRS balanced pairs of parentheses\n"
    if @ARGV or !defined($count) or $count !~ /^\d+\z/;

my @catalan = 1;
push @catalan, sum map $catalan[$_] * $catalan[$#catalan-$_], 0..$#catalan
    while @catalan <= $count;

sub string {
    my ($count, $index) = @_;
    return "" unless $count;

    my $in = 0;
    my $product;
    ++$in, $index -= $product
        while $index >= ($product = $catalan[$count-$in-1] * $catalan[$in]);

    "(".string($in, int($index % $catalan[$in])).")".
        string($count-1-$in, int($index / $catalan[$in]));
}

$\ = "\n";
if ($count) {
    print string($count, $_) for 0..$catalan[$count]-1;
}
========================================