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 }
 975
 976
 977 =head2 related_readings( $reading, $filter )
 978
 979 Returns a list of readings that are connected via direct relationship links
 980 to $reading. If $filter is set to a subroutine ref, returns only those
 981 related readings where $filter( $relationship ) returns a true value.
 982
 983 =cut
 984
 985 sub related_readings {
 986         my( $self, $reading, $filter ) = @_;
 987         my $return_object;
 988         if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
 989                 $reading = $reading->id;
 990                 $return_object = 1;
 991         }
 992         my @answer;
 993         if( $filter ) {
 994                 # Backwards compat
 995                 if( $filter eq 'colocated' ) {
 996                         $filter = sub { $_[0]->colocated };
 997                 } elsif( !ref( $filter ) ) {
 998                         my $type = $filter;
 999                         $filter = sub { $_[0]->type eq $type };
1000                 }
1001                 @answer = grep { &$filter( $self->get_relationship( $reading, $_ ) ) }
1002                         $self->graph->neighbors( $reading );
1003         } else {
1004                 @answer = $self->graph->neighbors( $reading );
1005         }
1006         if( $return_object ) {
1007                 my $c = $self->collation;
1008                 return map { $c->reading( $_ ) } @answer;
1009         } else {
1010                 return @answer;
1011         }
1012 }
1013
1014 =head2 propagate_relationship( $rel )
1015
1016 Apply the transitivity and binding level rules to propagate the consequences of
1017 the specified relationship link, ensuring all consequent relationships exist.
1018 For now, we only propagate colocation links if we are passed a colocation, and
1019 we only propagate displacement links if we are given a displacement.
1020
1021 Returns an array of tuples ( rdg1, rdg2, type ) for each new reading set.
1022
1023 =cut
1024
1025 sub propagate_relationship {
1026         my( $self, @rel ) = @_;
1027         ## Check that the vector is an arrayref
1028         my $rel = @rel > 1 ? \@rel : $rel[0];
1029         ## Get the relationship info
1030         my $relobj = $self->get_relationship( $rel );
1031         my $reltype = $self->type( $relobj->type );
1032         return () unless $reltype->is_transitive;
1033         my @newly_set;
1034
1035         my $colo = $reltype->is_colocation;
1036         my $bindlevel = $reltype->bindlevel;
1037
1038         ## Find all readings that are linked via this relationship type
1039         my %thislevel = ( $rel->[0] => 1, $rel->[1] => 1 );
1040         my $check = $rel;
1041         my $iter = 0;
1042         while( @$check ) {
1043                 my $more = [];
1044                 foreach my $r ( @$check ) {
1045                         push( @$more, grep { !exists $thislevel{$_}
1046                                 && $self->get_relationship( $r, $_ )
1047                                 && $self->get_relationship( $r, $_ )->type eq $relobj->type }
1048                                         $self->graph->neighbors( $r ) );
1049                 }
1050                 map { $thislevel{$_} = 1 } @$more;
1051                 $check = $more;
1052         }
1053
1054         ## Make sure every reading of our relationship type is linked to every other
1055         my @samelevel = keys %thislevel;
1056         while( @samelevel ) {
1057                 my $r = shift @samelevel;
1058                 foreach my $nr ( @samelevel ) {
1059                         my $existing = $self->get_relationship( $r, $nr );
1060                         my $skip;
1061                         if( $existing ) {
1062                                 my $extype = $self->type( $existing->type );
1063                                 unless( $extype->is_weak ) {
1064                                         # Check that it's a matching type, or a type subsumed by our
1065                                         # bindlevel
1066                                         throw( "Conflicting existing relationship of type "
1067                                                 . $existing->type . " at $r, $nr trying to propagate "
1068                                                 . $relobj->type . " relationship at @$rel" )
1069                                                 unless $existing->type eq $relobj->type
1070                                                         || $extype->bindlevel <= $reltype->bindlevel;
1071                                         $skip = 1;
1072                                 }
1073                         }
1074                         unless( $skip ) {
1075                                 # Try to add a new relationship here
1076                                 try {
1077                                         my @new = $self->add_relationship( $r, $nr, { type => $relobj->type,
1078                                                 annotation => "Propagated from relationship at @$rel" } );
1079                                         push( @newly_set, @new );
1080                                 } catch ( Text::Tradition::Error $e ) {
1081                                         throw( "Could not propagate " . $relobj->type .
1082                                                 " relationship (original @$rel) at $r -- $nr: " .
1083                                                 $e->message );
1084                                 }
1085                         }
1086                 }
1087
1088                 ## Now for each sibling our set, look for its direct connections to
1089                 ## transitive readings of a different bindlevel, and make sure that
1090                 ## all siblings are related to those readings.
1091                 my @other;
1092                 foreach my $n ( $self->graph->neighbors( $r ) ) {
1093                         my $crel = $self->get_relationship( $r, $n );
1094                         next unless $crel;
1095                         my $crt = $self->type( $crel->type );
1096                         if( $crt->is_transitive && $crt->is_colocation == $colo ) {
1097                                 next if $crt->bindlevel == $reltype->bindlevel;
1098                                 my $nrel = $crt->bindlevel < $reltype->bindlevel
1099                                         ? $reltype->name : $crt->name;
1100                                 push( @other, [ $n, $nrel ] );
1101                         }
1102                 }
1103                 # The @other array now contains tuples of ( reading, type ) where the
1104                 # reading is the non-sibling and the type is the type of relationship
1105                 # that the siblings should have to the non-sibling.
1106                 foreach ( @other ) {
1107                         my( $nr, $nrtype ) = @$_;
1108                         foreach my $sib ( keys %thislevel ) {
1109                                 next if $sib eq $r;
1110                                 next if $sib eq $nr; # can happen if linked to $r by tightrel
1111                                                                          # but linked to a sib of $r by thisrel
1112                                                                          # e.g. when a rel has been part propagated
1113                                 my $existing = $self->get_relationship( $sib, $nr );
1114                                 my $skip;
1115                                 if( $existing ) {
1116                                         # Check that it's compatible. The existing relationship type
1117                                         # should match or be subsumed by the looser of the two
1118                                         # relationships in play, whether the original relationship
1119                                         # being worked on or the relationship between $r and $or.
1120                                         my $extype = $self->type( $existing->type );
1121                                         unless( $extype->is_weak ) {
1122                                                 if( $nrtype ne $extype->name
1123                                                         && $self->type( $nrtype )->bindlevel <= $extype->bindlevel ) {
1124                                                         throw( "Conflicting existing relationship at $nr ( -> "
1125                                                                 . $self->get_relationship( $nr, $r )->type . " to $r) "
1126                                                                 . " -- $sib trying to propagate " . $relobj->type
1127                                                                 . " relationship at @$rel" );
1128                                                 }
1129                                                 $skip = 1;
1130                                         }
1131                                 }
1132                                 unless( $skip ) {
1133                                         # Try to add a new relationship here
1134                                         try {
1135                                                 my @new = $self->add_relationship( $sib, $nr, { type => $nrtype,
1136                                                         annotation => "Propagated from relationship at @$rel" } );
1137                                                 push( @newly_set, @new );
1138                                         } catch ( Text::Tradition::Error $e ) {
1139                                                 throw( "Could not propagate $nrtype relationship (original " .
1140                                                         $relobj->type . " at @$rel) at $sib -- $nr: " .
1141                                                         $e->message );
1142                                         }
1143                                 }
1144                         }
1145                 }
1146         }
1147
1148         return @newly_set;
1149 }
1150
1151 =head2 propagate_all_relationships
1152
1153 Apply propagation logic retroactively to all relationships in the tradition.
1154
1155 =cut
1156
1157 sub propagate_all_relationships {
1158         my $self = shift;
1159         my @allrels = sort { $self->_propagate_rel_order( $a, $b ) } $self->relationships;
1160         foreach my $rel ( @allrels ) {
1161                 my $relobj = $self->get_relationship( $rel );
1162                 if( $self->type( $relobj->type )->is_transitive ) {
1163                         my @added = $self->propagate_relationship( $rel );
1164                 }
1165         }
1166 }
1167
1168 # Helper sorting function for retroactive propagation order.
1169 sub _propagate_rel_order {
1170         my( $self, $a, $b ) = @_;
1171         my $aobj = $self->get_relationship( $a );
1172         my $bobj = $self->get_relationship( $b );
1173         my $at = $self->type( $aobj->type ); my $bt = $self->type( $bobj->type );
1174         # Apply strong relationships before weak
1175         return -1 if $bt->is_weak && !$at->is_weak;
1176         return 1 if $at->is_weak && !$bt->is_weak;
1177         # Apply more tightly bound relationships first
1178         return $at->bindlevel <=> $bt->bindlevel;
1179 }
1180
1181
1182 =head2 merge_readings( $kept, $deleted );
1183
1184 Makes a best-effort merge of the relationship links between the given readings, and
1185 stops tracking the to-be-deleted reading.
1186
1187 =cut
1188
1189 sub merge_readings {
1190         my( $self, $kept, $deleted, $combined ) = @_;
1191         foreach my $edge ( $self->graph->edges_at( $deleted ) ) {
1192                 # Get the pair of kept / rel
1193                 my @vector = ( $kept );
1194                 push( @vector, $edge->[0] eq $deleted ? $edge->[1] : $edge->[0] );
1195                 next if $vector[0] eq $vector[1]; # Don't add a self loop
1196
1197                 # If kept changes its text, drop the relationship.
1198                 next if $combined;
1199
1200                 # If kept / rel already has a relationship, just keep the old
1201                 my $rel = $self->get_relationship( @vector );
1202                 next if $rel;
1203
1204                 # Otherwise, adopt the relationship that would be deleted.
1205                 $rel = $self->get_relationship( @$edge );
1206                 $self->_set_relationship( $rel, @vector );
1207         }
1208         $self->_make_equivalence( $deleted, $kept );
1209 }
1210
1211 ### Equivalence logic
1212
1213 sub _remove_equivalence_node {
1214         my( $self, $node ) = @_;
1215         my $group = $self->equivalence( $node );
1216         my $nodelist = $self->eqreadings( $group );
1217         if( @$nodelist == 1 && $nodelist->[0] eq $node ) {
1218                 $self->equivalence_graph->delete_vertex( $group );
1219                 $self->remove_eqreadings( $group );
1220                 $self->remove_equivalence( $group );
1221         } elsif( @$nodelist == 1 ) {
1222                 throw( "DATA INCONSISTENCY in equivalence graph: " . $nodelist->[0] .
1223                         " in group that should have only $node" );
1224         } else {
1225                 my @newlist = grep { $_ ne $node } @$nodelist;
1226                 $self->set_eqreadings( $group, \@newlist );
1227                 $self->remove_equivalence( $node );
1228         }
1229 }
1230
1231 =head2 add_equivalence_edge
1232
1233 Add an edge in the equivalence graph corresponding to $source -> $target in the
1234 collation. Should only be called by Collation.
1235
1236 =cut
1237
1238 sub add_equivalence_edge {
1239         my( $self, $source, $target ) = @_;
1240         my $seq = $self->equivalence( $source );
1241         my $teq = $self->equivalence( $target );
1242         $self->equivalence_graph->add_edge( $seq, $teq );
1243 }
1244
1245 =head2 delete_equivalence_edge
1246
1247 Remove an edge in the equivalence graph corresponding to $source -> $target in the
1248 collation. Should only be called by Collation.
1249
1250 =cut
1251
1252 sub delete_equivalence_edge {
1253         my( $self, $source, $target ) = @_;
1254         my $seq = $self->equivalence( $source );
1255         my $teq = $self->equivalence( $target );
1256         $self->equivalence_graph->delete_edge( $seq, $teq );
1257 }
1258
1259 sub _is_disconnected {
1260         my $self = shift;
1261         return( scalar $self->equivalence_graph->predecessorless_vertices > 1
1262                 || scalar $self->equivalence_graph->successorless_vertices > 1 );
1263 }
1264
1265 # Equate two readings in the equivalence graph
1266 sub _make_equivalence {
1267         my( $self, $source, $target ) = @_;
1268         # Get the source equivalent readings
1269         my $seq = $self->equivalence( $source );
1270         my $teq = $self->equivalence( $target );
1271         # Nothing to do if they are already equivalent...
1272         return if $seq eq $teq;
1273         my $sourcepool = $self->eqreadings( $seq );
1274         # and add them to the target readings.
1275         push( @{$self->eqreadings( $teq )}, @$sourcepool );
1276         map { $self->set_equivalence( $_, $teq ) } @$sourcepool;
1277         # Then merge the nodes in the equivalence graph.
1278         foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
1279                 $self->equivalence_graph->add_edge( $pred, $teq );
1280         }
1281         foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
1282                 $self->equivalence_graph->add_edge( $teq, $succ );
1283         }
1284         $self->equivalence_graph->delete_vertex( $seq );
1285         # TODO enable this after collation parsing is done
1286         throw( "Graph got disconnected making $source / $target equivalence" )
1287                 if $self->_is_disconnected && $self->collation->tradition->_initialized;
1288 }
1289
1290 =head2 test_equivalence
1291
1292 Test whether, if two readings were equated with a 'colocated' relationship,
1293 the graph would still be valid.
1294
1295 =cut
1296
1297 # TODO Used the 'is_reachable' method; it killed performance. Think about doing away
1298 # with the equivalence graph in favor of a transitive closure graph (calculated ONCE)
1299 # on the sequence graph, and test that way.
1300
1301 sub test_equivalence {
1302         my( $self, $source, $target ) = @_;
1303         # Try merging the nodes in the equivalence graph; return a true value if
1304         # no cycle is introduced thereby. Restore the original graph first.
1305
1306         # Keep track of edges we add
1307         my %added_pred;
1308         my %added_succ;
1309         # Get the reading equivalents
1310         my $seq = $self->equivalence( $source );
1311         my $teq = $self->equivalence( $target );
1312         # Maybe this is easy?
1313         return 1 if $seq eq $teq;
1314
1315         # Save the first graph
1316         my $checkstr = $self->equivalence_graph->stringify();
1317         # Add and save relevant edges
1318         foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
1319                 if( $self->equivalence_graph->has_edge( $pred, $teq ) ) {
1320                         $added_pred{$pred} = 0;
1321                 } else {
1322                         $self->equivalence_graph->add_edge( $pred, $teq );
1323                         $added_pred{$pred} = 1;
1324                 }
1325         }
1326         foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
1327                 if( $self->equivalence_graph->has_edge( $teq, $succ ) ) {
1328                         $added_succ{$succ} = 0;
1329                 } else {
1330                         $self->equivalence_graph->add_edge( $teq, $succ );
1331                         $added_succ{$succ} = 1;
1332                 }
1333         }
1334         # Delete source equivalent and test
1335         $self->equivalence_graph->delete_vertex( $seq );
1336         my $ret = !$self->equivalence_graph->has_a_cycle;
1337
1338         # Restore what we changed
1339         $self->equivalence_graph->add_vertex( $seq );
1340         foreach my $pred ( keys %added_pred ) {
1341                 $self->equivalence_graph->add_edge( $pred, $seq );
1342                 $self->equivalence_graph->delete_edge( $pred, $teq ) if $added_pred{$pred};
1343         }
1344         foreach my $succ ( keys %added_succ ) {
1345                 $self->equivalence_graph->add_edge( $seq, $succ );
1346                 $self->equivalence_graph->delete_edge( $teq, $succ ) if $added_succ{$succ};
1347         }
1348         unless( $self->equivalence_graph->eq( $checkstr ) ) {
1349                 throw( "GRAPH CHANGED after testing" );
1350         }
1351         # Return our answer
1352         return $ret;
1353 }
1354
1355 # Unmake an equivalence link between two readings. Should only be called internally.
1356 sub _break_equivalence {
1357         my( $self, $source, $target ) = @_;
1358
1359         # This is the hard one. Need to reconstruct the equivalence groups without
1360         # the given link.
1361         my( %sng, %tng );
1362         map { $sng{$_} = 1 } $self->_find_equiv_without( $source, $target );
1363         map { $tng{$_} = 1 } $self->_find_equiv_without( $target, $source );
1364         # If these groups intersect, they are still connected; do nothing.
1365         foreach my $el ( keys %tng ) {
1366                 return if( exists $sng{$el} );
1367         }
1368         # If they don't intersect, then we split the nodes in the graph and in
1369         # the hashes. First figure out which group has which name
1370         my $oldgroup = $self->equivalence( $source ); # same as $target
1371         my $keepsource = $sng{$oldgroup};
1372         my $newgroup = $keepsource ? $target : $source;
1373         my( $oldmembers, $newmembers );
1374         if( $keepsource ) {
1375                 $oldmembers = [ keys %sng ];
1376                 $newmembers = [ keys %tng ];
1377         } else {
1378                 $oldmembers = [ keys %tng ];
1379                 $newmembers = [ keys %sng ];
1380         }
1381
1382         # First alter the old group in the hash
1383         $self->set_eqreadings( $oldgroup, $oldmembers );
1384         foreach my $el ( @$oldmembers ) {
1385                 $self->set_equivalence( $el, $oldgroup );
1386         }
1387
1388         # then add the new group back to the hash with its new key
1389         $self->set_eqreadings( $newgroup, $newmembers );
1390         foreach my $el ( @$newmembers ) {
1391                 $self->set_equivalence( $el, $newgroup );
1392         }
1393
1394         # Now add the new group back to the equivalence graph
1395         $self->equivalence_graph->add_vertex( $newgroup );
1396         # ...add the appropriate edges to the source group vertext
1397         my $c = $self->collation;
1398         foreach my $rdg ( @$newmembers ) {
1399                 foreach my $rp ( $c->sequence->predecessors( $rdg ) ) {
1400                         next unless $self->equivalence( $rp );
1401                         $self->equivalence_graph->add_edge( $self->equivalence( $rp ), $newgroup );
1402                 }
1403                 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
1404                         next unless $self->equivalence( $rs );
1405                         $self->equivalence_graph->add_edge( $newgroup, $self->equivalence( $rs ) );
1406                 }
1407         }
1408
1409         # ...and figure out which edges on the old group vertex to delete.
1410         my( %old_pred, %old_succ );
1411         foreach my $rdg ( @$oldmembers ) {
1412                 foreach my $rp ( $c->sequence->predecessors( $rdg ) ) {
1413                         next unless $self->equivalence( $rp );
1414                         $old_pred{$self->equivalence( $rp )} = 1;
1415                 }
1416                 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
1417                         next unless $self->equivalence( $rs );
1418                         $old_succ{$self->equivalence( $rs )} = 1;
1419                 }
1420         }
1421         foreach my $p ( $self->equivalence_graph->predecessors( $oldgroup ) ) {
1422                 unless( $old_pred{$p} ) {
1423                         $self->equivalence_graph->delete_edge( $p, $oldgroup );
1424                 }
1425         }
1426         foreach my $s ( $self->equivalence_graph->successors( $oldgroup ) ) {
1427                 unless( $old_succ{$s} ) {
1428                         $self->equivalence_graph->delete_edge( $oldgroup, $s );
1429                 }
1430         }
1431         # TODO enable this after collation parsing is done
1432         throw( "Graph got disconnected breaking $source / $target equivalence" )
1433                 if $self->_is_disconnected && $self->collation->tradition->_initialized;
1434 }
1435
1436 sub _find_equiv_without {
1437         my( $self, $first, $second ) = @_;
1438         my %found = ( $first => 1 );
1439         my $check = [ $first ];
1440         my $iter = 0;
1441         while( @$check ) {
1442                 my $more = [];
1443                 foreach my $r ( @$check ) {
1444                         foreach my $nr ( $self->graph->neighbors( $r ) ) {
1445                                 next if $r eq $second;
1446                                 if( $self->get_relationship( $r, $nr )->colocated ) {
1447                                         push( @$more, $nr ) unless exists $found{$nr};
1448                                         $found{$nr} = 1;
1449                                 }
1450                         }
1451                 }
1452                 $check = $more;
1453         }
1454         return keys %found;
1455 }
1456
1457 =head2 rebuild_equivalence
1458
1459 (Re)build the equivalence graph from scratch. Dumps the graph, makes a new one,
1460 adds all readings and edges, then makes an equivalence for all relationships.
1461
1462 =cut
1463
1464 sub rebuild_equivalence {
1465         my $self = shift;
1466         my $newgraph = Graph->new();
1467         # Set this as the new equivalence graph
1468         $self->_reset_equivalence( $newgraph );
1469         # Clear out the data hashes
1470         $self->_clear_equivalence;
1471         $self->_clear_eqreadings;
1472
1473         $self->collation->tradition->_init_done(0);
1474         # Add the readings
1475         foreach my $r ( $self->collation->readings ) {
1476                 my $rid = $r->id;
1477                 $newgraph->add_vertex( $rid );
1478                 $self->set_equivalence( $rid, $rid );
1479                 $self->set_eqreadings( $rid, [ $rid ] );
1480         }
1481
1482         # Now add the edges
1483         foreach my $e ( $self->collation->paths ) {
1484                 $self->add_equivalence_edge( @$e );
1485         }
1486
1487         # Now equate the colocated readings. This does no testing;
1488         # it assumes that all preexisting relationships are valid.
1489         foreach my $rel ( $self->relationships ) {
1490                 my $relobj = $self->get_relationship( $rel );
1491                 next unless $relobj && $relobj->colocated;
1492                 $self->_make_equivalence( @$rel );
1493         }
1494         $self->collation->tradition->_init_done(1);
1495 }
1496
1497 =head2 equivalence_ranks
1498
1499 Rank all vertices in the equivalence graph, and return a hash reference with
1500 vertex => rank mapping.
1501
1502 =cut
1503
1504 sub equivalence_ranks {
1505         my $self = shift;
1506         my $eqstart = $self->equivalence( $self->collation->start );
1507         my $eqranks = { $eqstart => 0 };
1508         my $rankeqs = { 0 => [ $eqstart ] };
1509         my @curr_origin = ( $eqstart );
1510     # A little iterative function.
1511     while( @curr_origin ) {
1512         @curr_origin = $self->_assign_rank( $eqranks, $rankeqs, @curr_origin );
1513     }
1514         return( $eqranks, $rankeqs );
1515 }
1516
1517 sub _assign_rank {
1518     my( $self, $node_ranks, $rank_nodes, @current_nodes ) = @_;
1519     my $graph = $self->equivalence_graph;
1520     # Look at each of the children of @current_nodes.  If all the child's
1521     # parents have a rank, assign it the highest rank + 1 and add it to
1522     # @next_nodes.  Otherwise skip it; we will return when the highest-ranked
1523     # parent gets a rank.
1524     my @next_nodes;
1525     foreach my $c ( @current_nodes ) {
1526         warn "Current reading $c has no rank!"
1527             unless exists $node_ranks->{$c};
1528         foreach my $child ( $graph->successors( $c ) ) {
1529             next if exists $node_ranks->{$child};
1530             my $highest_rank = -1;
1531             my $skip = 0;
1532             foreach my $parent ( $graph->predecessors( $child ) ) {
1533                 if( exists $node_ranks->{$parent} ) {
1534                     $highest_rank = $node_ranks->{$parent}
1535                         if $highest_rank <= $node_ranks->{$parent};
1536                 } else {
1537                     $skip = 1;
1538                     last;
1539                 }
1540             }
1541             next if $skip;
1542             my $c_rank = $highest_rank + 1;
1543             # print STDERR "Assigning rank $c_rank to node $child \n";
1544             $node_ranks->{$child} = $c_rank if $node_ranks;
1545             push( @{$rank_nodes->{$c_rank}}, $child ) if $rank_nodes;
1546             push( @next_nodes, $child );
1547         }
1548     }
1549     return @next_nodes;
1550 }
1551
1552 ### Output logic
1553
1554 sub _as_graphml {
1555         my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_;
1556
1557     my $rgraph = $xmlroot->addNewChild( $graphml_ns, 'graph' );
1558         $rgraph->setAttribute( 'edgedefault', 'directed' );
1559     $rgraph->setAttribute( 'id', 'relationships', );
1560     $rgraph->setAttribute( 'parse.edgeids', 'canonical' );
1561     $rgraph->setAttribute( 'parse.edges', 0 );
1562     $rgraph->setAttribute( 'parse.nodeids', 'canonical' );
1563     $rgraph->setAttribute( 'parse.nodes', 0 );
1564     $rgraph->setAttribute( 'parse.order', 'nodesfirst' );
1565
1566     # Add the vertices according to their XML IDs
1567     my %rdg_lookup = ( reverse %$node_hash );
1568     # my @nlist = sort _by_xmlid keys( %rdg_lookup ); ## CAUSES SEGFAULT
1569     my @nlist = sort keys( %rdg_lookup );
1570     foreach my $n ( @nlist ) {
1571         my $n_el = $rgraph->addNewChild( $graphml_ns, 'node' );
1572         $n_el->setAttribute( 'id', $n );
1573         _add_graphml_data( $n_el, $nodeid_key, $rdg_lookup{$n} );
1574     }
1575         $rgraph->setAttribute( 'parse.nodes', scalar @nlist );
1576
1577     # Add the relationship edges, with their object information
1578     my $edge_ctr = 0;
1579     foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->graph->edges ) {
1580         # Add an edge and fill in its relationship info.
1581         next unless( exists $node_hash->{$e->[0]} && exists $node_hash->{$e->[1]} );
1582                 my $edge_el = $rgraph->addNewChild( $graphml_ns, 'edge' );
1583                 $edge_el->setAttribute( 'source', $node_hash->{$e->[0]} );
1584                 $edge_el->setAttribute( 'target', $node_hash->{$e->[1]} );
1585                 $edge_el->setAttribute( 'id', 'e'.$edge_ctr++ );
1586
1587                 my $rel_obj = $self->get_relationship( @$e );
1588                 foreach my $key ( keys %$edge_keys ) {
1589                         my $value = $rel_obj->$key;
1590                         _add_graphml_data( $edge_el, $edge_keys->{$key}, $value )
1591                                 if defined $value;
1592                 }
1593         }
1594         $rgraph->setAttribute( 'parse.edges', $edge_ctr );
1595 }
1596
1597 sub _by_xmlid {
1598         my $tmp_a = $a;
1599         my $tmp_b = $b;
1600         $tmp_a =~ s/\D//g;
1601         $tmp_b =~ s/\D//g;
1602         return $tmp_a <=> $tmp_b;
1603 }
1604
1605 sub _add_graphml_data {
1606     my( $el, $key, $value ) = @_;
1607     return unless defined $value;
1608     my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
1609     $data_el->setAttribute( 'key', $key );
1610     $data_el->appendText( $value );
1611 }
1612
1613 sub dump_segment {
1614         my( $self, $from, $to ) = @_;
1615         open( DUMP, ">debug.svg" ) or die "Could not open debug.svg";
1616         binmode DUMP, ':utf8';
1617         print DUMP $self->collation->as_svg({ from => $from, to => $to, nocalc => 1 });
1618         close DUMP;
1619 }
1620
1621 sub throw {
1622         Text::Tradition::Error->throw(
1623                 'ident' => 'Relationship error',
1624                 'message' => $_[0],
1625                 );
1626 }
1627
1628 no Moose;
1629 __PACKAGE__->meta->make_immutable;
1630
1631 1;