#!/usr/bin/perl
use warnings;
use strict;

#use Memoize qw(memoize flush_cache);
#memoize(proc => NORMALIZER => \&normal);

while (0)
{
  my ($w1, $w2) = split;
  /^[^.]+$/ or warn "$w1 or $w2 is not a word\n" and next
    for $w1, $w2;    # We'll use embedded periods later on

  warn "$w1 and $w2 are not anagrams\n" and next unless
    join('', sort split //, $w1) eq join('', sort split //, $w2);

  our @sol;
  my $start = time;
  my $chunks = min_chunks($w1, $w2);
  print "$chunks: ", rearrange($w1, @sol), "  ", rearrange($w2, @sol),
        "  (", time-$start, " secs)\n";
#  flush_cache('proc');
}

sub min_chunks
{
  my ($w1, $w2) = @_;
  my @sub1 = substrs($w1);
  my @sub2 = substrs($w2);
  my @int  = intersect(\@sub1, \@sub2);

  my @frag1 = $w1;
  my @frag2 = $w2;

  our @sol = ();
  proc(\@frag1, \@frag2, [], \@int);
  @sol;
}

sub proc
{
  my @frag1 = @{shift()};
  my @frag2 = @{shift()};
  my @set   = @{shift()};
  my @subs  = @{shift()};
  our @sol;
  print "\t", join(".", @set), "\n" and @sol = @set and return unless @frag1;

  return if @sol and @set == @sol;  # Not going to beat the leading candidate
  
  # For each string in the set of remaining substrings
  while (my $str = shift @subs)
  {
    # Try and remove it from each of the fragments in @frag1
    foreach my $index1 (0 .. $#frag1)
    {
      if (splitup($frag1[$index1], $str, \my @frag1parts))
      {
        # Form new @frag1
        my @newfrag1 = @frag1;
        splice @newfrag1, $index1, 1, @frag1parts;

        # Try and remove it from each of the fragments in @frag2
        foreach my $index2 (0 .. $#frag2)
        {
          if (splitup($frag2[$index2], $str, \my @frag2parts))
          {
            # Form new @frag2
            my @newfrag2 = @frag2;
            splice @newfrag2, $index2, 1, @frag2parts;

            # For each fragment in @newfrag1, form the list of
            # substrings, take the union, and get the intersection
            # with the same list from @newfrag2
            my @subs1   = substrs(@newfrag1);
            my @subs2   = substrs(@newfrag2);
            my @subsint = intersect(\@subs1, \@subs2);

            # Only consider substrings that are also in the input list
            @subsint = intersect(\@subsint, \@subs);

            proc(\@newfrag1, \@newfrag2, [@set, $str], \@subsint);

            # But we only need to find one from @frag2
            last;
          }
        }
      }
    }
  }
}

# sub normal { join "\001" => map { join "\002" => sort @$_ } @_ }

# Can we split a word up on a substring, and if so, what's left?
sub splitup
{
  my ($str, $substr, $aref) = @_;
  if ($str =~ s/$substr//)
  {
    my @split = ($',$`);
    @$aref = grep length, @split;
    return 1;
  }
  return 0;
}

# How the original word should be chopped up to get these parts
sub rearrange
{
  my ($str, @subs) = @_;
  @subs = sort { length($b) <=> length($a) } @subs;

  my @pos;
  while (my $sub = shift @subs)
  {
    $str =~ s/$sub/'-' x length($sub)/e 
      or warn "\trearrange: give up\n" and return join '/' => @subs;
    push @pos, [ $-[0], $+[0] - $-[0] ];
  }

  join '/' => map substr($_[0], $_->[0], $_->[1]) =>
              sort { $a->[0] <=> $b->[0] } @pos;
}

# Return all possible substrings of a set of strings
sub substrs
{
  my @strs = @_;
  my @res;
  for my $str (@_)
  {
    for my $len (1 .. length $str)
    {
      for my $start (0 .. length($str)-$len)
      {
        push @res, substr($str, $start, $len);
      }
    }
  }

  # This ordering means we try longer substrings first and hence
  # are more likely to find shorter solutions first so we can
  # skip unproductive branches in proc()
  sort { length($b) <=> length($a) } @res;
}

# Intersect two lists, and yes, we want to preserve duplicates
sub intersect
{
  my @a = @{shift()};
  my %h;
  $h{$_}++ for @{shift()};
  grep $h{$_} => @a;
}

__END__
harmonistic anchoritism
paternoster penetrators
enumeration mountaineer
persistent prettiness
xylidin xylinid
conservation conversation
ausgangsspannung spannungsausgang
bade bead
glare lager
precipitate peripatetic
prefect perfect
trout tutor
alarm lamar
assist stasis
egret greet
virgin irving
ramada armada
addresser readdress
glossolabiopharyngeal labioglossopharyngeal
protomagnesium spermatogonium
urogenital regulation
ancestorial lacerations
anatomicopathological pathologicoanatomical
