1 package Text::Tradition::Collation::Reading;
4 use overload '""' => \&_stringify, 'fallback' => 1;
8 Text::Tradition::Collation::Reading - represents a reading (usually a word) in a collation.
12 Text::Tradition is a library for representation and analysis of collated
13 texts, particularly medieval ones. A 'reading' refers to a unit of text,
14 usually a word, that appears in one or more witnesses (manuscripts) of the
15 tradition; the text of a given witness is composed of a set of readings in
22 Creates a new reading in the given collation with the given attributes.
27 =item collation - The Text::Tradition::Collation object to which this reading belongs. Required.
29 =item id - A unique identifier for this reading. Required.
31 =item text - The word or other text of the reading.
33 =item is_start - The reading is the starting point for the collation.
35 =item is_end - The reading is the ending point for the collation.
37 =item is_lacuna - The 'reading' represents a known gap in the text.
39 =item is_ph - A temporary placeholder for apparatus parsing purposes. Do not use unless you know what you are doing.
41 =item rank - The sequence number of the reading. This should probably not be set manually.
45 One of 'text', 'is_start', 'is_end', or 'is_lacuna' is required.
61 Accessor methods for the given attributes.
67 isa => 'Text::Tradition::Collation',
82 writer => 'alter_text',
118 predicate => 'has_rank',
119 clearer => 'clear_rank',
122 ## For morphological analysis
124 has 'normal_form' => (
127 predicate => 'has_normal_form',
133 predicate => 'has_lemma',
136 has 'morphology' => (
138 isa => 'ArrayRef[HashRef[ArrayRef[Text::Tradition::Collation::Reading::Morphology]]]',
140 lexemes => 'elements',
141 has_morphology => 'count',
142 _clear_morph => 'clear',
143 _add_morph => 'push',
147 ## For prefix/suffix readings
149 has 'join_prior' => (
162 around BUILDARGS => sub {
172 # If one of our special booleans is set, we change the text and the
174 if( exists $args->{'is_lacuna'} && !exists $args->{'text'} ) {
175 $args->{'text'} = '#LACUNA#';
176 } elsif( exists $args->{'is_start'} ) {
177 $args->{'id'} = '#START#'; # Change the ID to ensure we have only one
178 $args->{'text'} = '#START#';
180 } elsif( exists $args->{'is_end'} ) {
181 $args->{'id'} = '#END#'; # Change the ID to ensure we have only one
182 $args->{'text'} = '#END#';
183 } elsif( exists $args->{'is_ph'} ) {
184 $args->{'text'} = $args->{'id'};
187 $class->$orig( $args );
192 A meta attribute (ha ha), which should be true if any of our 'special'
193 booleans are true. Implies that the reading does not represent a bit
194 of text found in a witness.
200 return $self->is_start || $self->is_end || $self->is_lacuna || $self->is_ph;
203 =head1 Convenience methods
205 =head2 related_readings
207 Calls Collation's related_readings with $self as the first argument.
211 sub related_readings {
213 return $self->collation->related_readings( $self, @_ );
218 Calls Collation's reading_witnesses with $self as the first argument.
224 return $self->collation->reading_witnesses( $self, @_ );
229 Returns a list of Reading objects that immediately precede $self in the collation.
235 my @pred = $self->collation->sequence->predecessors( $self->id );
236 return map { $self->collation->reading( $_ ) } @pred;
241 Returns a list of Reading objects that immediately follow $self in the collation.
247 my @succ = $self->collation->sequence->successors( $self->id );
248 return map { $self->collation->reading( $_ ) } @succ;
251 =head2 set_identical( $other_reading)
253 Backwards compatibility method, to add a transposition relationship
254 between $self and $other_reading. Don't use this.
259 my( $self, $other ) = @_;
260 return $self->collation->add_relationship( $self, $other,
261 { 'type' => 'transposition' } );
271 A few methods to try to tack on morphological information.
273 =head2 is_disambiguated
275 Returns true if there is only one tag per lexeme in this reading.
280 my( $self, @lexemes ) = @_;
281 # The lexemes need to be the same as $self->text.
282 my $cmpstr = $self->has_normal_form ? lc( $self->normal_form ) : lc( $self->text );
283 $cmpstr =~ s/[\s-]+//g;
284 my $lexstr = lc( join( '', @lexemes ) );
285 $lexstr =~ s/[\s-]+//g;
286 unless( $lexstr eq $cmpstr ) {
287 warn "Cannot split " . $self->text . " into " . join( '.', @lexemes );
291 map { $self->_add_morph( { $_ => [] } ) } @lexemes;
294 sub add_morphological_tag {
295 my( $self, $lexeme, $opts ) = @_;
298 # No lexeme was passed; use reading text.
300 $lexeme = $self->text;
301 $self->use_lexemes( $lexeme );
303 # Get the correct container
304 ( $struct ) = grep { exists $_->{$lexeme} } $self->lexemes;
306 warn "No lexeme $lexeme exists in this reading";
309 # Now make the morph object and add it to this lexeme.
310 my $morph_obj = Text::Tradition::Collation::Reading::Morphology->new( $opts );
311 # TODO Check for existence
312 push( @{$struct->{$lexeme}}, $morph_obj );
316 my( $self, $lexeme, $index ) = @_;
319 # No lexeme was passed; use reading text.
321 $lexeme = $self->text;
323 # Get the correct container
324 ( $struct ) = grep { exists $_->{$lexeme} } $self->lexemes;
326 warn "No lexeme $lexeme exists in this reading";
329 # Keep the object at the selected index
330 my $selected = $struct->{$lexeme}->[$index];
331 $struct->{$lexeme} = [ $selected ];
334 sub is_disambiguated {
336 return undef unless $self->has_morphology;
337 foreach my $lexeme ( $self->lexemes ) {
338 my( $key ) = keys %$lexeme; # will be only one
339 return undef unless @{$lexeme->{$key}} == 1;
351 ## TODO will need a throw() here
354 __PACKAGE__->meta->make_immutable;
356 ###################################################
357 ### Morphology objects, to be attached to readings
358 ###################################################
360 package Text::Tradition::Collation::Reading::Morphology;
382 ## Transmute codes into comparison arrays for our various languages.
384 around BUILDARGS => sub {
388 if( @_ == 1 && ref( $_[0] ) ) {
393 if( exists( $args->{'serial'} ) ) {
394 my( $lemma, $code ) = split( /!!/, delete $args->{'serial'} );
395 $args->{'lemma'} = $lemma;
396 $args->{'code'} = $code;
398 $class->$orig( $args );
403 return join( '!!', $self->lemma, $self->code );
406 sub comparison_array {
408 if( $self->language eq 'French' ) {
410 my @bits = split( /\+/, $self->code );
411 # First push the non k/v parts.
412 while( @bits && $bits[0] !~ /=/ ) {
413 push( @array, shift @bits );
415 while( @array < 2 ) {
416 push( @array, undef );
418 # Now push the k/v parts in a known order.
419 my @fields = qw/ Pers Nb Temps Genre Spec Fonc /;
421 map { my( $k, $v ) = split( /=/, $_ ); $props{$k} = $v; } @bits;
422 foreach my $k ( @fields ) {
423 push( @array, $props{$k} );
427 } elsif( $self->language eq 'English' ) {
428 # Do something as yet undetermined
430 # Latin or Greek or Armenian, just split the chars
431 return split( '', $self->code );
436 __PACKAGE__->meta->make_immutable;