File Coverage

blib/lib/NNexus/Morphology.pm

Criterion	Covered	Total	%
statement	47	100	47.0
branch	34	90	37.7
condition	1	2	50.0
subroutine	15	19	78.9
pod	13	13	100.0
total	110	224	49.1

# /=====================================================================\ #
# |  NNexus Autolinker                                                  | #
# | Text Morphology Module                                              | #
# |=====================================================================| #
# | Part of the Planetary project: http://trac.mathweb.org/planetary    | #
# |  Research software, produced as part of work done by:               | #
# |  the KWARC group at Jacobs University                               | #
# | Copyright (c) 2012                                                  | #
# | Released under the MIT License (MIT)                                | #
# |---------------------------------------------------------------------| #
# | Adapted from the original NNexus code by                            | #
# |                                  James Gardner and Aaron Krowne     | #
# |---------------------------------------------------------------------| #
# | Deyan Ginev                   #_#     | #
# | http://kwarc.info/people/dginev                            (o o)    | #
# \=========================================================ooo==U==ooo=/ #
package NNexus::Morphology;
###########################################################################
#	text morphology
###########################################################################
use strict;
use warnings;

use Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(is_possessive is_plural get_nonpossessive get_possessive
  depluralize_word depluralize_phrase root pluralize undetermine_word
  admissible_name firstword_split normalize_word
  canonicalize_url);
our %EXPORT_TAGS = (all=>qw(is_possessive is_plural get_nonpossessive get_possessive
  depluralize_word depluralize_phrase root pluralize undetermine_word
  admissible_name firstword_split normalize_word
  canonicalize_url));

use utf8;
use Encode qw{is_utf8};
use Text::Unidecode qw/unidecode/;

# TODO: Think about MathML

# 0. Define what we consider admissible and grammatical words and phrases, for the NNexus use case
our $concept_word_rex = qr/\w(?:\w|[\-\+\'])*/;
our $concept_phrase_rex = qr/$concept_word_rex(?:\s+$concept_word_rex)*/;


# I. Possessives
# return true if any word is possessive (ends in 's or s')
sub is_possessive { $_[0]  =~ /\w('s|s')(\s|$)/; }

# return phrase without possessive suffix ("Euler's" becomes "Euler")
sub get_nonpossessive {
  my ($word) = @_;
  $word =~ s/'s(\s|$)/$1/ || $word =~ s/s'(\s|$)/s$1/;
  $word; }

# return first word with possessive suffix ("Euler" becomes "Euler's")
sub get_possessive {
  my ($word) = @_;
  $word =~ s/^($concept_word_rex)/$1'/;
  $word =~ s/^($concept_word_rex[^s])'/$1's/;
  $word; }

# II. Plurality

# predicate for plural or not
sub is_plural { $_[0] ne depluralize_phrase($_[0]); }

sub pluralize {
    # "root of unity" pluralizes as "roots of unity" for example
    if ($_[0] =~ /($concept_word_rex)(\s+(of|by)\s+.+)/)	{ return pluralize($1).$2; }
    # normal pluralization
    elsif($_[0] =~ /(.+ri)x$/) {	return "$1ces"; }
    elsif($_[0] =~ /(.+t)ex$/) { return "$1ices"; }
    elsif($_[0] =~ /(.+[aeiuo])x$/) { return "$1xes";	}
    elsif($_[0] =~ /(.+[^aeiou])y$/) { return "$1ies"; }
    elsif($_[0] =~ /(.+)ee$/) { return "$1ees"; }
    elsif($_[0] =~ /(.+)us$/) { return "$1i"; }
    elsif($_[0] =~ /(.+)ch$/) { return "$1ches"; }
    elsif($_[0] =~ /(.+)ss$/) { return "$1sses"; }
    else { return $_[0].'s'; } }

# singularize a phrase... remove root and replace
sub depluralize_phrase {
    # "spaces of functions" depluralizes as "space of functions" for example.
    # also "proofs by induction"
    if ($_[0] =~ /(^\w[\w\s]+\w)(\s+(of|by)\s+.+)$/) {
      my ($l,$r) = ($1,$2);
      return depluralize_phrase($l).$r; }
    elsif($_[0] =~ /(.+ri)ces$/) { return "$1x"; }
    elsif($_[0] =~ /(.+t)ices$/) { return "$1ex";	}
    elsif($_[0] =~ /(.+[aeiuo]x)es$/) { return $1; }
    elsif($_[0] =~ /(.+)ies$/) { return "$1y"; }
    elsif($_[0] =~ /(.+)ees$/) { return "$1ee"; }
    elsif($_[0] =~ /(.+)ches$/) {	return "$1ch"; }
    elsif($_[0] =~ /(.+o)ci$/) { return "$1cus"; }
    elsif($_[0] =~ /(.+)sses$/) {	return "$1ss"; }
    elsif($_[0] =~ /(.+ie)s$/) { return $1;	}
    elsif($_[0] =~ /(.+[^eiuos])s$/) { return $1; }
    elsif($_[0] =~ /(.+[^aeio])es$/) { return "$1e"; }
    else { return $_[0]; } }

sub depluralize_word {
    if($_[0] !~  /oci|s$/) { return $_[0]; }
    elsif($_[0] =~ /(.+ri)ces$/) { return "$1x"; }
    elsif($_[0] =~ /(.+t)ices$/) { return "$1ex";	}
    elsif($_[0] =~ /(.+[aeiuo]x)es$/) { return $1; }
    elsif($_[0] =~ /(.+)ies$/) { return "$1y"; }
    elsif($_[0] =~ /(.+)ees$/) { return "$1ee"; }
    elsif($_[0] =~ /(.+)ches$/) {	return "$1ch"; }
    elsif($_[0] =~ /(.+)sses$/) {	return "$1ss"; }
    elsif($_[0] =~ /(.+ie)s$/) { return $1;	}
    elsif($_[0] =~ /(.+[^eiuos])s$/) { return $1; }
    elsif($_[0] =~ /(.+[^aeio])es$/) { return "$1e"; }
    elsif($_[0] =~ /(.+o)ci$/) { return "$1cus"; }
    else { return $_[0]; } }

# III. Stemming

# get the non-plural root for a word
sub root {
    if($_[0] =~ /(.+ri)ces$/) { return $1; }
    elsif($_[0] =~ /(.+[aeiuo]x)es$/) { return $1; }
    elsif($_[0] =~ /(.+)ies$/) { return $1;	}
    elsif($_[0] =~ /(.+)ches$/) {	return "$1ch"; }
    elsif($_[0] =~ /(.+o)ci$/) { return "$1c"; }
    elsif($_[0] =~ /(.+)sses$/) {	return "$1ss"; }
    elsif($_[0] =~ /(.+[^eiuos])s$/) { return $1;	}
    elsif($_[0] =~ /(.+[^aeio])es$/) { return "$1e"; }
    else { return $_[0]; } }

# Remove determiners from a word:
sub undetermine_word {
  my ($concept) = @_;
  $concept =~ s/^(?:an?|the)(?:\s+|$)//;
  return $concept;
}

# IV. Admissible concept words and high-level api
sub admissible_name {$_[0]=~/^$concept_phrase_rex$/; }
our %normalized_words = ();
sub normalize_word {
  my ($concept)=@_;
  my $normalized_concept = $normalized_words{$concept};
  return $normalized_concept if $normalized_concept;
  $normalized_concept=
    depluralize_word(
      get_nonpossessive(
        undetermine_word(
          lc(
            unidecode(
              $concept)))));
  $normalized_words{$concept} = $normalized_concept;
  return $normalized_concept; }

sub firstword_split {
  my ($concept)=@_;
  if ($concept=~/^($concept_word_rex)\s?(.*)$/) { # Grab first word if not provided
    return ($1,($2||''));
  }
  return; }

# Not the ideal place for it but... closest that comes to mind!
# Internal utilities:
# Canonicalize absolute URLs, borrowed from LaTeXML::Util::Pathname
our $PROTOCOL_RE = '(?:https?)(?=:)';
sub canonicalize_url {
  my ($pathname) = @_;
  my $urlprefix= undef;
  if($pathname =~ s|^($PROTOCOL_RE)://||){
    $urlprefix = $1; }
  $pathname =~ s|/\./|/|g;
  # Collapse any foo/.. patterns, but not ../..
  while($pathname =~ s|/(?!\.\./)[^/]+/\.\.(/\|$)|$1|){}
  $pathname =~ s|^\./||;
  $pathname =~ s|^www.||;
  # Deprecated: We don't want the prefix, keeps the index smaller
  #(defined $urlprefix ? $urlprefix . $pathname : $pathname); }
  $pathname; }

1;
__END__