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: add a parallel but not sibling relationship
508 $c5->add_relationship( 'r13.6', 'r13.2', { type => 'lexical', propagate => 1 } );
509 ok( !$c5->get_relationship( 'r13.6', 'r13.1' ),
510 "Lexical relationship did not affect grammatical" );
511 foreach my $rdg ( qw/ r13.3 r13.4 r13.5 / ) {
512 my $newlex = $c5->get_relationship( 'r13.6', $rdg );
513 ok( $newlex, 'Parallel was made between indirectly linked readings' );
515 is( $newlex->type, 'lexical', 'Implicit parallel-down relationship has the correct type' );
519 # Test 5.5: try it with non-colocated relationships
520 my $numrel = scalar $c5->relationships;
521 $c5->add_relationship( 'r62.1', 'r64.1', { type => 'transposition', propagate => 1 } );
522 is( scalar $c5->relationships, $numrel+1,
523 "Adding non-colo relationship did not propagate" );
525 $c5->add_relationship( 'r61.1', 'r61.5', { type => 'orthographic' } );
526 # Add a third transposed node
527 $c5->add_relationship( 'r62.1', 'r60.3', { type => 'transposition', propagate => 1 } );
528 my $newtrans = $c5->get_relationship( 'r64.1', 'r60.3' );
529 ok( $newtrans, 'Non-colo relationship was made between indirectly linked readings' );
531 is( $newtrans->type, 'transposition', 'Implicit non-colo relationship has the correct type' );
533 is( scalar $c5->relationships, $numrel+4,
534 "Adding non-colo relationship only propagated on non-colos" );
541 sub add_relationship {
542 my( $self, $source, $target, $options ) = @_;
543 my $c = $self->collation;
544 my $sourceobj = $c->reading( $source );
545 my $targetobj = $c->reading( $target );
546 throw( "Adding self relationship at $source" ) if $source eq $target;
547 throw( "Cannot set relationship on a meta reading" )
548 if( $sourceobj->is_meta || $targetobj->is_meta );
551 my $thispaironly = delete $options->{thispaironly};
552 my $propagate = delete $options->{propagate};
553 my $droppedcolls = [];
554 if( ref( $options ) eq 'Text::Tradition::Collation::Relationship' ) {
555 $relationship = $options;
556 $reltype = $self->type( $relationship->type );
557 $thispaironly = 1; # If existing rel, set only where asked.
559 my( $is_valid, $reason ) = $self->relationship_valid( $source, $target,
560 $relationship->type, $droppedcolls );
561 unless( $is_valid ) {
562 throw( "Invalid relationship: $reason" );
565 $reltype = $self->type( $options->{type} );
567 # Try to create the relationship object.
568 my $rdga = $reltype->regularize( $sourceobj );
569 my $rdgb = $reltype->regularize( $targetobj );
570 $options->{'orig_a'} = $sourceobj;
571 $options->{'orig_b'} = $targetobj;
572 $options->{'reading_a'} = $rdga;
573 $options->{'reading_b'} = $rdgb;
574 if( exists $options->{'scope'} && $options->{'scope'} ne 'local' ) {
575 # Is there a relationship with this a & b already?
576 if( $rdga eq $rdgb ) {
577 # If we have canonified to the same thing for the relationship
578 # type we want, something is wrong.
579 # NOTE we want to allow this at the local level, as a cheap means
580 # of merging readings in the UI, until we get a better means.
581 throw( "Canonifier returns identical form $rdga for this relationship type" );
584 my $otherrel = $self->scoped_relationship( $rdga, $rdgb );
585 if( $otherrel && $otherrel->type eq $options->{type}
586 && $otherrel->scope eq $options->{scope} ) {
587 # warn "Applying existing scoped relationship for $rdga / $rdgb";
588 $relationship = $otherrel;
589 } elsif( $otherrel ) {
590 throw( 'Conflicting scoped relationship '
591 . join( '/', $otherrel->type, $otherrel->scope ) . ' vs. '
592 . join( '/', $options->{type}, $options->{scope} )
593 . " for $rdga / $rdgb at $source / $target" );
596 $relationship = $self->create( $options ) unless $relationship;
597 # ... Will throw on error
599 # See if the relationship is actually valid here
600 my( $is_valid, $reason ) = $self->relationship_valid( $source, $target,
601 $options->{'type'}, $droppedcolls );
602 unless( $is_valid ) {
603 throw( "Invalid relationship: $reason" );
608 # Now set the relationship(s).
610 my $rel = $self->get_relationship( $source, $target );
612 if( $rel && $rel ne $relationship ) {
613 if( $rel->nonlocal ) {
614 throw( "Found conflicting relationship at $source - $target" );
615 } elsif( !$reltype->is_weak ) {
616 # Replace a weak relationship; leave any other sort in place.
617 my $r1ann = $rel->has_annotation ? $rel->annotation : '';
618 my $r2ann = $relationship->has_annotation ? $relationship->annotation : '';
619 unless( $rel->type eq $relationship->type && $r1ann eq $r2ann ) {
620 warn sprintf( "Not overriding local relationship %s with global %s "
621 . "set at %s -> %s (%s -> %s)", $rel->type, $relationship->type,
622 $source, $target, $rel->reading_a, $rel->reading_b );
627 $self->_set_relationship( $relationship, $source, $target ) unless $skip;
628 push( @pairs_set, [ $source, $target, $relationship->type ] );
630 # Find all the pairs for which we need to set the relationship.
631 if( $relationship->colocated && $relationship->nonlocal && !$thispaironly ) {
632 my @global_set = $self->add_global_relationship( $relationship );
633 map { push( @$_, $relationship->type ) } @global_set;
634 push( @pairs_set, @global_set );
638 foreach my $ps ( @pairs_set ) {
639 my @extra = $self->propagate_relationship( $ps->[0], $ps->[1] );
640 push( @prop, @extra );
642 push( @pairs_set, @prop ) if @prop;
645 # Finally, restore whatever collations we can, and return.
646 $self->_restore_weak( @$droppedcolls );
650 =head2 add_global_relationship( $options, $skipvector )
652 Adds the relationship specified wherever the relevant readings appear together
653 in the graph. Options as in add_relationship above.
657 sub add_global_relationship {
658 my( $self, $relationship ) = @_;
660 my $reltype = $self->type( $relationship->type );
661 throw( "Relationship passed to add_global is not global" )
662 unless $relationship->nonlocal;
663 throw( "Relationship passed to add_global is not a valid global type" )
664 unless $reltype->is_generalizable;
666 # Apply the relationship wherever it is valid
668 foreach my $v ( $self->_find_applicable( $relationship ) ) {
669 my $exists = $self->get_relationship( @$v );
670 my $etype = $exists ? $self->type( $exists->type ) : '';
671 if( $exists && !$etype->is_weak ) {
672 unless( $exists->is_equivalent( $relationship ) ) {
673 throw( "Found conflicting relationship at @$v" );
678 @added = $self->add_relationship( @$v, $relationship );
680 my $reldesc = sprintf( "%s %s -> %s", $relationship->type,
681 $relationship->reading_a, $relationship->reading_b );
682 # print STDERR "Global relationship $reldesc not applicable at @$v\n";
684 push( @pairs_set, @added ) if @added;
691 =head2 del_scoped_relationship( $reading_a, $reading_b )
693 Returns the general (document-level or global) relationship that has been defined
694 between the two reading strings. Returns undef if there is no general relationship.
698 sub del_scoped_relationship {
699 my( $self, $rdga, $rdgb ) = @_;
700 my( $first, $second ) = sort( $rdga, $rdgb );
701 return delete $self->scopedrels->{$first}->{$second};
704 sub _find_applicable {
705 my( $self, $rel ) = @_;
706 my $c = $self->collation;
707 my $reltype = $self->type( $rel->type );
709 my @identical_readings;
710 @identical_readings = grep { $reltype->regularize( $_ ) eq $rel->reading_a }
712 foreach my $ir ( @identical_readings ) {
714 @itarget = grep { $reltype->regularize( $_ ) eq $rel->reading_b }
715 $c->readings_at_rank( $ir->rank );
717 # Warn if there is more than one hit with no closer link between them.
718 my $itmain = shift @itarget;
721 my $bindlevel = $reltype->bindlevel;
722 map { $all_targets{$_} = 1 } @itarget;
723 map { delete $all_targets{$_} }
724 $self->related_readings( $itmain, sub {
725 $self->type( $_[0]->type )->bindlevel < $bindlevel } );
726 warn "More than one unrelated reading with text " . $itmain->text
727 . " at rank " . $ir->rank . "!" if keys %all_targets;
729 push( @vectors, [ $ir->id, $itmain->id ] );
735 =head2 del_relationship( $source, $target )
737 Removes the relationship between the given readings. If the relationship is
738 non-local, removes the relationship everywhere in the graph.
742 sub del_relationship {
743 my( $self, $source, $target ) = @_;
744 my $rel = $self->get_relationship( $source, $target );
745 return () unless $rel; # Nothing to delete; return an empty set.
746 my $reltype = $self->type( $rel->type );
747 my $colo = $rel->colocated;
748 my @vectors = ( [ $source, $target ] );
749 $self->_remove_relationship( $colo, $source, $target );
750 if( $rel->nonlocal ) {
751 # Remove the relationship wherever it occurs.
752 my @rel_edges = grep { $self->get_relationship( @$_ ) eq $rel }
753 $self->relationships;
754 foreach my $re ( @rel_edges ) {
755 $self->_remove_relationship( $colo, @$re );
756 push( @vectors, $re );
758 $self->del_scoped_relationship( $rel->reading_a, $rel->reading_b );
763 sub _remove_relationship {
764 my( $self, $equiv, @vector ) = @_;
765 $self->graph->delete_edge( @vector );
766 $self->_break_equivalence( @vector ) if $equiv;
769 =head2 relationship_valid( $source, $target, $type )
771 Checks whether a relationship of type $type may exist between the readings given
772 in $source and $target. Returns a tuple of ( status, message ) where status is
773 a yes/no boolean and, if the answer is no, message gives the reason why.
777 sub relationship_valid {
778 my( $self, $source, $target, $rel, $mustdrop ) = @_;
779 $mustdrop = [] unless $mustdrop; # in case we were passed nothing
780 my $c = $self->collation;
781 my $reltype = $self->type( $rel );
782 ## Assume validity is okay if we are initializing from scratch.
783 return ( 1, "initializing" ) unless $c->tradition->_initialized;
784 ## TODO Move this block to relationship type definition when we can save
786 if ( $rel eq 'transposition' || $rel eq 'repetition' ) {
787 # Check that the two readings do (for a repetition) or do not (for
788 # a transposition) appear in the same witness.
789 # TODO this might be called before witness paths are set...
791 map { $seen_wits{$_} = 1 } $c->reading_witnesses( $source );
792 foreach my $w ( $c->reading_witnesses( $target ) ) {
793 if( $seen_wits{$w} ) {
794 return ( 0, "Readings both occur in witness $w" )
795 if $rel eq 'transposition';
796 return ( 1, "ok" ) if $rel eq 'repetition';
799 return ( 0, "Readings occur only in distinct witnesses" )
800 if $rel eq 'repetition';
802 if ( $reltype->is_colocation ) {
803 # Check that linking the source and target in a relationship won't lead
804 # to a path loop for any witness.
805 # First, drop/stash any collations that might interfere
806 my $sourceobj = $c->reading( $source );
807 my $targetobj = $c->reading( $target );
808 my $sourcerank = $sourceobj->has_rank ? $sourceobj->rank : -1;
809 my $targetrank = $targetobj->has_rank ? $targetobj->rank : -1;
810 unless( $rel eq 'collated' || $sourcerank == $targetrank ) {
811 push( @$mustdrop, $self->_drop_weak( $source ) );
812 push( @$mustdrop, $self->_drop_weak( $target ) );
813 if( $c->end->has_rank ) {
814 foreach my $rk ( $sourcerank .. $targetrank ) {
815 map { push( @$mustdrop, $self->_drop_weak( $_->id ) ) }
816 $c->readings_at_rank( $rk );
820 unless( $self->test_equivalence( $source, $target ) ) {
821 $self->_restore_weak( @$mustdrop );
822 return( 0, "Relationship would create witness loop" );
826 # We also need to check that the readings are not in the same place.
827 # That is, proposing to equate them should cause a witness loop.
828 if( $self->test_equivalence( $source, $target ) ) {
829 return ( 0, "Readings appear to be colocated" );
837 my( $self, $reading ) = @_;
839 foreach my $n ( $self->graph->neighbors( $reading ) ) {
840 my $nrel = $self->get_relationship( $reading, $n );
841 if( $self->type( $nrel->type )->is_weak ) {
842 push( @dropped, [ $reading, $n, $nrel->type ] );
843 $self->del_relationship( $reading, $n );
844 #print STDERR "Dropped weak relationship $reading -> $n\n";
851 my( $self, @vectors ) = @_;
852 foreach my $v ( @vectors ) {
855 $self->add_relationship( @$v, { 'type' => $type } );
856 #print STDERR "Restored weak relationship @$v\n";
857 }; # if it fails we don't care
861 =head2 related_readings( $reading, $filter )
863 Returns a list of readings that are connected via direct relationship links
864 to $reading. If $filter is set to a subroutine ref, returns only those
865 related readings where $filter( $relationship ) returns a true value.
869 sub related_readings {
870 my( $self, $reading, $filter ) = @_;
872 if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
873 $reading = $reading->id;
879 if( $filter eq 'colocated' ) {
880 $filter = sub { $_[0]->colocated };
881 } elsif( !ref( $filter ) ) {
883 $filter = sub { $_[0]->type eq $type };
885 @answer = grep { &$filter( $self->get_relationship( $reading, $_ ) ) }
886 $self->graph->neighbors( $reading );
888 @answer = $self->graph->neighbors( $reading );
890 if( $return_object ) {
891 my $c = $self->collation;
892 return map { $c->reading( $_ ) } @answer;
898 =head2 propagate_relationship( $rel )
900 Apply the transitivity and binding level rules to propagate the consequences of
901 the specified relationship link, ensuring all consequent relationships exist.
902 For now, we only propagate colocation links if we are passed a colocation, and
903 we only propagate displacement links if we are given a displacement.
905 Returns an array of tuples ( rdg1, rdg2, type ) for each new reading set.
909 sub propagate_relationship {
910 my( $self, @rel ) = @_;
911 ## Check that the vector is an arrayref
912 my $rel = @rel > 1 ? \@rel : $rel[0];
913 ## Get the relationship info
914 my $relobj = $self->get_relationship( $rel );
915 my $reltype = $self->type( $relobj->type );
916 return () unless $reltype->is_transitive;
919 my $colo = $reltype->is_colocation;
920 my $bindlevel = $reltype->bindlevel;
922 ## Find all readings that are linked via this relationship type
923 my %thislevel = ( $rel->[0] => 1, $rel->[1] => 1 );
928 foreach my $r ( @$check ) {
929 push( @$more, grep { !exists $thislevel{$_}
930 && $self->get_relationship( $r, $_ )
931 && $self->get_relationship( $r, $_ )->type eq $relobj->type }
932 $self->graph->neighbors( $r ) );
934 map { $thislevel{$_} = 1 } @$more;
938 ## Make sure every reading of our relationship type is linked to every other
939 my @samelevel = keys %thislevel;
940 while( @samelevel ) {
941 my $r = shift @samelevel;
942 foreach my $nr ( @samelevel ) {
943 my $existing = $self->get_relationship( $r, $nr );
945 # Check that it's a matching type
946 throw( "Conflicting existing relationship at $r, $nr trying to propagate "
947 . $relobj->type . " relationship at @$rel" )
948 unless $existing->type eq $relobj->type;
950 # Try to add a new relationship here
952 my @new = $self->add_relationship( $r, $nr, { type => $relobj->type,
953 annotation => "Propagated from relationship at @$rel" } );
954 push( @newly_set, @new );
955 } catch ( Text::Tradition::Error $e ) {
956 throw( "Could not propagate " . $relobj->type .
957 " relationship (original @$rel) at $r -- $nr: " .
963 ## Now for each sibling our set, look for its direct connections to
964 ## transitive readings of a different bindlevel, and make sure that
965 ## all siblings are related to those readings.
967 foreach my $n ( $self->graph->neighbors( $r ) ) {
968 my $crel = $self->get_relationship( $r, $n );
970 my $crt = $self->type( $crel->type );
971 if( $crt->is_transitive && $crt->is_colocation == $colo ) {
972 next if $crt->bindlevel == $reltype->bindlevel;
973 my $nrel = $crt->bindlevel < $reltype->bindlevel
974 ? $reltype->name : $crt->name;
975 push( @other, [ $n, $nrel ] );
978 # The @other array now contains tuples of ( reading, type ) where the
979 # reading is the non-sibling and the type is the type of relationship
980 # that the siblings should have to the non-sibling.
982 my( $nr, $nrtype ) = @$_;
983 foreach my $sib ( keys %thislevel ) {
985 my $existing = $self->get_relationship( $sib, $nr );
987 # Check that it's compatible. The existing relationship type
988 # should match the looser of the two relationships in play,
989 # whether the original relationship being worked on or the
990 # relationship between $r and $or.
991 if( $nrtype ne $existing->type ) {
992 throw( "Conflicting existing relationship at $nr ( -> "
993 . $self->get_relationship( $nr, $r )->type . " to $r) "
994 . " -- $sib trying to propagate " . $relobj->type
995 . " relationship at @$rel" );
998 # Try to add a new relationship here
1000 my @new = $self->add_relationship( $sib, $nr, { type => $nrtype,
1001 annotation => "Propagated from relationship at @$rel" } );
1002 push( @newly_set, @new );
1003 } catch ( Text::Tradition::Error $e ) {
1004 throw( "Could not propagate $nrtype relationship (original " .
1005 $relobj->type . " at @$rel) at $sib -- $nr: " .
1016 =head2 merge_readings( $kept, $deleted );
1018 Makes a best-effort merge of the relationship links between the given readings, and
1019 stops tracking the to-be-deleted reading.
1023 sub merge_readings {
1024 my( $self, $kept, $deleted, $combined ) = @_;
1025 foreach my $edge ( $self->graph->edges_at( $deleted ) ) {
1026 # Get the pair of kept / rel
1027 my @vector = ( $kept );
1028 push( @vector, $edge->[0] eq $deleted ? $edge->[1] : $edge->[0] );
1029 next if $vector[0] eq $vector[1]; # Don't add a self loop
1031 # If kept changes its text, drop the relationship.
1034 # If kept / rel already has a relationship, just keep the old
1035 my $rel = $self->get_relationship( @vector );
1038 # Otherwise, adopt the relationship that would be deleted.
1039 $rel = $self->get_relationship( @$edge );
1040 $self->_set_relationship( $rel, @vector );
1042 $self->_make_equivalence( $deleted, $kept );
1045 ### Equivalence logic
1047 sub _remove_equivalence_node {
1048 my( $self, $node ) = @_;
1049 my $group = $self->equivalence( $node );
1050 my $nodelist = $self->eqreadings( $group );
1051 if( @$nodelist == 1 && $nodelist->[0] eq $node ) {
1052 $self->equivalence_graph->delete_vertex( $group );
1053 $self->remove_eqreadings( $group );
1054 $self->remove_equivalence( $group );
1055 } elsif( @$nodelist == 1 ) {
1056 throw( "DATA INCONSISTENCY in equivalence graph: " . $nodelist->[0] .
1057 " in group that should have only $node" );
1059 my @newlist = grep { $_ ne $node } @$nodelist;
1060 $self->set_eqreadings( $group, \@newlist );
1061 $self->remove_equivalence( $node );
1065 =head2 add_equivalence_edge
1067 Add an edge in the equivalence graph corresponding to $source -> $target in the
1068 collation. Should only be called by Collation.
1072 sub add_equivalence_edge {
1073 my( $self, $source, $target ) = @_;
1074 my $seq = $self->equivalence( $source );
1075 my $teq = $self->equivalence( $target );
1076 $self->equivalence_graph->add_edge( $seq, $teq );
1079 =head2 delete_equivalence_edge
1081 Remove an edge in the equivalence graph corresponding to $source -> $target in the
1082 collation. Should only be called by Collation.
1086 sub delete_equivalence_edge {
1087 my( $self, $source, $target ) = @_;
1088 my $seq = $self->equivalence( $source );
1089 my $teq = $self->equivalence( $target );
1090 $self->equivalence_graph->delete_edge( $seq, $teq );
1093 sub _is_disconnected {
1095 return( scalar $self->equivalence_graph->predecessorless_vertices > 1
1096 || scalar $self->equivalence_graph->successorless_vertices > 1 );
1099 # Equate two readings in the equivalence graph
1100 sub _make_equivalence {
1101 my( $self, $source, $target ) = @_;
1102 # Get the source equivalent readings
1103 my $seq = $self->equivalence( $source );
1104 my $teq = $self->equivalence( $target );
1105 # Nothing to do if they are already equivalent...
1106 return if $seq eq $teq;
1107 my $sourcepool = $self->eqreadings( $seq );
1108 # and add them to the target readings.
1109 push( @{$self->eqreadings( $teq )}, @$sourcepool );
1110 map { $self->set_equivalence( $_, $teq ) } @$sourcepool;
1111 # Then merge the nodes in the equivalence graph.
1112 foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
1113 $self->equivalence_graph->add_edge( $pred, $teq );
1115 foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
1116 $self->equivalence_graph->add_edge( $teq, $succ );
1118 $self->equivalence_graph->delete_vertex( $seq );
1119 # TODO enable this after collation parsing is done
1120 throw( "Graph got disconnected making $source / $target equivalence" )
1121 if $self->_is_disconnected && $self->collation->tradition->_initialized;
1124 =head2 test_equivalence
1126 Test whether, if two readings were equated with a 'colocated' relationship,
1127 the graph would still be valid.
1131 sub test_equivalence {
1132 my( $self, $source, $target ) = @_;
1133 # Try merging the nodes in the equivalence graph; return a true value if
1134 # no cycle is introduced thereby. Restore the original graph first.
1136 # Keep track of edges we add
1139 # Get the reading equivalents
1140 my $seq = $self->equivalence( $source );
1141 my $teq = $self->equivalence( $target );
1142 # Maybe this is easy?
1143 return 1 if $seq eq $teq;
1145 # Save the first graph
1146 my $checkstr = $self->equivalence_graph->stringify();
1147 # Add and save relevant edges
1148 foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
1149 if( $self->equivalence_graph->has_edge( $pred, $teq ) ) {
1150 $added_pred{$pred} = 0;
1152 $self->equivalence_graph->add_edge( $pred, $teq );
1153 $added_pred{$pred} = 1;
1156 foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
1157 if( $self->equivalence_graph->has_edge( $teq, $succ ) ) {
1158 $added_succ{$succ} = 0;
1160 $self->equivalence_graph->add_edge( $teq, $succ );
1161 $added_succ{$succ} = 1;
1164 # Delete source equivalent and test
1165 $self->equivalence_graph->delete_vertex( $seq );
1166 my $ret = !$self->equivalence_graph->has_a_cycle;
1168 # Restore what we changed
1169 $self->equivalence_graph->add_vertex( $seq );
1170 foreach my $pred ( keys %added_pred ) {
1171 $self->equivalence_graph->add_edge( $pred, $seq );
1172 $self->equivalence_graph->delete_edge( $pred, $teq ) if $added_pred{$pred};
1174 foreach my $succ ( keys %added_succ ) {
1175 $self->equivalence_graph->add_edge( $seq, $succ );
1176 $self->equivalence_graph->delete_edge( $teq, $succ ) if $added_succ{$succ};
1178 unless( $self->equivalence_graph->eq( $checkstr ) ) {
1179 throw( "GRAPH CHANGED after testing" );
1185 # Unmake an equivalence link between two readings. Should only be called internally.
1186 sub _break_equivalence {
1187 my( $self, $source, $target ) = @_;
1189 # This is the hard one. Need to reconstruct the equivalence groups without
1192 map { $sng{$_} = 1 } $self->_find_equiv_without( $source, $target );
1193 map { $tng{$_} = 1 } $self->_find_equiv_without( $target, $source );
1194 # If these groups intersect, they are still connected; do nothing.
1195 foreach my $el ( keys %tng ) {
1196 return if( exists $sng{$el} );
1198 # If they don't intersect, then we split the nodes in the graph and in
1199 # the hashes. First figure out which group has which name
1200 my $oldgroup = $self->equivalence( $source ); # same as $target
1201 my $keepsource = $sng{$oldgroup};
1202 my $newgroup = $keepsource ? $target : $source;
1203 my( $oldmembers, $newmembers );
1205 $oldmembers = [ keys %sng ];
1206 $newmembers = [ keys %tng ];
1208 $oldmembers = [ keys %tng ];
1209 $newmembers = [ keys %sng ];
1212 # First alter the old group in the hash
1213 $self->set_eqreadings( $oldgroup, $oldmembers );
1214 foreach my $el ( @$oldmembers ) {
1215 $self->set_equivalence( $el, $oldgroup );
1218 # then add the new group back to the hash with its new key
1219 $self->set_eqreadings( $newgroup, $newmembers );
1220 foreach my $el ( @$newmembers ) {
1221 $self->set_equivalence( $el, $newgroup );
1224 # Now add the new group back to the equivalence graph
1225 $self->equivalence_graph->add_vertex( $newgroup );
1226 # ...add the appropriate edges to the source group vertext
1227 my $c = $self->collation;
1228 foreach my $rdg ( @$newmembers ) {
1229 foreach my $rp ( $c->sequence->predecessors( $rdg ) ) {
1230 next unless $self->equivalence( $rp );
1231 $self->equivalence_graph->add_edge( $self->equivalence( $rp ), $newgroup );
1233 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
1234 next unless $self->equivalence( $rs );
1235 $self->equivalence_graph->add_edge( $newgroup, $self->equivalence( $rs ) );
1239 # ...and figure out which edges on the old group vertex to delete.
1240 my( %old_pred, %old_succ );
1241 foreach my $rdg ( @$oldmembers ) {
1242 foreach my $rp ( $c->sequence->predecessors( $rdg ) ) {
1243 next unless $self->equivalence( $rp );
1244 $old_pred{$self->equivalence( $rp )} = 1;
1246 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
1247 next unless $self->equivalence( $rs );
1248 $old_succ{$self->equivalence( $rs )} = 1;
1251 foreach my $p ( $self->equivalence_graph->predecessors( $oldgroup ) ) {
1252 unless( $old_pred{$p} ) {
1253 $self->equivalence_graph->delete_edge( $p, $oldgroup );
1256 foreach my $s ( $self->equivalence_graph->successors( $oldgroup ) ) {
1257 unless( $old_succ{$s} ) {
1258 $self->equivalence_graph->delete_edge( $oldgroup, $s );
1261 # TODO enable this after collation parsing is done
1262 throw( "Graph got disconnected breaking $source / $target equivalence" )
1263 if $self->_is_disconnected && $self->collation->tradition->_initialized;
1266 sub _find_equiv_without {
1267 my( $self, $first, $second ) = @_;
1268 my %found = ( $first => 1 );
1269 my $check = [ $first ];
1273 foreach my $r ( @$check ) {
1274 foreach my $nr ( $self->graph->neighbors( $r ) ) {
1275 next if $r eq $second;
1276 if( $self->get_relationship( $r, $nr )->colocated ) {
1277 push( @$more, $nr ) unless exists $found{$nr};
1287 =head2 rebuild_equivalence
1289 (Re)build the equivalence graph from scratch. Dumps the graph, makes a new one,
1290 adds all readings and edges, then makes an equivalence for all relationships.
1294 sub rebuild_equivalence {
1296 my $newgraph = Graph->new();
1297 # Set this as the new equivalence graph
1298 $self->_reset_equivalence( $newgraph );
1299 # Clear out the data hashes
1300 $self->_clear_equivalence;
1301 $self->_clear_eqreadings;
1303 $self->collation->tradition->_init_done(0);
1305 foreach my $r ( $self->collation->readings ) {
1307 $newgraph->add_vertex( $rid );
1308 $self->set_equivalence( $rid, $rid );
1309 $self->set_eqreadings( $rid, [ $rid ] );
1313 foreach my $e ( $self->collation->paths ) {
1314 $self->add_equivalence_edge( @$e );
1317 # Now equate the colocated readings. This does no testing;
1318 # it assumes that all preexisting relationships are valid.
1319 foreach my $rel ( $self->relationships ) {
1320 my $relobj = $self->get_relationship( $rel );
1321 next unless $relobj && $relobj->colocated;
1322 $self->_make_equivalence( @$rel );
1324 $self->collation->tradition->_init_done(1);
1327 =head2 equivalence_ranks
1329 Rank all vertices in the equivalence graph, and return a hash reference with
1330 vertex => rank mapping.
1334 sub equivalence_ranks {
1336 my $eqstart = $self->equivalence( $self->collation->start );
1337 my $eqranks = { $eqstart => 0 };
1338 my $rankeqs = { 0 => [ $eqstart ] };
1339 my @curr_origin = ( $eqstart );
1340 # A little iterative function.
1341 while( @curr_origin ) {
1342 @curr_origin = $self->_assign_rank( $eqranks, $rankeqs, @curr_origin );
1344 return( $eqranks, $rankeqs );
1348 my( $self, $node_ranks, $rank_nodes, @current_nodes ) = @_;
1349 my $graph = $self->equivalence_graph;
1350 # Look at each of the children of @current_nodes. If all the child's
1351 # parents have a rank, assign it the highest rank + 1 and add it to
1352 # @next_nodes. Otherwise skip it; we will return when the highest-ranked
1353 # parent gets a rank.
1355 foreach my $c ( @current_nodes ) {
1356 warn "Current reading $c has no rank!"
1357 unless exists $node_ranks->{$c};
1358 foreach my $child ( $graph->successors( $c ) ) {
1359 next if exists $node_ranks->{$child};
1360 my $highest_rank = -1;
1362 foreach my $parent ( $graph->predecessors( $child ) ) {
1363 if( exists $node_ranks->{$parent} ) {
1364 $highest_rank = $node_ranks->{$parent}
1365 if $highest_rank <= $node_ranks->{$parent};
1372 my $c_rank = $highest_rank + 1;
1373 # print STDERR "Assigning rank $c_rank to node $child \n";
1374 $node_ranks->{$child} = $c_rank if $node_ranks;
1375 push( @{$rank_nodes->{$c_rank}}, $child ) if $rank_nodes;
1376 push( @next_nodes, $child );
1385 my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_;
1387 my $rgraph = $xmlroot->addNewChild( $graphml_ns, 'graph' );
1388 $rgraph->setAttribute( 'edgedefault', 'directed' );
1389 $rgraph->setAttribute( 'id', 'relationships', );
1390 $rgraph->setAttribute( 'parse.edgeids', 'canonical' );
1391 $rgraph->setAttribute( 'parse.edges', 0 );
1392 $rgraph->setAttribute( 'parse.nodeids', 'canonical' );
1393 $rgraph->setAttribute( 'parse.nodes', 0 );
1394 $rgraph->setAttribute( 'parse.order', 'nodesfirst' );
1396 # Add the vertices according to their XML IDs
1397 my %rdg_lookup = ( reverse %$node_hash );
1398 # my @nlist = sort _by_xmlid keys( %rdg_lookup ); ## CAUSES SEGFAULT
1399 my @nlist = sort keys( %rdg_lookup );
1400 foreach my $n ( @nlist ) {
1401 my $n_el = $rgraph->addNewChild( $graphml_ns, 'node' );
1402 $n_el->setAttribute( 'id', $n );
1403 _add_graphml_data( $n_el, $nodeid_key, $rdg_lookup{$n} );
1405 $rgraph->setAttribute( 'parse.nodes', scalar @nlist );
1407 # Add the relationship edges, with their object information
1409 foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->graph->edges ) {
1410 # Add an edge and fill in its relationship info.
1411 next unless( exists $node_hash->{$e->[0]} && exists $node_hash->{$e->[1]} );
1412 my $edge_el = $rgraph->addNewChild( $graphml_ns, 'edge' );
1413 $edge_el->setAttribute( 'source', $node_hash->{$e->[0]} );
1414 $edge_el->setAttribute( 'target', $node_hash->{$e->[1]} );
1415 $edge_el->setAttribute( 'id', 'e'.$edge_ctr++ );
1417 my $rel_obj = $self->get_relationship( @$e );
1418 foreach my $key ( keys %$edge_keys ) {
1419 my $value = $rel_obj->$key;
1420 _add_graphml_data( $edge_el, $edge_keys->{$key}, $value )
1424 $rgraph->setAttribute( 'parse.edges', $edge_ctr );
1432 return $tmp_a <=> $tmp_b;
1435 sub _add_graphml_data {
1436 my( $el, $key, $value ) = @_;
1437 return unless defined $value;
1438 my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
1439 $data_el->setAttribute( 'key', $key );
1440 $data_el->appendText( $value );
1444 my( $self, $from, $to ) = @_;
1445 open( DUMP, ">debug.svg" ) or die "Could not open debug.svg";
1446 binmode DUMP, ':utf8';
1447 print DUMP $self->collation->as_svg({ from => $from, to => $to, nocalc => 1 });
1452 Text::Tradition::Error->throw(
1453 'ident' => 'Relationship error',
1459 __PACKAGE__->meta->make_immutable;