1 package Text::Tradition::Collation::Reading;
4 use overload '""' => \&_stringify, 'fallback' => 1;
8 Text::Tradition::Collation::Reading - represents a reading (usually a word)
13 Text::Tradition is a library for representation and analysis of collated
14 texts, particularly medieval ones. A 'reading' refers to a unit of text,
15 usually a word, that appears in one or more witnesses (manuscripts) of the
16 tradition; the text of a given witness is composed of a set of readings in
23 Creates a new reading in the given collation with the given attributes.
28 =item collation - The Text::Tradition::Collation object to which this
29 reading belongs. Required.
31 =item id - A unique identifier for this reading. Required.
33 =item text - The word or other text of the reading.
35 =item is_start - The reading is the starting point for the collation.
37 =item is_end - The reading is the ending point for the collation.
39 =item is_lacuna - The 'reading' represents a known gap in the text.
41 =item is_ph - A temporary placeholder for apparatus parsing purposes. Do
42 not use unless you know what you are doing.
44 =item rank - The sequence number of the reading. This should probably not
49 One of 'text', 'is_start', 'is_end', or 'is_lacuna' is required.
65 Accessor methods for the given attributes.
71 isa => 'Text::Tradition::Collation',
86 writer => 'alter_text',
128 predicate => 'has_rank',
129 clearer => 'clear_rank',
132 ## For morphological analysis
134 has 'normal_form' => (
137 predicate => 'has_normal_form',
143 predicate => 'has_lemma',
146 has 'morphology' => (
148 isa => 'ArrayRef[HashRef[ArrayRef[Text::Tradition::Collation::Reading::Morphology]]]',
150 lexemes => 'elements',
151 has_morphology => 'count',
152 _clear_morph => 'clear',
153 _add_morph => 'push',
157 ## For prefix/suffix readings
159 has 'join_prior' => (
172 around BUILDARGS => sub {
182 # If one of our special booleans is set, we change the text and the
184 if( exists $args->{'is_lacuna'} && !exists $args->{'text'} ) {
185 $args->{'text'} = '#LACUNA#';
186 } elsif( exists $args->{'is_start'} ) {
187 $args->{'id'} = '#START#'; # Change the ID to ensure we have only one
188 $args->{'text'} = '#START#';
190 } elsif( exists $args->{'is_end'} ) {
191 $args->{'id'} = '#END#'; # Change the ID to ensure we have only one
192 $args->{'text'} = '#END#';
193 } elsif( exists $args->{'is_ph'} ) {
194 $args->{'text'} = $args->{'id'};
197 $class->$orig( $args );
202 A meta attribute (ha ha), which should be true if any of our 'special'
203 booleans are true. Implies that the reading does not represent a bit
204 of text found in a witness.
210 return $self->is_start || $self->is_end || $self->is_lacuna || $self->is_ph;
213 =head1 Convenience methods
215 =head2 related_readings
217 Calls Collation's related_readings with $self as the first argument.
221 sub related_readings {
223 return $self->collation->related_readings( $self, @_ );
228 Calls Collation's reading_witnesses with $self as the first argument.
234 return $self->collation->reading_witnesses( $self, @_ );
239 Returns a list of Reading objects that immediately precede $self in the collation.
245 my @pred = $self->collation->sequence->predecessors( $self->id );
246 return map { $self->collation->reading( $_ ) } @pred;
251 Returns a list of Reading objects that immediately follow $self in the collation.
257 my @succ = $self->collation->sequence->successors( $self->id );
258 return map { $self->collation->reading( $_ ) } @succ;
261 =head2 set_identical( $other_reading)
263 Backwards compatibility method, to add a transposition relationship
264 between $self and $other_reading. Don't use this.
269 my( $self, $other ) = @_;
270 return $self->collation->add_relationship( $self, $other,
271 { 'type' => 'transposition' } );
281 A few methods to try to tack on morphological information.
283 =head2 is_disambiguated
285 Returns true if there is only one tag per lexeme in this reading.
291 =head2 add_morphological_tag
302 my( $self, @lexemes ) = @_;
303 # The lexemes need to be the same as $self->text.
304 my $cmpstr = $self->has_normal_form ? lc( $self->normal_form ) : lc( $self->text );
305 $cmpstr =~ s/[\s-]+//g;
306 my $lexstr = lc( join( '', @lexemes ) );
307 $lexstr =~ s/[\s-]+//g;
308 unless( $lexstr eq $cmpstr ) {
309 warn "Cannot split " . $self->text . " into " . join( '.', @lexemes );
313 map { $self->_add_morph( { $_ => [] } ) } @lexemes;
316 sub add_morphological_tag {
317 my( $self, $lexeme, $opts ) = @_;
320 # No lexeme was passed; use reading text.
322 $lexeme = $self->text;
323 $self->use_lexemes( $lexeme );
325 # Get the correct container
326 ( $struct ) = grep { exists $_->{$lexeme} } $self->lexemes;
328 warn "No lexeme $lexeme exists in this reading";
331 # Now make the morph object and add it to this lexeme.
332 my $morph_obj = Text::Tradition::Collation::Reading::Morphology->new( $opts );
333 # TODO Check for existence
334 push( @{$struct->{$lexeme}}, $morph_obj );
338 my( $self, $lexeme, $index ) = @_;
341 # No lexeme was passed; use reading text.
343 $lexeme = $self->text;
345 # Get the correct container
346 ( $struct ) = grep { exists $_->{$lexeme} } $self->lexemes;
348 warn "No lexeme $lexeme exists in this reading";
351 # Keep the object at the selected index
352 my $selected = $struct->{$lexeme}->[$index];
353 $struct->{$lexeme} = [ $selected ];
356 sub is_disambiguated {
358 return undef unless $self->has_morphology;
359 foreach my $lexeme ( $self->lexemes ) {
360 my( $key ) = keys %$lexeme; # will be only one
361 return undef unless @{$lexeme->{$key}} == 1;
373 ## TODO will need a throw() here
376 __PACKAGE__->meta->make_immutable;
378 ###################################################
379 ### Morphology objects, to be attached to readings
380 ###################################################
382 package Text::Tradition::Collation::Reading::Morphology;
404 ## Transmute codes into comparison arrays for our various languages.
406 around BUILDARGS => sub {
410 if( @_ == 1 && ref( $_[0] ) ) {
415 if( exists( $args->{'serial'} ) ) {
416 my( $lemma, $code ) = split( /!!/, delete $args->{'serial'} );
417 $args->{'lemma'} = $lemma;
418 $args->{'code'} = $code;
420 $class->$orig( $args );
425 return join( '!!', $self->lemma, $self->code );
428 sub comparison_array {
430 if( $self->language eq 'French' ) {
432 my @bits = split( /\+/, $self->code );
433 # First push the non k/v parts.
434 while( @bits && $bits[0] !~ /=/ ) {
435 push( @array, shift @bits );
437 while( @array < 2 ) {
438 push( @array, undef );
440 # Now push the k/v parts in a known order.
441 my @fields = qw/ Pers Nb Temps Genre Spec Fonc /;
443 map { my( $k, $v ) = split( /=/, $_ ); $props{$k} = $v; } @bits;
444 foreach my $k ( @fields ) {
445 push( @array, $props{$k} );
449 } elsif( $self->language eq 'English' ) {
450 # Do something as yet undetermined
452 # Latin or Greek or Armenian, just split the chars
453 return split( '', $self->code );
458 __PACKAGE__->meta->make_immutable;