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' } );
is => 'ro',
isa => 'Graph',
default => sub { Graph->new() },
+ writer => '_reset_equivalence',
);
has '_node_equivalences' => (
equivalence => 'get',
set_equivalence => 'set',
remove_equivalence => 'delete',
+ _clear_equivalence => 'clear',
},
);
eqreadings => 'get',
set_eqreadings => 'set',
remove_eqreadings => 'delete',
+ _clear_eqreadings => 'clear',
},
);
my $orig = shift;
my $self = shift;
- $DB::single = 1;
$self->_remove_equivalence_node( @_ );
$self->$orig( @_ );
};
my( $self, $relationship, @vector ) = @_;
$self->graph->add_edge( @vector );
$self->graph->set_edge_attribute( @vector, 'object', $relationship );
- $self->make_equivalence( @vector ) if $relationship->colocated;
+ $self->_make_equivalence( @vector ) if $relationship->colocated;
}
=head2 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 )
sub scoped_relationship {
my( $self, $rdga, $rdgb ) = @_;
my( $first, $second ) = sort( $rdga, $rdgb );
+ my( $lcfirst, $lcsecond ) = sort( lc( $rdga ), lc( $rdgb ) );
if( exists $self->scopedrels->{$first}->{$second} ) {
return $self->scopedrels->{$first}->{$second};
+ } elsif( exists $self->scopedrels->{$lcfirst}->{$lcsecond} ) {
+ my $rel = $self->scopedrels->{$lcfirst}->{$lcsecond};
+ return $rel->type ne 'orthographic' ? $rel : undef;
} else {
return undef;
}
=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 {
- ok( 0, "Collation now has a cycle" );
+} catch ( Text::Tradition::Error $e ) {
+ ok( 0, "Collation now has a cycle: " . $e->message );
}
-# Now attempt merge of an identical reading
+# Test 1.2: attempt merge of an identical reading
try {
- $c1->merge_readings( '9,3', '11,5' );
+ $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 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, "Relationship deletion failed with a meta reading as neighbor" );
+}
+
+# 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
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' ) {
# Is there a relationship with this a & b already?
# Case-insensitive for non-orthographics.
- my $rdga = $options->{'type'} eq 'orthographic'
- ? $options->{'reading_a'} : lc( $options->{'reading_a'} );
- my $rdgb = $options->{'type'} eq 'orthographic'
- ? $options->{'reading_b'} : lc( $options->{'reading_b'} );
+ my $rdga = $options->{'reading_a'};
+ my $rdgb = $options->{'reading_b'};
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
}
- # Find all the pairs for which we need to set the relationship.
- my @vectors;
- if( $relationship->colocated && $relationship->nonlocal && !$thispaironly ) {
- push( @vectors, $self->_find_applicable( $relationship ) );
- }
-
# Now set the relationship(s).
my @pairs_set;
my $rel = $self->get_relationship( $source, $target );
$self->_set_relationship( $relationship, $source, $target ) unless $skip;
push( @pairs_set, [ $source, $target ] );
- # Set any additional relationships that might be in @vectors.
- foreach my $v ( @vectors ) {
- next if $v->[0] eq $source && $v->[1] eq $target;
- next if $v->[1] eq $source && $v->[0] eq $target;
- my @added = $self->add_relationship( @$v, $relationship );
- push( @pairs_set, @added );
+ # 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 ) );
}
-
# Finally, restore whatever collations we can, and return.
$self->_restore_collations( @$droppedcolls );
return @pairs_set;
}
+=head2 add_global_relationship( $options, $skipvector )
+
+Adds the relationship specified wherever the relevant readings appear together
+in the graph. Options as in add_relationship above.
+
+=cut
+
+sub add_global_relationship {
+ my( $self, $options ) = @_;
+ # First see if we are dealing with a relationship object already
+ my $relationship;
+ if( ref( $options ) eq 'Text::Tradition::Collation::Relationship' ) {
+ $relationship = $options;
+ } else {
+ # Then see if a scoped relationship already applies for the words.
+ my $scopedrel = $self->scoped_relationship(
+ $options->{reading_a}, $options->{reading_b} );
+ $relationship = $scopedrel ? $scopedrel
+ : $self->create( $options );
+ }
+ # Sanity checking
+ throw( "Relationship passed to add_global is not global" )
+ unless $relationship->nonlocal;
+ throw( "Relationship passed to add_global is not a valid global type" )
+ unless $relationship->colocated && $relationship->type ne 'collated';
+
+ # Apply the relationship wherever it is valid
+ my @pairs_set;
+ foreach my $v ( $self->_find_applicable( $relationship ) ) {
+ my $exists = $self->get_relationship( @$v );
+ if( $exists && $exists->type ne 'collated' ) {
+ throw( "Found conflicting relationship at @$v" )
+ unless $exists->type eq $relationship->type
+ && $exists->scope eq $relationship->scope;
+ } else {
+ my @added = $self->add_relationship( @$v, $relationship );
+ push( @pairs_set, @added );
+ }
+ }
+ return @pairs_set;
+}
+
+
=head2 del_scoped_relationship( $reading_a, $reading_b )
Returns the general (document-level or global) relationship that has been defined
sub _remove_relationship {
my( $self, $equiv, @vector ) = @_;
$self->graph->delete_edge( @vector );
- $self->break_equivalence( @vector ) if $equiv;
+ $self->_break_equivalence( @vector ) if $equiv;
}
=head2 relationship_valid( $source, $target, $type )
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...
push( @$mustdrop, $self->_drop_collations( $source ) );
push( @$mustdrop, $self->_drop_collations( $target ) );
if( $c->end->has_rank ) {
- my $cpred = $c->common_predecessor( $source, $target );
- my $csucc = $c->common_successor( $source, $target );
- foreach my $rk ( $cpred->rank+1 .. $csucc->rank-1 ) {
+ foreach my $rk ( $sourcerank .. $targetrank ) {
map { push( @$mustdrop, $self->_drop_collations( $_->id ) ) }
$c->readings_at_rank( $rk );
}
# 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 ];
$rel = $self->get_relationship( @$edge );
$self->_set_relationship( $rel, @vector );
}
- $self->make_equivalence( $deleted, $kept );
+ $self->_make_equivalence( $deleted, $kept );
}
### Equivalence logic
my $group = $self->equivalence( $node );
my $nodelist = $self->eqreadings( $group );
if( @$nodelist == 1 && $nodelist->[0] eq $node ) {
- #print STDERR "Removing equivalence $group for $node\n";
+ $self->equivalence_graph->delete_vertex( $group );
$self->remove_eqreadings( $group );
+ $self->remove_equivalence( $group );
} elsif( @$nodelist == 1 ) {
- warn "DATA INCONSISTENCY in equivalence graph: " . $nodelist->[0] .
- " in group that should have only $node";
+ throw( "DATA INCONSISTENCY in equivalence graph: " . $nodelist->[0] .
+ " in group that should have only $node" );
} else {
- #print STDERR "Removing $node from equivalence $group\n";
- my @newlist = grep { $_ ne $node } @$nodelist;
+ my @newlist = grep { $_ ne $node } @$nodelist;
$self->set_eqreadings( $group, \@newlist );
$self->remove_equivalence( $node );
}
=head2 add_equivalence_edge
-Return the relationship object, if any, that exists between two readings.
+Add an edge in the equivalence graph corresponding to $source -> $target in the
+collation. Should only be called by Collation.
=cut
my( $self, $source, $target ) = @_;
my $seq = $self->equivalence( $source );
my $teq = $self->equivalence( $target );
- #print STDERR "Adding equivalence edge $seq -> $teq for $source -> $target\n";
$self->equivalence_graph->add_edge( $seq, $teq );
}
-=head2 add_equivalence_edge
+=head2 delete_equivalence_edge
-Return the relationship object, if any, that exists between two readings.
+Remove an edge in the equivalence graph corresponding to $source -> $target in the
+collation. Should only be called by Collation.
=cut
my( $self, $source, $target ) = @_;
my $seq = $self->equivalence( $source );
my $teq = $self->equivalence( $target );
- #print STDERR "Deleting equivalence edge $seq -> $teq for $source -> $target\n";
$self->equivalence_graph->delete_edge( $seq, $teq );
}
|| scalar $self->equivalence_graph->successorless_vertices > 1 );
}
-=head2 make_equivalence
-
-Equate two readings in the equivalence graph. Should only be called internally.
-
-=cut
-
-sub make_equivalence {
+# 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;
- #print STDERR "Making equivalence for $source -> $target\n";
my $sourcepool = $self->eqreadings( $seq );
# and add them to the target readings.
- # print STDERR "Moving readings '@$sourcepool' from group $seq to $teq\n";
push( @{$self->eqreadings( $teq )}, @$sourcepool );
map { $self->set_equivalence( $_, $teq ) } @$sourcepool;
# Then merge the nodes in the equivalence graph.
$self->equivalence_graph->add_edge( $teq, $succ );
}
$self->equivalence_graph->delete_vertex( $seq );
-# throw( "Graph got disconnected making $source / $target equivalence" )
-# if $self->_is_disconnected;
+ # 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 relationship, the graph would
-still be valid.
+Test whether, if two readings were equated with a 'colocated' relationship,
+the graph would still be valid.
=cut
return $ret;
}
-=head2 break_equivalence
-
-Unmake an equivalence link between two readings. Should only be called internally.
-
-=cut
-
-sub break_equivalence {
+# 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
map { $tng{$_} = 1 } $self->_find_equiv_without( $target, $source );
# If these groups intersect, they are still connected; do nothing.
foreach my $el ( keys %tng ) {
- if( exists $sng{$el} ) {
- #print STDERR "Equivalence break $source / $target is a noop\n";
- return;
- }
+ return if( exists $sng{$el} );
}
- #print STDERR "Breaking equivalence $source / $target\n";
# 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 ); # eq for $target
- my $swapped = $oldgroup eq $source;
- my $newgroup = $swapped ? $target : $source;
+ my $oldgroup = $self->equivalence( $source ); # same as $target
+ my $keepsource = $sng{$oldgroup};
+ my $newgroup = $keepsource ? $target : $source;
my( $oldmembers, $newmembers );
- if( $swapped ) {
+ if( $keepsource ) {
$oldmembers = [ keys %sng ];
$newmembers = [ keys %tng ];
} else {
# 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 );
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 ) );
}
}
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;
}
}
$self->equivalence_graph->delete_edge( $oldgroup, $s );
}
}
-# throw( "Graph got disconnected breaking $source / $target equivalence" )
-# if $self->_is_disconnected;
+ # 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 {
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;
+
+ $self->collation->tradition->_init_done(0);
+ # 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 );
+ }
+ $self->collation->tradition->_init_done(1);
+}
+
+=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 {
projects / scpubgit/stemmatology.git / blobdiff