#!/usr/bin/perl

use Anagram26;
use strict;

my $file = shift;
my $words = build_word_list($file, @ARGV);

add_more_words($words, qw(
  a I
  I'm you're he's she's we're they're
  I'll you'll he'll she'll we'll they'll
  I've you've we've they've
  it's that's what's
  isn't can't won't don't doesn't
));

print "Anagrams of '@ARGV':\n";

while (my $word = get_anagram($words)) {
  print "-> $word\n";
}

# or wait until they're all computed
# and get them in a hash via:
# my $anagram_hash = anagrams($words);


##</code><code>##

package Anagram26;

use strict;
require Exporter;

@Anagram26::ISA = qw( Exporter );
@Anagram26::EXPORT = qw(
  build_word_list
  add_more_words
  get_anagram
  anagrams
);

my @VAL = ('\0', map "[\\0-\\$_]", 1 .. 255);
my $SPAWNED = 0;
my $CHILD;


sub build_word_list {
  my $file = shift;
  (my $chars = lc join "", @_) =~ tr/a-z//cd;
  my $len = length $chars;
  my $rx = qr/[^$chars]/i;
  my @words = ($chars);

  open WORDS, "< $file" or die "can't read $file: $!";
  while (<WORDS>) {
    chomp;
    next if $len < length or /$rx/;
    push @{ $words[length]{frequency(lc)} }, $_;
  }
  close WORDS;

  for (keys %{ $words[-1] }) {
    warn freq_to_str($_), " => (@{ $words[-1]{$_} })\n";
  }

  return \@words;
}


sub add_more_words {
  my $words = shift;

  for (@_) {
    (my $canon = lc $_) =~ tr/a-z//cd;
    push @{ $words->[length $canon]{frequency($canon)} }, $_;
  }
}


sub get_anagram {
  &spawn if $SPAWNED == 0;

  my $ana = <IN>;

  if (defined $ana) { chomp $ana }
  else { close IN }

  return $ana;
}


sub spawn {
  pipe IN, OUT;
  select((select(OUT), $|=1)[0]);

  $SPAWNED = 1;
  my $pid = fork;

  if ($pid) {
    $CHILD = $pid;
    close OUT;
  }
  elsif (defined $pid) {
    close IN;
    &anagrams;
    exit;
  }
  else {
    die "fork failed: $!";
  }
}


sub anagrams {
  my $words = shift;
  my $chars = $words->[0];
  my %seen;
  my $ana;

  $ana = sub {
    my ($str, $len, $current, $prune) = @_;
    my $rx = freq_to_rx($str);

    if ($len == 0) {
      for (expand(@$current)) {
        my $ana = join " ", sort split;
        if ($seen{$ana}++ == 0 and $SPAWNED) { print OUT "$ana\n" }
        return;
      }
    }

    for (reverse(1 .. $prune)) {
      my $l = $words->[$_];

      for my $w (grep /$rx/, keys %$l) {
        my $p = ($_, $len - $_)[$_ > $len/2];
        push @$current, $l->{$w};
        $ana->(remove($str, $w, $len), $current, $p);
        pop @$current;
      }
    }
  };

  $ana->(frequency($chars), length($chars), [], @$words-1);
  close OUT if $SPAWNED;
  return \%seen;
}


sub frequency {
  my $word = shift;
  my $s = "\0" x 26;
  ++vec($s, ord($_) - ord('a'), 8) for split //, $word;
  return $s;
}


sub remove {
  my ($str, $rem, $len) = @_;
  my $o = 0;
  vec($str, $o++, 8) -= ord, $len -= ord for split //, $rem;
  return ($str, $len);
}


sub freq_to_rx {
  my $rx = join "", @VAL[map ord, split //, shift];
  qr/^$rx$/;
}


sub freq_to_str {
  my $c = 'a';
  join "", map $c++ x ord, split //, shift;
}


sub expand {
  return @{ +shift } if @_ == 1;
  return map { my $f = $_; map "$f $_", expand(@_) } @{ +shift };
}


END {
  kill TERM => $CHILD if defined $CHILD;
}


1;