},
);
+=head2 equivalence_graph()
+
+Returns an equivalence graph of the collation, in which all readings
+related via a 'colocated' relationship are transformed into a single
+vertex. Can be used to determine the validity of a new relationship.
+
+=cut
+
+has 'equivalence_graph' => (
+ is => 'ro',
+ isa => 'Graph',
+ default => sub { Graph->new() },
+ writer => '_reset_equivalence',
+ );
+
+has '_node_equivalences' => (
+ is => 'ro',
+ traits => ['Hash'],
+ handles => {
+ equivalence => 'get',
+ set_equivalence => 'set',
+ remove_equivalence => 'delete',
+ _clear_equivalence => 'clear',
+ },
+ );
+
+has '_equivalence_readings' => (
+ is => 'ro',
+ traits => ['Hash'],
+ handles => {
+ eqreadings => 'get',
+ set_eqreadings => 'set',
+ remove_eqreadings => 'delete',
+ _clear_eqreadings => 'clear',
+ },
+ );
+
+around add_reading => sub {
+ my $orig = shift;
+ my $self = shift;
+
+ $self->equivalence_graph->add_vertex( @_ );
+ $self->set_equivalence( $_[0], $_[0] );
+ $self->set_eqreadings( $_[0], [ $_[0] ] );
+ $self->$orig( @_ );
+};
+
+around delete_reading => sub {
+ my $orig = shift;
+ my $self = shift;
+
+ $self->_remove_equivalence_node( @_ );
+ $self->$orig( @_ );
+};
+
=head2 get_relationship
Return the relationship object, if any, that exists between two readings.
my( $self, $relationship, @vector ) = @_;
$self->graph->add_edge( @vector );
$self->graph->set_edge_attribute( @vector, 'object', $relationship );
+ $self->_make_equivalence( @vector ) if $relationship->colocated;
}
=head2 create
use TryCatch;
my $t1 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/legendfrag.xml' );
-# Test 1: try to equate nodes that are prevented with an intermediate collation
+# Test 1.1: try to equate nodes that are prevented with an intermediate collation
ok( $t1, "Parsed test fragment file" );
my $c1 = $t1->collation;
-my $trel = $c1->get_relationship( '9,2', '9,3' );
+my $trel = $c1->get_relationship( 'r9.2', 'r9.3' );
is( ref( $trel ), 'Text::Tradition::Collation::Relationship',
"Troublesome relationship exists" );
is( $trel->type, 'collated', "Troublesome relationship is a collation" );
# Try to make the link we want
try {
- $c1->add_relationship( '8,6', '10,3', { 'type' => 'orthographic' } );
+ $c1->add_relationship( 'r8.6', 'r10.3', { 'type' => 'orthographic' } );
ok( 1, "Added cross-collation relationship as expected" );
-} catch {
- ok( 0, "Existing collation blocked equivalence relationship" );
+} catch( Text::Tradition::Error $e ) {
+ ok( 0, "Existing collation blocked equivalence relationship: " . $e->message );
}
try {
$c1->calculate_ranks();
ok( 1, "Successfully calculated ranks" );
-} catch {
- ok( 0, "Collation now has a cycle" );
+} catch ( Text::Tradition::Error $e ) {
+ ok( 0, "Collation now has a cycle: " . $e->message );
+}
+
+# Test 1.2: attempt merge of an identical reading
+try {
+ $c1->merge_readings( 'r9.3', 'r11.5' );
+ ok( 1, "Successfully merged reading 'pontifex'" );
+} catch ( Text::Tradition::Error $e ) {
+ ok( 0, "Merge of mergeable readings failed: $e->message" );
+
}
-# Test 2: try to equate nodes that are prevented with a real intermediate
+# Test 1.3: attempt relationship with a meta reading (should fail)
+try {
+ $c1->add_relationship( 'r8.1', 'r9.2', { 'type' => 'collated' } );
+ ok( 0, "Allowed a meta-reading to be used in a relationship" );
+} catch ( Text::Tradition::Error $e ) {
+ is( $e->message, 'Cannot set relationship on a meta reading',
+ "Relationship link prevented for a meta reading" );
+}
+
+# Test 2.1: try to equate nodes that are prevented with a real intermediate
# equivalence
my $t2 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/legendfrag.xml' );
my $c2 = $t2->collation;
-$c2->add_relationship( '9,2', '9,3', { 'type' => 'lexical' } );
-my $trel2 = $c2->get_relationship( '9,2', '9,3' );
+$c2->add_relationship( 'r9.2', 'r9.3', { 'type' => 'lexical' } );
+my $trel2 = $c2->get_relationship( 'r9.2', 'r9.3' );
is( ref( $trel2 ), 'Text::Tradition::Collation::Relationship',
"Created blocking relationship" );
is( $trel2->type, 'lexical', "Blocking relationship is not a collation" );
# This time the link ought to fail
try {
- $c2->add_relationship( '8,6', '10,3', { 'type' => 'orthographic' } );
+ $c2->add_relationship( 'r8.6', 'r10.3', { 'type' => 'orthographic' } );
ok( 0, "Added cross-equivalent bad relationship" );
-} catch {
- ok( 1, "Existing equivalence blocked crossing relationship" );
+} catch ( Text::Tradition::Error $e ) {
+ like( $e->message, qr/witness loop/,
+ "Existing equivalence blocked crossing relationship" );
}
try {
$c2->calculate_ranks();
ok( 1, "Successfully calculated ranks" );
-} catch {
- ok( 0, "Collation now has a cycle" );
+} catch ( Text::Tradition::Error $e ) {
+ ok( 0, "Collation now has a cycle: " . $e->message );
}
-# Test 3: make a straightforward pair of transpositions.
+# Test 3.1: make a straightforward pair of transpositions.
my $t3 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/lf2.xml' );
# Test 1: try to equate nodes that are prevented with an intermediate collation
my $c3 = $t3->collation;
try {
- $c3->add_relationship( '36,4', '38,3', { 'type' => 'transposition' } );
+ $c3->add_relationship( 'r36.4', 'r38.3', { 'type' => 'transposition' } );
ok( 1, "Added straightforward transposition" );
-} catch {
- ok( 0, "Failed to add normal transposition" );
+} catch ( Text::Tradition::Error $e ) {
+ ok( 0, "Failed to add normal transposition: " . $e->message );
}
try {
- $c3->add_relationship( '36,3', '38,2', { 'type' => 'transposition' } );
+ $c3->add_relationship( 'r36.3', 'r38.2', { 'type' => 'transposition' } );
ok( 1, "Added straightforward transposition complement" );
-} catch {
- ok( 0, "Failed to add normal transposition complement" );
+} catch ( Text::Tradition::Error $e ) {
+ ok( 0, "Failed to add normal transposition complement: " . $e->message );
}
-# Test 4: try to make a transposition that could be a parallel.
+# Test 3.2: try to make a transposition that could be a parallel.
try {
- $c3->add_relationship( '28,2', '29,2', { 'type' => 'transposition' } );
+ $c3->add_relationship( 'r28.2', 'r29.2', { 'type' => 'transposition' } );
ok( 0, "Added bad colocated transposition" );
-} catch {
- ok( 1, "Prevented bad colocated transposition" );
+} catch ( Text::Tradition::Error $e ) {
+ like( $e->message, qr/Readings appear to be colocated/,
+ "Prevented bad colocated transposition" );
}
-# Test 5: make the parallel, and then make the transposition again.
+# Test 3.3: make the parallel, and then make the transposition again.
try {
- $c3->add_relationship( '28,3', '29,3', { 'type' => 'orthographic' } );
+ $c3->add_relationship( 'r28.3', 'r29.3', { 'type' => 'orthographic' } );
ok( 1, "Equated identical readings for transposition" );
-} catch {
- ok( 0, "Failed to equate identical readings" );
+} catch ( Text::Tradition::Error $e ) {
+ ok( 0, "Failed to equate identical readings: " . $e->message );
}
try {
- $c3->add_relationship( '28,2', '29,2', { 'type' => 'transposition' } );
+ $c3->add_relationship( 'r28.2', 'r29.2', { 'type' => 'transposition' } );
ok( 1, "Added straightforward transposition complement" );
-} catch {
- ok( 0, "Failed to add normal transposition complement" );
+} catch ( Text::Tradition::Error $e ) {
+ ok( 0, "Failed to add normal transposition complement: " . $e->message );
}
=end testing
sub add_relationship {
my( $self, $source, $target, $options ) = @_;
my $c = $self->collation;
-
+ my $sourceobj = $c->reading( $source );
+ my $targetobj = $c->reading( $target );
+ throw( "Adding self relationship at $source" ) if $source eq $target;
+ throw( "Cannot set relationship on a meta reading" )
+ if( $sourceobj->is_meta || $targetobj->is_meta );
my $relationship;
my $thispaironly;
my $droppedcolls = [];
}
# Try to create the relationship object.
- $options->{'reading_a'} = $c->reading( $source )->text;
- $options->{'reading_b'} = $c->reading( $target )->text;
+ $options->{'reading_a'} = $sourceobj->text;
+ $options->{'reading_b'} = $targetobj->text;
$options->{'orig_a'} = $source;
$options->{'orig_b'} = $target;
if( $options->{'scope'} ne 'local' ) {
my( $self, $source, $target ) = @_;
my $rel = $self->get_relationship( $source, $target );
return () unless $rel; # Nothing to delete; return an empty set.
+ my $colo = $rel->colocated;
my @vectors = ( [ $source, $target ] );
- $self->_remove_relationship( $source, $target );
+ $self->_remove_relationship( $colo, $source, $target );
if( $rel->nonlocal ) {
# Remove the relationship wherever it occurs.
# Remove the relationship wherever it occurs.
my @rel_edges = grep { $self->get_relationship( @$_ ) == $rel }
$self->relationships;
foreach my $re ( @rel_edges ) {
- $self->_remove_relationship( @$re );
+ $self->_remove_relationship( $colo, @$re );
push( @vectors, $re );
}
$self->del_scoped_relationship( $rel->reading_a, $rel->reading_b );
}
sub _remove_relationship {
- my( $self, @vector ) = @_;
+ my( $self, $equiv, @vector ) = @_;
$self->graph->delete_edge( @vector );
+ $self->_break_equivalence( @vector ) if $equiv;
}
=head2 relationship_valid( $source, $target, $type )
# We also need to check both that the readings occur in distinct
# witnesses, and that they are not in the same place. That is,
# proposing to link them should cause a witness loop.
- my $map = {};
- my( $startrank, $endrank );
- if( $c->end->has_rank ) {
- my $cpred = $c->common_predecessor( $source, $target );
- my $csucc = $c->common_successor( $source, $target );
- $startrank = $cpred->rank;
- $endrank = $csucc->rank;
- }
- my $eqgraph = $c->equivalence_graph( $map, $startrank, $endrank,
- $source, $target );
- if( $eqgraph->has_a_cycle ) {
- return ( 1, "ok" );
- } else {
+ if( $self->test_equivalence( $source, $target ) ) {
return ( 0, "Readings appear to be colocated, not transposed" );
+ } else {
+ return ( 1, "ok" );
}
} elsif( $rel ne 'repetition' ) {
unless( $rel eq 'collated' || $sourcerank == $targetrank ) {
push( @$mustdrop, $self->_drop_collations( $source ) );
push( @$mustdrop, $self->_drop_collations( $target ) );
- }
- my $map = {};
- my( $startrank, $endrank );
- if( $c->end->has_rank ) {
- my $cpred = $c->common_predecessor( $source, $target );
- my $csucc = $c->common_successor( $source, $target );
- $startrank = $cpred->rank;
- $endrank = $csucc->rank;
- unless( $rel eq 'collated' || $sourcerank == $targetrank ) {
- foreach my $rk ( $startrank+1 .. $endrank-1 ) {
+ if( $c->end->has_rank ) {
+ foreach my $rk ( $sourcerank .. $targetrank ) {
map { push( @$mustdrop, $self->_drop_collations( $_->id ) ) }
$c->readings_at_rank( $rk );
}
}
}
- my $eqgraph = $c->equivalence_graph( $map, $startrank, $endrank,
- $source, $target );
- if( $eqgraph->has_a_cycle ) {
+ unless( $self->test_equivalence( $source, $target ) ) {
$self->_restore_collations( @$mustdrop );
return( 0, "Relationship would create witness loop" );
}
if( $self->get_relationship( $reading, $n )->type eq 'collated' ) {
push( @dropped, [ $reading, $n ] );
$self->del_relationship( $reading, $n );
+ #print STDERR "Dropped collation $reading -> $n\n";
}
}
return @dropped;
foreach my $v ( @vectors ) {
try {
$self->add_relationship( @$v, { 'type' => 'collated' } );
+ #print STDERR "Restored collation @$v\n";
} catch {
print STDERR $v->[0] . " - " . $v->[1] . " no longer collate\n";
}
$rel = $self->get_relationship( @$edge );
$self->_set_relationship( $rel, @vector );
}
- $self->delete_reading( $deleted );
+ $self->_make_equivalence( $deleted, $kept );
+}
+
+### Equivalence logic
+
+sub _remove_equivalence_node {
+ my( $self, $node ) = @_;
+ my $group = $self->equivalence( $node );
+ my $nodelist = $self->eqreadings( $group );
+ if( @$nodelist == 1 && $nodelist->[0] eq $node ) {
+ $self->remove_eqreadings( $group );
+ } elsif( @$nodelist == 1 ) {
+ warn "DATA INCONSISTENCY in equivalence graph: " . $nodelist->[0] .
+ " in group that should have only $node";
+ } else {
+ my @newlist = grep { $_ ne $node } @$nodelist;
+ $self->set_eqreadings( $group, \@newlist );
+ $self->remove_equivalence( $node );
+ }
+}
+
+=head2 add_equivalence_edge
+
+Add an edge in the equivalence graph corresponding to $source -> $target in the
+collation. Should only be called by Collation.
+
+=cut
+
+sub add_equivalence_edge {
+ my( $self, $source, $target ) = @_;
+ my $seq = $self->equivalence( $source );
+ my $teq = $self->equivalence( $target );
+ $self->equivalence_graph->add_edge( $seq, $teq );
}
+=head2 delete_equivalence_edge
+
+Remove an edge in the equivalence graph corresponding to $source -> $target in the
+collation. Should only be called by Collation.
+
+=cut
+
+sub delete_equivalence_edge {
+ my( $self, $source, $target ) = @_;
+ my $seq = $self->equivalence( $source );
+ my $teq = $self->equivalence( $target );
+ $self->equivalence_graph->delete_edge( $seq, $teq );
+}
+
+sub _is_disconnected {
+ my $self = shift;
+ return( scalar $self->equivalence_graph->predecessorless_vertices > 1
+ || scalar $self->equivalence_graph->successorless_vertices > 1 );
+}
+
+# Equate two readings in the equivalence graph
+sub _make_equivalence {
+ my( $self, $source, $target ) = @_;
+ # Get the source equivalent readings
+ my $seq = $self->equivalence( $source );
+ my $teq = $self->equivalence( $target );
+ # Nothing to do if they are already equivalent...
+ return if $seq eq $teq;
+ my $sourcepool = $self->eqreadings( $seq );
+ # and add them to the target readings.
+ push( @{$self->eqreadings( $teq )}, @$sourcepool );
+ map { $self->set_equivalence( $_, $teq ) } @$sourcepool;
+ # Then merge the nodes in the equivalence graph.
+ foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
+ $self->equivalence_graph->add_edge( $pred, $teq );
+ }
+ foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
+ $self->equivalence_graph->add_edge( $teq, $succ );
+ }
+ $self->equivalence_graph->delete_vertex( $seq );
+ # TODO enable this after collation parsing is done
+# throw( "Graph got disconnected making $source / $target equivalence" )
+# if $self->_is_disconnected;
+}
+
+=head2 test_equivalence
+
+Test whether, if two readings were equated with a 'colocated' relationship,
+the graph would still be valid.
+
+=cut
+
+sub test_equivalence {
+ my( $self, $source, $target ) = @_;
+ # Try merging the nodes in the equivalence graph; return a true value if
+ # no cycle is introduced thereby. Restore the original graph first.
+
+ # Keep track of edges we add
+ my %added_pred;
+ my %added_succ;
+ # Get the reading equivalents
+ my $seq = $self->equivalence( $source );
+ my $teq = $self->equivalence( $target );
+ # Maybe this is easy?
+ return 1 if $seq eq $teq;
+
+ # Save the first graph
+ my $checkstr = $self->equivalence_graph->stringify();
+ # Add and save relevant edges
+ foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
+ if( $self->equivalence_graph->has_edge( $pred, $teq ) ) {
+ $added_pred{$pred} = 0;
+ } else {
+ $self->equivalence_graph->add_edge( $pred, $teq );
+ $added_pred{$pred} = 1;
+ }
+ }
+ foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
+ if( $self->equivalence_graph->has_edge( $teq, $succ ) ) {
+ $added_succ{$succ} = 0;
+ } else {
+ $self->equivalence_graph->add_edge( $teq, $succ );
+ $added_succ{$succ} = 1;
+ }
+ }
+ # Delete source equivalent and test
+ $self->equivalence_graph->delete_vertex( $seq );
+ my $ret = !$self->equivalence_graph->has_a_cycle;
+
+ # Restore what we changed
+ $self->equivalence_graph->add_vertex( $seq );
+ foreach my $pred ( keys %added_pred ) {
+ $self->equivalence_graph->add_edge( $pred, $seq );
+ $self->equivalence_graph->delete_edge( $pred, $teq ) if $added_pred{$pred};
+ }
+ foreach my $succ ( keys %added_succ ) {
+ $self->equivalence_graph->add_edge( $seq, $succ );
+ $self->equivalence_graph->delete_edge( $teq, $succ ) if $added_succ{$succ};
+ }
+ unless( $self->equivalence_graph->eq( $checkstr ) ) {
+ warn "GRAPH CHANGED after testing";
+ }
+ # Return our answer
+ return $ret;
+}
+
+# Unmake an equivalence link between two readings. Should only be called internally.
+sub _break_equivalence {
+ my( $self, $source, $target ) = @_;
+
+ # This is the hard one. Need to reconstruct the equivalence groups without
+ # the given link.
+ my( %sng, %tng );
+ map { $sng{$_} = 1 } $self->_find_equiv_without( $source, $target );
+ map { $tng{$_} = 1 } $self->_find_equiv_without( $target, $source );
+ # If these groups intersect, they are still connected; do nothing.
+ foreach my $el ( keys %tng ) {
+ return if( exists $sng{$el} );
+ }
+ # If they don't intersect, then we split the nodes in the graph and in
+ # the hashes. First figure out which group has which name
+ my $oldgroup = $self->equivalence( $source ); # same as $target
+ my $keepsource = $sng{$oldgroup};
+ my $newgroup = $keepsource ? $target : $source;
+ my( $oldmembers, $newmembers );
+ if( $keepsource ) {
+ $oldmembers = [ keys %sng ];
+ $newmembers = [ keys %tng ];
+ } else {
+ $oldmembers = [ keys %tng ];
+ $newmembers = [ keys %sng ];
+ }
+
+ # First alter the old group in the hash
+ $self->set_eqreadings( $oldgroup, $oldmembers );
+ foreach my $el ( @$oldmembers ) {
+ $self->set_equivalence( $el, $oldgroup );
+ }
+
+ # then add the new group back to the hash with its new key
+ $self->set_eqreadings( $newgroup, $newmembers );
+ foreach my $el ( @$newmembers ) {
+ $self->set_equivalence( $el, $newgroup );
+ }
+
+ # Now add the new group back to the equivalence graph
+ $self->equivalence_graph->add_vertex( $newgroup );
+ # ...add the appropriate edges to the source group vertext
+ my $c = $self->collation;
+ foreach my $rdg ( @$newmembers ) {
+ foreach my $rp ( $c->sequence->predecessors( $rdg ) ) {
+ $self->equivalence_graph->add_edge( $self->equivalence( $rp ), $newgroup );
+ }
+ foreach my $rs ( $c->sequence->successors( $rdg ) ) {
+ $self->equivalence_graph->add_edge( $newgroup, $self->equivalence( $rs ) );
+ }
+ }
+
+ # ...and figure out which edges on the old group vertex to delete.
+ my( %old_pred, %old_succ );
+ foreach my $rdg ( @$oldmembers ) {
+ foreach my $rp ( $c->sequence->predecessors( $rdg ) ) {
+ $old_pred{$self->equivalence( $rp )} = 1;
+ }
+ foreach my $rs ( $c->sequence->successors( $rdg ) ) {
+ $old_succ{$self->equivalence( $rs )} = 1;
+ }
+ }
+ foreach my $p ( $self->equivalence_graph->predecessors( $oldgroup ) ) {
+ unless( $old_pred{$p} ) {
+ $self->equivalence_graph->delete_edge( $p, $oldgroup );
+ }
+ }
+ foreach my $s ( $self->equivalence_graph->successors( $oldgroup ) ) {
+ unless( $old_succ{$s} ) {
+ $self->equivalence_graph->delete_edge( $oldgroup, $s );
+ }
+ }
+ # TODO enable this after collation parsing is done
+# throw( "Graph got disconnected breaking $source / $target equivalence" )
+# if $self->_is_disconnected;
+}
+
+sub _find_equiv_without {
+ my( $self, $first, $second ) = @_;
+ my %found = ( $first => 1 );
+ my $check = [ $first ];
+ my $iter = 0;
+ while( @$check ) {
+ my $more = [];
+ foreach my $r ( @$check ) {
+ foreach my $nr ( $self->graph->neighbors( $r ) ) {
+ next if $r eq $second;
+ if( $self->get_relationship( $r, $nr )->colocated ) {
+ push( @$more, $nr ) unless exists $found{$nr};
+ $found{$nr} = 1;
+ }
+ }
+ }
+ $check = $more;
+ }
+ return keys %found;
+}
+
+=head2 rebuild_equivalence
+
+(Re)build the equivalence graph from scratch. Dumps the graph, makes a new one,
+adds all readings and edges, then makes an equivalence for all relationships.
+
+=cut
+
+sub rebuild_equivalence {
+ my $self = shift;
+ my $newgraph = Graph->new();
+ # Set this as the new equivalence graph
+ $self->_reset_equivalence( $newgraph );
+ # Clear out the data hashes
+ $self->_clear_equivalence;
+ $self->_clear_eqreadings;
+
+ # Add the readings
+ foreach my $r ( $self->collation->readings ) {
+ my $rid = $r->id;
+ $newgraph->add_vertex( $rid );
+ $self->set_equivalence( $rid, $rid );
+ $self->set_eqreadings( $rid, [ $rid ] );
+ }
+
+ # Now add the edges
+ foreach my $e ( $self->collation->paths ) {
+ $self->add_equivalence_edge( @$e );
+ }
+
+ # Now equate the colocated readings. This does no testing;
+ # it assumes that all preexisting relationships are valid.
+ foreach my $rel ( $self->relationships ) {
+ my $relobj = $self->get_relationship( $rel );
+ next unless $relobj && $relobj->colocated;
+ $self->_make_equivalence( @$rel );
+ }
+}
+
+### Output logic
+
sub _as_graphml {
my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_;
projects / scpubgit/stemmatology.git / blobdiff