use warnings;
use strict;

use List::MoreUtils qw(uniq);


my @trans = (
    #  substitute... for...        except in...
    [ 'TWENTY',     'score',    qw(fourscore scored scores)       ],
    [ 'CENTER',     'core',     qw(encore encores coregent score) ],
  # [ 'CENTERS',    'cores',    qw(encores scores)                ],
    [ 'JOHN',       'Johann',   qw(Johannesburg)                  ],
    [ 'CENTER',     'centre',    ],
    [ 'TRAVELED',   'travelled', ],
    [ 'HAS NOT',    'hasn\'t',   ],
    );

my %trans = map @{ $_ }[1, 0], @trans;

my ($translate) =
    map qr{ $_ }xms,
    join ' | ',
    map word_regex(@{ $_ }[1 .. $#{$_}]),
    @trans
    ;

while (defined(my $line = <DATA>)) {
    print $line;
    $line =~ s{ ($translate) }{$trans{$1}}xmsg;
    print $line;
    print "\n";
    }


sub word_regex {

    my ($word,
        @stops,
        ) = @_;

    my $not_prefix =                # 5. conjunction
        join ') (?<! ',             # 4. neg. look-behind...
        uniq                        # 3. no dups...
        map m{ \A (.+) $word }xms,  # 2. extract prefixes...
        @stops                      # 1. for any stop words...
        ;
    $not_prefix = "(?<! $not_prefix)" if $not_prefix;  # final wrap

    my $not_suffix =
        join ' | ',
        uniq
        map m{ $word (.+) \z }xms,
        @stops
        ;
    $not_suffix = "(?! $not_suffix)" if $not_suffix;

    return qr{ $not_prefix $word $not_suffix }xms;

    }


__DATA__
the core of the coregents encores scored fourscore score of
scores when Johann travelled to Johannesburg
for a score of cores hasn't a centre encoregent