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