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' => (
92 isa => 'HashRef[HashRef[Text::Tradition::Collation::Relationship]]',
93 default => sub { {} },
99 default => sub { Graph->new( undirected => 1 ) },
101 relationships => 'edges',
102 add_reading => 'add_vertex',
103 delete_reading => 'delete_vertex',
107 =head2 equivalence_graph()
109 Returns an equivalence graph of the collation, in which all readings
110 related via a 'colocated' relationship are transformed into a single
111 vertex. Can be used to determine the validity of a new relationship.
115 has 'equivalence_graph' => (
118 default => sub { Graph->new() },
119 writer => '_reset_equivalence',
122 has '_node_equivalences' => (
126 equivalence => 'get',
127 set_equivalence => 'set',
128 remove_equivalence => 'delete',
129 _clear_equivalence => 'clear',
133 has '_equivalence_readings' => (
138 set_eqreadings => 'set',
139 remove_eqreadings => 'delete',
140 _clear_eqreadings => 'clear',
144 ## Build function - here we have our default set of relationship types.
149 my @DEFAULT_TYPES = (
150 { name => 'collated', bindlevel => 50, is_weak => 1, is_transitive => 0, is_generalizable => 0 },
151 { name => 'orthographic', bindlevel => 0, use_regular => 0 },
152 { name => 'spelling', bindlevel => 1 },
153 { name => 'punctuation', bindlevel => 2 },
154 { name => 'grammatical', bindlevel => 2 },
155 { name => 'lexical', bindlevel => 2 },
156 { name => 'uncertain', bindlevel => 50, is_transitive => 0, is_generalizable => 0 },
157 { name => 'other', bindlevel => 50, is_transitive => 0, is_generalizable => 0 },
158 { name => 'transposition', bindlevel => 50, is_colocation => 0 },
159 { name => 'repetition', bindlevel => 50, is_colocation => 0, is_transitive => 0 }
162 foreach my $type ( @DEFAULT_TYPES ) {
163 $self->add_type( $type );
167 around add_type => sub {
171 if( @_ == 1 && $_[0]->$_isa( 'Text::Tradition::Collation::RelationshipType' ) ) {
174 my %args = @_ == 1 ? %{$_[0]} : @_;
175 $new_type = Text::Tradition::Collation::RelationshipType->new( %args );
177 $self->$orig( $new_type->name => $new_type );
181 around add_reading => sub {
185 $self->equivalence_graph->add_vertex( @_ );
186 $self->set_equivalence( $_[0], $_[0] );
187 $self->set_eqreadings( $_[0], [ $_[0] ] );
191 around delete_reading => sub {
195 $self->_remove_equivalence_node( @_ );
199 =head2 get_relationship
201 Return the relationship object, if any, that exists between two readings.
205 sub get_relationship {
208 if( @_ == 1 && ref( $_[0] ) eq 'ARRAY' ) {
209 # Dereference the edge arrayref that was passed.
216 if( $self->graph->has_edge_attribute( @vector, 'object' ) ) {
217 $relationship = $self->graph->get_edge_attribute( @vector, 'object' );
219 return $relationship;
222 sub _set_relationship {
223 my( $self, $relationship, @vector ) = @_;
224 $self->graph->add_edge( @vector );
225 $self->graph->set_edge_attribute( @vector, 'object', $relationship );
226 $self->_make_equivalence( @vector ) if $relationship->colocated;
231 Create a new relationship with the given options and return it.
232 Warn and return undef if the relationship cannot be created.
237 my( $self, $options ) = @_;
238 # Check to see if a relationship exists between the two given readings
239 my $source = delete $options->{'orig_a'};
240 my $target = delete $options->{'orig_b'};
241 my $rel = $self->get_relationship( $source, $target );
243 if( $self->type( $rel->type )->is_weak ) {
244 # Always replace a weak relationship with a more descriptive
246 $self->del_relationship( $source, $target );
247 } elsif( $rel->type ne $options->{'type'} ) {
248 throw( "Another relationship of type " . $rel->type
249 . " already exists between $source and $target" );
255 $rel = Text::Tradition::Collation::Relationship->new( $options );
256 my $reltype = $self->type( $rel->type );
257 throw( "Unrecognized relationship type " . $rel->type ) unless $reltype;
258 # Validate the options given against the relationship type wanted
259 throw( "Cannot set nonlocal scope on relationship of type " . $reltype->name )
260 if $rel->nonlocal && !$reltype->is_generalizable;
262 $self->add_scoped_relationship( $rel ) if $rel->nonlocal;
266 =head2 add_scoped_relationship( $rel )
268 Keep track of relationships defined between specific readings that are scoped
269 non-locally. Key on whichever reading occurs first alphabetically.
273 sub add_scoped_relationship {
274 my( $self, $rel ) = @_;
275 my $rdga = $rel->reading_a;
276 my $rdgb = $rel->reading_b;
277 my $r = $self->scoped_relationship( $rdga, $rdgb );
279 warn sprintf( "Scoped relationship of type %s already exists between %s and %s",
280 $r->type, $rdga, $rdgb );
283 my( $first, $second ) = sort ( $rdga, $rdgb );
284 $self->scopedrels->{$first}->{$second} = $rel;
287 =head2 scoped_relationship( $reading_a, $reading_b )
289 Returns the general (document-level or global) relationship that has been defined
290 between the two reading strings. Returns undef if there is no general relationship.
294 sub scoped_relationship {
295 my( $self, $rdga, $rdgb ) = @_;
296 my( $first, $second ) = sort( $rdga, $rdgb );
297 if( exists $self->scopedrels->{$first}->{$second} ) {
298 return $self->scopedrels->{$first}->{$second};
303 =head2 add_relationship( $self, $source, $sourcetext, $target, $targettext, $opts )
305 Adds the relationship specified in $opts (see Text::Tradition::Collation::Relationship
306 for the possible options) between the readings given in $source and $target. Sets
307 up a scoped relationship between $sourcetext and $targettext if the relationship is
310 Returns a status boolean and a list of all reading pairs connected by the call to
321 $t1 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/legendfrag.xml' );
322 } [qr/Cannot set relationship on a meta reading/],
323 "Got expected relationship drop warning on parse";
325 # Test 1.1: try to equate nodes that are prevented with an intermediate collation
326 ok( $t1, "Parsed test fragment file" );
327 my $c1 = $t1->collation;
328 my $trel = $c1->get_relationship( 'r9.2', 'r9.3' );
329 is( ref( $trel ), 'Text::Tradition::Collation::Relationship',
330 "Troublesome relationship exists" );
331 is( $trel->type, 'collated', "Troublesome relationship is a collation" );
333 # Try to make the link we want
335 $c1->add_relationship( 'r8.6', 'r10.3', { 'type' => 'orthographic' } );
336 ok( 1, "Added cross-collation relationship as expected" );
337 } catch( Text::Tradition::Error $e ) {
338 ok( 0, "Existing collation blocked equivalence relationship: " . $e->message );
342 $c1->calculate_ranks();
343 ok( 1, "Successfully calculated ranks" );
344 } catch ( Text::Tradition::Error $e ) {
345 ok( 0, "Collation now has a cycle: " . $e->message );
348 # Test 1.2: attempt merge of an identical reading
350 $c1->merge_readings( 'r9.3', 'r11.5' );
351 ok( 1, "Successfully merged reading 'pontifex'" );
352 } catch ( Text::Tradition::Error $e ) {
353 ok( 0, "Merge of mergeable readings failed: $e->message" );
357 # Test 1.3: attempt relationship with a meta reading (should fail)
359 $c1->add_relationship( 'r8.1', 'r9.2', { 'type' => 'collated' } );
360 ok( 0, "Allowed a meta-reading to be used in a relationship" );
361 } catch ( Text::Tradition::Error $e ) {
362 is( $e->message, 'Cannot set relationship on a meta reading',
363 "Relationship link prevented for a meta reading" );
366 # Test 1.4: try to break a relationship near a meta reading
367 $c1->add_relationship( 'r7.6', 'r7.3', { type => 'orthographic' } );
369 $c1->del_relationship( 'r7.6', 'r7.7' );
370 $c1->del_relationship( 'r7.6', 'r7.3' );
371 ok( 1, "Relationship broken with a meta reading as neighbor" );
373 ok( 0, "Relationship deletion failed with a meta reading as neighbor" );
376 # Test 2.1: try to equate nodes that are prevented with a real intermediate
380 $t2 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/legendfrag.xml' );
381 } [qr/Cannot set relationship on a meta reading/],
382 "Got expected relationship drop warning on parse";
383 my $c2 = $t2->collation;
384 $c2->add_relationship( 'r9.2', 'r9.3', { 'type' => 'lexical' } );
385 my $trel2 = $c2->get_relationship( 'r9.2', 'r9.3' );
386 is( ref( $trel2 ), 'Text::Tradition::Collation::Relationship',
387 "Created blocking relationship" );
388 is( $trel2->type, 'lexical', "Blocking relationship is not a collation" );
389 # This time the link ought to fail
391 $c2->add_relationship( 'r8.6', 'r10.3', { 'type' => 'orthographic' } );
392 ok( 0, "Added cross-equivalent bad relationship" );
393 } catch ( Text::Tradition::Error $e ) {
394 like( $e->message, qr/witness loop/,
395 "Existing equivalence blocked crossing relationship" );
399 $c2->calculate_ranks();
400 ok( 1, "Successfully calculated ranks" );
401 } catch ( Text::Tradition::Error $e ) {
402 ok( 0, "Collation now has a cycle: " . $e->message );
405 # Test 3.1: make a straightforward pair of transpositions.
406 my $t3 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/lf2.xml' );
407 # Test 1: try to equate nodes that are prevented with an intermediate collation
408 my $c3 = $t3->collation;
410 $c3->add_relationship( 'r36.4', 'r38.3', { 'type' => 'transposition' } );
411 ok( 1, "Added straightforward transposition" );
412 } catch ( Text::Tradition::Error $e ) {
413 ok( 0, "Failed to add normal transposition: " . $e->message );
416 $c3->add_relationship( 'r36.3', 'r38.2', { 'type' => 'transposition' } );
417 ok( 1, "Added straightforward transposition complement" );
418 } catch ( Text::Tradition::Error $e ) {
419 ok( 0, "Failed to add normal transposition complement: " . $e->message );
422 # Test 3.2: try to make a transposition that could be a parallel.
424 $c3->add_relationship( 'r28.2', 'r29.2', { 'type' => 'transposition' } );
425 ok( 0, "Added bad colocated transposition" );
426 } catch ( Text::Tradition::Error $e ) {
427 like( $e->message, qr/Readings appear to be colocated/,
428 "Prevented bad colocated transposition" );
431 # Test 3.3: make the parallel, and then make the transposition again.
433 $c3->add_relationship( 'r28.3', 'r29.3', { 'type' => 'orthographic' } );
434 ok( 1, "Equated identical readings for transposition" );
435 } catch ( Text::Tradition::Error $e ) {
436 ok( 0, "Failed to equate identical readings: " . $e->message );
439 $c3->add_relationship( 'r28.2', 'r29.2', { 'type' => 'transposition' } );
440 ok( 1, "Added straightforward transposition complement" );
441 } catch ( Text::Tradition::Error $e ) {
442 ok( 0, "Failed to add normal transposition complement: " . $e->message );
445 # Test 4: make a global relationship that involves re-ranking a node first, when
446 # the prior rank has a potential match too
447 my $t4 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/globalrel_test.xml' );
448 my $c4 = $t4->collation;
449 # Can we even add the relationship?
451 $c4->add_relationship( 'r463.2', 'r463.4',
452 { type => 'orthographic', scope => 'global' } );
453 ok( 1, "Added global relationship without error" );
454 } catch ( Text::Tradition::Error $e ) {
455 ok( 0, "Failed to add global relationship when same-rank alternative exists: "
458 $c4->calculate_ranks();
459 # Do our readings now share a rank?
460 is( $c4->reading('r463.2')->rank, $c4->reading('r463.4')->rank,
461 "Expected readings now at same rank" );
463 # Test group 5: relationship transitivity.
464 my $t5 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/john.xml' );
465 my $c5 = $t5->collation;
467 # Test 5.1: make a grammatical link to an orthographically-linked reading
468 $c5->add_relationship( 'r13.5', 'r13.2', { type => 'orthographic' } );
469 $c5->add_relationship( 'r13.1', 'r13.2', { type => 'grammatical', propagate => 1 } );
470 my $impliedrel = $c5->get_relationship( 'r13.1', 'r13.5' );
471 ok( $impliedrel, 'Relationship was made between indirectly linked readings' );
473 is( $impliedrel->type, 'grammatical', 'Implicit inbound relationship has the correct type' );
476 # Test 5.2: make another orthographic link, see if the grammatical one propagates
477 $c5->add_relationship( 'r13.3', 'r13.5', { type => 'orthographic', propagate => 1 } );
478 foreach my $rdg ( qw/ r13.3 r13.5 / ) {
479 my $newgram = $c5->get_relationship( 'r13.1', $rdg );
480 ok( $newgram, 'Relationship was propagaged up between indirectly linked readings' );
482 is( $newgram->type, 'grammatical', 'Implicit outbound relationship has the correct type' );
485 my $neworth = $c5->get_relationship( 'r13.2', 'r13.3' );
486 ok( $neworth, 'Relationship was made between indirectly linked siblings' );
488 is( $neworth->type, 'orthographic', 'Implicit direct relationship has the correct type' );
491 # Test 5.3: make an intermediate (spelling) link to the remaining node
492 $c5->add_relationship( 'r13.4', 'r13.2', { type => 'spelling', propagate => 1 } );
493 # Should be linked grammatically to 12.1, spelling-wise to the rest
494 my $newgram = $c5->get_relationship( 'r13.4', 'r13.1' );
495 ok( $newgram, 'Relationship was made between indirectly linked readings' );
497 is( $newgram->type, 'grammatical', 'Implicit intermediate-out relationship has the correct type' );
499 foreach my $rdg ( qw/ r13.3 r13.5 / ) {
500 my $newspel = $c5->get_relationship( 'r13.4', $rdg );
501 ok( $newspel, 'Relationship was made between indirectly linked readings' );
503 is( $newspel->type, 'spelling', 'Implicit intermediate-in relationship has the correct type' );
507 # Test 5.4: delete a spelling relationship, add it again, make sure it doesn't
508 # throw and make sure all the relationships are the same
509 my $numrel = scalar $c5->relationships;
510 $c5->del_relationship( 'r13.4', 'r13.2' );
512 $c5->add_relationship( 'r13.4', 'r13.2', { type => 'spelling', propagate => 1 } );
513 ok( 1, "Managed not to throw an exception re-adding the relationship" );
514 } catch( Text::Tradition::Error $e ) {
515 ok( 0, "Threw an exception trying to re-add our intermediate relationship: " . $e->message );
517 is( $numrel, scalar $c5->relationships, "Number of relationships did not change" );
518 foreach my $rdg ( qw/ r13.2 r13.3 r13.5 / ) {
519 my $newspel = $c5->get_relationship( 'r13.4', $rdg );
520 ok( $newspel, 'Relationship was made between indirectly linked readings' );
522 is( $newspel->type, 'spelling', 'Reinstated intermediate-in relationship has the correct type' );
525 my $stillgram = $c5->get_relationship( 'r13.4', 'r13.1' );
526 ok( $stillgram, 'Relationship was made between indirectly linked readings' );
528 is( $stillgram->type, 'grammatical', 'Reinstated intermediate-out relationship has the correct type' );
531 # Test 5.5: add a parallel but not sibling relationship
532 $c5->add_relationship( 'r13.6', 'r13.2', { type => 'lexical', propagate => 1 } );
533 ok( !$c5->get_relationship( 'r13.6', 'r13.1' ),
534 "Lexical relationship did not affect grammatical" );
535 foreach my $rdg ( qw/ r13.3 r13.4 r13.5 / ) {
536 my $newlex = $c5->get_relationship( 'r13.6', $rdg );
537 ok( $newlex, 'Parallel was made between indirectly linked readings' );
539 is( $newlex->type, 'lexical', 'Implicit parallel-down relationship has the correct type' );
543 # Test 5.6: try it with non-colocated relationships
544 $numrel = scalar $c5->relationships;
545 $c5->add_relationship( 'r62.1', 'r64.1', { type => 'transposition', propagate => 1 } );
546 is( scalar $c5->relationships, $numrel+1,
547 "Adding non-colo relationship did not propagate" );
549 $c5->add_relationship( 'r61.1', 'r61.5', { type => 'orthographic' } );
550 # Add a third transposed node
551 $c5->add_relationship( 'r62.1', 'r60.3', { type => 'transposition', propagate => 1 } );
552 my $newtrans = $c5->get_relationship( 'r64.1', 'r60.3' );
553 ok( $newtrans, 'Non-colo relationship was made between indirectly linked readings' );
555 is( $newtrans->type, 'transposition', 'Implicit non-colo relationship has the correct type' );
557 is( scalar $c5->relationships, $numrel+4,
558 "Adding non-colo relationship only propagated on non-colos" );
560 # TODO test that attempts to cross boundaries on bindlevel-equal relationships fail.
562 # TODO test that weak relationships don't interfere
564 # TODO test that strong non-transitive relationships don't interfere
570 sub add_relationship {
571 my( $self, $source, $target, $options ) = @_;
572 my $c = $self->collation;
573 my $sourceobj = $c->reading( $source );
574 my $targetobj = $c->reading( $target );
575 throw( "Adding self relationship at $source" ) if $source eq $target;
576 throw( "Cannot set relationship on a meta reading" )
577 if( $sourceobj->is_meta || $targetobj->is_meta );
580 my $thispaironly = delete $options->{thispaironly};
581 my $propagate = delete $options->{propagate};
582 my $droppedcolls = [];
583 if( ref( $options ) eq 'Text::Tradition::Collation::Relationship' ) {
584 $relationship = $options;
585 $reltype = $self->type( $relationship->type );
586 $thispaironly = 1; # If existing rel, set only where asked.
588 my( $is_valid, $reason ) = $self->relationship_valid( $source, $target,
589 $relationship->type, $droppedcolls );
590 unless( $is_valid ) {
591 throw( "Invalid relationship: $reason" );
594 $reltype = $self->type( $options->{type} );
596 # Try to create the relationship object.
597 my $rdga = $reltype->regularize( $sourceobj );
598 my $rdgb = $reltype->regularize( $targetobj );
599 $options->{'orig_a'} = $sourceobj;
600 $options->{'orig_b'} = $targetobj;
601 $options->{'reading_a'} = $rdga;
602 $options->{'reading_b'} = $rdgb;
603 if( exists $options->{'scope'} && $options->{'scope'} ne 'local' ) {
604 # Is there a relationship with this a & b already?
605 if( $rdga eq $rdgb ) {
606 # If we have canonified to the same thing for the relationship
607 # type we want, something is wrong.
608 # NOTE we want to allow this at the local level, as a cheap means
609 # of merging readings in the UI, until we get a better means.
610 throw( "Canonifier returns identical form $rdga for this relationship type" );
613 my $otherrel = $self->scoped_relationship( $rdga, $rdgb );
614 if( $otherrel && $otherrel->type eq $options->{type}
615 && $otherrel->scope eq $options->{scope} ) {
616 # warn "Applying existing scoped relationship for $rdga / $rdgb";
617 $relationship = $otherrel;
618 } elsif( $otherrel ) {
619 throw( 'Conflicting scoped relationship '
620 . join( '/', $otherrel->type, $otherrel->scope ) . ' vs. '
621 . join( '/', $options->{type}, $options->{scope} )
622 . " for $rdga / $rdgb at $source / $target" );
625 $relationship = $self->create( $options ) unless $relationship;
626 # ... Will throw on error
628 # See if the relationship is actually valid here
629 my( $is_valid, $reason ) = $self->relationship_valid( $source, $target,
630 $options->{'type'}, $droppedcolls );
631 unless( $is_valid ) {
632 throw( "Invalid relationship: $reason" );
637 # Now set the relationship(s).
639 my $rel = $self->get_relationship( $source, $target );
641 if( $rel && $rel ne $relationship ) {
642 if( $rel->nonlocal ) {
643 throw( "Found conflicting relationship at $source - $target" );
644 } elsif( !$reltype->is_weak ) {
645 # Replace a weak relationship; leave any other sort in place.
646 my $r1ann = $rel->has_annotation ? $rel->annotation : '';
647 my $r2ann = $relationship->has_annotation ? $relationship->annotation : '';
648 unless( $rel->type eq $relationship->type && $r1ann eq $r2ann ) {
649 warn sprintf( "Not overriding local relationship %s with global %s "
650 . "set at %s -> %s (%s -> %s)", $rel->type, $relationship->type,
651 $source, $target, $rel->reading_a, $rel->reading_b );
656 $self->_set_relationship( $relationship, $source, $target ) unless $skip;
657 push( @pairs_set, [ $source, $target, $relationship->type ] );
659 # Find all the pairs for which we need to set the relationship.
660 if( $relationship->colocated && $relationship->nonlocal && !$thispaironly ) {
661 my @global_set = $self->add_global_relationship( $relationship );
662 push( @pairs_set, @global_set );
666 foreach my $ps ( @pairs_set ) {
667 my @extra = $self->propagate_relationship( $ps->[0], $ps->[1] );
668 push( @prop, @extra );
670 push( @pairs_set, @prop ) if @prop;
673 # Finally, restore whatever collations we can, and return.
674 $self->_restore_weak( @$droppedcolls );
678 =head2 add_global_relationship( $options, $skipvector )
680 Adds the relationship specified wherever the relevant readings appear together
681 in the graph. Options as in add_relationship above.
685 sub add_global_relationship {
686 my( $self, $relationship ) = @_;
688 my $reltype = $self->type( $relationship->type );
689 throw( "Relationship passed to add_global is not global" )
690 unless $relationship->nonlocal;
691 throw( "Relationship passed to add_global is not a valid global type" )
692 unless $reltype->is_generalizable;
694 # Apply the relationship wherever it is valid
696 foreach my $v ( $self->_find_applicable( $relationship ) ) {
697 my $exists = $self->get_relationship( @$v );
698 my $etype = $exists ? $self->type( $exists->type ) : '';
699 if( $exists && !$etype->is_weak ) {
700 unless( $exists->is_equivalent( $relationship ) ) {
701 throw( "Found conflicting relationship at @$v" );
706 @added = $self->add_relationship( @$v, $relationship );
708 my $reldesc = sprintf( "%s %s -> %s", $relationship->type,
709 $relationship->reading_a, $relationship->reading_b );
710 # print STDERR "Global relationship $reldesc not applicable at @$v\n";
712 push( @pairs_set, @added ) if @added;
719 =head2 del_scoped_relationship( $reading_a, $reading_b )
721 Returns the general (document-level or global) relationship that has been defined
722 between the two reading strings. Returns undef if there is no general relationship.
726 sub del_scoped_relationship {
727 my( $self, $rdga, $rdgb ) = @_;
728 my( $first, $second ) = sort( $rdga, $rdgb );
729 return delete $self->scopedrels->{$first}->{$second};
732 sub _find_applicable {
733 my( $self, $rel ) = @_;
734 my $c = $self->collation;
735 my $reltype = $self->type( $rel->type );
737 my @identical_readings;
738 @identical_readings = grep { $reltype->regularize( $_ ) eq $rel->reading_a }
740 foreach my $ir ( @identical_readings ) {
742 @itarget = grep { $reltype->regularize( $_ ) eq $rel->reading_b }
743 $c->readings_at_rank( $ir->rank );
745 # Warn if there is more than one hit with no closer link between them.
746 my $itmain = shift @itarget;
749 my $bindlevel = $reltype->bindlevel;
750 map { $all_targets{$_} = 1 } @itarget;
751 map { delete $all_targets{$_} }
752 $self->related_readings( $itmain, sub {
753 $self->type( $_[0]->type )->bindlevel < $bindlevel } );
754 warn "More than one unrelated reading with text " . $itmain->text
755 . " at rank " . $ir->rank . "!" if keys %all_targets;
757 push( @vectors, [ $ir->id, $itmain->id ] );
763 =head2 del_relationship( $source, $target )
765 Removes the relationship between the given readings. If the relationship is
766 non-local, removes the relationship everywhere in the graph.
770 sub del_relationship {
771 my( $self, $source, $target ) = @_;
772 my $rel = $self->get_relationship( $source, $target );
773 return () unless $rel; # Nothing to delete; return an empty set.
774 my $reltype = $self->type( $rel->type );
775 my $colo = $rel->colocated;
776 my @vectors = ( [ $source, $target ] );
777 $self->_remove_relationship( $colo, $source, $target );
778 if( $rel->nonlocal ) {
779 # Remove the relationship wherever it occurs.
780 my @rel_edges = grep { $self->get_relationship( @$_ ) eq $rel }
781 $self->relationships;
782 foreach my $re ( @rel_edges ) {
783 $self->_remove_relationship( $colo, @$re );
784 push( @vectors, $re );
786 $self->del_scoped_relationship( $rel->reading_a, $rel->reading_b );
791 sub _remove_relationship {
792 my( $self, $equiv, @vector ) = @_;
793 $self->graph->delete_edge( @vector );
794 $self->_break_equivalence( @vector ) if $equiv;
797 =head2 relationship_valid( $source, $target, $type )
799 Checks whether a relationship of type $type may exist between the readings given
800 in $source and $target. Returns a tuple of ( status, message ) where status is
801 a yes/no boolean and, if the answer is no, message gives the reason why.
805 sub relationship_valid {
806 my( $self, $source, $target, $rel, $mustdrop ) = @_;
807 $mustdrop = [] unless $mustdrop; # in case we were passed nothing
808 my $c = $self->collation;
809 my $reltype = $self->type( $rel );
810 ## Assume validity is okay if we are initializing from scratch.
811 return ( 1, "initializing" ) unless $c->tradition->_initialized;
812 ## TODO Move this block to relationship type definition when we can save
814 if ( $rel eq 'transposition' || $rel eq 'repetition' ) {
815 # Check that the two readings do (for a repetition) or do not (for
816 # a transposition) appear in the same witness.
817 # TODO this might be called before witness paths are set...
819 map { $seen_wits{$_} = 1 } $c->reading_witnesses( $source );
820 foreach my $w ( $c->reading_witnesses( $target ) ) {
821 if( $seen_wits{$w} ) {
822 return ( 0, "Readings both occur in witness $w" )
823 if $rel eq 'transposition';
824 return ( 1, "ok" ) if $rel eq 'repetition';
827 return ( 0, "Readings occur only in distinct witnesses" )
828 if $rel eq 'repetition';
830 if ( $reltype->is_colocation ) {
831 # Check that linking the source and target in a relationship won't lead
832 # to a path loop for any witness.
833 # First, drop/stash any collations that might interfere
834 my $sourceobj = $c->reading( $source );
835 my $targetobj = $c->reading( $target );
836 my $sourcerank = $sourceobj->has_rank ? $sourceobj->rank : -1;
837 my $targetrank = $targetobj->has_rank ? $targetobj->rank : -1;
838 unless( $rel eq 'collated' || $sourcerank == $targetrank ) {
839 push( @$mustdrop, $self->_drop_weak( $source ) );
840 push( @$mustdrop, $self->_drop_weak( $target ) );
841 if( $c->end->has_rank ) {
842 foreach my $rk ( $sourcerank .. $targetrank ) {
843 map { push( @$mustdrop, $self->_drop_weak( $_->id ) ) }
844 $c->readings_at_rank( $rk );
848 unless( $self->test_equivalence( $source, $target ) ) {
849 $self->_restore_weak( @$mustdrop );
850 return( 0, "Relationship would create witness loop" );
854 # We also need to check that the readings are not in the same place.
855 # That is, proposing to equate them should cause a witness loop.
856 if( $self->test_equivalence( $source, $target ) ) {
857 return ( 0, "Readings appear to be colocated" );
865 my( $self, $reading ) = @_;
867 foreach my $n ( $self->graph->neighbors( $reading ) ) {
868 my $nrel = $self->get_relationship( $reading, $n );
869 if( $self->type( $nrel->type )->is_weak ) {
870 push( @dropped, [ $reading, $n, $nrel->type ] );
871 $self->del_relationship( $reading, $n );
872 #print STDERR "Dropped weak relationship $reading -> $n\n";
879 my( $self, @vectors ) = @_;
880 foreach my $v ( @vectors ) {
883 $self->add_relationship( @$v, { 'type' => $type } );
884 #print STDERR "Restored weak relationship @$v\n";
885 }; # if it fails we don't care
889 =head2 related_readings( $reading, $filter )
891 Returns a list of readings that are connected via direct relationship links
892 to $reading. If $filter is set to a subroutine ref, returns only those
893 related readings where $filter( $relationship ) returns a true value.
897 sub related_readings {
898 my( $self, $reading, $filter ) = @_;
900 if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
901 $reading = $reading->id;
907 if( $filter eq 'colocated' ) {
908 $filter = sub { $_[0]->colocated };
909 } elsif( !ref( $filter ) ) {
911 $filter = sub { $_[0]->type eq $type };
913 @answer = grep { &$filter( $self->get_relationship( $reading, $_ ) ) }
914 $self->graph->neighbors( $reading );
916 @answer = $self->graph->neighbors( $reading );
918 if( $return_object ) {
919 my $c = $self->collation;
920 return map { $c->reading( $_ ) } @answer;
926 =head2 propagate_relationship( $rel )
928 Apply the transitivity and binding level rules to propagate the consequences of
929 the specified relationship link, ensuring all consequent relationships exist.
930 For now, we only propagate colocation links if we are passed a colocation, and
931 we only propagate displacement links if we are given a displacement.
933 Returns an array of tuples ( rdg1, rdg2, type ) for each new reading set.
937 sub propagate_relationship {
938 my( $self, @rel ) = @_;
939 ## Check that the vector is an arrayref
940 my $rel = @rel > 1 ? \@rel : $rel[0];
941 ## Get the relationship info
942 my $relobj = $self->get_relationship( $rel );
943 my $reltype = $self->type( $relobj->type );
944 return () unless $reltype->is_transitive;
947 my $colo = $reltype->is_colocation;
948 my $bindlevel = $reltype->bindlevel;
950 ## Find all readings that are linked via this relationship type
951 my %thislevel = ( $rel->[0] => 1, $rel->[1] => 1 );
956 foreach my $r ( @$check ) {
957 push( @$more, grep { !exists $thislevel{$_}
958 && $self->get_relationship( $r, $_ )
959 && $self->get_relationship( $r, $_ )->type eq $relobj->type }
960 $self->graph->neighbors( $r ) );
962 map { $thislevel{$_} = 1 } @$more;
966 ## Make sure every reading of our relationship type is linked to every other
967 my @samelevel = keys %thislevel;
968 while( @samelevel ) {
969 my $r = shift @samelevel;
970 foreach my $nr ( @samelevel ) {
971 my $existing = $self->get_relationship( $r, $nr );
974 my $extype = $self->type( $existing->type );
975 unless( $extype->is_weak ) {
976 # Check that it's a matching type, or a type subsumed by our
978 throw( "Conflicting existing relationship of type "
979 . $existing->type . " at $r, $nr trying to propagate "
980 . $relobj->type . " relationship at @$rel" )
981 unless $existing->type eq $relobj->type
982 || $extype->bindlevel <= $reltype->bindlevel;
987 # Try to add a new relationship here
989 my @new = $self->add_relationship( $r, $nr, { type => $relobj->type,
990 annotation => "Propagated from relationship at @$rel" } );
991 push( @newly_set, @new );
992 } catch ( Text::Tradition::Error $e ) {
993 throw( "Could not propagate " . $relobj->type .
994 " relationship (original @$rel) at $r -- $nr: " .
1000 ## Now for each sibling our set, look for its direct connections to
1001 ## transitive readings of a different bindlevel, and make sure that
1002 ## all siblings are related to those readings.
1004 foreach my $n ( $self->graph->neighbors( $r ) ) {
1005 my $crel = $self->get_relationship( $r, $n );
1007 my $crt = $self->type( $crel->type );
1008 if( $crt->is_transitive && $crt->is_colocation == $colo ) {
1009 next if $crt->bindlevel == $reltype->bindlevel;
1010 my $nrel = $crt->bindlevel < $reltype->bindlevel
1011 ? $reltype->name : $crt->name;
1012 push( @other, [ $n, $nrel ] );
1015 # The @other array now contains tuples of ( reading, type ) where the
1016 # reading is the non-sibling and the type is the type of relationship
1017 # that the siblings should have to the non-sibling.
1018 foreach ( @other ) {
1019 my( $nr, $nrtype ) = @$_;
1020 foreach my $sib ( keys %thislevel ) {
1022 next if $sib eq $nr; # can happen if linked to $r by tightrel
1023 # but linked to a sib of $r by thisrel
1024 # e.g. when a rel has been part propagated
1025 my $existing = $self->get_relationship( $sib, $nr );
1028 # Check that it's compatible. The existing relationship type
1029 # should match or be subsumed by the looser of the two
1030 # relationships in play, whether the original relationship
1031 # being worked on or the relationship between $r and $or.
1032 my $extype = $self->type( $existing->type );
1033 unless( $extype->is_weak ) {
1034 if( $nrtype ne $extype->name
1035 && $self->type( $nrtype )->bindlevel <= $extype->bindlevel ) {
1036 throw( "Conflicting existing relationship at $nr ( -> "
1037 . $self->get_relationship( $nr, $r )->type . " to $r) "
1038 . " -- $sib trying to propagate " . $relobj->type
1039 . " relationship at @$rel" );
1045 # Try to add a new relationship here
1047 my @new = $self->add_relationship( $sib, $nr, { type => $nrtype,
1048 annotation => "Propagated from relationship at @$rel" } );
1049 push( @newly_set, @new );
1050 } catch ( Text::Tradition::Error $e ) {
1051 throw( "Could not propagate $nrtype relationship (original " .
1052 $relobj->type . " at @$rel) at $sib -- $nr: " .
1063 =head2 propagate_all_relationships
1065 Apply propagation logic retroactively to all relationships in the tradition.
1069 sub propagate_all_relationships {
1071 my @allrels = sort { $self->_propagate_rel_order( $a, $b ) } $self->relationships;
1072 foreach my $rel ( @allrels ) {
1073 my $relobj = $self->get_relationship( $rel );
1074 if( $self->type( $relobj->type )->is_transitive ) {
1075 my @added = $self->propagate_relationship( $rel );
1080 # Helper sorting function for retroactive propagation order.
1081 sub _propagate_rel_order {
1082 my( $self, $a, $b ) = @_;
1083 my $aobj = $self->get_relationship( $a );
1084 my $bobj = $self->get_relationship( $b );
1085 my $at = $self->type( $aobj->type ); my $bt = $self->type( $bobj->type );
1086 # Apply strong relationships before weak
1087 return -1 if $bt->is_weak && !$at->is_weak;
1088 return 1 if $at->is_weak && !$bt->is_weak;
1089 # Apply more tightly bound relationships first
1090 return $at->bindlevel <=> $bt->bindlevel;
1094 =head2 merge_readings( $kept, $deleted );
1096 Makes a best-effort merge of the relationship links between the given readings, and
1097 stops tracking the to-be-deleted reading.
1101 sub merge_readings {
1102 my( $self, $kept, $deleted, $combined ) = @_;
1103 foreach my $edge ( $self->graph->edges_at( $deleted ) ) {
1104 # Get the pair of kept / rel
1105 my @vector = ( $kept );
1106 push( @vector, $edge->[0] eq $deleted ? $edge->[1] : $edge->[0] );
1107 next if $vector[0] eq $vector[1]; # Don't add a self loop
1109 # If kept changes its text, drop the relationship.
1112 # If kept / rel already has a relationship, just keep the old
1113 my $rel = $self->get_relationship( @vector );
1116 # Otherwise, adopt the relationship that would be deleted.
1117 $rel = $self->get_relationship( @$edge );
1118 $self->_set_relationship( $rel, @vector );
1120 $self->_make_equivalence( $deleted, $kept );
1123 ### Equivalence logic
1125 sub _remove_equivalence_node {
1126 my( $self, $node ) = @_;
1127 my $group = $self->equivalence( $node );
1128 my $nodelist = $self->eqreadings( $group );
1129 if( @$nodelist == 1 && $nodelist->[0] eq $node ) {
1130 $self->equivalence_graph->delete_vertex( $group );
1131 $self->remove_eqreadings( $group );
1132 $self->remove_equivalence( $group );
1133 } elsif( @$nodelist == 1 ) {
1134 throw( "DATA INCONSISTENCY in equivalence graph: " . $nodelist->[0] .
1135 " in group that should have only $node" );
1137 my @newlist = grep { $_ ne $node } @$nodelist;
1138 $self->set_eqreadings( $group, \@newlist );
1139 $self->remove_equivalence( $node );
1143 =head2 add_equivalence_edge
1145 Add an edge in the equivalence graph corresponding to $source -> $target in the
1146 collation. Should only be called by Collation.
1150 sub add_equivalence_edge {
1151 my( $self, $source, $target ) = @_;
1152 my $seq = $self->equivalence( $source );
1153 my $teq = $self->equivalence( $target );
1154 $self->equivalence_graph->add_edge( $seq, $teq );
1157 =head2 delete_equivalence_edge
1159 Remove an edge in the equivalence graph corresponding to $source -> $target in the
1160 collation. Should only be called by Collation.
1164 sub delete_equivalence_edge {
1165 my( $self, $source, $target ) = @_;
1166 my $seq = $self->equivalence( $source );
1167 my $teq = $self->equivalence( $target );
1168 $self->equivalence_graph->delete_edge( $seq, $teq );
1171 sub _is_disconnected {
1173 return( scalar $self->equivalence_graph->predecessorless_vertices > 1
1174 || scalar $self->equivalence_graph->successorless_vertices > 1 );
1177 # Equate two readings in the equivalence graph
1178 sub _make_equivalence {
1179 my( $self, $source, $target ) = @_;
1180 # Get the source equivalent readings
1181 my $seq = $self->equivalence( $source );
1182 my $teq = $self->equivalence( $target );
1183 # Nothing to do if they are already equivalent...
1184 return if $seq eq $teq;
1185 my $sourcepool = $self->eqreadings( $seq );
1186 # and add them to the target readings.
1187 push( @{$self->eqreadings( $teq )}, @$sourcepool );
1188 map { $self->set_equivalence( $_, $teq ) } @$sourcepool;
1189 # Then merge the nodes in the equivalence graph.
1190 foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
1191 $self->equivalence_graph->add_edge( $pred, $teq );
1193 foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
1194 $self->equivalence_graph->add_edge( $teq, $succ );
1196 $self->equivalence_graph->delete_vertex( $seq );
1197 # TODO enable this after collation parsing is done
1198 throw( "Graph got disconnected making $source / $target equivalence" )
1199 if $self->_is_disconnected && $self->collation->tradition->_initialized;
1202 =head2 test_equivalence
1204 Test whether, if two readings were equated with a 'colocated' relationship,
1205 the graph would still be valid.
1209 sub test_equivalence {
1210 my( $self, $source, $target ) = @_;
1211 # Try merging the nodes in the equivalence graph; return a true value if
1212 # no cycle is introduced thereby. Restore the original graph first.
1214 # Keep track of edges we add
1217 # Get the reading equivalents
1218 my $seq = $self->equivalence( $source );
1219 my $teq = $self->equivalence( $target );
1220 # Maybe this is easy?
1221 return 1 if $seq eq $teq;
1223 # Save the first graph
1224 my $checkstr = $self->equivalence_graph->stringify();
1225 # Add and save relevant edges
1226 foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
1227 if( $self->equivalence_graph->has_edge( $pred, $teq ) ) {
1228 $added_pred{$pred} = 0;
1230 $self->equivalence_graph->add_edge( $pred, $teq );
1231 $added_pred{$pred} = 1;
1234 foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
1235 if( $self->equivalence_graph->has_edge( $teq, $succ ) ) {
1236 $added_succ{$succ} = 0;
1238 $self->equivalence_graph->add_edge( $teq, $succ );
1239 $added_succ{$succ} = 1;
1242 # Delete source equivalent and test
1243 $self->equivalence_graph->delete_vertex( $seq );
1244 my $ret = !$self->equivalence_graph->has_a_cycle;
1246 # Restore what we changed
1247 $self->equivalence_graph->add_vertex( $seq );
1248 foreach my $pred ( keys %added_pred ) {
1249 $self->equivalence_graph->add_edge( $pred, $seq );
1250 $self->equivalence_graph->delete_edge( $pred, $teq ) if $added_pred{$pred};
1252 foreach my $succ ( keys %added_succ ) {
1253 $self->equivalence_graph->add_edge( $seq, $succ );
1254 $self->equivalence_graph->delete_edge( $teq, $succ ) if $added_succ{$succ};
1256 unless( $self->equivalence_graph->eq( $checkstr ) ) {
1257 throw( "GRAPH CHANGED after testing" );
1263 # Unmake an equivalence link between two readings. Should only be called internally.
1264 sub _break_equivalence {
1265 my( $self, $source, $target ) = @_;
1267 # This is the hard one. Need to reconstruct the equivalence groups without
1270 map { $sng{$_} = 1 } $self->_find_equiv_without( $source, $target );
1271 map { $tng{$_} = 1 } $self->_find_equiv_without( $target, $source );
1272 # If these groups intersect, they are still connected; do nothing.
1273 foreach my $el ( keys %tng ) {
1274 return if( exists $sng{$el} );
1276 # If they don't intersect, then we split the nodes in the graph and in
1277 # the hashes. First figure out which group has which name
1278 my $oldgroup = $self->equivalence( $source ); # same as $target
1279 my $keepsource = $sng{$oldgroup};
1280 my $newgroup = $keepsource ? $target : $source;
1281 my( $oldmembers, $newmembers );
1283 $oldmembers = [ keys %sng ];
1284 $newmembers = [ keys %tng ];
1286 $oldmembers = [ keys %tng ];
1287 $newmembers = [ keys %sng ];
1290 # First alter the old group in the hash
1291 $self->set_eqreadings( $oldgroup, $oldmembers );
1292 foreach my $el ( @$oldmembers ) {
1293 $self->set_equivalence( $el, $oldgroup );
1296 # then add the new group back to the hash with its new key
1297 $self->set_eqreadings( $newgroup, $newmembers );
1298 foreach my $el ( @$newmembers ) {
1299 $self->set_equivalence( $el, $newgroup );
1302 # Now add the new group back to the equivalence graph
1303 $self->equivalence_graph->add_vertex( $newgroup );
1304 # ...add the appropriate edges to the source group vertext
1305 my $c = $self->collation;
1306 foreach my $rdg ( @$newmembers ) {
1307 foreach my $rp ( $c->sequence->predecessors( $rdg ) ) {
1308 next unless $self->equivalence( $rp );
1309 $self->equivalence_graph->add_edge( $self->equivalence( $rp ), $newgroup );
1311 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
1312 next unless $self->equivalence( $rs );
1313 $self->equivalence_graph->add_edge( $newgroup, $self->equivalence( $rs ) );
1317 # ...and figure out which edges on the old group vertex to delete.
1318 my( %old_pred, %old_succ );
1319 foreach my $rdg ( @$oldmembers ) {
1320 foreach my $rp ( $c->sequence->predecessors( $rdg ) ) {
1321 next unless $self->equivalence( $rp );
1322 $old_pred{$self->equivalence( $rp )} = 1;
1324 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
1325 next unless $self->equivalence( $rs );
1326 $old_succ{$self->equivalence( $rs )} = 1;
1329 foreach my $p ( $self->equivalence_graph->predecessors( $oldgroup ) ) {
1330 unless( $old_pred{$p} ) {
1331 $self->equivalence_graph->delete_edge( $p, $oldgroup );
1334 foreach my $s ( $self->equivalence_graph->successors( $oldgroup ) ) {
1335 unless( $old_succ{$s} ) {
1336 $self->equivalence_graph->delete_edge( $oldgroup, $s );
1339 # TODO enable this after collation parsing is done
1340 throw( "Graph got disconnected breaking $source / $target equivalence" )
1341 if $self->_is_disconnected && $self->collation->tradition->_initialized;
1344 sub _find_equiv_without {
1345 my( $self, $first, $second ) = @_;
1346 my %found = ( $first => 1 );
1347 my $check = [ $first ];
1351 foreach my $r ( @$check ) {
1352 foreach my $nr ( $self->graph->neighbors( $r ) ) {
1353 next if $r eq $second;
1354 if( $self->get_relationship( $r, $nr )->colocated ) {
1355 push( @$more, $nr ) unless exists $found{$nr};
1365 =head2 rebuild_equivalence
1367 (Re)build the equivalence graph from scratch. Dumps the graph, makes a new one,
1368 adds all readings and edges, then makes an equivalence for all relationships.
1372 sub rebuild_equivalence {
1374 my $newgraph = Graph->new();
1375 # Set this as the new equivalence graph
1376 $self->_reset_equivalence( $newgraph );
1377 # Clear out the data hashes
1378 $self->_clear_equivalence;
1379 $self->_clear_eqreadings;
1381 $self->collation->tradition->_init_done(0);
1383 foreach my $r ( $self->collation->readings ) {
1385 $newgraph->add_vertex( $rid );
1386 $self->set_equivalence( $rid, $rid );
1387 $self->set_eqreadings( $rid, [ $rid ] );
1391 foreach my $e ( $self->collation->paths ) {
1392 $self->add_equivalence_edge( @$e );
1395 # Now equate the colocated readings. This does no testing;
1396 # it assumes that all preexisting relationships are valid.
1397 foreach my $rel ( $self->relationships ) {
1398 my $relobj = $self->get_relationship( $rel );
1399 next unless $relobj && $relobj->colocated;
1400 $self->_make_equivalence( @$rel );
1402 $self->collation->tradition->_init_done(1);
1405 =head2 equivalence_ranks
1407 Rank all vertices in the equivalence graph, and return a hash reference with
1408 vertex => rank mapping.
1412 sub equivalence_ranks {
1414 my $eqstart = $self->equivalence( $self->collation->start );
1415 my $eqranks = { $eqstart => 0 };
1416 my $rankeqs = { 0 => [ $eqstart ] };
1417 my @curr_origin = ( $eqstart );
1418 # A little iterative function.
1419 while( @curr_origin ) {
1420 @curr_origin = $self->_assign_rank( $eqranks, $rankeqs, @curr_origin );
1422 return( $eqranks, $rankeqs );
1426 my( $self, $node_ranks, $rank_nodes, @current_nodes ) = @_;
1427 my $graph = $self->equivalence_graph;
1428 # Look at each of the children of @current_nodes. If all the child's
1429 # parents have a rank, assign it the highest rank + 1 and add it to
1430 # @next_nodes. Otherwise skip it; we will return when the highest-ranked
1431 # parent gets a rank.
1433 foreach my $c ( @current_nodes ) {
1434 warn "Current reading $c has no rank!"
1435 unless exists $node_ranks->{$c};
1436 foreach my $child ( $graph->successors( $c ) ) {
1437 next if exists $node_ranks->{$child};
1438 my $highest_rank = -1;
1440 foreach my $parent ( $graph->predecessors( $child ) ) {
1441 if( exists $node_ranks->{$parent} ) {
1442 $highest_rank = $node_ranks->{$parent}
1443 if $highest_rank <= $node_ranks->{$parent};
1450 my $c_rank = $highest_rank + 1;
1451 # print STDERR "Assigning rank $c_rank to node $child \n";
1452 $node_ranks->{$child} = $c_rank if $node_ranks;
1453 push( @{$rank_nodes->{$c_rank}}, $child ) if $rank_nodes;
1454 push( @next_nodes, $child );
1463 my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_;
1465 my $rgraph = $xmlroot->addNewChild( $graphml_ns, 'graph' );
1466 $rgraph->setAttribute( 'edgedefault', 'directed' );
1467 $rgraph->setAttribute( 'id', 'relationships', );
1468 $rgraph->setAttribute( 'parse.edgeids', 'canonical' );
1469 $rgraph->setAttribute( 'parse.edges', 0 );
1470 $rgraph->setAttribute( 'parse.nodeids', 'canonical' );
1471 $rgraph->setAttribute( 'parse.nodes', 0 );
1472 $rgraph->setAttribute( 'parse.order', 'nodesfirst' );
1474 # Add the vertices according to their XML IDs
1475 my %rdg_lookup = ( reverse %$node_hash );
1476 # my @nlist = sort _by_xmlid keys( %rdg_lookup ); ## CAUSES SEGFAULT
1477 my @nlist = sort keys( %rdg_lookup );
1478 foreach my $n ( @nlist ) {
1479 my $n_el = $rgraph->addNewChild( $graphml_ns, 'node' );
1480 $n_el->setAttribute( 'id', $n );
1481 _add_graphml_data( $n_el, $nodeid_key, $rdg_lookup{$n} );
1483 $rgraph->setAttribute( 'parse.nodes', scalar @nlist );
1485 # Add the relationship edges, with their object information
1487 foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->graph->edges ) {
1488 # Add an edge and fill in its relationship info.
1489 next unless( exists $node_hash->{$e->[0]} && exists $node_hash->{$e->[1]} );
1490 my $edge_el = $rgraph->addNewChild( $graphml_ns, 'edge' );
1491 $edge_el->setAttribute( 'source', $node_hash->{$e->[0]} );
1492 $edge_el->setAttribute( 'target', $node_hash->{$e->[1]} );
1493 $edge_el->setAttribute( 'id', 'e'.$edge_ctr++ );
1495 my $rel_obj = $self->get_relationship( @$e );
1496 foreach my $key ( keys %$edge_keys ) {
1497 my $value = $rel_obj->$key;
1498 _add_graphml_data( $edge_el, $edge_keys->{$key}, $value )
1502 $rgraph->setAttribute( 'parse.edges', $edge_ctr );
1510 return $tmp_a <=> $tmp_b;
1513 sub _add_graphml_data {
1514 my( $el, $key, $value ) = @_;
1515 return unless defined $value;
1516 my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
1517 $data_el->setAttribute( 'key', $key );
1518 $data_el->appendText( $value );
1522 my( $self, $from, $to ) = @_;
1523 open( DUMP, ">debug.svg" ) or die "Could not open debug.svg";
1524 binmode DUMP, ':utf8';
1525 print DUMP $self->collation->as_svg({ from => $from, to => $to, nocalc => 1 });
1530 Text::Tradition::Error->throw(
1531 'ident' => 'Relationship error',
1537 __PACKAGE__->meta->make_immutable;