File Coverage

blib/lib/Lingua/ENG/Inflect.pm

Criterion	Covered	Total	%
statement	342	401	85.2
branch	359	440	81.5
condition	122	252	48.4
subroutine	38	49	77.5
pod	9	33	27.2
total	870	1175	74.0

package Lingua::ENG::Inflect;
# ABSTRACT: Plural inflection for ENG.

use 5.16.0;
use utf8;
use warnings;

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

require Exporter;
@ISA = qw(Exporter);
our $VERSION = '0.2603250';

%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,
);

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",
    "genus"     => "genera",
    "mythos"    => "mythoi",
    "penis"     => "penises|penes",
    "testis"    => "testes",
    "atlas"     => "atlases|atlantes",
    "yes"       => "yeses",
);

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',
    'Jerry'       => 'Jerrys',
    'jerry'       => 'jerries',
    'Mary'        => 'Marys',
    'mary'        => 'maries',
    'talouse'     => 'talouses',
    'blouse'      => 'blouses',
    'Rom'         => 'Roma',
    'rom'         => 'roma',

    %PL_sb_irregular_s,
);

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

# 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;

# 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",
);

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", "carmen"
);

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

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

# 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",
);

# 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",
);

# 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",
);

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

my $PL_sb_U_man_mans = enclose join "|",
qw(
    ataman caiman cayman ceriman
    desman dolman farman harman hetman
    human leman 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_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,
);

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)\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_sb_military = 'major|lieutenant|brigadier|adjutant|quartermaster';
my $PL_sb_general = '((?!'.$PL_sb_military.').*?)((-|\s+)general)';

my $PL_prep = enclose join '|', qw (
        about above across after among around at athwart before behind
        below beneath beside besides between betwixt beyond but by
        during except for from in into near of off on onto out over
        since till to under until unto upon with
);

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;
}

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

$rcfile = $INC{'Lingua//ENG/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_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_C_a_ata,   "as","ata")
     || _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
                and return $word;

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

# 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 ISOLATED IRREGULAR PLURALS

$word =~ /(.*)\b($PL_sb_irregular)$/i
                and return $1
                  . ( $PL_sb_irregular{$2} || $PL_sb_irregular{lc $2} );
$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";

# HANDLE FAMILIES OF IRREGULAR PLURALS

$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_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";

# 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 =~ /^(.*[^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 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;
$word =~ /\s/               and return;

# 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;
}

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;

}

# 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",
"[fhlmnx]-?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 if defined($value = ud_match($word, @A_a_user_defined));

# 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 =~ /^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) = @_;
my ($pre, $word, $post) = ($str =~ m/\A(\s*)(.+?)(\s*)\Z/);

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

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

# 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/i$//
        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/) {
        return $num . ($nth{$num%100} || $nth{$num%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));
my @mill = map { (my $val=$_) =~ s/_/illion/; " $val" }
       ('',qw(thousand m_ b_ tr_ quadr_ quint_ sext_ sept_ oct_ non_ dec_));

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/^ (?=[^\W\d_])  |  (?<=[^\W\d_]) $/ /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_])  |  (?<=[^\W\d_]) $/ /gxms;

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

1;

__END__