X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FText%2FTradition%2FCollation%2FRelationshipStore.pm;h=d3ca9bf31f5dd85e3a0f2b68e3dca9d2d05b0fbc;hb=99ab95354ac3ce1f09b81e2b8a3fcd66fe6e83d9;hp=3024f202903fa88e5575049d9d3c8034a67baa26;hpb=46e1fe146d07f8325d488278a41dac4697539651;p=scpubgit%2Fstemmatology.git diff --git a/lib/Text/Tradition/Collation/RelationshipStore.pm b/lib/Text/Tradition/Collation/RelationshipStore.pm index 3024f20..d3ca9bf 100644 --- a/lib/Text/Tradition/Collation/RelationshipStore.pm +++ b/lib/Text/Tradition/Collation/RelationshipStore.pm @@ -31,10 +31,10 @@ use_ok( 'Text::Tradition::Collation::RelationshipStore' ); my $cxfile = 't/data/Collatex-16.xml'; my $t = Text::Tradition->new( - 'name' => 'inline', - 'input' => 'CollateX', - 'file' => $cxfile, - ); + 'name' => 'inline', + 'input' => 'CollateX', + 'file' => $cxfile, + ); my $c = $t->collation; my @v1 = $c->add_relationship( 'n21', 'n22', { 'type' => 'lexical' } ); @@ -85,6 +85,61 @@ has 'graph' => ( }, ); +=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. @@ -112,6 +167,7 @@ sub _set_relationship { 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 @@ -140,18 +196,9 @@ sub create { } } - # Check to see if a nonlocal relationship is defined for the two readings - $rel = $self->scoped_relationship( $options->{'reading_a'}, - $options->{'reading_b'} ); - if( $rel && $rel->type eq $options->{'type'} ) { - return $rel; - } elsif( $rel ) { - throw( sprintf( "Relationship of type %s with scope %s already defined for readings %s and %s", $rel->type, $rel->scope, $options->{'reading_a'}, $options->{'reading_b'} ) ); - } else { - $rel = Text::Tradition::Collation::Relationship->new( $options ); - $self->add_scoped_relationship( $rel ) if $rel->nonlocal; - return $rel; - } + $rel = Text::Tradition::Collation::Relationship->new( $options ); + $self->add_scoped_relationship( $rel ) if $rel->nonlocal; + return $rel; } =head2 add_scoped_relationship( $rel ) @@ -204,94 +251,134 @@ add_relationship. =begin testing +use Test::Warn; use Text::Tradition; 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 +my $t1; +warning_is { + $t1 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/legendfrag.xml' ); +} 'DROPPING r14.2 -> r8.1: Cannot set relationship on a meta reading', + "Got expected relationship drop warning on parse"; + +# 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 ( 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 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 1.4: try to break a relationship near a meta reading +$c1->add_relationship( 'r7.6', 'r7.3', { type => 'orthographic' } ); +try { + $c1->del_relationship( 'r7.6', 'r7.7' ); + $c1->del_relationship( 'r7.6', 'r7.3' ); + ok( 1, "Relationship broken with a meta reading as neighbor" ); } catch { - ok( 0, "Collation now has a cycle" ); + ok( 0, "Relationship deletion failed with a meta reading as neighbor" ); } -# Test 2: try to equate nodes that are prevented with a real intermediate +# 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 $t2; +warning_is { + $t2 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/legendfrag.xml' ); +} 'DROPPING r14.2 -> r8.1: Cannot set relationship on a meta reading', + "Got expected relationship drop warning on parse"; 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 @@ -301,7 +388,11 @@ try { 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 = []; @@ -321,8 +412,8 @@ sub add_relationship { } # 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' ) { @@ -335,8 +426,10 @@ sub add_relationship { my $otherrel = $self->scoped_relationship( $rdga, $rdgb ); if( $otherrel && $otherrel->type eq $options->{type} && $otherrel->scope eq $options->{scope} ) { - warn "Applying existing scoped relationship"; + warn "Applying existing scoped relationship for $rdga / $rdgb"; $relationship = $otherrel; + } elsif( $otherrel ) { + throw( "Conflicting scoped relationship for $rdga / $rdgb at $source / $target" ); } } $relationship = $self->create( $options ) unless $relationship; # Will throw on error @@ -449,15 +542,16 @@ sub del_relationship { 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 ); @@ -466,8 +560,9 @@ sub del_relationship { } 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 ) @@ -482,7 +577,9 @@ sub relationship_valid { my( $self, $source, $target, $rel, $mustdrop ) = @_; $mustdrop = [] unless $mustdrop; # in case we were passed nothing my $c = $self->collation; - if ( $rel eq 'transposition' || $rel eq 'repetition' ) { + ## Assume validity is okay if we are initializing from scratch. + return ( 1, "initializing" ) unless $c->tradition->_initialized; + 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. # TODO this might be called before witness paths are set... @@ -502,20 +599,10 @@ sub relationship_valid { # 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' ) { @@ -529,24 +616,14 @@ sub relationship_valid { 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" ); } @@ -561,6 +638,7 @@ sub _drop_collations { 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; @@ -571,6 +649,7 @@ sub _restore_collations { 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"; } @@ -631,6 +710,9 @@ sub related_readings { # Backwards compat if( $filter eq 'colocated' ) { $filter = sub { $_[0]->colocated }; + } elsif( !ref( $filter ) ) { + my $type = $filter; + $filter = sub { $_[0]->type eq $type }; } my %found = ( $reading => 1 ); my $check = [ $reading ]; @@ -686,9 +768,346 @@ sub merge_readings { $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->equivalence_graph->delete_vertex( $group ); + $self->remove_eqreadings( $group ); + $self->remove_equivalence( $group ); + } elsif( @$nodelist == 1 ) { + throw( "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 && $self->collation->tradition->_initialized; } +=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 ) ) { + next unless $self->equivalence( $rp ); + $self->equivalence_graph->add_edge( $self->equivalence( $rp ), $newgroup ); + } + foreach my $rs ( $c->sequence->successors( $rdg ) ) { + next unless $self->equivalence( $rs ); + $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 ) ) { + next unless $self->equivalence( $rp ); + $old_pred{$self->equivalence( $rp )} = 1; + } + foreach my $rs ( $c->sequence->successors( $rdg ) ) { + next unless $self->equivalence( $rs ); + $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 && $self->collation->tradition->_initialized; +} + +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 ); + } +} + +=head2 equivalence_ranks + +Rank all vertices in the equivalence graph, and return a hash reference with +vertex => rank mapping. + +=cut + +sub equivalence_ranks { + my $self = shift; + my $eqstart = $self->equivalence( $self->collation->start ); + my $eqranks = { $eqstart => 0 }; + my $rankeqs = { 0 => [ $eqstart ] }; + my @curr_origin = ( $eqstart ); + # A little iterative function. + while( @curr_origin ) { + @curr_origin = $self->_assign_rank( $eqranks, $rankeqs, @curr_origin ); + } + return( $eqranks, $rankeqs ); +} + +sub _assign_rank { + my( $self, $node_ranks, $rank_nodes, @current_nodes ) = @_; + my $graph = $self->equivalence_graph; + # Look at each of the children of @current_nodes. If all the child's + # parents have a rank, assign it the highest rank + 1 and add it to + # @next_nodes. Otherwise skip it; we will return when the highest-ranked + # parent gets a rank. + my @next_nodes; + foreach my $c ( @current_nodes ) { + warn "Current reading $c has no rank!" + unless exists $node_ranks->{$c}; + foreach my $child ( $graph->successors( $c ) ) { + next if exists $node_ranks->{$child}; + my $highest_rank = -1; + my $skip = 0; + foreach my $parent ( $graph->predecessors( $child ) ) { + if( exists $node_ranks->{$parent} ) { + $highest_rank = $node_ranks->{$parent} + if $highest_rank <= $node_ranks->{$parent}; + } else { + $skip = 1; + last; + } + } + next if $skip; + my $c_rank = $highest_rank + 1; + # print STDERR "Assigning rank $c_rank to node $child \n"; + $node_ranks->{$child} = $c_rank if $node_ranks; + push( @{$rank_nodes->{$c_rank}}, $child ) if $rank_nodes; + push( @next_nodes, $child ); + } + } + return @next_nodes; +} + +### Output logic + sub _as_graphml { my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_;