X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FText%2FTradition%2FCollation%2FRelationshipStore.pm;h=dade4b409b29b5799240c87deb97523ee8eb80e2;hb=2f39215b4264117d3319f0f4d3357d3546199cae;hp=2d69b0cc6d98e43c3f1f1294f5ec75c8e0aa2370;hpb=08e481761b6ddd5e474ffaeaf4a79e116ac8674b;p=scpubgit%2Fstemmatology.git

diff --git a/lib/Text/Tradition/Collation/RelationshipStore.pm b/lib/Text/Tradition/Collation/RelationshipStore.pm
index 2d69b0c..dade4b4 100644
--- a/lib/Text/Tradition/Collation/RelationshipStore.pm
+++ b/lib/Text/Tradition/Collation/RelationshipStore.pm
@@ -380,10 +380,7 @@ 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.
-		# 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.
+		# TODO this might be called before witness paths are set...
 		my %seen_wits;
 		map { $seen_wits{$_} = 1 } $c->reading_witnesses( $source );
 		foreach my $w ( $c->reading_witnesses( $target ) ) {
@@ -393,50 +390,25 @@ 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" );
-	} 
-	if( $rel ne 'repetition' ) {
+	} else {
 		# 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
-		# 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" );
-		}
+		# 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;
 		
 		# 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 ) ) {
-			push( @dropped, $self->_drop_collations( $r ) )
-				unless $rel eq 'collated';
+			$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;
 	
@@ -449,22 +421,12 @@ sub relationship_valid {
 			map { $all_succ{$_} = 1 } $c->sequence->all_successors( $pr );
 		}
 		foreach my $k ( keys %all_pred ) {
-			if( exists $all_succ{$k} ) {
-				$self->_restore_collations( @dropped );
-				return( 1, "ok" ) if $rel eq 'transposition';
-				return( 0, "Relationship would create witness loop" );
-			}
+			return( 0, "Relationship would create witness loop" )
+				if exists $all_succ{$k};
 		}
 		foreach my $k ( keys %pr_ids ) {
-			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( 0, "Relationship would create witness loop" )
+				if exists $all_pred{$k} || exists $all_succ{$k};
 		}
 		return ( 1, "ok" );
 	}
@@ -472,23 +434,9 @@ 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 );
 		}
 	}
 }
@@ -551,8 +499,6 @@ 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 );