File Coverage

blib/lib/Lingua/EN/Inflect.pm

Criterion	Covered	Total	%
statement	341	423	80.6
branch	358	470	76.1
condition	144	285	50.5
subroutine	35	48	72.9
pod	9	33	27.2
total	887	1259	70.4

package Lingua::EN::Inflect;

use strict;
use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS @ISA);
use Env;

require Exporter;
@ISA = qw(Exporter);

our $VERSION = '1.903';

%EXPORT_TAGS =
(
    ALL =>      [ qw( classical inflect
                  PL PL_N PL_V PL_ADJ NO NUM A AN
                  PL_eq PL_N_eq PL_V_eq PL_ADJ_eq
                  PART_PRES
                  ORD
                  NUMWORDS
                  WORDLIST
                  def_noun def_verb def_adj def_a def_an )],

    INFLECTIONS =>  [ qw( classical inflect
                  PL PL_N PL_V PL_ADJ PL_eq
                  NO NUM A AN PART_PRES )],

    PLURALS =>  [ qw( classical inflect
                  PL PL_N PL_V PL_ADJ NO NUM
                  PL_eq PL_N_eq PL_V_eq PL_ADJ_eq )],

    COMPARISONS =>  [ qw( classical
                  PL_eq PL_N_eq PL_V_eq PL_ADJ_eq )],

    ARTICLES => [ qw( classical inflect NUM A AN )],

    NUMERICAL =>    [ qw( ORD NUMWORDS )],

    USER_DEFINED => [ qw( def_noun def_verb def_adj def_a def_an )],
);

Exporter::export_ok_tags(qw( ALL ));

# SUPPORT CLASSICAL PLURALIZATIONS

my %def_classical = (
    all      => 0,
    zero     => 0,
    herd     => 0,
    names    => 1,
    persons  => 0,
    ancient  => 0,
);

my %all_classical = (
    all               => 1,
    zero              => 1,
    herd              => 1,
    names             => 1,
    persons           => 1,
    ancient           => 1,
    noble_and_ancient => 10,
);

my %classical = %def_classical;

my $classical_mode = join '|', keys %all_classical;
   $classical_mode = qr/^(?:$classical_mode)$/;

sub classical
{
    if (!@_) {
        %classical = %all_classical;
        return;
    }
    if (@_==1 && $_[0] !~ $classical_mode) {
        %classical = $_[0] ? %all_classical : ();
        return;
    }
    while (@_) {
        my $arg = shift;
        if ($arg !~ $classical_mode) {
            die "Unknown classical mode ($arg)\n";
        }
        if (@_ && $_[0] !~ $classical_mode) { $classical{$arg} = shift; }
        else                                { $classical{$arg} = 1;     }

        if ($arg eq 'all') {
            %classical = $classical{all} ? %all_classical : ();
        }
    }
}

my $persistent_count;

sub NUM     # (;$count,$show)
{
    if (defined $_[0])
    {
        $persistent_count = $_[0];
        return $_[0] if !defined($_[1]) || $_[1];
    }
    else
    {
        $persistent_count = undef;
    }
    return '';
}


# 0. PERFORM GENERAL INFLECTIONS IN A STRING

sub enclose { "(?:$_[0])" }

sub inflect
{
    my $save_persistent_count = $persistent_count;
    my @sections = split /(NUM\([^)]*\))/, $_[0];
    my $inflection = "";

    foreach ( @sections )
    {
        unless (s/NUM\(\s*?(?:([^),]*)(?:,([^)]*))?)?\)/ NUM($1,$2) /xe)
        {
            1 while
               s/\bPL   \( ([^),]*) (, ([^)]*) )? \)  / PL($1,$3)   /xeg
            || s/\bPL_N \( ([^),]*) (, ([^)]*) )? \)  / PL_N($1,$3) /xeg
            || s/\bPL_V \( ([^),]*) (, ([^)]*) )? \)  / PL_V($1,$3) /xeg
            || s/\bPL_ADJ \( ([^),]*) (, ([^)]*) )? \)  / PL_ADJ($1,$3) /xeg
            || s/\bAN?  \( ([^),]*) (, ([^)]*) )? \)  / A($1,$3)    /xeg
            || s/\bNO   \( ([^),]*) (, ([^)]*) )? \)  / NO($1,$3)   /xeg
            || s/\bORD  \( ([^)]*) \)                 / ORD($1)   /xeg
            || s/\bNUMWORDS  \( ([^)]*) \)            / NUMWORDS($1)   /xeg
            || s/\bPART_PRES  \( ([^)]*) \)            / PART_PRES($1)   /xeg
        }

        $inflection .= $_;
    }

    $persistent_count = $save_persistent_count;
    return $inflection;
}


# 1. PLURALS

my %PL_sb_irregular_s =
(
    "corpus"          => "corpuses|corpora",
    "opus"            => "opuses|opera",
    "magnum opus"     => "magnum opuses|magna opera",
    "genus"           => "genera",
    "mythos"          => "mythoi",
    "penis"           => "penises|penes",
    "testis"          => "testes",
    "atlas"           => "atlases|atlantes",
    "yes"             => "yeses",
    'editio princeps' => 'editiones principes',
    'starets'         => 'startsy',
    'staretz'         => 'startzy',
);

my %PL_sb_irregular =
(
    "child"       => "children",
    "brother"     => "brothers|brethren",
    "loaf"        => "loaves",
    "hoof"        => "hoofs|hooves",
    "beef"        => "beefs|beeves",
    "thief"       => "thiefs|thieves",
    "money"       => "monies",
    "mongoose"    => "mongooses",
    "ox"          => "oxen",
    "cow"         => "cows|kine",
    "graffito"    => "graffiti",
    "prima donna" => "prima donnas|prime donne",
    "octopus"     => "octopuses|octopodes",
    "genie"       => "genies|genii",
    "ganglion"    => "ganglions|ganglia",
    "trilby"      => "trilbys",
    "turf"        => "turfs|turves",
    "numen"       => "numina",
    "atman"       => "atmas",
    "occiput"     => "occiputs|occipita",
    'sabretooth'  => 'sabretooths',
    'sabertooth'  => 'sabertooths',
    'lowlife'     => 'lowlifes',
    'flatfoot'    => 'flatfoots',
    'tenderfoot'  => 'tenderfoots',
    'Romany'      => 'Romanies',
    'romany'      => 'romanies',
    'Tornese'     => 'Tornesi',
    'Jerry'       => 'Jerrys',
    'jerry'       => 'jerries',
    'Mary'        => 'Marys',
    'mary'        => 'maries',
    'talouse'     => 'talouses',
    'blouse'      => 'blouses',
    'Rom'         => 'Roma',
    'rom'         => 'roma',
    'carmen'      => 'carmina',
    'cheval'      => 'chevaux',
    'chervonetz'  => 'chervontzi',
    'kuvasz'      => 'kuvaszok',
    'felo'        => 'felones',
    'put-off'     => 'put-offs',
    'set-off'     => 'set-offs',
    'set-out'     => 'set-outs',
    'set-to'      => 'set-tos',
    'brother-german' => 'brothers-german|brethren-german',
    'studium generale' => 'studia generali',

    %PL_sb_irregular_s,
);

my $PL_sb_irregular = enclose join '|', reverse sort keys %PL_sb_irregular;

# Z's that don't double

my @PL_sb_z_zes =
(
    "batz", "quartz", "topaz", "snooz(?=e)", "kibbutz",
);
my $PL_sb_z_zes = enclose join '|', @PL_sb_z_zes;

# UNCONDITIONAL "..is" -> "..ides"

my @PL_sb_U_is_ides =
(
    "aphis",
);

my $PL_sb_U_is_ides = enclose join "|", map { substr($_,0,-2) } @PL_sb_U_is_ides;

# CLASSICAL "..is" -> "..ides"

my @PL_sb_C_is_ides =
(
# GENERAL WORDS...

    "ephemeris", "iris", "clitoris",
    "chrysalis", "epididymis",

# INFLAMATIONS...

    ".*itis",

);

my $PL_sb_C_is_ides = enclose join "|", map { substr($_,0,-2) } @PL_sb_C_is_ides;

# UNCONDITIONAL "..a" -> "..ata"

my @PL_sb_U_a_ata =
(
    "plasmalemma", "pseudostoma",
);

my $PL_sb_U_a_ata = enclose join "|", map { substr($_,0,-1) } @PL_sb_U_a_ata;

# CLASSICAL "..a" -> "..ata"

my @PL_sb_C_a_ata =
(
    "anathema", "bema", "carcinoma", "charisma", "diploma",
    "dogma", "drama", "edema", "enema", "enigma", "lemma",
    "lymphoma", "magma", "melisma", "miasma", "oedema",
    "sarcoma", "schema", "soma", "stigma", "stoma", "trauma",
    "gumma", "pragma", "bema",
);

my $PL_sb_C_a_ata = enclose join "|", map { substr($_,0,-1) } @PL_sb_C_a_ata;

# UNCONDITIONAL "..a" -> "..ae"

my $PL_sb_U_a_ae = enclose join "|",
(
    "alumna", "alga", "vertebra", "persona"
);

# CLASSICAL "..a" -> "..ae"

my $PL_sb_C_a_ae = enclose join "|",
(
    "amoeba", "antenna", "formula", "hyperbola",
    "medusa", "nebula", "parabola", "abscissa",
    "hydra", "nova", "lacuna", "aurora", ".*umbra",
    "flora", "fauna",
);

# CLASSICAL "..en" -> "..ina"

my $PL_sb_C_en_ina = enclose join "|", map { substr($_,0,-2) }
(
    "stamen", "foramen", "lumen"
);

# UNCONDITIONAL "..um" -> "..a"

my $PL_sb_U_um_a = enclose join "|", map { substr($_,0,-2) }
(
    "bacterium",    "agendum",  "desideratum",  "erratum",
    "stratum",  "datum",    "ovum",     "extremum",
    "candelabrum", "intermedium", "malum", "Progymnasium",
);

# CLASSICAL "..um" -> "..a"

my $PL_sb_C_um_a = enclose join "|", map { substr($_,0,-2) }
(
    "maximum",  "minimum",    "momentum",   "optimum",
    "quantum",  "cranium",    "curriculum", "dictum",
    "phylum",   "aquarium",   "compendium", "emporium",
    "enconium", "gymnasium",  "honorarium", "interregnum",
    "lustrum",  "memorandum", "millennium", "rostrum",
    "spectrum", "speculum",   "stadium",    "trapezium",
    "ultimatum",    "medium",   "vacuum",   "velum",
    "consortium",
);

# UNCONDITIONAL "..us" -> "i"

my $PL_sb_U_us_i = enclose join "|", map { substr($_,0,-2) }
(
    "alumnus",  "alveolus", "bacillus", "bronchus",
    "locus",    "nucleus",  "stimulus", "meniscus",
    "sarcophagus", "interradius", "perradius", "triradius",
);

# CLASSICAL "..us" -> "..i"

my $PL_sb_C_us_i = enclose join "|", map { substr($_,0,-2) }
(
    "focus",    "radius",   "genius",
    "incubus",  "succubus", "nimbus",
    "fungus",   "nucleolus",    "stylus",
    "torus",    "umbilicus",    "uterus",
    "hippopotamus", "cactus",
);

# CLASSICAL "..us" -> "..us"  (ASSIMILATED 4TH DECLENSION LATIN NOUNS)

my $PL_sb_C_us_us = enclose join "|",
(
    "status", "apparatus", "prospectus", "sinus",
    "hiatus", "impetus", "plexus",
);

# UNCONDITIONAL "..on" -> "a"

my $PL_sb_U_on_a = enclose join "|", map { substr($_,0,-2) }
(
    "criterion",    "perihelion",   "aphelion",
    "phenomenon",   "prolegomenon", "noumenon",
    "organon",  "asyndeton",    "hyperbaton",
    "legomenon",
);

# CLASSICAL "..on" -> "..a"

my $PL_sb_C_on_a = enclose join "|", map { substr($_,0,-2) }
(
    "oxymoron",
);

# CLASSICAL "..o" -> "..i"  (BUT NORMALLY -> "..os")

my @PL_sb_C_o_i =
(
    "solo",     "soprano",  "basso",    "alto",
    "contralto",    "tempo",    "piano",    "virtuoso",
);
my $PL_sb_C_o_i = enclose join "|", map { substr($_,0,-1) } @PL_sb_C_o_i;

# ALWAYS "..o" -> "..os"

my $PL_sb_U_o_os = enclose join "|",
(
        "^ado",          "aficionado",   "aggro",
        "albino",       "allegro",      "ammo",
        "Antananarivo", "archipelago",  "armadillo",
        "auto",         "avocado",      "Bamako",
        "Barquisimeto", "bimbo",        "bingo",
        "Biro",         "bolero",       "Bolzano",
        "bongo",        "Boto",         "burro",
        "Cairo",        "canto",        "cappuccino",
        "casino",       "cello",        "Chicago",
        "Chimango",     "cilantro",     "cochito",
        "coco",         "Colombo",      "Colorado",
        "commando",     "concertino",   "contango",
        "credo",        "crescendo",    "cyano",
        "demo",         "ditto",        "Draco",
        "dynamo",       "embryo",       "Esperanto",
        "espresso",     "euro",         "falsetto",
        "Faro",         "fiasco",       "Filipino",
        "flamenco",     "furioso",      "generalissimo",
        "Gestapo",      "ghetto",       "gigolo",
        "gizmo",        "Greensboro",   "gringo",
        "Guaiabero",    "guano",        "gumbo",
        "gyro",         "hairdo",       "hippo",
        "Idaho",        "impetigo",     "inferno",
        "info",         "intermezzo",   "intertrigo",
        "Iquico",       "^ISO",          "jumbo",
        "junto",        "Kakapo",       "kilo",
        "Kinkimavo",    "Kokako",       "Kosovo",
        "Lesotho",      "libero",       "libido",
        "libretto",     "lido",         "Lilo",
        "limbo",        "limo",         "lineno",
        "lingo",        "lino",         "livedo",
        "loco",         "logo",         "lumbago",
        "macho",        "macro",        "mafioso",
        "magneto",      "magnifico",    "Majuro",
        "Malabo",       "manifesto",    "Maputo",
        "Maracaibo",    "medico",       "memo",
        "metro",        "Mexico",       "micro",
        "Milano",       "Monaco",       "mono",
        "Montenegro",   "Morocco",      "Muqdisho",
        "myo",          "^NATO",         "^NCO",
        "neutrino",     "^NGO",          "Ningbo",
        "octavo",       "oregano",      "Orinoco",
        "Orlando",      "Oslo",         "^oto",
        "panto",        "Paramaribo",   "Pardusco",
        "pedalo",       "photo",        "pimento",
        "pinto",        "pleco",        "Pluto",
        "pogo",         "polo",         "poncho",
        "Porto-Novo",   "Porto",        "pro",
        "psycho",       "pueblo",       "quarto",
        "Quito",        "rhino",        "risotto",
        "rococo",       "rondo",        "Sacramento",
        "saddo",        "sago",         "salvo",
        "Santiago",     "Sapporo",      "Sarajevo",
        "scherzando",   "scherzo",      "silo",
        "sirocco",      "sombrero",     "staccato",
        "sterno",       "stucco",       "stylo",
        "sumo",         "Taiko",        "techno",
        "terrazzo",     "testudo",      "timpano",
        "tiro",         "tobacco",      "Togo",
        "Tokyo",        "torero",       "Torino",
        "Toronto",      "torso",        "tremolo",
        "typo",         "tyro",         "ufo",
        "UNESCO",       "vaquero",      "vermicello",
        "verso",        "vibrato",      "violoncello",
        "Virgo",        "weirdo",       "WHO",
        "WTO",          "Yamoussoukro", "yo-yo",
        "zero",         "Zibo",

    @PL_sb_C_o_i,
);


# UNCONDITIONAL "..ch" -> "..chs"

my $PL_sb_U_ch_chs = enclose join "|", map { substr($_,0,-2) }
qw(
    czech eunuch stomach
);

# UNCONDITIONAL "..[ei]x" -> "..ices"

my $PL_sb_U_ex_ices = enclose join "|", map { substr($_,0,-2) }
(
    "codex",    "murex",    "silex",
);

my $PL_sb_U_ix_ices = enclose join "|", map { substr($_,0,-2) }
(
    "radix",    "helix",
);

# CLASSICAL "..[ei]x" -> "..ices"

my $PL_sb_C_ex_ices = enclose join "|", map { substr($_,0,-2) }
(
    "vortex",   "vertex",   "cortex",   "latex",
    "pontifex", "apex",     "index",    "simplex",
);

my $PL_sb_C_ix_ices = enclose join "|", map { substr($_,0,-2) }
(
    "appendix",
);

# ARABIC: ".." -> "..i"

my $PL_sb_C_i = enclose join "|",
(
    "afrit",    "afreet",   "efreet",
);

# HEBREW: ".." -> "..im"

my $PL_sb_C_im = enclose join "|",
(
    "goy",      "seraph",   "cherub",  "zuz", "kibbutz",
);

# UNCONDITIONAL "..man" -> "..mans"

my $PL_sb_U_man_mans = enclose join "|",
qw(
    \bataman caiman cayman ceriman
    \bdesman \bdolman \bfarman \bharman \bhetman
    human \bleman ottoman shaman talisman
    Alabaman Bahaman Burman German
    Hiroshiman Liman Nakayaman Norman Oklahoman
    Panaman Roman Selman Sonaman Tacoman Yakiman
    Yokohaman Yuman
);

my @PL_sb_uninflected_s =
(
# PAIRS OR GROUPS SUBSUMED TO A SINGULAR...
    "breeches", "britches", "pajamas", "pyjamas", "clippers", "gallows",
    "hijinks", "headquarters", "pliers", "scissors", "testes", "herpes",
    "pincers", "shears", "proceedings", "trousers",

# UNASSIMILATED LATIN 4th DECLENSION

    "cantus", "coitus", "nexus",

# RECENT IMPORTS...
    "contretemps", "corps", "debris",
    ".*ois", "siemens",

# DISEASES
    ".*measles", "mumps",

# MISCELLANEOUS OTHERS...
    "diabetes", "jackanapes", ".*series", "species", "rabies",
    "chassis", "innings", "news", "mews", "haggis",
);

my $PL_sb_uninflected_herd = enclose join "|",
# DON'T INFLECT IN CLASSICAL MODE, OTHERWISE NORMAL INFLECTION
(
    "wildebeest", "swine", "eland", "bison", "buffalo",
    "elk", "rhinoceros", 'zucchini',
    'caribou', 'dace', 'grouse', 'guinea[- ]fowl',
    'haddock', 'hake', 'halibut', 'herring', 'mackerel',
    'pickerel', 'pike', 'roe', 'seed', 'shad',
    'snipe', 'teal', 'turbot', 'water[- ]fowl',
);

my $PL_sb_lese_lesen = enclose join "|",
(
    'Auslese',
    'beerenauslese',
    'Spaetlese',
    'trockenbeerenauslese',
);

my $PL_sb_uninflected = enclose join "|",
(
# SOME FISH AND HERD ANIMALS
    ".*fish", "tuna", "salmon", "mackerel", "trout",
    "bream", "sea[- ]bass", "carp", "cod", "flounder", "whiting",

    ".*deer", ".*sheep", "moose",

# ALL NATIONALS ENDING IN -ese
    "Portuguese", "Amoyese", "Borghese", "Congoese", "Faroese",
    "Foochowese", "Genevese", "Genoese", "Gilbertese", "Hottentotese",
    "Kiplingese", "Kongoese", "Lucchese", "Maltese", "Nankingese",
    "Niasese", "Pekingese", "Piedmontese", "Pistoiese", "Sarawakese",
    "Shavese", "Vermontese", "Wenchowese", "Yengeese",
    ".*[nrlm]ese",

# SOME WORDS ENDING IN ...s (OFTEN PAIRS TAKEN AS A WHOLE)

    @PL_sb_uninflected_s,

# DISEASES
    ".*pox",


# OTHER ODDITIES
    "graffiti", "djinn", 'samuri',
    '.*craft$', 'offspring', 'pence', 'quid', 'hertz',
);

# SINGULAR WORDS ENDING IN ...s (ALL INFLECT WITH ...es)

my $PL_sb_singular_s = enclose join '|',
(
    ".*ss",
        "acropolis", "aegis", "alias", "asbestos", "bathos", "bias",
    "bronchitis", "bursitis", "caddis", "cannabis",
        "canvas", "chaos", "cosmos", "dais", "digitalis",
        "epidermis", "ethos", "eyas", "gas", "glottis",
    "hubris", "ibis", "lens", "mantis", "marquis", "metropolis",
        "pathos", "pelvis", "polis", "rhinoceros",
        "sassafras", "trellis", ".*us", "[A-Z].*es",

    @PL_sb_C_is_ides,
    @PL_sb_U_is_ides,
);

my $PL_v_special_s = enclose join '|',
(
    $PL_sb_singular_s,
    @PL_sb_uninflected_s,
    keys %PL_sb_irregular_s,
    '(.*[csx])is',
    '(.*)ceps',
    '[A-Z].*s',
);

my %PL_sb_postfix_adj = (
    'general' => ['(?!major|lieutenant|brigadier|adjutant|.*star)\S+'],
    'martial' => [qw(court)],
);

foreach (keys %PL_sb_postfix_adj) {
    $PL_sb_postfix_adj{$_} = enclose
                 enclose(join('|', @{$PL_sb_postfix_adj{$_}}))
                   . "(?=(?:-|\\s+)$_)";
}

my $PL_sb_postfix_adj = '(' . join('|', values %PL_sb_postfix_adj) . ')(.*)';

my $PL_prep = enclose join '|', qw (
    about above across after against amid amidst among around as at athwart atop
    barring before behind below beneath beside besides between betwixt beyond but by
    circa
    despite down during
    except
    failing for from
    given
    in inside into
    like
    minus
    near next
    of off on onto out outside over
    pace past per plus pro
    qua
    round
    sans save since
    than through throughout thru thruout till times to toward towards
    under underneath unlike until unto up upon
    versus via vs
    with within without worth
);

my $PL_sb_prep_dual_compound = '(.*?)((?:-|\s+)(?:'.$PL_prep.'|d[eua])(?:-|\s+))a(?:-|\s+)(.*)';

my $PL_sb_prep_compound = '(.*?)((-|\s+)('.$PL_prep.'|d[eua])((-|\s+)(.*))?)';


my %PL_pron_nom =
(
#   NOMINATIVE      REFLEXIVE

"i" => "we",    "myself"   =>   "ourselves",
"you"   => "you",   "yourself" =>   "yourselves",
"she"   => "they",  "herself"  =>   "themselves",
"he"    => "they",  "himself"  =>   "themselves",
"it"    => "they",  "itself"   =>   "themselves",
"they"  => "they",  "themself" =>   "themselves",

#   POSSESSIVE

"mine"   => "ours",
"yours"  => "yours",
"hers"   => "theirs",
"his"    => "theirs",
"its"    => "theirs",
"theirs" => "theirs",
);

my %PL_pron_acc =
(
#   ACCUSATIVE      REFLEXIVE

"me"    => "us",    "myself"   =>   "ourselves",
"you"   => "you",   "yourself" =>   "yourselves",
"her"   => "them",  "herself"  =>   "themselves",
"him"   => "them",  "himself"  =>   "themselves",
"it"    => "them",  "itself"   =>   "themselves",
"them"  => "them",  "themself" =>   "themselves",
);

my $PL_pron_acc = enclose join '|', keys %PL_pron_acc;

my %PL_v_irregular_pres =
(
#   1st PERS. SING.     2ND PERS. SING.     3RD PERS. SINGULAR
#               3RD PERS. (INDET.)

"am"    => "are",   "are"   => "are",   "is"     => "are",
"was"   => "were",  "were"  => "were",  "was"    => "were",
"have"  => "have",  "have"  => "have",  "has"    => "have",
"do"    => "do",    "do"    => "do",    "does"   => "do",
);

my $PL_v_irregular_pres = enclose join '|', keys %PL_v_irregular_pres;

my %PL_v_ambiguous_pres =
(
#   1st PERS. SING.     2ND PERS. SING.     3RD PERS. SINGULAR
#               3RD PERS. (INDET.)

"act"   => "act",   "act"   => "act",   "acts"    => "act",
"blame" => "blame", "blame" => "blame", "blames"  => "blame",
"can"   => "can",   "can"   => "can",   "can"     => "can",
"must"  => "must",  "must"  => "must",  "must"    => "must",
"fly"   => "fly",   "fly"   => "fly",   "flies"   => "fly",
"copy"  => "copy",  "copy"  => "copy",  "copies"  => "copy",
"drink" => "drink", "drink" => "drink", "drinks"  => "drink",
"fight" => "fight", "fight" => "fight", "fights"  => "fight",
"fire"  => "fire",  "fire"  => "fire",  "fires"   => "fire",
"like"  => "like",  "like"  => "like",  "likes"   => "like",
"look"  => "look",  "look"  => "look",  "looks"   => "look",
"make"  => "make",  "make"  => "make",  "makes"   => "make",
"reach" => "reach", "reach" => "reach", "reaches" => "reach",
"run"   => "run",   "run"   => "run",   "runs"    => "run",
"sink"  => "sink",  "sink"  => "sink",  "sinks"   => "sink",
"sleep" => "sleep", "sleep" => "sleep", "sleeps"  => "sleep",
"view"  => "view",  "view"  => "view",  "views"   => "view",
);

my $PL_v_ambiguous_pres = enclose join '|', keys %PL_v_ambiguous_pres;


my $PL_v_irregular_non_pres = enclose join '|',
(
"did", "had", "ate", "made", "put",
"spent", "fought", "sank", "gave", "sought",
"shall", "could", "ought", "should",
);

my $PL_v_ambiguous_non_pres = enclose join '|',
(
"thought", "saw", "bent", "will", "might", "cut",
);

# "..oes" -> "..oe" (the rest are "..oes" -> "o")

my $PL_v_oes_oe = enclose join "|",
qw(
    .*shoes  .*hoes  .*toes
    canoes   floes   oboes  roes  throes  woes
);

my $PL_count_zero = enclose join '|',
(
0, "no", "zero", "nil"
);

my $PL_count_one = enclose join '|',
(
1, "a", "an", "one", "each", "every", "this", "that",
);

my %PL_adj_special =
(
"a"    => "some",   "an"   =>  "some",
"this" => "these",  "that" => "those",
);
my $PL_adj_special = enclose join '|', keys %PL_adj_special;

my %PL_adj_poss =
(
"my"    => "our",
"your"  => "your",
"its"   => "their",
"her"   => "their",
"his"   => "their",
"their" => "their",
);
my $PL_adj_poss = enclose join '|', keys %PL_adj_poss;


sub checkpat
{
local $SIG{__WARN__} = sub {0};
do {$@ =~ s/at.*?$//;
    die "\nBad user-defined singular pattern:\n\t$@\n"}
    if (!eval "'' =~ m/$_[0]/; 1;" or $@);
return @_;
}

sub checkpatsubs
{
checkpat($_[0]);
if (defined $_[1])
{
    local $SIG{__WARN__} = sub {0};
    do {$@ =~ s/at.*?$//;
        die "\nBad user-defined plural string: '$_[1]'\n\t$@\n"}
        if (!eval "qq{$_[1]}; 1;" or $@);
}
return @_;
}

my @PL_sb_user_defined = ();
my @PL_v_user_defined  = ();
my @PL_adj_user_defined  = ();
my @A_a_user_defined   = ();

sub def_noun
{
    unshift @PL_sb_user_defined, checkpatsubs(@_);
    return 1;
}

sub def_verb
{
    unshift @PL_v_user_defined, checkpatsubs(@_[4,5]);
    unshift @PL_v_user_defined, checkpatsubs(@_[2,3]);
    unshift @PL_v_user_defined, checkpatsubs(@_[0,1]);
    return 1;
}

sub def_adj
{
    unshift @PL_adj_user_defined, checkpatsubs(@_);
    return 1;
}

sub def_a
{
unshift @A_a_user_defined, checkpat(@_,'a');
return 1;
}

sub def_an
{
unshift @A_a_user_defined, checkpat(@_,'an');
return 1;
}

sub ud_match
{
my $word = shift;
for (my $i=0; $i < @_; $i+=2)
{
    if ($word =~ /^(?:$_[$i])$/i)
    {
        last unless defined $_[$i+1];
        return eval '"'.$_[$i+1].'"';
    }
}
return undef;
}

do
{
local $SIG{__WARN__} = sub {0};
my $rcfile;

$rcfile = $INC{'Lingua//EN/Inflect.pm'} || '';
$rcfile =~ s/Inflect.pm$/.inflectrc/;
do $rcfile or die "\nBad .inflectrc file ($rcfile):\n\t$@\n"
if $rcfile && -r $rcfile && -s $rcfile;

$rcfile = "$ENV{HOME}/.inflectrc" || '';
do $rcfile or die "\nBad .inflectrc file ($rcfile):\n\t$@\n"
if $rcfile && -r $rcfile && -s $rcfile;
};

sub postprocess     # FIX PEDANTRY AND CAPITALIZATION :-)
{
my ($orig, $inflected) = @_;
$inflected =~ s/([^|]+)\|(.+)/ $classical{all}?$2:$1 /e;
return $orig =~ /^I$/   ? $inflected
 : $orig =~ /^[A-Z]+$/  ? uc $inflected
 : $orig =~ /^[A-Z]/    ? ucfirst $inflected
 :            $inflected;
}

sub PL
#   PL($word,$number)
{
my ($str, $count) = @_;
my ($pre, $word, $post) = ($str =~ m/\A(\s*)(.+?)(\s*)\Z/);
return $str unless $word;
my $plural = postprocess $word,  _PL_special_adjective($word,$count)
              || _PL_special_verb($word,$count)
              || _PL_noun($word,$count);
return $pre.$plural.$post;
}

sub PL_N
#   PL_N($word,$number)
{
my ($str, $count) = @_;
my ($pre, $word, $post) = ($str =~ m/\A(\s*)(.+?)(\s*)\Z/);
return $str unless $word;
my $plural = postprocess $word, _PL_noun($word,$count);
return $pre.$plural.$post;
}

sub PL_V
#   PL_V($word,$number)
{
my ($str, $count) = @_;
my ($pre, $word, $post) = ($str =~ m/\A(\s*)(.+?)(\s*)\Z/);
return $str unless $word;
my $plural = postprocess $word, _PL_special_verb($word,$count)
              || _PL_general_verb($word,$count);
return $pre.$plural.$post;
}

sub PL_ADJ
#   PL_ADJ($word,$number)
{
my ($str, $count) = @_;
my ($pre, $word, $post) = ($str =~ m/\A(\s*)(.+?)(\s*)\Z/);
return $str unless $word;
my $plural = postprocess $word, _PL_special_adjective($word,$count)
              || $word;
return $pre.$plural.$post;
}

sub PL_eq     { _PL_eq(@_, \&PL_N) || _PL_eq(@_, \&PL_V) || _PL_eq(@_, \&PL_ADJ); }
sub PL_N_eq   { _PL_eq(@_, \&PL_N); }
sub PL_V_eq   { _PL_eq(@_, \&PL_V); }
sub PL_ADJ_eq     { _PL_eq(@_, \&PL_ADJ); }

sub _PL_eq
{
my ( $word1, $word2, $PL ) = @_;
my %classval = %classical;
%classical = %all_classical;
my $result = "";
$result = "eq"  if !$result && $word1 eq $word2;
$result = "p:s" if !$result && $word1 eq &$PL($word2);
$result = "s:p" if !$result && &$PL($word1) eq $word2;
%classical = ();
$result = "p:s" if !$result && $word1 eq &$PL($word2);
$result = "s:p" if !$result && &$PL($word1) eq $word2;
%classical = %classval;

if ($PL == \&PL || $PL == \&PL_N)
{
    $result = "p:p"
        if !$result && _PL_check_plurals_N($word1,$word2);
    $result = "p:p"
        if !$result && _PL_check_plurals_N($word2,$word1);
}
if ($PL == \&PL || $PL == \&PL_ADJ)
{
    $result = "p:p"
        if !$result && _PL_check_plurals_ADJ($word1,$word2,$PL);
}

return $result;
}

sub _PL_reg_plurals
{
    $_[0] =~ /($_[1])($_[2]\|\1$_[3]|$_[3]\|\1$_[2])/
}

sub _PL_check_plurals_N
{
my $pair = "$_[0]|$_[1]";
foreach ( values %PL_sb_irregular_s )   { return 1 if $_ eq $pair; }
foreach ( values %PL_sb_irregular ) { return 1 if $_ eq $pair; }

return 1 if
        _PL_reg_plurals($pair, $PL_sb_U_a_ata,   "as","ata")
     || _PL_reg_plurals($pair, $PL_sb_C_a_ata,   "as","ata")
     || _PL_reg_plurals($pair, $PL_sb_U_is_ides, "is","ides")
     || _PL_reg_plurals($pair, $PL_sb_C_is_ides, "is","ides")
     || _PL_reg_plurals($pair, $PL_sb_C_a_ae,    "s","e")
     || _PL_reg_plurals($pair, $PL_sb_C_en_ina,  "ens","ina")
     || _PL_reg_plurals($pair, $PL_sb_C_um_a,    "ums","a")
     || _PL_reg_plurals($pair, $PL_sb_C_us_i,    "uses","i")
     || _PL_reg_plurals($pair, $PL_sb_C_on_a,    "ons","a")
     || _PL_reg_plurals($pair, $PL_sb_C_o_i,     "os","i")
     || _PL_reg_plurals($pair, $PL_sb_C_ex_ices, "exes","ices")
     || _PL_reg_plurals($pair, $PL_sb_C_ix_ices, "ixes","ices")
     || _PL_reg_plurals($pair, $PL_sb_C_i,       "s","i")
     || _PL_reg_plurals($pair, $PL_sb_C_im,      "s","im")

     || _PL_reg_plurals($pair, '.*eau',       "s","x")
     || _PL_reg_plurals($pair, '.*ieu',       "s","x")
     || _PL_reg_plurals($pair, '.*tri',       "xes","ces")
     || _PL_reg_plurals($pair, '.{2,}[yia]n', "xes","ges");


return 0;
}

sub _PL_check_plurals_ADJ
{
my ( $word1a, $word2a ) = @_;
my ( $word1b, $word2b ) = @_;

$word1a = '' unless $word1a =~ s/'s?$//;
$word2a = '' unless $word2a =~ s/'s?$//;
$word1b = '' unless $word1b =~ s/s'$//;
$word2b = '' unless $word2b =~ s/s'$//;

if ($word1a)
{
    return 1 if $word2a && ( _PL_check_plurals_N($word1a, $word2a)
                || _PL_check_plurals_N($word2a, $word1a) );
    return 1 if $word2b && ( _PL_check_plurals_N($word1a, $word2b)
                || _PL_check_plurals_N($word2b, $word1a) );
}
if ($word1b)
{
    return 1 if $word2a && ( _PL_check_plurals_N($word1b, $word2a)
                || _PL_check_plurals_N($word2a, $word1b) );
    return 1 if $word2b && ( _PL_check_plurals_N($word1b, $word2b)
                || _PL_check_plurals_N($word2b, $word1b) );
}


return "";
}

sub _PL_noun
{
my ( $word, $count ) = @_;
my $value;              # UTILITY VARIABLE

# DEFAULT TO PLURAL

$count = $persistent_count
    if !defined($count) && defined($persistent_count);

$count = (defined $count and $count=~/^($PL_count_one)$/io
         or defined $count and $classical{zero}
         and $count=~/^($PL_count_zero)$/io)
            ? 1
            : 2;

return $word if $count==1;

# HANDLE USER-DEFINED NOUNS

return $value if defined($value = ud_match($word, @PL_sb_user_defined));


# HANDLE EMPTY WORD, SINGULAR COUNT AND UNINFLECTED PLURALS

$word eq ''         and return $word;

$word =~ /^($PL_sb_uninflected)$/i && !exists $PL_sb_irregular{$word} && $word !~ /^($PL_sb_lese_lesen)$/i
                and return $word;

$classical{herd} and $word =~ /^($PL_sb_uninflected_herd)$/i
                and return $word;


# HANDLE ISOLATED IRREGULAR PLURALS

$word =~ /^($PL_sb_irregular)$/i
                and return ( $PL_sb_irregular{$1} || $PL_sb_irregular{lc $1} );
$word =~ /(.*)\b($PL_sb_irregular)$/i
                and return $1 . ( $PL_sb_irregular{$2} || $PL_sb_irregular{lc $2} );


# HANDLE COMPOUNDS ("Governor General", "mother-in-law", "aide-de-camp", ETC.)

$word =~ /^(?:$PL_sb_postfix_adj)$/i
                and $value = $2
                and return _PL_noun($1,2)
                       . $value;

$word =~ /^(?:$PL_sb_prep_dual_compound)$/i
                and $value = [$2,$3]
                and return _PL_noun($1,2)
                       . $value->[0]
                       . _PL_noun($value->[1]);

$word =~ /^(?:$PL_sb_prep_compound)$/i
                and $value = $2
                and return _PL_noun($1,2)
                       . $value;

# HANDLE PRONOUNS

$word =~ /^((?:$PL_prep)\s+)($PL_pron_acc)$/i
                and return $1.$PL_pron_acc{lc($2)};

$value = $PL_pron_nom{lc($word)}
                and return $value;

$word =~ /^($PL_pron_acc)$/i
                and return $PL_pron_acc{lc($1)};


# HANDLE FAMILIES OF IRREGULAR PLURALS

$word =~ /(.*$PL_sb_U_man_mans)$/i
                and return "$1s";
$word =~ /(\S*)quy$/i
                and return "$1quies";
$word =~ /(\S*)(person)$/i and return $classical{persons}?"$1persons":"$1people";
$word =~ /(.*)man$/i        and return "$1men";
$word =~ /(.*[ml])ouse$/i   and return "$1ice";
$word =~ /(.*)goose$/i      and return "$1geese";
$word =~ /(.*)tooth$/i      and return "$1teeth";
$word =~ /(.*)foot$/i       and return "$1feet";

# HANDLE UNASSIMILATED IMPORTS

$word =~ /(.*)ceps$/i       and return $word;
$word =~ /(.*)zoon$/i       and return "$1zoa";
$word =~ /(.*[csx])is$/i    and return "$1es";
$word =~ /(.*$PL_sb_U_a_ata)a$/i  and return "$1ata";
$word =~ /(.*$PL_sb_U_is_ides)is$/i   and return "$1ides";
$word =~ /(.*$PL_sb_U_ch_chs)ch$/i    and return "$1chs";
$word =~ /(.*$PL_sb_U_ex_ices)ex$/i   and return "$1ices";
$word =~ /(.*$PL_sb_U_ix_ices)ix$/i   and return "$1ices";
$word =~ /(.*$PL_sb_U_um_a)um$/i  and return "$1a";
$word =~ /(.*$PL_sb_U_us_i)us$/i  and return "$1i";
$word =~ /(.*$PL_sb_U_on_a)on$/i  and return "$1a";
$word =~ /(.*$PL_sb_U_a_ae)$/i    and return "$1e";
$word =~ /(.*$PL_sb_lese_lesen)$/i    and return "$1n";

# HANDLE INCOMPLETELY ASSIMILATED IMPORTS

if ($classical{ancient})
{
    $word =~ /(.*)trix$/i       and return "$1trices";
    $word =~ /(.*)eau$/i        and return "$1eaux";
    $word =~ /(.*)ieu$/i        and return "$1ieux";
    $word =~ /(.{2,}[yia])nx$/i     and return "$1nges";
    $word =~ /(.*$PL_sb_C_en_ina)en$/i    and return "$1ina";
    $word =~ /(.*$PL_sb_C_ex_ices)ex$/i   and return "$1ices";
    $word =~ /(.*$PL_sb_C_ix_ices)ix$/i   and return "$1ices";
    $word =~ /(.*$PL_sb_C_um_a)um$/i  and return "$1a";
    $word =~ /(.*$PL_sb_C_us_i)us$/i  and return "$1i";
    $word =~ /(.*$PL_sb_C_us_us)$/i   and return "$1";
    $word =~ /(.*$PL_sb_C_a_ae)$/i    and return "$1e";
    $word =~ /(.*$PL_sb_C_a_ata)a$/i  and return "$1ata";
    $word =~ /(.*$PL_sb_C_is_ides)is$/i   and return "$1ides";
    $word =~ /(.*$PL_sb_C_o_i)o$/i    and return "$1i";
    $word =~ /(.*$PL_sb_C_on_a)on$/i  and return "$1a";
    $word =~ /$PL_sb_C_im$/i        and return "${word}im";
    $word =~ /$PL_sb_C_i$/i     and return "${word}i";
}


# HANDLE SINGULAR NOUNS ENDING IN ...s OR OTHER SILIBANTS

$word =~ /^($PL_sb_singular_s)$/i   and return "$1es";
$word =~ /^([A-Z].*s)$/             and $classical{names} and return "$1es";
$word =~ /^($PL_sb_z_zes)$/i        and return "$1es";
$word =~ /^(.*[^z])(z)$/i           and return "$1zzes";
$word =~ /^(.*)([cs]h|x|zz|ss)$/i   and return "$1$2es";
# $word =~ /(.*)(us)$/i             and return "$1$2es";

# HANDLE ...f -> ...ves

$word =~ /(.*[eao])lf$/i    and return "$1lves";
$word =~ /(.*[^d])eaf$/i    and return "$1eaves";
$word =~ /(.*[nlw])ife$/i   and return "$1ives";
$word =~ /(.*)arf$/i        and return "$1arves";

# HANDLE ...y

$word =~ /(.*[aeiou])y$/i   and return "$1ys";
$word =~ /([A-Z].*y)$/      and $classical{names} and return "$1s";
$word =~ /(.*)y$/i      and return "$1ies";

# HANDLE ...o

$word =~ /$PL_sb_U_o_os$/i  and return "${word}s";
$word =~ /[aeiou]o$/i       and return "${word}s";
$word =~ /o$/i          and return "${word}es";


# OTHERWISE JUST ADD ...s

return "${word}s";
}


sub _PL_special_verb
{
my ( $word, $count ) = @_;
$count = $persistent_count
    if !defined($count) && defined($persistent_count);
$count = (defined $count and $count=~/^($PL_count_one)$/io or
      defined $count and $classical{zero} and $count=~/^($PL_count_zero)$/io) ? 1
       : 2;

return undef if $count=~/^($PL_count_one)$/io;

my $value;              # UTILITY VARIABLE

# HANDLE USER-DEFINED VERBS

return $value if defined($value = ud_match($word, @PL_v_user_defined));

# HANDLE IRREGULAR PRESENT TENSE (SIMPLE AND COMPOUND)

$word =~ /^($PL_v_irregular_pres)((\s.*)?)$/i
        and return $PL_v_irregular_pres{lc $1}.$2;

# HANDLE IRREGULAR FUTURE, PRETERITE AND PERFECT TENSES

$word =~ /^($PL_v_irregular_non_pres)((\s.*)?)$/i
        and return $word;

# HANDLE PRESENT NEGATIONS (SIMPLE AND COMPOUND)

$word =~ /^($PL_v_irregular_pres)(n't(\s.*)?)$/i
        and return $PL_v_irregular_pres{lc $1}.$2;

$word =~ /^\S+n't\b/i
        and return $word;

# HANDLE SPECIAL CASES

$word =~ /^($PL_v_special_s)$/      and return undef;
$word =~ /\s/                       and return undef;
$word =~ /^quizzes$/i               and return "quiz";

# HANDLE STANDARD 3RD PERSON (CHOP THE ...(e)s OFF SINGLE WORDS)

$word =~ /^(.*)([cs]h|[x]|zz|ss)es$/i   and return "$1$2";

$word =~ /^(..+)ies$/i          and return "$1y";

$word =~ /($PL_v_oes_oe)$/      and return substr($1,0,-1);
$word =~ /^(.+)oes$/i           and return "$1o";

$word =~ /^(.*[^s])s$/i         and return $1;

# OTHERWISE, A REGULAR VERB (HANDLE ELSEWHERE)

return undef;
}

sub _PL_general_verb
{
my ( $word, $count ) = @_;
$count = $persistent_count
    if !defined($count) && defined($persistent_count);
$count = (defined $count and $count=~/^($PL_count_one)$/io or
      defined $count and $classical{zero} and $count=~/^($PL_count_zero)$/io) ? 1
       : 2;

return $word if $count=~/^($PL_count_one)$/io;

# HANDLE AMBIGUOUS PRESENT TENSES  (SIMPLE AND COMPOUND)

$word =~ /^($PL_v_ambiguous_pres)((\s.*)?)$/i
        and return $PL_v_ambiguous_pres{lc $1}.$2;

# HANDLE AMBIGUOUS PRETERITE AND PERFECT TENSES

$word =~ /^($PL_v_ambiguous_non_pres)((\s.*)?)$/i
        and return $word;

# OTHERWISE, 1st OR 2ND PERSON IS UNINFLECTED

return $word;

}

sub _PL_special_adjective
{
my ( $word, $count ) = @_;
$count = $persistent_count
    if !defined($count) && defined($persistent_count);
$count = (defined $count and $count=~/^($PL_count_one)$/io or
      defined $count and $classical{zero} and $count=~/^($PL_count_zero)$/io) ? 1
       : 2;

return $word if $count=~/^($PL_count_one)$/io;


# HANDLE USER-DEFINED ADJECTIVES

my $value;
return $value if defined($value = ud_match($word, @PL_adj_user_defined));

# HANDLE KNOWN CASES

$word =~ /^($PL_adj_special)$/i
            and return $PL_adj_special{lc $1};

# HANDLE POSSESSIVES

$word =~ /^($PL_adj_poss)$/i
            and return $PL_adj_poss{lc $1};

$word =~ /^(.*)'s?$/    and do { my $pl = PL_N($1);
                 return "$pl'" . ($pl =~ m/s$/ ? "" : "s");
                   };

# OTHERWISE, NO IDEA

return undef;

}


# 2. INDEFINITE ARTICLES

# THIS PATTERN MATCHES STRINGS OF CAPITALS STARTING WITH A "VOWEL-SOUND"
# CONSONANT FOLLOWED BY ANOTHER CONSONANT, AND WHICH ARE NOT LIKELY
# TO BE REAL WORDS (OH, ALL RIGHT THEN, IT'S JUST MAGIC!)

my $A_abbrev = q{
(?! FJO | [HLMNS]Y.  | RY[EO] | SQU
  | ( F[LR]? | [HL] | MN? | N | RH? | S[CHKLMNPTVW]? | X(YL)?) [AEIOU])
[FHLMNRSX][A-Z]
};

# THIS PATTERN CODES THE BEGINNINGS OF ALL ENGLISH WORDS BEGINING WITH A
# 'y' FOLLOWED BY A CONSONANT. ANY OTHER Y-CONSONANT PREFIX THEREFORE
# IMPLIES AN ABBREVIATION.

my $A_y_cons = 'y(b[lor]|cl[ea]|fere|gg|p[ios]|rou|tt)';

# EXCEPTIONS TO EXCEPTIONS

my $A_explicit_an = enclose join '|',
(
    "euler",
    "hour(?!i)", "heir", "honest", "hono",
);

my $A_ordinal_an = enclose join '|',
(
    "[aefhilmnorsx]-?th",
);

my $A_ordinal_a = enclose join '|',
(
    "[bcdgjkpqtuvwyz]-?th",
);

sub A {
    my ($str, $count) = @_;
    my ($pre, $word, $post) = ( $str =~ m/\A(\s*)(?:an?\s+)?(.+?)(\s*)\Z/i );
    return $str unless $word;
    my $result = _indef_article($word,$count);
    return $pre.$result.$post;
}

sub AN { goto &A }

sub _indef_article {
    my ( $word, $count ) = @_;

    $count = $persistent_count
        if !defined($count) && defined($persistent_count);

    return "$count $word"
        if defined $count && $count!~/^($PL_count_one)$/io;

    # HANDLE USER-DEFINED VARIANTS

    my $value;
    return "$value $word"
        if defined($value = ud_match($word, @A_a_user_defined));

    # HANDLE ORDINAL FORMS

    $word =~ /^($A_ordinal_a)/i         and return "a $word";
    $word =~ /^($A_ordinal_an)/i        and return "an $word";

    # HANDLE SPECIAL CASES

    $word =~ /^($A_explicit_an)/i       and return "an $word";
    $word =~ /^[aefhilmnorsx]$/i        and return "an $word";
    $word =~ /^[bcdgjkpqtuvwyz]$/i      and return "a $word";


    # HANDLE ABBREVIATIONS

    $word =~ /^($A_abbrev)/ox           and return "an $word";
    $word =~ /^[aefhilmnorsx][.-]/i     and return "an $word";
    $word =~ /^[a-z][.-]/i              and return "a $word";

    # HANDLE CONSONANTS

    $word =~ /^[^aeiouy]/i              and return "a $word";

    # HANDLE SPECIAL VOWEL-FORMS

    $word =~ /^e[uw]/i                  and return "a $word";
    $word =~ /^onc?e\b/i                and return "a $word";
    $word =~ /^uni([^nmd]|mo)/i         and return "a $word";
    $word =~ /^ut[th]/i                 and return "an $word";
    $word =~ /^u[bcfhjkqrst][aeiou]/i   and return "a $word";

    # HANDLE SPECIAL CAPITALS

    $word =~ /^U[NK][AIEO]?/            and return "a $word";

    # HANDLE VOWELS

    $word =~ /^[aeiou]/i                and return "an $word";

    # HANDLE y... (BEFORE CERTAIN CONSONANTS IMPLIES (UNNATURALIZED) "i.." SOUND)

    $word =~ /^($A_y_cons)/io           and return "an $word";

    # OTHERWISE, GUESS "a"
    return "a $word";
}

# 2. TRANSLATE ZERO-QUANTIFIED $word TO "no PL($word)"

sub NO
{
    my ($str, $count, $opt_ref) = @_;
    my ($pre, $word, $post) = ($str =~ m/\A(\s*)(.+?)(\s*)\Z/);

    $count = $persistent_count
        if !defined($count) && defined($persistent_count);
    $count = 0 unless $count;

    if ($count =~ /^$PL_count_zero$/) {
        return "${pre}no ". PL($word,0) . $post ;
    }

    $count =~ s{[^\d.e+-]}{}gi;
    1 while $count =~ s{([.].*)[.]}{$1};
    $count = defined $opt_ref->{words_below} && $count < $opt_ref->{words_below}
                 ? NUMWORDS($count)
                 : $count;

    if (defined $opt_ref->{comma} || defined $opt_ref->{comma_every}) {
        $opt_ref->{comma_every} = 3   if !defined $opt_ref->{comma_every};
        $opt_ref->{comma}       = ',' if !defined $opt_ref->{comma}
                                      || $opt_ref->{comma} =~ /^\d+$/;

        $count = _commify($count, @{$opt_ref}{'comma','comma_every'});
    }

    return "$pre$count " . PL($word,$count) . $post
}

sub _commify {
    my ($number, $comma, $every) = @_;
    return if !defined $comma;
    return if !defined $comma;
    $number =~ s{(?:(?<=^)|(?<=^-))(\d\d{$every,})}
                { my $n = $1;
                  $n=~s/(?<=.)(?=(?:.{$every})+$)/$comma/g;
                  $n;
                }e;
    return $number;
}

# PARTICIPLES

sub PART_PRES
{
        local $_ = PL_V(shift,2);
           s/ie$/y/
        or s/ue$/u/
        or s/([auy])e$/$1/
        or s/ski$/ski/
        or s/[^b]i$//
        or s/^(are|were)$/be/
        or s/^(had)$/hav/
        or s/(hoe)$/$1/
        or s/([^e])e$/$1/
        or m/er$/
        or s/([^aeiou][aeiouy]([bdgmnprst]))$/$1$2/;
        return "${_}ing";
}



# NUMERICAL INFLECTIONS

my %nth =
(
    0 => 'th',
    1 => 'st',
    2 => 'nd',
    3 => 'rd',
    4 => 'th',
    5 => 'th',
    6 => 'th',
    7 => 'th',
    8 => 'th',
    9 => 'th',
    11 => 'th',
    12 => 'th',
    13 => 'th',
);


my %ordinal;
@ordinal{qw(ty    one   two    three five  eight  nine  twelve )}=
         qw(tieth first second third fifth eighth ninth twelfth);

my $ordinal_suff = join '|', keys %ordinal, "";

$ordinal{""} = 'th';

sub ORD($)
{
    my $num = shift;
    if ($num =~ /\d/) {
        my $tail = substr($num, -3);
        return $num . ($nth{$tail%100} || $nth{$tail%10});
    }
    else {
        $num =~ s/($ordinal_suff)\Z/$ordinal{$1}/;
        return $num;
    }
}


my %default_args =
(
    'group'   => 0,
    'comma'   => ',',
    'and'     => 'and',
    'zero'    => 'zero',
    'one'     => 'one',
    'decimal' => 'point',
);

my @unit = ('',qw(one two three four five six seven eight nine));
my @teen = qw(ten eleven twelve thirteen fourteen
          fifteen sixteen seventeen eighteen nineteen);
my @ten  = ('','',qw(twenty thirty forty fifty sixty seventy eighty ninety));

## From http://en.wikipedia.org/wiki/Names_of_large_numbers
our %millmap = (
     #num zeros
     '0'    => { US => q(),                       UK => q(),                                       EU => q()},
     '3'    => { US => q(thousand),               UK => q(thousand),                               EU => q(thousand)},
     '6'    => { US => q(million),                UK => q(million),                                EU => q(million)},
     '9'    => { US => q(billion),                UK => q(thousand million),                       EU => q(milliard)},
     '12'   => { US => q(trillion),               UK => q(billion),                                EU => q(billion)},
     '15'   => { US => q(quadrillion),            UK => q(thousand billion),                       EU => q(billiard)},
     '18'   => { US => q(quintillion),            UK => q(trillion),                               EU => q(trillion)},
     '21'   => { US => q(sextillion),             UK => q(thousand trillion),                      EU => q(trilliard)},
     '24'   => { US => q(septillion),             UK => q(quadrillion),                            EU => q(quadrillion)},
     '27'   => { US => q(octillion),              UK => q(thousand quadrillion),                   EU => q(quadrilliard)},
     '30'   => { US => q(nonillion),              UK => q(quintillion),                            EU => q(quintillion)},
     '33'   => { US => q(decillion),              UK => q(thousand quintillion),                   EU => q(quintilliard)},
     '36'   => { US => q(undecillion),            UK => q(sextillion),                             EU => q(sextillion)},
     '39'   => { US => q(duodecillion),           UK => q(thousand sextillion),                    EU => q(sextilliard)},
     '42'   => { US => q(tredecillion),           UK => q(septillion),                             EU => q(septillion)},
     '45'   => { US => q(quattuordecillion),      UK => q(thousand septillion),                    EU => q(septilliard)},
     '48'   => { US => q(quindecillion),          UK => q(octillion),                              EU => q(octillion)},
     '51'   => { US => q(sedecillion),            UK => q(thousand octillion),                     EU => q(octilliard)},
     '54'   => { US => q(septendecillion),        UK => q(nonillion),                              EU => q(nonillion)},
     '57'   => { US => q(octodecillion),          UK => q(thousand nonillion),                     EU => q(nonilliard)},
     '60'   => { US => q(novendecillion),         UK => q(decillion),                              EU => q(decillion)},
     '63'   => { US => q(vigintillion),           UK => q(thousand decillion),                     EU => q(decilliard)},
     '66'   => { US => q(unvigintillion),         UK => q(undecillion),                            EU => q(undecillion)},
     '69'   => { US => q(duovigintillion),        UK => q(thousand undecillion),                   EU => q(undecilliard)},
     '72'   => { US => q(tresvigintillion),       UK => q(duodecillion),                           EU => q(duodecillion)},
     '75'   => { US => q(quattuorvigintillion),   UK => q(thousand duodecillion),                  EU => q(duodecilliard)},
     '78'   => { US => q(quinquavigintillion),    UK => q(tredecillion),                           EU => q(tredecillion)},
     '81'   => { US => q(sesvigintillion),        UK => q(thousand tredecillion),                  EU => q(tredecilliard)},
     '84'   => { US => q(septemvigintillion),     UK => q(quattuordecillion),                      EU => q(quattuordecillion)},
     '87'   => { US => q(octovigintillion),       UK => q(thousand quattuordecillion),             EU => q(quattuordecilliard)},
     '90'   => { US => q(novemvigintillion),      UK => q(quindecillion),                          EU => q(quindecillion)},
     '93'   => { US => q(trigintillion),          UK => q(thousand quindecillion),                 EU => q(quindecilliard)},
     '96'   => { US => q(untrigintillion),        UK => q(sedecillion),                            EU => q(sedecillion)},
     '99'   => { US => q(duotrigintillion),       UK => q(thousand sedecillion),                   EU => q(sedecilliard)},
     '102'  => { US => q(trestrigintillion),      UK => q(septendecillion),                        EU => q(septendecillion)},
     '105'  => { US => q(quattuortrigintillion),  UK => q(thousand septendecillion),               EU => q(septendecilliard)},
     '108'  => { US => q(quinquatrigintillion),   UK => q(octodecillion),                          EU => q(octodecillion)},
     '111'  => { US => q(sestrigintillion),       UK => q(thousand octodecillion),                 EU => q(octodecilliard)},
     '114'  => { US => q(septentrigintillion),    UK => q(novendecillion),                         EU => q(novendecillion)},
     '117'  => { US => q(octotrigintillion),      UK => q(thousand novendecillion),                EU => q(novendecilliard)},
     '120'  => { US => q(noventrigintillion),     UK => q(vigintillion),                           EU => q(vigintillion)},
     '123'  => { US => q(quadragintillion),       UK => q(thousand vigintillion),                  EU => q(vigintilliard)},
     '153'  => { US => q(quinquagintillion),      UK => q(thousand quinquavigintillion),           EU => q(quinquavigintilliard) },
     '183'  => { US => q(sexagintillion),         UK => q(thousand trigintillion),                 EU => q(trigintilliard) },
     '213'  => { US => q(septuagintillion),       UK => q(thousand quinquatrigintillion),          EU => q(quinquatrigintilliard) },
     '243'  => { US => q(octogintillion),         UK => q(thousand quadragintillion),              EU => q(quadragintilliard) },
     '273'  => { US => q(nonagintillion),         UK => q(thousand quinquaquadragintillion),       EU => q(quinquaquadragintilliard) },
     '303'  => { US => q(centillion),             UK => q(thousand quinquagintillion),             EU => q(quinquagintilliard) },
     '306'  => { US => q(uncentillion),           UK => q(unquinquagintillion),                    EU => q(unquinquagintillion) },
     '309'  => { US => q(duocentillion),          UK => q(thousand unquinquagintillion),           EU => q(unquinquagintilliard) },
     '312'  => { US => q(trescentillion),         UK => q(duoquinquagintillion),                   EU => q(duoquinquagintillion) },
     '333'  => { US => q(decicentillion),         UK => q(thousand quinquaquinquagintillion),      EU => q(quinquaquinquagintilliard) },
     '336'  => { US => q(undecicentillion),       UK => q(sesquinquagintillion),                   EU => q(sesquinquagintillion) },
     '363'  => { US => q(viginticentillion),      UK => q(thousand sexagintillion),                EU => q(sexagintilliard) },
     '366'  => { US => q(unviginticentillion),    UK => q(unsexagintillion),                       EU => q(unsexagintillion) },
     '393'  => { US => q(trigintacentillion),     UK => q(thousand quinquasexagintillion),         EU => q(quinquasexagintilliard) },
     '423'  => { US => q(quadragintacentillion),  UK => q(thousand septuagintillion),              EU => q(septuagintilliard) },
     '453'  => { US => q(quinquagintacentillion), UK => q(thousand quinquaseptuagintillion),       EU => q(quinquaseptuagintilliard) },
     '483'  => { US => q(sexagintacentillion),    UK => q(thousand octogintillion),                EU => q(octogintilliard) },
     '513'  => { US => q(septuagintacentillion),  UK => q(thousand quinquaoctogintillion),         EU => q(quinquaoctogintilliard) },
     '543'  => { US => q(octogintacentillion),    UK => q(thousand nonagintillion),                EU => q(nonagintilliard) },
     '573'  => { US => q(nonagintacentillion),    UK => q(thousand quinquanonagintillion),         EU => q(quinquanonagintilliard) },
     '603'  => { US => q(ducentillion),           UK => q(thousand centillion),                    EU => q(centilliard) },
     '903'  => { US => q(trecentillion),          UK => q(thousand quinquagintacentillion),        EU => q(quinquagintacentilliard) },
     '1203' => { US => q(quadringentillion),      UK => q(thousand ducentillion),                  EU => q(ducentilliard) },
     '1503' => { US => q(quingentillion),         UK => q(thousand quinquagintaducentillion),      EU => q(quinquagintaducentilliard) },
     '1803' => { US => q(sescentillion),          UK => q(thousand trecentillion),                 EU => q(trecentilliard) },
     '2103' => { US => q(septingentillion),       UK => q(thousand quinquagintatrecentillion),     EU => q(quinquagintatrecentilliard) },
     '2403' => { US => q(octingentillion),        UK => q(thousand quadringentillion),             EU => q(quadringentilliard) },
     '2703' => { US => q(nongentillion),          UK => q(thousand quinquagintaquadringentillion), EU => q(quinquagintaquadringentilliard) },
     '3003' => { US => q(millinillion),           UK => q(thousand quingentillion),                EU => q(quingentilliard) },
);

my $millchoice = 'US';
my @millkeys = sort {$a <=> $b } keys %millmap;
my $maxmill = (sort {$a <=> $b } keys %millmap)[-1];
our $millast = undef;
our @mill;
for my $numZeros ( 0..$maxmill ) {
    next if $numZeros%3 != 0;
    my $arraySlot = $numZeros/3;
    if( defined( $millmap{$numZeros} ) ) {
        $mill[$arraySlot] = " $millmap{$numZeros}->{$millchoice}";
        $millast = $arraySlot;
    } else {
        my $missing = $arraySlot - $millast;
        $mill[$arraySlot] = $mill[$missing] . $mill[$millast];
    }
}

sub mill { my $ind = $_[0]||0;
       die "Number out of range\n" if $ind > $#mill;
       return $ind<@mill ? $mill[$ind] : ' ???illion'; }

sub unit { return $unit[$_[0]]. mill($_[1]); }

sub ten
{
    return $ten[$_[0]] . ($_[0]&&$_[1]?'-':'') . $unit[$_[1]] . mill($_[2])
        if $_[0] ne '1';
    return $teen[$_[1]]. $mill[$_[2]||0];
}

sub hund
{
    return unit($_[0]) . " hundred" . ($_[1] || $_[2] ? " $_[4] " : '')
         . ten($_[1],$_[2]) . mill($_[3]) . ', ' if $_[0];
    return ten($_[1],$_[2]) . mill($_[3]) . ', ' if $_[1] || $_[2];
    return '';
}


sub enword
{
    my ($num,$group,$zero,$one,$comma,$and) = @_;

    if ($group==1)
    {
        $num =~ s/(\d)/ ($1==1 ? " $one" : $1 ? unit($1) :" $zero")."$comma " /eg;
    }
    elsif ($group==2)
    {
        $num =~ s/(\d)(\d)/ ($1 ? ten($1,$2) : $2 ? " $zero " . unit($2) : " $zero $zero") . "$comma " /eg;
        $num =~ s/(\d)/ ($1 ? unit($1) :" $zero")."$comma " /e;
    }
    elsif ($group==3)
    {
        $num =~ s/(\d)(\d)(\d)/ ($1==1 ? " $one" : $1 ? unit($1) :" $zero")." ".($2 ? ten($2,$3) : $3 ? " $zero " . unit($3) : " $zero $zero") . "$comma " /eg;
        $num =~ s/(\d)(\d)/ ($1 ? ten($1,$2) : $2 ? " $zero " . unit($2) : " $zero $zero") . "$comma " /e;
        $num =~ s/(\d)/ ($1==1 ? " $one" : $1 ? unit($1) :" $zero")."$comma " /e;
    }
    elsif ($num+0==0) {
        $num = $zero;
    }
    elsif ($num+0==1) {
        $num = $one;
    }
    else {
        $num =~ s/\A\s*0+//;
        my $mill = 0;
        1 while $num =~ s/(\d)(\d)(\d)(?=\D*\Z)/ hund($1,$2,$3,$mill++,$and) /e;
        $num =~ s/(\d)(\d)(?=\D*\Z)/ ten($1,$2,$mill)."$comma " /e;
        $num =~ s/(\d)(?=\D*\Z)/ unit($1,$mill) . "$comma "/e;
    }
    return $num;
}

sub NUMWORDS
{
    my $num = shift;

    if (@_ % 2 and require Carp) {
        die "Missing value in option list (odd number of option args) at"
          . join ' line ', (caller)[1,2];
    }

    my %arg = ( %default_args, @_ );
    my $group = $arg{group};

    # Handle "stylistic" conversions (up to a given threshold)...
    if (exists $arg{threshold} && $num > $arg{threshold}) {
        my ($whole, $frac) = split /[.]/, $num;
        while ($arg{comma}) {
            $whole =~ s{ (\d) ( \d{3}(?:,|\z) ) }{$1,$2}xms
                or last;
        }
        return $frac ? "$whole.$frac" : $whole;
    }

    die "Bad chunking option: $group\n" unless $group =~ /\A[0-3]\Z/;
    my $sign = ($num =~ /\A\s*\+/) ? "plus"
         : ($num =~ /\A\s*\-/) ? "minus"
         : '';

    my ($zero, $one) = @arg{'zero','one'};
    my $comma = $arg{comma};
    my $and = $arg{'and'};

    my $ord = $num =~ s/(st|nd|rd|th)\Z//;
    my @chunks = ($arg{decimal})
            ? $group ? split(/\./, $num) : split(/\./, $num, 2)
            : ($num);

    my $first = 1;

    if ($chunks[0] eq '') { $first=0; shift @chunks; }

    foreach ( @chunks )
    {
        s/\D//g;
        $_ = '0' unless $_;

        if (!$group && !$first) { $_ = enword($_,1,$zero,$one,$comma,$and) }
        else                    { $_ = enword($_,$group,$zero,$one,$comma,$and) }

        s/, \Z//;
        s/\s+,/,/g;
        s/, (\S+)\s+\Z/ $and $1/ if !$group and $first;
        s/\s+/ /g;
        s/(\A\s|\s\Z)//g;
        $first = '' if $first;
    }

    my @numchunks = ();
    if ($first =~ /0/)
    {
        unshift @chunks, '';
    }
    else
    {
        @numchunks = split /\Q$comma /, $chunks[0];
    }

    $numchunks[-1] =~ s/($ordinal_suff)\Z/$ordinal{$1}/
        if $ord and @numchunks;

    foreach (@chunks[1..$#chunks])
    {
        push @numchunks, $arg{decimal};
        push @numchunks, split /\Q$comma /;
    }

    if (wantarray)
    {
        unshift @numchunks, $sign if $sign;
        return @numchunks
    }
    elsif ($group)
    {
        return ($sign?"$sign ":'') .  join ", ", @numchunks;
    }
    else
    {
        $num = ($sign?"$sign ":'') . shift @numchunks;
        $first = ($num !~ /$arg{decimal}\Z/);
        foreach ( @numchunks )
        {
            if (/\A$arg{decimal}\Z/)
            {
                $num .= " $_";
                $first = 0;
            }
            elsif ($first)
            {
                $num .= "$comma $_";
            }
            else
            {
                $num .= " $_";
            }
        }
        return $num;
    }
}

# Join words with commas and a trailing 'and' (when appropriate)...

sub WORDLIST {
    my %opt;
    my @words;

    for my $arg (@_) {
        if (ref $arg eq 'HASH' ) {
            %opt = (%opt, %{$arg});
        }
        else {
            push @words, $arg;
        }
    }

    return ""                               if @words == 0;
    return "$words[0]"                      if @words == 1;

    my $conj = exists($opt{conj}) ? $opt{conj} : 'and';
    if (@words == 2) {
        $conj =~ s/^ (?=\S)  |  (?<=\S) $/ /gxms;
        return "$words[0]$conj$words[1]";
    }

    my $sep = exists $opt{sep}  ? $opt{sep}
              : grep(/,/, @words)   ? q{; }
              :                       q{, }
              ;

    my $final_sep = !exists $opt{final_sep}        ? "$sep $conj"
                    : length($opt{final_sep}) == 0 ? $conj
                    :                                "$opt{final_sep} $conj"
                    ;
    $final_sep =~ s/\s+/ /gmxs;
    $final_sep =~ s/^ (?=[^\W\d_])  |  (?<=\S) $/ /gxms;

    return join($sep, @words[0..@words-2]) . "$final_sep$words[-1]";
}



1;

__END__