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 # This contains an array of reading objects; the array is a pool,
  16 # shared by the reading objects inside the pool.  When a reading is
  17 # added to the pool, all the same_as attributes should be updated.
  18 has 'same_as' => (
  19     is => 'rw',
  20     isa => 'ArrayRef[Text::Tradition::Collation::Reading]',
  21     );
  22
  23 # Deal with the non-arg option for Graph::Easy's constructor.
  24 around BUILDARGS => sub {
  25     my $orig = shift;
  26     my $class = shift;
  27
  28     my %args;
  29     if( @_ == 1 && ref( $_[0] ) ne 'HASH' ) {
  30         return $class->$orig( 'name' => $_[0] );
  31     } else {
  32         return $class->$orig( @_ );
  33     }
  34 };
  35
  36 # Take constructor args as well as a Position argument.
  37 around position => sub {
  38     my $orig = shift;
  39     my $self = shift;
  40     return $self->$orig() unless @_;
  41
  42     my @args = @_;
  43     unless( @_ == 1 && ref( $_[0] ) eq 'Text::Tradition::Collation::Position' ) {
  44         # We have constructor arguments; pass them to Position.
  45         @args = ( Text::Tradition::Collation::Position->new( @_ ) );
  46     }
  47     $self->$orig( @args );
  48 };
  49
  50 # Initialize the identity pool.
  51 sub BUILD {
  52     my( $self, $args ) = @_;
  53     $self->same_as( [ $self ] );
  54 }
  55
  56 sub text {
  57     # Wrapper function around 'label' attribute.
  58     my $self = shift;
  59     if( @_ ) {
  60         $self->set_attribute( 'label', $_[0] );
  61     }
  62     return $self->get_attribute( 'label' );
  63 }
  64
  65 sub merge_from {
  66     my( $self, $merged_node ) = @_;
  67     # Adopt the identity pool of the other node.
  68     my @now_identical = grep { $_ ne $merged_node } @{$merged_node->same_as};
  69     my $new_pool = _merge_array_pool( \@now_identical, $self->same_as )
  70         if @now_identical;
  71
  72     # TODO Adopt the relationship attributes of the other node.
  73 }
  74
  75 ## Dealing with transposed readings.  These methods are only really
  76 ## applicable if we have a linear collation graph.
  77
  78 sub set_identical {
  79     my( $self, $other_node ) = @_;
  80     my $enlarged_pool = _merge_array_pool( $self->same_as,
  81                                            $other_node->same_as );
  82
  83     # ...and set this node to point to the enlarged pool.
  84     $self->same_as( $enlarged_pool );
  85 }
  86
  87 sub identical_readings {
  88     my $self = shift;
  89     my @same = grep { $_ ne $self } @{$self->same_as};
  90     return @same;
  91 }
  92
  93 sub _merge_array_pool {
  94     my( $pool, $main_pool ) = @_;
  95     my %poolhash;
  96     foreach ( @$main_pool ) {
  97         # Note which nodes are already in the main pool so that we
  98         # don't re-add them.
  99         $poolhash{$_->name} = 1;
 100     }
 101
 102     foreach( @$pool ) {
 103         # Add the remaining nodes to the main pool...
 104         push( @$main_pool, $_ ) unless $poolhash{$_->name};
 105     }
 106     return $main_pool;
 107 }
 108
 109 sub has_primary {
 110     my $self = shift;
 111     my $pool = $self->same_as;
 112     return $pool->[0]->name ne $self->name;
 113 }
 114
 115 sub primary {
 116     my $self = shift;
 117     return $self->same_as->[0];
 118 }
 119
 120 sub is_at_position {
 121     my $self = shift;
 122     return undef unless $self->has_position;
 123     return $self->position->is_colocated( @_ );
 124 }
 125
 126 # Returns all readings that adjoin this one on any path.
 127 sub neighbor_readings {
 128     my( $self, $direction ) = @_;
 129     $direction = 'both' unless $direction;
 130     my @paths = grep { $_->isa( 'Text::Tradition::Collation::Path' ) } $self->edges;
 131     my %connected;
 132     foreach my $p ( @paths ) {
 133         if( $p->to eq $self ) {
 134             next if $direction eq 'forward';
 135             $connected{$p->from->name} = $p->from;
 136         } else { # $p->from eq $self
 137             next if $direction =~ /^back/;
 138             $connected{$p->to->name} = $p->to;
 139         }
 140     }
 141     return values( %connected );
 142 }
 143
 144 sub adjust_neighbor_position {
 145     my $self = shift;
 146     return unless $self->position->fixed;
 147
 148     # TODO This is a naive and repetitive implementation and
 149     # I don't like it.
 150     foreach my $neighbor ( $self->neighbor_readings('forward') ) {
 151         next unless !$neighbor->is_common &&
 152             $neighbor->position->common == $self->position->common;
 153         if( $neighbor->position->fixed &&
 154             $neighbor->position->min == $self->position->min ) {
 155             warn sprintf( "Readings %s and %s are at the same position!",
 156                           $neighbor->name, $self->name );
 157         }
 158         next if $neighbor->position->fixed || $neighbor->position->matched;
 159         $neighbor->position->min( $self->position->min + 1 );
 160         # Recurse if necessary.
 161         $neighbor->adjust_neighbor_position()
 162             unless $neighbor->position->fixed;
 163     }
 164     foreach my $neighbor ( $self->neighbor_readings('back') ) {
 165         next unless !$neighbor->is_common &&
 166             $neighbor->position->common == $self->position->common;
 167         if( $neighbor->position->fixed &&
 168             $neighbor->position->min == $self->position->min ) {
 169             warn sprintf( "Readings %s and %s are at the same position!",
 170                           $neighbor->name, $self->name );
 171         }
 172         next if $neighbor->position->fixed || $neighbor->position->matched;
 173         $neighbor->position->max( $self->position->max - 1 );
 174         # Recurse if necessary.
 175         $neighbor->adjust_neighbor_position()
 176             unless $neighbor->position->fixed;
 177     }
 178     return;
 179 }
 180
 181 sub match_position {
 182     my( $self, $other ) = @_;
 183     $DB::single = 1;
 184     # Adjust the position of both these nodes to be as restrictive as possible.
 185     unless( $self->position->is_colocated( $other->position ) ) {
 186         warn "Cannot match positions of non-colocated readings";
 187         return;
 188     }
 189     my $sp = $self->position;
 190     my $op = $other->position;
 191     my $newmin = $sp->min > $op->min ? $sp->min : $op->min;
 192     my $newmax = $sp->max < $op->max ? $sp->max : $op->max;
 193     my $newpos = Text::Tradition::Collation::Position->new(
 194         'common' => $sp->common,
 195         'min' => $newmin,
 196         'max' => $newmax,
 197         'matched' => 1,
 198         );
 199     # We are setting the positions to be the same object.  I don't
 200     # think that actually matters.  We may eventually want unique
 201     # objects for each position.
 202     $self->position( $newpos );
 203     $other->position( $newpos );
 204     $self->adjust_neighbor_position();
 205     $other->adjust_neighbor_position();
 206 }
 207
 208 ## Keep track of which readings are unchanged across witnesses.
 209
 210 sub is_common {
 211     my( $self ) = shift;
 212     return $self->get_attribute( 'class' ) eq 'common';
 213 }
 214
 215 sub make_common {
 216     my( $self ) = shift;
 217     $self->set_attribute( 'class', 'common' );
 218 }
 219
 220 sub make_variant {
 221     my( $self ) = shift;
 222     $self->set_attribute( 'class', 'variant' );
 223 }
 224
 225 no Moose;
 226 __PACKAGE__->meta->make_immutable;
 227
 228 1;
 229
 230 ######################################################
 231 ## copied from Graph::Easy::Parser docs
 232 ######################################################
 233 # when overriding nodes, we also need ::Anon
 234
 235 package Text::Tradition::Collation::Reading::Anon;
 236 use Moose;
 237 use MooseX::NonMoose;
 238 extends 'Text::Tradition::Collation::Reading';
 239 extends 'Graph::Easy::Node::Anon';
 240 no Moose;
 241 __PACKAGE__->meta->make_immutable;
 242
 243 1;
 244 # use base qw/Text::Tradition::Collation::Reading/;
 245 # use base qw/Graph::Easy::Node::Anon/;
 246
 247 ######################################################
 248 # and :::Empty
 249
 250 package Text::Tradition::Collation::Reading::Empty;
 251 use Moose;
 252 use MooseX::NonMoose;
 253 extends 'Graph::Easy::Node::Empty';
 254 no Moose;
 255 __PACKAGE__->meta->make_immutable;
 256
 257 1;
 258 # use base qw/Text::Tradition::Collation::Reading/;
 259
 260 ######################################################