morphology/lib/Text/Tradition/Morphology.pm

   1 package Text::Tradition::Morphology;
   2
   3 use strict;
   4 use warnings;
   5 use JSON qw/ from_json /;
   6 use Moose::Role;
   7 use Module::Load;
   8 use Text::Tradition::Collation::Reading::Lexeme;
   9
  10 use vars qw/ $VERSION /;
  11 $VERSION = "0.1";
  12
  13 =head1 NAME
  14
  15 Text::Tradition::Morphology - add-on to associate lemma and part-of-speech
  16 information to Text::Tradition::Collation::Reading objects
  17
  18 =cut
  19
  20 requires 'is_identical', 'is_combinable', '_combine';
  21
  22 has 'grammar_invalid' => (
  23         is => 'rw',
  24         isa => 'Bool',
  25         default => undef,
  26         );
  27
  28 has 'is_nonsense' => (
  29         is => 'rw',
  30         isa => 'Bool',
  31         default => undef,
  32         );
  33
  34 has 'normal_form' => (
  35         is => 'rw',
  36         isa => 'Str',
  37         predicate => '_has_normal_form',
  38         clearer => '_clear_normal_form',
  39         );
  40
  41 # Holds the lexemes for the reading.
  42 has 'reading_lexemes' => (
  43         traits => ['Array'],
  44         isa => 'ArrayRef[Text::Tradition::Collation::Reading::Lexeme]',
  45         handles => {
  46                 lexeme => 'get',
  47                 lexemes => 'elements',
  48                 has_lexemes => 'count',
  49                 clear_lexemes => 'clear',
  50                 add_lexeme => 'push',
  51                 },
  52         default => sub { [] },
  53         );
  54
  55
  56
  57 # Make normal_form default to text, transparently.
  58 around 'normal_form' => sub {
  59         my $orig = shift;
  60         my $self = shift;
  61         my( $arg ) = @_;
  62         if( $arg && $arg eq $self->text ) {
  63                 $self->_clear_normal_form;
  64                 return $arg;
  65         } elsif( !$arg && !$self->_has_normal_form ) {
  66                 return $self->text;
  67         } else {
  68                 $self->$orig( @_ );
  69         }
  70 };
  71
  72 =head1 METHODS
  73
  74 Methods for the morphological information (if any) attached to readings.
  75 A reading may be made up of multiple lexemes; the concatenated lexeme
  76 strings ought to match the reading's normalized form.
  77
  78 See L<Text::Tradition::Collation::Reading::Lexeme> for more information
  79 on Lexeme objects and their attributes.
  80
  81 =head2 has_lexemes
  82
  83 Returns a true value if the reading has any attached lexemes.
  84
  85 =head2 lexemes
  86
  87 Returns the Lexeme objects (if any) attached to the reading.
  88
  89 =head2 clear_lexemes
  90
  91 Wipes any associated Lexeme objects out of the reading.
  92
  93 =head2 add_lexeme( $lexobj )
  94
  95 Adds the Lexeme in $lexobj to the list of lexemes.
  96
  97 =head2 lemmatize
  98
  99 If the language of the reading is set, this method will use the appropriate
 100 Language model to determine the lexemes that belong to this reading.  See
 101 L<Text::Tradition::lemmatize> if you wish to lemmatize an entire tradition.
 102
 103 =cut
 104
 105 sub lemmatize {
 106         my $self = shift;
 107         unless( $self->has_language ) {
 108                 warn "Please set a language to lemmatize a tradition";
 109                 return;
 110         }
 111         my $mod = "Text::Tradition::Language::" . $self->language;
 112         load( $mod );
 113         $mod->can( 'reading_lookup' )->( $self );
 114
 115 }
 116
 117 # For graph serialization. Return a JSON representation of the associated
 118 # reading lexemes.
 119 sub _serialize_lexemes {
 120         my $self = shift;
 121         my $json = JSON->new->allow_blessed(1)->convert_blessed(1);
 122         return $json->encode( [ $self->lexemes ] );
 123 }
 124
 125 # Given a JSON representation of the lexemes, instantiate them and add
 126 # them to the reading.
 127 sub _deserialize_lexemes {
 128         my( $self, $json ) = @_;
 129         my $data = from_json( $json );
 130         return unless @$data;
 131
 132         my @lexemes;
 133         foreach my $lexhash ( @$data ) {
 134                 push( @lexemes, Text::Tradition::Collation::Reading::Lexeme->new(
 135                         'JSON' => $lexhash ) );
 136         }
 137         $self->clear_lexemes;
 138         $self->add_lexeme( @lexemes );
 139 }
 140
 141 sub disambiguated {
 142         my $self = shift;
 143         return 0 unless $self->has_lexemes;
 144         return !grep { !$_->is_disambiguated } $self->lexemes;
 145 }
 146
 147 sub filter_lexemes {
 148         my $self = shift;
 149         # While we are here, get rid of any extra wordforms from a disambiguated
 150         # reading.
 151         if( $self->disambiguated ) {
 152                 foreach my $lex ( $self->lexemes ) {
 153                         $lex->clear_matching_forms();
 154                         $lex->add_matching_form( $lex->form );
 155                 }
 156         }
 157 }
 158
 159 around 'is_identical' => sub {
 160         my $orig = shift;
 161         my $self = shift;
 162         my $other = shift;
 163         # If the base class returns true, do an extra check to make sure the
 164         # lexemes also match.
 165         my $answer = $self->$orig( $other );
 166         if( $answer ) {
 167                 if( $self->disambiguated && $other->disambiguated ) {
 168                         my $rform = join( '//', map { $_->form->to_string } $self->lexemes );
 169                         my $uform = join( '//', map { $_->form->to_string } $other->lexemes );
 170                         $answer = undef unless $rform eq $uform;
 171                 } elsif( $self->disambiguated xor $other->disambiguated ) {
 172                         $answer = undef;
 173                 }
 174         }
 175         return $answer;
 176 };
 177
 178 around 'is_combinable' => sub {
 179         my $orig = shift;
 180         my $self = shift;
 181         # If the reading is marked with invalid grammar or as a nonsense reading,
 182         # it is no longer combinable.
 183         return undef if $self->grammar_invalid || $self->is_nonsense;
 184         return $self->$orig();
 185 };
 186
 187 after '_combine' => sub {
 188         my $self = shift;
 189         my $other = shift;
 190         my $joinstr = shift;
 191         $self->normal_form(
 192                 join( $joinstr, $self->normal_form, $other->normal_form ) );
 193         # Combine the lexemes present in the readings
 194         if( $self->has_lexemes && $other->has_lexemes ) {
 195                 $self->add_lexeme( $other->lexemes );
 196         }
 197 };
 198
 199 1;
 200
 201 =head1 LICENSE
 202
 203 This package is free software and is provided "as is" without express
 204 or implied warranty.  You can redistribute it and/or modify it under
 205 the same terms as Perl itself.
 206
 207 =head1 AUTHOR
 208
 209 Tara L Andrews E<lt>aurum@cpan.orgE<gt>