projects / scpubgit/stemmatology.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
tweak relationship application order
[scpubgit/stemmatology.git] / base / lib / Text / Tradition / Collation / RelationshipStore.pm
CommitLineData
22222af9 1package Text::Tradition::Collation::RelationshipStore;
2
3use strict;
4use warnings;
24efa55d 5use Safe::Isa;
63778331 6use Text::Tradition::Error;
22222af9 7use Text::Tradition::Collation::Relationship;
24efa55d 8use Text::Tradition::Collation::RelationshipType;
a1615ee4 9use TryCatch;
22222af9 10
11use Moose;
12
13=head1 NAME
14
2626f709 15Text::Tradition::Collation::RelationshipStore - Keeps track of the relationships
16between readings in a given collation
22222af9 17
18=head1 DESCRIPTION
19
20Text::Tradition is a library for representation and analysis of collated
21texts, particularly medieval ones. The RelationshipStore is an internal object
22of the collation, to keep track of the defined relationships (both specific and
23general) between readings.
24
3ae5e2ad 25=begin testing
26
27use Text::Tradition;
ee801e17 28use TryCatch;
3ae5e2ad 29
30use_ok( 'Text::Tradition::Collation::RelationshipStore' );
31
ee801e17 32# Add some relationships, and delete them
33
34my $cxfile = 't/data/Collatex-16.xml';
35my $t = Text::Tradition->new(
56772e8c 36 'name' => 'inline',
37 'input' => 'CollateX',
38 'file' => $cxfile,
39 );
ee801e17 40my $c = $t->collation;
41
f8331a4d 42my @v1 = $c->add_relationship( 'n21', 'n22', { 'type' => 'lexical' } );
ee801e17 43is( scalar @v1, 1, "Added a single relationship" );
44is( $v1[0]->[0], 'n21', "Got correct node 1" );
45is( $v1[0]->[1], 'n22', "Got correct node 2" );
679f17e1 46my @v2 = $c->add_relationship( 'n24', 'n23',
ee801e17 47 { 'type' => 'spelling', 'scope' => 'global' } );
48is( scalar @v2, 2, "Added a global relationship with two instances" );
49@v1 = $c->del_relationship( 'n22', 'n21' );
50is( scalar @v1, 1, "Deleted first relationship" );
679f17e1 51@v2 = $c->del_relationship( 'n12', 'n13' );
ee801e17 52is( scalar @v2, 2, "Deleted second global relationship" );
681893aa 53my @v3 = $c->del_relationship( 'n1', 'n2' );
54is( scalar @v3, 0, "Nothing deleted on non-existent relationship" );
ee801e17 55
3ae5e2ad 56=end testing
57
22222af9 58=head1 METHODS
59
60=head2 new( collation => $collation );
61
62Creates a new relationship store for the given collation.
63
64=cut
65
66has 'collation' => (
67 is => 'ro',
68 isa => 'Text::Tradition::Collation',
69 required => 1,
70 weak_ref => 1,
71 );
24efa55d 72
73=head2 types
74
75Registry of possible relationship types. See RelationshipType for more info.
76
77=cut
78
79has 'relationship_types' => (
80 is => 'ro',
81 traits => ['Hash'],
82 handles => {
83 has_type => 'exists',
84 add_type => 'set',
85 type => 'get',
86 del_type => 'delete'
87 },
88 );
22222af9 89
90has 'scopedrels' => (
91 is => 'ro',
92 isa => 'HashRef[HashRef[Text::Tradition::Collation::Relationship]]',
93 default => sub { {} },
94 );
95
96has 'graph' => (
97 is => 'ro',
98 isa => 'Graph',
99 default => sub { Graph->new( undirected => 1 ) },
100 handles => {
101 relationships => 'edges',
102 add_reading => 'add_vertex',
103 delete_reading => 'delete_vertex',
24efa55d 104 },
22222af9 105 );
106
359944f7 107=head2 equivalence_graph()
108
109Returns an equivalence graph of the collation, in which all readings
110related via a 'colocated' relationship are transformed into a single
111vertex. Can be used to determine the validity of a new relationship.
112
113=cut
114
115has 'equivalence_graph' => (
116 is => 'ro',
117 isa => 'Graph',
118 default => sub { Graph->new() },
e1083e99 119 writer => '_reset_equivalence',
359944f7 120 );
121
122has '_node_equivalences' => (
123 is => 'ro',
124 traits => ['Hash'],
125 handles => {
126 equivalence => 'get',
127 set_equivalence => 'set',
128 remove_equivalence => 'delete',
04482188 129 _clear_equivalence => 'clear',
24efa55d 130 },
359944f7 131 );
132
133has '_equivalence_readings' => (
134 is => 'ro',
135 traits => ['Hash'],
136 handles => {
137 eqreadings => 'get',
138 set_eqreadings => 'set',
139 remove_eqreadings => 'delete',
04482188 140 _clear_eqreadings => 'clear',
24efa55d 141 },
359944f7 142 );
143
24efa55d 144## Build function - here we have our default set of relationship types.
145
146sub BUILD {
147 my $self = shift;
148
24efa55d 149 my @DEFAULT_TYPES = (
150 { name => 'collated', bindlevel => 50, is_weak => 1, is_transitive => 0, is_generalizable => 0 },
c7bd2768 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 },
9e9b7540 158 { name => 'transposition', bindlevel => 50, is_colocation => 0 },
24efa55d 159 { name => 'repetition', bindlevel => 50, is_colocation => 0, is_transitive => 0 }
160 );
161
162 foreach my $type ( @DEFAULT_TYPES ) {
163 $self->add_type( $type );
164 }
165}
166
24efa55d 167around add_type => sub {
168 my $orig = shift;
169 my $self = shift;
170 my $new_type;
171 if( @_ == 1 && $_[0]->$_isa( 'Text::Tradition::Collation::RelationshipType' ) ) {
172 $new_type = shift;
173 } else {
174 my %args = @_ == 1 ? %{$_[0]} : @_;
175 $new_type = Text::Tradition::Collation::RelationshipType->new( %args );
176 }
177 $self->$orig( $new_type->name => $new_type );
178 return $new_type;
179};
180
359944f7 181around add_reading => sub {
182 my $orig = shift;
183 my $self = shift;
184
185 $self->equivalence_graph->add_vertex( @_ );
186 $self->set_equivalence( $_[0], $_[0] );
187 $self->set_eqreadings( $_[0], [ $_[0] ] );
188 $self->$orig( @_ );
189};
190
191around delete_reading => sub {
192 my $orig = shift;
193 my $self = shift;
194
359944f7 195 $self->_remove_equivalence_node( @_ );
196 $self->$orig( @_ );
197};
198
3ae5e2ad 199=head2 get_relationship
200
201Return the relationship object, if any, that exists between two readings.
202
203=cut
204
205sub get_relationship {
4633f9e4 206 my $self = shift;
207 my @vector;
208 if( @_ == 1 && ref( $_[0] ) eq 'ARRAY' ) {
209 # Dereference the edge arrayref that was passed.
210 my $edge = shift;
211 @vector = @$edge;
212 } else {
213 @vector = @_;
214 }
3ae5e2ad 215 my $relationship;
216 if( $self->graph->has_edge_attribute( @vector, 'object' ) ) {
217 $relationship = $self->graph->get_edge_attribute( @vector, 'object' );
ca6e6095 218 }
3ae5e2ad 219 return $relationship;
220}
221
222sub _set_relationship {
223 my( $self, $relationship, @vector ) = @_;
224 $self->graph->add_edge( @vector );
225 $self->graph->set_edge_attribute( @vector, 'object', $relationship );
176badfe 226 $self->_make_equivalence( @vector ) if $relationship->colocated;
3ae5e2ad 227}
a1615ee4 228
22222af9 229=head2 create
230
231Create a new relationship with the given options and return it.
232Warn and return undef if the relationship cannot be created.
233
234=cut
235
236sub create {
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'};
3ae5e2ad 241 my $rel = $self->get_relationship( $source, $target );
242 if( $rel ) {
24efa55d 243 if( $self->type( $rel->type )->is_weak ) {
244 # Always replace a weak relationship with a more descriptive
3d14b48e 245 # one, if asked.
246 $self->del_relationship( $source, $target );
247 } elsif( $rel->type ne $options->{'type'} ) {
63778331 248 throw( "Another relationship of type " . $rel->type
249 . " already exists between $source and $target" );
22222af9 250 } else {
251 return $rel;
252 }
253 }
254
99ab9535 255 $rel = Text::Tradition::Collation::Relationship->new( $options );
24efa55d 256 my $reltype = $self->type( $rel->type );
c7bd2768 257 throw( "Unrecognized relationship type " . $rel->type ) unless $reltype;
24efa55d 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;
261
99ab9535 262 $self->add_scoped_relationship( $rel ) if $rel->nonlocal;
263 return $rel;
22222af9 264}
265
266=head2 add_scoped_relationship( $rel )
267
268Keep track of relationships defined between specific readings that are scoped
269non-locally. Key on whichever reading occurs first alphabetically.
270
271=cut
272
273sub add_scoped_relationship {
274 my( $self, $rel ) = @_;
24efa55d 275 my $rdga = $rel->reading_a;
276 my $rdgb = $rel->reading_b;
f222800e 277 my $r = $self->scoped_relationship( $rdga, $rdgb );
22222af9 278 if( $r ) {
279 warn sprintf( "Scoped relationship of type %s already exists between %s and %s",
f222800e 280 $r->type, $rdga, $rdgb );
22222af9 281 return;
282 }
f222800e 283 my( $first, $second ) = sort ( $rdga, $rdgb );
284 $self->scopedrels->{$first}->{$second} = $rel;
22222af9 285}
286
287=head2 scoped_relationship( $reading_a, $reading_b )
288
289Returns the general (document-level or global) relationship that has been defined
290between the two reading strings. Returns undef if there is no general relationship.
291
292=cut
293
294sub 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};
24efa55d 299 }
300 return undef;
22222af9 301}
302
303=head2 add_relationship( $self, $source, $sourcetext, $target, $targettext, $opts )
304
305Adds the relationship specified in $opts (see Text::Tradition::Collation::Relationship
306for the possible options) between the readings given in $source and $target. Sets
307up a scoped relationship between $sourcetext and $targettext if the relationship is
308scoped non-locally.
309
310Returns a status boolean and a list of all reading pairs connected by the call to
311add_relationship.
312
6d381462 313=begin testing
314
56772e8c 315use Test::Warn;
6d381462 316use Text::Tradition;
317use TryCatch;
318
56772e8c 319my $t1;
e92d4229 320warnings_exist {
56772e8c 321 $t1 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/legendfrag.xml' );
e92d4229 322} [qr/Cannot set relationship on a meta reading/],
56772e8c 323 "Got expected relationship drop warning on parse";
324
176badfe 325# Test 1.1: try to equate nodes that are prevented with an intermediate collation
6d381462 326ok( $t1, "Parsed test fragment file" );
327my $c1 = $t1->collation;
10e4b1ac 328my $trel = $c1->get_relationship( 'r9.2', 'r9.3' );
6d381462 329is( ref( $trel ), 'Text::Tradition::Collation::Relationship',
330 "Troublesome relationship exists" );
331is( $trel->type, 'collated', "Troublesome relationship is a collation" );
332
333# Try to make the link we want
334try {
10e4b1ac 335 $c1->add_relationship( 'r8.6', 'r10.3', { 'type' => 'orthographic' } );
6d381462 336 ok( 1, "Added cross-collation relationship as expected" );
176badfe 337} catch( Text::Tradition::Error $e ) {
338 ok( 0, "Existing collation blocked equivalence relationship: " . $e->message );
6d381462 339}
340
341try {
342 $c1->calculate_ranks();
343 ok( 1, "Successfully calculated ranks" );
176badfe 344} catch ( Text::Tradition::Error $e ) {
345 ok( 0, "Collation now has a cycle: " . $e->message );
6d381462 346}
347
176badfe 348# Test 1.2: attempt merge of an identical reading
359944f7 349try {
10e4b1ac 350 $c1->merge_readings( 'r9.3', 'r11.5' );
359944f7 351 ok( 1, "Successfully merged reading 'pontifex'" );
352} catch ( Text::Tradition::Error $e ) {
353 ok( 0, "Merge of mergeable readings failed: $e->message" );
354
355}
356
176badfe 357# Test 1.3: attempt relationship with a meta reading (should fail)
358try {
10e4b1ac 359 $c1->add_relationship( 'r8.1', 'r9.2', { 'type' => 'collated' } );
176badfe 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" );
364}
365
beb47b16 366# Test 1.4: try to break a relationship near a meta reading
367$c1->add_relationship( 'r7.6', 'r7.3', { type => 'orthographic' } );
368try {
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" );
372} catch {
373 ok( 0, "Relationship deletion failed with a meta reading as neighbor" );
374}
375
176badfe 376# Test 2.1: try to equate nodes that are prevented with a real intermediate
6d381462 377# equivalence
56772e8c 378my $t2;
e92d4229 379warnings_exist {
56772e8c 380 $t2 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/legendfrag.xml' );
e92d4229 381} [qr/Cannot set relationship on a meta reading/],
56772e8c 382 "Got expected relationship drop warning on parse";
6d381462 383my $c2 = $t2->collation;
10e4b1ac 384$c2->add_relationship( 'r9.2', 'r9.3', { 'type' => 'lexical' } );
385my $trel2 = $c2->get_relationship( 'r9.2', 'r9.3' );
6d381462 386is( ref( $trel2 ), 'Text::Tradition::Collation::Relationship',
387 "Created blocking relationship" );
388is( $trel2->type, 'lexical', "Blocking relationship is not a collation" );
389# This time the link ought to fail
390try {
10e4b1ac 391 $c2->add_relationship( 'r8.6', 'r10.3', { 'type' => 'orthographic' } );
414cc046 392 ok( 0, "Added cross-equivalent bad relationship" );
176badfe 393} catch ( Text::Tradition::Error $e ) {
394 like( $e->message, qr/witness loop/,
395 "Existing equivalence blocked crossing relationship" );
6d381462 396}
397
398try {
399 $c2->calculate_ranks();
400 ok( 1, "Successfully calculated ranks" );
176badfe 401} catch ( Text::Tradition::Error $e ) {
402 ok( 0, "Collation now has a cycle: " . $e->message );
6d381462 403}
404
176badfe 405# Test 3.1: make a straightforward pair of transpositions.
cc31ebaa 406my $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
408my $c3 = $t3->collation;
409try {
10e4b1ac 410 $c3->add_relationship( 'r36.4', 'r38.3', { 'type' => 'transposition' } );
cc31ebaa 411 ok( 1, "Added straightforward transposition" );
176badfe 412} catch ( Text::Tradition::Error $e ) {
413 ok( 0, "Failed to add normal transposition: " . $e->message );
cc31ebaa 414}
415try {
10e4b1ac 416 $c3->add_relationship( 'r36.3', 'r38.2', { 'type' => 'transposition' } );
cc31ebaa 417 ok( 1, "Added straightforward transposition complement" );
176badfe 418} catch ( Text::Tradition::Error $e ) {
419 ok( 0, "Failed to add normal transposition complement: " . $e->message );
cc31ebaa 420}
421
176badfe 422# Test 3.2: try to make a transposition that could be a parallel.
cc31ebaa 423try {
10e4b1ac 424 $c3->add_relationship( 'r28.2', 'r29.2', { 'type' => 'transposition' } );
cc31ebaa 425 ok( 0, "Added bad colocated transposition" );
176badfe 426} catch ( Text::Tradition::Error $e ) {
427 like( $e->message, qr/Readings appear to be colocated/,
428 "Prevented bad colocated transposition" );
cc31ebaa 429}
430
176badfe 431# Test 3.3: make the parallel, and then make the transposition again.
cc31ebaa 432try {
10e4b1ac 433 $c3->add_relationship( 'r28.3', 'r29.3', { 'type' => 'orthographic' } );
cc31ebaa 434 ok( 1, "Equated identical readings for transposition" );
176badfe 435} catch ( Text::Tradition::Error $e ) {
436 ok( 0, "Failed to equate identical readings: " . $e->message );
cc31ebaa 437}
438try {
10e4b1ac 439 $c3->add_relationship( 'r28.2', 'r29.2', { 'type' => 'transposition' } );
cc31ebaa 440 ok( 1, "Added straightforward transposition complement" );
176badfe 441} catch ( Text::Tradition::Error $e ) {
442 ok( 0, "Failed to add normal transposition complement: " . $e->message );
cc31ebaa 443}
444
9e9b7540 445# Test 4: make a global relationship that involves re-ranking a node first, when
c7bd2768 446# the prior rank has a potential match too
447my $t4 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/globalrel_test.xml' );
98a66507 448my $c4 = $t4->collation;
449# Can we even add the relationship?
450try {
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: "
456 . $e->message );
457}
458$c4->calculate_ranks();
459# Do our readings now share a rank?
460is( $c4->reading('r463.2')->rank, $c4->reading('r463.4')->rank,
461 "Expected readings now at same rank" );
9e9b7540 462
463# Test group 5: relationship transitivity.
464my $t5 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/john.xml' );
465my $c5 = $t5->collation;
466
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 } );
470my $impliedrel = $c5->get_relationship( 'r13.1', 'r13.5' );
471ok( $impliedrel, 'Relationship was made between indirectly linked readings' );
472if( $impliedrel ) {
473 is( $impliedrel->type, 'grammatical', 'Implicit inbound relationship has the correct type' );
474}
475
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 } );
478foreach 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' );
481 if( $newgram ) {
482 is( $newgram->type, 'grammatical', 'Implicit outbound relationship has the correct type' );
483 }
484}
485my $neworth = $c5->get_relationship( 'r13.2', 'r13.3' );
486ok( $neworth, 'Relationship was made between indirectly linked siblings' );
487if( $neworth ) {
488 is( $neworth->type, 'orthographic', 'Implicit direct relationship has the correct type' );
489}
490
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
494my $newgram = $c5->get_relationship( 'r13.4', 'r13.1' );
495ok( $newgram, 'Relationship was made between indirectly linked readings' );
496if( $newgram ) {
497 is( $newgram->type, 'grammatical', 'Implicit intermediate-out relationship has the correct type' );
498}
499foreach 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' );
502 if( $newspel ) {
503 is( $newspel->type, 'spelling', 'Implicit intermediate-in relationship has the correct type' );
504 }
505}
506
52179f61 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
509my $numrel = scalar $c5->relationships;
510$c5->del_relationship( 'r13.4', 'r13.2' );
511try {
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 );
516}
517is( $numrel, scalar $c5->relationships, "Number of relationships did not change" );
518foreach 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' );
521 if( $newspel ) {
522 is( $newspel->type, 'spelling', 'Reinstated intermediate-in relationship has the correct type' );
523 }
524}
525my $stillgram = $c5->get_relationship( 'r13.4', 'r13.1' );
526ok( $stillgram, 'Relationship was made between indirectly linked readings' );
527if( $stillgram ) {
528 is( $stillgram->type, 'grammatical', 'Reinstated intermediate-out relationship has the correct type' );
529}
530
531# Test 5.5: add a parallel but not sibling relationship
9e9b7540 532$c5->add_relationship( 'r13.6', 'r13.2', { type => 'lexical', propagate => 1 } );
533ok( !$c5->get_relationship( 'r13.6', 'r13.1' ),
534 "Lexical relationship did not affect grammatical" );
535foreach 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' );
538 if( $newlex ) {
539 is( $newlex->type, 'lexical', 'Implicit parallel-down relationship has the correct type' );
540 }
541}
542
52179f61 543# Test 5.6: try it with non-colocated relationships
544$numrel = scalar $c5->relationships;
9e9b7540 545$c5->add_relationship( 'r62.1', 'r64.1', { type => 'transposition', propagate => 1 } );
546is( scalar $c5->relationships, $numrel+1,
547 "Adding non-colo relationship did not propagate" );
548# Add a pivot point
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 } );
552my $newtrans = $c5->get_relationship( 'r64.1', 'r60.3' );
553ok( $newtrans, 'Non-colo relationship was made between indirectly linked readings' );
554if( $newtrans ) {
555 is( $newtrans->type, 'transposition', 'Implicit non-colo relationship has the correct type' );
556}
557is( scalar $c5->relationships, $numrel+4,
558 "Adding non-colo relationship only propagated on non-colos" );
559
52179f61 560# TODO test that attempts to cross boundaries on bindlevel-equal relationships fail.
c7bd2768 561
c96efd0b 562# TODO test that weak relationships don't interfere
563
564# TODO test that strong non-transitive relationships don't interfere
565
6d381462 566=end testing
567
22222af9 568=cut
569
570sub add_relationship {
414cc046 571 my( $self, $source, $target, $options ) = @_;
572 my $c = $self->collation;
176badfe 573 my $sourceobj = $c->reading( $source );
574 my $targetobj = $c->reading( $target );
359944f7 575 throw( "Adding self relationship at $source" ) if $source eq $target;
176badfe 576 throw( "Cannot set relationship on a meta reading" )
577 if( $sourceobj->is_meta || $targetobj->is_meta );
ca6e6095 578 my $relationship;
24efa55d 579 my $reltype;
c7bd2768 580 my $thispaironly = delete $options->{thispaironly};
9e9b7540 581 my $propagate = delete $options->{propagate};
414cc046 582 my $droppedcolls = [];
ca6e6095 583 if( ref( $options ) eq 'Text::Tradition::Collation::Relationship' ) {
584 $relationship = $options;
24efa55d 585 $reltype = $self->type( $relationship->type );
ca6e6095 586 $thispaironly = 1; # If existing rel, set only where asked.
24efa55d 587 # Test the validity
414cc046 588 my( $is_valid, $reason ) = $self->relationship_valid( $source, $target,
24efa55d 589 $relationship->type, $droppedcolls );
ca6e6095 590 unless( $is_valid ) {
591 throw( "Invalid relationship: $reason" );
592 }
24efa55d 593 } else {
594 $reltype = $self->type( $options->{type} );
ca6e6095 595
596 # Try to create the relationship object.
c7bd2768 597 my $rdga = $reltype->regularize( $sourceobj );
598 my $rdgb = $reltype->regularize( $targetobj );
24efa55d 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' ) {
0ac5e750 604 # Is there a relationship with this a & b already?
24efa55d 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" );
611 }
612
f222800e 613 my $otherrel = $self->scoped_relationship( $rdga, $rdgb );
0ac5e750 614 if( $otherrel && $otherrel->type eq $options->{type}
615 && $otherrel->scope eq $options->{scope} ) {
24efa55d 616 # warn "Applying existing scoped relationship for $rdga / $rdgb";
0ac5e750 617 $relationship = $otherrel;
99ab9535 618 } elsif( $otherrel ) {
24efa55d 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" );
0ac5e750 623 }
624 }
24efa55d 625 $relationship = $self->create( $options ) unless $relationship;
626 # ... Will throw on error
627
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" );
633 }
22222af9 634 }
ca6e6095 635
22222af9 636
22222af9 637 # Now set the relationship(s).
638 my @pairs_set;
414cc046 639 my $rel = $self->get_relationship( $source, $target );
cc31ebaa 640 my $skip;
414cc046 641 if( $rel && $rel ne $relationship ) {
642 if( $rel->nonlocal ) {
643 throw( "Found conflicting relationship at $source - $target" );
24efa55d 644 } elsif( !$reltype->is_weak ) {
645 # Replace a weak relationship; leave any other sort in place.
414cc046 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 );
414cc046 652 }
24efa55d 653 $skip = 1;
414cc046 654 }
655 }
cc31ebaa 656 $self->_set_relationship( $relationship, $source, $target ) unless $skip;
9e9b7540 657 push( @pairs_set, [ $source, $target, $relationship->type ] );
414cc046 658
428bcf0b 659 # Find all the pairs for which we need to set the relationship.
660 if( $relationship->colocated && $relationship->nonlocal && !$thispaironly ) {
9e9b7540 661 my @global_set = $self->add_global_relationship( $relationship );
9e9b7540 662 push( @pairs_set, @global_set );
663 }
664 if( $propagate ) {
665 my @prop;
666 foreach my $ps ( @pairs_set ) {
667 my @extra = $self->propagate_relationship( $ps->[0], $ps->[1] );
668 push( @prop, @extra );
669 }
670 push( @pairs_set, @prop ) if @prop;
22222af9 671 }
9e9b7540 672
414cc046 673 # Finally, restore whatever collations we can, and return.
24efa55d 674 $self->_restore_weak( @$droppedcolls );
63778331 675 return @pairs_set;
22222af9 676}
677
428bcf0b 678=head2 add_global_relationship( $options, $skipvector )
679
680Adds the relationship specified wherever the relevant readings appear together
681in the graph. Options as in add_relationship above.
682
683=cut
684
685sub add_global_relationship {
24efa55d 686 my( $self, $relationship ) = @_;
428bcf0b 687 # Sanity checking
24efa55d 688 my $reltype = $self->type( $relationship->type );
428bcf0b 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" )
24efa55d 692 unless $reltype->is_generalizable;
428bcf0b 693
694 # Apply the relationship wherever it is valid
695 my @pairs_set;
696 foreach my $v ( $self->_find_applicable( $relationship ) ) {
697 my $exists = $self->get_relationship( @$v );
24efa55d 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" );
702 }
428bcf0b 703 } else {
24efa55d 704 my @added;
705 try {
706 @added = $self->add_relationship( @$v, $relationship );
707 } catch {
708 my $reldesc = sprintf( "%s %s -> %s", $relationship->type,
709 $relationship->reading_a, $relationship->reading_b );
98a66507 710 # print STDERR "Global relationship $reldesc not applicable at @$v\n";
24efa55d 711 }
712 push( @pairs_set, @added ) if @added;
428bcf0b 713 }
714 }
715 return @pairs_set;
716}
717
718
9d829138 719=head2 del_scoped_relationship( $reading_a, $reading_b )
720
721Returns the general (document-level or global) relationship that has been defined
722between the two reading strings. Returns undef if there is no general relationship.
723
724=cut
725
726sub del_scoped_relationship {
727 my( $self, $rdga, $rdgb ) = @_;
728 my( $first, $second ) = sort( $rdga, $rdgb );
729 return delete $self->scopedrels->{$first}->{$second};
730}
731
bf6e338d 732sub _find_applicable {
733 my( $self, $rel ) = @_;
734 my $c = $self->collation;
24efa55d 735 my $reltype = $self->type( $rel->type );
bf6e338d 736 my @vectors;
737 my @identical_readings;
c7bd2768 738 @identical_readings = grep { $reltype->regularize( $_ ) eq $rel->reading_a }
24efa55d 739 $c->readings;
bf6e338d 740 foreach my $ir ( @identical_readings ) {
741 my @itarget;
c7bd2768 742 @itarget = grep { $reltype->regularize( $_ ) eq $rel->reading_b }
24efa55d 743 $c->readings_at_rank( $ir->rank );
bf6e338d 744 if( @itarget ) {
24efa55d 745 # Warn if there is more than one hit with no closer link between them.
bf6e338d 746 my $itmain = shift @itarget;
747 if( @itarget ) {
748 my %all_targets;
24efa55d 749 my $bindlevel = $reltype->bindlevel;
bf6e338d 750 map { $all_targets{$_} = 1 } @itarget;
751 map { delete $all_targets{$_} }
24efa55d 752 $self->related_readings( $itmain, sub {
753 $self->type( $_[0]->type )->bindlevel < $bindlevel } );
bf6e338d 754 warn "More than one unrelated reading with text " . $itmain->text
755 . " at rank " . $ir->rank . "!" if keys %all_targets;
756 }
757 push( @vectors, [ $ir->id, $itmain->id ] );
758 }
759 }
760 return @vectors;
761}
762
ee801e17 763=head2 del_relationship( $source, $target )
764
765Removes the relationship between the given readings. If the relationship is
766non-local, removes the relationship everywhere in the graph.
767
768=cut
769
770sub del_relationship {
771 my( $self, $source, $target ) = @_;
772 my $rel = $self->get_relationship( $source, $target );
681893aa 773 return () unless $rel; # Nothing to delete; return an empty set.
24efa55d 774 my $reltype = $self->type( $rel->type );
359944f7 775 my $colo = $rel->colocated;
ee801e17 776 my @vectors = ( [ $source, $target ] );
359944f7 777 $self->_remove_relationship( $colo, $source, $target );
ee801e17 778 if( $rel->nonlocal ) {
779 # Remove the relationship wherever it occurs.
24efa55d 780 my @rel_edges = grep { $self->get_relationship( @$_ ) eq $rel }
ee801e17 781 $self->relationships;
782 foreach my $re ( @rel_edges ) {
359944f7 783 $self->_remove_relationship( $colo, @$re );
ee801e17 784 push( @vectors, $re );
785 }
9d829138 786 $self->del_scoped_relationship( $rel->reading_a, $rel->reading_b );
ee801e17 787 }
788 return @vectors;
789}
790
ca6e6095 791sub _remove_relationship {
359944f7 792 my( $self, $equiv, @vector ) = @_;
ca6e6095 793 $self->graph->delete_edge( @vector );
176badfe 794 $self->_break_equivalence( @vector ) if $equiv;
ca6e6095 795}
796
22222af9 797=head2 relationship_valid( $source, $target, $type )
798
799Checks whether a relationship of type $type may exist between the readings given
800in $source and $target. Returns a tuple of ( status, message ) where status is
801a yes/no boolean and, if the answer is no, message gives the reason why.
802
803=cut
804
805sub relationship_valid {
414cc046 806 my( $self, $source, $target, $rel, $mustdrop ) = @_;
807 $mustdrop = [] unless $mustdrop; # in case we were passed nothing
22222af9 808 my $c = $self->collation;
24efa55d 809 my $reltype = $self->type( $rel );
10943ab0 810 ## Assume validity is okay if we are initializing from scratch.
3579c22b 811 return ( 1, "initializing" ) unless $c->tradition->_initialized;
c7bd2768 812 ## TODO Move this block to relationship type definition when we can save
813 ## coderefs
24efa55d 814 if ( $rel eq 'transposition' || $rel eq 'repetition' ) {
22222af9 815 # Check that the two readings do (for a repetition) or do not (for
816 # a transposition) appear in the same witness.
56772e8c 817 # TODO this might be called before witness paths are set...
22222af9 818 my %seen_wits;
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';
d6936dea 825 }
22222af9 826 }
abadc997 827 return ( 0, "Readings occur only in distinct witnesses" )
828 if $rel eq 'repetition';
829 }
24efa55d 830 if ( $reltype->is_colocation ) {
22222af9 831 # Check that linking the source and target in a relationship won't lead
414cc046 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 ) {
24efa55d 839 push( @$mustdrop, $self->_drop_weak( $source ) );
840 push( @$mustdrop, $self->_drop_weak( $target ) );
359944f7 841 if( $c->end->has_rank ) {
176badfe 842 foreach my $rk ( $sourcerank .. $targetrank ) {
24efa55d 843 map { push( @$mustdrop, $self->_drop_weak( $_->id ) ) }
414cc046 844 $c->readings_at_rank( $rk );
845 }
846 }
a1615ee4 847 }
359944f7 848 unless( $self->test_equivalence( $source, $target ) ) {
24efa55d 849 $self->_restore_weak( @$mustdrop );
414cc046 850 return( 0, "Relationship would create witness loop" );
a1615ee4 851 }
22222af9 852 return ( 1, "ok" );
24efa55d 853 } else {
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" );
858 } else {
859 return ( 1, "ok" );
860 }
22222af9 861 }
862}
863
24efa55d 864sub _drop_weak {
778251a6 865 my( $self, $reading ) = @_;
414cc046 866 my @dropped;
778251a6 867 foreach my $n ( $self->graph->neighbors( $reading ) ) {
24efa55d 868 my $nrel = $self->get_relationship( $reading, $n );
869 if( $self->type( $nrel->type )->is_weak ) {
870 push( @dropped, [ $reading, $n, $nrel->type ] );
778251a6 871 $self->del_relationship( $reading, $n );
24efa55d 872 #print STDERR "Dropped weak relationship $reading -> $n\n";
778251a6 873 }
874 }
414cc046 875 return @dropped;
876}
877
24efa55d 878sub _restore_weak {
414cc046 879 my( $self, @vectors ) = @_;
880 foreach my $v ( @vectors ) {
24efa55d 881 my $type = pop @$v;
882 eval {
883 $self->add_relationship( @$v, { 'type' => $type } );
884 #print STDERR "Restored weak relationship @$v\n";
885 }; # if it fails we don't care
414cc046 886 }
778251a6 887}
888
7f52eac8 889=head2 related_readings( $reading, $filter )
22222af9 890
9e9b7540 891Returns a list of readings that are connected via direct relationship links
892to $reading. If $filter is set to a subroutine ref, returns only those
893related readings where $filter( $relationship ) returns a true value.
22222af9 894
895=cut
896
897sub related_readings {
7f52eac8 898 my( $self, $reading, $filter ) = @_;
22222af9 899 my $return_object;
900 if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
901 $reading = $reading->id;
902 $return_object = 1;
903 }
c84275ff 904 my @answer;
7f52eac8 905 if( $filter ) {
906 # Backwards compat
907 if( $filter eq 'colocated' ) {
908 $filter = sub { $_[0]->colocated };
d002ccb7 909 } elsif( !ref( $filter ) ) {
910 my $type = $filter;
911 $filter = sub { $_[0]->type eq $type };
7f52eac8 912 }
9e9b7540 913 @answer = grep { &$filter( $self->get_relationship( $reading, $_ ) ) }
914 $self->graph->neighbors( $reading );
c84275ff 915 } else {
9e9b7540 916 @answer = $self->graph->neighbors( $reading );
22222af9 917 }
918 if( $return_object ) {
919 my $c = $self->collation;
c84275ff 920 return map { $c->reading( $_ ) } @answer;
22222af9 921 } else {
c84275ff 922 return @answer;
22222af9 923 }
924}
925
9e9b7540 926=head2 propagate_relationship( $rel )
927
928Apply the transitivity and binding level rules to propagate the consequences of
929the specified relationship link, ensuring all consequent relationships exist.
930For now, we only propagate colocation links if we are passed a colocation, and
931we only propagate displacement links if we are given a displacement.
932
933Returns an array of tuples ( rdg1, rdg2, type ) for each new reading set.
934
935=cut
936
937sub 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;
945 my @newly_set;
946
947 my $colo = $reltype->is_colocation;
948 my $bindlevel = $reltype->bindlevel;
949
950 ## Find all readings that are linked via this relationship type
951 my %thislevel = ( $rel->[0] => 1, $rel->[1] => 1 );
952 my $check = $rel;
953 my $iter = 0;
954 while( @$check ) {
955 my $more = [];
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 ) );
961 }
962 map { $thislevel{$_} = 1 } @$more;
963 $check = $more;
964 }
965
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 );
52179f61 972 my $skip;
9e9b7540 973 if( $existing ) {
52179f61 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
977 # bindlevel
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;
983 $skip = 1;
984 }
985 }
986 unless( $skip ) {
9e9b7540 987 # Try to add a new relationship here
988 try {
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: " .
995 $e->message );
996 }
997 }
998 }
999
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.
1003 my @other;
1004 foreach my $n ( $self->graph->neighbors( $r ) ) {
1005 my $crel = $self->get_relationship( $r, $n );
1006 next unless $crel;
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 ] );
1013 }
1014 }
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 ) {
1021 next if $sib eq $r;
52179f61 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
9e9b7540 1025 my $existing = $self->get_relationship( $sib, $nr );
52179f61 1026 my $skip;
9e9b7540 1027 if( $existing ) {
1028 # Check that it's compatible. The existing relationship type
52179f61 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" );
1040 }
1041 $skip = 1;
9e9b7540 1042 }
52179f61 1043 }
1044 unless( $skip ) {
9e9b7540 1045 # Try to add a new relationship here
1046 try {
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: " .
1053 $e->message );
1054 }
1055 }
1056 }
1057 }
1058 }
1059
1060 return @newly_set;
1061}
1062
52179f61 1063=head2 propagate_all_relationships
1064
1065Apply propagation logic retroactively to all relationships in the tradition.
1066
1067=cut
1068
1069sub propagate_all_relationships {
1070 my $self = shift;
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 );
1076 }
1077 }
1078}
1079
1080# Helper sorting function for retroactive propagation order.
1081sub _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;
1091}
1092
1093
22222af9 1094=head2 merge_readings( $kept, $deleted );
1095
1096Makes a best-effort merge of the relationship links between the given readings, and
1097stops tracking the to-be-deleted reading.
1098
1099=cut
1100
1101sub 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
1108
1109 # If kept changes its text, drop the relationship.
1110 next if $combined;
1111
f222800e 1112 # If kept / rel already has a relationship, just keep the old
3ae5e2ad 1113 my $rel = $self->get_relationship( @vector );
f222800e 1114 next if $rel;
22222af9 1115
1116 # Otherwise, adopt the relationship that would be deleted.
3ae5e2ad 1117 $rel = $self->get_relationship( @$edge );
1118 $self->_set_relationship( $rel, @vector );
22222af9 1119 }
56772e8c 1120 $self->_make_equivalence( $deleted, $kept );
22222af9 1121}
1122
359944f7 1123### Equivalence logic
1124
1125sub _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 ) {
3579c22b 1130 $self->equivalence_graph->delete_vertex( $group );
359944f7 1131 $self->remove_eqreadings( $group );
3579c22b 1132 $self->remove_equivalence( $group );
359944f7 1133 } elsif( @$nodelist == 1 ) {
3579c22b 1134 throw( "DATA INCONSISTENCY in equivalence graph: " . $nodelist->[0] .
1135 " in group that should have only $node" );
359944f7 1136 } else {
10e4b1ac 1137 my @newlist = grep { $_ ne $node } @$nodelist;
359944f7 1138 $self->set_eqreadings( $group, \@newlist );
1139 $self->remove_equivalence( $node );
1140 }
1141}
1142
1143=head2 add_equivalence_edge
1144
176badfe 1145Add an edge in the equivalence graph corresponding to $source -> $target in the
1146collation. Should only be called by Collation.
359944f7 1147
1148=cut
1149
1150sub add_equivalence_edge {
1151 my( $self, $source, $target ) = @_;
1152 my $seq = $self->equivalence( $source );
1153 my $teq = $self->equivalence( $target );
359944f7 1154 $self->equivalence_graph->add_edge( $seq, $teq );
1155}
1156
176badfe 1157=head2 delete_equivalence_edge
359944f7 1158
176badfe 1159Remove an edge in the equivalence graph corresponding to $source -> $target in the
1160collation. Should only be called by Collation.
359944f7 1161
1162=cut
1163
1164sub delete_equivalence_edge {
1165 my( $self, $source, $target ) = @_;
1166 my $seq = $self->equivalence( $source );
1167 my $teq = $self->equivalence( $target );
359944f7 1168 $self->equivalence_graph->delete_edge( $seq, $teq );
1169}
1170
1171sub _is_disconnected {
1172 my $self = shift;
1173 return( scalar $self->equivalence_graph->predecessorless_vertices > 1
1174 || scalar $self->equivalence_graph->successorless_vertices > 1 );
1175}
1176
176badfe 1177# Equate two readings in the equivalence graph
1178sub _make_equivalence {
56772e8c 1179 my( $self, $source, $target ) = @_;
359944f7 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;
56772e8c 1185 my $sourcepool = $self->eqreadings( $seq );
359944f7 1186 # and add them to the target readings.
56772e8c 1187 push( @{$self->eqreadings( $teq )}, @$sourcepool );
1188 map { $self->set_equivalence( $_, $teq ) } @$sourcepool;
359944f7 1189 # Then merge the nodes in the equivalence graph.
1190 foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
56772e8c 1191 $self->equivalence_graph->add_edge( $pred, $teq );
359944f7 1192 }
1193 foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
56772e8c 1194 $self->equivalence_graph->add_edge( $teq, $succ );
359944f7 1195 }
1196 $self->equivalence_graph->delete_vertex( $seq );
176badfe 1197 # TODO enable this after collation parsing is done
10943ab0 1198 throw( "Graph got disconnected making $source / $target equivalence" )
3579c22b 1199 if $self->_is_disconnected && $self->collation->tradition->_initialized;
359944f7 1200}
1201
1202=head2 test_equivalence
1203
176badfe 1204Test whether, if two readings were equated with a 'colocated' relationship,
1205the graph would still be valid.
359944f7 1206
1207=cut
1208
1209sub 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.
1213
1214 # Keep track of edges we add
1215 my %added_pred;
1216 my %added_succ;
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;
1222
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;
1229 } else {
1230 $self->equivalence_graph->add_edge( $pred, $teq );
1231 $added_pred{$pred} = 1;
1232 }
1233 }
1234 foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
1235 if( $self->equivalence_graph->has_edge( $teq, $succ ) ) {
1236 $added_succ{$succ} = 0;
1237 } else {
1238 $self->equivalence_graph->add_edge( $teq, $succ );
1239 $added_succ{$succ} = 1;
1240 }
1241 }
1242 # Delete source equivalent and test
1243 $self->equivalence_graph->delete_vertex( $seq );
1244 my $ret = !$self->equivalence_graph->has_a_cycle;
1245
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};
1251 }
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};
1255 }
1256 unless( $self->equivalence_graph->eq( $checkstr ) ) {
c7bd2768 1257 throw( "GRAPH CHANGED after testing" );
359944f7 1258 }
1259 # Return our answer
1260 return $ret;
1261}
1262
176badfe 1263# Unmake an equivalence link between two readings. Should only be called internally.
1264sub _break_equivalence {
359944f7 1265 my( $self, $source, $target ) = @_;
1266
1267 # This is the hard one. Need to reconstruct the equivalence groups without
1268 # the given link.
1269 my( %sng, %tng );
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 ) {
10e4b1ac 1274 return if( exists $sng{$el} );
359944f7 1275 }
359944f7 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
176badfe 1278 my $oldgroup = $self->equivalence( $source ); # same as $target
1279 my $keepsource = $sng{$oldgroup};
1280 my $newgroup = $keepsource ? $target : $source;
359944f7 1281 my( $oldmembers, $newmembers );
176badfe 1282 if( $keepsource ) {
359944f7 1283 $oldmembers = [ keys %sng ];
1284 $newmembers = [ keys %tng ];
1285 } else {
1286 $oldmembers = [ keys %tng ];
1287 $newmembers = [ keys %sng ];
1288 }
1289
1290 # First alter the old group in the hash
1291 $self->set_eqreadings( $oldgroup, $oldmembers );
176badfe 1292 foreach my $el ( @$oldmembers ) {
1293 $self->set_equivalence( $el, $oldgroup );
1294 }
359944f7 1295
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 );
1300 }
1301
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 ) ) {
beb47b16 1308 next unless $self->equivalence( $rp );
359944f7 1309 $self->equivalence_graph->add_edge( $self->equivalence( $rp ), $newgroup );
1310 }
1311 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
beb47b16 1312 next unless $self->equivalence( $rs );
359944f7 1313 $self->equivalence_graph->add_edge( $newgroup, $self->equivalence( $rs ) );
1314 }
1315 }
1316
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 ) ) {
beb47b16 1321 next unless $self->equivalence( $rp );
359944f7 1322 $old_pred{$self->equivalence( $rp )} = 1;
1323 }
1324 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
beb47b16 1325 next unless $self->equivalence( $rs );
359944f7 1326 $old_succ{$self->equivalence( $rs )} = 1;
1327 }
1328 }
1329 foreach my $p ( $self->equivalence_graph->predecessors( $oldgroup ) ) {
1330 unless( $old_pred{$p} ) {
1331 $self->equivalence_graph->delete_edge( $p, $oldgroup );
1332 }
1333 }
1334 foreach my $s ( $self->equivalence_graph->successors( $oldgroup ) ) {
1335 unless( $old_succ{$s} ) {
1336 $self->equivalence_graph->delete_edge( $oldgroup, $s );
1337 }
1338 }
176badfe 1339 # TODO enable this after collation parsing is done
10943ab0 1340 throw( "Graph got disconnected breaking $source / $target equivalence" )
3579c22b 1341 if $self->_is_disconnected && $self->collation->tradition->_initialized;
359944f7 1342}
1343
1344sub _find_equiv_without {
1345 my( $self, $first, $second ) = @_;
1346 my %found = ( $first => 1 );
1347 my $check = [ $first ];
1348 my $iter = 0;
1349 while( @$check ) {
1350 my $more = [];
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};
1356 $found{$nr} = 1;
1357 }
1358 }
1359 }
1360 $check = $more;
1361 }
1362 return keys %found;
1363}
1364
e1083e99 1365=head2 rebuild_equivalence
1366
1367(Re)build the equivalence graph from scratch. Dumps the graph, makes a new one,
1368adds all readings and edges, then makes an equivalence for all relationships.
1369
1370=cut
1371
1372sub rebuild_equivalence {
1373 my $self = shift;
1374 my $newgraph = Graph->new();
04482188 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;
1380
b6f13859 1381 $self->collation->tradition->_init_done(0);
04482188 1382 # Add the readings
e1083e99 1383 foreach my $r ( $self->collation->readings ) {
04482188 1384 my $rid = $r->id;
1385 $newgraph->add_vertex( $rid );
1386 $self->set_equivalence( $rid, $rid );
1387 $self->set_eqreadings( $rid, [ $rid ] );
e1083e99 1388 }
04482188 1389
1390 # Now add the edges
e1083e99 1391 foreach my $e ( $self->collation->paths ) {
04482188 1392 $self->add_equivalence_edge( @$e );
e1083e99 1393 }
04482188 1394
1395 # Now equate the colocated readings. This does no testing;
1396 # it assumes that all preexisting relationships are valid.
e1083e99 1397 foreach my $rel ( $self->relationships ) {
1398 my $relobj = $self->get_relationship( $rel );
1399 next unless $relobj && $relobj->colocated;
1400 $self->_make_equivalence( @$rel );
1401 }
b6f13859 1402 $self->collation->tradition->_init_done(1);
e1083e99 1403}
1404
56772e8c 1405=head2 equivalence_ranks
1406
1407Rank all vertices in the equivalence graph, and return a hash reference with
1408vertex => rank mapping.
1409
1410=cut
1411
1412sub equivalence_ranks {
1413 my $self = shift;
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 );
1421 }
1422 return( $eqranks, $rankeqs );
1423}
1424
1425sub _assign_rank {
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.
1432 my @next_nodes;
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;
1439 my $skip = 0;
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};
1444 } else {
1445 $skip = 1;
1446 last;
1447 }
1448 }
1449 next if $skip;
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 );
1455 }
1456 }
1457 return @next_nodes;
1458}
1459
359944f7 1460### Output logic
1461
027d819c 1462sub _as_graphml {
2626f709 1463 my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_;
c84275ff 1464
1465 my $rgraph = $xmlroot->addNewChild( $graphml_ns, 'graph' );
1466 $rgraph->setAttribute( 'edgedefault', 'directed' );
1467 $rgraph->setAttribute( 'id', 'relationships', );
1468 $rgraph->setAttribute( 'parse.edgeids', 'canonical' );
cc31ebaa 1469 $rgraph->setAttribute( 'parse.edges', 0 );
c84275ff 1470 $rgraph->setAttribute( 'parse.nodeids', 'canonical' );
cc31ebaa 1471 $rgraph->setAttribute( 'parse.nodes', 0 );
c84275ff 1472 $rgraph->setAttribute( 'parse.order', 'nodesfirst' );
1473
1474 # Add the vertices according to their XML IDs
2626f709 1475 my %rdg_lookup = ( reverse %$node_hash );
cc31ebaa 1476 # my @nlist = sort _by_xmlid keys( %rdg_lookup ); ## CAUSES SEGFAULT
826d8773 1477 my @nlist = sort keys( %rdg_lookup );
414cc046 1478 foreach my $n ( @nlist ) {
c84275ff 1479 my $n_el = $rgraph->addNewChild( $graphml_ns, 'node' );
1480 $n_el->setAttribute( 'id', $n );
2626f709 1481 _add_graphml_data( $n_el, $nodeid_key, $rdg_lookup{$n} );
c84275ff 1482 }
cc31ebaa 1483 $rgraph->setAttribute( 'parse.nodes', scalar @nlist );
c84275ff 1484
1485 # Add the relationship edges, with their object information
1486 my $edge_ctr = 0;
1487 foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->graph->edges ) {
1488 # Add an edge and fill in its relationship info.
a30ca502 1489 next unless( exists $node_hash->{$e->[0]} && exists $node_hash->{$e->[1]} );
c84275ff 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++ );
1494
3ae5e2ad 1495 my $rel_obj = $self->get_relationship( @$e );
bbd064a9 1496 foreach my $key ( keys %$edge_keys ) {
1497 my $value = $rel_obj->$key;
1498 _add_graphml_data( $edge_el, $edge_keys->{$key}, $value )
1499 if defined $value;
1500 }
c84275ff 1501 }
cc31ebaa 1502 $rgraph->setAttribute( 'parse.edges', $edge_ctr );
c84275ff 1503}
1504
1505sub _by_xmlid {
2626f709 1506 my $tmp_a = $a;
1507 my $tmp_b = $b;
1508 $tmp_a =~ s/\D//g;
1509 $tmp_b =~ s/\D//g;
1510 return $tmp_a <=> $tmp_b;
c84275ff 1511}
1512
1513sub _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 );
83d5ac3a 1519}
1520
c7bd2768 1521sub dump_segment {
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 });
1526 close DUMP;
1527}
1528
63778331 1529sub throw {
1530 Text::Tradition::Error->throw(
1531 'ident' => 'Relationship error',
1532 'message' => $_[0],
1533 );
1534}
1535
22222af9 1536no Moose;
1537__PACKAGE__->meta->make_immutable;
1538
15391;
Unnamed repository; edit this file 'description' to name the repository.