#!perl

use constant MIN_INTERESTING => 5;
# (The suggested heuristic of > 4 produced too many duds, as it did
# not exclude, for instance, sibyl/Sybil.)

{
package Partition;

use strict;

use vars '$VERSION';
$VERSION = 0.10;

=head1 NAME

Partition - enumerate possible divisions of a pile of tokens

=head1 SYNOPSIS

    use Partition;
    my $p = Partition->new(4);
    do {
      print join("_", $p->partition("foo!")), " ";
    } while $p->inc;
    # prints the following:
    #   foo! foo_! fo_o! f_oo! fo_o_! f_oo_! f_o_o! f_o_o_!

=head1 DESCRIPTION

C<Partition> objects represent possible ways that a given
number of tokens can be divided into an ordered list of
non-empty groups.  There will be C<2**(n-1)> such ways to
divide up C<n> tokens.  A single C<Partition> can be used to
iterate over the entire space of possible divisions in a
predictable order.

=head1 CLASS METHODS

=head2 new

Takes one argument: the number of tokens to be divided.
Returns a C<Partition> object initialized to the first
possible grouping, which consists of a single group
containing all of the tokens.

=cut

sub new {
  my ($class, $length) = @_;
  bless [ $length ], ref $class ? ref $class : $class;
}

=head1 INSTANCE METHODS

=head2 clone

Returns a copy of a C<Partition> object.

=cut

sub clone {
  my ($self) = @_;
  [ @$self ];
}

=head2 groups

In array context, returns the sizes of the groups that
make up the current arrangement; in scalar context,
returns the number of groups.

=cut

sub groups {
  @{$_[0]};
}

=head2 size

Returns the total number of tokens being partitioned.

=cut

sub size {
  my $tot = 0;
  foreach my $n (@{$_[0]}) {
    $tot += $n;
  }
  $tot;
}

=head2 inc

Advances a C<Partition> to the next arrangement.
Returns the number of groups in the new arrangement,
or undef if there are no possible arrangements that
have not already been considered (in which case the
object will not be changed).  The algorithm generates
all possible arrangements of C<n> groups before any
arrangement of C<n+1> groups.

=cut

sub inc {
  my ($part) = @_;
  my $len = @$part;
  my $last = $part->[-1];
  # Think of the partition as a row of piles of tokens.
  # Working from right to left, and skipping over the
  # rightmost pile, find the first pile that contains
  # more than one token.
  for (my $i = -2; $i >= -$len; --$i) {
    if ($part->[$i] != 1) {
      # Swap the pile to the right of this pile with the
      # rightmost pile.  (Exercise for the reader: How
      # many tokens must be in the pile to the right of
      # this pile?)
      @$part[$i+1, -1] = ($last, 1)
        unless $i == -2;
      # Move one token from this pile to the pile to its
      # right.
      --$part->[$i];
      ++$part->[$i+1];
      # Done.
      return $len;
    }
  }
  # If we've arrived here, all piles (except possibly
  # the rightmost) started with only one token.
  if ($last == 1) {
    # We've exhausted the space of possible partitions.
    return undef;
  }
  # Swap the leftmost and rightmost piles, then take one
  # token from the leftmost pile and use it to start a
  # new pile at the right end.
  $part->[-1] = 1;
  $part->[0] = $last - 1;
  push @$part, 1;
}

=head2 partition

Divides a string or an array reference into an array of
substrings or references to subarrays in accordance with
the C<Partition>'s current arrangement.  Elements of the
input are not permuted.

=cut

sub partition {
  my ($part, $target) = @_;
  my $pos = 0;
  my (@chunks) = ();
  if (ref $target) {
    foreach my $len (@$part) {
      push @chunks, [ @$target[$pos .. $pos+$len] ];
      $pos += $len;
    }
  } else {
    foreach my $len (@$part) {
      push @chunks, substr($target, $pos, $len);
      $pos += $len;
    }
  }
  @chunks;
}

=head1 COPYRIGHT

Copyright E<copy> 2002, Seth L. Blumberg
E<lt>sethb@pobox.comE<gt>.  All Rights Reserved.  This
program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

This program is distributed in the hope that it will be
useful, but without any warranty; without even the implied
warranty of merchantability or fitness for a particular
purpose.

=head1 AUTHOR

Seth L. Blumberg E<lt>sethb@pobox.comE<gt>

=cut

1;
}

use strict;

#use Partition 0.10;
use Carp 'croak';

# Will not work properly on words with embedded NULs.
# There are lots of those in the English language, too,
# so it's a real problem.

sub try_chunks {
    my ($word, $chunk, @chunks) = @_;
    return $word !~ tr/\0//c unless defined $chunk;
    my $re = qr/\Q$chunk/;
    my $len = length $chunk;
    my @pos;
    while ($word =~ /$re/g) {
	my $p = $-[0];
	push @pos, $p;
	pos($word) = $p + 1;
    }
    foreach my $p (@pos) {
	my $t = $word;
	substr($t, $p, $len) = "\0";
	return @chunks + 1
	    if try_chunks($t, @chunks);
    }
    0;
}

sub min_chunks {
    my ($word, $drow) = @_;
    my $p = new Partition length $word;
    do {
	my $n = try_chunks $drow, partition $p $word;
	return $n if $n;
    } while inc $p;
    croak "\"$word\" is not an anagram of \"$drow\"\n";
}

# Assumes STDIN contains the output from this week's non-expert quiz
# solution.

while (<>) {
    next if /\(/;
    my (@words) = split /\s+/;
    while (my $head = shift @words) {
	foreach my $word (@words) {
	    print "$head $word\n"
		if min_chunks($head, $word) == MIN_INTERESTING;
	}
    }
}
__END__

-- 
Seth Blumberg, a.k.a. Metal Fatigue, a.k.a. Nodens <sethb@pobox.com> O-
-  --  ---  -----  --------  -------------  --------  -----  ---  --  -
"Faced with the prospect of rereading this book, I would rather have my
 brains ripped out with a plastic fork."           -- ZDnet book review
