lib/Text/Tradition/Collation/Reading.pm

   1 package Text::Tradition::Collation::Reading;
   2
   3 use Moose;
   4 use overload '""' => \&_stringify, 'fallback' => 1;
   5
   6 =head1 NAME
   7
   8 Text::Tradition::Collation::Reading - represents a reading (usually a word) in a collation.
   9
  10 =head1 DESCRIPTION
  11
  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
  16 a particular sequence
  17
  18 =head1 METHODS
  19
  20 =head2 new
  21
  22 Creates a new reading in the given collation with the given attributes.
  23 Options include:
  24
  25 =over 4
  26
  27 =item collation - The Text::Tradition::Collation object to which this reading belongs.  Required.
  28
  29 =item id - A unique identifier for this reading. Required.
  30
  31 =item text - The word or other text of the reading.
  32
  33 =item is_start - The reading is the starting point for the collation.
  34
  35 =item is_end - The reading is the ending point for the collation.
  36
  37 =item is_lacuna - The 'reading' represents a known gap in the text.
  38
  39 =item is_ph - A temporary placeholder for apparatus parsing purposes.  Do not use unless you know what you are doing.
  40
  41 =item rank - The sequence number of the reading. This should probably not be set manually.
  42
  43 =back
  44
  45 One of 'text', 'is_start', 'is_end', or 'is_lacuna' is required.
  46
  47 =head2 collation
  48
  49 =head2 id
  50
  51 =head2 text
  52
  53 =head2 is_start
  54
  55 =head2 is_end
  56
  57 =head2 is_lacuna
  58
  59 =head2 rank
  60
  61 Accessor methods for the given attributes.
  62
  63 =cut
  64
  65 has 'collation' => (
  66         is => 'ro',
  67         isa => 'Text::Tradition::Collation',
  68         # required => 1,
  69         weak_ref => 1,
  70         );
  71
  72 has 'id' => (
  73         is => 'ro',
  74         isa => 'Str',
  75         required => 1,
  76         );
  77
  78 has 'text' => (
  79         is => 'ro',
  80         isa => 'Str',
  81         required => 1,
  82         writer => 'alter_text',
  83         );
  84
  85 has 'punctuation' => (
  86         traits => ['Array'],
  87         isa => 'ArrayRef[HashRef[Str]]',
  88         default => sub { [] },
  89         handles => {
  90                         punctuation => 'elements',
  91                         add_punctuation => 'push',
  92                         },
  93         );
  94
  95 has 'separate_punctuation' => (
  96         is => 'ro',
  97         isa => 'Bool',
  98         default => 1,
  99         );
 100
 101 has 'is_start' => (
 102         is => 'ro',
 103         isa => 'Bool',
 104         default => undef,
 105         );
 106
 107 has 'is_end' => (
 108         is => 'ro',
 109         isa => 'Bool',
 110         default => undef,
 111         );
 112
 113 has 'is_lacuna' => (
 114     is => 'ro',
 115     isa => 'Bool',
 116         default => undef,
 117     );
 118
 119 has 'is_ph' => (
 120         is => 'ro',
 121         isa => 'Bool',
 122         default => undef,
 123         );
 124
 125 has 'rank' => (
 126     is => 'rw',
 127     isa => 'Int',
 128     predicate => 'has_rank',
 129     );
 130
 131
 132 around BUILDARGS => sub {
 133         my $orig = shift;
 134         my $class = shift;
 135         my $args;
 136         if( @_ == 1 ) {
 137                 $args = shift;
 138         } else {
 139                 $args = { @_ };
 140         }
 141
 142         # Did we get a JSON token to parse into a reading?  If so, massage it.
 143         if( exists $args->{'json'} ) {
 144                 my $j = delete $args->{'json'};
 145
 146                 # If we have separated punctuation and don't want it, restore it.
 147                 if( exists $j->{'punctuation'}
 148                         && exists $args->{'separate_punctuation'}
 149                         && !$args->{'separate_punctuation'} ) {
 150                         $args->{'text'} = _restore_punct( $j->{'t'}, $j->{'punctuation'} );
 151
 152                 # In all other cases, keep text and punct as they are.
 153                 } else {
 154                         $args->{'text'} = $j->{'t'};
 155                         # we don't use comparison or canonical forms here
 156                         $args->{'punctuation'} = $j->{'punctuation'}
 157                                 if exists $j->{'punctuation'};
 158                 }
 159         }
 160
 161         # If one of our special booleans is set, we change the text and the
 162         # ID to match.
 163         if( exists $args->{'is_lacuna'} && !exists $args->{'text'} ) {
 164                 $args->{'text'} = '#LACUNA#';
 165         } elsif( exists $args->{'is_start'} ) {
 166                 $args->{'id'} = '#START#';  # Change the ID to ensure we have only one
 167                 $args->{'text'} = '#START#';
 168                 $args->{'rank'} = 0;
 169         } elsif( exists $args->{'is_end'} ) {
 170                 $args->{'id'} = '#END#';        # Change the ID to ensure we have only one
 171                 $args->{'text'} = '#END#';
 172         } elsif( exists $args->{'is_ph'} ) {
 173                 $args->{'text'} = $args->{'id'};
 174         }
 175
 176         $class->$orig( $args );
 177 };
 178
 179 # Post-process the given text, stripping punctuation if we are asked.
 180 sub BUILD {
 181         my $self = shift;
 182         if( $self->separate_punctuation && !$self->is_meta
 183                 && !$self->punctuation ) {
 184                 my $pos = 0;
 185                 my $wspunct = '';  # word sans punctuation
 186                 foreach my $char ( split( //, $self->text ) ) {
 187                         if( $char =~ /^[[:punct:]]$/ ) {
 188                                 $self->add_punctuation( { 'char' => $char, 'pos' => $pos } );
 189                         } else {
 190                                 $wspunct .= $char;
 191                         }
 192                         $pos++;
 193                 }
 194                 $self->alter_text( $wspunct );
 195         }
 196 }
 197
 198 sub punctuated_form {
 199         my $self = shift;
 200         return _restore_punct( $self->text, $self->punctuation );
 201 }
 202
 203 sub _restore_punct {
 204         my( $word, @punct ) = @_;
 205         foreach my $p ( sort { $a->{pos} <=> $b->{pos} } @punct ) {
 206                 substr( $word, $p->{pos}, 0, $p->{char} );
 207         }
 208         return $word;
 209 }
 210
 211 =head2 is_meta
 212
 213 A meta attribute (ha ha), which should be true if any of our 'special'
 214 booleans are true.  Implies that the reading does not represent a bit
 215 of text found in a witness.
 216
 217 =cut
 218
 219 sub is_meta {
 220         my $self = shift;
 221         return $self->is_start || $self->is_end || $self->is_lacuna || $self->is_ph;
 222 }
 223
 224 # Some syntactic sugar
 225 sub related_readings {
 226         my $self = shift;
 227         return $self->collation->related_readings( $self, @_ );
 228 }
 229
 230 sub predecessors {
 231         my $self = shift;
 232         my @pred = $self->collation->sequence->predecessors( $self->id );
 233         return map { $self->collation->reading( $_ ) } @pred;
 234 }
 235
 236 sub successors {
 237         my $self = shift;
 238         my @succ = $self->collation->sequence->successors( $self->id );
 239         return map { $self->collation->reading( $_ ) } @succ;
 240 }
 241
 242 sub set_identical {
 243         my( $self, $other ) = @_;
 244         return $self->collation->add_relationship( $self, $other,
 245                 { 'type' => 'transposition' } );
 246 }
 247
 248 sub _stringify {
 249         my $self = shift;
 250         return $self->id;
 251 }
 252
 253 no Moose;
 254 __PACKAGE__->meta->make_immutable;
 255
 256 1;
 257