--------------------------------------------------------
calculate inputphrase signature
while (input available)
read word
skip if words letters not in inputphrase
calculate signature and anagrams
for each candidate word # first pass
for each candidate word # second pass
for each candidate word # third pass
combine candidate signatures
skip if different from inputphrase signature
add to anagrams list
print anagrams list
--------------------------------------------------------
####
cere
cheer
come
cree
echo
eeoc
em
he
here
herm
home
me
mere
moe
re
reme
rhee
rho
##
##
perl mul_anagram.pl "come here" < words
##
##
[come] (here rhee)
[echo] (mere reme)
[eeoc] (herm)
[home] (cere cree)
[moe] (cheer)
[re] (come)
[re] (echo)
[rho] (emcee)
##
##
monk friar
norm fakir
marin fork
rank of rim
koran firm
lithographic
alight orphic
goliath chirp
high tropical
oligarch pith
pig haircloth
perlmonks.net
tromp kernel
monk saint
main knots
mason knit
Perl forever
lover prefer
reprover elf
repel fervor
Use Perl forever
profuse reveler
reefer overplus
reprove refuels
sleeper fervour
wait for experience
firepower exitance
son of a gun
snafu goon
GNU on sofa
Brother Tilly
try their boll
try other bill
lit Tyrol herb
##
##
#!/usr/bin/perl -w
use strict;
my $phrase = shift || die "input phrase required\n";
my $outer_limit = shift || 1500;
my $inner_limit = shift || 100;
$phrase = lc $phrase;
$phrase =~ tr/a-z//cd; # considers only alpha characters
my @input_letters = split //, $phrase;
my $signature = join "", sort @input_letters;
my %words = ();
my %compare_template;
for (@input_letters) {$compare_template{$_}++};
INPUT:
while (<>) {
chomp;
$_ = lc $_;
my @letters = split //, $_;
my $windex = join "", sort @letters;
my %compare = %compare_template;
for my $let (@letters) {
next INPUT
unless (exists $compare{$let}) # keeps only words made of
and $compare{$let}--; # signature letters
}
if (exists $words{$windex}) {
next if $words{$windex} =~ /\b$_\b/;
$words{$windex} .= " ";
}
$words{$windex} .= $_;
}
my $items = scalar keys %words ;
print STDERR "Considering $items items. ";
if ($items > $outer_limit) {
print "Too many candidates. It would take too long\n";
exit;
}
print STDERR @{[$items > $inner_limit ? "Only two" : "Three"]},
" passes\n";
my @candidates = keys %words;
my @used = (); # stores the combination of words already found
for my $first (0 .. $#candidates) {
if ($signature eq $candidates[$first]) {
print " [" . $words{$candidates[$first]} . "]\n";
push @used , [$first, -1,-1];
next
}
for my $second (0 .. $#candidates) {
next if $second == $first;
next if grep { (grep {$_ == $first} @$_)
and (grep {$_ == $second} @$_)} @used;
my $sign = join "", sort
split //, $candidates[$first].$candidates[$second];
if ($sign eq $signature) {
print " [" . $words{$candidates[$first]}. "] ("
. $words{$candidates[$second]}. ") \n";
push @used, [$first, $second, -1];
next;
}
if ($items <= $inner_limit) {
for my $third (0.. $#candidates) {
next if $third == $second;
next if grep { (grep {$_ == $first} @$_ )
and (grep {$_ == $second} @$_)
and (grep {$_ == $third} @$_) } @used;
my $sign = join "", sort
split //, $candidates[$first]
.$candidates[$second].$candidates[$third];
if ($sign eq $signature) {
print " [" . $words{$candidates[$first]}. "] ("
. $words{$candidates[$second]}. ") <"
. $words{$candidates[$third]}. "> \n";
push @used, [$first, $second,$third];
next;
}
}
}
}
}