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', 1 );
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" );
55 my @v4 = $c->add_relationship( 'n24', 'n23',
56 { 'type' => 'spelling', 'scope' => 'global' } );
57 is( @v4, 2, "Re-added global relationship" );
58 @v4 = $c->del_relationship( 'n12', 'n13' );
59 is( @v4, 1, "Only specified relationship deleted this time" );
60 ok( $c->get_relationship( 'n24', 'n23' ), "Other globally-added relationship exists" );
66 =head2 new( collation => $collation );
68 Creates a new relationship store for the given collation.
74 isa => 'Text::Tradition::Collation',
81 Registry of possible relationship types. See RelationshipType for more info.
85 has 'relationship_types' => (
99 isa => 'HashRef[HashRef[Text::Tradition::Collation::Relationship]]',
100 default => sub { {} },
106 default => sub { Graph->new( undirected => 1 ) },
108 relationships => 'edges',
109 add_reading => 'add_vertex',
110 delete_reading => 'delete_vertex',
114 =head2 equivalence_graph()
116 Returns an equivalence graph of the collation, in which all readings
117 related via a 'colocated' relationship are transformed into a single
118 vertex. Can be used to determine the validity of a new relationship.
122 has 'equivalence_graph' => (
125 default => sub { Graph->new() },
126 writer => '_reset_equivalence',
129 has '_node_equivalences' => (
133 equivalence => 'get',
134 set_equivalence => 'set',
135 remove_equivalence => 'delete',
136 _clear_equivalence => 'clear',
140 has '_equivalence_readings' => (
145 set_eqreadings => 'set',
146 remove_eqreadings => 'delete',
147 _clear_eqreadings => 'clear',
151 ## Build function - here we have our default set of relationship types.
156 my @DEFAULT_TYPES = (
157 { name => 'collated', bindlevel => 50, is_weak => 1, is_transitive => 0,
158 is_generalizable => 0, description => 'Internal use only' },
159 { name => 'orthographic', bindlevel => 0, use_regular => 0,
160 description => 'These are the same reading, neither unusually spelled.' },
161 { name => 'punctuation', bindlevel => 0,
162 description => 'These are the same reading apart from punctuation.' },
163 { name => 'spelling', bindlevel => 1,
164 description => 'These are the same reading, spelled differently.' },
165 { name => 'grammatical', bindlevel => 2,
166 description => 'These readings share a root (lemma), but have different parts of speech (morphologies).' },
167 { name => 'lexical', bindlevel => 2,
168 description => 'These readings share a part of speech (morphology), but have different roots (lemmata).' },
169 { name => 'uncertain', bindlevel => 0, is_transitive => 0, is_generalizable => 0,
170 use_regular => 0, description => 'These readings are related, but a clear category cannot be assigned.' },
171 { name => 'other', bindlevel => 0, is_transitive => 0, is_generalizable => 0,
172 description => 'These readings are related in a way not covered by the existing types.' },
173 { name => 'transposition', bindlevel => 50, is_colocation => 0,
174 description => 'This is the same (or nearly the same) reading in a different location.' },
175 { name => 'repetition', bindlevel => 50, is_colocation => 0, is_transitive => 0,
176 description => 'This is a reading that was repeated in one or more witnesses.' }
179 foreach my $type ( @DEFAULT_TYPES ) {
180 $self->add_type( $type );
184 around add_type => sub {
188 if( @_ == 1 && $_[0]->$_isa( 'Text::Tradition::Collation::RelationshipType' ) ) {
191 my %args = @_ == 1 ? %{$_[0]} : @_;
192 $new_type = Text::Tradition::Collation::RelationshipType->new( %args );
194 $self->$orig( $new_type->name => $new_type );
198 around add_reading => sub {
202 $self->equivalence_graph->add_vertex( @_ );
203 $self->set_equivalence( $_[0], $_[0] );
204 $self->set_eqreadings( $_[0], [ $_[0] ] );
208 around delete_reading => sub {
212 $self->_remove_equivalence_node( @_ );
216 =head2 get_relationship
218 Return the relationship object, if any, that exists between two readings.
222 sub get_relationship {
225 if( @_ == 1 && ref( $_[0] ) eq 'ARRAY' ) {
226 # Dereference the edge arrayref that was passed.
233 if( $self->graph->has_edge_attribute( @vector, 'object' ) ) {
234 $relationship = $self->graph->get_edge_attribute( @vector, 'object' );
236 return $relationship;
239 sub _set_relationship {
240 my( $self, $relationship, @vector ) = @_;
241 $self->graph->add_edge( @vector );
242 $self->graph->set_edge_attribute( @vector, 'object', $relationship );
243 $self->_make_equivalence( @vector ) if $relationship->colocated;
248 Create a new relationship with the given options and return it.
249 Warn and return undef if the relationship cannot be created.
254 my( $self, $options ) = @_;
255 # Check to see if a relationship exists between the two given readings
256 my $source = delete $options->{'orig_a'};
257 my $target = delete $options->{'orig_b'};
258 my $rel = $self->get_relationship( $source, $target );
260 if( $self->type( $rel->type )->is_weak ) {
261 # Always replace a weak relationship with a more descriptive
263 $self->del_relationship( $source, $target );
264 } elsif( $rel->type ne $options->{'type'} ) {
265 throw( "Another relationship of type " . $rel->type
266 . " already exists between $source and $target" );
272 $rel = Text::Tradition::Collation::Relationship->new( $options );
273 my $reltype = $self->type( $rel->type );
274 throw( "Unrecognized relationship type " . $rel->type ) unless $reltype;
275 # Validate the options given against the relationship type wanted
276 throw( "Cannot set nonlocal scope on relationship of type " . $reltype->name )
277 if $rel->nonlocal && !$reltype->is_generalizable;
279 $self->add_scoped_relationship( $rel ) if $rel->nonlocal;
283 =head2 add_scoped_relationship( $rel )
285 Keep track of relationships defined between specific readings that are scoped
286 non-locally. Key on whichever reading occurs first alphabetically.
290 sub add_scoped_relationship {
291 my( $self, $rel ) = @_;
292 my $rdga = $rel->reading_a;
293 my $rdgb = $rel->reading_b;
294 my $r = $self->scoped_relationship( $rdga, $rdgb );
296 warn sprintf( "Scoped relationship of type %s already exists between %s and %s",
297 $r->type, $rdga, $rdgb );
300 my( $first, $second ) = sort ( $rdga, $rdgb );
301 $self->scopedrels->{$first}->{$second} = $rel;
304 =head2 scoped_relationship( $reading_a, $reading_b )
306 Returns the general (document-level or global) relationship that has been defined
307 between the two reading strings. Returns undef if there is no general relationship.
311 sub scoped_relationship {
312 my( $self, $rdga, $rdgb ) = @_;
313 my( $first, $second ) = sort( $rdga, $rdgb );
314 if( exists $self->scopedrels->{$first}->{$second} ) {
315 return $self->scopedrels->{$first}->{$second};
320 =head2 add_relationship( $self, $source, $sourcetext, $target, $targettext, $opts )
322 Adds the relationship specified in $opts (see Text::Tradition::Collation::Relationship
323 for the possible options) between the readings given in $source and $target. Sets
324 up a scoped relationship between $sourcetext and $targettext if the relationship is
327 Returns a status boolean and a list of all reading pairs connected by the call to
338 $t1 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/legendfrag.xml' );
339 } [qr/Cannot set relationship on a meta reading/],
340 "Got expected relationship drop warning on parse";
342 # Test 1.1: try to equate nodes that are prevented with an intermediate collation
343 ok( $t1, "Parsed test fragment file" );
344 my $c1 = $t1->collation;
345 my $trel = $c1->get_relationship( 'r9.2', 'r9.3' );
346 is( ref( $trel ), 'Text::Tradition::Collation::Relationship',
347 "Troublesome relationship exists" );
348 is( $trel->type, 'collated', "Troublesome relationship is a collation" );
350 # Try to make the link we want
352 $c1->add_relationship( 'r8.6', 'r10.3', { 'type' => 'orthographic' } );
353 ok( 1, "Added cross-collation relationship as expected" );
354 } catch( Text::Tradition::Error $e ) {
355 ok( 0, "Existing collation blocked equivalence relationship: " . $e->message );
359 $c1->calculate_ranks();
360 ok( 1, "Successfully calculated ranks" );
361 } catch ( Text::Tradition::Error $e ) {
362 ok( 0, "Collation now has a cycle: " . $e->message );
365 # Test 1.2: attempt merge of an identical reading
367 $c1->merge_readings( 'r9.3', 'r11.5' );
368 ok( 1, "Successfully merged reading 'pontifex'" );
369 } catch ( Text::Tradition::Error $e ) {
370 ok( 0, "Merge of mergeable readings failed: $e->message" );
374 # Test 1.3: attempt relationship with a meta reading (should fail)
376 $c1->add_relationship( 'r8.1', 'r9.2', { 'type' => 'collated' } );
377 ok( 0, "Allowed a meta-reading to be used in a relationship" );
378 } catch ( Text::Tradition::Error $e ) {
379 is( $e->message, 'Cannot set relationship on a meta reading',
380 "Relationship link prevented for a meta reading" );
383 # Test 1.4: try to break a relationship near a meta reading
384 $c1->add_relationship( 'r7.6', 'r7.3', { type => 'orthographic' } );
386 $c1->del_relationship( 'r7.6', 'r7.7' );
387 $c1->del_relationship( 'r7.6', 'r7.3' );
388 ok( 1, "Relationship broken with a meta reading as neighbor" );
390 ok( 0, "Relationship deletion failed with a meta reading as neighbor" );
393 # Test 2.1: try to equate nodes that are prevented with a real intermediate
397 $t2 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/legendfrag.xml' );
398 } [qr/Cannot set relationship on a meta reading/],
399 "Got expected relationship drop warning on parse";
400 my $c2 = $t2->collation;
401 $c2->add_relationship( 'r9.2', 'r9.3', { 'type' => 'lexical' } );
402 my $trel2 = $c2->get_relationship( 'r9.2', 'r9.3' );
403 is( ref( $trel2 ), 'Text::Tradition::Collation::Relationship',
404 "Created blocking relationship" );
405 is( $trel2->type, 'lexical', "Blocking relationship is not a collation" );
406 # This time the link ought to fail
408 $c2->add_relationship( 'r8.6', 'r10.3', { 'type' => 'orthographic' } );
409 ok( 0, "Added cross-equivalent bad relationship" );
410 } catch ( Text::Tradition::Error $e ) {
411 like( $e->message, qr/witness loop/,
412 "Existing equivalence blocked crossing relationship" );
416 $c2->calculate_ranks();
417 ok( 1, "Successfully calculated ranks" );
418 } catch ( Text::Tradition::Error $e ) {
419 ok( 0, "Collation now has a cycle: " . $e->message );
422 # Test 3.1: make a straightforward pair of transpositions.
423 my $t3 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/lf2.xml' );
424 # Test 1: try to equate nodes that are prevented with an intermediate collation
425 my $c3 = $t3->collation;
427 $c3->add_relationship( 'r36.4', 'r38.3', { 'type' => 'transposition' } );
428 ok( 1, "Added straightforward transposition" );
429 } catch ( Text::Tradition::Error $e ) {
430 ok( 0, "Failed to add normal transposition: " . $e->message );
433 $c3->add_relationship( 'r36.3', 'r38.2', { 'type' => 'transposition' } );
434 ok( 1, "Added straightforward transposition complement" );
435 } catch ( Text::Tradition::Error $e ) {
436 ok( 0, "Failed to add normal transposition complement: " . $e->message );
439 # Test 3.2: try to make a transposition that could be a parallel.
441 $c3->add_relationship( 'r28.2', 'r29.2', { 'type' => 'transposition' } );
442 ok( 0, "Added bad colocated transposition" );
443 } catch ( Text::Tradition::Error $e ) {
444 like( $e->message, qr/Readings appear to be colocated/,
445 "Prevented bad colocated transposition" );
448 # Test 3.3: make the parallel, and then make the transposition again.
450 $c3->add_relationship( 'r28.3', 'r29.3', { 'type' => 'orthographic' } );
451 ok( 1, "Equated identical readings for transposition" );
452 } catch ( Text::Tradition::Error $e ) {
453 ok( 0, "Failed to equate identical readings: " . $e->message );
456 $c3->add_relationship( 'r28.2', 'r29.2', { 'type' => 'transposition' } );
457 ok( 1, "Added straightforward transposition complement" );
458 } catch ( Text::Tradition::Error $e ) {
459 ok( 0, "Failed to add normal transposition complement: " . $e->message );
462 # Test 4: make a global relationship that involves re-ranking a node first, when
463 # the prior rank has a potential match too
464 my $t4 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/globalrel_test.xml' );
465 my $c4 = $t4->collation;
466 # Can we even add the relationship?
468 $c4->add_relationship( 'r463.2', 'r463.4',
469 { type => 'orthographic', scope => 'global' } );
470 ok( 1, "Added global relationship without error" );
471 } catch ( Text::Tradition::Error $e ) {
472 ok( 0, "Failed to add global relationship when same-rank alternative exists: "
475 $c4->calculate_ranks();
476 # Do our readings now share a rank?
477 is( $c4->reading('r463.2')->rank, $c4->reading('r463.4')->rank,
478 "Expected readings now at same rank" );
480 # Test group 5: relationship transitivity.
481 my $t5 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/john.xml' );
482 my $c5 = $t5->collation;
483 # Test 5.0: propagate all existing transitive rels and make sure it succeeds
484 my $orignumrels = scalar $c5->relationships();
486 $c5->relations->propagate_all_relationships();
487 ok( 1, "Propagated all existing transitive relationships" );
488 } catch ( Text::Tradition::Error $err ) {
489 ok( 0, "Failed to propagate all existing relationships: " . $err->message );
491 ok( scalar( $c5->relationships ) > $orignumrels, "Added some relationships in propagation" );
493 # Test 5.1: make a grammatical link to an orthographically-linked reading
494 $c5->add_relationship( 'r13.5', 'r13.2', { type => 'orthographic' } );
495 $c5->add_relationship( 'r13.1', 'r13.2', { type => 'grammatical', propagate => 1 } );
496 my $impliedrel = $c5->get_relationship( 'r13.1', 'r13.5' );
497 ok( $impliedrel, 'Relationship was made between indirectly linked readings' );
499 is( $impliedrel->type, 'grammatical', 'Implicit inbound relationship has the correct type' );
502 # Test 5.2: make another orthographic link, see if the grammatical one propagates
503 $c5->add_relationship( 'r13.3', 'r13.5', { type => 'orthographic', propagate => 1 } );
504 foreach my $rdg ( qw/ r13.3 r13.5 / ) {
505 my $newgram = $c5->get_relationship( 'r13.1', $rdg );
506 ok( $newgram, 'Relationship was propagaged up between indirectly linked readings' );
508 is( $newgram->type, 'grammatical', 'Implicit outbound relationship has the correct type' );
511 my $neworth = $c5->get_relationship( 'r13.2', 'r13.3' );
512 ok( $neworth, 'Relationship was made between indirectly linked siblings' );
514 is( $neworth->type, 'orthographic', 'Implicit direct relationship has the correct type' );
517 # Test 5.3: make an intermediate (spelling) link to the remaining node
518 $c5->add_relationship( 'r13.4', 'r13.2', { type => 'spelling', propagate => 1 } );
519 # Should be linked grammatically to 12.1, spelling-wise to the rest
520 my $newgram = $c5->get_relationship( 'r13.4', 'r13.1' );
521 ok( $newgram, 'Relationship was made between indirectly linked readings' );
523 is( $newgram->type, 'grammatical', 'Implicit intermediate-out relationship has the correct type' );
525 foreach my $rdg ( qw/ r13.3 r13.5 / ) {
526 my $newspel = $c5->get_relationship( 'r13.4', $rdg );
527 ok( $newspel, 'Relationship was made between indirectly linked readings' );
529 is( $newspel->type, 'spelling', 'Implicit intermediate-in relationship has the correct type' );
533 # Test 5.4: delete a spelling relationship, add it again, make sure it doesn't
534 # throw and make sure all the relationships are the same
535 my $numrel = scalar $c5->relationships;
536 $c5->del_relationship( 'r13.4', 'r13.2' );
538 $c5->add_relationship( 'r13.4', 'r13.2', { type => 'spelling', propagate => 1 } );
539 ok( 1, "Managed not to throw an exception re-adding the relationship" );
540 } catch( Text::Tradition::Error $e ) {
541 ok( 0, "Threw an exception trying to re-add our intermediate relationship: " . $e->message );
543 is( $numrel, scalar $c5->relationships, "Number of relationships did not change" );
544 foreach my $rdg ( qw/ r13.2 r13.3 r13.5 / ) {
545 my $newspel = $c5->get_relationship( 'r13.4', $rdg );
546 ok( $newspel, 'Relationship was made between indirectly linked readings' );
548 is( $newspel->type, 'spelling', 'Reinstated intermediate-in relationship has the correct type' );
551 my $stillgram = $c5->get_relationship( 'r13.4', 'r13.1' );
552 ok( $stillgram, 'Relationship was made between indirectly linked readings' );
554 is( $stillgram->type, 'grammatical', 'Reinstated intermediate-out relationship has the correct type' );
557 # Test 5.5: add a parallel but not sibling relationship
558 $c5->add_relationship( 'r13.6', 'r13.2', { type => 'lexical', propagate => 1 } );
559 ok( !$c5->get_relationship( 'r13.6', 'r13.1' ),
560 "Lexical relationship did not affect grammatical" );
561 foreach my $rdg ( qw/ r13.3 r13.4 r13.5 / ) {
562 my $newlex = $c5->get_relationship( 'r13.6', $rdg );
563 ok( $newlex, 'Parallel was made between indirectly linked readings' );
565 is( $newlex->type, 'lexical', 'Implicit parallel-down relationship has the correct type' );
569 # Test 5.6: try it with non-colocated relationships
570 $numrel = scalar $c5->relationships;
571 $c5->add_relationship( 'r62.1', 'r64.1', { type => 'transposition', propagate => 1 } );
572 is( scalar $c5->relationships, $numrel+1,
573 "Adding non-colo relationship did not propagate" );
575 $c5->add_relationship( 'r61.1', 'r61.5', { type => 'orthographic' } );
576 # Add a third transposed node
577 $c5->add_relationship( 'r62.1', 'r60.3', { type => 'transposition', propagate => 1 } );
578 my $newtrans = $c5->get_relationship( 'r64.1', 'r60.3' );
579 ok( $newtrans, 'Non-colo relationship was made between indirectly linked readings' );
581 is( $newtrans->type, 'transposition', 'Implicit non-colo relationship has the correct type' );
583 is( scalar $c5->relationships, $numrel+4,
584 "Adding non-colo relationship only propagated on non-colos" );
586 # Test 5.7: ensure that attempts to cross boundaries on bindlevel-equal
587 # relationships fail.
589 $c5->add_relationship( 'r39.6', 'r41.1', { type => 'grammatical', propagate => 1 } );
590 ok( 0, "Did not prevent add of conflicting relationship level" );
591 } catch( Text::Tradition::Error $err ) {
592 like( $err->message, qr/Conflicting existing relationship/, "Got correct error message trying to add conflicting relationship level" );
595 # Test 5.8: ensure that weak relationships don't interfere
596 $c5->add_relationship( 'r50.1', 'r50.2', { type => 'collated' } );
597 $c5->add_relationship( 'r50.3', 'r50.4', { type => 'orthographic' } );
599 $c5->add_relationship( 'r50.4', 'r50.1', { type => 'grammatical', propagate => 1 } );
600 ok( 1, "Collation did not interfere with new relationship add" );
601 } catch( Text::Tradition::Error $err ) {
602 ok( 0, "Collation interfered with new relationship add: " . $err->message );
604 my $crel = $c5->get_relationship( 'r50.1', 'r50.2' );
605 ok( $crel, "Original relationship still exists" );
607 is( $crel->type, 'collated', "Original relationship still a collation" );
611 $c5->add_relationship( 'r50.1', 'r51.1', { type => 'spelling', propagate => 1 } );
612 ok( 1, "Collation did not interfere with relationship re-ranking" );
613 } catch( Text::Tradition::Error $err ) {
614 ok( 0, "Collation interfered with relationship re-ranking: " . $err->message );
616 $crel = $c5->get_relationship( 'r50.1', 'r50.2' );
617 ok( !$crel, "Collation relationship now gone" );
619 # Test 5.9: ensure that strong non-transitive relationships don't interfere
620 $c5->add_relationship( 'r66.1', 'r66.4', { type => 'grammatical' } );
621 $c5->add_relationship( 'r66.2', 'r66.4', { type => 'uncertain', propagate => 1 } );
623 $c5->add_relationship( 'r66.1', 'r66.3', { type => 'grammatical', propagate => 1 } );
624 ok( 1, "Non-transitive relationship did not block grammatical add" );
625 } catch( Text::Tradition::Error $err ) {
626 ok( 0, "Non-transitive relationship blocked grammatical add: " . $err->message );
628 is( scalar $c5->related_readings( 'r66.4' ), 3, "Reading 66.4 has all its links" );
629 is( scalar $c5->related_readings( 'r66.2' ), 1, "Reading 66.2 has only one link" );
630 is( scalar $c5->related_readings( 'r66.1' ), 2, "Reading 66.1 has all its links" );
631 is( scalar $c5->related_readings( 'r66.3' ), 2, "Reading 66.3 has all its links" );
637 sub add_relationship {
638 my( $self, $source, $target, $options ) = @_;
639 my $c = $self->collation;
640 my $sourceobj = $c->reading( $source );
641 my $targetobj = $c->reading( $target );
642 throw( "Adding self relationship at $source" ) if $source eq $target;
643 throw( "Cannot set relationship on a meta reading" )
644 if( $sourceobj->is_meta || $targetobj->is_meta );
647 my $thispaironly = delete $options->{thispaironly};
648 my $propagate = delete $options->{propagate};
649 my $droppedcolls = [];
650 if( ref( $options ) eq 'Text::Tradition::Collation::Relationship' ) {
651 $relationship = $options;
652 $reltype = $self->type( $relationship->type );
653 $thispaironly = 1; # If existing rel, set only where asked.
655 my( $is_valid, $reason ) = $self->relationship_valid( $source, $target,
656 $relationship->type, $droppedcolls );
657 unless( $is_valid ) {
658 throw( "Invalid relationship: $reason" );
661 $reltype = $self->type( $options->{type} );
663 # Try to create the relationship object.
664 my $rdga = $reltype->regularize( $sourceobj );
665 my $rdgb = $reltype->regularize( $targetobj );
666 $options->{'orig_a'} = $sourceobj;
667 $options->{'orig_b'} = $targetobj;
668 $options->{'reading_a'} = $rdga;
669 $options->{'reading_b'} = $rdgb;
670 if( exists $options->{'scope'} && $options->{'scope'} ne 'local' ) {
671 # Is there a relationship with this a & b already?
672 if( $rdga eq $rdgb ) {
673 # If we have canonified to the same thing for the relationship
674 # type we want, something is wrong.
675 # NOTE we want to allow this at the local level, as a cheap means
676 # of merging readings in the UI, until we get a better means.
677 throw( "Canonifier returns identical form $rdga for this relationship type" );
680 my $otherrel = $self->scoped_relationship( $rdga, $rdgb );
681 if( $otherrel && $otherrel->type eq $options->{type}
682 && $otherrel->scope eq $options->{scope} ) {
683 # warn "Applying existing scoped relationship for $rdga / $rdgb";
684 $relationship = $otherrel;
685 } elsif( $otherrel ) {
686 throw( 'Conflicting scoped relationship '
687 . join( '/', $otherrel->type, $otherrel->scope ) . ' vs. '
688 . join( '/', $options->{type}, $options->{scope} )
689 . " for $rdga / $rdgb at $source / $target" );
692 $relationship = $self->create( $options ) unless $relationship;
693 # ... Will throw on error
695 # See if the relationship is actually valid here
696 my( $is_valid, $reason ) = $self->relationship_valid( $source, $target,
697 $options->{'type'}, $droppedcolls );
698 unless( $is_valid ) {
699 throw( "Invalid relationship: $reason" );
704 # Now set the relationship(s).
706 my $rel = $self->get_relationship( $source, $target );
708 if( $rel && $rel ne $relationship ) {
709 if( $rel->nonlocal ) {
710 throw( "Found conflicting relationship at $source - $target" );
711 } elsif( !$reltype->is_weak ) {
712 # Replace a weak relationship; leave any other sort in place.
713 my $r1ann = $rel->has_annotation ? $rel->annotation : '';
714 my $r2ann = $relationship->has_annotation ? $relationship->annotation : '';
715 unless( $rel->type eq $relationship->type && $r1ann eq $r2ann ) {
716 warn sprintf( "Not overriding local relationship %s with global %s "
717 . "set at %s -> %s (%s -> %s)", $rel->type, $relationship->type,
718 $source, $target, $rel->reading_a, $rel->reading_b );
723 $self->_set_relationship( $relationship, $source, $target ) unless $skip;
724 push( @pairs_set, [ $source, $target, $relationship->type ] );
726 # Find all the pairs for which we need to set the relationship.
727 if( $relationship->colocated && $relationship->nonlocal && !$thispaironly ) {
728 my @global_set = $self->add_global_relationship( $relationship );
729 push( @pairs_set, @global_set );
733 foreach my $ps ( @pairs_set ) {
734 my @extra = $self->propagate_relationship( $ps->[0], $ps->[1] );
735 push( @prop, @extra );
737 push( @pairs_set, @prop ) if @prop;
740 # Finally, restore whatever collations we can, and return.
741 $self->_restore_weak( @$droppedcolls );
745 =head2 add_global_relationship( $options, $skipvector )
747 Adds the relationship specified wherever the relevant readings appear together
748 in the graph. Options as in add_relationship above.
752 sub add_global_relationship {
753 my( $self, $relationship ) = @_;
755 my $reltype = $self->type( $relationship->type );
756 throw( "Relationship passed to add_global is not global" )
757 unless $relationship->nonlocal;
758 throw( "Relationship passed to add_global is not a valid global type" )
759 unless $reltype->is_generalizable;
761 # Apply the relationship wherever it is valid
763 foreach my $v ( $self->_find_applicable( $relationship ) ) {
764 my $exists = $self->get_relationship( @$v );
765 my $etype = $exists ? $self->type( $exists->type ) : '';
766 if( $exists && !$etype->is_weak ) {
767 unless( $exists->is_equivalent( $relationship ) ) {
768 throw( "Found conflicting relationship at @$v" );
773 @added = $self->add_relationship( @$v, $relationship );
775 my $reldesc = sprintf( "%s %s -> %s", $relationship->type,
776 $relationship->reading_a, $relationship->reading_b );
777 # print STDERR "Global relationship $reldesc not applicable at @$v\n";
779 push( @pairs_set, @added ) if @added;
786 =head2 del_scoped_relationship( $reading_a, $reading_b )
788 Returns the general (document-level or global) relationship that has been defined
789 between the two reading strings. Returns undef if there is no general relationship.
793 sub del_scoped_relationship {
794 my( $self, $rdga, $rdgb ) = @_;
795 my( $first, $second ) = sort( $rdga, $rdgb );
796 return delete $self->scopedrels->{$first}->{$second};
799 sub _find_applicable {
800 my( $self, $rel ) = @_;
801 my $c = $self->collation;
802 my $reltype = $self->type( $rel->type );
804 my @identical_readings;
805 @identical_readings = grep { $reltype->regularize( $_ ) eq $rel->reading_a }
807 foreach my $ir ( @identical_readings ) {
809 @itarget = grep { $reltype->regularize( $_ ) eq $rel->reading_b }
810 $c->readings_at_rank( $ir->rank );
812 # Warn if there is more than one hit with no closer link between them.
813 my $itmain = shift @itarget;
816 my $bindlevel = $reltype->bindlevel;
817 map { $all_targets{$_} = 1 } @itarget;
818 map { delete $all_targets{$_} }
819 $self->related_readings( $itmain, sub {
820 $self->type( $_[0]->type )->bindlevel < $bindlevel } );
821 warn "More than one unrelated reading with text " . $itmain->text
822 . " at rank " . $ir->rank . "!" if keys %all_targets;
824 push( @vectors, [ $ir->id, $itmain->id ] );
830 =head2 del_relationship( $source, $target, $allscope )
832 Removes the relationship between the given readings. If the relationship is
833 non-local and $allscope is true, removes the relationship throughout the
838 sub del_relationship {
839 my( $self, $source, $target, $allscope ) = @_;
840 my $rel = $self->get_relationship( $source, $target );
841 return () unless $rel; # Nothing to delete; return an empty set.
842 my $reltype = $self->type( $rel->type );
843 my $colo = $rel->colocated;
844 my @vectors = ( [ $source, $target ] );
845 $self->_remove_relationship( $colo, $source, $target );
846 if( $rel->nonlocal && $allscope ) {
847 # Remove the relationship wherever it occurs.
848 my @rel_edges = grep { $self->get_relationship( @$_ ) eq $rel }
849 $self->relationships;
850 foreach my $re ( @rel_edges ) {
851 $self->_remove_relationship( $colo, @$re );
852 push( @vectors, $re );
854 $self->del_scoped_relationship( $rel->reading_a, $rel->reading_b );
859 sub _remove_relationship {
860 my( $self, $equiv, @vector ) = @_;
861 $self->graph->delete_edge( @vector );
862 $self->_break_equivalence( @vector ) if $equiv;
865 =head2 relationship_valid( $source, $target, $type )
867 Checks whether a relationship of type $type may exist between the readings given
868 in $source and $target. Returns a tuple of ( status, message ) where status is
869 a yes/no boolean and, if the answer is no, message gives the reason why.
873 sub relationship_valid {
874 my( $self, $source, $target, $rel, $mustdrop ) = @_;
875 $mustdrop = [] unless $mustdrop; # in case we were passed nothing
876 my $c = $self->collation;
877 my $reltype = $self->type( $rel );
878 ## Assume validity is okay if we are initializing from scratch.
879 return ( 1, "initializing" ) unless $c->tradition->_initialized;
880 ## TODO Move this block to relationship type definition when we can save
882 if ( $rel eq 'transposition' || $rel eq 'repetition' ) {
883 # Check that the two readings do (for a repetition) or do not (for
884 # a transposition) appear in the same witness.
885 # TODO this might be called before witness paths are set...
887 map { $seen_wits{$_} = 1 } $c->reading_witnesses( $source );
888 foreach my $w ( $c->reading_witnesses( $target ) ) {
889 if( $seen_wits{$w} ) {
890 return ( 0, "Readings both occur in witness $w" )
891 if $rel eq 'transposition';
892 return ( 1, "ok" ) if $rel eq 'repetition';
895 return ( 0, "Readings occur only in distinct witnesses" )
896 if $rel eq 'repetition';
898 if ( $reltype->is_colocation ) {
899 # Check that linking the source and target in a relationship won't lead
900 # to a path loop for any witness.
901 # First, drop/stash any collations that might interfere
902 my $sourceobj = $c->reading( $source );
903 my $targetobj = $c->reading( $target );
904 my $sourcerank = $sourceobj->has_rank ? $sourceobj->rank : -1;
905 my $targetrank = $targetobj->has_rank ? $targetobj->rank : -1;
906 unless( $rel eq 'collated' || $sourcerank == $targetrank ) {
907 push( @$mustdrop, $self->_drop_weak( $source ) );
908 push( @$mustdrop, $self->_drop_weak( $target ) );
909 if( $c->end->has_rank ) {
910 foreach my $rk ( $sourcerank .. $targetrank ) {
911 map { push( @$mustdrop, $self->_drop_weak( $_->id ) ) }
912 $c->readings_at_rank( $rk );
916 unless( $self->test_equivalence( $source, $target ) ) {
917 $self->_restore_weak( @$mustdrop );
918 return( 0, "Relationship would create witness loop" );
922 # We also need to check that the readings are not in the same place.
923 # That is, proposing to equate them should cause a witness loop.
924 if( $self->test_equivalence( $source, $target ) ) {
925 return ( 0, "Readings appear to be colocated" );
933 my( $self, $reading ) = @_;
935 foreach my $n ( $self->graph->neighbors( $reading ) ) {
936 my $nrel = $self->get_relationship( $reading, $n );
937 if( $self->type( $nrel->type )->is_weak ) {
938 push( @dropped, [ $reading, $n, $nrel->type ] );
939 $self->del_relationship( $reading, $n );
940 #print STDERR "Dropped weak relationship $reading -> $n\n";
947 my( $self, @vectors ) = @_;
948 foreach my $v ( @vectors ) {
951 $self->add_relationship( @$v, { 'type' => $type } );
952 #print STDERR "Restored weak relationship @$v\n";
953 }; # if it fails we don't care
957 =head2 verify_or_delete( $reading1, $reading2 ) {
959 Given the existing relationship at ( $reading1, $reading2 ), make sure it is
960 still valid. If it is not still valid, delete it. Use this only to check
961 non-colocated relationships!
965 sub verify_or_delete {
966 my( $self, @vector ) = @_;
967 my $rel = $self->get_relationship( @vector );
968 throw( "You should not now be verifying colocated relationships!" )
970 my( $ok, $reason ) = $self->relationship_valid( @vector, $rel->type );
972 $self->del_relationship( @vector );
978 =head2 related_readings( $reading, $filter )
980 Returns a list of readings that are connected via direct relationship links
981 to $reading. If $filter is set to a subroutine ref, returns only those
982 related readings where $filter( $relationship ) returns a true value.
986 sub related_readings {
987 my( $self, $reading, $filter ) = @_;
989 if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
990 $reading = $reading->id;
996 if( $filter eq 'colocated' ) {
997 $filter = sub { $_[0]->colocated };
998 } elsif( !ref( $filter ) ) {
1000 $filter = sub { $_[0]->type eq $type };
1002 @answer = grep { &$filter( $self->get_relationship( $reading, $_ ) ) }
1003 $self->graph->neighbors( $reading );
1005 @answer = $self->graph->neighbors( $reading );
1007 if( $return_object ) {
1008 my $c = $self->collation;
1009 return map { $c->reading( $_ ) } @answer;
1015 =head2 propagate_relationship( $rel )
1017 Apply the transitivity and binding level rules to propagate the consequences of
1018 the specified relationship link, ensuring all consequent relationships exist.
1019 For now, we only propagate colocation links if we are passed a colocation, and
1020 we only propagate displacement links if we are given a displacement.
1022 Returns an array of tuples ( rdg1, rdg2, type ) for each new reading set.
1026 sub propagate_relationship {
1027 my( $self, @rel ) = @_;
1028 ## Check that the vector is an arrayref
1029 my $rel = @rel > 1 ? \@rel : $rel[0];
1030 ## Get the relationship info
1031 my $relobj = $self->get_relationship( $rel );
1032 my $reltype = $self->type( $relobj->type );
1033 return () unless $reltype->is_transitive;
1036 my $colo = $reltype->is_colocation;
1037 my $bindlevel = $reltype->bindlevel;
1039 ## Find all readings that are linked via this relationship type
1040 my %thislevel = ( $rel->[0] => 1, $rel->[1] => 1 );
1045 foreach my $r ( @$check ) {
1046 push( @$more, grep { !exists $thislevel{$_}
1047 && $self->get_relationship( $r, $_ )
1048 && $self->get_relationship( $r, $_ )->type eq $relobj->type }
1049 $self->graph->neighbors( $r ) );
1051 map { $thislevel{$_} = 1 } @$more;
1055 ## Make sure every reading of our relationship type is linked to every other
1056 my @samelevel = keys %thislevel;
1057 while( @samelevel ) {
1058 my $r = shift @samelevel;
1059 foreach my $nr ( @samelevel ) {
1060 my $existing = $self->get_relationship( $r, $nr );
1063 my $extype = $self->type( $existing->type );
1064 unless( $extype->is_weak ) {
1065 # Check that it's a matching type, or a type subsumed by our
1067 throw( "Conflicting existing relationship of type "
1068 . $existing->type . " at $r, $nr trying to propagate "
1069 . $relobj->type . " relationship at @$rel" )
1070 unless $existing->type eq $relobj->type
1071 || $extype->bindlevel <= $reltype->bindlevel;
1076 # Try to add a new relationship here
1078 my @new = $self->add_relationship( $r, $nr, { type => $relobj->type,
1079 annotation => "Propagated from relationship at @$rel" } );
1080 push( @newly_set, @new );
1081 } catch ( Text::Tradition::Error $e ) {
1082 throw( "Could not propagate " . $relobj->type .
1083 " relationship (original @$rel) at $r -- $nr: " .
1089 ## Now for each sibling our set, look for its direct connections to
1090 ## transitive readings of a different bindlevel, and make sure that
1091 ## all siblings are related to those readings.
1093 foreach my $n ( $self->graph->neighbors( $r ) ) {
1094 my $crel = $self->get_relationship( $r, $n );
1096 my $crt = $self->type( $crel->type );
1097 if( $crt->is_transitive && $crt->is_colocation == $colo ) {
1098 next if $crt->bindlevel == $reltype->bindlevel;
1099 my $nrel = $crt->bindlevel < $reltype->bindlevel
1100 ? $reltype->name : $crt->name;
1101 push( @other, [ $n, $nrel ] );
1104 # The @other array now contains tuples of ( reading, type ) where the
1105 # reading is the non-sibling and the type is the type of relationship
1106 # that the siblings should have to the non-sibling.
1107 foreach ( @other ) {
1108 my( $nr, $nrtype ) = @$_;
1109 foreach my $sib ( keys %thislevel ) {
1111 next if $sib eq $nr; # can happen if linked to $r by tightrel
1112 # but linked to a sib of $r by thisrel
1113 # e.g. when a rel has been part propagated
1114 my $existing = $self->get_relationship( $sib, $nr );
1117 # Check that it's compatible. The existing relationship type
1118 # should match or be subsumed by the looser of the two
1119 # relationships in play, whether the original relationship
1120 # being worked on or the relationship between $r and $or.
1121 my $extype = $self->type( $existing->type );
1122 unless( $extype->is_weak ) {
1123 if( $nrtype ne $extype->name
1124 && $self->type( $nrtype )->bindlevel <= $extype->bindlevel ) {
1125 throw( "Conflicting existing relationship at $nr ( -> "
1126 . $self->get_relationship( $nr, $r )->type . " to $r) "
1127 . " -- $sib trying to propagate " . $relobj->type
1128 . " relationship at @$rel" );
1134 # Try to add a new relationship here
1136 my @new = $self->add_relationship( $sib, $nr, { type => $nrtype,
1137 annotation => "Propagated from relationship at @$rel" } );
1138 push( @newly_set, @new );
1139 } catch ( Text::Tradition::Error $e ) {
1140 throw( "Could not propagate $nrtype relationship (original " .
1141 $relobj->type . " at @$rel) at $sib -- $nr: " .
1152 =head2 propagate_all_relationships
1154 Apply propagation logic retroactively to all relationships in the tradition.
1158 sub propagate_all_relationships {
1160 my @allrels = sort { $self->_propagate_rel_order( $a, $b ) } $self->relationships;
1161 foreach my $rel ( @allrels ) {
1162 my $relobj = $self->get_relationship( $rel );
1163 if( $self->type( $relobj->type )->is_transitive ) {
1164 my @added = $self->propagate_relationship( $rel );
1169 # Helper sorting function for retroactive propagation order.
1170 sub _propagate_rel_order {
1171 my( $self, $a, $b ) = @_;
1172 my $aobj = $self->get_relationship( $a );
1173 my $bobj = $self->get_relationship( $b );
1174 my $at = $self->type( $aobj->type ); my $bt = $self->type( $bobj->type );
1175 # Apply strong relationships before weak
1176 return -1 if $bt->is_weak && !$at->is_weak;
1177 return 1 if $at->is_weak && !$bt->is_weak;
1178 # Apply more tightly bound relationships first
1179 return $at->bindlevel <=> $bt->bindlevel;
1183 =head2 merge_readings( $kept, $deleted );
1185 Makes a best-effort merge of the relationship links between the given readings, and
1186 stops tracking the to-be-deleted reading.
1190 sub merge_readings {
1191 my( $self, $kept, $deleted, $combined ) = @_;
1192 foreach my $edge ( $self->graph->edges_at( $deleted ) ) {
1193 # Get the pair of kept / rel
1194 my @vector = ( $kept );
1195 push( @vector, $edge->[0] eq $deleted ? $edge->[1] : $edge->[0] );
1196 next if $vector[0] eq $vector[1]; # Don't add a self loop
1198 # If kept changes its text, drop the relationship.
1201 # If kept / rel already has a relationship, just keep the old
1202 my $rel = $self->get_relationship( @vector );
1205 # Otherwise, adopt the relationship that would be deleted.
1206 $rel = $self->get_relationship( @$edge );
1207 $self->_set_relationship( $rel, @vector );
1209 $self->_make_equivalence( $deleted, $kept );
1212 ### Equivalence logic
1214 sub _remove_equivalence_node {
1215 my( $self, $node ) = @_;
1216 my $group = $self->equivalence( $node );
1217 my $nodelist = $self->eqreadings( $group );
1218 if( @$nodelist == 1 && $nodelist->[0] eq $node ) {
1219 $self->equivalence_graph->delete_vertex( $group );
1220 $self->remove_eqreadings( $group );
1221 $self->remove_equivalence( $group );
1222 } elsif( @$nodelist == 1 ) {
1223 throw( "DATA INCONSISTENCY in equivalence graph: " . $nodelist->[0] .
1224 " in group that should have only $node" );
1226 my @newlist = grep { $_ ne $node } @$nodelist;
1227 $self->set_eqreadings( $group, \@newlist );
1228 $self->remove_equivalence( $node );
1232 =head2 add_equivalence_edge
1234 Add an edge in the equivalence graph corresponding to $source -> $target in the
1235 collation. Should only be called by Collation.
1239 sub add_equivalence_edge {
1240 my( $self, $source, $target ) = @_;
1241 my $seq = $self->equivalence( $source );
1242 my $teq = $self->equivalence( $target );
1243 $self->equivalence_graph->add_edge( $seq, $teq );
1246 =head2 delete_equivalence_edge
1248 Remove an edge in the equivalence graph corresponding to $source -> $target in the
1249 collation. Should only be called by Collation.
1253 sub delete_equivalence_edge {
1254 my( $self, $source, $target ) = @_;
1255 my $seq = $self->equivalence( $source );
1256 my $teq = $self->equivalence( $target );
1257 $self->equivalence_graph->delete_edge( $seq, $teq );
1260 sub _is_disconnected {
1262 return( scalar $self->equivalence_graph->predecessorless_vertices > 1
1263 || scalar $self->equivalence_graph->successorless_vertices > 1 );
1266 # Equate two readings in the equivalence graph
1267 sub _make_equivalence {
1268 my( $self, $source, $target ) = @_;
1269 # Get the source equivalent readings
1270 my $seq = $self->equivalence( $source );
1271 my $teq = $self->equivalence( $target );
1272 # Nothing to do if they are already equivalent...
1273 return if $seq eq $teq;
1274 my $sourcepool = $self->eqreadings( $seq );
1275 # and add them to the target readings.
1276 push( @{$self->eqreadings( $teq )}, @$sourcepool );
1277 map { $self->set_equivalence( $_, $teq ) } @$sourcepool;
1278 # Then merge the nodes in the equivalence graph.
1279 foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
1280 $self->equivalence_graph->add_edge( $pred, $teq );
1282 foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
1283 $self->equivalence_graph->add_edge( $teq, $succ );
1285 $self->equivalence_graph->delete_vertex( $seq );
1286 # TODO enable this after collation parsing is done
1287 throw( "Graph got disconnected making $source / $target equivalence" )
1288 if $self->_is_disconnected && $self->collation->tradition->_initialized;
1291 =head2 test_equivalence
1293 Test whether, if two readings were equated with a 'colocated' relationship,
1294 the graph would still be valid.
1298 # TODO Used the 'is_reachable' method; it killed performance. Think about doing away
1299 # with the equivalence graph in favor of a transitive closure graph (calculated ONCE)
1300 # on the sequence graph, and test that way.
1302 sub test_equivalence {
1303 my( $self, $source, $target ) = @_;
1304 # Try merging the nodes in the equivalence graph; return a true value if
1305 # no cycle is introduced thereby. Restore the original graph first.
1307 # Keep track of edges we add
1310 # Get the reading equivalents
1311 my $seq = $self->equivalence( $source );
1312 my $teq = $self->equivalence( $target );
1313 # Maybe this is easy?
1314 return 1 if $seq eq $teq;
1316 # Save the first graph
1317 my $checkstr = $self->equivalence_graph->stringify();
1318 # Add and save relevant edges
1319 foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
1320 if( $self->equivalence_graph->has_edge( $pred, $teq ) ) {
1321 $added_pred{$pred} = 0;
1323 $self->equivalence_graph->add_edge( $pred, $teq );
1324 $added_pred{$pred} = 1;
1327 foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
1328 if( $self->equivalence_graph->has_edge( $teq, $succ ) ) {
1329 $added_succ{$succ} = 0;
1331 $self->equivalence_graph->add_edge( $teq, $succ );
1332 $added_succ{$succ} = 1;
1335 # Delete source equivalent and test
1336 $self->equivalence_graph->delete_vertex( $seq );
1337 my $ret = !$self->equivalence_graph->has_a_cycle;
1339 # Restore what we changed
1340 $self->equivalence_graph->add_vertex( $seq );
1341 foreach my $pred ( keys %added_pred ) {
1342 $self->equivalence_graph->add_edge( $pred, $seq );
1343 $self->equivalence_graph->delete_edge( $pred, $teq ) if $added_pred{$pred};
1345 foreach my $succ ( keys %added_succ ) {
1346 $self->equivalence_graph->add_edge( $seq, $succ );
1347 $self->equivalence_graph->delete_edge( $teq, $succ ) if $added_succ{$succ};
1349 unless( $self->equivalence_graph->eq( $checkstr ) ) {
1350 throw( "GRAPH CHANGED after testing" );
1356 # Unmake an equivalence link between two readings. Should only be called internally.
1357 sub _break_equivalence {
1358 my( $self, $source, $target ) = @_;
1360 # This is the hard one. Need to reconstruct the equivalence groups without
1363 map { $sng{$_} = 1 } $self->_find_equiv_without( $source, $target );
1364 map { $tng{$_} = 1 } $self->_find_equiv_without( $target, $source );
1365 # If these groups intersect, they are still connected; do nothing.
1366 foreach my $el ( keys %tng ) {
1367 return if( exists $sng{$el} );
1369 # If they don't intersect, then we split the nodes in the graph and in
1370 # the hashes. First figure out which group has which name
1371 my $oldgroup = $self->equivalence( $source ); # same as $target
1372 my $keepsource = $sng{$oldgroup};
1373 my $newgroup = $keepsource ? $target : $source;
1374 my( $oldmembers, $newmembers );
1376 $oldmembers = [ keys %sng ];
1377 $newmembers = [ keys %tng ];
1379 $oldmembers = [ keys %tng ];
1380 $newmembers = [ keys %sng ];
1383 # First alter the old group in the hash
1384 $self->set_eqreadings( $oldgroup, $oldmembers );
1385 foreach my $el ( @$oldmembers ) {
1386 $self->set_equivalence( $el, $oldgroup );
1389 # then add the new group back to the hash with its new key
1390 $self->set_eqreadings( $newgroup, $newmembers );
1391 foreach my $el ( @$newmembers ) {
1392 $self->set_equivalence( $el, $newgroup );
1395 # Now add the new group back to the equivalence graph
1396 $self->equivalence_graph->add_vertex( $newgroup );
1397 # ...add the appropriate edges to the source group vertext
1398 my $c = $self->collation;
1399 foreach my $rdg ( @$newmembers ) {
1400 foreach my $rp ( $c->sequence->predecessors( $rdg ) ) {
1401 next unless $self->equivalence( $rp );
1402 $self->equivalence_graph->add_edge( $self->equivalence( $rp ), $newgroup );
1404 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
1405 next unless $self->equivalence( $rs );
1406 $self->equivalence_graph->add_edge( $newgroup, $self->equivalence( $rs ) );
1410 # ...and figure out which edges on the old group vertex to delete.
1411 my( %old_pred, %old_succ );
1412 foreach my $rdg ( @$oldmembers ) {
1413 foreach my $rp ( $c->sequence->predecessors( $rdg ) ) {
1414 next unless $self->equivalence( $rp );
1415 $old_pred{$self->equivalence( $rp )} = 1;
1417 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
1418 next unless $self->equivalence( $rs );
1419 $old_succ{$self->equivalence( $rs )} = 1;
1422 foreach my $p ( $self->equivalence_graph->predecessors( $oldgroup ) ) {
1423 unless( $old_pred{$p} ) {
1424 $self->equivalence_graph->delete_edge( $p, $oldgroup );
1427 foreach my $s ( $self->equivalence_graph->successors( $oldgroup ) ) {
1428 unless( $old_succ{$s} ) {
1429 $self->equivalence_graph->delete_edge( $oldgroup, $s );
1432 # TODO enable this after collation parsing is done
1433 throw( "Graph got disconnected breaking $source / $target equivalence" )
1434 if $self->_is_disconnected && $self->collation->tradition->_initialized;
1437 sub _find_equiv_without {
1438 my( $self, $first, $second ) = @_;
1439 my %found = ( $first => 1 );
1440 my $check = [ $first ];
1444 foreach my $r ( @$check ) {
1445 foreach my $nr ( $self->graph->neighbors( $r ) ) {
1446 next if $r eq $second;
1447 if( $self->get_relationship( $r, $nr )->colocated ) {
1448 push( @$more, $nr ) unless exists $found{$nr};
1458 =head2 rebuild_equivalence
1460 (Re)build the equivalence graph from scratch. Dumps the graph, makes a new one,
1461 adds all readings and edges, then makes an equivalence for all relationships.
1465 sub rebuild_equivalence {
1467 my $newgraph = Graph->new();
1468 # Set this as the new equivalence graph
1469 $self->_reset_equivalence( $newgraph );
1470 # Clear out the data hashes
1471 $self->_clear_equivalence;
1472 $self->_clear_eqreadings;
1474 $self->collation->tradition->_init_done(0);
1476 foreach my $r ( $self->collation->readings ) {
1478 $newgraph->add_vertex( $rid );
1479 $self->set_equivalence( $rid, $rid );
1480 $self->set_eqreadings( $rid, [ $rid ] );
1484 foreach my $e ( $self->collation->paths ) {
1485 $self->add_equivalence_edge( @$e );
1488 # Now equate the colocated readings. This does no testing;
1489 # it assumes that all preexisting relationships are valid.
1490 foreach my $rel ( $self->relationships ) {
1491 my $relobj = $self->get_relationship( $rel );
1492 next unless $relobj && $relobj->colocated;
1493 $self->_make_equivalence( @$rel );
1495 $self->collation->tradition->_init_done(1);
1498 =head2 equivalence_ranks
1500 Rank all vertices in the equivalence graph, and return a hash reference with
1501 vertex => rank mapping.
1505 sub equivalence_ranks {
1507 my $eqstart = $self->equivalence( $self->collation->start );
1508 my $eqranks = { $eqstart => 0 };
1509 my $rankeqs = { 0 => [ $eqstart ] };
1510 my @curr_origin = ( $eqstart );
1511 # A little iterative function.
1512 while( @curr_origin ) {
1513 @curr_origin = $self->_assign_rank( $eqranks, $rankeqs, @curr_origin );
1515 return( $eqranks, $rankeqs );
1519 my( $self, $node_ranks, $rank_nodes, @current_nodes ) = @_;
1520 my $graph = $self->equivalence_graph;
1521 # Look at each of the children of @current_nodes. If all the child's
1522 # parents have a rank, assign it the highest rank + 1 and add it to
1523 # @next_nodes. Otherwise skip it; we will return when the highest-ranked
1524 # parent gets a rank.
1526 foreach my $c ( @current_nodes ) {
1527 warn "Current reading $c has no rank!"
1528 unless exists $node_ranks->{$c};
1529 foreach my $child ( $graph->successors( $c ) ) {
1530 next if exists $node_ranks->{$child};
1531 my $highest_rank = -1;
1533 foreach my $parent ( $graph->predecessors( $child ) ) {
1534 if( exists $node_ranks->{$parent} ) {
1535 $highest_rank = $node_ranks->{$parent}
1536 if $highest_rank <= $node_ranks->{$parent};
1543 my $c_rank = $highest_rank + 1;
1544 # print STDERR "Assigning rank $c_rank to node $child \n";
1545 $node_ranks->{$child} = $c_rank if $node_ranks;
1546 push( @{$rank_nodes->{$c_rank}}, $child ) if $rank_nodes;
1547 push( @next_nodes, $child );
1556 my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_;
1558 my $rgraph = $xmlroot->addNewChild( $graphml_ns, 'graph' );
1559 $rgraph->setAttribute( 'edgedefault', 'directed' );
1560 $rgraph->setAttribute( 'id', 'relationships', );
1561 $rgraph->setAttribute( 'parse.edgeids', 'canonical' );
1562 $rgraph->setAttribute( 'parse.edges', 0 );
1563 $rgraph->setAttribute( 'parse.nodeids', 'canonical' );
1564 $rgraph->setAttribute( 'parse.nodes', 0 );
1565 $rgraph->setAttribute( 'parse.order', 'nodesfirst' );
1567 # Add the vertices according to their XML IDs
1568 my %rdg_lookup = ( reverse %$node_hash );
1569 # my @nlist = sort _by_xmlid keys( %rdg_lookup ); ## CAUSES SEGFAULT
1570 my @nlist = sort keys( %rdg_lookup );
1571 foreach my $n ( @nlist ) {
1572 my $n_el = $rgraph->addNewChild( $graphml_ns, 'node' );
1573 $n_el->setAttribute( 'id', $n );
1574 _add_graphml_data( $n_el, $nodeid_key, $rdg_lookup{$n} );
1576 $rgraph->setAttribute( 'parse.nodes', scalar @nlist );
1578 # Add the relationship edges, with their object information
1580 foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->graph->edges ) {
1581 # Add an edge and fill in its relationship info.
1582 next unless( exists $node_hash->{$e->[0]} && exists $node_hash->{$e->[1]} );
1583 my $edge_el = $rgraph->addNewChild( $graphml_ns, 'edge' );
1584 $edge_el->setAttribute( 'source', $node_hash->{$e->[0]} );
1585 $edge_el->setAttribute( 'target', $node_hash->{$e->[1]} );
1586 $edge_el->setAttribute( 'id', 'e'.$edge_ctr++ );
1588 my $rel_obj = $self->get_relationship( @$e );
1589 foreach my $key ( keys %$edge_keys ) {
1590 my $value = $rel_obj->$key;
1591 _add_graphml_data( $edge_el, $edge_keys->{$key}, $value )
1595 $rgraph->setAttribute( 'parse.edges', $edge_ctr );
1603 return $tmp_a <=> $tmp_b;
1606 sub _add_graphml_data {
1607 my( $el, $key, $value ) = @_;
1608 return unless defined $value;
1609 my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
1610 $data_el->setAttribute( 'key', $key );
1611 $data_el->appendText( $value );
1615 my( $self, $from, $to ) = @_;
1616 open( DUMP, ">debug.svg" ) or die "Could not open debug.svg";
1617 binmode DUMP, ':utf8';
1618 print DUMP $self->collation->as_svg({ from => $from, to => $to, nocalc => 1 });
1623 Text::Tradition::Error->throw(
1624 'ident' => 'Relationship error',
1630 __PACKAGE__->meta->make_immutable;