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.
286 my( $self, @lexemes ) = @_;
287 # The lexemes need to be the same as $self->text.
288 my $cmpstr = $self->has_normal_form ? lc( $self->normal_form ) : lc( $self->text );
289 $cmpstr =~ s/[\s-]+//g;
290 my $lexstr = lc( join( '', @lexemes ) );
291 $lexstr =~ s/[\s-]+//g;
292 unless( $lexstr eq $cmpstr ) {
293 warn "Cannot split " . $self->text . " into " . join( '.', @lexemes );
297 map { $self->_add_morph( { $_ => [] } ) } @lexemes;
300 sub add_morphological_tag {
301 my( $self, $lexeme, $opts ) = @_;
304 # No lexeme was passed; use reading text.
306 $lexeme = $self->text;
307 $self->use_lexemes( $lexeme );
309 # Get the correct container
310 ( $struct ) = grep { exists $_->{$lexeme} } $self->lexemes;
312 warn "No lexeme $lexeme exists in this reading";
315 # Now make the morph object and add it to this lexeme.
316 my $morph_obj = Text::Tradition::Collation::Reading::Morphology->new( $opts );
317 # TODO Check for existence
318 push( @{$struct->{$lexeme}}, $morph_obj );
322 my( $self, $lexeme, $index ) = @_;
325 # No lexeme was passed; use reading text.
327 $lexeme = $self->text;
329 # Get the correct container
330 ( $struct ) = grep { exists $_->{$lexeme} } $self->lexemes;
332 warn "No lexeme $lexeme exists in this reading";
335 # Keep the object at the selected index
336 my $selected = $struct->{$lexeme}->[$index];
337 $struct->{$lexeme} = [ $selected ];
340 sub is_disambiguated {
342 return undef unless $self->has_morphology;
343 foreach my $lexeme ( $self->lexemes ) {
344 my( $key ) = keys %$lexeme; # will be only one
345 return undef unless @{$lexeme->{$key}} == 1;
357 ## TODO will need a throw() here
360 __PACKAGE__->meta->make_immutable;
362 ###################################################
363 ### Morphology objects, to be attached to readings
364 ###################################################
366 package Text::Tradition::Collation::Reading::Morphology;
388 ## Transmute codes into comparison arrays for our various languages.
390 around BUILDARGS => sub {
394 if( @_ == 1 && ref( $_[0] ) ) {
399 if( exists( $args->{'serial'} ) ) {
400 my( $lemma, $code ) = split( /!!/, delete $args->{'serial'} );
401 $args->{'lemma'} = $lemma;
402 $args->{'code'} = $code;
404 $class->$orig( $args );
409 return join( '!!', $self->lemma, $self->code );
412 sub comparison_array {
414 if( $self->language eq 'French' ) {
416 my @bits = split( /\+/, $self->code );
417 # First push the non k/v parts.
418 while( @bits && $bits[0] !~ /=/ ) {
419 push( @array, shift @bits );
421 while( @array < 2 ) {
422 push( @array, undef );
424 # Now push the k/v parts in a known order.
425 my @fields = qw/ Pers Nb Temps Genre Spec Fonc /;
427 map { my( $k, $v ) = split( /=/, $_ ); $props{$k} = $v; } @bits;
428 foreach my $k ( @fields ) {
429 push( @array, $props{$k} );
433 } elsif( $self->language eq 'English' ) {
434 # Do something as yet undetermined
436 # Latin or Greek or Armenian, just split the chars
437 return split( '', $self->code );
442 __PACKAGE__->meta->make_immutable;