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',
124 predicate => 'has_rank',
125 clearer => 'clear_rank',
128 ## For morphological analysis
130 has 'normal_form' => (
133 predicate => 'has_normal_form',
139 predicate => 'has_lemma',
142 has 'morphology' => (
144 isa => 'ArrayRef[HashRef[ArrayRef[Text::Tradition::Collation::Reading::Morphology]]]',
146 lexemes => 'elements',
147 has_morphology => 'count',
148 _clear_morph => 'clear',
149 _add_morph => 'push',
153 ## For prefix/suffix readings
155 has 'join_prior' => (
168 around BUILDARGS => sub {
178 # If one of our special booleans is set, we change the text and the
180 if( exists $args->{'is_lacuna'} && !exists $args->{'text'} ) {
181 $args->{'text'} = '#LACUNA#';
182 } elsif( exists $args->{'is_start'} ) {
183 $args->{'id'} = '#START#'; # Change the ID to ensure we have only one
184 $args->{'text'} = '#START#';
186 } elsif( exists $args->{'is_end'} ) {
187 $args->{'id'} = '#END#'; # Change the ID to ensure we have only one
188 $args->{'text'} = '#END#';
189 } elsif( exists $args->{'is_ph'} ) {
190 $args->{'text'} = $args->{'id'};
193 $class->$orig( $args );
198 A meta attribute (ha ha), which should be true if any of our 'special'
199 booleans are true. Implies that the reading does not represent a bit
200 of text found in a witness.
206 return $self->is_start || $self->is_end || $self->is_lacuna || $self->is_ph;
209 =head1 Convenience methods
211 =head2 related_readings
213 Calls Collation's related_readings with $self as the first argument.
217 sub related_readings {
219 return $self->collation->related_readings( $self, @_ );
224 Calls Collation's reading_witnesses with $self as the first argument.
230 return $self->collation->reading_witnesses( $self, @_ );
235 Returns a list of Reading objects that immediately precede $self in the collation.
241 my @pred = $self->collation->sequence->predecessors( $self->id );
242 return map { $self->collation->reading( $_ ) } @pred;
247 Returns a list of Reading objects that immediately follow $self in the collation.
253 my @succ = $self->collation->sequence->successors( $self->id );
254 return map { $self->collation->reading( $_ ) } @succ;
257 =head2 set_identical( $other_reading)
259 Backwards compatibility method, to add a transposition relationship
260 between $self and $other_reading. Don't use this.
265 my( $self, $other ) = @_;
266 return $self->collation->add_relationship( $self, $other,
267 { 'type' => 'transposition' } );
277 A few methods to try to tack on morphological information.
279 =head2 is_disambiguated
281 Returns true if there is only one tag per lexeme in this reading.
287 =head2 add_morphological_tag
298 my( $self, @lexemes ) = @_;
299 # The lexemes need to be the same as $self->text.
300 my $cmpstr = $self->has_normal_form ? lc( $self->normal_form ) : lc( $self->text );
301 $cmpstr =~ s/[\s-]+//g;
302 my $lexstr = lc( join( '', @lexemes ) );
303 $lexstr =~ s/[\s-]+//g;
304 unless( $lexstr eq $cmpstr ) {
305 warn "Cannot split " . $self->text . " into " . join( '.', @lexemes );
309 map { $self->_add_morph( { $_ => [] } ) } @lexemes;
312 sub add_morphological_tag {
313 my( $self, $lexeme, $opts ) = @_;
316 # No lexeme was passed; use reading text.
318 $lexeme = $self->text;
319 $self->use_lexemes( $lexeme );
321 # Get the correct container
322 ( $struct ) = grep { exists $_->{$lexeme} } $self->lexemes;
324 warn "No lexeme $lexeme exists in this reading";
327 # Now make the morph object and add it to this lexeme.
328 my $morph_obj = Text::Tradition::Collation::Reading::Morphology->new( $opts );
329 # TODO Check for existence
330 push( @{$struct->{$lexeme}}, $morph_obj );
334 my( $self, $lexeme, $index ) = @_;
337 # No lexeme was passed; use reading text.
339 $lexeme = $self->text;
341 # Get the correct container
342 ( $struct ) = grep { exists $_->{$lexeme} } $self->lexemes;
344 warn "No lexeme $lexeme exists in this reading";
347 # Keep the object at the selected index
348 my $selected = $struct->{$lexeme}->[$index];
349 $struct->{$lexeme} = [ $selected ];
352 sub is_disambiguated {
354 return undef unless $self->has_morphology;
355 foreach my $lexeme ( $self->lexemes ) {
356 my( $key ) = keys %$lexeme; # will be only one
357 return undef unless @{$lexeme->{$key}} == 1;
369 ## TODO will need a throw() here
372 __PACKAGE__->meta->make_immutable;
374 ###################################################
375 ### Morphology objects, to be attached to readings
376 ###################################################
378 package Text::Tradition::Collation::Reading::Morphology;
400 ## Transmute codes into comparison arrays for our various languages.
402 around BUILDARGS => sub {
406 if( @_ == 1 && ref( $_[0] ) ) {
411 if( exists( $args->{'serial'} ) ) {
412 my( $lemma, $code ) = split( /!!/, delete $args->{'serial'} );
413 $args->{'lemma'} = $lemma;
414 $args->{'code'} = $code;
416 $class->$orig( $args );
421 return join( '!!', $self->lemma, $self->code );
424 sub comparison_array {
426 if( $self->language eq 'French' ) {
428 my @bits = split( /\+/, $self->code );
429 # First push the non k/v parts.
430 while( @bits && $bits[0] !~ /=/ ) {
431 push( @array, shift @bits );
433 while( @array < 2 ) {
434 push( @array, undef );
436 # Now push the k/v parts in a known order.
437 my @fields = qw/ Pers Nb Temps Genre Spec Fonc /;
439 map { my( $k, $v ) = split( /=/, $_ ); $props{$k} = $v; } @bits;
440 foreach my $k ( @fields ) {
441 push( @array, $props{$k} );
445 } elsif( $self->language eq 'English' ) {
446 # Do something as yet undetermined
448 # Latin or Greek or Armenian, just split the chars
449 return split( '', $self->code );
454 __PACKAGE__->meta->make_immutable;