X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=base%2Flib%2FText%2FTradition%2FCollation%2FRelationshipStore.pm;h=8610f9b5095ec9e6f7a253030ddd0443d028d245;hb=7bdce750483cb2491f21da638ed68d1ce726b325;hp=195eb09151485f015c7badf9248db47d37beabb6;hpb=c96efd0bcf680011583fb0b474130ffdc5245bf1;p=scpubgit%2Fstemmatology.git

diff --git a/base/lib/Text/Tradition/Collation/RelationshipStore.pm b/base/lib/Text/Tradition/Collation/RelationshipStore.pm
index 195eb09..8610f9b 100644
--- a/base/lib/Text/Tradition/Collation/RelationshipStore.pm
+++ b/base/lib/Text/Tradition/Collation/RelationshipStore.pm
@@ -48,10 +48,16 @@ my @v2 = $c->add_relationship( 'n24', 'n23',
 is( scalar @v2, 2, "Added a global relationship with two instances" );
 @v1 = $c->del_relationship( 'n22', 'n21' );
 is( scalar @v1, 1, "Deleted first relationship" );
-@v2 = $c->del_relationship( 'n12', 'n13' );
+@v2 = $c->del_relationship( 'n12', 'n13', 1 );
 is( scalar @v2, 2, "Deleted second global relationship" );
 my @v3 = $c->del_relationship( 'n1', 'n2' );
 is( scalar @v3, 0, "Nothing deleted on non-existent relationship" );
+my @v4 = $c->add_relationship( 'n24', 'n23', 
+    { 'type' => 'spelling', 'scope' => 'global' } );
+is( @v4, 2, "Re-added global relationship" );
+@v4 = $c->del_relationship( 'n12', 'n13' );
+is( @v4, 1, "Only specified relationship deleted this time" );
+ok( $c->get_relationship( 'n24', 'n23' ), "Other globally-added relationship exists" );
 
 =end testing
 
@@ -82,8 +88,9 @@ has 'relationship_types' => (
 	handles => {
 		has_type => 'exists',
 		add_type => 'set',
+		del_type => 'delete',
 		type     => 'get',
-		del_type => 'delete'
+		types    => 'values'
 		},
 	);
 
@@ -147,16 +154,26 @@ sub BUILD {
 	my $self = shift;
 	
 	my @DEFAULT_TYPES = (
-		{ name => 'collated', bindlevel => 50, is_weak => 1, is_transitive => 0, is_generalizable => 0 },
-		{ name => 'orthographic', bindlevel => 0, use_regular => 0 },
-		{ name => 'spelling', bindlevel => 1 },
-		{ name => 'punctuation', bindlevel => 2 },
-		{ name => 'grammatical', bindlevel => 2 },
-		{ name => 'lexical', bindlevel => 2 },
-		{ name => 'uncertain', bindlevel => 50, is_transitive => 0, is_generalizable => 0 },
-		{ name => 'other', bindlevel => 50, is_transitive => 0, is_generalizable => 0 },
-		{ name => 'transposition', bindlevel => 50, is_colocation => 0 },
-		{ name => 'repetition', bindlevel => 50, is_colocation => 0, is_transitive => 0 }
+		{ name => 'collated', bindlevel => 50, is_weak => 1, is_transitive => 0, 
+			is_generalizable => 0, description => 'Internal use only' },
+		{ name => 'orthographic', bindlevel => 0, use_regular => 0,
+			description => 'These are the same reading, neither unusually spelled.' },
+		{ name => 'punctuation', bindlevel => 0,
+			description => 'These are the same reading apart from punctuation.' },
+		{ name => 'spelling', bindlevel => 1,
+			description => 'These are the same reading, spelled differently.' },
+		{ name => 'grammatical', bindlevel => 2,
+			description => 'These readings share a root (lemma), but have different parts of speech (morphologies).' },
+		{ name => 'lexical', bindlevel => 2,
+			description => 'These readings share a part of speech (morphology), but have different roots (lemmata).' },
+		{ name => 'uncertain', bindlevel => 0, is_transitive => 0, is_generalizable => 0,
+			use_regular => 0, description => 'These readings are related, but a clear category cannot be assigned.' },
+		{ name => 'other', bindlevel => 0, is_transitive => 0, is_generalizable => 0,
+			description => 'These readings are related in a way not covered by the existing types.' },
+		{ name => 'transposition', bindlevel => 50, is_colocation => 0,
+			description => 'This is the same (or nearly the same) reading in a different location.' },
+		{ name => 'repetition', bindlevel => 50, is_colocation => 0, is_transitive => 0,
+			description => 'This is a reading that was repeated in one or more witnesses.' }
 		);
 	
 	foreach my $type ( @DEFAULT_TYPES ) {
@@ -210,7 +227,7 @@ sub get_relationship {
 		my $edge = shift;
 		@vector = @$edge;
 	} else {
-		@vector = @_;
+		@vector = @_[0,1];
 	}
 	my $relationship;
 	if( $self->graph->has_edge_attribute( @vector, 'object' ) ) {
@@ -463,6 +480,15 @@ is( $c4->reading('r463.2')->rank, $c4->reading('r463.4')->rank,
 # Test group 5: relationship transitivity.
 my $t5 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/john.xml' );
 my $c5 = $t5->collation;
+# Test 5.0: propagate all existing transitive rels and make sure it succeeds
+my $orignumrels = scalar $c5->relationships();
+try {
+	$c5->relations->propagate_all_relationships();
+	ok( 1, "Propagated all existing transitive relationships" );
+} catch ( Text::Tradition::Error $err ) {
+	ok( 0, "Failed to propagate all existing relationships: " . $err->message );
+}
+ok( scalar( $c5->relationships ) > $orignumrels, "Added some relationships in propagation" );
 
 # Test 5.1: make a grammatical link to an orthographically-linked reading
 $c5->add_relationship( 'r13.5', 'r13.2', { type => 'orthographic' } );
@@ -557,11 +583,52 @@ if( $newtrans ) {
 is( scalar $c5->relationships, $numrel+4, 
 	"Adding non-colo relationship only propagated on non-colos" );
 
-# TODO test that attempts to cross boundaries on bindlevel-equal relationships fail.
+# Test 5.7: ensure that attempts to cross boundaries on bindlevel-equal 
+# relationships fail.
+try {
+	$c5->add_relationship( 'r39.6', 'r41.1', { type => 'grammatical', propagate => 1 } );
+	ok( 0, "Did not prevent add of conflicting relationship level" );
+} catch( Text::Tradition::Error $err ) {
+	like( $err->message, qr/Conflicting existing relationship/, "Got correct error message trying to add conflicting relationship level" );
+}
 
-# TODO test that weak relationships don't interfere
+# Test 5.8: ensure that weak relationships don't interfere
+$c5->add_relationship( 'r50.1', 'r50.2', { type => 'collated' } );
+$c5->add_relationship( 'r50.3', 'r50.4', { type => 'orthographic' } );
+try {
+	$c5->add_relationship( 'r50.4', 'r50.1', { type => 'grammatical', propagate => 1 } );
+	ok( 1, "Collation did not interfere with new relationship add" );
+} catch( Text::Tradition::Error $err ) {
+	ok( 0, "Collation interfered with new relationship add: " . $err->message );
+}
+my $crel = $c5->get_relationship( 'r50.1', 'r50.2' );
+ok( $crel, "Original relationship still exists" );
+if( $crel ) {
+	is( $crel->type, 'collated', "Original relationship still a collation" );
+}
 
-# TODO test that strong non-transitive relationships don't interfere
+try {
+	$c5->add_relationship( 'r50.1', 'r51.1', { type => 'spelling', propagate => 1 } );
+	ok( 1, "Collation did not interfere with relationship re-ranking" );
+} catch( Text::Tradition::Error $err ) {
+	ok( 0, "Collation interfered with relationship re-ranking: " . $err->message );
+}
+$crel = $c5->get_relationship( 'r50.1', 'r50.2' );
+ok( !$crel, "Collation relationship now gone" );
+
+# Test 5.9: ensure that strong non-transitive relationships don't interfere
+$c5->add_relationship( 'r66.1', 'r66.4', { type => 'grammatical' } );
+$c5->add_relationship( 'r66.2', 'r66.4', { type => 'uncertain', propagate => 1 } );
+try {
+	$c5->add_relationship( 'r66.1', 'r66.3', { type => 'grammatical', propagate => 1 } );
+	ok( 1, "Non-transitive relationship did not block grammatical add" );
+} catch( Text::Tradition::Error $err ) {
+	ok( 0, "Non-transitive relationship blocked grammatical add: " . $err->message );
+}
+is( scalar $c5->related_readings( 'r66.4' ), 3, "Reading 66.4 has all its links" );
+is( scalar $c5->related_readings( 'r66.2' ), 1, "Reading 66.2 has only one link" );
+is( scalar $c5->related_readings( 'r66.1' ), 2, "Reading 66.1 has all its links" );
+is( scalar $c5->related_readings( 'r66.3' ), 2, "Reading 66.3 has all its links" );
 
 =end testing
 
@@ -659,7 +726,6 @@ sub add_relationship {
 	# Find all the pairs for which we need to set the relationship.
     if( $relationship->colocated && $relationship->nonlocal && !$thispaironly ) {
     	my @global_set = $self->add_global_relationship( $relationship );
-    	map { push( @$_, $relationship->type ) } @global_set;
 		push( @pairs_set, @global_set );
     }
     if( $propagate ) {
@@ -761,22 +827,23 @@ sub _find_applicable {
 	return @vectors;
 }
 
-=head2 del_relationship( $source, $target )
+=head2 del_relationship( $source, $target, $allscope )
 
 Removes the relationship between the given readings. If the relationship is
-non-local, removes the relationship everywhere in the graph.
+non-local and $allscope is true, removes the relationship throughout the 
+relevant scope.
 
 =cut
 
 sub del_relationship {
-	my( $self, $source, $target ) = @_;
+	my( $self, $source, $target, $allscope ) = @_;
 	my $rel = $self->get_relationship( $source, $target );
 	return () unless $rel; # Nothing to delete; return an empty set.
 	my $reltype = $self->type( $rel->type );
 	my $colo = $rel->colocated;
 	my @vectors = ( [ $source, $target ] );
 	$self->_remove_relationship( $colo, $source, $target );
-	if( $rel->nonlocal ) {
+	if( $rel->nonlocal && $allscope ) {
 		# Remove the relationship wherever it occurs.
 		my @rel_edges = grep { $self->get_relationship( @$_ ) eq $rel }
 			$self->relationships;
@@ -887,6 +954,26 @@ sub _restore_weak {
 	}
 }
 
+=head2 verify_or_delete( $reading1, $reading2 ) {
+
+Given the existing relationship at ( $reading1, $reading2 ), make sure it is
+still valid. If it is not still valid, delete it. Use this only to check
+non-colocated relationships!
+
+=cut
+
+sub verify_or_delete {
+	my( $self, @vector ) = @_;
+	my $rel = $self->get_relationship( @vector );
+	throw( "You should not now be verifying colocated relationships!" )
+		if $rel->colocated;
+	my( $ok, $reason ) = $self->relationship_valid( @vector, $rel->type );
+	unless( $ok ) {
+		$self->del_relationship( @vector );
+	}
+}
+	
+
 =head2 related_readings( $reading, $filter )
 
 Returns a list of readings that are connected via direct relationship links
@@ -1207,6 +1294,10 @@ the graph would still be valid.
 
 =cut
 
+# TODO Used the 'is_reachable' method; it killed performance. Think about doing away
+# with the equivalence graph in favor of a transitive closure graph (calculated ONCE)
+# on the sequence graph, and test that way.
+
 sub test_equivalence {
 	my( $self, $source, $target ) = @_;
 	# Try merging the nodes in the equivalence graph; return a true value if