lib/Text/Tradition/Collation/Reading.pm

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