X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FText%2FTradition%2FCollation%2FReading.pm;h=95912061ff128164b231fd37a053721e43ae5c43;hb=3837c155d39333869a93adf1e8375960ffbf3a92;hp=a2fff663c558c51835533d158950433b4ee77b8f;hpb=4cdd82f11ff3566dcb09b89aa7bc3ba908a5e677;p=scpubgit%2Fstemmatology.git

diff --git a/lib/Text/Tradition/Collation/Reading.pm b/lib/Text/Tradition/Collation/Reading.pm
index a2fff66..9591206 100644
--- a/lib/Text/Tradition/Collation/Reading.pm
+++ b/lib/Text/Tradition/Collation/Reading.pm
@@ -2,14 +2,18 @@ package Text::Tradition::Collation::Reading;
 
 use Moose;
 use MooseX::NonMoose;
-use Text::Tradition::Collation::Position;
 
 extends 'Graph::Easy::Node';
 
-has 'position' => (
+has 'rank' => (
     is => 'rw',
-    isa => 'Text::Tradition::Collation::Position',
-    predicate => 'has_position',
+    isa => 'Int',
+    predicate => 'has_rank',
+    );
+    
+has 'is_lacuna' => (
+    is => 'rw',
+    isa => 'Bool',
     );
 
 # This contains an array of reading objects; the array is a pool,
@@ -33,18 +37,12 @@ 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 );
+# A lacuna node is also a meta node.
+before is_lacuna => sub {
+	my( $self, $arg ) = @_;
+	if( $arg ) {
+		$self->is_meta( 1 );
+	}
 };
 
 # Initialize the identity pool. 
@@ -57,9 +55,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->get_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 keys %wits;
 }
 
 sub merge_from {
@@ -69,7 +98,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
@@ -117,10 +146,18 @@ sub primary {
     return $self->same_as->[0];
 }
 
-sub is_at_position {
-    my $self = shift;
-    return undef unless $self->has_position;
-    return $self->position->is_colocated( @_ );
+# Looks from the outside like an accessor for a Boolean, but really 
+# sets the node's class.  Should apply to start, end, and lacunae.
+
+sub is_meta {
+	my $self = shift;
+	my $arg = shift;
+	if( defined $arg && $arg ) {
+		$self->set_attribute( 'class', 'meta' );
+	} elsif ( defined $arg ) {
+		$self->del_attribute( 'class' );
+	}
+	return $self->sub_class eq 'meta';	
 }
 
 # Returns all readings that adjoin this one on any path.
@@ -141,77 +178,36 @@ sub neighbor_readings {
     return values( %connected );
 }
 
-sub adjust_neighbor_position {
-    my $self = shift;
-    return unless $self->position->fixed;
-
-    # TODO This is a naive and repetitive implementation and
-    # I don't like it.
-    foreach my $neighbor ( $self->neighbor_readings('forward') ) {
-	next unless !$neighbor->is_common &&
-	    $neighbor->position->common == $self->position->common;
-	if( $neighbor->position->fixed &&
-	    $neighbor->position->min == $self->position->min ) {
-	    warn sprintf( "Readings %s and %s are at the same position!",
-			  $neighbor->name, $self->name );
-	}
-	next if $neighbor->position->fixed || $neighbor->position->matched;
-	$neighbor->position->min( $self->position->min + 1 );
-	# Recurse if necessary.
-	$neighbor->adjust_neighbor_position() 
-	    unless $neighbor->position->fixed;
-    }
-    foreach my $neighbor ( $self->neighbor_readings('back') ) {
-	next unless !$neighbor->is_common &&
-	    $neighbor->position->common == $self->position->common;
-	if( $neighbor->position->fixed &&
-	    $neighbor->position->min == $self->position->min ) {
-	    warn sprintf( "Readings %s and %s are at the same position!",
-			  $neighbor->name, $self->name );
-	}
-	next if $neighbor->position->fixed || $neighbor->position->matched;
-	$neighbor->position->max( $self->position->max - 1 );
-	# Recurse if necessary.
-	$neighbor->adjust_neighbor_position() 
-	    unless $neighbor->position->fixed;
+# Returns all readings related to the one we've got.
+sub related_readings {
+    my( $self, $colocated, $queried ) = @_;
+    $queried = { $self->name => 1 } unless $queried;
+    my @related;
+    # Get the nodes directly related to this one
+    foreach my $e ( $self->edges ) {
+        next unless $e->isa( 'Text::Tradition::Collation::Relationship' );
+        next if $colocated && $e->type eq 'repetition';
+        my $n = $e->from eq $self ? $e->to : $e->from;
+        next if $queried->{$n->name};
+        push( @related, $n );
     }
-    return;
-}
-    
-sub match_position {
-    my( $self, $other ) = @_;
-    $DB::single = 1;
-    # Adjust the position of both these nodes to be as restrictive as possible.
-    unless( $self->position->is_colocated( $other->position ) ) {
-	warn "Cannot match positions of non-colocated readings";
-	return;
+    # Now query those nodes for their relations, recursively
+    map { $queried->{$_->name} = 1 } @related;
+    my @also_related;
+    foreach ( @related ) {
+        push( @also_related, $_->related_readings( $colocated, $queried ) );
     }
-    my $sp = $self->position;
-    my $op = $other->position;
-    my $newmin = $sp->min > $op->min ? $sp->min : $op->min;
-    my $newmax = $sp->max < $op->max ? $sp->max : $op->max;
-    my $newpos = Text::Tradition::Collation::Position->new( 
-	'common' => $sp->common,
-	'min' => $newmin,
-	'max' => $newmax,
-	'matched' => 1,
-	);
-    # We are setting the positions to be the same object.  I don't
-    # think that actually matters.  We may eventually want unique
-    # objects for each position.
-    $self->position( $newpos );
-    $other->position( $newpos );
-    $self->adjust_neighbor_position();
-    $other->adjust_neighbor_position();
+    push( @related, @also_related );
+    return @related;
 }
 
 ## Keep track of which readings are unchanged across witnesses.
-
 sub is_common {
     my( $self ) = shift;
     return $self->get_attribute( 'class' ) eq 'common';
 }
 
+## TODO Rationalize make_common, is_meta, etc.
 sub make_common {
     my( $self ) = shift;
     $self->set_attribute( 'class', 'common' );