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

A friend of mine pointed me to a solution  from The Computer Journal,
"O(1) Time Algorithms for Combinatorial Generation by Tree Traversal."

http://www3.oup.co.uk/computer_journal/hdb/Volume_42/Issue_05/pdf/420400.pdf

Here's a fairly direct translation from the Pascal given there:

my $n = shift;
my (@q, @s, @d, @solved, @up, @c);
@q[1..(2 * $n)] = (('(') x ($n), (')') x ($n));
@s[0..$n] = (0) x ($n+1);
@d[1..$n] = (1) x ($n);
@solved[0..$n] = 0;
$up[$_] = $_ for (0..$n);
$c[$n-1] = 1;
$d[0] = 0;
my $i;
do {
  print join '', @q[1..$#q], "\n";
  $i = $up[$n-1];
  $up[$n-1] = $n - 1;
  if ($d[$i] > 0) {
    swap($q[$i+$s[$i]+1],$q[$i+$s[$i]+1+$c[$i]]);
  } else {
    swap($q[$i+$s[$i]], $q[$i+$s[$i]+$c[$i]]);
  }
  $s[$i] += $d[$i];
  my $b = ($up[$i-1] == $i-1 or $solved[$i-1]) ? $s[$i-1] : $s[$i-1] -
$d[$up[$i-1]];
  if (($d[$i] > 0 and $s[$i] == $i) or ($d[$i] < 0 and $s[$i] == $b)) {
    if ($d[$i] < 0 and !$solved[$i - 1]) {
      $solved[$i] = 0;
      $s[$i] = $s[$i] + $d[$up[$i-1]];
    }
    else {
      $solved[$i] = 1;
    }
    $up[$i] = $up[$i-1];
    $up[$i-1] = $i - 1;
    $c[$up[$i]] = $i - $up[$i] if !$solved[$i-1] and $solved[$i];
    $c[$up[$i]] = $n - $up[$i] if !$solved[$i]  and $i == $n-1;
    $solved[$i-1] = 0;
    $d[$i] *= -1;
  }
} while ($i > 0);

sub swap {
  ($_[0], $_[1]) = ($_[1], $_[0]);
}

Despite how convoluted it looks, it's generating a solution per
iteration, so it's reasonably fast.