use strict; use warnings; my (%l, @a, $bad, $w); my @w = ('bumps','seams','domes','shake','pokes','dukes'); for (@w) { $l{$_} = () for (split //, $_); } permute(5, '', \@a, sort keys %l); for $w (@a) { $bad = 0; for (@w) { if (both($_, $w) != 2) { $bad = 1; last; } } if (!$bad) { print "$w\n"; } } sub permute { my ($d, $w, $a, @l) = @_; if (!--$d) { push @$a, $w.$_ for @l; } else { permute($d, $w.$l[$_], $a, @l[($_+1)..$#l]) for (0..($#l-$d)); } } sub both { my ($w1, $w2) = @_; my %l; my $c = 0; $l{$_} = () for split //, $w1; for (split //, $w2) { $l{$_} = 1 if exists $l{$_}; } for (values %l) { $c++ if $_; } return $c; } #### abdep abeou adkmp akmou