in reply to Generate Multi-word Anagrams

A golfed version that passes strictures w/o warnings ... Comes in at 362 characters and requires a little preprocessing of the dictionary to organize by length.

I could have reduced it further by removing the check to make sure that letters exist, but it wouldn't run in reasonable time otherwise.

use Algorithm::Loops qw( NestedLoops ); sub a { # 1 2 3 4 5 6 7 + 8 #234567890123456789012345678901234567890123456789012345678901234567890 +1234567890 my$w=shift;my@x=sort$w=~/\w/g;my@d=@_;my$i=sub{$^=pop;my$i=NestedLoops +([map{my$x=$d[$@[$_]];[grep{$x->[$_]!~/[^$w]/}0..$#{$x}]}1..$^ ]);whi +le(@%=&$i){my@f=sort map{$d[$@[$_]][$%[$_-1]]}1..$^;$.[@.]="@f"if"@{[ +sort map{/./g}@f]}"eq"@x"}};my$p;$p=sub{my($n,$k,$t)=@_;$@[$t]=$k;$n- +$k?map{$p->($n-$k,$_,$t+1)}reverse 1..(2*$k<$n?$k:$n-$k):&$i($t)};&$p +(2*@x,1*@x,0);@. } open (my $dict, "/usr/dict/words") || die "No words\n"; my @dict; push @{$dict[length $_]}, $_ for grep { length > 1 || $_ eq 'a' || $_ eq 'i' } grep { lc eq $_ } grep { chomp } <$dict>; close ($dict); print "$_\n" for a( 'together', @dict);

Update: Added code to remove dupes. Up to 378 characters. *sighs*

my$w=shift;my@x=sort$w=~/\w/g;my@d=@_;my%s;my$i=sub{$%=pop;my$i=Nested +Loops([map{my$x=$d[$@[$_]];[grep{$x->[$_]!~/[^$w]/}0..$#$x]}1..$%]);w +hile(@%=&$i){my@f=sort map{$d[$@[$_]][$%[$_-1]]}1..$%;$.[@.]="@f"if!$ +s{"@f"}++&&"@{[sort map{/./g}@f]}"eq"@x"}};my $p;$p=sub{my($n,$k,$t)= +@_;$@[$t]=$k;$n-$k?map{$p->($n-$k,$_,$t+1)}reverse 1..(2*$k<$n?$k:$n- +$k):&$i($t)};&$p(2*@x,1*@x,0);@.

Update2: Cleaned things up a little. Down to 348 characters! :-)

my($w,@d)=@_;my@x=sort$w=~/\w/g;**=sub{$%=pop;*)=NestedLoops([map{my$x +=$d[$@[$_]];[grep{$x->[$_]!~/[^$w]/}0..$#$x]}1..$%]);while(@%=&)){my@ +f=sort map{$d[$@[$_]][$%[$_-1]]}1..$%;$.[@.]="@f"if!$_{"@f"}++&&"@{[s +ort map{/./g}@f]}"eq"@x"}};*(=sub{my($n,$k,$t)=@_;$@[$t]=$k;$n-$k?map +{&(($n-$k,0-$_,$t+1)}(2*$k<$n?-$k:$k-$n)..-1:&*($t)};&((2*@x,1*@x,0); +@.

Update3: Took advantage of NestedLoops() callback methods. 336 characters! I'm closing in on 320 ...

my($w,@d)=@_;my@x=sort$w=~/\w/g;**=sub{$%=pop;*)=NestedLoops([map{my$x +=$d[$@[$_]];[grep{$x->[$_]!~/[^$w]/}0..$#$x]}1..$%],sub{my@f=sort map +$d[$@[$_]][$_[$_-1]],1..$%;$.[@.]="@f"if!$_{"@f"}++&&"@{[sort map/./g +,@f]}"eq"@x"})};*(=sub{my($n,$k,$t)=@_;$@[$t]=$k;$n-$k?map&(($n-$k,0- +$_,$t+1),(2*$k<$n?-$k:$k-$n)..-1:&*($t)};&((2*@x,1*@x,0);@.

Update4: 319!! Woo-hoo!

($,,@,)=@_;@$=sort$,=~/\w/g;**=sub{@%=1..pop;NestedLoops([map{$a=$,[$@ +[$_]];[grep{$$a[$_]!~/[^$,]/}0..$#$a]}@%],sub{@:=sort map$,[$@[$_]][$ +_[$_-1]],@%;$.[@.]="@:"if!$_{"@:"}++&&"@{[sort map/./g,@:]}"eq"@$"})} +;*(=sub{my($n,$k,$t)=@_;$@[$t]=$k;($n-=$k)>0?map&(($n,0-$_,$t+1),($k< +$n?-$k:-$n)..-1:&*($t)};&((2*@$,1*@$,0);@.

Update5: Hunting for 300 ... at 305 right now:

($,,@,)=@_;@$=sort$,=~/\w/g;*(=sub{my($n,$k,$t)=@_;$@[$t]=$k;($n-=$k)> +0?map&(($n,0-$_,$t+1),($k<$n?-$k:-$n)..-1:(@%=1..$t),NestedLoops([map +{$a=$,[$@[$_]];[grep{$$a[$_]!~/[^$,]/}0..$#$a]}@%],sub{@:=sort map$,[ +$@[$_]][$_[$_-1]],@%;$.[@.]="@:"if!$_{"@:"}++&&"@{[sort map/./g,@:]}" +eq"@$"})};&((2*@$,1*@$,0);@.

Update6: I'm happy. 297 characters, but no longer warnings-safe.

($,,@,)=@_;@$=sort$,=~/\w/g;*b=sub{my($n,$k,$t)=@_;$@[$t]=$k;($n-=$k)> +0?map b($n,0-$_,$t+1),($k<$n?-$k:-$n)..-1:(@%=@,[@@[1..$t]]),NestedLo +ops([map{$a=$_;[grep$$a[$_]!~/[^$,]/,0..$#$a]}@%],sub{@:=sort map$%[$ +_][pop],1-@%..0;$.[@.]="@:"if!$_{"@:"}++&&"@{[sort map/./g,@:]}"eq"@$ +"})};b(2*@$,1*@$);@.

------
We are the carpenters and bricklayers of the Information Age.

Then there are Damian modules.... *sigh* ... that's not about being less-lazy -- that's about being on some really good drugs -- you know, there is no spoon. - flyingmoose