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