lib/Text/Tradition/Collation/Reading/Lexeme.pm

   1 package Text::Tradition::Collation::Reading::Lexeme;
   2
   3 use Moose;
   4 use JSON ();
   5 use Module::Load;
   6 use Text::Tradition::Collation::Reading::WordForm;
   7 use Text::Tradition::Error;
   8
   9 =head1 NAME
  10
  11 Text::Tradition::Collation::Reading::Lexeme - represents the components of
  12 a Reading.
  13
  14 =head1 DESCRIPTION
  15
  16 Text::Tradition is a library for representation and analysis of collated
  17 texts, particularly medieval ones.  A word form is used for the analysis of
  18 Reading objects; it consists of a lemma, a language, and a code to
  19 represent its part of speech.  In general the word forms for a particular
  20 language should be read from / written to some morphological database.
  21
  22 =head1 METHODS
  23
  24 =head2 new
  25
  26 Creates a new lexeme from the passed options.
  27
  28 =head2 language
  29
  30 Returns the language to which this lexeme belongs.
  31
  32 =head2 normalized
  33
  34 Returns the canonical string version of this lexeme.
  35
  36 =head2 matches
  37
  38 Returns the number of possible word forms for this lexeme, as drawn from
  39 the appropriate database.
  40
  41 =head2 matching_forms
  42
  43 Returns an array of the possible word forms for this lexeme.
  44
  45 =head2 matching_form( $index )
  46
  47 Returns the form at $index in the list of matching forms.
  48
  49 =head2 is_disambiguated
  50
  51 Returns true if a single wordform has been picked as 'correct' for this
  52 lexeme in its context.
  53
  54 =head2 form
  55
  56 Returns the correct word form (if any has been selected) for the lexeme in
  57 its context.
  58
  59 =cut
  60
  61 # TODO need to be able to populate this from DB
  62 has 'language' => (
  63         is => 'ro',
  64         isa => 'Str',
  65         required => 1,
  66         );
  67
  68 has 'string' => (
  69         is => 'rw',
  70         isa => 'Str',
  71         required => 1,
  72         );
  73
  74 has 'wordform_matchlist' => (
  75         isa => 'ArrayRef[Text::Tradition::Collation::Reading::WordForm]',
  76         traits => ['Array'],
  77         handles => {
  78                 'matches' => 'count',
  79                 'matching_forms' => 'elements',
  80                 'matching_form' => 'get',
  81                 'add_matching_form' => 'push',
  82                 },
  83         default => sub { [] },
  84         );
  85
  86 has 'is_disambiguated' => (
  87         is => 'rw',
  88         isa => 'Bool',
  89         default => undef,
  90         );
  91
  92 has 'form' => (
  93         is => 'ro',
  94         isa => 'Text::Tradition::Collation::Reading::WordForm',
  95         writer => '_set_form',
  96         );
  97
  98 around BUILDARGS => sub {
  99         my $orig = shift;
 100         my $class = shift;
 101         my $args = @_ == 1 ? $_[0] : { @_ };
 102         if( exists $args->{JSON} ) {
 103                 my $data = $args->{JSON};
 104                 if( exists $data->{'form'} && $data->{'form'} ) {
 105                         my $form = Text::Tradition::Collation::Reading::WordForm->new(
 106                                 'JSON' => $data->{'form'} );
 107                         $data->{'form'} = $form;
 108                 }
 109                 if( exists $data->{'wordform_matchlist'} && $data->{'wordform_matchlist'} ) {
 110                         my @ml;
 111                         foreach my $wfjson ( @{$data->{'wordform_matchlist'}} ) {
 112                                 push( @ml, Text::Tradition::Collation::Reading::WordForm->new(
 113                                         'JSON' => $wfjson ) );
 114                         }
 115                         $data->{'wordform_matchlist'} = \@ml;
 116                 }
 117                 $args = $data;
 118         }
 119         $class->$orig( $args );
 120 };
 121
 122 # Do auto-disambiguation if we were created with a single wordform
 123 sub BUILD {
 124         my $self = shift;
 125
 126         if( $self->matches == 1 ) {
 127                 $self->disambiguate( 0 );
 128         }
 129 }
 130
 131 around 'add_matching_form' => sub {
 132         my $orig = shift;
 133         my $self = shift;
 134         my @realargs;
 135         foreach my $a ( @_ ) {
 136                 if( ref( $a ) ) {
 137                         push( @realargs, $a );
 138                 } else {
 139                         # Make the wordform from the string
 140                         my $wf = Text::Tradition::Collation::Reading::WordForm->new(
 141                                 'JSON' => $a );
 142                         push( @realargs, $wf );
 143                 }
 144         }
 145         return $self->$orig( @realargs );
 146 };
 147
 148 =head2 disambiguate( $index )
 149
 150 Selects the word form at $index in the list of matching forms, and asserts
 151 that this is the correct form for the lexeme.
 152
 153 =cut
 154
 155 sub disambiguate {
 156         my( $self, $idx ) = @_;
 157         my $form = $self->matching_form( $idx );
 158         throw( "There is no candidate wordform at index $idx" )
 159                 unless $form;
 160         $self->_set_form( $form );
 161         $self->is_disambiguated( 1 );
 162 }
 163
 164 =head2 has_form( $rep )
 165
 166 Returns the index of the matching form whose string representation is in $rep,
 167 or else undef if none is found.
 168
 169 =cut
 170
 171 sub has_form {
 172         my( $self, $rep ) = @_;
 173         my $i = 0;
 174         foreach my $mf ( $self->matching_forms ) {
 175                 my $struct = $mf->TO_JSON;
 176                 return $i if $struct eq $rep;
 177                 $i++;
 178         }
 179         return undef;
 180 }
 181
 182
 183 sub TO_JSON {
 184         my $self = shift;
 185         my $hash = {};
 186         # Do the scalar keys
 187         map { $hash->{$_} = $self->$_ if defined $self->$_ }
 188                 qw/ language string is_disambiguated form /;
 189         $hash->{'wordform_matchlist'} = [ $self->matching_forms ] if $self->matches;
 190         return $hash;
 191 }
 192
 193 sub throw {
 194         Text::Tradition::Error->throw(
 195                 'ident' => 'Lexeme error',
 196                 'message' => $_[0],
 197                 );
 198 }
 199
 200 no Moose;
 201 __PACKAGE__->meta->make_immutable;
 202
 203 1;
 204
 205 =head1 LICENSE
 206
 207 This package is free software and is provided "as is" without express
 208 or implied warranty.  You can redistribute it and/or modify it under
 209 the same terms as Perl itself.
 210
 211 =head1 AUTHOR
 212
 213 Tara L Andrews E<lt>aurum@cpan.orgE<gt>