-------------------------------------------------------- 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; } } } } }