#!/usr/bin/perl

#
#
# qe4.pl
#
# Perl Quiz of the Week (Expert) No.4 solution
# by Cam (camilo@mesias.co.uk)

use strict;

sub min_chunks {
  my ($w1, $w2) = @_;

  my $max = length($w1);

  # search for large chunks first
  my $len = $max - 1;

  # count chunks and remaining unchunked characters
  my $chunks = 0;
  my $remaining = $max;

  # chunks are recorded and returned if wanted
  my @saved;

  while ($len >= 2){
    # print "Looking for $len length chunks\n";
    for (my $start = 0; $start <= $max-$len; $start++){
      # pick the search target from the first word
      my $target = substr($w1, $start, $len);
      # search for the target in the second word
      my $found = index($w2, $target);
      if ($found >= 0){
        # cross out the used letters in the second word
        substr($w2, $found, $len) = '-' x $len;
        # update counts
        $chunks++;
        $remaining -= $len;
        $start += $len-1;
        push @saved, $target;
      }
    }
    $len--;
  }
  # add the count of remaining letters to the chunks
  $chunks += $remaining;

  if (wantarray){
    return $chunks, @saved;
  }else{
    return $chunks;
  }
}

# close relation to my answer to the simple quiz
sub key {
  my ($word) = @_;

  my $letters;

  for my $l (split //, lc($word)){
    $letters->{$l}++;
  }
  return join ',', map {$letters->{$_}} ('a'..'z');
}

my %words;

while (<>){
  chomp;
  
  next unless $_ =~ m/^[a-z]+$/i;

  push @{$words{key($_)}}, $_;
}

my %output;

# make a hashtable of words by their score
for my $k (keys(%words)){
  my ($first, @rest) = @{$words{$k}};
  if (@rest){
    for my $second (@rest){
# this is for the pretty solution:
      my ($score, @chunks) = min_chunks($first, $second);
      push @{$output{$score}}, pretty($first, $second, @chunks);
# replace with these lines for the plain solution:
#      my $score = min_chunks($first, $second);
#      push @{$output{$score}}, "$first $second";
    }
  }
}

# to aid in pretty printing
sub pretty {
  my ($w1, $w2, @chunks) = @_;

  # assume every letter is a chunk
  $w1 = join '/', split //, $w1;
  $w2 = join '/', split //, $w2;

  for my $c (@chunks){
    # replace split chunks with the original version
    # eg. replace 'i/n/g' with 'ing'
    my $splitchunk = join '/', split //, $c;
    $w1 =~ s/$splitchunk/$c/;
    $w2 =~ s/$splitchunk/$c/;
  }
  return "$w1 $w2";
}

# output anagrams in order of interest
for my $k (sort {$b <=> $a} (keys(%output))){
  print "Scoring $k\n";
  # obligatory use of 'map' :)
  print map {"  $_\n"} @{$output{$k}};
}

