I rewrote the code to find even more matches, here it is, enjoy :-)
use warnings;
use 5.014; # mostly for /r
my %words = map {chomp; $_=>1} grep {!/'s$/}
do { open my $fh, '<', '/usr/share/dict/words' or die $!; <$fh> };
my %search;
for my $word (sort keys %words) {
next unless $word=~ m{ \A
(?<pre> s )?
(?<sep> [a-zA-Z0-9] )
(?<search> (?: (?!\g{sep}) . )+ )
\g{sep}
(?! \g{search} \g{sep} )
(?<repl> (?: (?!\g{sep}) . )* )
\g{sep}
(?<flags> [msixpongr]* )
\z }msx;
push @{ $search{$+{search}} }, { word=>$word, %+ };
}
my @search = sort { length $b <=> length $a or $a cmp $b }
keys %search;
my ($re) = map {qr/$_/} join '|', map {quotemeta} @search;
for my $word (sort keys %words) {
next unless length $word > 1 && $word=~/($re)/;
for my $s (@search) {
next unless $word=~/\Q$s/;
for my $r (@{$search{$s}}) {
my $test = eval '$word=~s/\Q$s/$$r{repl}/r'.$$r{flags};
defined $test or die $@;
next unless length $test > 1 && exists $words{$test}
&& $test ne $word;
my ($pre,$pat) = ($$r{pre}//'s',$$r{word});
( $pat = $$r{word} ) =~ s/\A\Q$$r{pre}// if $$r{pre};
my $code = "\$word =~$pre $pat$$r{flags}r";
eval($code) eq $test or die "$code - $test - $@";
say "$word =~$pre $pat => $test";
}
}
}
But seriously, to respond to Fletch's comments, of course this is just for fun ;-) When I wrote it I was thinking I might try my hand at some Perl poetry some time, unfortunately I don't think I'm creative enough in that way... at least here's some code if anyone else wants to give it a spin ;-)
|