add support for lacunas within the witnesses

[scpubgit/stemmatology.git] / lib / Text / Tradition / Collation / Reading.pm

diff --git a/lib/Text/Tradition/Collation/Reading.pm b/lib/Text/Tradition/Collation/Reading.pm
index 8402751..f598418 100644 (file)
--- a/lib/Text/Tradition/Collation/Reading.pm
+++ b/lib/Text/Tradition/Collation/Reading.pm
@@ -1,22 +1,27 @@
 package Text::Tradition::Collation::Reading;
 
 use Moose;
-use Moose::Util::TypeConstraints;
 use MooseX::NonMoose;
-use Text::Tradition::Collation::Relationship;
+use Text::Tradition::Collation::Position;
 
 extends 'Graph::Easy::Node';
 
-subtype 'Position'
-    => as 'Str',
-    => where { $_ =~ /^\d+\,\d+$/ },
-    message { 'Position must be of the form x,y' };
-
 has 'position' => (
     is => 'rw',
-    isa => 'Position',
+    isa => 'Text::Tradition::Collation::Position',
     predicate => 'has_position',
     );
+    
+has 'rank' => (
+    is => 'rw',
+    isa => 'Int',
+    predicate => 'has_rank',
+    );
+    
+has 'is_lacuna' => (
+    is => 'rw',
+    isa => 'Bool',
+    );
 
 # This contains an array of reading objects; the array is a pool,
 # shared by the reading objects inside the pool.  When a reading is
@@ -39,6 +44,20 @@ around BUILDARGS => sub {
     }
 };
 
+# Take constructor args as well as a Position argument.
+around position => sub {
+    my $orig = shift;
+    my $self = shift;
+    return $self->$orig() unless @_;
+
+    my @args = @_;
+    unless( @_ == 1 && ref( $_[0] ) eq 'Text::Tradition::Collation::Position' ) {
+       # We have constructor arguments; pass them to Position.
+       @args = ( Text::Tradition::Collation::Position->new( @_ ) );
+    }
+    $self->$orig( @args );
+};
+
 # Initialize the identity pool. 
 sub BUILD {
     my( $self, $args ) = @_;
@@ -49,9 +68,40 @@ sub text {
     # Wrapper function around 'label' attribute.
     my $self = shift;
     if( @_ ) {
-       $self->set_attribute( 'label', $_[0] );
+        if( defined $_[0] ) {
+               $self->set_attribute( 'label', $_[0] );
+        } else {
+            $self->del_attribute( 'label' );
+        }
+    }
+    return $self->label;
+}
+
+sub witnessed_by {
+    my( $self, $sigil, $backup ) = @_;
+    my @wits = $self->witnesses;
+    return 1 if grep { $_ eq $sigil } @wits;
+    if( $backup ) {
+        return 1 if grep { $_ eq $backup } @wits;
+    }
+    return 0;
+}
+    
+sub witnesses {
+    my( $self ) = @_;
+    my @paths = grep { $_->get_attribute( 'class' ) eq 'path' } $self->outgoing;
+    push( @paths, grep { $_->get_attribute( 'class' ) eq 'path' } $self->incoming );
+    my %wits;
+    foreach my $p ( @paths ) {
+        if( $p->has_hidden_witnesses ) {
+            foreach ( @{$p->hidden_witnesses} ) {
+                $wits{$_} = 1;
+            }
+        } else {
+            $wits{$p->label} = 1;
+        }
     }
-    return $self->get_attribute( 'label' );
+    return keys %wits;
 }
 
 sub merge_from {
@@ -61,7 +111,7 @@ sub merge_from {
     my $new_pool = _merge_array_pool( \@now_identical, $self->same_as )
        if @now_identical;
 
-    # TODO Adopt the relationship attributes of the other node.
+    # TODO Adopt the relationship attributes and segment memberships of the other node.
 }
 
 ## Dealing with transposed readings.  These methods are only really
@@ -101,7 +151,7 @@ sub _merge_array_pool {
 sub has_primary {
     my $self = shift;
     my $pool = $self->same_as;
-    return $pool->[0]->name eq $self->name;
+    return $pool->[0]->name ne $self->name;
 }
 
 sub primary {
@@ -109,8 +159,43 @@ sub primary {
     return $self->same_as->[0];
 }
 
-## Keep track of which readings are unchanged across witnesses.
+sub is_at_position {
+    my $self = shift;
+    return undef unless $self->has_position;
+    return $self->position->is_colocated( @_ );
+}
 
+# Returns all readings that adjoin this one on any path.
+sub neighbor_readings {
+    my( $self, $direction ) = @_;
+    $direction = 'both' unless $direction;
+    my @paths = grep { $_->isa( 'Text::Tradition::Collation::Path' ) } $self->edges;
+    my %connected;
+    foreach my $p ( @paths ) {
+       if( $p->to eq $self ) {
+           next if $direction eq 'forward';
+           $connected{$p->from->name} = $p->from;
+       } else { # $p->from eq $self
+           next if $direction =~ /^back/;
+           $connected{$p->to->name} = $p->to;
+       }
+    }
+    return values( %connected );
+}
+
+# Returns all readings related to the one we've got.
+sub related_readings {
+    my( $self, $colocated ) = @_;
+    my @related;
+    foreach my $e ( $self->edges ) {
+        next unless $e->isa( 'Text::Tradition::Collation::Relationship' );
+        next if $colocated && $e->type eq 'repetition';
+        push( @related, $e->from eq $self ? $e->to : $e->from );
+    }
+    return @related;
+}
+
+## Keep track of which readings are unchanged across witnesses.
 sub is_common {
     my( $self ) = shift;
     return $self->get_attribute( 'class' ) eq 'common';