1 package Text::Tradition::Collation::RelationshipStore;
6 use Text::Tradition::Error;
7 use Text::Tradition::Collation::Relationship;
8 use Text::Tradition::Collation::RelationshipType;
15 Text::Tradition::Collation::RelationshipStore - Keeps track of the relationships
16 between readings in a given collation
20 Text::Tradition is a library for representation and analysis of collated
21 texts, particularly medieval ones. The RelationshipStore is an internal object
22 of the collation, to keep track of the defined relationships (both specific and
23 general) between readings.
30 use_ok( 'Text::Tradition::Collation::RelationshipStore' );
32 # Add some relationships, and delete them
34 my $cxfile = 't/data/Collatex-16.xml';
35 my $t = Text::Tradition->new(
37 'input' => 'CollateX',
40 my $c = $t->collation;
42 my @v1 = $c->add_relationship( 'n21', 'n22', { 'type' => 'lexical' } );
43 is( scalar @v1, 1, "Added a single relationship" );
44 is( $v1[0]->[0], 'n21', "Got correct node 1" );
45 is( $v1[0]->[1], 'n22', "Got correct node 2" );
46 my @v2 = $c->add_relationship( 'n24', 'n23',
47 { 'type' => 'spelling', 'scope' => 'global' } );
48 is( scalar @v2, 2, "Added a global relationship with two instances" );
49 @v1 = $c->del_relationship( 'n22', 'n21' );
50 is( scalar @v1, 1, "Deleted first relationship" );
51 @v2 = $c->del_relationship( 'n12', 'n13' );
52 is( scalar @v2, 2, "Deleted second global relationship" );
53 my @v3 = $c->del_relationship( 'n1', 'n2' );
54 is( scalar @v3, 0, "Nothing deleted on non-existent relationship" );
60 =head2 new( collation => $collation );
62 Creates a new relationship store for the given collation.
68 isa => 'Text::Tradition::Collation',
75 Registry of possible relationship types. See RelationshipType for more info.
79 has 'relationship_types' => (
93 isa => 'HashRef[HashRef[Text::Tradition::Collation::Relationship]]',
94 default => sub { {} },
100 default => sub { Graph->new( undirected => 1 ) },
102 relationships => 'edges',
103 add_reading => 'add_vertex',
104 delete_reading => 'delete_vertex',
108 =head2 equivalence_graph()
110 Returns an equivalence graph of the collation, in which all readings
111 related via a 'colocated' relationship are transformed into a single
112 vertex. Can be used to determine the validity of a new relationship.
116 has 'equivalence_graph' => (
119 default => sub { Graph->new() },
120 writer => '_reset_equivalence',
123 has '_node_equivalences' => (
127 equivalence => 'get',
128 set_equivalence => 'set',
129 remove_equivalence => 'delete',
130 _clear_equivalence => 'clear',
134 has '_equivalence_readings' => (
139 set_eqreadings => 'set',
140 remove_eqreadings => 'delete',
141 _clear_eqreadings => 'clear',
145 ## Build function - here we have our default set of relationship types.
150 my @DEFAULT_TYPES = (
151 { name => 'collated', bindlevel => 50, is_weak => 1, is_transitive => 0,
152 is_generalizable => 0, description => 'Internal use only' },
153 { name => 'orthographic', bindlevel => 0, use_regular => 0,
154 description => 'These are the same reading, neither unusually spelled.' },
155 { name => 'punctuation', bindlevel => 0,
156 description => 'These are the same reading apart from punctuation.' },
157 { name => 'spelling', bindlevel => 1,
158 description => 'These are the same reading, spelled differently.' },
159 { name => 'grammatical', bindlevel => 2,
160 description => 'These readings share a root (lemma), but have different parts of speech (morphologies).' },
161 { name => 'lexical', bindlevel => 2,
162 description => 'These readings share a part of speech (morphology), but have different roots (lemmata).' },
163 { name => 'uncertain', bindlevel => 0, is_transitive => 0, is_generalizable => 0,
164 use_regular => 0, description => 'These readings are related, but a clear category cannot be assigned.' },
165 { name => 'other', bindlevel => 0, is_transitive => 0, is_generalizable => 0,
166 description => 'These readings are related in a way not covered by the existing types.' },
167 { name => 'transposition', bindlevel => 50, is_colocation => 0,
168 description => 'This is the same (or nearly the same) reading in a different location.' },
169 { name => 'repetition', bindlevel => 50, is_colocation => 0, is_transitive => 0,
170 description => 'This is a reading that was repeated in one or more witnesses.' }
173 foreach my $type ( @DEFAULT_TYPES ) {
174 $self->add_type( $type );
178 around add_type => sub {
182 if( @_ == 1 && $_[0]->$_isa( 'Text::Tradition::Collation::RelationshipType' ) ) {
185 my %args = @_ == 1 ? %{$_[0]} : @_;
186 $new_type = Text::Tradition::Collation::RelationshipType->new( %args );
188 $self->$orig( $new_type->name => $new_type );
192 around add_reading => sub {
196 $self->equivalence_graph->add_vertex( @_ );
197 $self->set_equivalence( $_[0], $_[0] );
198 $self->set_eqreadings( $_[0], [ $_[0] ] );
202 around delete_reading => sub {
206 $self->_remove_equivalence_node( @_ );
210 =head2 get_relationship
212 Return the relationship object, if any, that exists between two readings.
216 sub get_relationship {
219 if( @_ == 1 && ref( $_[0] ) eq 'ARRAY' ) {
220 # Dereference the edge arrayref that was passed.
227 if( $self->graph->has_edge_attribute( @vector, 'object' ) ) {
228 $relationship = $self->graph->get_edge_attribute( @vector, 'object' );
230 return $relationship;
233 sub _set_relationship {
234 my( $self, $relationship, @vector ) = @_;
235 $self->graph->add_edge( @vector );
236 $self->graph->set_edge_attribute( @vector, 'object', $relationship );
237 $self->_make_equivalence( @vector ) if $relationship->colocated;
242 Create a new relationship with the given options and return it.
243 Warn and return undef if the relationship cannot be created.
248 my( $self, $options ) = @_;
249 # Check to see if a relationship exists between the two given readings
250 my $source = delete $options->{'orig_a'};
251 my $target = delete $options->{'orig_b'};
252 my $rel = $self->get_relationship( $source, $target );
254 if( $self->type( $rel->type )->is_weak ) {
255 # Always replace a weak relationship with a more descriptive
257 $self->del_relationship( $source, $target );
258 } elsif( $rel->type ne $options->{'type'} ) {
259 throw( "Another relationship of type " . $rel->type
260 . " already exists between $source and $target" );
266 $rel = Text::Tradition::Collation::Relationship->new( $options );
267 my $reltype = $self->type( $rel->type );
268 throw( "Unrecognized relationship type " . $rel->type ) unless $reltype;
269 # Validate the options given against the relationship type wanted
270 throw( "Cannot set nonlocal scope on relationship of type " . $reltype->name )
271 if $rel->nonlocal && !$reltype->is_generalizable;
273 $self->add_scoped_relationship( $rel ) if $rel->nonlocal;
277 =head2 add_scoped_relationship( $rel )
279 Keep track of relationships defined between specific readings that are scoped
280 non-locally. Key on whichever reading occurs first alphabetically.
284 sub add_scoped_relationship {
285 my( $self, $rel ) = @_;
286 my $rdga = $rel->reading_a;
287 my $rdgb = $rel->reading_b;
288 my $r = $self->scoped_relationship( $rdga, $rdgb );
290 warn sprintf( "Scoped relationship of type %s already exists between %s and %s",
291 $r->type, $rdga, $rdgb );
294 my( $first, $second ) = sort ( $rdga, $rdgb );
295 $self->scopedrels->{$first}->{$second} = $rel;
298 =head2 scoped_relationship( $reading_a, $reading_b )
300 Returns the general (document-level or global) relationship that has been defined
301 between the two reading strings. Returns undef if there is no general relationship.
305 sub scoped_relationship {
306 my( $self, $rdga, $rdgb ) = @_;
307 my( $first, $second ) = sort( $rdga, $rdgb );
308 if( exists $self->scopedrels->{$first}->{$second} ) {
309 return $self->scopedrels->{$first}->{$second};
314 =head2 add_relationship( $self, $source, $sourcetext, $target, $targettext, $opts )
316 Adds the relationship specified in $opts (see Text::Tradition::Collation::Relationship
317 for the possible options) between the readings given in $source and $target. Sets
318 up a scoped relationship between $sourcetext and $targettext if the relationship is
321 Returns a status boolean and a list of all reading pairs connected by the call to
332 $t1 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/legendfrag.xml' );
333 } [qr/Cannot set relationship on a meta reading/],
334 "Got expected relationship drop warning on parse";
336 # Test 1.1: try to equate nodes that are prevented with an intermediate collation
337 ok( $t1, "Parsed test fragment file" );
338 my $c1 = $t1->collation;
339 my $trel = $c1->get_relationship( 'r9.2', 'r9.3' );
340 is( ref( $trel ), 'Text::Tradition::Collation::Relationship',
341 "Troublesome relationship exists" );
342 is( $trel->type, 'collated', "Troublesome relationship is a collation" );
344 # Try to make the link we want
346 $c1->add_relationship( 'r8.6', 'r10.3', { 'type' => 'orthographic' } );
347 ok( 1, "Added cross-collation relationship as expected" );
348 } catch( Text::Tradition::Error $e ) {
349 ok( 0, "Existing collation blocked equivalence relationship: " . $e->message );
353 $c1->calculate_ranks();
354 ok( 1, "Successfully calculated ranks" );
355 } catch ( Text::Tradition::Error $e ) {
356 ok( 0, "Collation now has a cycle: " . $e->message );
359 # Test 1.2: attempt merge of an identical reading
361 $c1->merge_readings( 'r9.3', 'r11.5' );
362 ok( 1, "Successfully merged reading 'pontifex'" );
363 } catch ( Text::Tradition::Error $e ) {
364 ok( 0, "Merge of mergeable readings failed: $e->message" );
368 # Test 1.3: attempt relationship with a meta reading (should fail)
370 $c1->add_relationship( 'r8.1', 'r9.2', { 'type' => 'collated' } );
371 ok( 0, "Allowed a meta-reading to be used in a relationship" );
372 } catch ( Text::Tradition::Error $e ) {
373 is( $e->message, 'Cannot set relationship on a meta reading',
374 "Relationship link prevented for a meta reading" );
377 # Test 1.4: try to break a relationship near a meta reading
378 $c1->add_relationship( 'r7.6', 'r7.3', { type => 'orthographic' } );
380 $c1->del_relationship( 'r7.6', 'r7.7' );
381 $c1->del_relationship( 'r7.6', 'r7.3' );
382 ok( 1, "Relationship broken with a meta reading as neighbor" );
384 ok( 0, "Relationship deletion failed with a meta reading as neighbor" );
387 # Test 2.1: try to equate nodes that are prevented with a real intermediate
391 $t2 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/legendfrag.xml' );
392 } [qr/Cannot set relationship on a meta reading/],
393 "Got expected relationship drop warning on parse";
394 my $c2 = $t2->collation;
395 $c2->add_relationship( 'r9.2', 'r9.3', { 'type' => 'lexical' } );
396 my $trel2 = $c2->get_relationship( 'r9.2', 'r9.3' );
397 is( ref( $trel2 ), 'Text::Tradition::Collation::Relationship',
398 "Created blocking relationship" );
399 is( $trel2->type, 'lexical', "Blocking relationship is not a collation" );
400 # This time the link ought to fail
402 $c2->add_relationship( 'r8.6', 'r10.3', { 'type' => 'orthographic' } );
403 ok( 0, "Added cross-equivalent bad relationship" );
404 } catch ( Text::Tradition::Error $e ) {
405 like( $e->message, qr/witness loop/,
406 "Existing equivalence blocked crossing relationship" );
410 $c2->calculate_ranks();
411 ok( 1, "Successfully calculated ranks" );
412 } catch ( Text::Tradition::Error $e ) {
413 ok( 0, "Collation now has a cycle: " . $e->message );
416 # Test 3.1: make a straightforward pair of transpositions.
417 my $t3 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/lf2.xml' );
418 # Test 1: try to equate nodes that are prevented with an intermediate collation
419 my $c3 = $t3->collation;
421 $c3->add_relationship( 'r36.4', 'r38.3', { 'type' => 'transposition' } );
422 ok( 1, "Added straightforward transposition" );
423 } catch ( Text::Tradition::Error $e ) {
424 ok( 0, "Failed to add normal transposition: " . $e->message );
427 $c3->add_relationship( 'r36.3', 'r38.2', { 'type' => 'transposition' } );
428 ok( 1, "Added straightforward transposition complement" );
429 } catch ( Text::Tradition::Error $e ) {
430 ok( 0, "Failed to add normal transposition complement: " . $e->message );
433 # Test 3.2: try to make a transposition that could be a parallel.
435 $c3->add_relationship( 'r28.2', 'r29.2', { 'type' => 'transposition' } );
436 ok( 0, "Added bad colocated transposition" );
437 } catch ( Text::Tradition::Error $e ) {
438 like( $e->message, qr/Readings appear to be colocated/,
439 "Prevented bad colocated transposition" );
442 # Test 3.3: make the parallel, and then make the transposition again.
444 $c3->add_relationship( 'r28.3', 'r29.3', { 'type' => 'orthographic' } );
445 ok( 1, "Equated identical readings for transposition" );
446 } catch ( Text::Tradition::Error $e ) {
447 ok( 0, "Failed to equate identical readings: " . $e->message );
450 $c3->add_relationship( 'r28.2', 'r29.2', { 'type' => 'transposition' } );
451 ok( 1, "Added straightforward transposition complement" );
452 } catch ( Text::Tradition::Error $e ) {
453 ok( 0, "Failed to add normal transposition complement: " . $e->message );
456 # Test 4: make a global relationship that involves re-ranking a node first, when
457 # the prior rank has a potential match too
458 my $t4 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/globalrel_test.xml' );
459 my $c4 = $t4->collation;
460 # Can we even add the relationship?
462 $c4->add_relationship( 'r463.2', 'r463.4',
463 { type => 'orthographic', scope => 'global' } );
464 ok( 1, "Added global relationship without error" );
465 } catch ( Text::Tradition::Error $e ) {
466 ok( 0, "Failed to add global relationship when same-rank alternative exists: "
469 $c4->calculate_ranks();
470 # Do our readings now share a rank?
471 is( $c4->reading('r463.2')->rank, $c4->reading('r463.4')->rank,
472 "Expected readings now at same rank" );
474 # Test group 5: relationship transitivity.
475 my $t5 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/john.xml' );
476 my $c5 = $t5->collation;
477 # Test 5.0: propagate all existing transitive rels and make sure it succeeds
478 my $orignumrels = scalar $c5->relationships();
480 $c5->relations->propagate_all_relationships();
481 ok( 1, "Propagated all existing transitive relationships" );
482 } catch ( Text::Tradition::Error $err ) {
483 ok( 0, "Failed to propagate all existing relationships: " . $err->message );
485 ok( scalar( $c5->relationships ) > $orignumrels, "Added some relationships in propagation" );
487 # Test 5.1: make a grammatical link to an orthographically-linked reading
488 $c5->add_relationship( 'r13.5', 'r13.2', { type => 'orthographic' } );
489 $c5->add_relationship( 'r13.1', 'r13.2', { type => 'grammatical', propagate => 1 } );
490 my $impliedrel = $c5->get_relationship( 'r13.1', 'r13.5' );
491 ok( $impliedrel, 'Relationship was made between indirectly linked readings' );
493 is( $impliedrel->type, 'grammatical', 'Implicit inbound relationship has the correct type' );
496 # Test 5.2: make another orthographic link, see if the grammatical one propagates
497 $c5->add_relationship( 'r13.3', 'r13.5', { type => 'orthographic', propagate => 1 } );
498 foreach my $rdg ( qw/ r13.3 r13.5 / ) {
499 my $newgram = $c5->get_relationship( 'r13.1', $rdg );
500 ok( $newgram, 'Relationship was propagaged up between indirectly linked readings' );
502 is( $newgram->type, 'grammatical', 'Implicit outbound relationship has the correct type' );
505 my $neworth = $c5->get_relationship( 'r13.2', 'r13.3' );
506 ok( $neworth, 'Relationship was made between indirectly linked siblings' );
508 is( $neworth->type, 'orthographic', 'Implicit direct relationship has the correct type' );
511 # Test 5.3: make an intermediate (spelling) link to the remaining node
512 $c5->add_relationship( 'r13.4', 'r13.2', { type => 'spelling', propagate => 1 } );
513 # Should be linked grammatically to 12.1, spelling-wise to the rest
514 my $newgram = $c5->get_relationship( 'r13.4', 'r13.1' );
515 ok( $newgram, 'Relationship was made between indirectly linked readings' );
517 is( $newgram->type, 'grammatical', 'Implicit intermediate-out relationship has the correct type' );
519 foreach my $rdg ( qw/ r13.3 r13.5 / ) {
520 my $newspel = $c5->get_relationship( 'r13.4', $rdg );
521 ok( $newspel, 'Relationship was made between indirectly linked readings' );
523 is( $newspel->type, 'spelling', 'Implicit intermediate-in relationship has the correct type' );
527 # Test 5.4: delete a spelling relationship, add it again, make sure it doesn't
528 # throw and make sure all the relationships are the same
529 my $numrel = scalar $c5->relationships;
530 $c5->del_relationship( 'r13.4', 'r13.2' );
532 $c5->add_relationship( 'r13.4', 'r13.2', { type => 'spelling', propagate => 1 } );
533 ok( 1, "Managed not to throw an exception re-adding the relationship" );
534 } catch( Text::Tradition::Error $e ) {
535 ok( 0, "Threw an exception trying to re-add our intermediate relationship: " . $e->message );
537 is( $numrel, scalar $c5->relationships, "Number of relationships did not change" );
538 foreach my $rdg ( qw/ r13.2 r13.3 r13.5 / ) {
539 my $newspel = $c5->get_relationship( 'r13.4', $rdg );
540 ok( $newspel, 'Relationship was made between indirectly linked readings' );
542 is( $newspel->type, 'spelling', 'Reinstated intermediate-in relationship has the correct type' );
545 my $stillgram = $c5->get_relationship( 'r13.4', 'r13.1' );
546 ok( $stillgram, 'Relationship was made between indirectly linked readings' );
548 is( $stillgram->type, 'grammatical', 'Reinstated intermediate-out relationship has the correct type' );
551 # Test 5.5: add a parallel but not sibling relationship
552 $c5->add_relationship( 'r13.6', 'r13.2', { type => 'lexical', propagate => 1 } );
553 ok( !$c5->get_relationship( 'r13.6', 'r13.1' ),
554 "Lexical relationship did not affect grammatical" );
555 foreach my $rdg ( qw/ r13.3 r13.4 r13.5 / ) {
556 my $newlex = $c5->get_relationship( 'r13.6', $rdg );
557 ok( $newlex, 'Parallel was made between indirectly linked readings' );
559 is( $newlex->type, 'lexical', 'Implicit parallel-down relationship has the correct type' );
563 # Test 5.6: try it with non-colocated relationships
564 $numrel = scalar $c5->relationships;
565 $c5->add_relationship( 'r62.1', 'r64.1', { type => 'transposition', propagate => 1 } );
566 is( scalar $c5->relationships, $numrel+1,
567 "Adding non-colo relationship did not propagate" );
569 $c5->add_relationship( 'r61.1', 'r61.5', { type => 'orthographic' } );
570 # Add a third transposed node
571 $c5->add_relationship( 'r62.1', 'r60.3', { type => 'transposition', propagate => 1 } );
572 my $newtrans = $c5->get_relationship( 'r64.1', 'r60.3' );
573 ok( $newtrans, 'Non-colo relationship was made between indirectly linked readings' );
575 is( $newtrans->type, 'transposition', 'Implicit non-colo relationship has the correct type' );
577 is( scalar $c5->relationships, $numrel+4,
578 "Adding non-colo relationship only propagated on non-colos" );
580 # Test 5.7: ensure that attempts to cross boundaries on bindlevel-equal
581 # relationships fail.
583 $c5->add_relationship( 'r39.6', 'r41.1', { type => 'grammatical', propagate => 1 } );
584 ok( 0, "Did not prevent add of conflicting relationship level" );
585 } catch( Text::Tradition::Error $err ) {
586 like( $err->message, qr/Conflicting existing relationship/, "Got correct error message trying to add conflicting relationship level" );
589 # Test 5.8: ensure that weak relationships don't interfere
590 $c5->add_relationship( 'r50.1', 'r50.2', { type => 'collated' } );
591 $c5->add_relationship( 'r50.3', 'r50.4', { type => 'orthographic' } );
593 $c5->add_relationship( 'r50.4', 'r50.1', { type => 'grammatical', propagate => 1 } );
594 ok( 1, "Collation did not interfere with new relationship add" );
595 } catch( Text::Tradition::Error $err ) {
596 ok( 0, "Collation interfered with new relationship add: " . $err->message );
598 my $crel = $c5->get_relationship( 'r50.1', 'r50.2' );
599 ok( $crel, "Original relationship still exists" );
601 is( $crel->type, 'collated', "Original relationship still a collation" );
605 $c5->add_relationship( 'r50.1', 'r51.1', { type => 'spelling', propagate => 1 } );
606 ok( 1, "Collation did not interfere with relationship re-ranking" );
607 } catch( Text::Tradition::Error $err ) {
608 ok( 0, "Collation interfered with relationship re-ranking: " . $err->message );
610 $crel = $c5->get_relationship( 'r50.1', 'r50.2' );
611 ok( !$crel, "Collation relationship now gone" );
613 # Test 5.9: ensure that strong non-transitive relationships don't interfere
614 $c5->add_relationship( 'r66.1', 'r66.4', { type => 'grammatical' } );
615 $c5->add_relationship( 'r66.2', 'r66.4', { type => 'uncertain', propagate => 1 } );
617 $c5->add_relationship( 'r66.1', 'r66.3', { type => 'grammatical', propagate => 1 } );
618 ok( 1, "Non-transitive relationship did not block grammatical add" );
619 } catch( Text::Tradition::Error $err ) {
620 ok( 0, "Non-transitive relationship blocked grammatical add: " . $err->message );
622 is( scalar $c5->related_readings( 'r66.4' ), 3, "Reading 66.4 has all its links" );
623 is( scalar $c5->related_readings( 'r66.2' ), 1, "Reading 66.2 has only one link" );
624 is( scalar $c5->related_readings( 'r66.1' ), 2, "Reading 66.1 has all its links" );
625 is( scalar $c5->related_readings( 'r66.3' ), 2, "Reading 66.3 has all its links" );
631 sub add_relationship {
632 my( $self, $source, $target, $options ) = @_;
633 my $c = $self->collation;
634 my $sourceobj = $c->reading( $source );
635 my $targetobj = $c->reading( $target );
636 throw( "Adding self relationship at $source" ) if $source eq $target;
637 throw( "Cannot set relationship on a meta reading" )
638 if( $sourceobj->is_meta || $targetobj->is_meta );
641 my $thispaironly = delete $options->{thispaironly};
642 my $propagate = delete $options->{propagate};
643 my $droppedcolls = [];
644 if( ref( $options ) eq 'Text::Tradition::Collation::Relationship' ) {
645 $relationship = $options;
646 $reltype = $self->type( $relationship->type );
647 $thispaironly = 1; # If existing rel, set only where asked.
649 my( $is_valid, $reason ) = $self->relationship_valid( $source, $target,
650 $relationship->type, $droppedcolls );
651 unless( $is_valid ) {
652 throw( "Invalid relationship: $reason" );
655 $reltype = $self->type( $options->{type} );
657 # Try to create the relationship object.
658 my $rdga = $reltype->regularize( $sourceobj );
659 my $rdgb = $reltype->regularize( $targetobj );
660 $options->{'orig_a'} = $sourceobj;
661 $options->{'orig_b'} = $targetobj;
662 $options->{'reading_a'} = $rdga;
663 $options->{'reading_b'} = $rdgb;
664 if( exists $options->{'scope'} && $options->{'scope'} ne 'local' ) {
665 # Is there a relationship with this a & b already?
666 if( $rdga eq $rdgb ) {
667 # If we have canonified to the same thing for the relationship
668 # type we want, something is wrong.
669 # NOTE we want to allow this at the local level, as a cheap means
670 # of merging readings in the UI, until we get a better means.
671 throw( "Canonifier returns identical form $rdga for this relationship type" );
674 my $otherrel = $self->scoped_relationship( $rdga, $rdgb );
675 if( $otherrel && $otherrel->type eq $options->{type}
676 && $otherrel->scope eq $options->{scope} ) {
677 # warn "Applying existing scoped relationship for $rdga / $rdgb";
678 $relationship = $otherrel;
679 } elsif( $otherrel ) {
680 throw( 'Conflicting scoped relationship '
681 . join( '/', $otherrel->type, $otherrel->scope ) . ' vs. '
682 . join( '/', $options->{type}, $options->{scope} )
683 . " for $rdga / $rdgb at $source / $target" );
686 $relationship = $self->create( $options ) unless $relationship;
687 # ... Will throw on error
689 # See if the relationship is actually valid here
690 my( $is_valid, $reason ) = $self->relationship_valid( $source, $target,
691 $options->{'type'}, $droppedcolls );
692 unless( $is_valid ) {
693 throw( "Invalid relationship: $reason" );
698 # Now set the relationship(s).
700 my $rel = $self->get_relationship( $source, $target );
702 if( $rel && $rel ne $relationship ) {
703 if( $rel->nonlocal ) {
704 throw( "Found conflicting relationship at $source - $target" );
705 } elsif( !$reltype->is_weak ) {
706 # Replace a weak relationship; leave any other sort in place.
707 my $r1ann = $rel->has_annotation ? $rel->annotation : '';
708 my $r2ann = $relationship->has_annotation ? $relationship->annotation : '';
709 unless( $rel->type eq $relationship->type && $r1ann eq $r2ann ) {
710 warn sprintf( "Not overriding local relationship %s with global %s "
711 . "set at %s -> %s (%s -> %s)", $rel->type, $relationship->type,
712 $source, $target, $rel->reading_a, $rel->reading_b );
717 $self->_set_relationship( $relationship, $source, $target ) unless $skip;
718 push( @pairs_set, [ $source, $target, $relationship->type ] );
720 # Find all the pairs for which we need to set the relationship.
721 if( $relationship->colocated && $relationship->nonlocal && !$thispaironly ) {
722 my @global_set = $self->add_global_relationship( $relationship );
723 push( @pairs_set, @global_set );
727 foreach my $ps ( @pairs_set ) {
728 my @extra = $self->propagate_relationship( $ps->[0], $ps->[1] );
729 push( @prop, @extra );
731 push( @pairs_set, @prop ) if @prop;
734 # Finally, restore whatever collations we can, and return.
735 $self->_restore_weak( @$droppedcolls );
739 =head2 add_global_relationship( $options, $skipvector )
741 Adds the relationship specified wherever the relevant readings appear together
742 in the graph. Options as in add_relationship above.
746 sub add_global_relationship {
747 my( $self, $relationship ) = @_;
749 my $reltype = $self->type( $relationship->type );
750 throw( "Relationship passed to add_global is not global" )
751 unless $relationship->nonlocal;
752 throw( "Relationship passed to add_global is not a valid global type" )
753 unless $reltype->is_generalizable;
755 # Apply the relationship wherever it is valid
757 foreach my $v ( $self->_find_applicable( $relationship ) ) {
758 my $exists = $self->get_relationship( @$v );
759 my $etype = $exists ? $self->type( $exists->type ) : '';
760 if( $exists && !$etype->is_weak ) {
761 unless( $exists->is_equivalent( $relationship ) ) {
762 throw( "Found conflicting relationship at @$v" );
767 @added = $self->add_relationship( @$v, $relationship );
769 my $reldesc = sprintf( "%s %s -> %s", $relationship->type,
770 $relationship->reading_a, $relationship->reading_b );
771 # print STDERR "Global relationship $reldesc not applicable at @$v\n";
773 push( @pairs_set, @added ) if @added;
780 =head2 del_scoped_relationship( $reading_a, $reading_b )
782 Returns the general (document-level or global) relationship that has been defined
783 between the two reading strings. Returns undef if there is no general relationship.
787 sub del_scoped_relationship {
788 my( $self, $rdga, $rdgb ) = @_;
789 my( $first, $second ) = sort( $rdga, $rdgb );
790 return delete $self->scopedrels->{$first}->{$second};
793 sub _find_applicable {
794 my( $self, $rel ) = @_;
795 my $c = $self->collation;
796 my $reltype = $self->type( $rel->type );
798 my @identical_readings;
799 @identical_readings = grep { $reltype->regularize( $_ ) eq $rel->reading_a }
801 foreach my $ir ( @identical_readings ) {
803 @itarget = grep { $reltype->regularize( $_ ) eq $rel->reading_b }
804 $c->readings_at_rank( $ir->rank );
806 # Warn if there is more than one hit with no closer link between them.
807 my $itmain = shift @itarget;
810 my $bindlevel = $reltype->bindlevel;
811 map { $all_targets{$_} = 1 } @itarget;
812 map { delete $all_targets{$_} }
813 $self->related_readings( $itmain, sub {
814 $self->type( $_[0]->type )->bindlevel < $bindlevel } );
815 warn "More than one unrelated reading with text " . $itmain->text
816 . " at rank " . $ir->rank . "!" if keys %all_targets;
818 push( @vectors, [ $ir->id, $itmain->id ] );
824 =head2 del_relationship( $source, $target )
826 Removes the relationship between the given readings. If the relationship is
827 non-local, removes the relationship everywhere in the graph.
831 sub del_relationship {
832 my( $self, $source, $target ) = @_;
833 my $rel = $self->get_relationship( $source, $target );
834 return () unless $rel; # Nothing to delete; return an empty set.
835 my $reltype = $self->type( $rel->type );
836 my $colo = $rel->colocated;
837 my @vectors = ( [ $source, $target ] );
838 $self->_remove_relationship( $colo, $source, $target );
839 if( $rel->nonlocal ) {
840 # Remove the relationship wherever it occurs.
841 my @rel_edges = grep { $self->get_relationship( @$_ ) eq $rel }
842 $self->relationships;
843 foreach my $re ( @rel_edges ) {
844 $self->_remove_relationship( $colo, @$re );
845 push( @vectors, $re );
847 $self->del_scoped_relationship( $rel->reading_a, $rel->reading_b );
852 sub _remove_relationship {
853 my( $self, $equiv, @vector ) = @_;
854 $self->graph->delete_edge( @vector );
855 $self->_break_equivalence( @vector ) if $equiv;
858 =head2 relationship_valid( $source, $target, $type )
860 Checks whether a relationship of type $type may exist between the readings given
861 in $source and $target. Returns a tuple of ( status, message ) where status is
862 a yes/no boolean and, if the answer is no, message gives the reason why.
866 sub relationship_valid {
867 my( $self, $source, $target, $rel, $mustdrop ) = @_;
868 $mustdrop = [] unless $mustdrop; # in case we were passed nothing
869 my $c = $self->collation;
870 my $reltype = $self->type( $rel );
871 ## Assume validity is okay if we are initializing from scratch.
872 return ( 1, "initializing" ) unless $c->tradition->_initialized;
873 ## TODO Move this block to relationship type definition when we can save
875 if ( $rel eq 'transposition' || $rel eq 'repetition' ) {
876 # Check that the two readings do (for a repetition) or do not (for
877 # a transposition) appear in the same witness.
878 # TODO this might be called before witness paths are set...
880 map { $seen_wits{$_} = 1 } $c->reading_witnesses( $source );
881 foreach my $w ( $c->reading_witnesses( $target ) ) {
882 if( $seen_wits{$w} ) {
883 return ( 0, "Readings both occur in witness $w" )
884 if $rel eq 'transposition';
885 return ( 1, "ok" ) if $rel eq 'repetition';
888 return ( 0, "Readings occur only in distinct witnesses" )
889 if $rel eq 'repetition';
891 if ( $reltype->is_colocation ) {
892 # Check that linking the source and target in a relationship won't lead
893 # to a path loop for any witness.
894 # First, drop/stash any collations that might interfere
895 my $sourceobj = $c->reading( $source );
896 my $targetobj = $c->reading( $target );
897 my $sourcerank = $sourceobj->has_rank ? $sourceobj->rank : -1;
898 my $targetrank = $targetobj->has_rank ? $targetobj->rank : -1;
899 unless( $rel eq 'collated' || $sourcerank == $targetrank ) {
900 push( @$mustdrop, $self->_drop_weak( $source ) );
901 push( @$mustdrop, $self->_drop_weak( $target ) );
902 if( $c->end->has_rank ) {
903 foreach my $rk ( $sourcerank .. $targetrank ) {
904 map { push( @$mustdrop, $self->_drop_weak( $_->id ) ) }
905 $c->readings_at_rank( $rk );
909 unless( $self->test_equivalence( $source, $target ) ) {
910 $self->_restore_weak( @$mustdrop );
911 return( 0, "Relationship would create witness loop" );
915 # We also need to check that the readings are not in the same place.
916 # That is, proposing to equate them should cause a witness loop.
917 if( $self->test_equivalence( $source, $target ) ) {
918 return ( 0, "Readings appear to be colocated" );
926 my( $self, $reading ) = @_;
928 foreach my $n ( $self->graph->neighbors( $reading ) ) {
929 my $nrel = $self->get_relationship( $reading, $n );
930 if( $self->type( $nrel->type )->is_weak ) {
931 push( @dropped, [ $reading, $n, $nrel->type ] );
932 $self->del_relationship( $reading, $n );
933 #print STDERR "Dropped weak relationship $reading -> $n\n";
940 my( $self, @vectors ) = @_;
941 foreach my $v ( @vectors ) {
944 $self->add_relationship( @$v, { 'type' => $type } );
945 #print STDERR "Restored weak relationship @$v\n";
946 }; # if it fails we don't care
950 =head2 verify_or_delete( $reading1, $reading2 ) {
952 Given the existing relationship at ( $reading1, $reading2 ), make sure it is
953 still valid. If it is not still valid, delete it. Use this only to check
954 non-colocated relationships!
958 sub verify_or_delete {
959 my( $self, @vector ) = @_;
960 my $rel = $self->get_relationship( @vector );
961 throw( "You should not now be verifying colocated relationships!" )
963 my( $ok, $reason ) = $self->relationship_valid( @vector, $rel->type );
965 $self->del_relationship( @vector );
970 =head2 related_readings( $reading, $filter )
972 Returns a list of readings that are connected via direct relationship links
973 to $reading. If $filter is set to a subroutine ref, returns only those
974 related readings where $filter( $relationship ) returns a true value.
978 sub related_readings {
979 my( $self, $reading, $filter ) = @_;
981 if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
982 $reading = $reading->id;
988 if( $filter eq 'colocated' ) {
989 $filter = sub { $_[0]->colocated };
990 } elsif( !ref( $filter ) ) {
992 $filter = sub { $_[0]->type eq $type };
994 @answer = grep { &$filter( $self->get_relationship( $reading, $_ ) ) }
995 $self->graph->neighbors( $reading );
997 @answer = $self->graph->neighbors( $reading );
999 if( $return_object ) {
1000 my $c = $self->collation;
1001 return map { $c->reading( $_ ) } @answer;
1007 =head2 propagate_relationship( $rel )
1009 Apply the transitivity and binding level rules to propagate the consequences of
1010 the specified relationship link, ensuring all consequent relationships exist.
1011 For now, we only propagate colocation links if we are passed a colocation, and
1012 we only propagate displacement links if we are given a displacement.
1014 Returns an array of tuples ( rdg1, rdg2, type ) for each new reading set.
1018 sub propagate_relationship {
1019 my( $self, @rel ) = @_;
1020 ## Check that the vector is an arrayref
1021 my $rel = @rel > 1 ? \@rel : $rel[0];
1022 ## Get the relationship info
1023 my $relobj = $self->get_relationship( $rel );
1024 my $reltype = $self->type( $relobj->type );
1025 return () unless $reltype->is_transitive;
1028 my $colo = $reltype->is_colocation;
1029 my $bindlevel = $reltype->bindlevel;
1031 ## Find all readings that are linked via this relationship type
1032 my %thislevel = ( $rel->[0] => 1, $rel->[1] => 1 );
1037 foreach my $r ( @$check ) {
1038 push( @$more, grep { !exists $thislevel{$_}
1039 && $self->get_relationship( $r, $_ )
1040 && $self->get_relationship( $r, $_ )->type eq $relobj->type }
1041 $self->graph->neighbors( $r ) );
1043 map { $thislevel{$_} = 1 } @$more;
1047 ## Make sure every reading of our relationship type is linked to every other
1048 my @samelevel = keys %thislevel;
1049 while( @samelevel ) {
1050 my $r = shift @samelevel;
1051 foreach my $nr ( @samelevel ) {
1052 my $existing = $self->get_relationship( $r, $nr );
1055 my $extype = $self->type( $existing->type );
1056 unless( $extype->is_weak ) {
1057 # Check that it's a matching type, or a type subsumed by our
1059 throw( "Conflicting existing relationship of type "
1060 . $existing->type . " at $r, $nr trying to propagate "
1061 . $relobj->type . " relationship at @$rel" )
1062 unless $existing->type eq $relobj->type
1063 || $extype->bindlevel <= $reltype->bindlevel;
1068 # Try to add a new relationship here
1070 my @new = $self->add_relationship( $r, $nr, { type => $relobj->type,
1071 annotation => "Propagated from relationship at @$rel" } );
1072 push( @newly_set, @new );
1073 } catch ( Text::Tradition::Error $e ) {
1074 throw( "Could not propagate " . $relobj->type .
1075 " relationship (original @$rel) at $r -- $nr: " .
1081 ## Now for each sibling our set, look for its direct connections to
1082 ## transitive readings of a different bindlevel, and make sure that
1083 ## all siblings are related to those readings.
1085 foreach my $n ( $self->graph->neighbors( $r ) ) {
1086 my $crel = $self->get_relationship( $r, $n );
1088 my $crt = $self->type( $crel->type );
1089 if( $crt->is_transitive && $crt->is_colocation == $colo ) {
1090 next if $crt->bindlevel == $reltype->bindlevel;
1091 my $nrel = $crt->bindlevel < $reltype->bindlevel
1092 ? $reltype->name : $crt->name;
1093 push( @other, [ $n, $nrel ] );
1096 # The @other array now contains tuples of ( reading, type ) where the
1097 # reading is the non-sibling and the type is the type of relationship
1098 # that the siblings should have to the non-sibling.
1099 foreach ( @other ) {
1100 my( $nr, $nrtype ) = @$_;
1101 foreach my $sib ( keys %thislevel ) {
1103 next if $sib eq $nr; # can happen if linked to $r by tightrel
1104 # but linked to a sib of $r by thisrel
1105 # e.g. when a rel has been part propagated
1106 my $existing = $self->get_relationship( $sib, $nr );
1109 # Check that it's compatible. The existing relationship type
1110 # should match or be subsumed by the looser of the two
1111 # relationships in play, whether the original relationship
1112 # being worked on or the relationship between $r and $or.
1113 my $extype = $self->type( $existing->type );
1114 unless( $extype->is_weak ) {
1115 if( $nrtype ne $extype->name
1116 && $self->type( $nrtype )->bindlevel <= $extype->bindlevel ) {
1117 throw( "Conflicting existing relationship at $nr ( -> "
1118 . $self->get_relationship( $nr, $r )->type . " to $r) "
1119 . " -- $sib trying to propagate " . $relobj->type
1120 . " relationship at @$rel" );
1126 # Try to add a new relationship here
1128 my @new = $self->add_relationship( $sib, $nr, { type => $nrtype,
1129 annotation => "Propagated from relationship at @$rel" } );
1130 push( @newly_set, @new );
1131 } catch ( Text::Tradition::Error $e ) {
1132 throw( "Could not propagate $nrtype relationship (original " .
1133 $relobj->type . " at @$rel) at $sib -- $nr: " .
1144 =head2 propagate_all_relationships
1146 Apply propagation logic retroactively to all relationships in the tradition.
1150 sub propagate_all_relationships {
1152 my @allrels = sort { $self->_propagate_rel_order( $a, $b ) } $self->relationships;
1153 foreach my $rel ( @allrels ) {
1154 my $relobj = $self->get_relationship( $rel );
1155 if( $self->type( $relobj->type )->is_transitive ) {
1156 my @added = $self->propagate_relationship( $rel );
1161 # Helper sorting function for retroactive propagation order.
1162 sub _propagate_rel_order {
1163 my( $self, $a, $b ) = @_;
1164 my $aobj = $self->get_relationship( $a );
1165 my $bobj = $self->get_relationship( $b );
1166 my $at = $self->type( $aobj->type ); my $bt = $self->type( $bobj->type );
1167 # Apply strong relationships before weak
1168 return -1 if $bt->is_weak && !$at->is_weak;
1169 return 1 if $at->is_weak && !$bt->is_weak;
1170 # Apply more tightly bound relationships first
1171 return $at->bindlevel <=> $bt->bindlevel;
1175 =head2 merge_readings( $kept, $deleted );
1177 Makes a best-effort merge of the relationship links between the given readings, and
1178 stops tracking the to-be-deleted reading.
1182 sub merge_readings {
1183 my( $self, $kept, $deleted, $combined ) = @_;
1184 foreach my $edge ( $self->graph->edges_at( $deleted ) ) {
1185 # Get the pair of kept / rel
1186 my @vector = ( $kept );
1187 push( @vector, $edge->[0] eq $deleted ? $edge->[1] : $edge->[0] );
1188 next if $vector[0] eq $vector[1]; # Don't add a self loop
1190 # If kept changes its text, drop the relationship.
1193 # If kept / rel already has a relationship, just keep the old
1194 my $rel = $self->get_relationship( @vector );
1197 # Otherwise, adopt the relationship that would be deleted.
1198 $rel = $self->get_relationship( @$edge );
1199 $self->_set_relationship( $rel, @vector );
1201 $self->_make_equivalence( $deleted, $kept );
1204 ### Equivalence logic
1206 sub _remove_equivalence_node {
1207 my( $self, $node ) = @_;
1208 my $group = $self->equivalence( $node );
1209 my $nodelist = $self->eqreadings( $group );
1210 if( @$nodelist == 1 && $nodelist->[0] eq $node ) {
1211 $self->equivalence_graph->delete_vertex( $group );
1212 $self->remove_eqreadings( $group );
1213 $self->remove_equivalence( $group );
1214 } elsif( @$nodelist == 1 ) {
1215 throw( "DATA INCONSISTENCY in equivalence graph: " . $nodelist->[0] .
1216 " in group that should have only $node" );
1218 my @newlist = grep { $_ ne $node } @$nodelist;
1219 $self->set_eqreadings( $group, \@newlist );
1220 $self->remove_equivalence( $node );
1224 =head2 add_equivalence_edge
1226 Add an edge in the equivalence graph corresponding to $source -> $target in the
1227 collation. Should only be called by Collation.
1231 sub add_equivalence_edge {
1232 my( $self, $source, $target ) = @_;
1233 my $seq = $self->equivalence( $source );
1234 my $teq = $self->equivalence( $target );
1235 $self->equivalence_graph->add_edge( $seq, $teq );
1238 =head2 delete_equivalence_edge
1240 Remove an edge in the equivalence graph corresponding to $source -> $target in the
1241 collation. Should only be called by Collation.
1245 sub delete_equivalence_edge {
1246 my( $self, $source, $target ) = @_;
1247 my $seq = $self->equivalence( $source );
1248 my $teq = $self->equivalence( $target );
1249 $self->equivalence_graph->delete_edge( $seq, $teq );
1252 sub _is_disconnected {
1254 return( scalar $self->equivalence_graph->predecessorless_vertices > 1
1255 || scalar $self->equivalence_graph->successorless_vertices > 1 );
1258 # Equate two readings in the equivalence graph
1259 sub _make_equivalence {
1260 my( $self, $source, $target ) = @_;
1261 # Get the source equivalent readings
1262 my $seq = $self->equivalence( $source );
1263 my $teq = $self->equivalence( $target );
1264 # Nothing to do if they are already equivalent...
1265 return if $seq eq $teq;
1266 my $sourcepool = $self->eqreadings( $seq );
1267 # and add them to the target readings.
1268 push( @{$self->eqreadings( $teq )}, @$sourcepool );
1269 map { $self->set_equivalence( $_, $teq ) } @$sourcepool;
1270 # Then merge the nodes in the equivalence graph.
1271 foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
1272 $self->equivalence_graph->add_edge( $pred, $teq );
1274 foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
1275 $self->equivalence_graph->add_edge( $teq, $succ );
1277 $self->equivalence_graph->delete_vertex( $seq );
1278 # TODO enable this after collation parsing is done
1279 throw( "Graph got disconnected making $source / $target equivalence" )
1280 if $self->_is_disconnected && $self->collation->tradition->_initialized;
1283 =head2 test_equivalence
1285 Test whether, if two readings were equated with a 'colocated' relationship,
1286 the graph would still be valid.
1290 # TODO Used the 'is_reachable' method; it killed performance. Think about doing away
1291 # with the equivalence graph in favor of a transitive closure graph (calculated ONCE)
1292 # on the sequence graph, and test that way.
1294 sub test_equivalence {
1295 my( $self, $source, $target ) = @_;
1296 # Try merging the nodes in the equivalence graph; return a true value if
1297 # no cycle is introduced thereby. Restore the original graph first.
1299 # Keep track of edges we add
1302 # Get the reading equivalents
1303 my $seq = $self->equivalence( $source );
1304 my $teq = $self->equivalence( $target );
1305 # Maybe this is easy?
1306 return 1 if $seq eq $teq;
1308 # Save the first graph
1309 my $checkstr = $self->equivalence_graph->stringify();
1310 # Add and save relevant edges
1311 foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
1312 if( $self->equivalence_graph->has_edge( $pred, $teq ) ) {
1313 $added_pred{$pred} = 0;
1315 $self->equivalence_graph->add_edge( $pred, $teq );
1316 $added_pred{$pred} = 1;
1319 foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
1320 if( $self->equivalence_graph->has_edge( $teq, $succ ) ) {
1321 $added_succ{$succ} = 0;
1323 $self->equivalence_graph->add_edge( $teq, $succ );
1324 $added_succ{$succ} = 1;
1327 # Delete source equivalent and test
1328 $self->equivalence_graph->delete_vertex( $seq );
1329 my $ret = !$self->equivalence_graph->has_a_cycle;
1331 # Restore what we changed
1332 $self->equivalence_graph->add_vertex( $seq );
1333 foreach my $pred ( keys %added_pred ) {
1334 $self->equivalence_graph->add_edge( $pred, $seq );
1335 $self->equivalence_graph->delete_edge( $pred, $teq ) if $added_pred{$pred};
1337 foreach my $succ ( keys %added_succ ) {
1338 $self->equivalence_graph->add_edge( $seq, $succ );
1339 $self->equivalence_graph->delete_edge( $teq, $succ ) if $added_succ{$succ};
1341 unless( $self->equivalence_graph->eq( $checkstr ) ) {
1342 throw( "GRAPH CHANGED after testing" );
1348 # Unmake an equivalence link between two readings. Should only be called internally.
1349 sub _break_equivalence {
1350 my( $self, $source, $target ) = @_;
1352 # This is the hard one. Need to reconstruct the equivalence groups without
1355 map { $sng{$_} = 1 } $self->_find_equiv_without( $source, $target );
1356 map { $tng{$_} = 1 } $self->_find_equiv_without( $target, $source );
1357 # If these groups intersect, they are still connected; do nothing.
1358 foreach my $el ( keys %tng ) {
1359 return if( exists $sng{$el} );
1361 # If they don't intersect, then we split the nodes in the graph and in
1362 # the hashes. First figure out which group has which name
1363 my $oldgroup = $self->equivalence( $source ); # same as $target
1364 my $keepsource = $sng{$oldgroup};
1365 my $newgroup = $keepsource ? $target : $source;
1366 my( $oldmembers, $newmembers );
1368 $oldmembers = [ keys %sng ];
1369 $newmembers = [ keys %tng ];
1371 $oldmembers = [ keys %tng ];
1372 $newmembers = [ keys %sng ];
1375 # First alter the old group in the hash
1376 $self->set_eqreadings( $oldgroup, $oldmembers );
1377 foreach my $el ( @$oldmembers ) {
1378 $self->set_equivalence( $el, $oldgroup );
1381 # then add the new group back to the hash with its new key
1382 $self->set_eqreadings( $newgroup, $newmembers );
1383 foreach my $el ( @$newmembers ) {
1384 $self->set_equivalence( $el, $newgroup );
1387 # Now add the new group back to the equivalence graph
1388 $self->equivalence_graph->add_vertex( $newgroup );
1389 # ...add the appropriate edges to the source group vertext
1390 my $c = $self->collation;
1391 foreach my $rdg ( @$newmembers ) {
1392 foreach my $rp ( $c->sequence->predecessors( $rdg ) ) {
1393 next unless $self->equivalence( $rp );
1394 $self->equivalence_graph->add_edge( $self->equivalence( $rp ), $newgroup );
1396 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
1397 next unless $self->equivalence( $rs );
1398 $self->equivalence_graph->add_edge( $newgroup, $self->equivalence( $rs ) );
1402 # ...and figure out which edges on the old group vertex to delete.
1403 my( %old_pred, %old_succ );
1404 foreach my $rdg ( @$oldmembers ) {
1405 foreach my $rp ( $c->sequence->predecessors( $rdg ) ) {
1406 next unless $self->equivalence( $rp );
1407 $old_pred{$self->equivalence( $rp )} = 1;
1409 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
1410 next unless $self->equivalence( $rs );
1411 $old_succ{$self->equivalence( $rs )} = 1;
1414 foreach my $p ( $self->equivalence_graph->predecessors( $oldgroup ) ) {
1415 unless( $old_pred{$p} ) {
1416 $self->equivalence_graph->delete_edge( $p, $oldgroup );
1419 foreach my $s ( $self->equivalence_graph->successors( $oldgroup ) ) {
1420 unless( $old_succ{$s} ) {
1421 $self->equivalence_graph->delete_edge( $oldgroup, $s );
1424 # TODO enable this after collation parsing is done
1425 throw( "Graph got disconnected breaking $source / $target equivalence" )
1426 if $self->_is_disconnected && $self->collation->tradition->_initialized;
1429 sub _find_equiv_without {
1430 my( $self, $first, $second ) = @_;
1431 my %found = ( $first => 1 );
1432 my $check = [ $first ];
1436 foreach my $r ( @$check ) {
1437 foreach my $nr ( $self->graph->neighbors( $r ) ) {
1438 next if $r eq $second;
1439 if( $self->get_relationship( $r, $nr )->colocated ) {
1440 push( @$more, $nr ) unless exists $found{$nr};
1450 =head2 rebuild_equivalence
1452 (Re)build the equivalence graph from scratch. Dumps the graph, makes a new one,
1453 adds all readings and edges, then makes an equivalence for all relationships.
1457 sub rebuild_equivalence {
1459 my $newgraph = Graph->new();
1460 # Set this as the new equivalence graph
1461 $self->_reset_equivalence( $newgraph );
1462 # Clear out the data hashes
1463 $self->_clear_equivalence;
1464 $self->_clear_eqreadings;
1466 $self->collation->tradition->_init_done(0);
1468 foreach my $r ( $self->collation->readings ) {
1470 $newgraph->add_vertex( $rid );
1471 $self->set_equivalence( $rid, $rid );
1472 $self->set_eqreadings( $rid, [ $rid ] );
1476 foreach my $e ( $self->collation->paths ) {
1477 $self->add_equivalence_edge( @$e );
1480 # Now equate the colocated readings. This does no testing;
1481 # it assumes that all preexisting relationships are valid.
1482 foreach my $rel ( $self->relationships ) {
1483 my $relobj = $self->get_relationship( $rel );
1484 next unless $relobj && $relobj->colocated;
1485 $self->_make_equivalence( @$rel );
1487 $self->collation->tradition->_init_done(1);
1490 =head2 equivalence_ranks
1492 Rank all vertices in the equivalence graph, and return a hash reference with
1493 vertex => rank mapping.
1497 sub equivalence_ranks {
1499 my $eqstart = $self->equivalence( $self->collation->start );
1500 my $eqranks = { $eqstart => 0 };
1501 my $rankeqs = { 0 => [ $eqstart ] };
1502 my @curr_origin = ( $eqstart );
1503 # A little iterative function.
1504 while( @curr_origin ) {
1505 @curr_origin = $self->_assign_rank( $eqranks, $rankeqs, @curr_origin );
1507 return( $eqranks, $rankeqs );
1511 my( $self, $node_ranks, $rank_nodes, @current_nodes ) = @_;
1512 my $graph = $self->equivalence_graph;
1513 # Look at each of the children of @current_nodes. If all the child's
1514 # parents have a rank, assign it the highest rank + 1 and add it to
1515 # @next_nodes. Otherwise skip it; we will return when the highest-ranked
1516 # parent gets a rank.
1518 foreach my $c ( @current_nodes ) {
1519 warn "Current reading $c has no rank!"
1520 unless exists $node_ranks->{$c};
1521 foreach my $child ( $graph->successors( $c ) ) {
1522 next if exists $node_ranks->{$child};
1523 my $highest_rank = -1;
1525 foreach my $parent ( $graph->predecessors( $child ) ) {
1526 if( exists $node_ranks->{$parent} ) {
1527 $highest_rank = $node_ranks->{$parent}
1528 if $highest_rank <= $node_ranks->{$parent};
1535 my $c_rank = $highest_rank + 1;
1536 # print STDERR "Assigning rank $c_rank to node $child \n";
1537 $node_ranks->{$child} = $c_rank if $node_ranks;
1538 push( @{$rank_nodes->{$c_rank}}, $child ) if $rank_nodes;
1539 push( @next_nodes, $child );
1548 my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_;
1550 my $rgraph = $xmlroot->addNewChild( $graphml_ns, 'graph' );
1551 $rgraph->setAttribute( 'edgedefault', 'directed' );
1552 $rgraph->setAttribute( 'id', 'relationships', );
1553 $rgraph->setAttribute( 'parse.edgeids', 'canonical' );
1554 $rgraph->setAttribute( 'parse.edges', 0 );
1555 $rgraph->setAttribute( 'parse.nodeids', 'canonical' );
1556 $rgraph->setAttribute( 'parse.nodes', 0 );
1557 $rgraph->setAttribute( 'parse.order', 'nodesfirst' );
1559 # Add the vertices according to their XML IDs
1560 my %rdg_lookup = ( reverse %$node_hash );
1561 # my @nlist = sort _by_xmlid keys( %rdg_lookup ); ## CAUSES SEGFAULT
1562 my @nlist = sort keys( %rdg_lookup );
1563 foreach my $n ( @nlist ) {
1564 my $n_el = $rgraph->addNewChild( $graphml_ns, 'node' );
1565 $n_el->setAttribute( 'id', $n );
1566 _add_graphml_data( $n_el, $nodeid_key, $rdg_lookup{$n} );
1568 $rgraph->setAttribute( 'parse.nodes', scalar @nlist );
1570 # Add the relationship edges, with their object information
1572 foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->graph->edges ) {
1573 # Add an edge and fill in its relationship info.
1574 next unless( exists $node_hash->{$e->[0]} && exists $node_hash->{$e->[1]} );
1575 my $edge_el = $rgraph->addNewChild( $graphml_ns, 'edge' );
1576 $edge_el->setAttribute( 'source', $node_hash->{$e->[0]} );
1577 $edge_el->setAttribute( 'target', $node_hash->{$e->[1]} );
1578 $edge_el->setAttribute( 'id', 'e'.$edge_ctr++ );
1580 my $rel_obj = $self->get_relationship( @$e );
1581 foreach my $key ( keys %$edge_keys ) {
1582 my $value = $rel_obj->$key;
1583 _add_graphml_data( $edge_el, $edge_keys->{$key}, $value )
1587 $rgraph->setAttribute( 'parse.edges', $edge_ctr );
1595 return $tmp_a <=> $tmp_b;
1598 sub _add_graphml_data {
1599 my( $el, $key, $value ) = @_;
1600 return unless defined $value;
1601 my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
1602 $data_el->setAttribute( 'key', $key );
1603 $data_el->appendText( $value );
1607 my( $self, $from, $to ) = @_;
1608 open( DUMP, ">debug.svg" ) or die "Could not open debug.svg";
1609 binmode DUMP, ':utf8';
1610 print DUMP $self->collation->as_svg({ from => $from, to => $to, nocalc => 1 });
1615 Text::Tradition::Error->throw(
1616 'ident' => 'Relationship error',
1622 __PACKAGE__->meta->make_immutable;