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
handles => {
has_type => 'exists',
add_type => 'set',
+ del_type => 'delete',
type => 'get',
- del_type => 'delete'
+ types => 'values'
},
);
sub BUILD {
my $self = shift;
- my $regularize = sub {
- return $_[0]->can('regularize') ? $_[0]->regularize : $_[0]->text; };
-
my @DEFAULT_TYPES = (
- { name => 'collated', bindlevel => 50, is_weak => 1, is_transitive => 0, is_generalizable => 0 },
- { name => 'orthographic', bindlevel => 0 },
- { name => 'spelling', bindlevel => 1, record_sub => $regularize },
- { name => 'punctuation', bindlevel => 2, record_sub => $regularize },
- { name => 'grammatical', bindlevel => 2, record_sub => $regularize },
- { name => 'lexical', bindlevel => 2, record_sub => $regularize },
- { name => 'transposition', bindlevel => 50, is_colocation => 0, is_transitive => 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 ) {
}
}
-sub _regular_form {
-}
-
around add_type => sub {
my $orig = shift;
my $self = shift;
my $edge = shift;
@vector = @$edge;
} else {
- @vector = @_;
+ @vector = @_[0,1];
}
my $relationship;
if( $self->graph->has_edge_attribute( @vector, 'object' ) ) {
$rel = Text::Tradition::Collation::Relationship->new( $options );
my $reltype = $self->type( $rel->type );
+ throw( "Unrecognized relationship type " . $rel->type ) unless $reltype;
# Validate the options given against the relationship type wanted
throw( "Cannot set nonlocal scope on relationship of type " . $reltype->name )
if $rel->nonlocal && !$reltype->is_generalizable;
ok( 0, "Failed to add normal transposition complement: " . $e->message );
}
+# Test 4: make a global relationship that involves re-ranking a node first, when
+# the prior rank has a potential match too
+my $t4 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/globalrel_test.xml' );
+my $c4 = $t4->collation;
+# Can we even add the relationship?
+try {
+ $c4->add_relationship( 'r463.2', 'r463.4',
+ { type => 'orthographic', scope => 'global' } );
+ ok( 1, "Added global relationship without error" );
+} catch ( Text::Tradition::Error $e ) {
+ ok( 0, "Failed to add global relationship when same-rank alternative exists: "
+ . $e->message );
+}
+$c4->calculate_ranks();
+# Do our readings now share a rank?
+is( $c4->reading('r463.2')->rank, $c4->reading('r463.4')->rank,
+ "Expected readings now at same 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' } );
+$c5->add_relationship( 'r13.1', 'r13.2', { type => 'grammatical', propagate => 1 } );
+my $impliedrel = $c5->get_relationship( 'r13.1', 'r13.5' );
+ok( $impliedrel, 'Relationship was made between indirectly linked readings' );
+if( $impliedrel ) {
+ is( $impliedrel->type, 'grammatical', 'Implicit inbound relationship has the correct type' );
+}
+
+# Test 5.2: make another orthographic link, see if the grammatical one propagates
+$c5->add_relationship( 'r13.3', 'r13.5', { type => 'orthographic', propagate => 1 } );
+foreach my $rdg ( qw/ r13.3 r13.5 / ) {
+ my $newgram = $c5->get_relationship( 'r13.1', $rdg );
+ ok( $newgram, 'Relationship was propagaged up between indirectly linked readings' );
+ if( $newgram ) {
+ is( $newgram->type, 'grammatical', 'Implicit outbound relationship has the correct type' );
+ }
+}
+my $neworth = $c5->get_relationship( 'r13.2', 'r13.3' );
+ok( $neworth, 'Relationship was made between indirectly linked siblings' );
+if( $neworth ) {
+ is( $neworth->type, 'orthographic', 'Implicit direct relationship has the correct type' );
+}
+
+# Test 5.3: make an intermediate (spelling) link to the remaining node
+$c5->add_relationship( 'r13.4', 'r13.2', { type => 'spelling', propagate => 1 } );
+# Should be linked grammatically to 12.1, spelling-wise to the rest
+my $newgram = $c5->get_relationship( 'r13.4', 'r13.1' );
+ok( $newgram, 'Relationship was made between indirectly linked readings' );
+if( $newgram ) {
+ is( $newgram->type, 'grammatical', 'Implicit intermediate-out relationship has the correct type' );
+}
+foreach my $rdg ( qw/ 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', 'Implicit intermediate-in relationship has the correct type' );
+ }
+}
+
+# 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" );
+foreach my $rdg ( qw/ r13.3 r13.4 r13.5 / ) {
+ my $newlex = $c5->get_relationship( 'r13.6', $rdg );
+ ok( $newlex, 'Parallel was made between indirectly linked readings' );
+ if( $newlex ) {
+ is( $newlex->type, 'lexical', 'Implicit parallel-down relationship has the correct type' );
+ }
+}
+
+# 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" );
+# Add a pivot point
+$c5->add_relationship( 'r61.1', 'r61.5', { type => 'orthographic' } );
+# Add a third transposed node
+$c5->add_relationship( 'r62.1', 'r60.3', { type => 'transposition', propagate => 1 } );
+my $newtrans = $c5->get_relationship( 'r64.1', 'r60.3' );
+ok( $newtrans, 'Non-colo relationship was made between indirectly linked readings' );
+if( $newtrans ) {
+ is( $newtrans->type, 'transposition', 'Implicit non-colo relationship has the correct type' );
+}
+is( scalar $c5->relationships, $numrel+4,
+ "Adding non-colo relationship only propagated on non-colos" );
+
+# 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" );
+}
+
+# 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" );
+}
+
+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
=cut
if( $sourceobj->is_meta || $targetobj->is_meta );
my $relationship;
my $reltype;
- my $thispaironly;
+ my $thispaironly = delete $options->{thispaironly};
+ my $propagate = delete $options->{propagate};
my $droppedcolls = [];
if( ref( $options ) eq 'Text::Tradition::Collation::Relationship' ) {
$relationship = $options;
$reltype = $self->type( $options->{type} );
# Try to create the relationship object.
- my $rdga = $reltype->record_sub->( $sourceobj );
- my $rdgb = $reltype->record_sub->( $targetobj );
+ my $rdga = $reltype->regularize( $sourceobj );
+ my $rdgb = $reltype->regularize( $targetobj );
$options->{'orig_a'} = $sourceobj;
$options->{'orig_b'} = $targetobj;
$options->{'reading_a'} = $rdga;
}
}
$self->_set_relationship( $relationship, $source, $target ) unless $skip;
- push( @pairs_set, [ $source, $target ] );
+ push( @pairs_set, [ $source, $target, $relationship->type ] );
# Find all the pairs for which we need to set the relationship.
if( $relationship->colocated && $relationship->nonlocal && !$thispaironly ) {
- push( @pairs_set, $self->add_global_relationship( $relationship ) );
+ my @global_set = $self->add_global_relationship( $relationship );
+ push( @pairs_set, @global_set );
}
+ if( $propagate ) {
+ my @prop;
+ foreach my $ps ( @pairs_set ) {
+ my @extra = $self->propagate_relationship( $ps->[0], $ps->[1] );
+ push( @prop, @extra );
+ }
+ push( @pairs_set, @prop ) if @prop;
+ }
+
# Finally, restore whatever collations we can, and return.
$self->_restore_weak( @$droppedcolls );
return @pairs_set;
} catch {
my $reldesc = sprintf( "%s %s -> %s", $relationship->type,
$relationship->reading_a, $relationship->reading_b );
- print STDERR "Global relationship $reldesc not applicable at @$v\n";
+ # print STDERR "Global relationship $reldesc not applicable at @$v\n";
}
push( @pairs_set, @added ) if @added;
}
my $reltype = $self->type( $rel->type );
my @vectors;
my @identical_readings;
- @identical_readings = grep { $reltype->record_sub->( $_ ) eq $rel->reading_a }
+ @identical_readings = grep { $reltype->regularize( $_ ) eq $rel->reading_a }
$c->readings;
foreach my $ir ( @identical_readings ) {
my @itarget;
- @itarget = grep { $reltype->record_sub->( $_ ) eq $rel->reading_b }
+ @itarget = grep { $reltype->regularize( $_ ) eq $rel->reading_b }
$c->readings_at_rank( $ir->rank );
if( @itarget ) {
# Warn if there is more than one hit with no closer link between them.
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;
my $reltype = $self->type( $rel );
## Assume validity is okay if we are initializing from scratch.
return ( 1, "initializing" ) unless $c->tradition->_initialized;
- ## TODO Move this block to relationship type definition
+ ## TODO Move this block to relationship type definition when we can save
+ ## coderefs
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.
}
}
-=head2 filter_collations()
+=head2 verify_or_delete( $reading1, $reading2 ) {
-Utility function. Removes any redundant weak relationships from the graph.
-A weak relationship is redundant if the readings in question would occupy
-the same rank regardless of the existence of the relationship.
+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
-#TODO change name
-sub filter_collations {
- my $self = shift;
- my $c = $self->collation;
- foreach my $r ( 1 .. $c->end->rank - 1 ) {
- my $anchor;
- my @need_weak;
- foreach my $rdg ( $c->readings_at_rank( $r ) ) {
- next if $rdg->is_meta;
- my $ip = 0;
- foreach my $pred ( $rdg->predecessors ) {
- if( $pred->rank == $r - 1 ) {
- $ip = 1;
- $anchor = $rdg unless( $anchor );
- last;
- }
- }
- push( @need_weak, $rdg ) unless $ip;
- $self->_drop_weak( $rdg->id );
- }
- $anchor
- # TODO FIX HACK of adding explicit collation type
- ? map { $c->add_relationship( $anchor, $_, { 'type' => 'collated' } )
- unless $c->get_relationship( $anchor, $_ ) } @need_weak
- : print STDERR "No anchor found at $r\n";
+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 relationship links to $reading.
-If $filter is set to a subroutine ref, returns only those related readings where
-$filter( $relationship ) returns a true value.
+Returns a list of readings that are connected via direct relationship links
+to $reading. If $filter is set to a subroutine ref, returns only those
+related readings where $filter( $relationship ) returns a true value.
=cut
my $type = $filter;
$filter = sub { $_[0]->type eq $type };
}
- my %found = ( $reading => 1 );
- my $check = [ $reading ];
- my $iter = 0;
- while( @$check ) {
- my $more = [];
- foreach my $r ( @$check ) {
- foreach my $nr ( $self->graph->neighbors( $r ) ) {
- if( &$filter( $self->get_relationship( $r, $nr ) ) ) {
- push( @$more, $nr ) unless exists $found{$nr};
- $found{$nr} = 1;
- }
- }
- }
- $check = $more;
- }
- delete $found{$reading};
- @answer = keys %found;
+ @answer = grep { &$filter( $self->get_relationship( $reading, $_ ) ) }
+ $self->graph->neighbors( $reading );
} else {
- @answer = $self->graph->all_reachable( $reading );
+ @answer = $self->graph->neighbors( $reading );
}
if( $return_object ) {
my $c = $self->collation;
}
}
+=head2 propagate_relationship( $rel )
+
+Apply the transitivity and binding level rules to propagate the consequences of
+the specified relationship link, ensuring all consequent relationships exist.
+For now, we only propagate colocation links if we are passed a colocation, and
+we only propagate displacement links if we are given a displacement.
+
+Returns an array of tuples ( rdg1, rdg2, type ) for each new reading set.
+
+=cut
+
+sub propagate_relationship {
+ my( $self, @rel ) = @_;
+ ## Check that the vector is an arrayref
+ my $rel = @rel > 1 ? \@rel : $rel[0];
+ ## Get the relationship info
+ my $relobj = $self->get_relationship( $rel );
+ my $reltype = $self->type( $relobj->type );
+ return () unless $reltype->is_transitive;
+ my @newly_set;
+
+ my $colo = $reltype->is_colocation;
+ my $bindlevel = $reltype->bindlevel;
+
+ ## Find all readings that are linked via this relationship type
+ my %thislevel = ( $rel->[0] => 1, $rel->[1] => 1 );
+ my $check = $rel;
+ my $iter = 0;
+ while( @$check ) {
+ my $more = [];
+ foreach my $r ( @$check ) {
+ push( @$more, grep { !exists $thislevel{$_}
+ && $self->get_relationship( $r, $_ )
+ && $self->get_relationship( $r, $_ )->type eq $relobj->type }
+ $self->graph->neighbors( $r ) );
+ }
+ map { $thislevel{$_} = 1 } @$more;
+ $check = $more;
+ }
+
+ ## Make sure every reading of our relationship type is linked to every other
+ my @samelevel = keys %thislevel;
+ while( @samelevel ) {
+ my $r = shift @samelevel;
+ foreach my $nr ( @samelevel ) {
+ my $existing = $self->get_relationship( $r, $nr );
+ my $skip;
+ if( $existing ) {
+ 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,
+ annotation => "Propagated from relationship at @$rel" } );
+ push( @newly_set, @new );
+ } catch ( Text::Tradition::Error $e ) {
+ throw( "Could not propagate " . $relobj->type .
+ " relationship (original @$rel) at $r -- $nr: " .
+ $e->message );
+ }
+ }
+ }
+
+ ## Now for each sibling our set, look for its direct connections to
+ ## transitive readings of a different bindlevel, and make sure that
+ ## all siblings are related to those readings.
+ my @other;
+ foreach my $n ( $self->graph->neighbors( $r ) ) {
+ my $crel = $self->get_relationship( $r, $n );
+ next unless $crel;
+ my $crt = $self->type( $crel->type );
+ if( $crt->is_transitive && $crt->is_colocation == $colo ) {
+ next if $crt->bindlevel == $reltype->bindlevel;
+ my $nrel = $crt->bindlevel < $reltype->bindlevel
+ ? $reltype->name : $crt->name;
+ push( @other, [ $n, $nrel ] );
+ }
+ }
+ # The @other array now contains tuples of ( reading, type ) where the
+ # reading is the non-sibling and the type is the type of relationship
+ # that the siblings should have to the non-sibling.
+ foreach ( @other ) {
+ 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 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;
+ }
+ }
+ unless( $skip ) {
+ # Try to add a new relationship here
+ try {
+ my @new = $self->add_relationship( $sib, $nr, { type => $nrtype,
+ annotation => "Propagated from relationship at @$rel" } );
+ push( @newly_set, @new );
+ } catch ( Text::Tradition::Error $e ) {
+ throw( "Could not propagate $nrtype relationship (original " .
+ $relobj->type . " at @$rel) at $sib -- $nr: " .
+ $e->message );
+ }
+ }
+ }
+ }
+ }
+
+ 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
=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
$self->equivalence_graph->delete_edge( $teq, $succ ) if $added_succ{$succ};
}
unless( $self->equivalence_graph->eq( $checkstr ) ) {
- warn "GRAPH CHANGED after testing";
+ throw( "GRAPH CHANGED after testing" );
}
# Return our answer
return $ret;
$data_el->appendText( $value );
}
+sub dump_segment {
+ my( $self, $from, $to ) = @_;
+ open( DUMP, ">debug.svg" ) or die "Could not open debug.svg";
+ binmode DUMP, ':utf8';
+ print DUMP $self->collation->as_svg({ from => $from, to => $to, nocalc => 1 });
+ close DUMP;
+}
+
sub throw {
Text::Tradition::Error->throw(
'ident' => 'Relationship error',
projects / scpubgit/stemmatology.git / blobdiff