#!/usr/bin/perl -w

# This program will read on STDIN the output of anagram.pl (the results of
#  the beginner perl quiz of the week #4), and try and find 'good' or
#  'interesting' anagrams.
#
#  A good anagram is defined as an anagram that requires a significant
#  amount of reorganization of letters and can be controlled by 2 constants:
#    MIN_LENGTH - The shortest length of anagram that we will look at
#    MIN_RATIO  - The minimum ratio of word-chunks to word-length that we accept
#
# Output consists of the following:
#   #letters #chunks ratio:  anagram1 anagram2 - chunklist
#

use strict;

use Memoize;
memoize('_min_chunks');

use constant MIN_LENGTH => 8;
use constant MIN_RATIO  => 0.7;

my %seen = ();
while (<>) {
  next if /\(See/;
  my @list = split;

  my $length = length($list[0]);
  next if $length < MIN_LENGTH;
  next if $seen{$list[0]};
  if (@list == 2) {
    # We have a 2 element list.  This means we will see this pair again
    #  later on in the datafile (according to the spec for beginner quiz)
    $seen{$list[1]}++;
  }
  for (my $i=0; $i < @list-1; $i++) {
    for (my $j=$i+1; $j < @list; $j++) {
      my @chunks = min_chunks($list[$i], $list[$j]);
      my $ratio = @chunks / $length;
      if ($ratio > MIN_RATIO) {
        printf("%2d %2d %.2f:  %s %s - %s\n", $length, scalar @chunks, $ratio,
$list[$i], $list[$j], join(' ', sort @chunks));
      }
    }
  }
}

# min_chunks
#
# This function takes 2 words and returns an array of word-chunks
# that can be used to recreate either word.  It is intended to
# return the smallest list of word-chunks possible.

sub min_chunks {
  my $word1 = shift;
  my $word2 = shift;

  return unless is_anagram($word1, $word2);
  return _min_chunks($word1, $word2);
}

# _min_chunks
#
# A helper function that should not be called directly.  It accepts a
# word and an array of word chunks.  It splits the word into 2 pieces
# and tries to find the first piece in one of the chunks of the chunk-list.  
# If a match is found, the matching piece is split out of the chunk, and 
# the function recursively calls itself using the second unused piece, and 
# the newly updated chunk-list.
# Recursion ends when _min_chunks is called with only two elements and they are equal
#
# example:
#   _min_chunks('tacos', 'ascot');
#
#  split 'tacos' in 4 different ways ('taco', 's'), ('tac', 'os'),('ta', 'cos'),('t', 'acos')
#    match 'taco' against 'ascot' => no match
#    match 's' against 'ascot' => match => split 'ascot' into 'a', 'cot' => call _min_chunks('taco', 'a', 'cot'')
#    match 'tac' against 'ascot' => no match
#    match 'os' against 'ascot' => no match
#    match 'ta' against 'ascot' => no match
#    match 'cos' against 'ascot' => no match
#    match 't' against 'ascot' => match => split 'ascot' into 'asco' => call _min_chunks('acos', 'asco')
#    match 'acos' against 'ascot' => no match
# if you follow this through recursively, then you will see that every combination of chunks of tacos
#  will be checked against ascot


sub _min_chunks {
  my $word   = shift;
  my @chunks = @_;

  # At the end we will just have one word and one list item that are equal to each other
  #  ie we might get 'em' and 'em'
  #  This signals the end of the recursion
  return $word if (@chunks == 1 && $word eq $chunks[0]);

  # Find the biggest chunk we have so far
  my $max_chunk=0;
    foreach my $chunk (@chunks) {
    $max_chunk = length($chunk) if length($chunk) > $max_chunk;
  }

  # prefill @shortest with the current shortest list we know about 
  #  ie the longest possible chunk list
  my @shortest = split '', $word;

  # Main loop:  loop once for every letter but one in $word
  for(my $i=1; $i < length($word); $i++) {

    # Second loop:  always loops 2 times so we can test both chunks when we split a word
    #               ie if $word='tacos' and $i=2 then on the first iteration of the second loop
    #                  $part='cos' and $newword='ta'.  On the second iteration they swap, so
    #                  $part='ta' and $newword='cos'.
    foreach my $which (0..1) {
      my $part    = ( $which) ? substr($word, 0, $i) : substr($word, $i);
      my $newword = (!$which) ? substr($word, 0, $i) : substr($word, $i);
      next if length($part) > $max_chunk; # the part we're matching is too long so skip it

      # Third loop:  Try to match $part against all of the @chunks we have
      for(my $j=0; $j < @chunks; $j++) {
        my $piece = $chunks[$j];
        my $count=0;

        # Fourth loop:  this $part might match more than once in a given chunk
        #               ie.  if $part='abc' and $piece='abcdeabc' then there
        #                    are 2 spots where 'abc' will match, and we should
        #                    check them both
        while (index($piece, $part, $count) >= 0) {
          my $index = index($piece, $part, $count);
          $count++;

          # Generate a new list of 'chunks' (we split out the part we found and remove it)
          # For example, if we had the following list and part:
          #   $part='path'
          #   @chunks=('anatomic', 'opathological')
          # we would get a new list without the 'path' in it
          #   newchunks = (anatomic, o, ological)
          my @newchunks = ();
          push @newchunks, @chunks[0..$j-1] if $j > 0;
          push @newchunks, substr($piece, 0, $index) if $index > 0;
          push @newchunks, substr($piece, $index+length($part)) if $index+length($part) < length($piece);
          push @newchunks, @chunks[($j+1)..$#chunks] if $j < $#chunks;

          # Recursively call ourselves with a shorter $word and longer list of chunks
          my @newlist = _min_chunks($newword, @newchunks);

          # We should now have the shortest list of chunks for $word, except the
          # $part we removed above so we add it back in
          push @newlist, $part;

          # See if this list of chunks is shorter than what we have found so far
          @shortest = sort @newlist if @newlist <= @shortest;
        }
      }
    }
  }
  return @shortest;
}

sub is_anagram {
  my $first  = lc shift;
  my $second = lc shift;

  return if $first eq $second;  # If they are equal, then they are not anagrams
  return if $first =~ /[^a-z]/;

  # sort the letters of the word in alphabetical order to simplify comparison
  my $sort_first  = join('', sort split('', $first));
  my $sort_second = join('', sort split('', $second));

  return ($sort_first eq $sort_second);
}

