From: Tara L Andrews <tla@mit.edu>
Date: Sun, 30 Sep 2012 05:31:02 +0000 (+0200)
Subject: tested on all existing traditions, fixed bugs that arose
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=52179f613976c0be48b7c44a5601028948c71b20;p=scpubgit%2Fstemmatology.git
tested on all existing traditions, fixed bugs that arose
---
diff --git a/base/lib/Text/Tradition/Collation/RelationshipStore.pm b/base/lib/Text/Tradition/Collation/RelationshipStore.pm
index 31c0716..424cddf 100644
--- a/base/lib/Text/Tradition/Collation/RelationshipStore.pm
+++ b/base/lib/Text/Tradition/Collation/RelationshipStore.pm
@@ -504,7 +504,31 @@ foreach my $rdg ( qw/ r13.3 r13.5 / ) {
}
}
-# Test 5.4: add a parallel but not sibling relationship
+# Test 5.4: delete a spelling relationship, add it again, make sure it doesn't
+# throw and make sure all the relationships are the same
+my $numrel = scalar $c5->relationships;
+$c5->del_relationship( 'r13.4', 'r13.2' );
+try {
+ $c5->add_relationship( 'r13.4', 'r13.2', { type => 'spelling', propagate => 1 } );
+ ok( 1, "Managed not to throw an exception re-adding the relationship" );
+} catch( Text::Tradition::Error $e ) {
+ ok( 0, "Threw an exception trying to re-add our intermediate relationship: " . $e->message );
+}
+is( $numrel, scalar $c5->relationships, "Number of relationships did not change" );
+foreach my $rdg ( qw/ r13.2 r13.3 r13.5 / ) {
+ my $newspel = $c5->get_relationship( 'r13.4', $rdg );
+ ok( $newspel, 'Relationship was made between indirectly linked readings' );
+ if( $newspel ) {
+ is( $newspel->type, 'spelling', 'Reinstated intermediate-in relationship has the correct type' );
+ }
+}
+my $stillgram = $c5->get_relationship( 'r13.4', 'r13.1' );
+ok( $stillgram, 'Relationship was made between indirectly linked readings' );
+if( $stillgram ) {
+ is( $stillgram->type, 'grammatical', 'Reinstated intermediate-out relationship has the correct type' );
+}
+
+# Test 5.5: add a parallel but not sibling relationship
$c5->add_relationship( 'r13.6', 'r13.2', { type => 'lexical', propagate => 1 } );
ok( !$c5->get_relationship( 'r13.6', 'r13.1' ),
"Lexical relationship did not affect grammatical" );
@@ -516,8 +540,8 @@ foreach my $rdg ( qw/ r13.3 r13.4 r13.5 / ) {
}
}
-# Test 5.5: try it with non-colocated relationships
-my $numrel = scalar $c5->relationships;
+# Test 5.6: try it with non-colocated relationships
+$numrel = scalar $c5->relationships;
$c5->add_relationship( 'r62.1', 'r64.1', { type => 'transposition', propagate => 1 } );
is( scalar $c5->relationships, $numrel+1,
"Adding non-colo relationship did not propagate" );
@@ -533,6 +557,7 @@ 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.
=end testing
@@ -941,12 +966,21 @@ sub propagate_relationship {
my $r = shift @samelevel;
foreach my $nr ( @samelevel ) {
my $existing = $self->get_relationship( $r, $nr );
+ my $skip;
if( $existing ) {
- # Check that it's a matching type
- throw( "Conflicting existing relationship at $r, $nr trying to propagate "
- . $relobj->type . " relationship at @$rel" )
- unless $existing->type eq $relobj->type;
- } else {
+ my $extype = $self->type( $existing->type );
+ unless( $extype->is_weak ) {
+ # Check that it's a matching type, or a type subsumed by our
+ # bindlevel
+ throw( "Conflicting existing relationship of type "
+ . $existing->type . " at $r, $nr trying to propagate "
+ . $relobj->type . " relationship at @$rel" )
+ unless $existing->type eq $relobj->type
+ || $extype->bindlevel <= $reltype->bindlevel;
+ $skip = 1;
+ }
+ }
+ unless( $skip ) {
# Try to add a new relationship here
try {
my @new = $self->add_relationship( $r, $nr, { type => $relobj->type,
@@ -982,19 +1016,29 @@ sub propagate_relationship {
my( $nr, $nrtype ) = @$_;
foreach my $sib ( keys %thislevel ) {
next if $sib eq $r;
+ next if $sib eq $nr; # can happen if linked to $r by tightrel
+ # but linked to a sib of $r by thisrel
+ # e.g. when a rel has been part propagated
my $existing = $self->get_relationship( $sib, $nr );
+ my $skip;
if( $existing ) {
# Check that it's compatible. The existing relationship type
- # should match the looser of the two relationships in play,
- # whether the original relationship being worked on or the
- # relationship between $r and $or.
- if( $nrtype ne $existing->type ) {
- throw( "Conflicting existing relationship at $nr ( -> "
- . $self->get_relationship( $nr, $r )->type . " to $r) "
- . " -- $sib trying to propagate " . $relobj->type
- . " relationship at @$rel" );
+ # should match or be subsumed by the looser of the two
+ # relationships in play, whether the original relationship
+ # being worked on or the relationship between $r and $or.
+ my $extype = $self->type( $existing->type );
+ unless( $extype->is_weak ) {
+ if( $nrtype ne $extype->name
+ && $self->type( $nrtype )->bindlevel <= $extype->bindlevel ) {
+ throw( "Conflicting existing relationship at $nr ( -> "
+ . $self->get_relationship( $nr, $r )->type . " to $r) "
+ . " -- $sib trying to propagate " . $relobj->type
+ . " relationship at @$rel" );
+ }
+ $skip = 1;
}
- } else {
+ }
+ unless( $skip ) {
# Try to add a new relationship here
try {
my @new = $self->add_relationship( $sib, $nr, { type => $nrtype,
@@ -1013,6 +1057,37 @@ sub propagate_relationship {
return @newly_set;
}
+=head2 propagate_all_relationships
+
+Apply propagation logic retroactively to all relationships in the tradition.
+
+=cut
+
+sub propagate_all_relationships {
+ my $self = shift;
+ my @allrels = sort { $self->_propagate_rel_order( $a, $b ) } $self->relationships;
+ foreach my $rel ( @allrels ) {
+ my $relobj = $self->get_relationship( $rel );
+ if( $self->type( $relobj->type )->is_transitive ) {
+ my @added = $self->propagate_relationship( $rel );
+ }
+ }
+}
+
+# Helper sorting function for retroactive propagation order.
+sub _propagate_rel_order {
+ my( $self, $a, $b ) = @_;
+ my $aobj = $self->get_relationship( $a );
+ my $bobj = $self->get_relationship( $b );
+ my $at = $self->type( $aobj->type ); my $bt = $self->type( $bobj->type );
+ # Apply strong relationships before weak
+ return -1 if $bt->is_weak && !$at->is_weak;
+ return 1 if $at->is_weak && !$bt->is_weak;
+ # Apply more tightly bound relationships first
+ return $at->bindlevel <=> $bt->bindlevel;
+}
+
+
=head2 merge_readings( $kept, $deleted );
Makes a best-effort merge of the relationship links between the given readings, and
diff --git a/base/t/text_tradition_collation_relationshipstore.t b/base/t/text_tradition_collation_relationshipstore.t
index c78d343..6baaccd 100644
--- a/base/t/text_tradition_collation_relationshipstore.t
+++ b/base/t/text_tradition_collation_relationshipstore.t
@@ -234,7 +234,31 @@ foreach my $rdg ( qw/ r13.3 r13.5 / ) {
}
}
-# Test 5.4: add a parallel but not sibling relationship
+# Test 5.4: delete a spelling relationship, add it again, make sure it doesn't
+# throw and make sure all the relationships are the same
+my $numrel = scalar $c5->relationships;
+$c5->del_relationship( 'r13.4', 'r13.2' );
+try {
+ $c5->add_relationship( 'r13.4', 'r13.2', { type => 'spelling', propagate => 1 } );
+ ok( 1, "Managed not to throw an exception re-adding the relationship" );
+} catch( Text::Tradition::Error $e ) {
+ ok( 0, "Threw an exception trying to re-add our intermediate relationship: " . $e->message );
+}
+is( $numrel, scalar $c5->relationships, "Number of relationships did not change" );
+foreach my $rdg ( qw/ r13.2 r13.3 r13.5 / ) {
+ my $newspel = $c5->get_relationship( 'r13.4', $rdg );
+ ok( $newspel, 'Relationship was made between indirectly linked readings' );
+ if( $newspel ) {
+ is( $newspel->type, 'spelling', 'Reinstated intermediate-in relationship has the correct type' );
+ }
+}
+my $stillgram = $c5->get_relationship( 'r13.4', 'r13.1' );
+ok( $stillgram, 'Relationship was made between indirectly linked readings' );
+if( $stillgram ) {
+ is( $stillgram->type, 'grammatical', 'Reinstated intermediate-out relationship has the correct type' );
+}
+
+# Test 5.5: add a parallel but not sibling relationship
$c5->add_relationship( 'r13.6', 'r13.2', { type => 'lexical', propagate => 1 } );
ok( !$c5->get_relationship( 'r13.6', 'r13.1' ),
"Lexical relationship did not affect grammatical" );
@@ -246,8 +270,8 @@ foreach my $rdg ( qw/ r13.3 r13.4 r13.5 / ) {
}
}
-# Test 5.5: try it with non-colocated relationships
-my $numrel = scalar $c5->relationships;
+# Test 5.6: try it with non-colocated relationships
+$numrel = scalar $c5->relationships;
$c5->add_relationship( 'r62.1', 'r64.1', { type => 'transposition', propagate => 1 } );
is( scalar $c5->relationships, $numrel+1,
"Adding non-colo relationship did not propagate" );