lib/Text/Tradition/Collation/Reading.pm

   1 package Text::Tradition::Collation::Reading;
   2
   3 use Moose;
   4 use MooseX::NonMoose;
   5 use Text::Tradition::Collation::Position;
   6
   7 extends 'Graph::Easy::Node';
   8
   9 has 'position' => (
  10     is => 'rw',
  11     isa => 'Text::Tradition::Collation::Position',
  12     predicate => 'has_position',
  13     );
  14
  15 has 'rank' => (
  16     is => 'rw',
  17     isa => 'Int',
  18     predicate => 'has_rank',
  19     );
  20
  21 has 'is_lacuna' => (
  22     is => 'rw',
  23     isa => 'Bool',
  24     );
  25
  26 # This contains an array of reading objects; the array is a pool,
  27 # shared by the reading objects inside the pool.  When a reading is
  28 # added to the pool, all the same_as attributes should be updated.
  29 has 'same_as' => (
  30     is => 'rw',
  31     isa => 'ArrayRef[Text::Tradition::Collation::Reading]',
  32     );
  33
  34 # Deal with the non-arg option for Graph::Easy's constructor.
  35 around BUILDARGS => sub {
  36     my $orig = shift;
  37     my $class = shift;
  38
  39     my %args;
  40     if( @_ == 1 && ref( $_[0] ) ne 'HASH' ) {
  41         return $class->$orig( 'name' => $_[0] );
  42     } else {
  43         return $class->$orig( @_ );
  44     }
  45 };
  46
  47 # Take constructor args as well as a Position argument.
  48 around position => sub {
  49     my $orig = shift;
  50     my $self = shift;
  51     return $self->$orig() unless @_;
  52
  53     my @args = @_;
  54     unless( @_ == 1 && ref( $_[0] ) eq 'Text::Tradition::Collation::Position' ) {
  55         # We have constructor arguments; pass them to Position.
  56         @args = ( Text::Tradition::Collation::Position->new( @_ ) );
  57     }
  58     $self->$orig( @args );
  59 };
  60
  61 # A lacuna node is also a meta node.
  62 before is_lacuna => sub {
  63         my( $self, $arg ) = @_;
  64         if( $arg ) {
  65                 $self->is_meta( 1 );
  66         }
  67 };
  68
  69 # Initialize the identity pool.
  70 sub BUILD {
  71     my( $self, $args ) = @_;
  72     $self->same_as( [ $self ] );
  73 }
  74
  75 sub text {
  76     # Wrapper function around 'label' attribute.
  77     my $self = shift;
  78     if( @_ ) {
  79         if( defined $_[0] ) {
  80                 $self->set_attribute( 'label', $_[0] );
  81         } else {
  82             $self->del_attribute( 'label' );
  83         }
  84     }
  85     return $self->label;
  86 }
  87
  88 sub witnessed_by {
  89     my( $self, $sigil, $backup ) = @_;
  90     my @wits = $self->witnesses;
  91     return 1 if grep { $_ eq $sigil } @wits;
  92     if( $backup ) {
  93         return 1 if grep { $_ eq $backup } @wits;
  94     }
  95     return 0;
  96 }
  97
  98 sub witnesses {
  99     my( $self ) = @_;
 100     my @paths = grep { $_->get_attribute( 'class' ) eq 'path' } $self->outgoing;
 101     push( @paths, grep { $_->get_attribute( 'class' ) eq 'path' } $self->incoming );
 102     my %wits;
 103     foreach my $p ( @paths ) {
 104         if( $p->has_hidden_witnesses ) {
 105             foreach ( @{$p->hidden_witnesses} ) {
 106                 $wits{$_} = 1;
 107             }
 108         } else {
 109             $wits{$p->label} = 1;
 110         }
 111     }
 112     return keys %wits;
 113 }
 114
 115 sub merge_from {
 116     my( $self, $merged_node ) = @_;
 117     # Adopt the identity pool of the other node.
 118     my @now_identical = grep { $_ ne $merged_node } @{$merged_node->same_as};
 119     my $new_pool = _merge_array_pool( \@now_identical, $self->same_as )
 120         if @now_identical;
 121
 122     # TODO Adopt the relationship attributes and segment memberships of the other node.
 123 }
 124
 125 ## Dealing with transposed readings.  These methods are only really
 126 ## applicable if we have a linear collation graph.
 127
 128 sub set_identical {
 129     my( $self, $other_node ) = @_;
 130     my $enlarged_pool = _merge_array_pool( $self->same_as,
 131                                            $other_node->same_as );
 132
 133     # ...and set this node to point to the enlarged pool.
 134     $self->same_as( $enlarged_pool );
 135 }
 136
 137 sub identical_readings {
 138     my $self = shift;
 139     my @same = grep { $_ ne $self } @{$self->same_as};
 140     return @same;
 141 }
 142
 143 sub _merge_array_pool {
 144     my( $pool, $main_pool ) = @_;
 145     my %poolhash;
 146     foreach ( @$main_pool ) {
 147         # Note which nodes are already in the main pool so that we
 148         # don't re-add them.
 149         $poolhash{$_->name} = 1;
 150     }
 151
 152     foreach( @$pool ) {
 153         # Add the remaining nodes to the main pool...
 154         push( @$main_pool, $_ ) unless $poolhash{$_->name};
 155     }
 156     return $main_pool;
 157 }
 158
 159 sub has_primary {
 160     my $self = shift;
 161     my $pool = $self->same_as;
 162     return $pool->[0]->name ne $self->name;
 163 }
 164
 165 sub primary {
 166     my $self = shift;
 167     return $self->same_as->[0];
 168 }
 169
 170 sub is_at_position {
 171     my $self = shift;
 172     return undef unless $self->has_position;
 173     return $self->position->is_colocated( @_ );
 174 }
 175
 176 # Looks from the outside like an accessor for a Boolean, but really
 177 # sets the node's class.  Should apply to start, end, and lacunae.
 178
 179 sub is_meta {
 180         my $self = shift;
 181         my $arg = shift;
 182         if( defined $arg && $arg ) {
 183                 $self->set_attribute( 'class', 'meta' );
 184         } elsif ( defined $arg ) {
 185                 $self->del_attribute( 'class' );
 186         }
 187         return $self->sub_class eq 'meta';
 188 }
 189
 190 # Returns all readings that adjoin this one on any path.
 191 sub neighbor_readings {
 192     my( $self, $direction ) = @_;
 193     $direction = 'both' unless $direction;
 194     my @paths = grep { $_->isa( 'Text::Tradition::Collation::Path' ) } $self->edges;
 195     my %connected;
 196     foreach my $p ( @paths ) {
 197         if( $p->to eq $self ) {
 198             next if $direction eq 'forward';
 199             $connected{$p->from->name} = $p->from;
 200         } else { # $p->from eq $self
 201             next if $direction =~ /^back/;
 202             $connected{$p->to->name} = $p->to;
 203         }
 204     }
 205     return values( %connected );
 206 }
 207
 208 # Returns all readings related to the one we've got.
 209 sub related_readings {
 210     my( $self, $colocated ) = @_;
 211     my @related;
 212     foreach my $e ( $self->edges ) {
 213         next unless $e->isa( 'Text::Tradition::Collation::Relationship' );
 214         next if $colocated && $e->type eq 'repetition';
 215         push( @related, $e->from eq $self ? $e->to : $e->from );
 216     }
 217     return @related;
 218 }
 219
 220 ## Keep track of which readings are unchanged across witnesses.
 221 sub is_common {
 222     my( $self ) = shift;
 223     return $self->get_attribute( 'class' ) eq 'common';
 224 }
 225
 226 ## TODO Rationalize make_common, is_meta, etc.
 227 sub make_common {
 228     my( $self ) = shift;
 229     $self->set_attribute( 'class', 'common' );
 230 }
 231
 232 sub make_variant {
 233     my( $self ) = shift;
 234     $self->set_attribute( 'class', 'variant' );
 235 }
 236
 237 no Moose;
 238 __PACKAGE__->meta->make_immutable;
 239
 240 1;
 241
 242 ######################################################
 243 ## copied from Graph::Easy::Parser docs
 244 ######################################################
 245 # when overriding nodes, we also need ::Anon
 246
 247 package Text::Tradition::Collation::Reading::Anon;
 248 use Moose;
 249 use MooseX::NonMoose;
 250 extends 'Text::Tradition::Collation::Reading';
 251 extends 'Graph::Easy::Node::Anon';
 252 no Moose;
 253 __PACKAGE__->meta->make_immutable;
 254
 255 1;
 256 # use base qw/Text::Tradition::Collation::Reading/;
 257 # use base qw/Graph::Easy::Node::Anon/;
 258
 259 ######################################################
 260 # and :::Empty
 261
 262 package Text::Tradition::Collation::Reading::Empty;
 263 use Moose;
 264 use MooseX::NonMoose;
 265 extends 'Graph::Easy::Node::Empty';
 266 no Moose;
 267 __PACKAGE__->meta->make_immutable;
 268
 269 1;
 270 # use base qw/Text::Tradition::Collation::Reading/;
 271
 272 ######################################################