#!/usr/bin/perl -w

# Solution for Perl QotW #4 Expert Quiz
# http://perl.plover.com/qotw/e/004

use strict;

# Being lazy -- didn't feel like thinking of a good variable name
my %h;
# Load words, grouped by common anagramality
while (<>) {
	chomp;
	next unless /^[a-z]+$/i;
	# Optional speed-up here...  I took it up to test speeds with other solutions
	# next unless length > 7;
	push(@{$h{ident($_)}}, lc($_));
}

# For each set of anagrams, check to see if any of the pairs are
# "interesting".  Print if they are.
for my $ref (values %h) {
	my @a = @{$ref};
	while (@a > 1) {
		for my $i (1 .. $#a) {
			if (min_chunks($a[0], $a[$i]) > 5) {
				print "$a[0] -> $a[$i]\n";
			}
		}
		shift @a;
	}
}

# Here is the main function.  Given two words which are anagrams of one
# another, determines the minimum number of "chunks" you have to split the
# first word into in order to be able to re-arrange them into the second
# word.
# This is the basic strategy -- given 2 words of N letters each, we try all
# of the possible 2-chunk solutions, then the 3-chunk solutions, until we
# eventually end up at the N-chunk solution (which had better work).
# It's sort of brute-force, but I processed about 4100 word pairs in around
# 240 seconds, so it seems to be reasonably fast.
sub min_chunks {
	# Short for $one and $two
	my($o, $t) = @_;
	for my $i (1 .. length($o)) {
		# @a contains the locations of the "cuts" that deliniate the "chunks"
		my @a = (1 .. $i);
		do {
			return @a + 1 if matches($o, $t, @a);
		} while (manip(\@a, length($o)));
	}
}

# Tests to see if a proposed set of "cuts" allows one to form the
# second word from the first.
sub matches {
	my($o, $t, @a) = @_;
	my @parts;
	my $old = 0;
	for my $cut (@a) {
		push(@parts, substr($o, $old, $cut - $old));
		$old = $cut;
	}
	push(@parts, substr($o, $old));
	# Have to get rid of the chunks in descending length order, otherwise
	# we might accidentally take a smaller one out from inside a larger
	# one, giving a false negative.
	for my $part (sort { length($b) <=> length($a) } @parts) {
		$t =~ s/$part//;
	}
	return !length($t);
}

# Adjusts the array of cut locations.
sub manip {
	my $ref = shift;
	my $len = shift;
	for my $i (1 .. @{$ref}) {
		for my $j (1 .. $i) {
			$ref->[-$j]++;
		}
		if ($ref->[-1] > $len) {
			for my $j (-$i .. -1) {
				next unless defined $ref->[$j - 1];
				$ref->[$j] = $ref->[$j - 1] + 1;
			}
		}
		else {
			return 1;
		}
	}
	return 0;
}

# I stole this sexy bit of code from Walt.
# It provides the "anagram identity" of a word.
# He originally gave it a much better name.
sub ident {
	return join "", sort map lc, split //, shift;
}

