#!/usr/bin/perl -w
#
# Word partitioner - Adapted by gene@ology.net
#        from code by dngor, AKA Rocco Caputo.
#
use strict;

# Samples of strings like xaxx, abc, xxxx, etc.
my $word = shift || die "Usage: ./$0 string [words in the lexicon]\n";

# Set lexicon and dictionary.
my @lex  = @ARGV ? @ARGV : qw(a ab abc bc bcd de d e); #qw(a ab abc);
my %DICT;
@DICT{@lex} = ();

# Bucket for previously seen word-parts.
my %SEEN;
# Partition the word!
print join ', ', partition($word);

exit;

#-----------------------------------------------#
sub partition {
  my $left = shift;
  my($original, $right) = ($left, '');
  my @returns = ();

  push @returns, $left if exists $DICT{$left};

  while ($left ne '') {
    # Find all rights and make all "left-right" combinations.
    if( exists $DICT{$left} ) {
      push @returns, "$left-$_" for get_rights($right)
    }

    # Move the last char of $left to the beginning of $right.
    # ..123/4567 -> 12/34567 -> 1/234567 -> /1234567
    $right = chop($left) . $right;
  }

  # Cache the results, so we don't re-partition substrings.
  $SEEN{$original} = \@returns;

  @returns;
}

#-----------------------------------------------#
sub get_rights {
  my $right = shift;
  #print 'Right: ', $right, "\n";
  return $right ne ''               # If $right isn't empty, then
         ? ( exists $SEEN{$right}   # If $right has already been seen, then
             ? @{ $SEEN{$right} }   # ..use the cached permutation.
             : partition($right) )  # ..otherwise, permute and cache.
         : ();                      # Else, $right is not empty - return nothing.
}