generalize Latin module to Latin/Greek/Armenian on Perseus

[scpubgit/stemmatology.git] / lib / Text / Tradition / Language / Perseus.pm

diff --git a/lib/Text/Tradition/Language/Perseus.pm b/lib/Text/Tradition/Language/Perseus.pm
new file mode 100644 (file)
index 0000000..9bf71d8
--- /dev/null
+++ b/lib/Text/Tradition/Language/Perseus.pm
@@ -0,0 +1,129 @@
+package Text::Tradition::Language::Perseus;
+
+use strict;
+use warnings;
+use Module::Load;
+use Text::Tradition::Language::Base qw/ lemmatize_treetagger lfs_morph_tags /;
+use TryCatch;
+
+=head1 NAME
+
+Text::Tradition::Language::Perseus - base module for those languages that rely
+on a Lingua::Morph::Perseus database.
+
+=head1 DESCRIPTION
+
+Implements morphology lookup for words in context.  This module depends on the Lingua::Morph::Perseus module for access to PhiloLogic database data.
+
+=head1 SUBROUTINES
+
+=head2 lemmatize( $text )
+
+Evaluates the string using Treetagger and Perseus, and returns the results.
+
+=cut
+
+# tested in child language modules
+
+sub perseus_lemmatize {
+       my $self = shift;
+       my $tradition = shift;
+       my %opts = ( 
+               'language' => $tradition->language, 
+               'callback' => sub { _perseus_lookup_tt( $self, @_ ) } 
+               );
+       return lemmatize_treetagger( $tradition, %opts );
+}
+
+=head2 reading_lookup( $rdg[, $rdg, ...] )
+
+Looks up one or more readings using the Perseus package, and returns the
+possible results.  This skips the tree tagger / tokenizer, returning any
+match for the word string(s) in the morphology DB.
+
+=cut
+
+sub perseus_reading_lookup {
+       my( $self, @words ) = @_;
+       return map { $self->_perseus_lookup_str( $_ ) } @words;
+}
+
+=head2 morphology_tags
+
+Return a data structure describing the available parts of speech and their attributes.
+
+=cut
+
+sub morphology_tags {
+       return lfs_morph_tags();
+}
+
+sub _get_lang {
+       my $self = shift;
+       my @parts = split( /::/, $self );
+       return $parts[-1];
+}
+
+sub _morph_connect {
+       my $self = shift;
+       unless( $self::dbhandle ) {
+               my $lang = $self->_get_lang();
+               try {
+                       load 'Lingua::Morph::Perseus';
+                       $self::dbhandle = Lingua::Morph::Perseus->connect( $lang );
+               } catch {
+                       warn "Cannot do $lang word lemmatization without Lingua::Morph::Perseus: @_";
+                       return;
+               }
+       }
+}
+                       
+sub _perseus_lookup_tt {
+       my $self = shift;
+       my( $orig, $pos, $lemma ) = split( /\t/, $_[0] );
+       $self->_morph_connect();
+       return unless $self::dbhandle;
+       # Discard results that don't match the lemma, unless lemma is unknown
+       my $lookupopts = {};
+       unless( $lemma eq '<unknown>' || $lemma =~ /^\W+$/ ) {
+               my %lems;
+               map { $lems{$_} = 1; $lems{lc($_)} = 1 } split( /\|/, $lemma );
+               $lookupopts->{'lemma'} = [ keys %lems ];
+       }
+       $lookupopts->{'ttpos'} = $pos if $pos;
+       
+       my $result = $self::dbhandle->lexicon_lookup( $orig, $lookupopts );
+       # unless( !keys( %$lookupopts ) ||  $result->{'filtered'} ) {
+       #       warn "Filter on $pos / $lemma returned no results; using all results";
+       # }
+       my @ret = @{$result->{'objects'}};
+       my %unique_wordforms;
+       foreach my $obj ( @ret ) {
+               my $wf = $self->_wordform_from_row( $obj );
+               $unique_wordforms{$wf->to_string} = $wf;
+       }
+       return values( %unique_wordforms );
+}
+
+sub _perseus_lookup_str {
+       my( $self, $orig ) = @_;
+       $self->_morph_connect();
+       return unless $self::dbhandle;
+       # Simple morph DB lookup, and return the results.
+       my $result = $self::dbhandle->lexicon_lookup( $orig );
+       return map { $self->_wordform_from_row( $_ ) } @{$result->{'objects'}};
+}
+       
+sub _wordform_from_row {
+       my( $self, $rowobj ) = @_;
+       my $lemma = $rowobj->lemma;
+       $lemma =~ s/^(\D+)\d*$/$1/;
+       my $wf = Text::Tradition::Collation::Reading::WordForm->new(
+               'language' => $self->_get_lang(),
+               'lemma' => $lemma,
+               'morphology' => $rowobj->morphology,
+               );
+       return $wf;
+}
+       
+1;