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