lib/Text/Tradition/Collation/Reading.pm

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