From: Tara L Andrews <tla@mit.edu>
Date: Thu, 19 Apr 2012 09:49:39 +0000 (+0200)
Subject: UNTESTED better validation for transpositions
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=91e21ac6cbd1e34dc730a3f3539d4852ebdfc116;p=scpubgit%2Fstemmatology.git

UNTESTED better validation for transpositions
---

diff --git a/lib/Text/Tradition/Collation/RelationshipStore.pm b/lib/Text/Tradition/Collation/RelationshipStore.pm
index dc2fe1b..1e3af41 100644
--- a/lib/Text/Tradition/Collation/RelationshipStore.pm
+++ b/lib/Text/Tradition/Collation/RelationshipStore.pm
@@ -374,7 +374,10 @@ sub relationship_valid {
     if ( $rel eq 'transposition' || $rel eq 'repetition' ) {
 		# Check that the two readings do (for a repetition) or do not (for
 		# a transposition) appear in the same witness.
-		# TODO this might be called before witness paths are set...
+		# If we haven't made reading paths yet, take it on faith.
+		return( 1, "no paths yet" ) unless $c->sequence->successors( $c->start );
+		
+		# We have some paths, so carry on.
 		my %seen_wits;
 		map { $seen_wits{$_} = 1 } $c->reading_witnesses( $source );
 		foreach my $w ( $c->reading_witnesses( $target ) ) {
@@ -384,25 +387,50 @@ sub relationship_valid {
 				return ( 1, "ok" ) if $rel eq 'repetition';
 			}
 		}
+		# For transpositions, there should also be a path from one reading
+		# to the other.
+		if( $rel eq 'transposition' ) {
+			my( %sourceseq, %targetseq );
+			map { $sourceseq{$_} = 1 } $c->sequence->all_successors( $source );
+			map { $targetseq{$_} = 1 } $c->sequence->all_successors( $target );
+			return( 0, "Readings are parallel" )
+				unless $sourceseq{$target} || $targetseq{$source};
+		}
 		return $rel eq 'transposition' ? ( 1, "ok" )
 			: ( 0, "Readings occur only in distinct witnesses" );
-	} else {
+	} 
+	if( $rel ne 'repetition' ) {
 		# Check that linking the source and target in a relationship won't lead
-		# to a path loop for any witness.  If they have the same rank then fine.
-		return( 1, "ok" ) 
-			if $c->reading( $source )->has_rank
-				&& $c->reading( $target )->has_rank
-				&& $c->reading( $source )->rank == $c->reading( $target )->rank;
+		# to a path loop for any witness.  If they have the same rank then
+		# they are parallel by definition.
+		# For transpositions, we want the opposite result: it is only valid if
+		# the readings cannot be parallel.
+		my $sourcerank = $c->reading( $source )->has_rank
+			? $c->reading( $source )->rank : undef;
+		my $targetrank = $c->reading( $target )->has_rank
+			? $c->reading( $target )->rank : undef;
+		if( $sourcerank && $targetrank && $sourcerank == $targetrank ) {
+			return( 0, "Cannot transpose readings of same rank" )
+				if $rel eq 'transposition';
+			return( 1, "ok" );
+		}
 		
 		# Otherwise, first make a lookup table of all the
 		# readings related to either the source or the target.
 		my @proposed_related = ( $source, $target );
 		# Drop the collation links of source and target, unless we want to
 		# add a collation relationship.
+		my @dropped;
 		foreach my $r ( ( $source, $target ) ) {
-			$self->_drop_collations( $r ) unless $rel eq 'collated';
+			push( @dropped, $self->_drop_collations( $r ) )
+				unless $rel eq 'collated';
 			push( @proposed_related, $self->related_readings( $r, 'colocated' ) );
 		}
+		# Also drop any collation links at intermediate ranks.
+		foreach my $rank ( $sourcerank+1 .. $targetrank-1 ) {
+			map { push( @dropped, $self->_drop_collations( $_ ) ) }
+				$c->readings_at_rank( $rank );
+		}
 		my %pr_ids;
 		map { $pr_ids{ $_ } = 1 } @proposed_related;
 	
@@ -415,12 +443,22 @@ sub relationship_valid {
 			map { $all_succ{$_} = 1 } $c->sequence->all_successors( $pr );
 		}
 		foreach my $k ( keys %all_pred ) {
-			return( 0, "Relationship would create witness loop" )
-				if exists $all_succ{$k};
+			if( exists $all_succ{$k} ) {
+				$self->_restore_collations( @dropped );
+				return( 1, "ok" ) if $rel eq 'transposition';
+				return( 0, "Relationship would create witness loop" );
+			}
 		}
 		foreach my $k ( keys %pr_ids ) {
-			return( 0, "Relationship would create witness loop" )
-				if exists $all_pred{$k} || exists $all_succ{$k};
+			if( exists $all_pred{$k} || exists $all_succ{$k} ) {
+				$self->_restore_collations( @dropped );
+				return( 1, "ok" ) if $rel eq 'transposition';
+				return( 0, "Relationship would create witness loop" );
+			}
+		}
+		if( $rel eq 'transposition' ) {
+			$self->_restore_collations( @dropped );
+			return ( 0, "Cannot transpose parallel readings" );
 		}
 		return ( 1, "ok" );
 	}
@@ -428,9 +466,23 @@ sub relationship_valid {
 
 sub _drop_collations {
 	my( $self, $reading ) = @_;
+	my @deleted;
 	foreach my $n ( $self->graph->neighbors( $reading ) ) {
 		if( $self->get_relationship( $reading, $n )->type eq 'collated' ) {
 			$self->del_relationship( $reading, $n );
+			push( @deleted, [ $reading, $n ] );
+		}
+	}
+	return @deleted;
+}
+
+sub _restore_collations {
+	my( $self, @vectors ) = @_;
+	foreach my $v ( @vectors ) {
+		try {
+			$self->add_relationship( @$v, { 'type' => 'collated' } );
+		} catch ( Text::Tradition::Error $e ) {
+			warn "Could not restore collation " . join( ' -> ', @$v );
 		}
 	}
 }
@@ -493,6 +545,8 @@ stops tracking the to-be-deleted reading.
 
 sub merge_readings {
 	my( $self, $kept, $deleted, $combined ) = @_;
+	# Delete any relationship between kept and deleted
+	$self->del_relationship( $kept, $deleted );
 	foreach my $edge ( $self->graph->edges_at( $deleted ) ) {
 		# Get the pair of kept / rel
 		my @vector = ( $kept );