base/lib/Text/Tradition/Collation/RelationshipStore.pm

   1 package Text::Tradition::Collation::RelationshipStore;
   2
   3 use strict;
   4 use warnings;
   5 use Safe::Isa;
   6 use Text::Tradition::Error;
   7 use Text::Tradition::Collation::Relationship;
   8 use Text::Tradition::Collation::RelationshipType;
   9 use TryCatch;
  10
  11 use Moose;
  12
  13 =head1 NAME
  14
  15 Text::Tradition::Collation::RelationshipStore - Keeps track of the relationships
  16 between readings in a given collation
  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
  25 =begin testing
  26
  27 use Text::Tradition;
  28 use TryCatch;
  29
  30 use_ok( 'Text::Tradition::Collation::RelationshipStore' );
  31
  32 # Add some relationships, and delete them
  33
  34 my $cxfile = 't/data/Collatex-16.xml';
  35 my $t = Text::Tradition->new(
  36         'name'  => 'inline',
  37         'input' => 'CollateX',
  38         'file'  => $cxfile,
  39         );
  40 my $c = $t->collation;
  41
  42 my @v1 = $c->add_relationship( 'n21', 'n22', { 'type' => 'lexical' } );
  43 is( scalar @v1, 1, "Added a single relationship" );
  44 is( $v1[0]->[0], 'n21', "Got correct node 1" );
  45 is( $v1[0]->[1], 'n22', "Got correct node 2" );
  46 my @v2 = $c->add_relationship( 'n24', 'n23',
  47         { 'type' => 'spelling', 'scope' => 'global' } );
  48 is( scalar @v2, 2, "Added a global relationship with two instances" );
  49 @v1 = $c->del_relationship( 'n22', 'n21' );
  50 is( scalar @v1, 1, "Deleted first relationship" );
  51 @v2 = $c->del_relationship( 'n12', 'n13', 1 );
  52 is( scalar @v2, 2, "Deleted second global relationship" );
  53 my @v3 = $c->del_relationship( 'n1', 'n2' );
  54 is( scalar @v3, 0, "Nothing deleted on non-existent relationship" );
  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" );
  61
  62 =end testing
  63
  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         );
  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',
  91                 del_type => 'delete',
  92                 type     => 'get',
  93                 types    => 'values'
  94                 },
  95         );
  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',
 111         },
 112         );
 113
 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() },
 126         writer => '_reset_equivalence',
 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',
 136                 _clear_equivalence => 'clear',
 137                 },
 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',
 147                 _clear_eqreadings => 'clear',
 148                 },
 149         );
 150
 151 ## Build function - here we have our default set of relationship types.
 152
 153 sub BUILD {
 154         my $self = shift;
 155
 156         my @DEFAULT_TYPES = (
 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.' }
 177                 );
 178
 179         foreach my $type ( @DEFAULT_TYPES ) {
 180                 $self->add_type( $type );
 181         }
 182 }
 183
 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
 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
 212         $self->_remove_equivalence_node( @_ );
 213         $self->$orig( @_ );
 214 };
 215
 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 {
 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 {
 230                 @vector = @_[0,1];
 231         }
 232         my $relationship;
 233         if( $self->graph->has_edge_attribute( @vector, 'object' ) ) {
 234                 $relationship = $self->graph->get_edge_attribute( @vector, 'object' );
 235         }
 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 );
 243         $self->_make_equivalence( @vector ) if $relationship->colocated;
 244 }
 245
 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'};
 258         my $rel = $self->get_relationship( $source, $target );
 259         if( $rel ) {
 260                 if( $self->type( $rel->type )->is_weak ) {
 261                         # Always replace a weak relationship with a more descriptive
 262                         # one, if asked.
 263                         $self->del_relationship( $source, $target );
 264                 } elsif( $rel->type ne $options->{'type'} ) {
 265                         throw( "Another relationship of type " . $rel->type
 266                                 . " already exists between $source and $target" );
 267                 } else {
 268                         return $rel;
 269                 }
 270         }
 271
 272         $rel = Text::Tradition::Collation::Relationship->new( $options );
 273         my $reltype = $self->type( $rel->type );
 274         throw( "Unrecognized relationship type " . $rel->type ) unless $reltype;
 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
 279         $self->add_scoped_relationship( $rel ) if $rel->nonlocal;
 280         return $rel;
 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 ) = @_;
 292         my $rdga = $rel->reading_a;
 293         my $rdgb = $rel->reading_b;
 294         my $r = $self->scoped_relationship( $rdga, $rdgb );
 295         if( $r ) {
 296                 warn sprintf( "Scoped relationship of type %s already exists between %s and %s",
 297                         $r->type, $rdga, $rdgb );
 298                 return;
 299         }
 300         my( $first, $second ) = sort ( $rdga, $rdgb );
 301         $self->scopedrels->{$first}->{$second} = $rel;
 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};
 316         }
 317         return undef;
 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
 330 =begin testing
 331
 332 use Test::Warn;
 333 use Text::Tradition;
 334 use TryCatch;
 335
 336 my $t1;
 337 warnings_exist {
 338         $t1 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/legendfrag.xml' );
 339 } [qr/Cannot set relationship on a meta reading/],
 340         "Got expected relationship drop warning on parse";
 341
 342 # Test 1.1: try to equate nodes that are prevented with an intermediate collation
 343 ok( $t1, "Parsed test fragment file" );
 344 my $c1 = $t1->collation;
 345 my $trel = $c1->get_relationship( 'r9.2', 'r9.3' );
 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 {
 352         $c1->add_relationship( 'r8.6', 'r10.3', { 'type' => 'orthographic' } );
 353         ok( 1, "Added cross-collation relationship as expected" );
 354 } catch( Text::Tradition::Error $e ) {
 355         ok( 0, "Existing collation blocked equivalence relationship: " . $e->message );
 356 }
 357
 358 try {
 359         $c1->calculate_ranks();
 360         ok( 1, "Successfully calculated ranks" );
 361 } catch ( Text::Tradition::Error $e ) {
 362         ok( 0, "Collation now has a cycle: " . $e->message );
 363 }
 364
 365 # Test 1.2: attempt merge of an identical reading
 366 try {
 367         $c1->merge_readings( 'r9.3', 'r11.5' );
 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
 374 # Test 1.3: attempt relationship with a meta reading (should fail)
 375 try {
 376         $c1->add_relationship( 'r8.1', 'r9.2', { 'type' => 'collated' } );
 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
 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
 393 # Test 2.1: try to equate nodes that are prevented with a real intermediate
 394 # equivalence
 395 my $t2;
 396 warnings_exist {
 397         $t2 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/legendfrag.xml' );
 398 } [qr/Cannot set relationship on a meta reading/],
 399         "Got expected relationship drop warning on parse";
 400 my $c2 = $t2->collation;
 401 $c2->add_relationship( 'r9.2', 'r9.3', { 'type' => 'lexical' } );
 402 my $trel2 = $c2->get_relationship( 'r9.2', 'r9.3' );
 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 {
 408         $c2->add_relationship( 'r8.6', 'r10.3', { 'type' => 'orthographic' } );
 409         ok( 0, "Added cross-equivalent bad relationship" );
 410 } catch ( Text::Tradition::Error $e ) {
 411         like( $e->message, qr/witness loop/,
 412                 "Existing equivalence blocked crossing relationship" );
 413 }
 414
 415 try {
 416         $c2->calculate_ranks();
 417         ok( 1, "Successfully calculated ranks" );
 418 } catch ( Text::Tradition::Error $e ) {
 419         ok( 0, "Collation now has a cycle: " . $e->message );
 420 }
 421
 422 # Test 3.1: make a straightforward pair of transpositions.
 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 {
 427         $c3->add_relationship( 'r36.4', 'r38.3', { 'type' => 'transposition' } );
 428         ok( 1, "Added straightforward transposition" );
 429 } catch ( Text::Tradition::Error $e ) {
 430         ok( 0, "Failed to add normal transposition: " . $e->message );
 431 }
 432 try {
 433         $c3->add_relationship( 'r36.3', 'r38.2', { 'type' => 'transposition' } );
 434         ok( 1, "Added straightforward transposition complement" );
 435 } catch ( Text::Tradition::Error $e ) {
 436         ok( 0, "Failed to add normal transposition complement: " . $e->message );
 437 }
 438
 439 # Test 3.2: try to make a transposition that could be a parallel.
 440 try {
 441         $c3->add_relationship( 'r28.2', 'r29.2', { 'type' => 'transposition' } );
 442         ok( 0, "Added bad colocated transposition" );
 443 } catch ( Text::Tradition::Error $e ) {
 444         like( $e->message, qr/Readings appear to be colocated/,
 445                 "Prevented bad colocated transposition" );
 446 }
 447
 448 # Test 3.3: make the parallel, and then make the transposition again.
 449 try {
 450         $c3->add_relationship( 'r28.3', 'r29.3', { 'type' => 'orthographic' } );
 451         ok( 1, "Equated identical readings for transposition" );
 452 } catch ( Text::Tradition::Error $e ) {
 453         ok( 0, "Failed to equate identical readings: " . $e->message );
 454 }
 455 try {
 456         $c3->add_relationship( 'r28.2', 'r29.2', { 'type' => 'transposition' } );
 457         ok( 1, "Added straightforward transposition complement" );
 458 } catch ( Text::Tradition::Error $e ) {
 459         ok( 0, "Failed to add normal transposition complement: " . $e->message );
 460 }
 461
 462 # Test 4: make a global relationship that involves re-ranking a node first, when
 463 # the prior rank has a potential match too
 464 my $t4 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/globalrel_test.xml' );
 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" );
 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;
 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" );
 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
 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
 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
 569 # Test 5.6: try it with non-colocated relationships
 570 $numrel = scalar $c5->relationships;
 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
 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 }
 609
 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" );
 618
 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" );
 632
 633 =end testing
 634
 635 =cut
 636
 637 sub add_relationship {
 638         my( $self, $source, $target, $options ) = @_;
 639     my $c = $self->collation;
 640         my $sourceobj = $c->reading( $source );
 641         my $targetobj = $c->reading( $target );
 642         throw( "Adding self relationship at $source" ) if $source eq $target;
 643         throw( "Cannot set relationship on a meta reading" )
 644                 if( $sourceobj->is_meta || $targetobj->is_meta );
 645         my $relationship;
 646         my $reltype;
 647         my $thispaironly = delete $options->{thispaironly};
 648         my $propagate = delete $options->{propagate};
 649         my $droppedcolls = [];
 650         if( ref( $options ) eq 'Text::Tradition::Collation::Relationship' ) {
 651                 $relationship = $options;
 652                 $reltype = $self->type( $relationship->type );
 653                 $thispaironly = 1;  # If existing rel, set only where asked.
 654                 # Test the validity
 655                 my( $is_valid, $reason ) = $self->relationship_valid( $source, $target,
 656                         $relationship->type, $droppedcolls );
 657                 unless( $is_valid ) {
 658                         throw( "Invalid relationship: $reason" );
 659                 }
 660         } else {
 661                 $reltype = $self->type( $options->{type} );
 662
 663                 # Try to create the relationship object.
 664                 my $rdga = $reltype->regularize( $sourceobj );
 665                 my $rdgb = $reltype->regularize( $targetobj );
 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' ) {
 671                         # Is there a relationship with this a & b already?
 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
 680                         my $otherrel = $self->scoped_relationship( $rdga, $rdgb );
 681                         if( $otherrel && $otherrel->type eq $options->{type}
 682                                 && $otherrel->scope eq $options->{scope} ) {
 683                                 # warn "Applying existing scoped relationship for $rdga / $rdgb";
 684                                 $relationship = $otherrel;
 685                         } elsif( $otherrel ) {
 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" );
 690                         }
 691         }
 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                 }
 701     }
 702
 703
 704     # Now set the relationship(s).
 705     my @pairs_set;
 706         my $rel = $self->get_relationship( $source, $target );
 707         my $skip;
 708         if( $rel && $rel ne $relationship ) {
 709                 if( $rel->nonlocal ) {
 710                         throw( "Found conflicting relationship at $source - $target" );
 711                 } elsif( !$reltype->is_weak ) {
 712                         # Replace a weak relationship; leave any other sort in place.
 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 );
 719                         }
 720                         $skip = 1;
 721                 }
 722         }
 723         $self->_set_relationship( $relationship, $source, $target ) unless $skip;
 724         push( @pairs_set, [ $source, $target, $relationship->type ] );
 725
 726         # Find all the pairs for which we need to set the relationship.
 727     if( $relationship->colocated && $relationship->nonlocal && !$thispaironly ) {
 728         my @global_set = $self->add_global_relationship( $relationship );
 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;
 738     }
 739
 740     # Finally, restore whatever collations we can, and return.
 741     $self->_restore_weak( @$droppedcolls );
 742     return @pairs_set;
 743 }
 744
 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 {
 753         my( $self, $relationship ) = @_;
 754         # Sanity checking
 755         my $reltype = $self->type( $relationship->type );
 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" )
 759                 unless $reltype->is_generalizable;
 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 );
 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                 }
 770         } else {
 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 );
 777                         # print STDERR "Global relationship $reldesc not applicable at @$v\n";
 778                     }
 779                 push( @pairs_set, @added ) if @added;
 780         }
 781     }
 782         return @pairs_set;
 783 }
 784
 785
 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
 799 sub _find_applicable {
 800         my( $self, $rel ) = @_;
 801         my $c = $self->collation;
 802         my $reltype = $self->type( $rel->type );
 803         my @vectors;
 804         my @identical_readings;
 805         @identical_readings = grep { $reltype->regularize( $_ ) eq $rel->reading_a }
 806                 $c->readings;
 807         foreach my $ir ( @identical_readings ) {
 808                 my @itarget;
 809                 @itarget = grep { $reltype->regularize( $_ ) eq $rel->reading_b }
 810                         $c->readings_at_rank( $ir->rank );
 811                 if( @itarget ) {
 812                         # Warn if there is more than one hit with no closer link between them.
 813                         my $itmain = shift @itarget;
 814                         if( @itarget ) {
 815                                 my %all_targets;
 816                                 my $bindlevel = $reltype->bindlevel;
 817                                 map { $all_targets{$_} = 1 } @itarget;
 818                                 map { delete $all_targets{$_} }
 819                                         $self->related_readings( $itmain, sub {
 820                                                 $self->type( $_[0]->type )->bindlevel < $bindlevel } );
 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
 830 =head2 del_relationship( $source, $target, $allscope )
 831
 832 Removes the relationship between the given readings. If the relationship is
 833 non-local and $allscope is true, removes the relationship throughout the
 834 relevant scope.
 835
 836 =cut
 837
 838 sub del_relationship {
 839         my( $self, $source, $target, $allscope ) = @_;
 840         my $rel = $self->get_relationship( $source, $target );
 841         return () unless $rel; # Nothing to delete; return an empty set.
 842         my $reltype = $self->type( $rel->type );
 843         my $colo = $rel->colocated;
 844         my @vectors = ( [ $source, $target ] );
 845         $self->_remove_relationship( $colo, $source, $target );
 846         if( $rel->nonlocal && $allscope ) {
 847                 # Remove the relationship wherever it occurs.
 848                 my @rel_edges = grep { $self->get_relationship( @$_ ) eq $rel }
 849                         $self->relationships;
 850                 foreach my $re ( @rel_edges ) {
 851                         $self->_remove_relationship( $colo, @$re );
 852                         push( @vectors, $re );
 853                 }
 854                 $self->del_scoped_relationship( $rel->reading_a, $rel->reading_b );
 855         }
 856         return @vectors;
 857 }
 858
 859 sub _remove_relationship {
 860         my( $self, $equiv, @vector ) = @_;
 861         $self->graph->delete_edge( @vector );
 862         $self->_break_equivalence( @vector ) if $equiv;
 863 }
 864
 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 {
 874     my( $self, $source, $target, $rel, $mustdrop ) = @_;
 875     $mustdrop = [] unless $mustdrop; # in case we were passed nothing
 876     my $c = $self->collation;
 877     my $reltype = $self->type( $rel );
 878     ## Assume validity is okay if we are initializing from scratch.
 879     return ( 1, "initializing" ) unless $c->tradition->_initialized;
 880     ## TODO Move this block to relationship type definition when we can save
 881     ## coderefs
 882     if ( $rel eq 'transposition' || $rel eq 'repetition' ) {
 883                 # Check that the two readings do (for a repetition) or do not (for
 884                 # a transposition) appear in the same witness.
 885                 # TODO this might be called before witness paths are set...
 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';
 893                         }
 894                 }
 895                 return ( 0, "Readings occur only in distinct witnesses" )
 896                         if $rel eq 'repetition';
 897         }
 898         if ( $reltype->is_colocation ) {
 899                 # Check that linking the source and target in a relationship won't lead
 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 ) {
 907                         push( @$mustdrop, $self->_drop_weak( $source ) );
 908                         push( @$mustdrop, $self->_drop_weak( $target ) );
 909                         if( $c->end->has_rank ) {
 910                                 foreach my $rk ( $sourcerank .. $targetrank ) {
 911                                         map { push( @$mustdrop, $self->_drop_weak( $_->id ) ) }
 912                                                 $c->readings_at_rank( $rk );
 913                                 }
 914                         }
 915                 }
 916                 unless( $self->test_equivalence( $source, $target ) ) {
 917                         $self->_restore_weak( @$mustdrop );
 918                         return( 0, "Relationship would create witness loop" );
 919                 }
 920                 return ( 1, "ok" );
 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                 }
 929         }
 930 }
 931
 932 sub _drop_weak {
 933         my( $self, $reading ) = @_;
 934         my @dropped;
 935         foreach my $n ( $self->graph->neighbors( $reading ) ) {
 936                 my $nrel = $self->get_relationship( $reading, $n );
 937                 if( $self->type( $nrel->type )->is_weak ) {
 938                         push( @dropped, [ $reading, $n, $nrel->type ] );
 939                         $self->del_relationship( $reading, $n );
 940                         #print STDERR "Dropped weak relationship $reading -> $n\n";
 941                 }
 942         }
 943         return @dropped;
 944 }
 945
 946 sub _restore_weak {
 947         my( $self, @vectors ) = @_;
 948         foreach my $v ( @vectors ) {
 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
 954         }
 955 }
 956
 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         }
 974         return $ok;
 975 }
 976
 977
 978 =head2 related_readings( $reading, $filter )
 979
 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.
 983
 984 =cut
 985
 986 sub related_readings {
 987         my( $self, $reading, $filter ) = @_;
 988         my $return_object;
 989         if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
 990                 $reading = $reading->id;
 991                 $return_object = 1;
 992         }
 993         my @answer;
 994         if( $filter ) {
 995                 # Backwards compat
 996                 if( $filter eq 'colocated' ) {
 997                         $filter = sub { $_[0]->colocated };
 998                 } elsif( !ref( $filter ) ) {
 999                         my $type = $filter;
1000                         $filter = sub { $_[0]->type eq $type };
1001                 }
1002                 @answer = grep { &$filter( $self->get_relationship( $reading, $_ ) ) }
1003                         $self->graph->neighbors( $reading );
1004         } else {
1005                 @answer = $self->graph->neighbors( $reading );
1006         }
1007         if( $return_object ) {
1008                 my $c = $self->collation;
1009                 return map { $c->reading( $_ ) } @answer;
1010         } else {
1011                 return @answer;
1012         }
1013 }
1014
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 );
1061                         my $skip;
1062                         if( $existing ) {
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 ) {
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;
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
1114                                 my $existing = $self->get_relationship( $sib, $nr );
1115                                 my $skip;
1116                                 if( $existing ) {
1117                                         # Check that it's compatible. The existing relationship type
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;
1131                                         }
1132                                 }
1133                                 unless( $skip ) {
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
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
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
1201                 # If kept / rel already has a relationship, just keep the old
1202                 my $rel = $self->get_relationship( @vector );
1203                 next if $rel;
1204
1205                 # Otherwise, adopt the relationship that would be deleted.
1206                 $rel = $self->get_relationship( @$edge );
1207                 $self->_set_relationship( $rel, @vector );
1208         }
1209         $self->_make_equivalence( $deleted, $kept );
1210 }
1211
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 ) {
1219                 $self->equivalence_graph->delete_vertex( $group );
1220                 $self->remove_eqreadings( $group );
1221                 $self->remove_equivalence( $group );
1222         } elsif( @$nodelist == 1 ) {
1223                 throw( "DATA INCONSISTENCY in equivalence graph: " . $nodelist->[0] .
1224                         " in group that should have only $node" );
1225         } else {
1226                 my @newlist = grep { $_ ne $node } @$nodelist;
1227                 $self->set_eqreadings( $group, \@newlist );
1228                 $self->remove_equivalence( $node );
1229         }
1230 }
1231
1232 =head2 add_equivalence_edge
1233
1234 Add an edge in the equivalence graph corresponding to $source -> $target in the
1235 collation. Should only be called by Collation.
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 );
1243         $self->equivalence_graph->add_edge( $seq, $teq );
1244 }
1245
1246 =head2 delete_equivalence_edge
1247
1248 Remove an edge in the equivalence graph corresponding to $source -> $target in the
1249 collation. Should only be called by Collation.
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 );
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
1266 # Equate two readings in the equivalence graph
1267 sub _make_equivalence {
1268         my( $self, $source, $target ) = @_;
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;
1274         my $sourcepool = $self->eqreadings( $seq );
1275         # and add them to the target readings.
1276         push( @{$self->eqreadings( $teq )}, @$sourcepool );
1277         map { $self->set_equivalence( $_, $teq ) } @$sourcepool;
1278         # Then merge the nodes in the equivalence graph.
1279         foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
1280                 $self->equivalence_graph->add_edge( $pred, $teq );
1281         }
1282         foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
1283                 $self->equivalence_graph->add_edge( $teq, $succ );
1284         }
1285         $self->equivalence_graph->delete_vertex( $seq );
1286         # TODO enable this after collation parsing is done
1287         throw( "Graph got disconnected making $source / $target equivalence" )
1288                 if $self->_is_disconnected && $self->collation->tradition->_initialized;
1289 }
1290
1291 =head2 test_equivalence
1292
1293 Test whether, if two readings were equated with a 'colocated' relationship,
1294 the graph would still be valid.
1295
1296 =cut
1297
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
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 ) ) {
1350                 throw( "GRAPH CHANGED after testing" );
1351         }
1352         # Return our answer
1353         return $ret;
1354 }
1355
1356 # Unmake an equivalence link between two readings. Should only be called internally.
1357 sub _break_equivalence {
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 ) {
1367                 return if( exists $sng{$el} );
1368         }
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
1371         my $oldgroup = $self->equivalence( $source ); # same as $target
1372         my $keepsource = $sng{$oldgroup};
1373         my $newgroup = $keepsource ? $target : $source;
1374         my( $oldmembers, $newmembers );
1375         if( $keepsource ) {
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 );
1385         foreach my $el ( @$oldmembers ) {
1386                 $self->set_equivalence( $el, $oldgroup );
1387         }
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 ) ) {
1401                         next unless $self->equivalence( $rp );
1402                         $self->equivalence_graph->add_edge( $self->equivalence( $rp ), $newgroup );
1403                 }
1404                 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
1405                         next unless $self->equivalence( $rs );
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 ) ) {
1414                         next unless $self->equivalence( $rp );
1415                         $old_pred{$self->equivalence( $rp )} = 1;
1416                 }
1417                 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
1418                         next unless $self->equivalence( $rs );
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         }
1432         # TODO enable this after collation parsing is done
1433         throw( "Graph got disconnected breaking $source / $target equivalence" )
1434                 if $self->_is_disconnected && $self->collation->tradition->_initialized;
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
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();
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
1474         $self->collation->tradition->_init_done(0);
1475         # Add the readings
1476         foreach my $r ( $self->collation->readings ) {
1477                 my $rid = $r->id;
1478                 $newgraph->add_vertex( $rid );
1479                 $self->set_equivalence( $rid, $rid );
1480                 $self->set_eqreadings( $rid, [ $rid ] );
1481         }
1482
1483         # Now add the edges
1484         foreach my $e ( $self->collation->paths ) {
1485                 $self->add_equivalence_edge( @$e );
1486         }
1487
1488         # Now equate the colocated readings. This does no testing;
1489         # it assumes that all preexisting relationships are valid.
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         }
1495         $self->collation->tradition->_init_done(1);
1496 }
1497
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
1553 ### Output logic
1554
1555 sub _as_graphml {
1556         my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_;
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' );
1562     $rgraph->setAttribute( 'parse.edges', 0 );
1563     $rgraph->setAttribute( 'parse.nodeids', 'canonical' );
1564     $rgraph->setAttribute( 'parse.nodes', 0 );
1565     $rgraph->setAttribute( 'parse.order', 'nodesfirst' );
1566
1567     # Add the vertices according to their XML IDs
1568     my %rdg_lookup = ( reverse %$node_hash );
1569     # my @nlist = sort _by_xmlid keys( %rdg_lookup ); ## CAUSES SEGFAULT
1570     my @nlist = sort keys( %rdg_lookup );
1571     foreach my $n ( @nlist ) {
1572         my $n_el = $rgraph->addNewChild( $graphml_ns, 'node' );
1573         $n_el->setAttribute( 'id', $n );
1574         _add_graphml_data( $n_el, $nodeid_key, $rdg_lookup{$n} );
1575     }
1576         $rgraph->setAttribute( 'parse.nodes', scalar @nlist );
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.
1582         next unless( exists $node_hash->{$e->[0]} && exists $node_hash->{$e->[1]} );
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
1588                 my $rel_obj = $self->get_relationship( @$e );
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                 }
1594         }
1595         $rgraph->setAttribute( 'parse.edges', $edge_ctr );
1596 }
1597
1598 sub _by_xmlid {
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;
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 );
1612 }
1613
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
1622 sub throw {
1623         Text::Tradition::Error->throw(
1624                 'ident' => 'Relationship error',
1625                 'message' => $_[0],
1626                 );
1627 }
1628
1629 no Moose;
1630 __PACKAGE__->meta->make_immutable;
1631
1632 1;