File Coverage

blib/lib/Lingua/EN/Inflexion.pm

Criterion	Covered	Total	%
statement	81	91	89.0
branch	30	58	51.7
condition	16	29	55.1
subroutine	15	18	83.3
pod	4	5	80.0
total	146	201	72.6

package Lingua::EN::Inflexion;
use 5.010; use warnings;
use Carp;

our $VERSION = '0.001005';

# Import noun, verb, and adj classes...
use Lingua::EN::Inflexion::Term;

sub import {
    my (undef, @exports) = @_;

    # Export interface...
    @exports = qw< noun verb adj inflect wordlist >  if !@exports;

    # Handle renames...
    my %export_name;
    @exports = map { ref eq 'HASH' ? do { @export_name{keys %$_} = values %$_; keys %$_ } : $_ }
                   @exports;

    no strict 'refs';
    for my $func (@exports) {
        *{caller().'::'.($export_name{$func}//$func)} = \&{$func};
    }
}


# Noun constructor...
sub noun ($) {
    my ($noun) = @_;
    return Lingua::EN::Inflexion::Noun->new($noun);
}

# Verb constructor...
sub verb ($) {
    my ($verb) = @_;
    return Lingua::EN::Inflexion::Verb->new($verb);
}


# Verb constructor...
sub adj ($) {
    my ($adj) = @_;
    return Lingua::EN::Inflexion::Adjective->new($adj);
}


# Convert a list of words to...a list of words in a single string...
sub wordlist {
    my (@words, %opt);

    # Unpack the argument list...
    my $sep    = ',';
    my $conj   = 'and';
    for my $arg (@_) {
        my $argtype = ref($arg);

           if ($argtype eq q{})     { push @words, $arg; $sep = ';' if $arg =~ /,/; }
        elsif ($argtype eq q{HASH}) { @opt{keys %$arg} = values %$arg }
        else                        { croak 'Invalid $argtype argument to wordlist' }
    }

    # Fill in defaults...
    $conj = $opt{conj}   // $conj;
    $sep  = $opt{sep}    // $sep;

    # Set the Oxford comma...
    my $oxford = $opt{final_sep} // $sep;

    # Construct the list phrase...
    my $list = @words < 3
                    ? join(" $conj ", @words)
                    : join("$sep ", @words[0..$#words-1]) . "$oxford $conj $words[-1]";

    # Condense any extra whitespace...
    $list =~ s/(\s)\s+/$1/g;

    return $list;
}


# All-in-one inflexions...
my %word_for_number = (
    0 => 'zero',   5 => 'five',
    1 => 'one',    6 => 'six',
    2 => 'two',    7 => 'seven',
    3 => 'three',  8 => 'eight',
    4 => 'four',   9 => 'nine',
                  10 => 'ten',
);

my $normalize_opts = sub {
    my ($opts) = @_;

    if ($opts =~ m{ [[:upper:]] }x) {
        $opts =~ s{ [[:lower:]] }{}gx;
    }
    return lc $opts;
};

sub inflect($) {
    my ($string) = @_;

    my $inflexion = 'singular';

    my $transform = {
        'N'  => sub{
                    my ($term, $opts) = @_;
                    carp "Unknown '$_' option to  command"
                        for $opts =~ /([^cps])/;

                    my $word = noun($term);
                    $word = $word->classical if $opts =~ /c/i;

                    return $opts =~ /p/i ?  $word->plural
                         : $opts =~ /s/i ?  $word->singular
                         :                  $word->$inflexion;
                },

        'V'   => sub{ return verb(shift)->$inflexion; },

        'A'   => sub{ return adj(shift)->$inflexion; },

        '#' => sub{
                    my ($count, $opts) = @_;
                    $opts =~ s{e}{asw}g;
                    carp "Unknown '$_' option to <#:...> command"
                        for $opts =~ /([^acdefinosw\d])/;

                    # Increment count if requested...
                    if ($opts =~ /i/i) {
                        $count++;
                    }

                    # Decide which inflexion the count requires...
                    $inflexion
                        = $count == 1 || $opts =~ /s/i && $count == 0 || $opts =~ /o/i ? 'singular'
                        :                                                                'plural';

                    # Defer handling of A/AN...
                    if ($count == 1 && $opts =~ /a/i) {
                        return "<#a:>";
                    }

                    my $count_word = $opts =~ /w|o/i ? noun($count) : undef;
                       $count_word = $count_word->classical if $count_word && $opts =~ /c/i;

                    my $count_thresh = $opts =~ /w(\d+)/i ? $1 : 11;

                    # Otherwise, interpolate count or its equivalent (deferring fuzzies)...
                    return $opts =~ /n|s/i && $count == 0  ?  'no'
                         : $opts =~ /w/i && $opts =~ /o/i  ?  $count_word->ordinal($count_thresh)
                         : $opts =~ /w/i                   ?  $count_word->cardinal($count_thresh)
                         : $opts =~ /o/i                   ?  $count_word->ordinal(0)
                         : $opts =~ /f/i                   ?  "<#f:$count>"
                         : $opts =~ /d/                    ?  q{}
                         :                                    $count;
               },
    };

    # Inflect markups...
    $string =~ s{ (?
                    < (? (?-i: [#NVA] ) )  # FUNC is case-sensitive
                      (? [^:]* ) \s*
                    : \s* (? [^>]+? ) \s*
                    >
                    (? \s* )
                  )
                }{
                    my %parsed = %+;
                    my $opts = $normalize_opts->($parsed{OPTS});
                    my $func = $transform->{ uc $parsed{FUNC} } // sub{shift};
                    my $replacement = $func->( $parsed{TERM}, $opts );
                    length $replacement > 0 ? $replacement . $parsed{TWS} : q{}
                }gexmsi;

    # Inflect consequent A/AN's...
    $string =~ s{ <[#]a:> \s*+ (? \S++) }{ noun($+{next_word})->indefinite }gxe;
    $string =~ s{ <[#]a:> \s*+ \Z }{ "a" }xe;

    # Inflect fuzzies...
    state $fuzzy = sub {
        my ($count, $is_postfix) = @_;

        return $count >= 10 ? 'many'
             : $count >=  6 ? 'several'
             : $count >=  3 ? 'a few'
             : $count ==  2 ? 'a couple' . ($is_postfix ? q{} : ' of')
             : $count ==  1 ? 'one'
             :                ($is_postfix ? 'none' : 'no')
             ;
    };

    $string =~ s{ <\#f: (? \d++) > (?= \s*+ [[:alpha:]]) }
                { $fuzzy->($+{count}) }gxe;
    $string =~ s{ <\#f: (? \d++) > (?= [^[:alpha:]]*+ \Z) }
                { $fuzzy->($+{count}, 'postfix') }xe;

    # And we're done...
    return $string;
}


1; # Magic true value required at end of module
__END__