lib/Text/Tradition/Language/Base.pm

   1 package Text::Tradition::Language::Base;
   2
   3 use strict;
   4 use warnings;
   5 use Encode qw/ encode_utf8 decode_utf8 /;
   6 use Exporter 'import';
   7 use vars qw/ @EXPORT_OK /;
   8 use IPC::Run qw/ run /;
   9 use Module::Load;
  10 use Text::Tradition::Collation::Reading::Lexeme;
  11 use Text::Tradition::Collation::Reading::WordForm;
  12 use TryCatch;
  13
  14 @EXPORT_OK = qw/ lemmatize_treetagger reading_lookup_treetagger lfs_morph_tags /;
  15
  16 =head1 NAME
  17
  18 Text::Tradition::Language::Base - Base subroutines for lemmatization of words
  19
  20 =head1 DESCRIPTION
  21
  22 Common routines for applying morphological tagging to a Text::Tradition. Used
  23 with callbacks from the named language packages.
  24
  25 =head1 SUBROUTINES
  26
  27 =head2 lemmatize_treetagger( $tradition )
  28
  29 Evaluates the tradition with the given options, and returns the results.
  30
  31 =cut
  32
  33 sub lemmatize_treetagger {
  34         my( $tradition, %opts ) = @_;
  35
  36         # Given a tradition, lemmatize it witness by witness and see what we get.
  37         my $c = $tradition->collation;
  38         # First, clear out all existing lexemes from the readings.
  39         my %witness_paths = _clear_reading_lexemes( $tradition );
  40
  41         foreach my $sig ( keys %witness_paths ) {
  42                 # Get the text as a sequence of readings and as a string
  43                 my %witopts = (
  44                         'path' => $witness_paths{$sig},
  45                         %opts
  46                         );
  47                 _lemmatize_treetagger_sequence( %witopts );
  48         }
  49 }
  50
  51 sub _clear_reading_lexemes {
  52         my $tradition = shift;
  53                 my $c = $tradition->collation;
  54         # Clear out all existing lexemes from the readings. Save the path as long
  55         # as we went to the trouble of generating it.
  56         my %witness_paths;
  57         foreach my $wit ( $tradition->witnesses ) {
  58                 my @sigla = ( $wit->sigil );
  59                 push( @sigla, $wit->sigil . $c->ac_label ) if $wit->is_layered;
  60                 foreach my $sig ( @sigla ) {
  61                         my @path = grep { !$_->is_meta }
  62                                 $c->reading_sequence( $c->start, $c->end, $sig );
  63                         map { $_->clear_lexemes } @path;
  64                         $witness_paths{$sig} = \@path;
  65                 }
  66         }
  67         return %witness_paths;
  68 }
  69
  70 =head2 reading_lookup( $rdg[, $rdg, ...] )
  71
  72 Looks up one or more readings using the Flemm package, and returns the
  73 possible results.  This uses the same logic as L<lemmatize> above for the
  74 entire tradition, but can also be used to (re-)analyze individual readings.
  75
  76 =cut
  77
  78 sub reading_lookup_treetagger {
  79         my %opts = @_;
  80         $opts{'replace'} = 1;
  81         return _lemmatize_treetagger_sequence( %opts );
  82 }
  83
  84 sub _lemmatize_treetagger_sequence {
  85         my %opts = @_;
  86         my @path = @{$opts{'path'}};
  87         my $tagresult = _treetag_string( _text_from_path( 1, @path ), $opts{'language'} );
  88         if( $tagresult ) {
  89                 # Map the tagged words onto the original readings, splitting
  90                 # them up into lexemes where necessary.
  91                 # NOTE we can have multiple lexemes in a reading, but not
  92                 # multiple readings to a lexeme.
  93                 my @tags = split( /\n/, $tagresult );
  94                 my @lexemes;
  95                 my $curr_rdg = shift @path;
  96                 my @curr_lexemes;
  97                 my $unused_rdg_part;
  98                 foreach my $tag ( @tags ) {
  99                         # Get the original word
 100                         my( $lexeme, @rest ) = split( /\t/, $tag );
 101                         # Lemmatize the whole
 102                         # TODO error trap this
 103                         my @forms = $opts{'callback'}( $tag );
 104
 105                         my $lexobj = Text::Tradition::Collation::Reading::Lexeme->new(
 106                                 'string' => $lexeme, 'language' => $opts{'language'},
 107                                 'wordform_matchlist' => \@forms );
 108                         # Find the next non-meta reading
 109                         while( $curr_rdg && $curr_rdg->is_meta ) {
 110                                 $curr_rdg = shift @path;
 111                         }
 112                         unless( $curr_rdg ) {
 113                                 warn "Ran out of readings in sequence at $lexeme";
 114                                 last;
 115                         }
 116                         my $curr_rdg_text = $curr_rdg->has_normal_form
 117                                 ? $curr_rdg->normal_form : $curr_rdg->text;
 118                         if( $unused_rdg_part &&
 119                                 $unused_rdg_part =~ /^\Q$lexeme\E(\s*)(.*)$/ ) {
 120                                 # Nth part of curr_rdg
 121                                 $unused_rdg_part = $2;
 122                                 push( @curr_lexemes, $lexobj );
 123                         } elsif( $curr_rdg_text =~ /^\Q$lexeme\E(\s*)(.*)$/ ) {
 124                                 # Flag an error if there is already an unused reading part.
 125                                 warn "Skipped over unused text $unused_rdg_part at $curr_rdg"
 126                                         if $unused_rdg_part;
 127                                 $unused_rdg_part = $2; # will be empty if the whole reading matched
 128                                 push( @curr_lexemes, $lexobj );
 129                         } else {
 130                                 # We do not cope with the idea of a lexeme being
 131                                 # spread across multiple readings.
 132                                 warn "Word sequence changed unexpectedly in text";
 133                                 # See if we can find a matching reading
 134                                 my @lookahead;
 135                                 my $matched;
 136                                 while( my $nr = shift @path ) {
 137                                         my $nrtext = $nr->has_normal_form ? $nr->normal_form : $nr->text;
 138                                         if( $nrtext =~ /^\Q$lexeme\E/ ) {
 139                                                 $curr_rdg = $lookahead[-1] if @lookahead;
 140                                                 $matched = 1;
 141                                                 last;
 142                                         } else {
 143                                                 push( @lookahead, $nr );
 144                                         }
 145                                 }
 146                                 # No match? Restore the state we had
 147                                 unless( $matched ) {
 148                                         unshift( @path, @lookahead );
 149                                 }
 150                                 # Trigger a move
 151                                 $unused_rdg_part = '';
 152                         }
 153
 154                         unless( $unused_rdg_part ) {
 155                                 # Record the lexemes for the given reading.
 156                                 #print STDERR sprintf( "Adding lexeme(s) %s to reading %s (%s)\n",
 157                                 #       join( ' ', map { $_->string } @curr_lexemes ),
 158                                 #       $curr_rdg->id, $curr_rdg->text );
 159                                 _update_reading_lexemes( $opts{replace}, $curr_rdg, @curr_lexemes );
 160                                 $curr_rdg = shift @path;
 161                                 @curr_lexemes = ();
 162                         }
 163                 }
 164         }
 165 }
 166
 167 sub _update_reading_lexemes {
 168         my( $replace, $reading, @lexemes ) = @_;
 169         if( $reading->has_lexemes && !$replace ) {
 170                 # We need to merge what is in @lexemes with what we have already.
 171                 my @oldlex = $reading->lexemes;
 172                 my $cmp1 = join( '||', map { $_->string } @oldlex );
 173                 my $cmp2 = join( '||', map { $_->string } @lexemes );
 174                 if ( @oldlex == @lexemes && $cmp1 eq $cmp2 ) {
 175                         # The lexeme strings are the same, so merge the possible
 176                         # word forms from new to old.
 177                         foreach my $i ( 0 .. $#lexemes ) {
 178                                 my $ol = $oldlex[$i];
 179                                 my $nl = $lexemes[$i];
 180                                 my %ofw;
 181                                 map { $ofw{$_->to_string} = 1 } $ol->matching_forms;
 182                                 foreach my $form ( $nl->matching_forms ) {
 183                                         unless( $ofw{$form->to_string} ) {
 184                                                 # print STDERR "Adding form " . $form->to_string .
 185                                                 #       " to lexeme " . $nl->string . " at $reading\n";
 186                                                 $ol->add_matching_form( $form );
 187                                                 $ol->is_disambiguated(0);
 188                                         }
 189                                 }
 190                         }
 191                 } else {
 192                         warn "Lexeme layout for $reading changed; replacing the lot";
 193                         $reading->clear_lexemes;
 194                         $reading->add_lexeme( @lexemes );
 195                 }
 196         } else {
 197                 $reading->clear_lexemes if $replace;
 198                 $reading->add_lexeme( @lexemes );
 199         }
 200 }
 201
 202 # Utility function so that we can cheat and use it when we need both the path
 203 # and its text.
 204 sub _text_from_path {
 205         my( $normalize, @path ) = @_;
 206         my $pathtext = '';
 207         my $last;
 208         foreach my $r ( @path ) {
 209                 unless ( $r->join_prior || !$last || $last->join_next ) {
 210                         $pathtext .= ' ';
 211                 }
 212                 $pathtext .= ( $normalize && $r->has_normal_form )
 213                         ? $r->normal_form : $r->text;
 214                 $last = $r;
 215         }
 216         return $pathtext;
 217 }
 218
 219 # Utility function that actually calls the tree tagger.
 220 sub _treetag_string {
 221         my( $text, $lang ) = @_;
 222         my $wittext = encode_utf8( $text );
 223         # Then see if we have TreeTagger
 224         try {
 225                 load( 'Lingua::TreeTagger' );
 226         } catch {
 227                 warn "Cannot run TreeTagger without Lingua::TreeTagger module";
 228                 return '';
 229         }
 230         # OK, we can run it then.
 231         # First upgrade to UTF8 for necessary languages.
 232         my @utf8_supported = qw/ French /;
 233         my %ttopts = ( 'language' => $lang, 'options' => [ qw/ -token -lemma / ] );
 234         if( grep { $_ eq $lang } @utf8_supported ) {
 235                 $ttopts{'use_utf8'} = 1;
 236         }
 237         # Now instantiate and run the tagger.
 238         my $tagger = Lingua::TreeTagger->new( %ttopts );
 239         my $tagresult = $tagger->tag_text( \$text );
 240
 241         # TODO maybe send the tokens back rather than the interpreted string...
 242         return $tagresult->as_text();
 243 }
 244
 245 =head2 lfs_morph_tags
 246
 247 Return a data structure describing the available parts of speech and their attributes
 248 from the Lingua::Features::Structure class currently defined.
 249
 250 =cut
 251
 252 sub lfs_morph_tags {
 253         load('Lingua::Features::StructureType');
 254         my $tagset = { 'structures' => [], 'features' => {} };
 255         foreach my $lfs ( sort { _by_structid( $a->id, $b->id ) } Lingua::Features::StructureType->types() ) {
 256                 my $tsstruct = { 'id' => $lfs->id, 'desc' => $lfs->desc, 'use_features' => [] };
 257                 foreach my $ftid ( Lingua::Features::StructureType->type($lfs->id)->features ) {
 258                         my $ftype = $lfs->feature_type( $ftid );
 259                         if( !$ftype && $lfs->base ) {
 260                                 $ftype = $lfs->base->feature_type( $ftid );
 261                         }
 262                         if( $ftype ) {
 263                                 push( @{$tsstruct->{'use_features'}}, $ftid );
 264                                 if( $ftid eq 'type' ) {
 265                                         # Type values change according to category
 266                                         $ftid .= " (" . $lfs->id . ")";
 267                                 }
 268                                 my $tfstruct = { 'id' => $ftid, 'values' => [] };
 269                                 foreach my $fval( $ftype->values ) {
 270                                         push( @{$tfstruct->{'values'}},
 271                                                 { 'short' => $fval, 'long' => $ftype->value_name( $fval ) } );
 272                                 }
 273                                 $tagset->{'features'}->{$ftid} = $tfstruct;
 274                         }
 275                 }
 276                 push( @{$tagset->{'structures'}}, $tsstruct );
 277         }
 278         return $tagset;
 279 }
 280
 281 sub _by_structid {
 282         my( $a, $b ) = @_;
 283         return -1 if $a eq 'cat';
 284         return 1 if $b eq 'cat';
 285         return $a cmp $b;
 286 }
 287
 288 1;
 289
 290 =head2 TODO
 291
 292 =over
 293
 294 =item * Handle package dependencies more gracefully
 295
 296 =back
 297
 298 =head1 LICENSE
 299
 300 This package is free software and is provided "as is" without express
 301 or implied warranty.  You can redistribute it and/or modify it under
 302 the same terms as Perl itself.
 303
 304 =head1 AUTHOR
 305
 306 Tara L Andrews E<lt>aurum@cpan.orgE<gt>