view release on metacpan or  search on metacpan

lib/Lingua/EN/Grammarian.pm  view on Meta::CPAN

        '<him>'  => q{him,her},
        '<us>'   => q{us,you,them},
        '<my>'   => q{my,your,hers,his,its,our,their},
        '<his>'  => q{her,his},
        '<our>'  => q{our,your,their},
        '<mine>' => q{mine,yours,hers,his,its,ours,theirs},
        '<hers>' => q{hers,his},
        '<ours>' => q{ours,yours,theirs},
    );


    # Preprocess <pronoun> expansions...
    my @components = split /($PRONOUN_MARKER)/, $term;
    $term = q{};
    my $in_parens = 0;
    while (@components) {
        my ($prefix, $pronoun) = splice(@components, 0, 2);
        $in_parens += ($prefix=~tr/(//) - ($prefix=~tr/)//);
        $term .= $prefix;
        if ($pronoun) {
            $term .= ($in_parens ? '' : '(')
                . ($PRONOUN_EXPANSION_FOR{$pronoun} // $pronoun)
                . ($in_parens ? '' : ')')
        }
    }

    # Convert any parenthesized or starred set of alternatives...
    my @inflexions;
    $term =~ s{ (?<root> \S*? (?<last_letter> \S? ) )
                (?:
                      (?<e_star>                  e [*]       )
                    | (?<ch_star>                ch [*]       )
                    | (?<y_star> (?<= [^aeiou] )  y [*]       )
                    | (?<y_s>    (?<= [^aeiou] )  y [(] s [)] )
                    | (?<double_star>               [*][*]    )
                    | (?<star>                      [*]       )
                    | [(] (?<alts> [^)]+ ) [)]
                )
                }
                {
                my $ll = $+{last_letter};
                @inflexions = $+{e_star}      ? ( 'e',    'es',      'ed',     'ing')
                            : $+{ch_star}     ? ( 'ch', 'ches',    'ched',   'ching')
                            : $+{y_star}      ? ( 'y',   'ies',     'ied',    'ying')
                            : $+{y_s}         ? ( 'y',   'ies',                     )
                            : $+{double_star} ? (  '',     's',  $ll.'ed', $ll.'ing')
                            : $+{star}        ? (  '',     's',      'ed',     'ing')
                            : $+{alts}        ? ( ($+{root} ? '' : ()), split(',', $+{alts}) )
                            :                     ();

                qq{$+{root}*};
                }xmse;

    return @inflexions ? map { my $infl = $term; $infl =~ s{[*]}{$_}; $infl} @inflexions
                       : $term;
}

# Parse cautions file and convert to internal data structures...
sub _load_cautions {
    # Gather config from current directory and home directory...
    local @ARGV = grep { -e }
                  map { ("$_.$CAUTIONS_FILE", "$_$CAUTIONS_FILE") }
                  @CONFIG_PATH;

    # If no config, we're done...
    return if !@ARGV;

    # Store sets of terms together...
    my @term_sets = { terms => [], defns => [], inflexions => [] };

    # Parse configuration file...
    LINE:
    while (my $next_line = readline) {
        # Ignore comments...
        next LINE if $next_line =~ m{ \A \h* [#] }xms;

        # Blank lines delimit new term sets...
        if ($next_line =~ m{\A \h* \Z}xms) {
            push @term_sets, { terms => [], defns => [], inflexions => [] };
            next LINE;
        }

        # Parse config line...
        $next_line =~ m{
            \A
                (?<is_silent> -?  )
            \h* (?<term> [^:]*? )
            (?:
                \h*  :
                \h*  (?<defn> .*? )
            )?
            \h*
            \Z
        }xms;

        # Unpack components...
        my $term      = $+{term};
        my $defn      = $+{defn} // q{};
        my $is_silent = length($+{is_silent});

        # Warn of bad config...
        if (!defined $term) {
            warn "Invalid entry in grammarian_cautions: $next_line";
            next LINE;
        }

        # Unpack any inflexions...
        my @inflexions = _inflect_term($term);

        my $original = shift @inflexions;
        if ($defn =~ /\S/) {
            push @{$term_sets[-1]{terms}}, $original;
            push @{$term_sets[-1]{defns}}, $defn;
        }

        # Store patterns to be matched...
        my $order = 0;
        for my $next_inflexion ($original, @inflexions) {
            push @{ $term_sets[-1]{inflexions}[$order++] }, {silent => $is_silent, term => $next_inflexion};
        }
    }

lib/Lingua/EN/Grammarian.pm  view on Meta::CPAN

            " (be,being,been,was,were) $pres   -->     (be,being,been,was,were) $pastp      ",
            "    (has,had,have,having) $pres   -->        (has,had,have,having) $pastp      ",

            "====[ Incorrect use of participle instead of infinitive ]=================",
            "               to ($pastp,$presp) -->     to $pres                             ",
        ($third ne $pres ?
            "                        to $third -->     to $pres                             "
        :()),
        ($past ne $pastp ?
            "                         to $past -->     to $pres                             "
        :()),

            "====[ Incorrect use of present participle instead of past participle ]=========",
            "                    being $presp  -->   being $pastp                            ",

            "====[ Incorrect use of \"try and\" instead of \"try to\" ]=====================",
            "try and ($pres,$past,$pastp,$presp)  -->   try to $pres                        ",

            "====[ Incorrect inflexion of verb after \"try to\" ]===========================",
            "       try to ($past,$pastp,$presp)  -->      try to $pres                     ",
            "     tried to ($past,$pastp,$presp)  -->    tried to $pres                     ",
            "    trying to ($past,$pastp,$presp)  -->   trying to $pres                     ",
    );
}

sub _gen_absolute_adjective_errors {
    my ($adj, $modifier) = @_;
    $modifier //= '';

    my @QUALIFIERS = qw<
        somewhat   highly   extremely   totally   completely   absolutely   utterly
    >;
    my $QUALIFIERS = '(' . join(',', @QUALIFIERS) . ')';

    my @errors = (
        "====[ Incorrect use of modifier with ungradeable adjective ]===================",
        "           more $adj  -->  $adj                                                ",
        "           most $adj  -->  $adj                                                ",
        "          quite $adj  -->  $adj                                                ",
        "         rather $adj  -->  $adj                                                ",
        "           very $adj  -->  $adj                                                ",
        "    $QUALIFIERS $adj  -->  $adj                                                ",
    );

    if ($modifier) {
        $modifier =~ s{ \A [(] | [)] \z}{}xgms;
        for my $mod (split(',', $modifier)) {
            $errors[1] .=  " -->   more $mod $adj";
            $errors[2] .=  " -->   most $mod $adj";
            $errors[3] .=  " -->  quite $mod $adj";
            $errors[4] .=  " --> rather $mod $adj";
            $errors[5] .=  " -->   very $mod $adj";
        }
    }

    return @errors;
}

sub _load_errors {
    # Gather config from search path
    local @ARGV = grep { -e }
                  map { ("$_.$ERRORS_FILE", "$_$ERRORS_FILE") }
                  @CONFIG_PATH;

    # If no config, we're done...
    return if !@ARGV;

    # Extract corrections...
    my @regex_components;
    my $explanation = '????';
    my $last_was_explanation = 1;
    my @insertions;
    LINE:
    while (my $next_line = shift(@insertions) // readline) {

        # Ignore comment and empty lines...
        next LINE if $next_line =~ m{\A \h* (?: [#] | \Z )}xms;

        # Handle explanation lines...
        if ($next_line =~ m{\A \h* ===\S* \h* (.*?) \h* \S*===.* \Z }xms) {
            $explanation = $last_was_explanation ? "$explanation\n$1" : $1;
            $last_was_explanation = 1;
            next LINE;
        }
        $last_was_explanation = 0;

        # Generate errors from a <verb> specification...
        if ($next_line =~ m{\A\h* <verb> \h* (?<pres>\S+) \h* (?<third>\S+) \h* (?<past>\S+) \h* (?<part>\S+)}xms) {
            push @insertions, _gen_verb_errors(@+{qw<pres third past part>}, _gen_pres_participle_for($+{pres}));
            next LINE;
        }

        # Generate errors from an <absolute> specification...
        if ($next_line =~ m{\A\h* <absolute (?: \h*:\h* (?<modifier> \S+) \h*)?> \h* (?<adjective>\S+) }xms) {
            push @insertions, _gen_absolute_adjective_errors( @+{qw< adjective modifier >} );
            next LINE;
        }

        # Extract error --> correction pair...
        $next_line =~ m{
            \A \h*
            (?<error> .*? )
            \h* --> \h*
            (?<correction> .*? )
            \h* \Z
        }xms;
        my ($error, $correction) = @+{'error', 'correction'};

        # Ignore invalid lines...
        next LINE if !defined $error;

        # Expand inflected forms...
        my @error_inflexions = _inflect_term($error);
        my @corrections_inflections
            = map {[_inflect_term($_)]}
              split /\h+-->\h+/,
              $correction;

        # Iterated inflections in parallel...
        for my $next (0..$#error_inflexions) {
            my $error = $error_inflexions[$next];