Commit | Line | Data |
22222af9 |
1 | package Text::Tradition::Collation::RelationshipStore; |
2 | |
3 | use strict; |
4 | use warnings; |
24efa55d |
5 | use Safe::Isa; |
63778331 |
6 | use Text::Tradition::Error; |
22222af9 |
7 | use Text::Tradition::Collation::Relationship; |
24efa55d |
8 | use Text::Tradition::Collation::RelationshipType; |
a1615ee4 |
9 | use TryCatch; |
22222af9 |
10 | |
11 | use Moose; |
12 | |
13 | =head1 NAME |
14 | |
2626f709 |
15 | Text::Tradition::Collation::RelationshipStore - Keeps track of the relationships |
16 | between readings in a given collation |
22222af9 |
17 | |
18 | =head1 DESCRIPTION |
19 | |
20 | Text::Tradition is a library for representation and analysis of collated |
21 | texts, particularly medieval ones. The RelationshipStore is an internal object |
22 | of the collation, to keep track of the defined relationships (both specific and |
23 | general) between readings. |
24 | |
3ae5e2ad |
25 | =begin testing |
26 | |
27 | use Text::Tradition; |
ee801e17 |
28 | use TryCatch; |
3ae5e2ad |
29 | |
30 | use_ok( 'Text::Tradition::Collation::RelationshipStore' ); |
31 | |
ee801e17 |
32 | # Add some relationships, and delete them |
33 | |
34 | my $cxfile = 't/data/Collatex-16.xml'; |
35 | my $t = Text::Tradition->new( |
56772e8c |
36 | 'name' => 'inline', |
37 | 'input' => 'CollateX', |
38 | 'file' => $cxfile, |
39 | ); |
ee801e17 |
40 | my $c = $t->collation; |
41 | |
f8331a4d |
42 | my @v1 = $c->add_relationship( 'n21', 'n22', { 'type' => 'lexical' } ); |
ee801e17 |
43 | is( scalar @v1, 1, "Added a single relationship" ); |
44 | is( $v1[0]->[0], 'n21', "Got correct node 1" ); |
45 | is( $v1[0]->[1], 'n22', "Got correct node 2" ); |
679f17e1 |
46 | my @v2 = $c->add_relationship( 'n24', 'n23', |
ee801e17 |
47 | { 'type' => 'spelling', 'scope' => 'global' } ); |
48 | is( scalar @v2, 2, "Added a global relationship with two instances" ); |
49 | @v1 = $c->del_relationship( 'n22', 'n21' ); |
50 | is( scalar @v1, 1, "Deleted first relationship" ); |
7bdce750 |
51 | @v2 = $c->del_relationship( 'n12', 'n13', 1 ); |
ee801e17 |
52 | is( scalar @v2, 2, "Deleted second global relationship" ); |
681893aa |
53 | my @v3 = $c->del_relationship( 'n1', 'n2' ); |
54 | is( scalar @v3, 0, "Nothing deleted on non-existent relationship" ); |
7bdce750 |
55 | my @v4 = $c->add_relationship( 'n24', 'n23', |
56 | { 'type' => 'spelling', 'scope' => 'global' } ); |
57 | is( @v4, 2, "Re-added global relationship" ); |
58 | @v4 = $c->del_relationship( 'n12', 'n13' ); |
59 | is( @v4, 1, "Only specified relationship deleted this time" ); |
60 | ok( $c->get_relationship( 'n24', 'n23' ), "Other globally-added relationship exists" ); |
ee801e17 |
61 | |
3ae5e2ad |
62 | =end testing |
63 | |
22222af9 |
64 | =head1 METHODS |
65 | |
66 | =head2 new( collation => $collation ); |
67 | |
68 | Creates a new relationship store for the given collation. |
69 | |
70 | =cut |
71 | |
72 | has 'collation' => ( |
73 | is => 'ro', |
74 | isa => 'Text::Tradition::Collation', |
75 | required => 1, |
76 | weak_ref => 1, |
77 | ); |
24efa55d |
78 | |
79 | =head2 types |
80 | |
81 | Registry of possible relationship types. See RelationshipType for more info. |
82 | |
83 | =cut |
84 | |
85 | has 'relationship_types' => ( |
86 | is => 'ro', |
87 | traits => ['Hash'], |
88 | handles => { |
89 | has_type => 'exists', |
90 | add_type => 'set', |
77464a41 |
91 | del_type => 'delete', |
24efa55d |
92 | type => 'get', |
77464a41 |
93 | types => 'values' |
24efa55d |
94 | }, |
95 | ); |
22222af9 |
96 | |
97 | has 'scopedrels' => ( |
98 | is => 'ro', |
99 | isa => 'HashRef[HashRef[Text::Tradition::Collation::Relationship]]', |
100 | default => sub { {} }, |
101 | ); |
102 | |
103 | has 'graph' => ( |
104 | is => 'ro', |
105 | isa => 'Graph', |
106 | default => sub { Graph->new( undirected => 1 ) }, |
107 | handles => { |
108 | relationships => 'edges', |
109 | add_reading => 'add_vertex', |
110 | delete_reading => 'delete_vertex', |
24efa55d |
111 | }, |
22222af9 |
112 | ); |
113 | |
359944f7 |
114 | =head2 equivalence_graph() |
115 | |
116 | Returns an equivalence graph of the collation, in which all readings |
117 | related via a 'colocated' relationship are transformed into a single |
118 | vertex. Can be used to determine the validity of a new relationship. |
119 | |
120 | =cut |
121 | |
122 | has 'equivalence_graph' => ( |
123 | is => 'ro', |
124 | isa => 'Graph', |
125 | default => sub { Graph->new() }, |
e1083e99 |
126 | writer => '_reset_equivalence', |
359944f7 |
127 | ); |
128 | |
129 | has '_node_equivalences' => ( |
130 | is => 'ro', |
131 | traits => ['Hash'], |
132 | handles => { |
133 | equivalence => 'get', |
134 | set_equivalence => 'set', |
135 | remove_equivalence => 'delete', |
04482188 |
136 | _clear_equivalence => 'clear', |
24efa55d |
137 | }, |
359944f7 |
138 | ); |
139 | |
140 | has '_equivalence_readings' => ( |
141 | is => 'ro', |
142 | traits => ['Hash'], |
143 | handles => { |
144 | eqreadings => 'get', |
145 | set_eqreadings => 'set', |
146 | remove_eqreadings => 'delete', |
04482188 |
147 | _clear_eqreadings => 'clear', |
24efa55d |
148 | }, |
359944f7 |
149 | ); |
150 | |
24efa55d |
151 | ## Build function - here we have our default set of relationship types. |
152 | |
153 | sub BUILD { |
154 | my $self = shift; |
155 | |
24efa55d |
156 | my @DEFAULT_TYPES = ( |
0e4e4e4b |
157 | { name => 'collated', bindlevel => 50, is_weak => 1, is_transitive => 0, |
158 | is_generalizable => 0, description => 'Internal use only' }, |
159 | { name => 'orthographic', bindlevel => 0, use_regular => 0, |
160 | description => 'These are the same reading, neither unusually spelled.' }, |
161 | { name => 'punctuation', bindlevel => 0, |
162 | description => 'These are the same reading apart from punctuation.' }, |
163 | { name => 'spelling', bindlevel => 1, |
164 | description => 'These are the same reading, spelled differently.' }, |
165 | { name => 'grammatical', bindlevel => 2, |
166 | description => 'These readings share a root (lemma), but have different parts of speech (morphologies).' }, |
167 | { name => 'lexical', bindlevel => 2, |
168 | description => 'These readings share a part of speech (morphology), but have different roots (lemmata).' }, |
169 | { name => 'uncertain', bindlevel => 0, is_transitive => 0, is_generalizable => 0, |
170 | use_regular => 0, description => 'These readings are related, but a clear category cannot be assigned.' }, |
171 | { name => 'other', bindlevel => 0, is_transitive => 0, is_generalizable => 0, |
172 | description => 'These readings are related in a way not covered by the existing types.' }, |
173 | { name => 'transposition', bindlevel => 50, is_colocation => 0, |
174 | description => 'This is the same (or nearly the same) reading in a different location.' }, |
175 | { name => 'repetition', bindlevel => 50, is_colocation => 0, is_transitive => 0, |
176 | description => 'This is a reading that was repeated in one or more witnesses.' } |
24efa55d |
177 | ); |
178 | |
179 | foreach my $type ( @DEFAULT_TYPES ) { |
180 | $self->add_type( $type ); |
181 | } |
182 | } |
183 | |
24efa55d |
184 | around add_type => sub { |
185 | my $orig = shift; |
186 | my $self = shift; |
187 | my $new_type; |
188 | if( @_ == 1 && $_[0]->$_isa( 'Text::Tradition::Collation::RelationshipType' ) ) { |
189 | $new_type = shift; |
190 | } else { |
191 | my %args = @_ == 1 ? %{$_[0]} : @_; |
192 | $new_type = Text::Tradition::Collation::RelationshipType->new( %args ); |
193 | } |
194 | $self->$orig( $new_type->name => $new_type ); |
195 | return $new_type; |
196 | }; |
197 | |
359944f7 |
198 | around add_reading => sub { |
199 | my $orig = shift; |
200 | my $self = shift; |
201 | |
202 | $self->equivalence_graph->add_vertex( @_ ); |
203 | $self->set_equivalence( $_[0], $_[0] ); |
204 | $self->set_eqreadings( $_[0], [ $_[0] ] ); |
205 | $self->$orig( @_ ); |
206 | }; |
207 | |
208 | around delete_reading => sub { |
209 | my $orig = shift; |
210 | my $self = shift; |
211 | |
359944f7 |
212 | $self->_remove_equivalence_node( @_ ); |
213 | $self->$orig( @_ ); |
214 | }; |
215 | |
3ae5e2ad |
216 | =head2 get_relationship |
217 | |
218 | Return the relationship object, if any, that exists between two readings. |
219 | |
220 | =cut |
221 | |
222 | sub get_relationship { |
4633f9e4 |
223 | my $self = shift; |
224 | my @vector; |
225 | if( @_ == 1 && ref( $_[0] ) eq 'ARRAY' ) { |
226 | # Dereference the edge arrayref that was passed. |
227 | my $edge = shift; |
228 | @vector = @$edge; |
229 | } else { |
7bdce750 |
230 | @vector = @_[0,1]; |
4633f9e4 |
231 | } |
3ae5e2ad |
232 | my $relationship; |
233 | if( $self->graph->has_edge_attribute( @vector, 'object' ) ) { |
234 | $relationship = $self->graph->get_edge_attribute( @vector, 'object' ); |
ca6e6095 |
235 | } |
3ae5e2ad |
236 | return $relationship; |
237 | } |
238 | |
239 | sub _set_relationship { |
240 | my( $self, $relationship, @vector ) = @_; |
241 | $self->graph->add_edge( @vector ); |
242 | $self->graph->set_edge_attribute( @vector, 'object', $relationship ); |
176badfe |
243 | $self->_make_equivalence( @vector ) if $relationship->colocated; |
3ae5e2ad |
244 | } |
a1615ee4 |
245 | |
22222af9 |
246 | =head2 create |
247 | |
248 | Create a new relationship with the given options and return it. |
249 | Warn and return undef if the relationship cannot be created. |
250 | |
251 | =cut |
252 | |
253 | sub create { |
254 | my( $self, $options ) = @_; |
255 | # Check to see if a relationship exists between the two given readings |
256 | my $source = delete $options->{'orig_a'}; |
257 | my $target = delete $options->{'orig_b'}; |
3ae5e2ad |
258 | my $rel = $self->get_relationship( $source, $target ); |
259 | if( $rel ) { |
24efa55d |
260 | if( $self->type( $rel->type )->is_weak ) { |
261 | # Always replace a weak relationship with a more descriptive |
3d14b48e |
262 | # one, if asked. |
263 | $self->del_relationship( $source, $target ); |
264 | } elsif( $rel->type ne $options->{'type'} ) { |
63778331 |
265 | throw( "Another relationship of type " . $rel->type |
266 | . " already exists between $source and $target" ); |
22222af9 |
267 | } else { |
268 | return $rel; |
269 | } |
270 | } |
271 | |
99ab9535 |
272 | $rel = Text::Tradition::Collation::Relationship->new( $options ); |
24efa55d |
273 | my $reltype = $self->type( $rel->type ); |
c7bd2768 |
274 | throw( "Unrecognized relationship type " . $rel->type ) unless $reltype; |
24efa55d |
275 | # Validate the options given against the relationship type wanted |
276 | throw( "Cannot set nonlocal scope on relationship of type " . $reltype->name ) |
277 | if $rel->nonlocal && !$reltype->is_generalizable; |
278 | |
99ab9535 |
279 | $self->add_scoped_relationship( $rel ) if $rel->nonlocal; |
280 | return $rel; |
22222af9 |
281 | } |
282 | |
283 | =head2 add_scoped_relationship( $rel ) |
284 | |
285 | Keep track of relationships defined between specific readings that are scoped |
286 | non-locally. Key on whichever reading occurs first alphabetically. |
287 | |
288 | =cut |
289 | |
290 | sub add_scoped_relationship { |
291 | my( $self, $rel ) = @_; |
24efa55d |
292 | my $rdga = $rel->reading_a; |
293 | my $rdgb = $rel->reading_b; |
f222800e |
294 | my $r = $self->scoped_relationship( $rdga, $rdgb ); |
22222af9 |
295 | if( $r ) { |
296 | warn sprintf( "Scoped relationship of type %s already exists between %s and %s", |
f222800e |
297 | $r->type, $rdga, $rdgb ); |
22222af9 |
298 | return; |
299 | } |
f222800e |
300 | my( $first, $second ) = sort ( $rdga, $rdgb ); |
301 | $self->scopedrels->{$first}->{$second} = $rel; |
22222af9 |
302 | } |
303 | |
304 | =head2 scoped_relationship( $reading_a, $reading_b ) |
305 | |
306 | Returns the general (document-level or global) relationship that has been defined |
307 | between the two reading strings. Returns undef if there is no general relationship. |
308 | |
309 | =cut |
310 | |
311 | sub scoped_relationship { |
312 | my( $self, $rdga, $rdgb ) = @_; |
313 | my( $first, $second ) = sort( $rdga, $rdgb ); |
314 | if( exists $self->scopedrels->{$first}->{$second} ) { |
315 | return $self->scopedrels->{$first}->{$second}; |
24efa55d |
316 | } |
317 | return undef; |
22222af9 |
318 | } |
319 | |
320 | =head2 add_relationship( $self, $source, $sourcetext, $target, $targettext, $opts ) |
321 | |
322 | Adds the relationship specified in $opts (see Text::Tradition::Collation::Relationship |
323 | for the possible options) between the readings given in $source and $target. Sets |
324 | up a scoped relationship between $sourcetext and $targettext if the relationship is |
325 | scoped non-locally. |
326 | |
327 | Returns a status boolean and a list of all reading pairs connected by the call to |
328 | add_relationship. |
329 | |
6d381462 |
330 | =begin testing |
331 | |
56772e8c |
332 | use Test::Warn; |
6d381462 |
333 | use Text::Tradition; |
334 | use TryCatch; |
335 | |
56772e8c |
336 | my $t1; |
e92d4229 |
337 | warnings_exist { |
56772e8c |
338 | $t1 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/legendfrag.xml' ); |
e92d4229 |
339 | } [qr/Cannot set relationship on a meta reading/], |
56772e8c |
340 | "Got expected relationship drop warning on parse"; |
341 | |
176badfe |
342 | # Test 1.1: try to equate nodes that are prevented with an intermediate collation |
6d381462 |
343 | ok( $t1, "Parsed test fragment file" ); |
344 | my $c1 = $t1->collation; |
10e4b1ac |
345 | my $trel = $c1->get_relationship( 'r9.2', 'r9.3' ); |
6d381462 |
346 | is( ref( $trel ), 'Text::Tradition::Collation::Relationship', |
347 | "Troublesome relationship exists" ); |
348 | is( $trel->type, 'collated', "Troublesome relationship is a collation" ); |
349 | |
350 | # Try to make the link we want |
351 | try { |
10e4b1ac |
352 | $c1->add_relationship( 'r8.6', 'r10.3', { 'type' => 'orthographic' } ); |
6d381462 |
353 | ok( 1, "Added cross-collation relationship as expected" ); |
176badfe |
354 | } catch( Text::Tradition::Error $e ) { |
355 | ok( 0, "Existing collation blocked equivalence relationship: " . $e->message ); |
6d381462 |
356 | } |
357 | |
358 | try { |
359 | $c1->calculate_ranks(); |
360 | ok( 1, "Successfully calculated ranks" ); |
176badfe |
361 | } catch ( Text::Tradition::Error $e ) { |
362 | ok( 0, "Collation now has a cycle: " . $e->message ); |
6d381462 |
363 | } |
364 | |
176badfe |
365 | # Test 1.2: attempt merge of an identical reading |
359944f7 |
366 | try { |
10e4b1ac |
367 | $c1->merge_readings( 'r9.3', 'r11.5' ); |
359944f7 |
368 | ok( 1, "Successfully merged reading 'pontifex'" ); |
369 | } catch ( Text::Tradition::Error $e ) { |
370 | ok( 0, "Merge of mergeable readings failed: $e->message" ); |
371 | |
372 | } |
373 | |
176badfe |
374 | # Test 1.3: attempt relationship with a meta reading (should fail) |
375 | try { |
10e4b1ac |
376 | $c1->add_relationship( 'r8.1', 'r9.2', { 'type' => 'collated' } ); |
176badfe |
377 | ok( 0, "Allowed a meta-reading to be used in a relationship" ); |
378 | } catch ( Text::Tradition::Error $e ) { |
379 | is( $e->message, 'Cannot set relationship on a meta reading', |
380 | "Relationship link prevented for a meta reading" ); |
381 | } |
382 | |
beb47b16 |
383 | # Test 1.4: try to break a relationship near a meta reading |
384 | $c1->add_relationship( 'r7.6', 'r7.3', { type => 'orthographic' } ); |
385 | try { |
386 | $c1->del_relationship( 'r7.6', 'r7.7' ); |
387 | $c1->del_relationship( 'r7.6', 'r7.3' ); |
388 | ok( 1, "Relationship broken with a meta reading as neighbor" ); |
389 | } catch { |
390 | ok( 0, "Relationship deletion failed with a meta reading as neighbor" ); |
391 | } |
392 | |
176badfe |
393 | # Test 2.1: try to equate nodes that are prevented with a real intermediate |
6d381462 |
394 | # equivalence |
56772e8c |
395 | my $t2; |
e92d4229 |
396 | warnings_exist { |
56772e8c |
397 | $t2 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/legendfrag.xml' ); |
e92d4229 |
398 | } [qr/Cannot set relationship on a meta reading/], |
56772e8c |
399 | "Got expected relationship drop warning on parse"; |
6d381462 |
400 | my $c2 = $t2->collation; |
10e4b1ac |
401 | $c2->add_relationship( 'r9.2', 'r9.3', { 'type' => 'lexical' } ); |
402 | my $trel2 = $c2->get_relationship( 'r9.2', 'r9.3' ); |
6d381462 |
403 | is( ref( $trel2 ), 'Text::Tradition::Collation::Relationship', |
404 | "Created blocking relationship" ); |
405 | is( $trel2->type, 'lexical', "Blocking relationship is not a collation" ); |
406 | # This time the link ought to fail |
407 | try { |
10e4b1ac |
408 | $c2->add_relationship( 'r8.6', 'r10.3', { 'type' => 'orthographic' } ); |
414cc046 |
409 | ok( 0, "Added cross-equivalent bad relationship" ); |
176badfe |
410 | } catch ( Text::Tradition::Error $e ) { |
411 | like( $e->message, qr/witness loop/, |
412 | "Existing equivalence blocked crossing relationship" ); |
6d381462 |
413 | } |
414 | |
415 | try { |
416 | $c2->calculate_ranks(); |
417 | ok( 1, "Successfully calculated ranks" ); |
176badfe |
418 | } catch ( Text::Tradition::Error $e ) { |
419 | ok( 0, "Collation now has a cycle: " . $e->message ); |
6d381462 |
420 | } |
421 | |
176badfe |
422 | # Test 3.1: make a straightforward pair of transpositions. |
cc31ebaa |
423 | my $t3 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/lf2.xml' ); |
424 | # Test 1: try to equate nodes that are prevented with an intermediate collation |
425 | my $c3 = $t3->collation; |
426 | try { |
10e4b1ac |
427 | $c3->add_relationship( 'r36.4', 'r38.3', { 'type' => 'transposition' } ); |
cc31ebaa |
428 | ok( 1, "Added straightforward transposition" ); |
176badfe |
429 | } catch ( Text::Tradition::Error $e ) { |
430 | ok( 0, "Failed to add normal transposition: " . $e->message ); |
cc31ebaa |
431 | } |
432 | try { |
10e4b1ac |
433 | $c3->add_relationship( 'r36.3', 'r38.2', { 'type' => 'transposition' } ); |
cc31ebaa |
434 | ok( 1, "Added straightforward transposition complement" ); |
176badfe |
435 | } catch ( Text::Tradition::Error $e ) { |
436 | ok( 0, "Failed to add normal transposition complement: " . $e->message ); |
cc31ebaa |
437 | } |
438 | |
176badfe |
439 | # Test 3.2: try to make a transposition that could be a parallel. |
cc31ebaa |
440 | try { |
10e4b1ac |
441 | $c3->add_relationship( 'r28.2', 'r29.2', { 'type' => 'transposition' } ); |
cc31ebaa |
442 | ok( 0, "Added bad colocated transposition" ); |
176badfe |
443 | } catch ( Text::Tradition::Error $e ) { |
444 | like( $e->message, qr/Readings appear to be colocated/, |
445 | "Prevented bad colocated transposition" ); |
cc31ebaa |
446 | } |
447 | |
176badfe |
448 | # Test 3.3: make the parallel, and then make the transposition again. |
cc31ebaa |
449 | try { |
10e4b1ac |
450 | $c3->add_relationship( 'r28.3', 'r29.3', { 'type' => 'orthographic' } ); |
cc31ebaa |
451 | ok( 1, "Equated identical readings for transposition" ); |
176badfe |
452 | } catch ( Text::Tradition::Error $e ) { |
453 | ok( 0, "Failed to equate identical readings: " . $e->message ); |
cc31ebaa |
454 | } |
455 | try { |
10e4b1ac |
456 | $c3->add_relationship( 'r28.2', 'r29.2', { 'type' => 'transposition' } ); |
cc31ebaa |
457 | ok( 1, "Added straightforward transposition complement" ); |
176badfe |
458 | } catch ( Text::Tradition::Error $e ) { |
459 | ok( 0, "Failed to add normal transposition complement: " . $e->message ); |
cc31ebaa |
460 | } |
461 | |
9e9b7540 |
462 | # Test 4: make a global relationship that involves re-ranking a node first, when |
c7bd2768 |
463 | # the prior rank has a potential match too |
464 | my $t4 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/globalrel_test.xml' ); |
98a66507 |
465 | my $c4 = $t4->collation; |
466 | # Can we even add the relationship? |
467 | try { |
468 | $c4->add_relationship( 'r463.2', 'r463.4', |
469 | { type => 'orthographic', scope => 'global' } ); |
470 | ok( 1, "Added global relationship without error" ); |
471 | } catch ( Text::Tradition::Error $e ) { |
472 | ok( 0, "Failed to add global relationship when same-rank alternative exists: " |
473 | . $e->message ); |
474 | } |
475 | $c4->calculate_ranks(); |
476 | # Do our readings now share a rank? |
477 | is( $c4->reading('r463.2')->rank, $c4->reading('r463.4')->rank, |
478 | "Expected readings now at same rank" ); |
9e9b7540 |
479 | |
480 | # Test group 5: relationship transitivity. |
481 | my $t5 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/john.xml' ); |
482 | my $c5 = $t5->collation; |
0e4e4e4b |
483 | # Test 5.0: propagate all existing transitive rels and make sure it succeeds |
484 | my $orignumrels = scalar $c5->relationships(); |
485 | try { |
486 | $c5->relations->propagate_all_relationships(); |
487 | ok( 1, "Propagated all existing transitive relationships" ); |
488 | } catch ( Text::Tradition::Error $err ) { |
489 | ok( 0, "Failed to propagate all existing relationships: " . $err->message ); |
490 | } |
491 | ok( scalar( $c5->relationships ) > $orignumrels, "Added some relationships in propagation" ); |
9e9b7540 |
492 | |
493 | # Test 5.1: make a grammatical link to an orthographically-linked reading |
494 | $c5->add_relationship( 'r13.5', 'r13.2', { type => 'orthographic' } ); |
495 | $c5->add_relationship( 'r13.1', 'r13.2', { type => 'grammatical', propagate => 1 } ); |
496 | my $impliedrel = $c5->get_relationship( 'r13.1', 'r13.5' ); |
497 | ok( $impliedrel, 'Relationship was made between indirectly linked readings' ); |
498 | if( $impliedrel ) { |
499 | is( $impliedrel->type, 'grammatical', 'Implicit inbound relationship has the correct type' ); |
500 | } |
501 | |
502 | # Test 5.2: make another orthographic link, see if the grammatical one propagates |
503 | $c5->add_relationship( 'r13.3', 'r13.5', { type => 'orthographic', propagate => 1 } ); |
504 | foreach my $rdg ( qw/ r13.3 r13.5 / ) { |
505 | my $newgram = $c5->get_relationship( 'r13.1', $rdg ); |
506 | ok( $newgram, 'Relationship was propagaged up between indirectly linked readings' ); |
507 | if( $newgram ) { |
508 | is( $newgram->type, 'grammatical', 'Implicit outbound relationship has the correct type' ); |
509 | } |
510 | } |
511 | my $neworth = $c5->get_relationship( 'r13.2', 'r13.3' ); |
512 | ok( $neworth, 'Relationship was made between indirectly linked siblings' ); |
513 | if( $neworth ) { |
514 | is( $neworth->type, 'orthographic', 'Implicit direct relationship has the correct type' ); |
515 | } |
516 | |
517 | # Test 5.3: make an intermediate (spelling) link to the remaining node |
518 | $c5->add_relationship( 'r13.4', 'r13.2', { type => 'spelling', propagate => 1 } ); |
519 | # Should be linked grammatically to 12.1, spelling-wise to the rest |
520 | my $newgram = $c5->get_relationship( 'r13.4', 'r13.1' ); |
521 | ok( $newgram, 'Relationship was made between indirectly linked readings' ); |
522 | if( $newgram ) { |
523 | is( $newgram->type, 'grammatical', 'Implicit intermediate-out relationship has the correct type' ); |
524 | } |
525 | foreach my $rdg ( qw/ r13.3 r13.5 / ) { |
526 | my $newspel = $c5->get_relationship( 'r13.4', $rdg ); |
527 | ok( $newspel, 'Relationship was made between indirectly linked readings' ); |
528 | if( $newspel ) { |
529 | is( $newspel->type, 'spelling', 'Implicit intermediate-in relationship has the correct type' ); |
530 | } |
531 | } |
532 | |
52179f61 |
533 | # Test 5.4: delete a spelling relationship, add it again, make sure it doesn't |
534 | # throw and make sure all the relationships are the same |
535 | my $numrel = scalar $c5->relationships; |
536 | $c5->del_relationship( 'r13.4', 'r13.2' ); |
537 | try { |
538 | $c5->add_relationship( 'r13.4', 'r13.2', { type => 'spelling', propagate => 1 } ); |
539 | ok( 1, "Managed not to throw an exception re-adding the relationship" ); |
540 | } catch( Text::Tradition::Error $e ) { |
541 | ok( 0, "Threw an exception trying to re-add our intermediate relationship: " . $e->message ); |
542 | } |
543 | is( $numrel, scalar $c5->relationships, "Number of relationships did not change" ); |
544 | foreach my $rdg ( qw/ r13.2 r13.3 r13.5 / ) { |
545 | my $newspel = $c5->get_relationship( 'r13.4', $rdg ); |
546 | ok( $newspel, 'Relationship was made between indirectly linked readings' ); |
547 | if( $newspel ) { |
548 | is( $newspel->type, 'spelling', 'Reinstated intermediate-in relationship has the correct type' ); |
549 | } |
550 | } |
551 | my $stillgram = $c5->get_relationship( 'r13.4', 'r13.1' ); |
552 | ok( $stillgram, 'Relationship was made between indirectly linked readings' ); |
553 | if( $stillgram ) { |
554 | is( $stillgram->type, 'grammatical', 'Reinstated intermediate-out relationship has the correct type' ); |
555 | } |
556 | |
557 | # Test 5.5: add a parallel but not sibling relationship |
9e9b7540 |
558 | $c5->add_relationship( 'r13.6', 'r13.2', { type => 'lexical', propagate => 1 } ); |
559 | ok( !$c5->get_relationship( 'r13.6', 'r13.1' ), |
560 | "Lexical relationship did not affect grammatical" ); |
561 | foreach my $rdg ( qw/ r13.3 r13.4 r13.5 / ) { |
562 | my $newlex = $c5->get_relationship( 'r13.6', $rdg ); |
563 | ok( $newlex, 'Parallel was made between indirectly linked readings' ); |
564 | if( $newlex ) { |
565 | is( $newlex->type, 'lexical', 'Implicit parallel-down relationship has the correct type' ); |
566 | } |
567 | } |
568 | |
52179f61 |
569 | # Test 5.6: try it with non-colocated relationships |
570 | $numrel = scalar $c5->relationships; |
9e9b7540 |
571 | $c5->add_relationship( 'r62.1', 'r64.1', { type => 'transposition', propagate => 1 } ); |
572 | is( scalar $c5->relationships, $numrel+1, |
573 | "Adding non-colo relationship did not propagate" ); |
574 | # Add a pivot point |
575 | $c5->add_relationship( 'r61.1', 'r61.5', { type => 'orthographic' } ); |
576 | # Add a third transposed node |
577 | $c5->add_relationship( 'r62.1', 'r60.3', { type => 'transposition', propagate => 1 } ); |
578 | my $newtrans = $c5->get_relationship( 'r64.1', 'r60.3' ); |
579 | ok( $newtrans, 'Non-colo relationship was made between indirectly linked readings' ); |
580 | if( $newtrans ) { |
581 | is( $newtrans->type, 'transposition', 'Implicit non-colo relationship has the correct type' ); |
582 | } |
583 | is( scalar $c5->relationships, $numrel+4, |
584 | "Adding non-colo relationship only propagated on non-colos" ); |
585 | |
0e4e4e4b |
586 | # Test 5.7: ensure that attempts to cross boundaries on bindlevel-equal |
587 | # relationships fail. |
588 | try { |
589 | $c5->add_relationship( 'r39.6', 'r41.1', { type => 'grammatical', propagate => 1 } ); |
590 | ok( 0, "Did not prevent add of conflicting relationship level" ); |
591 | } catch( Text::Tradition::Error $err ) { |
592 | like( $err->message, qr/Conflicting existing relationship/, "Got correct error message trying to add conflicting relationship level" ); |
593 | } |
594 | |
595 | # Test 5.8: ensure that weak relationships don't interfere |
596 | $c5->add_relationship( 'r50.1', 'r50.2', { type => 'collated' } ); |
597 | $c5->add_relationship( 'r50.3', 'r50.4', { type => 'orthographic' } ); |
598 | try { |
599 | $c5->add_relationship( 'r50.4', 'r50.1', { type => 'grammatical', propagate => 1 } ); |
600 | ok( 1, "Collation did not interfere with new relationship add" ); |
601 | } catch( Text::Tradition::Error $err ) { |
602 | ok( 0, "Collation interfered with new relationship add: " . $err->message ); |
603 | } |
604 | my $crel = $c5->get_relationship( 'r50.1', 'r50.2' ); |
605 | ok( $crel, "Original relationship still exists" ); |
606 | if( $crel ) { |
607 | is( $crel->type, 'collated', "Original relationship still a collation" ); |
608 | } |
c7bd2768 |
609 | |
0e4e4e4b |
610 | try { |
611 | $c5->add_relationship( 'r50.1', 'r51.1', { type => 'spelling', propagate => 1 } ); |
612 | ok( 1, "Collation did not interfere with relationship re-ranking" ); |
613 | } catch( Text::Tradition::Error $err ) { |
614 | ok( 0, "Collation interfered with relationship re-ranking: " . $err->message ); |
615 | } |
616 | $crel = $c5->get_relationship( 'r50.1', 'r50.2' ); |
617 | ok( !$crel, "Collation relationship now gone" ); |
c96efd0b |
618 | |
0e4e4e4b |
619 | # Test 5.9: ensure that strong non-transitive relationships don't interfere |
620 | $c5->add_relationship( 'r66.1', 'r66.4', { type => 'grammatical' } ); |
621 | $c5->add_relationship( 'r66.2', 'r66.4', { type => 'uncertain', propagate => 1 } ); |
622 | try { |
623 | $c5->add_relationship( 'r66.1', 'r66.3', { type => 'grammatical', propagate => 1 } ); |
624 | ok( 1, "Non-transitive relationship did not block grammatical add" ); |
625 | } catch( Text::Tradition::Error $err ) { |
626 | ok( 0, "Non-transitive relationship blocked grammatical add: " . $err->message ); |
627 | } |
628 | is( scalar $c5->related_readings( 'r66.4' ), 3, "Reading 66.4 has all its links" ); |
629 | is( scalar $c5->related_readings( 'r66.2' ), 1, "Reading 66.2 has only one link" ); |
630 | is( scalar $c5->related_readings( 'r66.1' ), 2, "Reading 66.1 has all its links" ); |
631 | is( scalar $c5->related_readings( 'r66.3' ), 2, "Reading 66.3 has all its links" ); |
c96efd0b |
632 | |
6d381462 |
633 | =end testing |
634 | |
22222af9 |
635 | =cut |
636 | |
637 | sub add_relationship { |
414cc046 |
638 | my( $self, $source, $target, $options ) = @_; |
639 | my $c = $self->collation; |
176badfe |
640 | my $sourceobj = $c->reading( $source ); |
641 | my $targetobj = $c->reading( $target ); |
359944f7 |
642 | throw( "Adding self relationship at $source" ) if $source eq $target; |
176badfe |
643 | throw( "Cannot set relationship on a meta reading" ) |
644 | if( $sourceobj->is_meta || $targetobj->is_meta ); |
ca6e6095 |
645 | my $relationship; |
24efa55d |
646 | my $reltype; |
c7bd2768 |
647 | my $thispaironly = delete $options->{thispaironly}; |
9e9b7540 |
648 | my $propagate = delete $options->{propagate}; |
414cc046 |
649 | my $droppedcolls = []; |
ca6e6095 |
650 | if( ref( $options ) eq 'Text::Tradition::Collation::Relationship' ) { |
651 | $relationship = $options; |
24efa55d |
652 | $reltype = $self->type( $relationship->type ); |
ca6e6095 |
653 | $thispaironly = 1; # If existing rel, set only where asked. |
24efa55d |
654 | # Test the validity |
414cc046 |
655 | my( $is_valid, $reason ) = $self->relationship_valid( $source, $target, |
24efa55d |
656 | $relationship->type, $droppedcolls ); |
ca6e6095 |
657 | unless( $is_valid ) { |
658 | throw( "Invalid relationship: $reason" ); |
659 | } |
24efa55d |
660 | } else { |
661 | $reltype = $self->type( $options->{type} ); |
ca6e6095 |
662 | |
663 | # Try to create the relationship object. |
c7bd2768 |
664 | my $rdga = $reltype->regularize( $sourceobj ); |
665 | my $rdgb = $reltype->regularize( $targetobj ); |
24efa55d |
666 | $options->{'orig_a'} = $sourceobj; |
667 | $options->{'orig_b'} = $targetobj; |
668 | $options->{'reading_a'} = $rdga; |
669 | $options->{'reading_b'} = $rdgb; |
670 | if( exists $options->{'scope'} && $options->{'scope'} ne 'local' ) { |
0ac5e750 |
671 | # Is there a relationship with this a & b already? |
24efa55d |
672 | if( $rdga eq $rdgb ) { |
673 | # If we have canonified to the same thing for the relationship |
674 | # type we want, something is wrong. |
675 | # NOTE we want to allow this at the local level, as a cheap means |
676 | # of merging readings in the UI, until we get a better means. |
677 | throw( "Canonifier returns identical form $rdga for this relationship type" ); |
678 | } |
679 | |
f222800e |
680 | my $otherrel = $self->scoped_relationship( $rdga, $rdgb ); |
0ac5e750 |
681 | if( $otherrel && $otherrel->type eq $options->{type} |
682 | && $otherrel->scope eq $options->{scope} ) { |
24efa55d |
683 | # warn "Applying existing scoped relationship for $rdga / $rdgb"; |
0ac5e750 |
684 | $relationship = $otherrel; |
99ab9535 |
685 | } elsif( $otherrel ) { |
24efa55d |
686 | throw( 'Conflicting scoped relationship ' |
687 | . join( '/', $otherrel->type, $otherrel->scope ) . ' vs. ' |
688 | . join( '/', $options->{type}, $options->{scope} ) |
689 | . " for $rdga / $rdgb at $source / $target" ); |
0ac5e750 |
690 | } |
691 | } |
24efa55d |
692 | $relationship = $self->create( $options ) unless $relationship; |
693 | # ... Will throw on error |
694 | |
695 | # See if the relationship is actually valid here |
696 | my( $is_valid, $reason ) = $self->relationship_valid( $source, $target, |
697 | $options->{'type'}, $droppedcolls ); |
698 | unless( $is_valid ) { |
699 | throw( "Invalid relationship: $reason" ); |
700 | } |
22222af9 |
701 | } |
ca6e6095 |
702 | |
22222af9 |
703 | |
22222af9 |
704 | # Now set the relationship(s). |
705 | my @pairs_set; |
414cc046 |
706 | my $rel = $self->get_relationship( $source, $target ); |
cc31ebaa |
707 | my $skip; |
414cc046 |
708 | if( $rel && $rel ne $relationship ) { |
709 | if( $rel->nonlocal ) { |
710 | throw( "Found conflicting relationship at $source - $target" ); |
24efa55d |
711 | } elsif( !$reltype->is_weak ) { |
712 | # Replace a weak relationship; leave any other sort in place. |
414cc046 |
713 | my $r1ann = $rel->has_annotation ? $rel->annotation : ''; |
714 | my $r2ann = $relationship->has_annotation ? $relationship->annotation : ''; |
715 | unless( $rel->type eq $relationship->type && $r1ann eq $r2ann ) { |
716 | warn sprintf( "Not overriding local relationship %s with global %s " |
717 | . "set at %s -> %s (%s -> %s)", $rel->type, $relationship->type, |
718 | $source, $target, $rel->reading_a, $rel->reading_b ); |
414cc046 |
719 | } |
24efa55d |
720 | $skip = 1; |
414cc046 |
721 | } |
722 | } |
cc31ebaa |
723 | $self->_set_relationship( $relationship, $source, $target ) unless $skip; |
9e9b7540 |
724 | push( @pairs_set, [ $source, $target, $relationship->type ] ); |
414cc046 |
725 | |
428bcf0b |
726 | # Find all the pairs for which we need to set the relationship. |
727 | if( $relationship->colocated && $relationship->nonlocal && !$thispaironly ) { |
9e9b7540 |
728 | my @global_set = $self->add_global_relationship( $relationship ); |
9e9b7540 |
729 | push( @pairs_set, @global_set ); |
730 | } |
731 | if( $propagate ) { |
732 | my @prop; |
733 | foreach my $ps ( @pairs_set ) { |
734 | my @extra = $self->propagate_relationship( $ps->[0], $ps->[1] ); |
735 | push( @prop, @extra ); |
736 | } |
737 | push( @pairs_set, @prop ) if @prop; |
22222af9 |
738 | } |
9e9b7540 |
739 | |
414cc046 |
740 | # Finally, restore whatever collations we can, and return. |
24efa55d |
741 | $self->_restore_weak( @$droppedcolls ); |
63778331 |
742 | return @pairs_set; |
22222af9 |
743 | } |
744 | |
428bcf0b |
745 | =head2 add_global_relationship( $options, $skipvector ) |
746 | |
747 | Adds the relationship specified wherever the relevant readings appear together |
748 | in the graph. Options as in add_relationship above. |
749 | |
750 | =cut |
751 | |
752 | sub add_global_relationship { |
24efa55d |
753 | my( $self, $relationship ) = @_; |
428bcf0b |
754 | # Sanity checking |
24efa55d |
755 | my $reltype = $self->type( $relationship->type ); |
428bcf0b |
756 | throw( "Relationship passed to add_global is not global" ) |
757 | unless $relationship->nonlocal; |
758 | throw( "Relationship passed to add_global is not a valid global type" ) |
24efa55d |
759 | unless $reltype->is_generalizable; |
428bcf0b |
760 | |
761 | # Apply the relationship wherever it is valid |
762 | my @pairs_set; |
763 | foreach my $v ( $self->_find_applicable( $relationship ) ) { |
764 | my $exists = $self->get_relationship( @$v ); |
24efa55d |
765 | my $etype = $exists ? $self->type( $exists->type ) : ''; |
766 | if( $exists && !$etype->is_weak ) { |
767 | unless( $exists->is_equivalent( $relationship ) ) { |
768 | throw( "Found conflicting relationship at @$v" ); |
769 | } |
428bcf0b |
770 | } else { |
24efa55d |
771 | my @added; |
772 | try { |
773 | @added = $self->add_relationship( @$v, $relationship ); |
774 | } catch { |
775 | my $reldesc = sprintf( "%s %s -> %s", $relationship->type, |
776 | $relationship->reading_a, $relationship->reading_b ); |
98a66507 |
777 | # print STDERR "Global relationship $reldesc not applicable at @$v\n"; |
24efa55d |
778 | } |
779 | push( @pairs_set, @added ) if @added; |
428bcf0b |
780 | } |
781 | } |
782 | return @pairs_set; |
783 | } |
784 | |
785 | |
9d829138 |
786 | =head2 del_scoped_relationship( $reading_a, $reading_b ) |
787 | |
788 | Returns the general (document-level or global) relationship that has been defined |
789 | between the two reading strings. Returns undef if there is no general relationship. |
790 | |
791 | =cut |
792 | |
793 | sub del_scoped_relationship { |
794 | my( $self, $rdga, $rdgb ) = @_; |
795 | my( $first, $second ) = sort( $rdga, $rdgb ); |
796 | return delete $self->scopedrels->{$first}->{$second}; |
797 | } |
798 | |
bf6e338d |
799 | sub _find_applicable { |
800 | my( $self, $rel ) = @_; |
801 | my $c = $self->collation; |
24efa55d |
802 | my $reltype = $self->type( $rel->type ); |
bf6e338d |
803 | my @vectors; |
804 | my @identical_readings; |
c7bd2768 |
805 | @identical_readings = grep { $reltype->regularize( $_ ) eq $rel->reading_a } |
24efa55d |
806 | $c->readings; |
bf6e338d |
807 | foreach my $ir ( @identical_readings ) { |
808 | my @itarget; |
c7bd2768 |
809 | @itarget = grep { $reltype->regularize( $_ ) eq $rel->reading_b } |
24efa55d |
810 | $c->readings_at_rank( $ir->rank ); |
bf6e338d |
811 | if( @itarget ) { |
24efa55d |
812 | # Warn if there is more than one hit with no closer link between them. |
bf6e338d |
813 | my $itmain = shift @itarget; |
814 | if( @itarget ) { |
815 | my %all_targets; |
24efa55d |
816 | my $bindlevel = $reltype->bindlevel; |
bf6e338d |
817 | map { $all_targets{$_} = 1 } @itarget; |
818 | map { delete $all_targets{$_} } |
24efa55d |
819 | $self->related_readings( $itmain, sub { |
820 | $self->type( $_[0]->type )->bindlevel < $bindlevel } ); |
bf6e338d |
821 | warn "More than one unrelated reading with text " . $itmain->text |
822 | . " at rank " . $ir->rank . "!" if keys %all_targets; |
823 | } |
824 | push( @vectors, [ $ir->id, $itmain->id ] ); |
825 | } |
826 | } |
827 | return @vectors; |
828 | } |
829 | |
7bdce750 |
830 | =head2 del_relationship( $source, $target, $allscope ) |
ee801e17 |
831 | |
832 | Removes the relationship between the given readings. If the relationship is |
7bdce750 |
833 | non-local and $allscope is true, removes the relationship throughout the |
834 | relevant scope. |
ee801e17 |
835 | |
836 | =cut |
837 | |
838 | sub del_relationship { |
7bdce750 |
839 | my( $self, $source, $target, $allscope ) = @_; |
ee801e17 |
840 | my $rel = $self->get_relationship( $source, $target ); |
681893aa |
841 | return () unless $rel; # Nothing to delete; return an empty set. |
24efa55d |
842 | my $reltype = $self->type( $rel->type ); |
359944f7 |
843 | my $colo = $rel->colocated; |
ee801e17 |
844 | my @vectors = ( [ $source, $target ] ); |
359944f7 |
845 | $self->_remove_relationship( $colo, $source, $target ); |
7bdce750 |
846 | if( $rel->nonlocal && $allscope ) { |
ee801e17 |
847 | # Remove the relationship wherever it occurs. |
24efa55d |
848 | my @rel_edges = grep { $self->get_relationship( @$_ ) eq $rel } |
ee801e17 |
849 | $self->relationships; |
850 | foreach my $re ( @rel_edges ) { |
359944f7 |
851 | $self->_remove_relationship( $colo, @$re ); |
ee801e17 |
852 | push( @vectors, $re ); |
853 | } |
9d829138 |
854 | $self->del_scoped_relationship( $rel->reading_a, $rel->reading_b ); |
ee801e17 |
855 | } |
856 | return @vectors; |
857 | } |
858 | |
ca6e6095 |
859 | sub _remove_relationship { |
359944f7 |
860 | my( $self, $equiv, @vector ) = @_; |
ca6e6095 |
861 | $self->graph->delete_edge( @vector ); |
176badfe |
862 | $self->_break_equivalence( @vector ) if $equiv; |
ca6e6095 |
863 | } |
864 | |
22222af9 |
865 | =head2 relationship_valid( $source, $target, $type ) |
866 | |
867 | Checks whether a relationship of type $type may exist between the readings given |
868 | in $source and $target. Returns a tuple of ( status, message ) where status is |
869 | a yes/no boolean and, if the answer is no, message gives the reason why. |
870 | |
871 | =cut |
872 | |
873 | sub relationship_valid { |
414cc046 |
874 | my( $self, $source, $target, $rel, $mustdrop ) = @_; |
875 | $mustdrop = [] unless $mustdrop; # in case we were passed nothing |
22222af9 |
876 | my $c = $self->collation; |
24efa55d |
877 | my $reltype = $self->type( $rel ); |
10943ab0 |
878 | ## Assume validity is okay if we are initializing from scratch. |
3579c22b |
879 | return ( 1, "initializing" ) unless $c->tradition->_initialized; |
c7bd2768 |
880 | ## TODO Move this block to relationship type definition when we can save |
881 | ## coderefs |
24efa55d |
882 | if ( $rel eq 'transposition' || $rel eq 'repetition' ) { |
22222af9 |
883 | # Check that the two readings do (for a repetition) or do not (for |
884 | # a transposition) appear in the same witness. |
56772e8c |
885 | # TODO this might be called before witness paths are set... |
22222af9 |
886 | my %seen_wits; |
887 | map { $seen_wits{$_} = 1 } $c->reading_witnesses( $source ); |
888 | foreach my $w ( $c->reading_witnesses( $target ) ) { |
889 | if( $seen_wits{$w} ) { |
890 | return ( 0, "Readings both occur in witness $w" ) |
891 | if $rel eq 'transposition'; |
892 | return ( 1, "ok" ) if $rel eq 'repetition'; |
d6936dea |
893 | } |
22222af9 |
894 | } |
abadc997 |
895 | return ( 0, "Readings occur only in distinct witnesses" ) |
896 | if $rel eq 'repetition'; |
897 | } |
24efa55d |
898 | if ( $reltype->is_colocation ) { |
22222af9 |
899 | # Check that linking the source and target in a relationship won't lead |
414cc046 |
900 | # to a path loop for any witness. |
901 | # First, drop/stash any collations that might interfere |
902 | my $sourceobj = $c->reading( $source ); |
903 | my $targetobj = $c->reading( $target ); |
904 | my $sourcerank = $sourceobj->has_rank ? $sourceobj->rank : -1; |
905 | my $targetrank = $targetobj->has_rank ? $targetobj->rank : -1; |
906 | unless( $rel eq 'collated' || $sourcerank == $targetrank ) { |
24efa55d |
907 | push( @$mustdrop, $self->_drop_weak( $source ) ); |
908 | push( @$mustdrop, $self->_drop_weak( $target ) ); |
359944f7 |
909 | if( $c->end->has_rank ) { |
176badfe |
910 | foreach my $rk ( $sourcerank .. $targetrank ) { |
24efa55d |
911 | map { push( @$mustdrop, $self->_drop_weak( $_->id ) ) } |
414cc046 |
912 | $c->readings_at_rank( $rk ); |
913 | } |
914 | } |
a1615ee4 |
915 | } |
359944f7 |
916 | unless( $self->test_equivalence( $source, $target ) ) { |
24efa55d |
917 | $self->_restore_weak( @$mustdrop ); |
414cc046 |
918 | return( 0, "Relationship would create witness loop" ); |
a1615ee4 |
919 | } |
22222af9 |
920 | return ( 1, "ok" ); |
24efa55d |
921 | } else { |
922 | # We also need to check that the readings are not in the same place. |
923 | # That is, proposing to equate them should cause a witness loop. |
924 | if( $self->test_equivalence( $source, $target ) ) { |
925 | return ( 0, "Readings appear to be colocated" ); |
926 | } else { |
927 | return ( 1, "ok" ); |
928 | } |
22222af9 |
929 | } |
930 | } |
931 | |
24efa55d |
932 | sub _drop_weak { |
778251a6 |
933 | my( $self, $reading ) = @_; |
414cc046 |
934 | my @dropped; |
778251a6 |
935 | foreach my $n ( $self->graph->neighbors( $reading ) ) { |
24efa55d |
936 | my $nrel = $self->get_relationship( $reading, $n ); |
937 | if( $self->type( $nrel->type )->is_weak ) { |
938 | push( @dropped, [ $reading, $n, $nrel->type ] ); |
778251a6 |
939 | $self->del_relationship( $reading, $n ); |
24efa55d |
940 | #print STDERR "Dropped weak relationship $reading -> $n\n"; |
778251a6 |
941 | } |
942 | } |
414cc046 |
943 | return @dropped; |
944 | } |
945 | |
24efa55d |
946 | sub _restore_weak { |
414cc046 |
947 | my( $self, @vectors ) = @_; |
948 | foreach my $v ( @vectors ) { |
24efa55d |
949 | my $type = pop @$v; |
950 | eval { |
951 | $self->add_relationship( @$v, { 'type' => $type } ); |
952 | #print STDERR "Restored weak relationship @$v\n"; |
953 | }; # if it fails we don't care |
414cc046 |
954 | } |
778251a6 |
955 | } |
956 | |
f97ef19e |
957 | =head2 verify_or_delete( $reading1, $reading2 ) { |
958 | |
959 | Given the existing relationship at ( $reading1, $reading2 ), make sure it is |
960 | still valid. If it is not still valid, delete it. Use this only to check |
961 | non-colocated relationships! |
962 | |
963 | =cut |
964 | |
965 | sub verify_or_delete { |
966 | my( $self, @vector ) = @_; |
967 | my $rel = $self->get_relationship( @vector ); |
968 | throw( "You should not now be verifying colocated relationships!" ) |
969 | if $rel->colocated; |
970 | my( $ok, $reason ) = $self->relationship_valid( @vector, $rel->type ); |
971 | unless( $ok ) { |
972 | $self->del_relationship( @vector ); |
973 | } |
2dcb5d11 |
974 | return $ok; |
f97ef19e |
975 | } |
976 | |
977 | |
7f52eac8 |
978 | =head2 related_readings( $reading, $filter ) |
22222af9 |
979 | |
9e9b7540 |
980 | Returns a list of readings that are connected via direct relationship links |
981 | to $reading. If $filter is set to a subroutine ref, returns only those |
982 | related readings where $filter( $relationship ) returns a true value. |
22222af9 |
983 | |
984 | =cut |
985 | |
986 | sub related_readings { |
7f52eac8 |
987 | my( $self, $reading, $filter ) = @_; |
22222af9 |
988 | my $return_object; |
989 | if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) { |
990 | $reading = $reading->id; |
991 | $return_object = 1; |
992 | } |
c84275ff |
993 | my @answer; |
7f52eac8 |
994 | if( $filter ) { |
995 | # Backwards compat |
996 | if( $filter eq 'colocated' ) { |
997 | $filter = sub { $_[0]->colocated }; |
d002ccb7 |
998 | } elsif( !ref( $filter ) ) { |
999 | my $type = $filter; |
1000 | $filter = sub { $_[0]->type eq $type }; |
7f52eac8 |
1001 | } |
9e9b7540 |
1002 | @answer = grep { &$filter( $self->get_relationship( $reading, $_ ) ) } |
1003 | $self->graph->neighbors( $reading ); |
c84275ff |
1004 | } else { |
9e9b7540 |
1005 | @answer = $self->graph->neighbors( $reading ); |
22222af9 |
1006 | } |
1007 | if( $return_object ) { |
1008 | my $c = $self->collation; |
c84275ff |
1009 | return map { $c->reading( $_ ) } @answer; |
22222af9 |
1010 | } else { |
c84275ff |
1011 | return @answer; |
22222af9 |
1012 | } |
1013 | } |
1014 | |
9e9b7540 |
1015 | =head2 propagate_relationship( $rel ) |
1016 | |
1017 | Apply the transitivity and binding level rules to propagate the consequences of |
1018 | the specified relationship link, ensuring all consequent relationships exist. |
1019 | For now, we only propagate colocation links if we are passed a colocation, and |
1020 | we only propagate displacement links if we are given a displacement. |
1021 | |
1022 | Returns an array of tuples ( rdg1, rdg2, type ) for each new reading set. |
1023 | |
1024 | =cut |
1025 | |
1026 | sub propagate_relationship { |
1027 | my( $self, @rel ) = @_; |
1028 | ## Check that the vector is an arrayref |
1029 | my $rel = @rel > 1 ? \@rel : $rel[0]; |
1030 | ## Get the relationship info |
1031 | my $relobj = $self->get_relationship( $rel ); |
1032 | my $reltype = $self->type( $relobj->type ); |
1033 | return () unless $reltype->is_transitive; |
1034 | my @newly_set; |
1035 | |
1036 | my $colo = $reltype->is_colocation; |
1037 | my $bindlevel = $reltype->bindlevel; |
1038 | |
1039 | ## Find all readings that are linked via this relationship type |
1040 | my %thislevel = ( $rel->[0] => 1, $rel->[1] => 1 ); |
1041 | my $check = $rel; |
1042 | my $iter = 0; |
1043 | while( @$check ) { |
1044 | my $more = []; |
1045 | foreach my $r ( @$check ) { |
1046 | push( @$more, grep { !exists $thislevel{$_} |
1047 | && $self->get_relationship( $r, $_ ) |
1048 | && $self->get_relationship( $r, $_ )->type eq $relobj->type } |
1049 | $self->graph->neighbors( $r ) ); |
1050 | } |
1051 | map { $thislevel{$_} = 1 } @$more; |
1052 | $check = $more; |
1053 | } |
1054 | |
1055 | ## Make sure every reading of our relationship type is linked to every other |
1056 | my @samelevel = keys %thislevel; |
1057 | while( @samelevel ) { |
1058 | my $r = shift @samelevel; |
1059 | foreach my $nr ( @samelevel ) { |
1060 | my $existing = $self->get_relationship( $r, $nr ); |
52179f61 |
1061 | my $skip; |
9e9b7540 |
1062 | if( $existing ) { |
52179f61 |
1063 | my $extype = $self->type( $existing->type ); |
1064 | unless( $extype->is_weak ) { |
1065 | # Check that it's a matching type, or a type subsumed by our |
1066 | # bindlevel |
1067 | throw( "Conflicting existing relationship of type " |
1068 | . $existing->type . " at $r, $nr trying to propagate " |
1069 | . $relobj->type . " relationship at @$rel" ) |
1070 | unless $existing->type eq $relobj->type |
1071 | || $extype->bindlevel <= $reltype->bindlevel; |
1072 | $skip = 1; |
1073 | } |
1074 | } |
1075 | unless( $skip ) { |
9e9b7540 |
1076 | # Try to add a new relationship here |
1077 | try { |
1078 | my @new = $self->add_relationship( $r, $nr, { type => $relobj->type, |
1079 | annotation => "Propagated from relationship at @$rel" } ); |
1080 | push( @newly_set, @new ); |
1081 | } catch ( Text::Tradition::Error $e ) { |
1082 | throw( "Could not propagate " . $relobj->type . |
1083 | " relationship (original @$rel) at $r -- $nr: " . |
1084 | $e->message ); |
1085 | } |
1086 | } |
1087 | } |
1088 | |
1089 | ## Now for each sibling our set, look for its direct connections to |
1090 | ## transitive readings of a different bindlevel, and make sure that |
1091 | ## all siblings are related to those readings. |
1092 | my @other; |
1093 | foreach my $n ( $self->graph->neighbors( $r ) ) { |
1094 | my $crel = $self->get_relationship( $r, $n ); |
1095 | next unless $crel; |
1096 | my $crt = $self->type( $crel->type ); |
1097 | if( $crt->is_transitive && $crt->is_colocation == $colo ) { |
1098 | next if $crt->bindlevel == $reltype->bindlevel; |
1099 | my $nrel = $crt->bindlevel < $reltype->bindlevel |
1100 | ? $reltype->name : $crt->name; |
1101 | push( @other, [ $n, $nrel ] ); |
1102 | } |
1103 | } |
1104 | # The @other array now contains tuples of ( reading, type ) where the |
1105 | # reading is the non-sibling and the type is the type of relationship |
1106 | # that the siblings should have to the non-sibling. |
1107 | foreach ( @other ) { |
1108 | my( $nr, $nrtype ) = @$_; |
1109 | foreach my $sib ( keys %thislevel ) { |
1110 | next if $sib eq $r; |
52179f61 |
1111 | next if $sib eq $nr; # can happen if linked to $r by tightrel |
1112 | # but linked to a sib of $r by thisrel |
1113 | # e.g. when a rel has been part propagated |
9e9b7540 |
1114 | my $existing = $self->get_relationship( $sib, $nr ); |
52179f61 |
1115 | my $skip; |
9e9b7540 |
1116 | if( $existing ) { |
1117 | # Check that it's compatible. The existing relationship type |
52179f61 |
1118 | # should match or be subsumed by the looser of the two |
1119 | # relationships in play, whether the original relationship |
1120 | # being worked on or the relationship between $r and $or. |
1121 | my $extype = $self->type( $existing->type ); |
1122 | unless( $extype->is_weak ) { |
1123 | if( $nrtype ne $extype->name |
1124 | && $self->type( $nrtype )->bindlevel <= $extype->bindlevel ) { |
1125 | throw( "Conflicting existing relationship at $nr ( -> " |
1126 | . $self->get_relationship( $nr, $r )->type . " to $r) " |
1127 | . " -- $sib trying to propagate " . $relobj->type |
1128 | . " relationship at @$rel" ); |
1129 | } |
1130 | $skip = 1; |
9e9b7540 |
1131 | } |
52179f61 |
1132 | } |
1133 | unless( $skip ) { |
9e9b7540 |
1134 | # Try to add a new relationship here |
1135 | try { |
1136 | my @new = $self->add_relationship( $sib, $nr, { type => $nrtype, |
1137 | annotation => "Propagated from relationship at @$rel" } ); |
1138 | push( @newly_set, @new ); |
1139 | } catch ( Text::Tradition::Error $e ) { |
1140 | throw( "Could not propagate $nrtype relationship (original " . |
1141 | $relobj->type . " at @$rel) at $sib -- $nr: " . |
1142 | $e->message ); |
1143 | } |
1144 | } |
1145 | } |
1146 | } |
1147 | } |
1148 | |
1149 | return @newly_set; |
1150 | } |
1151 | |
52179f61 |
1152 | =head2 propagate_all_relationships |
1153 | |
1154 | Apply propagation logic retroactively to all relationships in the tradition. |
1155 | |
1156 | =cut |
1157 | |
1158 | sub propagate_all_relationships { |
1159 | my $self = shift; |
1160 | my @allrels = sort { $self->_propagate_rel_order( $a, $b ) } $self->relationships; |
1161 | foreach my $rel ( @allrels ) { |
1162 | my $relobj = $self->get_relationship( $rel ); |
1163 | if( $self->type( $relobj->type )->is_transitive ) { |
1164 | my @added = $self->propagate_relationship( $rel ); |
1165 | } |
1166 | } |
1167 | } |
1168 | |
1169 | # Helper sorting function for retroactive propagation order. |
1170 | sub _propagate_rel_order { |
1171 | my( $self, $a, $b ) = @_; |
1172 | my $aobj = $self->get_relationship( $a ); |
1173 | my $bobj = $self->get_relationship( $b ); |
1174 | my $at = $self->type( $aobj->type ); my $bt = $self->type( $bobj->type ); |
1175 | # Apply strong relationships before weak |
1176 | return -1 if $bt->is_weak && !$at->is_weak; |
1177 | return 1 if $at->is_weak && !$bt->is_weak; |
1178 | # Apply more tightly bound relationships first |
1179 | return $at->bindlevel <=> $bt->bindlevel; |
1180 | } |
1181 | |
1182 | |
22222af9 |
1183 | =head2 merge_readings( $kept, $deleted ); |
1184 | |
1185 | Makes a best-effort merge of the relationship links between the given readings, and |
1186 | stops tracking the to-be-deleted reading. |
1187 | |
1188 | =cut |
1189 | |
1190 | sub merge_readings { |
1191 | my( $self, $kept, $deleted, $combined ) = @_; |
1192 | foreach my $edge ( $self->graph->edges_at( $deleted ) ) { |
1193 | # Get the pair of kept / rel |
1194 | my @vector = ( $kept ); |
1195 | push( @vector, $edge->[0] eq $deleted ? $edge->[1] : $edge->[0] ); |
1196 | next if $vector[0] eq $vector[1]; # Don't add a self loop |
1197 | |
1198 | # If kept changes its text, drop the relationship. |
1199 | next if $combined; |
1200 | |
f222800e |
1201 | # If kept / rel already has a relationship, just keep the old |
3ae5e2ad |
1202 | my $rel = $self->get_relationship( @vector ); |
f222800e |
1203 | next if $rel; |
22222af9 |
1204 | |
1205 | # Otherwise, adopt the relationship that would be deleted. |
3ae5e2ad |
1206 | $rel = $self->get_relationship( @$edge ); |
1207 | $self->_set_relationship( $rel, @vector ); |
22222af9 |
1208 | } |
56772e8c |
1209 | $self->_make_equivalence( $deleted, $kept ); |
22222af9 |
1210 | } |
1211 | |
359944f7 |
1212 | ### Equivalence logic |
1213 | |
1214 | sub _remove_equivalence_node { |
1215 | my( $self, $node ) = @_; |
1216 | my $group = $self->equivalence( $node ); |
1217 | my $nodelist = $self->eqreadings( $group ); |
1218 | if( @$nodelist == 1 && $nodelist->[0] eq $node ) { |
3579c22b |
1219 | $self->equivalence_graph->delete_vertex( $group ); |
359944f7 |
1220 | $self->remove_eqreadings( $group ); |
3579c22b |
1221 | $self->remove_equivalence( $group ); |
359944f7 |
1222 | } elsif( @$nodelist == 1 ) { |
3579c22b |
1223 | throw( "DATA INCONSISTENCY in equivalence graph: " . $nodelist->[0] . |
1224 | " in group that should have only $node" ); |
359944f7 |
1225 | } else { |
10e4b1ac |
1226 | my @newlist = grep { $_ ne $node } @$nodelist; |
359944f7 |
1227 | $self->set_eqreadings( $group, \@newlist ); |
1228 | $self->remove_equivalence( $node ); |
1229 | } |
1230 | } |
1231 | |
1232 | =head2 add_equivalence_edge |
1233 | |
176badfe |
1234 | Add an edge in the equivalence graph corresponding to $source -> $target in the |
1235 | collation. Should only be called by Collation. |
359944f7 |
1236 | |
1237 | =cut |
1238 | |
1239 | sub add_equivalence_edge { |
1240 | my( $self, $source, $target ) = @_; |
1241 | my $seq = $self->equivalence( $source ); |
1242 | my $teq = $self->equivalence( $target ); |
359944f7 |
1243 | $self->equivalence_graph->add_edge( $seq, $teq ); |
1244 | } |
1245 | |
176badfe |
1246 | =head2 delete_equivalence_edge |
359944f7 |
1247 | |
176badfe |
1248 | Remove an edge in the equivalence graph corresponding to $source -> $target in the |
1249 | collation. Should only be called by Collation. |
359944f7 |
1250 | |
1251 | =cut |
1252 | |
1253 | sub delete_equivalence_edge { |
1254 | my( $self, $source, $target ) = @_; |
1255 | my $seq = $self->equivalence( $source ); |
1256 | my $teq = $self->equivalence( $target ); |
359944f7 |
1257 | $self->equivalence_graph->delete_edge( $seq, $teq ); |
1258 | } |
1259 | |
1260 | sub _is_disconnected { |
1261 | my $self = shift; |
1262 | return( scalar $self->equivalence_graph->predecessorless_vertices > 1 |
1263 | || scalar $self->equivalence_graph->successorless_vertices > 1 ); |
1264 | } |
1265 | |
176badfe |
1266 | # Equate two readings in the equivalence graph |
1267 | sub _make_equivalence { |
56772e8c |
1268 | my( $self, $source, $target ) = @_; |
359944f7 |
1269 | # Get the source equivalent readings |
1270 | my $seq = $self->equivalence( $source ); |
1271 | my $teq = $self->equivalence( $target ); |
1272 | # Nothing to do if they are already equivalent... |
1273 | return if $seq eq $teq; |
56772e8c |
1274 | my $sourcepool = $self->eqreadings( $seq ); |
359944f7 |
1275 | # and add them to the target readings. |
56772e8c |
1276 | push( @{$self->eqreadings( $teq )}, @$sourcepool ); |
1277 | map { $self->set_equivalence( $_, $teq ) } @$sourcepool; |
359944f7 |
1278 | # Then merge the nodes in the equivalence graph. |
1279 | foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) { |
56772e8c |
1280 | $self->equivalence_graph->add_edge( $pred, $teq ); |
359944f7 |
1281 | } |
1282 | foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) { |
56772e8c |
1283 | $self->equivalence_graph->add_edge( $teq, $succ ); |
359944f7 |
1284 | } |
1285 | $self->equivalence_graph->delete_vertex( $seq ); |
176badfe |
1286 | # TODO enable this after collation parsing is done |
10943ab0 |
1287 | throw( "Graph got disconnected making $source / $target equivalence" ) |
3579c22b |
1288 | if $self->_is_disconnected && $self->collation->tradition->_initialized; |
359944f7 |
1289 | } |
1290 | |
1291 | =head2 test_equivalence |
1292 | |
176badfe |
1293 | Test whether, if two readings were equated with a 'colocated' relationship, |
1294 | the graph would still be valid. |
359944f7 |
1295 | |
1296 | =cut |
1297 | |
f97ef19e |
1298 | # TODO Used the 'is_reachable' method; it killed performance. Think about doing away |
1299 | # with the equivalence graph in favor of a transitive closure graph (calculated ONCE) |
1300 | # on the sequence graph, and test that way. |
1301 | |
359944f7 |
1302 | sub test_equivalence { |
1303 | my( $self, $source, $target ) = @_; |
1304 | # Try merging the nodes in the equivalence graph; return a true value if |
1305 | # no cycle is introduced thereby. Restore the original graph first. |
1306 | |
1307 | # Keep track of edges we add |
1308 | my %added_pred; |
1309 | my %added_succ; |
1310 | # Get the reading equivalents |
1311 | my $seq = $self->equivalence( $source ); |
1312 | my $teq = $self->equivalence( $target ); |
1313 | # Maybe this is easy? |
1314 | return 1 if $seq eq $teq; |
1315 | |
1316 | # Save the first graph |
1317 | my $checkstr = $self->equivalence_graph->stringify(); |
1318 | # Add and save relevant edges |
1319 | foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) { |
1320 | if( $self->equivalence_graph->has_edge( $pred, $teq ) ) { |
1321 | $added_pred{$pred} = 0; |
1322 | } else { |
1323 | $self->equivalence_graph->add_edge( $pred, $teq ); |
1324 | $added_pred{$pred} = 1; |
1325 | } |
1326 | } |
1327 | foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) { |
1328 | if( $self->equivalence_graph->has_edge( $teq, $succ ) ) { |
1329 | $added_succ{$succ} = 0; |
1330 | } else { |
1331 | $self->equivalence_graph->add_edge( $teq, $succ ); |
1332 | $added_succ{$succ} = 1; |
1333 | } |
1334 | } |
1335 | # Delete source equivalent and test |
1336 | $self->equivalence_graph->delete_vertex( $seq ); |
1337 | my $ret = !$self->equivalence_graph->has_a_cycle; |
1338 | |
1339 | # Restore what we changed |
1340 | $self->equivalence_graph->add_vertex( $seq ); |
1341 | foreach my $pred ( keys %added_pred ) { |
1342 | $self->equivalence_graph->add_edge( $pred, $seq ); |
1343 | $self->equivalence_graph->delete_edge( $pred, $teq ) if $added_pred{$pred}; |
1344 | } |
1345 | foreach my $succ ( keys %added_succ ) { |
1346 | $self->equivalence_graph->add_edge( $seq, $succ ); |
1347 | $self->equivalence_graph->delete_edge( $teq, $succ ) if $added_succ{$succ}; |
1348 | } |
1349 | unless( $self->equivalence_graph->eq( $checkstr ) ) { |
c7bd2768 |
1350 | throw( "GRAPH CHANGED after testing" ); |
359944f7 |
1351 | } |
1352 | # Return our answer |
1353 | return $ret; |
1354 | } |
1355 | |
176badfe |
1356 | # Unmake an equivalence link between two readings. Should only be called internally. |
1357 | sub _break_equivalence { |
359944f7 |
1358 | my( $self, $source, $target ) = @_; |
1359 | |
1360 | # This is the hard one. Need to reconstruct the equivalence groups without |
1361 | # the given link. |
1362 | my( %sng, %tng ); |
1363 | map { $sng{$_} = 1 } $self->_find_equiv_without( $source, $target ); |
1364 | map { $tng{$_} = 1 } $self->_find_equiv_without( $target, $source ); |
1365 | # If these groups intersect, they are still connected; do nothing. |
1366 | foreach my $el ( keys %tng ) { |
10e4b1ac |
1367 | return if( exists $sng{$el} ); |
359944f7 |
1368 | } |
359944f7 |
1369 | # If they don't intersect, then we split the nodes in the graph and in |
1370 | # the hashes. First figure out which group has which name |
176badfe |
1371 | my $oldgroup = $self->equivalence( $source ); # same as $target |
1372 | my $keepsource = $sng{$oldgroup}; |
1373 | my $newgroup = $keepsource ? $target : $source; |
359944f7 |
1374 | my( $oldmembers, $newmembers ); |
176badfe |
1375 | if( $keepsource ) { |
359944f7 |
1376 | $oldmembers = [ keys %sng ]; |
1377 | $newmembers = [ keys %tng ]; |
1378 | } else { |
1379 | $oldmembers = [ keys %tng ]; |
1380 | $newmembers = [ keys %sng ]; |
1381 | } |
1382 | |
1383 | # First alter the old group in the hash |
1384 | $self->set_eqreadings( $oldgroup, $oldmembers ); |
176badfe |
1385 | foreach my $el ( @$oldmembers ) { |
1386 | $self->set_equivalence( $el, $oldgroup ); |
1387 | } |
359944f7 |
1388 | |
1389 | # then add the new group back to the hash with its new key |
1390 | $self->set_eqreadings( $newgroup, $newmembers ); |
1391 | foreach my $el ( @$newmembers ) { |
1392 | $self->set_equivalence( $el, $newgroup ); |
1393 | } |
1394 | |
1395 | # Now add the new group back to the equivalence graph |
1396 | $self->equivalence_graph->add_vertex( $newgroup ); |
1397 | # ...add the appropriate edges to the source group vertext |
1398 | my $c = $self->collation; |
1399 | foreach my $rdg ( @$newmembers ) { |
1400 | foreach my $rp ( $c->sequence->predecessors( $rdg ) ) { |
beb47b16 |
1401 | next unless $self->equivalence( $rp ); |
359944f7 |
1402 | $self->equivalence_graph->add_edge( $self->equivalence( $rp ), $newgroup ); |
1403 | } |
1404 | foreach my $rs ( $c->sequence->successors( $rdg ) ) { |
beb47b16 |
1405 | next unless $self->equivalence( $rs ); |
359944f7 |
1406 | $self->equivalence_graph->add_edge( $newgroup, $self->equivalence( $rs ) ); |
1407 | } |
1408 | } |
1409 | |
1410 | # ...and figure out which edges on the old group vertex to delete. |
1411 | my( %old_pred, %old_succ ); |
1412 | foreach my $rdg ( @$oldmembers ) { |
1413 | foreach my $rp ( $c->sequence->predecessors( $rdg ) ) { |
beb47b16 |
1414 | next unless $self->equivalence( $rp ); |
359944f7 |
1415 | $old_pred{$self->equivalence( $rp )} = 1; |
1416 | } |
1417 | foreach my $rs ( $c->sequence->successors( $rdg ) ) { |
beb47b16 |
1418 | next unless $self->equivalence( $rs ); |
359944f7 |
1419 | $old_succ{$self->equivalence( $rs )} = 1; |
1420 | } |
1421 | } |
1422 | foreach my $p ( $self->equivalence_graph->predecessors( $oldgroup ) ) { |
1423 | unless( $old_pred{$p} ) { |
1424 | $self->equivalence_graph->delete_edge( $p, $oldgroup ); |
1425 | } |
1426 | } |
1427 | foreach my $s ( $self->equivalence_graph->successors( $oldgroup ) ) { |
1428 | unless( $old_succ{$s} ) { |
1429 | $self->equivalence_graph->delete_edge( $oldgroup, $s ); |
1430 | } |
1431 | } |
176badfe |
1432 | # TODO enable this after collation parsing is done |
10943ab0 |
1433 | throw( "Graph got disconnected breaking $source / $target equivalence" ) |
3579c22b |
1434 | if $self->_is_disconnected && $self->collation->tradition->_initialized; |
359944f7 |
1435 | } |
1436 | |
1437 | sub _find_equiv_without { |
1438 | my( $self, $first, $second ) = @_; |
1439 | my %found = ( $first => 1 ); |
1440 | my $check = [ $first ]; |
1441 | my $iter = 0; |
1442 | while( @$check ) { |
1443 | my $more = []; |
1444 | foreach my $r ( @$check ) { |
1445 | foreach my $nr ( $self->graph->neighbors( $r ) ) { |
1446 | next if $r eq $second; |
1447 | if( $self->get_relationship( $r, $nr )->colocated ) { |
1448 | push( @$more, $nr ) unless exists $found{$nr}; |
1449 | $found{$nr} = 1; |
1450 | } |
1451 | } |
1452 | } |
1453 | $check = $more; |
1454 | } |
1455 | return keys %found; |
1456 | } |
1457 | |
e1083e99 |
1458 | =head2 rebuild_equivalence |
1459 | |
1460 | (Re)build the equivalence graph from scratch. Dumps the graph, makes a new one, |
1461 | adds all readings and edges, then makes an equivalence for all relationships. |
1462 | |
1463 | =cut |
1464 | |
1465 | sub rebuild_equivalence { |
1466 | my $self = shift; |
1467 | my $newgraph = Graph->new(); |
04482188 |
1468 | # Set this as the new equivalence graph |
1469 | $self->_reset_equivalence( $newgraph ); |
1470 | # Clear out the data hashes |
1471 | $self->_clear_equivalence; |
1472 | $self->_clear_eqreadings; |
1473 | |
b6f13859 |
1474 | $self->collation->tradition->_init_done(0); |
04482188 |
1475 | # Add the readings |
e1083e99 |
1476 | foreach my $r ( $self->collation->readings ) { |
04482188 |
1477 | my $rid = $r->id; |
1478 | $newgraph->add_vertex( $rid ); |
1479 | $self->set_equivalence( $rid, $rid ); |
1480 | $self->set_eqreadings( $rid, [ $rid ] ); |
e1083e99 |
1481 | } |
04482188 |
1482 | |
1483 | # Now add the edges |
e1083e99 |
1484 | foreach my $e ( $self->collation->paths ) { |
04482188 |
1485 | $self->add_equivalence_edge( @$e ); |
e1083e99 |
1486 | } |
04482188 |
1487 | |
1488 | # Now equate the colocated readings. This does no testing; |
1489 | # it assumes that all preexisting relationships are valid. |
e1083e99 |
1490 | foreach my $rel ( $self->relationships ) { |
1491 | my $relobj = $self->get_relationship( $rel ); |
1492 | next unless $relobj && $relobj->colocated; |
1493 | $self->_make_equivalence( @$rel ); |
1494 | } |
b6f13859 |
1495 | $self->collation->tradition->_init_done(1); |
e1083e99 |
1496 | } |
1497 | |
56772e8c |
1498 | =head2 equivalence_ranks |
1499 | |
1500 | Rank all vertices in the equivalence graph, and return a hash reference with |
1501 | vertex => rank mapping. |
1502 | |
1503 | =cut |
1504 | |
1505 | sub equivalence_ranks { |
1506 | my $self = shift; |
1507 | my $eqstart = $self->equivalence( $self->collation->start ); |
1508 | my $eqranks = { $eqstart => 0 }; |
1509 | my $rankeqs = { 0 => [ $eqstart ] }; |
1510 | my @curr_origin = ( $eqstart ); |
1511 | # A little iterative function. |
1512 | while( @curr_origin ) { |
1513 | @curr_origin = $self->_assign_rank( $eqranks, $rankeqs, @curr_origin ); |
1514 | } |
1515 | return( $eqranks, $rankeqs ); |
1516 | } |
1517 | |
1518 | sub _assign_rank { |
1519 | my( $self, $node_ranks, $rank_nodes, @current_nodes ) = @_; |
1520 | my $graph = $self->equivalence_graph; |
1521 | # Look at each of the children of @current_nodes. If all the child's |
1522 | # parents have a rank, assign it the highest rank + 1 and add it to |
1523 | # @next_nodes. Otherwise skip it; we will return when the highest-ranked |
1524 | # parent gets a rank. |
1525 | my @next_nodes; |
1526 | foreach my $c ( @current_nodes ) { |
1527 | warn "Current reading $c has no rank!" |
1528 | unless exists $node_ranks->{$c}; |
1529 | foreach my $child ( $graph->successors( $c ) ) { |
1530 | next if exists $node_ranks->{$child}; |
1531 | my $highest_rank = -1; |
1532 | my $skip = 0; |
1533 | foreach my $parent ( $graph->predecessors( $child ) ) { |
1534 | if( exists $node_ranks->{$parent} ) { |
1535 | $highest_rank = $node_ranks->{$parent} |
1536 | if $highest_rank <= $node_ranks->{$parent}; |
1537 | } else { |
1538 | $skip = 1; |
1539 | last; |
1540 | } |
1541 | } |
1542 | next if $skip; |
1543 | my $c_rank = $highest_rank + 1; |
1544 | # print STDERR "Assigning rank $c_rank to node $child \n"; |
1545 | $node_ranks->{$child} = $c_rank if $node_ranks; |
1546 | push( @{$rank_nodes->{$c_rank}}, $child ) if $rank_nodes; |
1547 | push( @next_nodes, $child ); |
1548 | } |
1549 | } |
1550 | return @next_nodes; |
1551 | } |
1552 | |
359944f7 |
1553 | ### Output logic |
1554 | |
027d819c |
1555 | sub _as_graphml { |
2626f709 |
1556 | my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_; |
c84275ff |
1557 | |
1558 | my $rgraph = $xmlroot->addNewChild( $graphml_ns, 'graph' ); |
1559 | $rgraph->setAttribute( 'edgedefault', 'directed' ); |
1560 | $rgraph->setAttribute( 'id', 'relationships', ); |
1561 | $rgraph->setAttribute( 'parse.edgeids', 'canonical' ); |
cc31ebaa |
1562 | $rgraph->setAttribute( 'parse.edges', 0 ); |
c84275ff |
1563 | $rgraph->setAttribute( 'parse.nodeids', 'canonical' ); |
cc31ebaa |
1564 | $rgraph->setAttribute( 'parse.nodes', 0 ); |
c84275ff |
1565 | $rgraph->setAttribute( 'parse.order', 'nodesfirst' ); |
1566 | |
1567 | # Add the vertices according to their XML IDs |
2626f709 |
1568 | my %rdg_lookup = ( reverse %$node_hash ); |
cc31ebaa |
1569 | # my @nlist = sort _by_xmlid keys( %rdg_lookup ); ## CAUSES SEGFAULT |
826d8773 |
1570 | my @nlist = sort keys( %rdg_lookup ); |
414cc046 |
1571 | foreach my $n ( @nlist ) { |
c84275ff |
1572 | my $n_el = $rgraph->addNewChild( $graphml_ns, 'node' ); |
1573 | $n_el->setAttribute( 'id', $n ); |
2626f709 |
1574 | _add_graphml_data( $n_el, $nodeid_key, $rdg_lookup{$n} ); |
c84275ff |
1575 | } |
cc31ebaa |
1576 | $rgraph->setAttribute( 'parse.nodes', scalar @nlist ); |
c84275ff |
1577 | |
1578 | # Add the relationship edges, with their object information |
1579 | my $edge_ctr = 0; |
1580 | foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->graph->edges ) { |
1581 | # Add an edge and fill in its relationship info. |
a30ca502 |
1582 | next unless( exists $node_hash->{$e->[0]} && exists $node_hash->{$e->[1]} ); |
c84275ff |
1583 | my $edge_el = $rgraph->addNewChild( $graphml_ns, 'edge' ); |
1584 | $edge_el->setAttribute( 'source', $node_hash->{$e->[0]} ); |
1585 | $edge_el->setAttribute( 'target', $node_hash->{$e->[1]} ); |
1586 | $edge_el->setAttribute( 'id', 'e'.$edge_ctr++ ); |
1587 | |
3ae5e2ad |
1588 | my $rel_obj = $self->get_relationship( @$e ); |
bbd064a9 |
1589 | foreach my $key ( keys %$edge_keys ) { |
1590 | my $value = $rel_obj->$key; |
1591 | _add_graphml_data( $edge_el, $edge_keys->{$key}, $value ) |
1592 | if defined $value; |
1593 | } |
c84275ff |
1594 | } |
cc31ebaa |
1595 | $rgraph->setAttribute( 'parse.edges', $edge_ctr ); |
c84275ff |
1596 | } |
1597 | |
1598 | sub _by_xmlid { |
2626f709 |
1599 | my $tmp_a = $a; |
1600 | my $tmp_b = $b; |
1601 | $tmp_a =~ s/\D//g; |
1602 | $tmp_b =~ s/\D//g; |
1603 | return $tmp_a <=> $tmp_b; |
c84275ff |
1604 | } |
1605 | |
1606 | sub _add_graphml_data { |
1607 | my( $el, $key, $value ) = @_; |
1608 | return unless defined $value; |
1609 | my $data_el = $el->addNewChild( $el->namespaceURI, 'data' ); |
1610 | $data_el->setAttribute( 'key', $key ); |
1611 | $data_el->appendText( $value ); |
83d5ac3a |
1612 | } |
1613 | |
c7bd2768 |
1614 | sub dump_segment { |
1615 | my( $self, $from, $to ) = @_; |
1616 | open( DUMP, ">debug.svg" ) or die "Could not open debug.svg"; |
1617 | binmode DUMP, ':utf8'; |
1618 | print DUMP $self->collation->as_svg({ from => $from, to => $to, nocalc => 1 }); |
1619 | close DUMP; |
1620 | } |
1621 | |
63778331 |
1622 | sub throw { |
1623 | Text::Tradition::Error->throw( |
1624 | 'ident' => 'Relationship error', |
1625 | 'message' => $_[0], |
1626 | ); |
1627 | } |
1628 | |
22222af9 |
1629 | no Moose; |
1630 | __PACKAGE__->meta->make_immutable; |
1631 | |
1632 | 1; |