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