4 use Test::More 'no_plan';
14 use_ok( 'Text::Tradition::Collation::RelationshipStore' );
16 # Add some relationships, and delete them
18 my $cxfile = 't/data/Collatex-16.xml';
19 my $t = Text::Tradition->new(
21 'input' => 'CollateX',
24 my $c = $t->collation;
26 my @v1 = $c->add_relationship( 'n21', 'n22', { 'type' => 'lexical' } );
27 is( scalar @v1, 1, "Added a single relationship" );
28 is( $v1[0]->[0], 'n21', "Got correct node 1" );
29 is( $v1[0]->[1], 'n22', "Got correct node 2" );
30 my @v2 = $c->add_relationship( 'n24', 'n23',
31 { 'type' => 'spelling', 'scope' => 'global' } );
32 is( scalar @v2, 2, "Added a global relationship with two instances" );
33 @v1 = $c->del_relationship( 'n22', 'n21' );
34 is( scalar @v1, 1, "Deleted first relationship" );
35 @v2 = $c->del_relationship( 'n12', 'n13', 1 );
36 is( scalar @v2, 2, "Deleted second global relationship" );
37 my @v3 = $c->del_relationship( 'n1', 'n2' );
38 is( scalar @v3, 0, "Nothing deleted on non-existent relationship" );
39 my @v4 = $c->add_relationship( 'n24', 'n23',
40 { 'type' => 'spelling', 'scope' => 'global' } );
41 is( @v4, 2, "Re-added global relationship" );
42 @v4 = $c->del_relationship( 'n12', 'n13' );
43 is( @v4, 1, "Only specified relationship deleted this time" );
44 ok( $c->get_relationship( 'n24', 'n23' ), "Other globally-added relationship exists" );
57 $t1 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/legendfrag.xml' );
58 } [qr/Cannot set relationship on a meta reading/],
59 "Got expected relationship drop warning on parse";
61 # Test 1.1: try to equate nodes that are prevented with an intermediate collation
62 ok( $t1, "Parsed test fragment file" );
63 my $c1 = $t1->collation;
64 my $trel = $c1->get_relationship( 'r9.2', 'r9.3' );
65 is( ref( $trel ), 'Text::Tradition::Collation::Relationship',
66 "Troublesome relationship exists" );
67 is( $trel->type, 'collated', "Troublesome relationship is a collation" );
69 # Try to make the link we want
71 $c1->add_relationship( 'r8.6', 'r10.3', { 'type' => 'orthographic' } );
72 ok( 1, "Added cross-collation relationship as expected" );
73 } catch( Text::Tradition::Error $e ) {
74 ok( 0, "Existing collation blocked equivalence relationship: " . $e->message );
78 $c1->calculate_ranks();
79 ok( 1, "Successfully calculated ranks" );
80 } catch ( Text::Tradition::Error $e ) {
81 ok( 0, "Collation now has a cycle: " . $e->message );
84 # Test 1.2: attempt merge of an identical reading
86 $c1->merge_readings( 'r9.3', 'r11.5' );
87 ok( 1, "Successfully merged reading 'pontifex'" );
88 } catch ( Text::Tradition::Error $e ) {
89 ok( 0, "Merge of mergeable readings failed: $e->message" );
93 # Test 1.3: attempt relationship with a meta reading (should fail)
95 $c1->add_relationship( 'r8.1', 'r9.2', { 'type' => 'collated' } );
96 ok( 0, "Allowed a meta-reading to be used in a relationship" );
97 } catch ( Text::Tradition::Error $e ) {
98 is( $e->message, 'Cannot set relationship on a meta reading',
99 "Relationship link prevented for a meta reading" );
102 # Test 1.4: try to break a relationship near a meta reading
103 $c1->add_relationship( 'r7.6', 'r7.3', { type => 'orthographic' } );
105 $c1->del_relationship( 'r7.6', 'r7.7' );
106 $c1->del_relationship( 'r7.6', 'r7.3' );
107 ok( 1, "Relationship broken with a meta reading as neighbor" );
109 ok( 0, "Relationship deletion failed with a meta reading as neighbor" );
112 # Test 2.1: try to equate nodes that are prevented with a real intermediate
116 $t2 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/legendfrag.xml' );
117 } [qr/Cannot set relationship on a meta reading/],
118 "Got expected relationship drop warning on parse";
119 my $c2 = $t2->collation;
120 $c2->add_relationship( 'r9.2', 'r9.3', { 'type' => 'lexical' } );
121 my $trel2 = $c2->get_relationship( 'r9.2', 'r9.3' );
122 is( ref( $trel2 ), 'Text::Tradition::Collation::Relationship',
123 "Created blocking relationship" );
124 is( $trel2->type, 'lexical', "Blocking relationship is not a collation" );
125 # This time the link ought to fail
127 $c2->add_relationship( 'r8.6', 'r10.3', { 'type' => 'orthographic' } );
128 ok( 0, "Added cross-equivalent bad relationship" );
129 } catch ( Text::Tradition::Error $e ) {
130 like( $e->message, qr/witness loop/,
131 "Existing equivalence blocked crossing relationship" );
135 $c2->calculate_ranks();
136 ok( 1, "Successfully calculated ranks" );
137 } catch ( Text::Tradition::Error $e ) {
138 ok( 0, "Collation now has a cycle: " . $e->message );
141 # Test 3.1: make a straightforward pair of transpositions.
142 my $t3 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/lf2.xml' );
143 # Test 1: try to equate nodes that are prevented with an intermediate collation
144 my $c3 = $t3->collation;
146 $c3->add_relationship( 'r36.4', 'r38.3', { 'type' => 'transposition' } );
147 ok( 1, "Added straightforward transposition" );
148 } catch ( Text::Tradition::Error $e ) {
149 ok( 0, "Failed to add normal transposition: " . $e->message );
152 $c3->add_relationship( 'r36.3', 'r38.2', { 'type' => 'transposition' } );
153 ok( 1, "Added straightforward transposition complement" );
154 } catch ( Text::Tradition::Error $e ) {
155 ok( 0, "Failed to add normal transposition complement: " . $e->message );
158 # Test 3.2: try to make a transposition that could be a parallel.
160 $c3->add_relationship( 'r28.2', 'r29.2', { 'type' => 'transposition' } );
161 ok( 0, "Added bad colocated transposition" );
162 } catch ( Text::Tradition::Error $e ) {
163 like( $e->message, qr/Readings appear to be colocated/,
164 "Prevented bad colocated transposition" );
167 # Test 3.3: make the parallel, and then make the transposition again.
169 $c3->add_relationship( 'r28.3', 'r29.3', { 'type' => 'orthographic' } );
170 ok( 1, "Equated identical readings for transposition" );
171 } catch ( Text::Tradition::Error $e ) {
172 ok( 0, "Failed to equate identical readings: " . $e->message );
175 $c3->add_relationship( 'r28.2', 'r29.2', { 'type' => 'transposition' } );
176 ok( 1, "Added straightforward transposition complement" );
177 } catch ( Text::Tradition::Error $e ) {
178 ok( 0, "Failed to add normal transposition complement: " . $e->message );
181 # Test 4: make a global relationship that involves re-ranking a node first, when
182 # the prior rank has a potential match too
183 my $t4 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/globalrel_test.xml' );
184 my $c4 = $t4->collation;
185 # Can we even add the relationship?
187 $c4->add_relationship( 'r463.2', 'r463.4',
188 { type => 'orthographic', scope => 'global' } );
189 ok( 1, "Added global relationship without error" );
190 } catch ( Text::Tradition::Error $e ) {
191 ok( 0, "Failed to add global relationship when same-rank alternative exists: "
194 $c4->calculate_ranks();
195 # Do our readings now share a rank?
196 is( $c4->reading('r463.2')->rank, $c4->reading('r463.4')->rank,
197 "Expected readings now at same rank" );
199 # Test group 5: relationship transitivity.
200 my $t5 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/john.xml' );
201 my $c5 = $t5->collation;
202 # Test 5.0: propagate all existing transitive rels and make sure it succeeds
203 my $orignumrels = scalar $c5->relationships();
205 $c5->relations->propagate_all_relationships();
206 ok( 1, "Propagated all existing transitive relationships" );
207 } catch ( Text::Tradition::Error $err ) {
208 ok( 0, "Failed to propagate all existing relationships: " . $err->message );
210 ok( scalar( $c5->relationships ) > $orignumrels, "Added some relationships in propagation" );
212 # Test 5.1: make a grammatical link to an orthographically-linked reading
213 $c5->add_relationship( 'r13.5', 'r13.2', { type => 'orthographic' } );
214 $c5->add_relationship( 'r13.1', 'r13.2', { type => 'grammatical', propagate => 1 } );
215 my $impliedrel = $c5->get_relationship( 'r13.1', 'r13.5' );
216 ok( $impliedrel, 'Relationship was made between indirectly linked readings' );
218 is( $impliedrel->type, 'grammatical', 'Implicit inbound relationship has the correct type' );
221 # Test 5.2: make another orthographic link, see if the grammatical one propagates
222 $c5->add_relationship( 'r13.3', 'r13.5', { type => 'orthographic', propagate => 1 } );
223 foreach my $rdg ( qw/ r13.3 r13.5 / ) {
224 my $newgram = $c5->get_relationship( 'r13.1', $rdg );
225 ok( $newgram, 'Relationship was propagaged up between indirectly linked readings' );
227 is( $newgram->type, 'grammatical', 'Implicit outbound relationship has the correct type' );
230 my $neworth = $c5->get_relationship( 'r13.2', 'r13.3' );
231 ok( $neworth, 'Relationship was made between indirectly linked siblings' );
233 is( $neworth->type, 'orthographic', 'Implicit direct relationship has the correct type' );
236 # Test 5.3: make an intermediate (spelling) link to the remaining node
237 $c5->add_relationship( 'r13.4', 'r13.2', { type => 'spelling', propagate => 1 } );
238 # Should be linked grammatically to 12.1, spelling-wise to the rest
239 my $newgram = $c5->get_relationship( 'r13.4', 'r13.1' );
240 ok( $newgram, 'Relationship was made between indirectly linked readings' );
242 is( $newgram->type, 'grammatical', 'Implicit intermediate-out relationship has the correct type' );
244 foreach my $rdg ( qw/ r13.3 r13.5 / ) {
245 my $newspel = $c5->get_relationship( 'r13.4', $rdg );
246 ok( $newspel, 'Relationship was made between indirectly linked readings' );
248 is( $newspel->type, 'spelling', 'Implicit intermediate-in relationship has the correct type' );
252 # Test 5.4: delete a spelling relationship, add it again, make sure it doesn't
253 # throw and make sure all the relationships are the same
254 my $numrel = scalar $c5->relationships;
255 $c5->del_relationship( 'r13.4', 'r13.2' );
257 $c5->add_relationship( 'r13.4', 'r13.2', { type => 'spelling', propagate => 1 } );
258 ok( 1, "Managed not to throw an exception re-adding the relationship" );
259 } catch( Text::Tradition::Error $e ) {
260 ok( 0, "Threw an exception trying to re-add our intermediate relationship: " . $e->message );
262 is( $numrel, scalar $c5->relationships, "Number of relationships did not change" );
263 foreach my $rdg ( qw/ r13.2 r13.3 r13.5 / ) {
264 my $newspel = $c5->get_relationship( 'r13.4', $rdg );
265 ok( $newspel, 'Relationship was made between indirectly linked readings' );
267 is( $newspel->type, 'spelling', 'Reinstated intermediate-in relationship has the correct type' );
270 my $stillgram = $c5->get_relationship( 'r13.4', 'r13.1' );
271 ok( $stillgram, 'Relationship was made between indirectly linked readings' );
273 is( $stillgram->type, 'grammatical', 'Reinstated intermediate-out relationship has the correct type' );
276 # Test 5.5: add a parallel but not sibling relationship
277 $c5->add_relationship( 'r13.6', 'r13.2', { type => 'lexical', propagate => 1 } );
278 ok( !$c5->get_relationship( 'r13.6', 'r13.1' ),
279 "Lexical relationship did not affect grammatical" );
280 foreach my $rdg ( qw/ r13.3 r13.4 r13.5 / ) {
281 my $newlex = $c5->get_relationship( 'r13.6', $rdg );
282 ok( $newlex, 'Parallel was made between indirectly linked readings' );
284 is( $newlex->type, 'lexical', 'Implicit parallel-down relationship has the correct type' );
288 # Test 5.6: try it with non-colocated relationships
289 $numrel = scalar $c5->relationships;
290 $c5->add_relationship( 'r62.1', 'r64.1', { type => 'transposition', propagate => 1 } );
291 is( scalar $c5->relationships, $numrel+1,
292 "Adding non-colo relationship did not propagate" );
294 $c5->add_relationship( 'r61.1', 'r61.5', { type => 'orthographic' } );
295 # Add a third transposed node
296 $c5->add_relationship( 'r62.1', 'r60.3', { type => 'transposition', propagate => 1 } );
297 my $newtrans = $c5->get_relationship( 'r64.1', 'r60.3' );
298 ok( $newtrans, 'Non-colo relationship was made between indirectly linked readings' );
300 is( $newtrans->type, 'transposition', 'Implicit non-colo relationship has the correct type' );
302 is( scalar $c5->relationships, $numrel+4,
303 "Adding non-colo relationship only propagated on non-colos" );
305 # Test 5.7: ensure that attempts to cross boundaries on bindlevel-equal
306 # relationships fail.
308 $c5->add_relationship( 'r39.6', 'r41.1', { type => 'grammatical', propagate => 1 } );
309 ok( 0, "Did not prevent add of conflicting relationship level" );
310 } catch( Text::Tradition::Error $err ) {
311 like( $err->message, qr/Conflicting existing relationship/, "Got correct error message trying to add conflicting relationship level" );
314 # Test 5.8: ensure that weak relationships don't interfere
315 $c5->add_relationship( 'r50.1', 'r50.2', { type => 'collated' } );
316 $c5->add_relationship( 'r50.3', 'r50.4', { type => 'orthographic' } );
318 $c5->add_relationship( 'r50.4', 'r50.1', { type => 'grammatical', propagate => 1 } );
319 ok( 1, "Collation did not interfere with new relationship add" );
320 } catch( Text::Tradition::Error $err ) {
321 ok( 0, "Collation interfered with new relationship add: " . $err->message );
323 my $crel = $c5->get_relationship( 'r50.1', 'r50.2' );
324 ok( $crel, "Original relationship still exists" );
326 is( $crel->type, 'collated', "Original relationship still a collation" );
330 $c5->add_relationship( 'r50.1', 'r51.1', { type => 'spelling', propagate => 1 } );
331 ok( 1, "Collation did not interfere with relationship re-ranking" );
332 } catch( Text::Tradition::Error $err ) {
333 ok( 0, "Collation interfered with relationship re-ranking: " . $err->message );
335 $crel = $c5->get_relationship( 'r50.1', 'r50.2' );
336 ok( !$crel, "Collation relationship now gone" );
338 # Test 5.9: ensure that strong non-transitive relationships don't interfere
339 $c5->add_relationship( 'r66.1', 'r66.4', { type => 'grammatical' } );
340 $c5->add_relationship( 'r66.2', 'r66.4', { type => 'uncertain', propagate => 1 } );
342 $c5->add_relationship( 'r66.1', 'r66.3', { type => 'grammatical', propagate => 1 } );
343 ok( 1, "Non-transitive relationship did not block grammatical add" );
344 } catch( Text::Tradition::Error $err ) {
345 ok( 0, "Non-transitive relationship blocked grammatical add: " . $err->message );
347 is( scalar $c5->related_readings( 'r66.4' ), 3, "Reading 66.4 has all its links" );
348 is( scalar $c5->related_readings( 'r66.2' ), 1, "Reading 66.2 has only one link" );
349 is( scalar $c5->related_readings( 'r66.1' ), 2, "Reading 66.1 has all its links" );
350 is( scalar $c5->related_readings( 'r66.3' ), 2, "Reading 66.3 has all its links" );