#!/usr/bin/perl -w
use strict;

# Dear Monks
#
# I am trying to solve a permutation probelm and looking for
#
# pointers. The different permutation we can create by putting pair of
# paranthesis before,after or in between given number.  Example: for p=2
# and n= 123, we may have:
#
# (1) (2) 3
# (1) 2 (3)
# (1 2) (3)
# (1 (2 3))
# ((1 2 3))
# 1 ((2 3))
#
# etc..
# Thanks,
# artist
#
# --------------------------------------------------------
#
# Given n=3, p=2 as above, without parens we have n+1=4
# places where parens can be placed, i.e. on the dots in
#
#  . 1 . 2 . 3 .
#
# Assuming that arrangements like "() 1 2 3" are illegal,
# a left-paren may be placed at a dot numbered
# L=0..(n-1) and its corresponding right-paren at R=(L+1)..n
#
# Therefore the number of ways I can place a single pair
# of parens around n digits is
#
#        3   (1) 2  3  , (1  2) 3  , (1 2 3)      L=0; R=1,2,3
#      + 2    1 (2) 3  ,  1 (2  3)                L=1; R=2,3
#      + 1    1  2 (3)                            L=2; R=3
#      ---
#  total 6 = (n)(n+1)/2
#
# Now let's try to place another pair of parens.
# These can be put at the same dot locations; 
# the trick will be to avoid counting arrangements like
# "(1)(2)3" twice.  For visual clarity, I'll use
# sqaure brackets for the second parens, working 
# forward from the six single paren patterns above.
#
# For the first pattern "(1) 2 3", adding a second
# pair of brackets again gives six possibilities.
#
#  [(1)] 2  3   , [(1) 2] 3  , [(1) 2 3]                    6 new
#   (1) [2] 3   , (1) [2  3]
#   (1)  2 [3]
#
# However, trying the same approach to the second
# pattern "(1 2) 3" starts to give arrangments that
# have already been found.  (Remember that the []
# and () symbols are actually identical and interchangeable.)
#
# Try all six combinations starting from the next
# single pattern "(1 2) 3" gives
#  ([1] 2) 3 *OLD*,  ([1 2]) 3 *NEW*,  [(1 2) 3] *NEW*      +5 new
#  (1 [2]) 3 *NEW*,  (1 [2) 3] *NEW*,  
#  (1 2) [3] *NEW*
# of which the first is a repeat of "[(1) 2] 3" and 
# the rest are new.  
#
# Continuing in the same vein gives
#
# ([1] 2 3) *OLD*, ([1 2] 3) *OLD*, [(1 2 3)] *NEW*         +3 new
# (1 [2] 3) *OLD*, (1 [2 3]) *NEW*,
# (1 2 [3]) *NEW*
#
# Hmmm.  I stared at this but haven't really found an obvious pattern.
#
# But whether there is or not, feels like its time
# to write some code.  If I loop over all the possible
# positions of the left and right parens, as I'm doing above,
# I can just remember which ones I've found already in 
# a hash, and keep the new ones.
#
# This may not be the most efficient, but it'll get the job done.
#
# Here's what the output look like :
#
#  Looking for permutations of 2 pairs of parens around 3 digits. 
#  ((1))23
#  ((1)2)3
#  ((1)23)
#  (1)(2)3
#  (1)(23)
#  (1)2(3)
#  ((12))3
#  ((12)3)
#  (1(2))3
#  (1(2)3)
#  (12)(3)
#  ((123))
#  (1(23))
#  (12(3))
#  1((2))3
#  1((2)3)
#  1(2)(3)
#  1((23))
#  1(2(3))
#  12((3))
#  Total number of permutations = 20

my $n;                  # number of digits
my $p;                  # number of paren pairs
my @leftparens;         # count of left parens at each position
my @rightparens;        # count of right parens at each position
my %seen;               # permutations generated
my $DEBUG = 0;

init(3,2);        # define n,p
print " Looking for permutations of $p pairs of parens around $n digits. \n";
addParenPair(1);  # add first pair of parens, and others recursively
print " Total number of permutations = " . scalar(keys %seen) . "\n";

# ------------------------------------------------------------

sub init {
  ($n, $p) = @_;
  @leftparens  = (0)x($n+1);
  @rightparens = (0)x($n+1);
  %seen = ();
}

# Convert current permutation as recorded in @leftparens and @rightparens to a string.
sub permutationAsString {
  my $result = "("x$leftparens[0];
  for my $digit (1..$n){
    $result .= $digit . ")"x$rightparens[$digit] . "("x$leftparens[$digit];
  }
  return $result;
}

# If we haven't seen this one, remember it and print it out.
sub analyzePermutation {
  my $permutation = permutationAsString();
  unless ($seen{$permutation}){
    $seen{$permutation}++;
    print " " . $permutation . "\n";
  }
}

# Recursive descent routine to put in next pair of parens
# and analyze the result if all the parens have been placed.
# If $DEBUG is true, it'll also print some progress reports.
sub addParenPair {
  my ($whichPair) = @_;
  for my $left (0..($n-1)){
    $leftparens[$left]++;
    for my $right (($left+1)..$n){
      $rightparens[$right]++;
      if ($whichPair == $p){
        analyzePermutation();
      }
      else {
        if ($DEBUG){
          print "  "x$whichPair . 
            "Permutation so far is " . 
            permutationAsString() . "; adding pair " . ($whichPair+1) . "\n";
        }
        my $lastCount = scalar(keys %seen);
        addParenPair($whichPair+1);
        my $newPerms = scalar(keys %seen) - $lastCount;
        if ($DEBUG){
          print "  "x$whichPair . "new permutations added = $newPerms. \n";
        }
      }
      $rightparens[$right]--;
    }
    $leftparens[$left]--;
  }
}