projects / scpubgit/stemmatology.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
update test file to explicitly propagate implicit relationships
[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
507# Test 5.4: add a parallel but not sibling relationship
508$c5->add_relationship( 'r13.6', 'r13.2', { type => 'lexical', propagate => 1 } );
509ok( !$c5->get_relationship( 'r13.6', 'r13.1' ),
510 "Lexical relationship did not affect grammatical" );
511foreach 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' );
514 if( $newlex ) {
515 is( $newlex->type, 'lexical', 'Implicit parallel-down relationship has the correct type' );
516 }
517}
518
519# Test 5.5: try it with non-colocated relationships
520my $numrel = scalar $c5->relationships;
521$c5->add_relationship( 'r62.1', 'r64.1', { type => 'transposition', propagate => 1 } );
522is( scalar $c5->relationships, $numrel+1,
523 "Adding non-colo relationship did not propagate" );
524# Add a pivot point
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 } );
528my $newtrans = $c5->get_relationship( 'r64.1', 'r60.3' );
529ok( $newtrans, 'Non-colo relationship was made between indirectly linked readings' );
530if( $newtrans ) {
531 is( $newtrans->type, 'transposition', 'Implicit non-colo relationship has the correct type' );
532}
533is( scalar $c5->relationships, $numrel+4,
534 "Adding non-colo relationship only propagated on non-colos" );
535
c7bd2768 536
6d381462 537=end testing
538
22222af9 539=cut
540
541sub add_relationship {
414cc046 542 my( $self, $source, $target, $options ) = @_;
543 my $c = $self->collation;
176badfe 544 my $sourceobj = $c->reading( $source );
545 my $targetobj = $c->reading( $target );
359944f7 546 throw( "Adding self relationship at $source" ) if $source eq $target;
176badfe 547 throw( "Cannot set relationship on a meta reading" )
548 if( $sourceobj->is_meta || $targetobj->is_meta );
ca6e6095 549 my $relationship;
24efa55d 550 my $reltype;
c7bd2768 551 my $thispaironly = delete $options->{thispaironly};
9e9b7540 552 my $propagate = delete $options->{propagate};
414cc046 553 my $droppedcolls = [];
ca6e6095 554 if( ref( $options ) eq 'Text::Tradition::Collation::Relationship' ) {
555 $relationship = $options;
24efa55d 556 $reltype = $self->type( $relationship->type );
ca6e6095 557 $thispaironly = 1; # If existing rel, set only where asked.
24efa55d 558 # Test the validity
414cc046 559 my( $is_valid, $reason ) = $self->relationship_valid( $source, $target,
24efa55d 560 $relationship->type, $droppedcolls );
ca6e6095 561 unless( $is_valid ) {
562 throw( "Invalid relationship: $reason" );
563 }
24efa55d 564 } else {
565 $reltype = $self->type( $options->{type} );
ca6e6095 566
567 # Try to create the relationship object.
c7bd2768 568 my $rdga = $reltype->regularize( $sourceobj );
569 my $rdgb = $reltype->regularize( $targetobj );
24efa55d 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' ) {
0ac5e750 575 # Is there a relationship with this a & b already?
24efa55d 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" );
582 }
583
f222800e 584 my $otherrel = $self->scoped_relationship( $rdga, $rdgb );
0ac5e750 585 if( $otherrel && $otherrel->type eq $options->{type}
586 && $otherrel->scope eq $options->{scope} ) {
24efa55d 587 # warn "Applying existing scoped relationship for $rdga / $rdgb";
0ac5e750 588 $relationship = $otherrel;
99ab9535 589 } elsif( $otherrel ) {
24efa55d 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" );
0ac5e750 594 }
595 }
24efa55d 596 $relationship = $self->create( $options ) unless $relationship;
597 # ... Will throw on error
598
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" );
604 }
22222af9 605 }
ca6e6095 606
22222af9 607
22222af9 608 # Now set the relationship(s).
609 my @pairs_set;
414cc046 610 my $rel = $self->get_relationship( $source, $target );
cc31ebaa 611 my $skip;
414cc046 612 if( $rel && $rel ne $relationship ) {
613 if( $rel->nonlocal ) {
614 throw( "Found conflicting relationship at $source - $target" );
24efa55d 615 } elsif( !$reltype->is_weak ) {
616 # Replace a weak relationship; leave any other sort in place.
414cc046 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 );
414cc046 623 }
24efa55d 624 $skip = 1;
414cc046 625 }
626 }
cc31ebaa 627 $self->_set_relationship( $relationship, $source, $target ) unless $skip;
9e9b7540 628 push( @pairs_set, [ $source, $target, $relationship->type ] );
414cc046 629
428bcf0b 630 # Find all the pairs for which we need to set the relationship.
631 if( $relationship->colocated && $relationship->nonlocal && !$thispaironly ) {
9e9b7540 632 my @global_set = $self->add_global_relationship( $relationship );
633 map { push( @$_, $relationship->type ) } @global_set;
634 push( @pairs_set, @global_set );
635 }
636 if( $propagate ) {
637 my @prop;
638 foreach my $ps ( @pairs_set ) {
639 my @extra = $self->propagate_relationship( $ps->[0], $ps->[1] );
640 push( @prop, @extra );
641 }
642 push( @pairs_set, @prop ) if @prop;
22222af9 643 }
9e9b7540 644
414cc046 645 # Finally, restore whatever collations we can, and return.
24efa55d 646 $self->_restore_weak( @$droppedcolls );
63778331 647 return @pairs_set;
22222af9 648}
649
428bcf0b 650=head2 add_global_relationship( $options, $skipvector )
651
652Adds the relationship specified wherever the relevant readings appear together
653in the graph. Options as in add_relationship above.
654
655=cut
656
657sub add_global_relationship {
24efa55d 658 my( $self, $relationship ) = @_;
428bcf0b 659 # Sanity checking
24efa55d 660 my $reltype = $self->type( $relationship->type );
428bcf0b 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" )
24efa55d 664 unless $reltype->is_generalizable;
428bcf0b 665
666 # Apply the relationship wherever it is valid
667 my @pairs_set;
668 foreach my $v ( $self->_find_applicable( $relationship ) ) {
669 my $exists = $self->get_relationship( @$v );
24efa55d 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" );
674 }
428bcf0b 675 } else {
24efa55d 676 my @added;
677 try {
678 @added = $self->add_relationship( @$v, $relationship );
679 } catch {
680 my $reldesc = sprintf( "%s %s -> %s", $relationship->type,
681 $relationship->reading_a, $relationship->reading_b );
98a66507 682 # print STDERR "Global relationship $reldesc not applicable at @$v\n";
24efa55d 683 }
684 push( @pairs_set, @added ) if @added;
428bcf0b 685 }
686 }
687 return @pairs_set;
688}
689
690
9d829138 691=head2 del_scoped_relationship( $reading_a, $reading_b )
692
693Returns the general (document-level or global) relationship that has been defined
694between the two reading strings. Returns undef if there is no general relationship.
695
696=cut
697
698sub del_scoped_relationship {
699 my( $self, $rdga, $rdgb ) = @_;
700 my( $first, $second ) = sort( $rdga, $rdgb );
701 return delete $self->scopedrels->{$first}->{$second};
702}
703
bf6e338d 704sub _find_applicable {
705 my( $self, $rel ) = @_;
706 my $c = $self->collation;
24efa55d 707 my $reltype = $self->type( $rel->type );
bf6e338d 708 my @vectors;
709 my @identical_readings;
c7bd2768 710 @identical_readings = grep { $reltype->regularize( $_ ) eq $rel->reading_a }
24efa55d 711 $c->readings;
bf6e338d 712 foreach my $ir ( @identical_readings ) {
713 my @itarget;
c7bd2768 714 @itarget = grep { $reltype->regularize( $_ ) eq $rel->reading_b }
24efa55d 715 $c->readings_at_rank( $ir->rank );
bf6e338d 716 if( @itarget ) {
24efa55d 717 # Warn if there is more than one hit with no closer link between them.
bf6e338d 718 my $itmain = shift @itarget;
719 if( @itarget ) {
720 my %all_targets;
24efa55d 721 my $bindlevel = $reltype->bindlevel;
bf6e338d 722 map { $all_targets{$_} = 1 } @itarget;
723 map { delete $all_targets{$_} }
24efa55d 724 $self->related_readings( $itmain, sub {
725 $self->type( $_[0]->type )->bindlevel < $bindlevel } );
bf6e338d 726 warn "More than one unrelated reading with text " . $itmain->text
727 . " at rank " . $ir->rank . "!" if keys %all_targets;
728 }
729 push( @vectors, [ $ir->id, $itmain->id ] );
730 }
731 }
732 return @vectors;
733}
734
ee801e17 735=head2 del_relationship( $source, $target )
736
737Removes the relationship between the given readings. If the relationship is
738non-local, removes the relationship everywhere in the graph.
739
740=cut
741
742sub del_relationship {
743 my( $self, $source, $target ) = @_;
744 my $rel = $self->get_relationship( $source, $target );
681893aa 745 return () unless $rel; # Nothing to delete; return an empty set.
24efa55d 746 my $reltype = $self->type( $rel->type );
359944f7 747 my $colo = $rel->colocated;
ee801e17 748 my @vectors = ( [ $source, $target ] );
359944f7 749 $self->_remove_relationship( $colo, $source, $target );
ee801e17 750 if( $rel->nonlocal ) {
751 # Remove the relationship wherever it occurs.
24efa55d 752 my @rel_edges = grep { $self->get_relationship( @$_ ) eq $rel }
ee801e17 753 $self->relationships;
754 foreach my $re ( @rel_edges ) {
359944f7 755 $self->_remove_relationship( $colo, @$re );
ee801e17 756 push( @vectors, $re );
757 }
9d829138 758 $self->del_scoped_relationship( $rel->reading_a, $rel->reading_b );
ee801e17 759 }
760 return @vectors;
761}
762
ca6e6095 763sub _remove_relationship {
359944f7 764 my( $self, $equiv, @vector ) = @_;
ca6e6095 765 $self->graph->delete_edge( @vector );
176badfe 766 $self->_break_equivalence( @vector ) if $equiv;
ca6e6095 767}
768
22222af9 769=head2 relationship_valid( $source, $target, $type )
770
771Checks whether a relationship of type $type may exist between the readings given
772in $source and $target. Returns a tuple of ( status, message ) where status is
773a yes/no boolean and, if the answer is no, message gives the reason why.
774
775=cut
776
777sub relationship_valid {
414cc046 778 my( $self, $source, $target, $rel, $mustdrop ) = @_;
779 $mustdrop = [] unless $mustdrop; # in case we were passed nothing
22222af9 780 my $c = $self->collation;
24efa55d 781 my $reltype = $self->type( $rel );
10943ab0 782 ## Assume validity is okay if we are initializing from scratch.
3579c22b 783 return ( 1, "initializing" ) unless $c->tradition->_initialized;
c7bd2768 784 ## TODO Move this block to relationship type definition when we can save
785 ## coderefs
24efa55d 786 if ( $rel eq 'transposition' || $rel eq 'repetition' ) {
22222af9 787 # Check that the two readings do (for a repetition) or do not (for
788 # a transposition) appear in the same witness.
56772e8c 789 # TODO this might be called before witness paths are set...
22222af9 790 my %seen_wits;
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';
d6936dea 797 }
22222af9 798 }
abadc997 799 return ( 0, "Readings occur only in distinct witnesses" )
800 if $rel eq 'repetition';
801 }
24efa55d 802 if ( $reltype->is_colocation ) {
22222af9 803 # Check that linking the source and target in a relationship won't lead
414cc046 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 ) {
24efa55d 811 push( @$mustdrop, $self->_drop_weak( $source ) );
812 push( @$mustdrop, $self->_drop_weak( $target ) );
359944f7 813 if( $c->end->has_rank ) {
176badfe 814 foreach my $rk ( $sourcerank .. $targetrank ) {
24efa55d 815 map { push( @$mustdrop, $self->_drop_weak( $_->id ) ) }
414cc046 816 $c->readings_at_rank( $rk );
817 }
818 }
a1615ee4 819 }
359944f7 820 unless( $self->test_equivalence( $source, $target ) ) {
24efa55d 821 $self->_restore_weak( @$mustdrop );
414cc046 822 return( 0, "Relationship would create witness loop" );
a1615ee4 823 }
22222af9 824 return ( 1, "ok" );
24efa55d 825 } else {
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" );
830 } else {
831 return ( 1, "ok" );
832 }
22222af9 833 }
834}
835
24efa55d 836sub _drop_weak {
778251a6 837 my( $self, $reading ) = @_;
414cc046 838 my @dropped;
778251a6 839 foreach my $n ( $self->graph->neighbors( $reading ) ) {
24efa55d 840 my $nrel = $self->get_relationship( $reading, $n );
841 if( $self->type( $nrel->type )->is_weak ) {
842 push( @dropped, [ $reading, $n, $nrel->type ] );
778251a6 843 $self->del_relationship( $reading, $n );
24efa55d 844 #print STDERR "Dropped weak relationship $reading -> $n\n";
778251a6 845 }
846 }
414cc046 847 return @dropped;
848}
849
24efa55d 850sub _restore_weak {
414cc046 851 my( $self, @vectors ) = @_;
852 foreach my $v ( @vectors ) {
24efa55d 853 my $type = pop @$v;
854 eval {
855 $self->add_relationship( @$v, { 'type' => $type } );
856 #print STDERR "Restored weak relationship @$v\n";
857 }; # if it fails we don't care
414cc046 858 }
778251a6 859}
860
7f52eac8 861=head2 related_readings( $reading, $filter )
22222af9 862
9e9b7540 863Returns a list of readings that are connected via direct relationship links
864to $reading. If $filter is set to a subroutine ref, returns only those
865related readings where $filter( $relationship ) returns a true value.
22222af9 866
867=cut
868
869sub related_readings {
7f52eac8 870 my( $self, $reading, $filter ) = @_;
22222af9 871 my $return_object;
872 if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
873 $reading = $reading->id;
874 $return_object = 1;
875 }
c84275ff 876 my @answer;
7f52eac8 877 if( $filter ) {
878 # Backwards compat
879 if( $filter eq 'colocated' ) {
880 $filter = sub { $_[0]->colocated };
d002ccb7 881 } elsif( !ref( $filter ) ) {
882 my $type = $filter;
883 $filter = sub { $_[0]->type eq $type };
7f52eac8 884 }
9e9b7540 885 @answer = grep { &$filter( $self->get_relationship( $reading, $_ ) ) }
886 $self->graph->neighbors( $reading );
c84275ff 887 } else {
9e9b7540 888 @answer = $self->graph->neighbors( $reading );
22222af9 889 }
890 if( $return_object ) {
891 my $c = $self->collation;
c84275ff 892 return map { $c->reading( $_ ) } @answer;
22222af9 893 } else {
c84275ff 894 return @answer;
22222af9 895 }
896}
897
9e9b7540 898=head2 propagate_relationship( $rel )
899
900Apply the transitivity and binding level rules to propagate the consequences of
901the specified relationship link, ensuring all consequent relationships exist.
902For now, we only propagate colocation links if we are passed a colocation, and
903we only propagate displacement links if we are given a displacement.
904
905Returns an array of tuples ( rdg1, rdg2, type ) for each new reading set.
906
907=cut
908
909sub 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;
917 my @newly_set;
918
919 my $colo = $reltype->is_colocation;
920 my $bindlevel = $reltype->bindlevel;
921
922 ## Find all readings that are linked via this relationship type
923 my %thislevel = ( $rel->[0] => 1, $rel->[1] => 1 );
924 my $check = $rel;
925 my $iter = 0;
926 while( @$check ) {
927 my $more = [];
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 ) );
933 }
934 map { $thislevel{$_} = 1 } @$more;
935 $check = $more;
936 }
937
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 );
944 if( $existing ) {
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;
949 } else {
950 # Try to add a new relationship here
951 try {
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: " .
958 $e->message );
959 }
960 }
961 }
962
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.
966 my @other;
967 foreach my $n ( $self->graph->neighbors( $r ) ) {
968 my $crel = $self->get_relationship( $r, $n );
969 next unless $crel;
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 ] );
976 }
977 }
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.
981 foreach ( @other ) {
982 my( $nr, $nrtype ) = @$_;
983 foreach my $sib ( keys %thislevel ) {
984 next if $sib eq $r;
985 my $existing = $self->get_relationship( $sib, $nr );
986 if( $existing ) {
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" );
996 }
997 } else {
998 # Try to add a new relationship here
999 try {
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: " .
1006 $e->message );
1007 }
1008 }
1009 }
1010 }
1011 }
1012
1013 return @newly_set;
1014}
1015
22222af9 1016=head2 merge_readings( $kept, $deleted );
1017
1018Makes a best-effort merge of the relationship links between the given readings, and
1019stops tracking the to-be-deleted reading.
1020
1021=cut
1022
1023sub 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
1030
1031 # If kept changes its text, drop the relationship.
1032 next if $combined;
1033
f222800e 1034 # If kept / rel already has a relationship, just keep the old
3ae5e2ad 1035 my $rel = $self->get_relationship( @vector );
f222800e 1036 next if $rel;
22222af9 1037
1038 # Otherwise, adopt the relationship that would be deleted.
3ae5e2ad 1039 $rel = $self->get_relationship( @$edge );
1040 $self->_set_relationship( $rel, @vector );
22222af9 1041 }
56772e8c 1042 $self->_make_equivalence( $deleted, $kept );
22222af9 1043}
1044
359944f7 1045### Equivalence logic
1046
1047sub _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 ) {
3579c22b 1052 $self->equivalence_graph->delete_vertex( $group );
359944f7 1053 $self->remove_eqreadings( $group );
3579c22b 1054 $self->remove_equivalence( $group );
359944f7 1055 } elsif( @$nodelist == 1 ) {
3579c22b 1056 throw( "DATA INCONSISTENCY in equivalence graph: " . $nodelist->[0] .
1057 " in group that should have only $node" );
359944f7 1058 } else {
10e4b1ac 1059 my @newlist = grep { $_ ne $node } @$nodelist;
359944f7 1060 $self->set_eqreadings( $group, \@newlist );
1061 $self->remove_equivalence( $node );
1062 }
1063}
1064
1065=head2 add_equivalence_edge
1066
176badfe 1067Add an edge in the equivalence graph corresponding to $source -> $target in the
1068collation. Should only be called by Collation.
359944f7 1069
1070=cut
1071
1072sub add_equivalence_edge {
1073 my( $self, $source, $target ) = @_;
1074 my $seq = $self->equivalence( $source );
1075 my $teq = $self->equivalence( $target );
359944f7 1076 $self->equivalence_graph->add_edge( $seq, $teq );
1077}
1078
176badfe 1079=head2 delete_equivalence_edge
359944f7 1080
176badfe 1081Remove an edge in the equivalence graph corresponding to $source -> $target in the
1082collation. Should only be called by Collation.
359944f7 1083
1084=cut
1085
1086sub delete_equivalence_edge {
1087 my( $self, $source, $target ) = @_;
1088 my $seq = $self->equivalence( $source );
1089 my $teq = $self->equivalence( $target );
359944f7 1090 $self->equivalence_graph->delete_edge( $seq, $teq );
1091}
1092
1093sub _is_disconnected {
1094 my $self = shift;
1095 return( scalar $self->equivalence_graph->predecessorless_vertices > 1
1096 || scalar $self->equivalence_graph->successorless_vertices > 1 );
1097}
1098
176badfe 1099# Equate two readings in the equivalence graph
1100sub _make_equivalence {
56772e8c 1101 my( $self, $source, $target ) = @_;
359944f7 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;
56772e8c 1107 my $sourcepool = $self->eqreadings( $seq );
359944f7 1108 # and add them to the target readings.
56772e8c 1109 push( @{$self->eqreadings( $teq )}, @$sourcepool );
1110 map { $self->set_equivalence( $_, $teq ) } @$sourcepool;
359944f7 1111 # Then merge the nodes in the equivalence graph.
1112 foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
56772e8c 1113 $self->equivalence_graph->add_edge( $pred, $teq );
359944f7 1114 }
1115 foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
56772e8c 1116 $self->equivalence_graph->add_edge( $teq, $succ );
359944f7 1117 }
1118 $self->equivalence_graph->delete_vertex( $seq );
176badfe 1119 # TODO enable this after collation parsing is done
10943ab0 1120 throw( "Graph got disconnected making $source / $target equivalence" )
3579c22b 1121 if $self->_is_disconnected && $self->collation->tradition->_initialized;
359944f7 1122}
1123
1124=head2 test_equivalence
1125
176badfe 1126Test whether, if two readings were equated with a 'colocated' relationship,
1127the graph would still be valid.
359944f7 1128
1129=cut
1130
1131sub 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.
1135
1136 # Keep track of edges we add
1137 my %added_pred;
1138 my %added_succ;
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;
1144
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;
1151 } else {
1152 $self->equivalence_graph->add_edge( $pred, $teq );
1153 $added_pred{$pred} = 1;
1154 }
1155 }
1156 foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
1157 if( $self->equivalence_graph->has_edge( $teq, $succ ) ) {
1158 $added_succ{$succ} = 0;
1159 } else {
1160 $self->equivalence_graph->add_edge( $teq, $succ );
1161 $added_succ{$succ} = 1;
1162 }
1163 }
1164 # Delete source equivalent and test
1165 $self->equivalence_graph->delete_vertex( $seq );
1166 my $ret = !$self->equivalence_graph->has_a_cycle;
1167
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};
1173 }
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};
1177 }
1178 unless( $self->equivalence_graph->eq( $checkstr ) ) {
c7bd2768 1179 throw( "GRAPH CHANGED after testing" );
359944f7 1180 }
1181 # Return our answer
1182 return $ret;
1183}
1184
176badfe 1185# Unmake an equivalence link between two readings. Should only be called internally.
1186sub _break_equivalence {
359944f7 1187 my( $self, $source, $target ) = @_;
1188
1189 # This is the hard one. Need to reconstruct the equivalence groups without
1190 # the given link.
1191 my( %sng, %tng );
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 ) {
10e4b1ac 1196 return if( exists $sng{$el} );
359944f7 1197 }
359944f7 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
176badfe 1200 my $oldgroup = $self->equivalence( $source ); # same as $target
1201 my $keepsource = $sng{$oldgroup};
1202 my $newgroup = $keepsource ? $target : $source;
359944f7 1203 my( $oldmembers, $newmembers );
176badfe 1204 if( $keepsource ) {
359944f7 1205 $oldmembers = [ keys %sng ];
1206 $newmembers = [ keys %tng ];
1207 } else {
1208 $oldmembers = [ keys %tng ];
1209 $newmembers = [ keys %sng ];
1210 }
1211
1212 # First alter the old group in the hash
1213 $self->set_eqreadings( $oldgroup, $oldmembers );
176badfe 1214 foreach my $el ( @$oldmembers ) {
1215 $self->set_equivalence( $el, $oldgroup );
1216 }
359944f7 1217
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 );
1222 }
1223
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 ) ) {
beb47b16 1230 next unless $self->equivalence( $rp );
359944f7 1231 $self->equivalence_graph->add_edge( $self->equivalence( $rp ), $newgroup );
1232 }
1233 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
beb47b16 1234 next unless $self->equivalence( $rs );
359944f7 1235 $self->equivalence_graph->add_edge( $newgroup, $self->equivalence( $rs ) );
1236 }
1237 }
1238
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 ) ) {
beb47b16 1243 next unless $self->equivalence( $rp );
359944f7 1244 $old_pred{$self->equivalence( $rp )} = 1;
1245 }
1246 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
beb47b16 1247 next unless $self->equivalence( $rs );
359944f7 1248 $old_succ{$self->equivalence( $rs )} = 1;
1249 }
1250 }
1251 foreach my $p ( $self->equivalence_graph->predecessors( $oldgroup ) ) {
1252 unless( $old_pred{$p} ) {
1253 $self->equivalence_graph->delete_edge( $p, $oldgroup );
1254 }
1255 }
1256 foreach my $s ( $self->equivalence_graph->successors( $oldgroup ) ) {
1257 unless( $old_succ{$s} ) {
1258 $self->equivalence_graph->delete_edge( $oldgroup, $s );
1259 }
1260 }
176badfe 1261 # TODO enable this after collation parsing is done
10943ab0 1262 throw( "Graph got disconnected breaking $source / $target equivalence" )
3579c22b 1263 if $self->_is_disconnected && $self->collation->tradition->_initialized;
359944f7 1264}
1265
1266sub _find_equiv_without {
1267 my( $self, $first, $second ) = @_;
1268 my %found = ( $first => 1 );
1269 my $check = [ $first ];
1270 my $iter = 0;
1271 while( @$check ) {
1272 my $more = [];
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};
1278 $found{$nr} = 1;
1279 }
1280 }
1281 }
1282 $check = $more;
1283 }
1284 return keys %found;
1285}
1286
e1083e99 1287=head2 rebuild_equivalence
1288
1289(Re)build the equivalence graph from scratch. Dumps the graph, makes a new one,
1290adds all readings and edges, then makes an equivalence for all relationships.
1291
1292=cut
1293
1294sub rebuild_equivalence {
1295 my $self = shift;
1296 my $newgraph = Graph->new();
04482188 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;
1302
b6f13859 1303 $self->collation->tradition->_init_done(0);
04482188 1304 # Add the readings
e1083e99 1305 foreach my $r ( $self->collation->readings ) {
04482188 1306 my $rid = $r->id;
1307 $newgraph->add_vertex( $rid );
1308 $self->set_equivalence( $rid, $rid );
1309 $self->set_eqreadings( $rid, [ $rid ] );
e1083e99 1310 }
04482188 1311
1312 # Now add the edges
e1083e99 1313 foreach my $e ( $self->collation->paths ) {
04482188 1314 $self->add_equivalence_edge( @$e );
e1083e99 1315 }
04482188 1316
1317 # Now equate the colocated readings. This does no testing;
1318 # it assumes that all preexisting relationships are valid.
e1083e99 1319 foreach my $rel ( $self->relationships ) {
1320 my $relobj = $self->get_relationship( $rel );
1321 next unless $relobj && $relobj->colocated;
1322 $self->_make_equivalence( @$rel );
1323 }
b6f13859 1324 $self->collation->tradition->_init_done(1);
e1083e99 1325}
1326
56772e8c 1327=head2 equivalence_ranks
1328
1329Rank all vertices in the equivalence graph, and return a hash reference with
1330vertex => rank mapping.
1331
1332=cut
1333
1334sub equivalence_ranks {
1335 my $self = shift;
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 );
1343 }
1344 return( $eqranks, $rankeqs );
1345}
1346
1347sub _assign_rank {
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.
1354 my @next_nodes;
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;
1361 my $skip = 0;
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};
1366 } else {
1367 $skip = 1;
1368 last;
1369 }
1370 }
1371 next if $skip;
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 );
1377 }
1378 }
1379 return @next_nodes;
1380}
1381
359944f7 1382### Output logic
1383
027d819c 1384sub _as_graphml {
2626f709 1385 my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_;
c84275ff 1386
1387 my $rgraph = $xmlroot->addNewChild( $graphml_ns, 'graph' );
1388 $rgraph->setAttribute( 'edgedefault', 'directed' );
1389 $rgraph->setAttribute( 'id', 'relationships', );
1390 $rgraph->setAttribute( 'parse.edgeids', 'canonical' );
cc31ebaa 1391 $rgraph->setAttribute( 'parse.edges', 0 );
c84275ff 1392 $rgraph->setAttribute( 'parse.nodeids', 'canonical' );
cc31ebaa 1393 $rgraph->setAttribute( 'parse.nodes', 0 );
c84275ff 1394 $rgraph->setAttribute( 'parse.order', 'nodesfirst' );
1395
1396 # Add the vertices according to their XML IDs
2626f709 1397 my %rdg_lookup = ( reverse %$node_hash );
cc31ebaa 1398 # my @nlist = sort _by_xmlid keys( %rdg_lookup ); ## CAUSES SEGFAULT
826d8773 1399 my @nlist = sort keys( %rdg_lookup );
414cc046 1400 foreach my $n ( @nlist ) {
c84275ff 1401 my $n_el = $rgraph->addNewChild( $graphml_ns, 'node' );
1402 $n_el->setAttribute( 'id', $n );
2626f709 1403 _add_graphml_data( $n_el, $nodeid_key, $rdg_lookup{$n} );
c84275ff 1404 }
cc31ebaa 1405 $rgraph->setAttribute( 'parse.nodes', scalar @nlist );
c84275ff 1406
1407 # Add the relationship edges, with their object information
1408 my $edge_ctr = 0;
1409 foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->graph->edges ) {
1410 # Add an edge and fill in its relationship info.
a30ca502 1411 next unless( exists $node_hash->{$e->[0]} && exists $node_hash->{$e->[1]} );
c84275ff 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++ );
1416
3ae5e2ad 1417 my $rel_obj = $self->get_relationship( @$e );
bbd064a9 1418 foreach my $key ( keys %$edge_keys ) {
1419 my $value = $rel_obj->$key;
1420 _add_graphml_data( $edge_el, $edge_keys->{$key}, $value )
1421 if defined $value;
1422 }
c84275ff 1423 }
cc31ebaa 1424 $rgraph->setAttribute( 'parse.edges', $edge_ctr );
c84275ff 1425}
1426
1427sub _by_xmlid {
2626f709 1428 my $tmp_a = $a;
1429 my $tmp_b = $b;
1430 $tmp_a =~ s/\D//g;
1431 $tmp_b =~ s/\D//g;
1432 return $tmp_a <=> $tmp_b;
c84275ff 1433}
1434
1435sub _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 );
83d5ac3a 1441}
1442
c7bd2768 1443sub dump_segment {
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 });
1448 close DUMP;
1449}
1450
63778331 1451sub throw {
1452 Text::Tradition::Error->throw(
1453 'ident' => 'Relationship error',
1454 'message' => $_[0],
1455 );
1456}
1457
22222af9 1458no Moose;
1459__PACKAGE__->meta->make_immutable;
1460
14611;
Unnamed repository; edit this file 'description' to name the repository.