[Spoiler] QotW 23

Well, as it turns out, the times I posted before were too good to be 
true. At higher levels of N, it failed to produce all the results. 
Namely, those of the form (()())(()()).

But, I do have several solutions that do work. This entire project is 
rather beastly, because I was stuck somewhere boring with my laptop, and 
amused myself with "How many different ways can I solve this?" Many of 
them are serious, some of them are.... discouraged. I'm looking forward 
to seeing if anyone comes up with any algorithms I didn't.

I never really bothered optimizing, but I did add the ability to time 
for curiosity. Nor did I strain for the most elegant form of a given 
technique. Most of my time was spent coming up with new ways of doing 
it. I did force myself against coming up with more solutions like 
"Testing - eval w/ comma".

Comments in code should explain the different techniques.

Questions welcome.

-- Rod Adams



#!/usr/bin/perl

use Time::HiRes qw( time );

use Memoize;
memoize('Nested');

use constant ( EnablePrint => 1 ); # Turn on Timing only mode or not.

our $Pairs = $ARGV[0] or die "Must specify length.\n";
our @AllStrings;


###
### Main execution block
###
#
# What's up with this convuluted structure? Well, I wanted an easy
# way to print all the results in a consistant fashion. I also wanted
# to be able to quickly disable various tests from running during testing.
#
# Doesn't really belong in a 'normal' class QotW, but it should be
# instructive to those who hadn't seen anything like it before.
#

our @Routines =
    (
     ['Counting'             => sub{ 
Counting('',$Pairs,0)                 }],
     ['Nested'               => sub{ if (EnablePrint)
                     { print map(($_,"\n"),Nested($Pairs))}
                     else { Nested($Pairs) }               }],
     ['AddClosing'           => sub{ 
AddClosing($Pairs)                    }],
     ['Insert'               => sub{ 
Insert($Pairs)                        }],
     ['Shifter'              => sub{ 
Shifter($Pairs)                       }],
    
     ['MakeAllStrings'       => sub{ MakeAllStrings('',$Pairs, 
$Pairs)     }],
    
     ['Test - Removal'       => sub{ 
TestRemoval()                         }],
     ['Test - RE'            => sub{ 
TestRE()                              }],
     ['Test - eval w/ comma' => sub{ 
TestEvalComma()                       }],
     ['Test - eval as RE'    => sub{ 
TestEvalRE()                          }],
     );


for my $Routine (@Routines) {
  my ($name, $rSub) = @$Routine;
 
  if (EnablePrint) {
    # do a big fancy header
    print ("\n\n", $name, "\n", '-' x length($name), "\n");
    my $start = time;
    $rSub->();
    printf "%0.2f seconds\n", time - $start;
  } else {
    # something more terse
   
    print "\n" if $name eq 'MakeAllStrings';
    my $start = time;
    $rSub->();
    printf "%-20s %0.2fs\n", $name, time - $start;
  }
}



###
### And now the routines
###



sub Counting {
  # Builds the string, keeping track of how many open and close parens it
  # has left to add. Careful use of +1 and -1 in the recursion ensures the
  # end result is balanced.
  #
  # I consider this one of the 'classic' approaches to the problem.

  my ($prefix, $open, $close) = @_;
  if ($open) {
    Counting("$prefix(", $open-1, $close+1);
    Counting("$prefix)", $open,   $close-1) if $close;
  } else {
    print $prefix, ')' x $close, "\n" if EnablePrint;
  }
}



sub Nested {
  # For a specified length, it generates the pattern
  # (_)_ where the _ are of length multiple two, and the overall length is
  # one requested. It creates this pattern for all possible lengths of __.
  # Then, for each _, it calls itself, and fills in all returns.
  #
  # Memoized for severe performance boost

  my ($maxlength) = @_;
  return('') if $maxlength <= 0;

  my @result;
  for my $length (0..$maxlength-1) {
    my @inside = Nested($length);
    my @after  = Nested($maxlength-$length-1);
    for my $inside (@inside) {
      for my $after (@after) {
    push @result, '(' . $inside . ')' . $after;
      }
    }
  }
  return @result;
}



sub AddClosing {
  # Start with appropriate length (((( string. Then, add each ) one at a 
time,
  # and use all the possible positions it can be in, then recurse to the 
next
  # ) that in the line. On the last ), print.


  my ($length) = @_;
 
  my $start = '(' x $length;
  _addclosing($start, 0, 1);
 
  sub _addclosing {
    my ($string, $min, $cnt) = @_;
   
    if ($cnt == $length) {
      print $string, ')', "\n" if EnablePrint;
    } else {
      my $altmin = 2*$cnt - 1;
      $min = $altmin if $altmin > $min;
      my $max = length($string);

      for my $x ($min .. $max) {
    my $newstring = $string;
    substr($newstring, $x, 0, ')');
    _addclosing($newstring, $x+1, $cnt+1);
      }
    }
  }
}



sub Insert {
  # Given any previously properly balanced string of parens, including the
  # empty string, you can insert a '()' at any position you feel like, and
  # it will remain a properly balanced string.
  # Unfortunately, I couldn't come up with a way of doing this to avoid
  # creating the same pattern more than once, so I had to add a %seen hash.

  my ($length) = @_;
  my %seen = ();
  _insert('',$length);

  sub _insert {
    my ($string, $left) = @_;
    for (my $x = 0 ; $x <= length($string) ; ++$x) {
      my $newstring = $string;
      substr($newstring,$x,0,'()');
      next if $seen{$newstring}++;
      if ($left == 1) {
    print "$newstring\n" if EnablePrint;
      } else {
    _insert($newstring, $left - 1);
      }
    }
  }
}



sub Shifter {
  # Start off with a string like '((()))', for the desired length.
  # At all times, one can swap a () with a )( as long as there are more ('s
  # than )'s in front of it. So I proceed to keep shifting the )'s forward,
  # as much as possible, and after each move printing, and then see if I 
made
  # room for and )'s behind the move to now move forward some more, etc.

  my ($length) = @_;
  my $start = '(' x $length . ')' x $length;
  print "$start\n" if EnablePrint;
  _shifter($start, 1);

  sub _shifter {
    my ($string, $position) = @_;
    my $pre = $position-1;
    $string =~ /^( (?: \(*\) ){$pre} ) ( \(* \) )  (.*)$/x;
    my ($prefix, $mover, $postfix) = ($1, $2, $3);

    # this is the tricky part.. calculating the amount you can move it.
    my $maxmoves = (length($mover)-1) - (length($prefix) > 2*$pre ? 0 : 1);
    while ($maxmoves-- > 0) {
      $mover =~ s/\(\)/\)\(/;
      my $newstring = "$prefix$mover$postfix";
      print "$newstring\n" if EnablePrint;
      _shifter($newstring, $position+1) if $position < $length;
    }
  }
}



sub MakeAllStrings {
  # The rest of the methods are just tests (some sane, others not), so here
  # I create a list of all strings containing just '(' and ')' in the 
correct
  # numbers, but not neccessarily the right order.

  my ($prefix, $open, $close) = @_;
  if ($open == 0 && $close == 0) {
    push @AllStrings, $prefix;
  } else {
    MakeAllStrings($prefix . '(', $open-1, $close) if $open;
    MakeAllStrings($prefix . ')', $open, $close-1) if $close;
  }
}



sub TestRemoval {
  # Continually remove any occurance of '()'. When it cannot be done any 
more,
  # you either have an empty string, or not. If empty, it was balanced.

  for my $string (@AllStrings) {
    my $s = $string;
    1 while $s =~ s/\(\)//g;
    unless ($s) {
      print "$string\n" if EnablePrint;
    }
  }
}



sub TestRE {
  # Use a nifty Regular Expression to test for balance.
  # `perldoc perlre` if you want a version which allows letters.
 
  my $re;
  $re = qr/ ( \( (??{$re}) \) )* /x;

  for my $s (@AllStrings) {
    if ($s =~ /^$re$/) {
      print "$s\n" if EnablePrint;
    }
  }
}



sub TestEvalComma {
  # Why do all the work yourself, when the Perl compiler can do it for you?
  # Adds a comma after each ) so that the whole thing will compile and
  # evaluate as a list of empty lists, or some such, if balanced.

  for my $string (@AllStrings) {
    my $s = $string;
    $s =~ s/\)/\),/g;
    eval($s);
    unless ($@) {
      print "$string\n" if EnablePrint;
    }
  }
}



sub TestEvalRE {
  # Again, let Perl do the work for you. This time try to make it a
  # Regular Expression. If it compiles, it's balanced....

  for my $s (@AllStrings) {
    eval("qr/$s/");
    unless ($@) {
      print "$s\n" if EnablePrint;
    }
  }
}

__END__