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: add a parallel but not sibling relationship
 508 $c5->add_relationship( 'r13.6', 'r13.2', { type => 'lexical', propagate => 1 } );
 509 ok( !$c5->get_relationship( 'r13.6', 'r13.1' ),
 510         "Lexical relationship did not affect grammatical" );
 511 foreach my $rdg ( qw/ r13.3 r13.4 r13.5 / ) {
 512         my $newlex = $c5->get_relationship( 'r13.6', $rdg );
 513         ok( $newlex, 'Parallel was made between indirectly linked readings' );
 514         if( $newlex ) {
 515                 is( $newlex->type, 'lexical', 'Implicit parallel-down relationship has the correct type' );
 516         }
 517 }
 518
 519 # Test 5.5: try it with non-colocated relationships
 520 my $numrel = scalar $c5->relationships;
 521 $c5->add_relationship( 'r62.1', 'r64.1', { type => 'transposition', propagate => 1 } );
 522 is( scalar $c5->relationships, $numrel+1,
 523         "Adding non-colo relationship did not propagate" );
 524 # Add a pivot point
 525 $c5->add_relationship( 'r61.1', 'r61.5', { type => 'orthographic' } );
 526 # Add a third transposed node
 527 $c5->add_relationship( 'r62.1', 'r60.3', { type => 'transposition', propagate => 1 } );
 528 my $newtrans = $c5->get_relationship( 'r64.1', 'r60.3' );
 529 ok( $newtrans, 'Non-colo relationship was made between indirectly linked readings' );
 530 if( $newtrans ) {
 531         is( $newtrans->type, 'transposition', 'Implicit non-colo relationship has the correct type' );
 532 }
 533 is( scalar $c5->relationships, $numrel+4,
 534         "Adding non-colo relationship only propagated on non-colos" );
 535
 536
 537 =end testing
 538
 539 =cut
 540
 541 sub add_relationship {
 542         my( $self, $source, $target, $options ) = @_;
 543     my $c = $self->collation;
 544         my $sourceobj = $c->reading( $source );
 545         my $targetobj = $c->reading( $target );
 546         throw( "Adding self relationship at $source" ) if $source eq $target;
 547         throw( "Cannot set relationship on a meta reading" )
 548                 if( $sourceobj->is_meta || $targetobj->is_meta );
 549         my $relationship;
 550         my $reltype;
 551         my $thispaironly = delete $options->{thispaironly};
 552         my $propagate = delete $options->{propagate};
 553         my $droppedcolls = [];
 554         if( ref( $options ) eq 'Text::Tradition::Collation::Relationship' ) {
 555                 $relationship = $options;
 556                 $reltype = $self->type( $relationship->type );
 557                 $thispaironly = 1;  # If existing rel, set only where asked.
 558                 # Test the validity
 559                 my( $is_valid, $reason ) = $self->relationship_valid( $source, $target,
 560                         $relationship->type, $droppedcolls );
 561                 unless( $is_valid ) {
 562                         throw( "Invalid relationship: $reason" );
 563                 }
 564         } else {
 565                 $reltype = $self->type( $options->{type} );
 566
 567                 # Try to create the relationship object.
 568                 my $rdga = $reltype->regularize( $sourceobj );
 569                 my $rdgb = $reltype->regularize( $targetobj );
 570                 $options->{'orig_a'} = $sourceobj;
 571                 $options->{'orig_b'} = $targetobj;
 572                 $options->{'reading_a'} = $rdga;
 573                 $options->{'reading_b'} = $rdgb;
 574         if( exists $options->{'scope'} && $options->{'scope'} ne 'local' ) {
 575                         # Is there a relationship with this a & b already?
 576                         if( $rdga eq $rdgb ) {
 577                                 # If we have canonified to the same thing for the relationship
 578                                 # type we want, something is wrong.
 579                                 # NOTE we want to allow this at the local level, as a cheap means
 580                                 # of merging readings in the UI, until we get a better means.
 581                                 throw( "Canonifier returns identical form $rdga for this relationship type" );
 582                         }
 583
 584                         my $otherrel = $self->scoped_relationship( $rdga, $rdgb );
 585                         if( $otherrel && $otherrel->type eq $options->{type}
 586                                 && $otherrel->scope eq $options->{scope} ) {
 587                                 # warn "Applying existing scoped relationship for $rdga / $rdgb";
 588                                 $relationship = $otherrel;
 589                         } elsif( $otherrel ) {
 590                                 throw( 'Conflicting scoped relationship '
 591                                         . join( '/', $otherrel->type, $otherrel->scope ) . ' vs. '
 592                                         . join( '/', $options->{type}, $options->{scope} )
 593                                         . " for $rdga / $rdgb at $source / $target" );
 594                         }
 595         }
 596                 $relationship = $self->create( $options ) unless $relationship;
 597                 # ... Will throw on error
 598
 599                 # See if the relationship is actually valid here
 600                 my( $is_valid, $reason ) = $self->relationship_valid( $source, $target,
 601                         $options->{'type'}, $droppedcolls );
 602                 unless( $is_valid ) {
 603                         throw( "Invalid relationship: $reason" );
 604                 }
 605     }
 606
 607
 608     # Now set the relationship(s).
 609     my @pairs_set;
 610         my $rel = $self->get_relationship( $source, $target );
 611         my $skip;
 612         if( $rel && $rel ne $relationship ) {
 613                 if( $rel->nonlocal ) {
 614                         throw( "Found conflicting relationship at $source - $target" );
 615                 } elsif( !$reltype->is_weak ) {
 616                         # Replace a weak relationship; leave any other sort in place.
 617                         my $r1ann = $rel->has_annotation ? $rel->annotation : '';
 618                         my $r2ann = $relationship->has_annotation ? $relationship->annotation : '';
 619                         unless( $rel->type eq $relationship->type && $r1ann eq $r2ann ) {
 620                                 warn sprintf( "Not overriding local relationship %s with global %s "
 621                                         . "set at %s -> %s (%s -> %s)", $rel->type, $relationship->type,
 622                                         $source, $target, $rel->reading_a, $rel->reading_b );
 623                         }
 624                         $skip = 1;
 625                 }
 626         }
 627         $self->_set_relationship( $relationship, $source, $target ) unless $skip;
 628         push( @pairs_set, [ $source, $target, $relationship->type ] );
 629
 630         # Find all the pairs for which we need to set the relationship.
 631     if( $relationship->colocated && $relationship->nonlocal && !$thispaironly ) {
 632         my @global_set = $self->add_global_relationship( $relationship );
 633         map { push( @$_, $relationship->type ) } @global_set;
 634                 push( @pairs_set, @global_set );
 635     }
 636     if( $propagate ) {
 637                 my @prop;
 638         foreach my $ps ( @pairs_set ) {
 639                 my @extra = $self->propagate_relationship( $ps->[0], $ps->[1] );
 640                 push( @prop, @extra );
 641         }
 642         push( @pairs_set, @prop ) if @prop;
 643     }
 644
 645     # Finally, restore whatever collations we can, and return.
 646     $self->_restore_weak( @$droppedcolls );
 647     return @pairs_set;
 648 }
 649
 650 =head2 add_global_relationship( $options, $skipvector )
 651
 652 Adds the relationship specified wherever the relevant readings appear together
 653 in the graph.  Options as in add_relationship above.
 654
 655 =cut
 656
 657 sub add_global_relationship {
 658         my( $self, $relationship ) = @_;
 659         # Sanity checking
 660         my $reltype = $self->type( $relationship->type );
 661         throw( "Relationship passed to add_global is not global" )
 662                 unless $relationship->nonlocal;
 663         throw( "Relationship passed to add_global is not a valid global type" )
 664                 unless $reltype->is_generalizable;
 665
 666         # Apply the relationship wherever it is valid
 667         my @pairs_set;
 668     foreach my $v ( $self->_find_applicable( $relationship ) ) {
 669         my $exists = $self->get_relationship( @$v );
 670         my $etype = $exists ? $self->type( $exists->type ) : '';
 671         if( $exists && !$etype->is_weak ) {
 672                         unless( $exists->is_equivalent( $relationship ) ) {
 673                         throw( "Found conflicting relationship at @$v" );
 674                 }
 675         } else {
 676                 my @added;
 677                 try {
 678                         @added = $self->add_relationship( @$v, $relationship );
 679                     } catch {
 680                         my $reldesc = sprintf( "%s %s -> %s", $relationship->type,
 681                                 $relationship->reading_a, $relationship->reading_b );
 682                         # print STDERR "Global relationship $reldesc not applicable at @$v\n";
 683                     }
 684                 push( @pairs_set, @added ) if @added;
 685         }
 686     }
 687         return @pairs_set;
 688 }
 689
 690
 691 =head2 del_scoped_relationship( $reading_a, $reading_b )
 692
 693 Returns the general (document-level or global) relationship that has been defined
 694 between the two reading strings. Returns undef if there is no general relationship.
 695
 696 =cut
 697
 698 sub del_scoped_relationship {
 699         my( $self, $rdga, $rdgb ) = @_;
 700         my( $first, $second ) = sort( $rdga, $rdgb );
 701         return delete $self->scopedrels->{$first}->{$second};
 702 }
 703
 704 sub _find_applicable {
 705         my( $self, $rel ) = @_;
 706         my $c = $self->collation;
 707         my $reltype = $self->type( $rel->type );
 708         my @vectors;
 709         my @identical_readings;
 710         @identical_readings = grep { $reltype->regularize( $_ ) eq $rel->reading_a }
 711                 $c->readings;
 712         foreach my $ir ( @identical_readings ) {
 713                 my @itarget;
 714                 @itarget = grep { $reltype->regularize( $_ ) eq $rel->reading_b }
 715                         $c->readings_at_rank( $ir->rank );
 716                 if( @itarget ) {
 717                         # Warn if there is more than one hit with no closer link between them.
 718                         my $itmain = shift @itarget;
 719                         if( @itarget ) {
 720                                 my %all_targets;
 721                                 my $bindlevel = $reltype->bindlevel;
 722                                 map { $all_targets{$_} = 1 } @itarget;
 723                                 map { delete $all_targets{$_} }
 724                                         $self->related_readings( $itmain, sub {
 725                                                 $self->type( $_[0]->type )->bindlevel < $bindlevel } );
 726                         warn "More than one unrelated reading with text " . $itmain->text
 727                                 . " at rank " . $ir->rank . "!" if keys %all_targets;
 728                         }
 729                         push( @vectors, [ $ir->id, $itmain->id ] );
 730                 }
 731         }
 732         return @vectors;
 733 }
 734
 735 =head2 del_relationship( $source, $target )
 736
 737 Removes the relationship between the given readings. If the relationship is
 738 non-local, removes the relationship everywhere in the graph.
 739
 740 =cut
 741
 742 sub del_relationship {
 743         my( $self, $source, $target ) = @_;
 744         my $rel = $self->get_relationship( $source, $target );
 745         return () unless $rel; # Nothing to delete; return an empty set.
 746         my $reltype = $self->type( $rel->type );
 747         my $colo = $rel->colocated;
 748         my @vectors = ( [ $source, $target ] );
 749         $self->_remove_relationship( $colo, $source, $target );
 750         if( $rel->nonlocal ) {
 751                 # Remove the relationship wherever it occurs.
 752                 my @rel_edges = grep { $self->get_relationship( @$_ ) eq $rel }
 753                         $self->relationships;
 754                 foreach my $re ( @rel_edges ) {
 755                         $self->_remove_relationship( $colo, @$re );
 756                         push( @vectors, $re );
 757                 }
 758                 $self->del_scoped_relationship( $rel->reading_a, $rel->reading_b );
 759         }
 760         return @vectors;
 761 }
 762
 763 sub _remove_relationship {
 764         my( $self, $equiv, @vector ) = @_;
 765         $self->graph->delete_edge( @vector );
 766         $self->_break_equivalence( @vector ) if $equiv;
 767 }
 768
 769 =head2 relationship_valid( $source, $target, $type )
 770
 771 Checks whether a relationship of type $type may exist between the readings given
 772 in $source and $target.  Returns a tuple of ( status, message ) where status is
 773 a yes/no boolean and, if the answer is no, message gives the reason why.
 774
 775 =cut
 776
 777 sub relationship_valid {
 778     my( $self, $source, $target, $rel, $mustdrop ) = @_;
 779     $mustdrop = [] unless $mustdrop; # in case we were passed nothing
 780     my $c = $self->collation;
 781     my $reltype = $self->type( $rel );
 782     ## Assume validity is okay if we are initializing from scratch.
 783     return ( 1, "initializing" ) unless $c->tradition->_initialized;
 784     ## TODO Move this block to relationship type definition when we can save
 785     ## coderefs
 786     if ( $rel eq 'transposition' || $rel eq 'repetition' ) {
 787                 # Check that the two readings do (for a repetition) or do not (for
 788                 # a transposition) appear in the same witness.
 789                 # TODO this might be called before witness paths are set...
 790                 my %seen_wits;
 791                 map { $seen_wits{$_} = 1 } $c->reading_witnesses( $source );
 792                 foreach my $w ( $c->reading_witnesses( $target ) ) {
 793                         if( $seen_wits{$w} ) {
 794                                 return ( 0, "Readings both occur in witness $w" )
 795                                         if $rel eq 'transposition';
 796                                 return ( 1, "ok" ) if $rel eq 'repetition';
 797                         }
 798                 }
 799                 return ( 0, "Readings occur only in distinct witnesses" )
 800                         if $rel eq 'repetition';
 801         }
 802         if ( $reltype->is_colocation ) {
 803                 # Check that linking the source and target in a relationship won't lead
 804                 # to a path loop for any witness.
 805                 # First, drop/stash any collations that might interfere
 806                 my $sourceobj = $c->reading( $source );
 807                 my $targetobj = $c->reading( $target );
 808                 my $sourcerank = $sourceobj->has_rank ? $sourceobj->rank : -1;
 809                 my $targetrank = $targetobj->has_rank ? $targetobj->rank : -1;
 810                 unless( $rel eq 'collated' || $sourcerank == $targetrank ) {
 811                         push( @$mustdrop, $self->_drop_weak( $source ) );
 812                         push( @$mustdrop, $self->_drop_weak( $target ) );
 813                         if( $c->end->has_rank ) {
 814                                 foreach my $rk ( $sourcerank .. $targetrank ) {
 815                                         map { push( @$mustdrop, $self->_drop_weak( $_->id ) ) }
 816                                                 $c->readings_at_rank( $rk );
 817                                 }
 818                         }
 819                 }
 820                 unless( $self->test_equivalence( $source, $target ) ) {
 821                         $self->_restore_weak( @$mustdrop );
 822                         return( 0, "Relationship would create witness loop" );
 823                 }
 824                 return ( 1, "ok" );
 825         } else {
 826                 # We also need to check that the readings are not in the same place.
 827                 # That is, proposing to equate them should cause a witness loop.
 828                 if( $self->test_equivalence( $source, $target ) ) {
 829                         return ( 0, "Readings appear to be colocated" );
 830                 } else {
 831                         return ( 1, "ok" );
 832                 }
 833         }
 834 }
 835
 836 sub _drop_weak {
 837         my( $self, $reading ) = @_;
 838         my @dropped;
 839         foreach my $n ( $self->graph->neighbors( $reading ) ) {
 840                 my $nrel = $self->get_relationship( $reading, $n );
 841                 if( $self->type( $nrel->type )->is_weak ) {
 842                         push( @dropped, [ $reading, $n, $nrel->type ] );
 843                         $self->del_relationship( $reading, $n );
 844                         #print STDERR "Dropped weak relationship $reading -> $n\n";
 845                 }
 846         }
 847         return @dropped;
 848 }
 849
 850 sub _restore_weak {
 851         my( $self, @vectors ) = @_;
 852         foreach my $v ( @vectors ) {
 853                 my $type = pop @$v;
 854                 eval {
 855                         $self->add_relationship( @$v, { 'type' => $type } );
 856                         #print STDERR "Restored weak relationship @$v\n";
 857                 }; # if it fails we don't care
 858         }
 859 }
 860
 861 =head2 related_readings( $reading, $filter )
 862
 863 Returns a list of readings that are connected via direct relationship links
 864 to $reading. If $filter is set to a subroutine ref, returns only those
 865 related readings where $filter( $relationship ) returns a true value.
 866
 867 =cut
 868
 869 sub related_readings {
 870         my( $self, $reading, $filter ) = @_;
 871         my $return_object;
 872         if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
 873                 $reading = $reading->id;
 874                 $return_object = 1;
 875         }
 876         my @answer;
 877         if( $filter ) {
 878                 # Backwards compat
 879                 if( $filter eq 'colocated' ) {
 880                         $filter = sub { $_[0]->colocated };
 881                 } elsif( !ref( $filter ) ) {
 882                         my $type = $filter;
 883                         $filter = sub { $_[0]->type eq $type };
 884                 }
 885                 @answer = grep { &$filter( $self->get_relationship( $reading, $_ ) ) }
 886                         $self->graph->neighbors( $reading );
 887         } else {
 888                 @answer = $self->graph->neighbors( $reading );
 889         }
 890         if( $return_object ) {
 891                 my $c = $self->collation;
 892                 return map { $c->reading( $_ ) } @answer;
 893         } else {
 894                 return @answer;
 895         }
 896 }
 897
 898 =head2 propagate_relationship( $rel )
 899
 900 Apply the transitivity and binding level rules to propagate the consequences of
 901 the specified relationship link, ensuring all consequent relationships exist.
 902 For now, we only propagate colocation links if we are passed a colocation, and
 903 we only propagate displacement links if we are given a displacement.
 904
 905 Returns an array of tuples ( rdg1, rdg2, type ) for each new reading set.
 906
 907 =cut
 908
 909 sub propagate_relationship {
 910         my( $self, @rel ) = @_;
 911         ## Check that the vector is an arrayref
 912         my $rel = @rel > 1 ? \@rel : $rel[0];
 913         ## Get the relationship info
 914         my $relobj = $self->get_relationship( $rel );
 915         my $reltype = $self->type( $relobj->type );
 916         return () unless $reltype->is_transitive;
 917         my @newly_set;
 918
 919         my $colo = $reltype->is_colocation;
 920         my $bindlevel = $reltype->bindlevel;
 921
 922         ## Find all readings that are linked via this relationship type
 923         my %thislevel = ( $rel->[0] => 1, $rel->[1] => 1 );
 924         my $check = $rel;
 925         my $iter = 0;
 926         while( @$check ) {
 927                 my $more = [];
 928                 foreach my $r ( @$check ) {
 929                         push( @$more, grep { !exists $thislevel{$_}
 930                                 && $self->get_relationship( $r, $_ )
 931                                 && $self->get_relationship( $r, $_ )->type eq $relobj->type }
 932                                         $self->graph->neighbors( $r ) );
 933                 }
 934                 map { $thislevel{$_} = 1 } @$more;
 935                 $check = $more;
 936         }
 937
 938         ## Make sure every reading of our relationship type is linked to every other
 939         my @samelevel = keys %thislevel;
 940         while( @samelevel ) {
 941                 my $r = shift @samelevel;
 942                 foreach my $nr ( @samelevel ) {
 943                         my $existing = $self->get_relationship( $r, $nr );
 944                         if( $existing ) {
 945                                 # Check that it's a matching type
 946                                 throw( "Conflicting existing relationship at $r, $nr trying to propagate "
 947                                         . $relobj->type . " relationship at @$rel" )
 948                                         unless $existing->type eq $relobj->type;
 949                         } else {
 950                                 # Try to add a new relationship here
 951                                 try {
 952                                         my @new = $self->add_relationship( $r, $nr, { type => $relobj->type,
 953                                                 annotation => "Propagated from relationship at @$rel" } );
 954                                         push( @newly_set, @new );
 955                                 } catch ( Text::Tradition::Error $e ) {
 956                                         throw( "Could not propagate " . $relobj->type .
 957                                                 " relationship (original @$rel) at $r -- $nr: " .
 958                                                 $e->message );
 959                                 }
 960                         }
 961                 }
 962
 963                 ## Now for each sibling our set, look for its direct connections to
 964                 ## transitive readings of a different bindlevel, and make sure that
 965                 ## all siblings are related to those readings.
 966                 my @other;
 967                 foreach my $n ( $self->graph->neighbors( $r ) ) {
 968                         my $crel = $self->get_relationship( $r, $n );
 969                         next unless $crel;
 970                         my $crt = $self->type( $crel->type );
 971                         if( $crt->is_transitive && $crt->is_colocation == $colo ) {
 972                                 next if $crt->bindlevel == $reltype->bindlevel;
 973                                 my $nrel = $crt->bindlevel < $reltype->bindlevel
 974                                         ? $reltype->name : $crt->name;
 975                                 push( @other, [ $n, $nrel ] );
 976                         }
 977                 }
 978                 # The @other array now contains tuples of ( reading, type ) where the
 979                 # reading is the non-sibling and the type is the type of relationship
 980                 # that the siblings should have to the non-sibling.
 981                 foreach ( @other ) {
 982                         my( $nr, $nrtype ) = @$_;
 983                         foreach my $sib ( keys %thislevel ) {
 984                                 next if $sib eq $r;
 985                                 my $existing = $self->get_relationship( $sib, $nr );
 986                                 if( $existing ) {
 987                                         # Check that it's compatible. The existing relationship type
 988                                         # should match the looser of the two relationships in play,
 989                                         # whether the original relationship being worked on or the
 990                                         # relationship between $r and $or.
 991                                         if( $nrtype ne $existing->type ) {
 992                                                 throw( "Conflicting existing relationship at $nr ( -> "
 993                                                         . $self->get_relationship( $nr, $r )->type . " to $r) "
 994                                                         . " -- $sib trying to propagate " . $relobj->type
 995                                                         . " relationship at @$rel" );
 996                                         }
 997                                 } else {
 998                                         # Try to add a new relationship here
 999                                         try {
1000                                                 my @new = $self->add_relationship( $sib, $nr, { type => $nrtype,
1001                                                         annotation => "Propagated from relationship at @$rel" } );
1002                                                 push( @newly_set, @new );
1003                                         } catch ( Text::Tradition::Error $e ) {
1004                                                 throw( "Could not propagate $nrtype relationship (original " .
1005                                                         $relobj->type . " at @$rel) at $sib -- $nr: " .
1006                                                         $e->message );
1007                                         }
1008                                 }
1009                         }
1010                 }
1011         }
1012
1013         return @newly_set;
1014 }
1015
1016 =head2 merge_readings( $kept, $deleted );
1017
1018 Makes a best-effort merge of the relationship links between the given readings, and
1019 stops tracking the to-be-deleted reading.
1020
1021 =cut
1022
1023 sub merge_readings {
1024         my( $self, $kept, $deleted, $combined ) = @_;
1025         foreach my $edge ( $self->graph->edges_at( $deleted ) ) {
1026                 # Get the pair of kept / rel
1027                 my @vector = ( $kept );
1028                 push( @vector, $edge->[0] eq $deleted ? $edge->[1] : $edge->[0] );
1029                 next if $vector[0] eq $vector[1]; # Don't add a self loop
1030
1031                 # If kept changes its text, drop the relationship.
1032                 next if $combined;
1033
1034                 # If kept / rel already has a relationship, just keep the old
1035                 my $rel = $self->get_relationship( @vector );
1036                 next if $rel;
1037
1038                 # Otherwise, adopt the relationship that would be deleted.
1039                 $rel = $self->get_relationship( @$edge );
1040                 $self->_set_relationship( $rel, @vector );
1041         }
1042         $self->_make_equivalence( $deleted, $kept );
1043 }
1044
1045 ### Equivalence logic
1046
1047 sub _remove_equivalence_node {
1048         my( $self, $node ) = @_;
1049         my $group = $self->equivalence( $node );
1050         my $nodelist = $self->eqreadings( $group );
1051         if( @$nodelist == 1 && $nodelist->[0] eq $node ) {
1052                 $self->equivalence_graph->delete_vertex( $group );
1053                 $self->remove_eqreadings( $group );
1054                 $self->remove_equivalence( $group );
1055         } elsif( @$nodelist == 1 ) {
1056                 throw( "DATA INCONSISTENCY in equivalence graph: " . $nodelist->[0] .
1057                         " in group that should have only $node" );
1058         } else {
1059                 my @newlist = grep { $_ ne $node } @$nodelist;
1060                 $self->set_eqreadings( $group, \@newlist );
1061                 $self->remove_equivalence( $node );
1062         }
1063 }
1064
1065 =head2 add_equivalence_edge
1066
1067 Add an edge in the equivalence graph corresponding to $source -> $target in the
1068 collation. Should only be called by Collation.
1069
1070 =cut
1071
1072 sub add_equivalence_edge {
1073         my( $self, $source, $target ) = @_;
1074         my $seq = $self->equivalence( $source );
1075         my $teq = $self->equivalence( $target );
1076         $self->equivalence_graph->add_edge( $seq, $teq );
1077 }
1078
1079 =head2 delete_equivalence_edge
1080
1081 Remove an edge in the equivalence graph corresponding to $source -> $target in the
1082 collation. Should only be called by Collation.
1083
1084 =cut
1085
1086 sub delete_equivalence_edge {
1087         my( $self, $source, $target ) = @_;
1088         my $seq = $self->equivalence( $source );
1089         my $teq = $self->equivalence( $target );
1090         $self->equivalence_graph->delete_edge( $seq, $teq );
1091 }
1092
1093 sub _is_disconnected {
1094         my $self = shift;
1095         return( scalar $self->equivalence_graph->predecessorless_vertices > 1
1096                 || scalar $self->equivalence_graph->successorless_vertices > 1 );
1097 }
1098
1099 # Equate two readings in the equivalence graph
1100 sub _make_equivalence {
1101         my( $self, $source, $target ) = @_;
1102         # Get the source equivalent readings
1103         my $seq = $self->equivalence( $source );
1104         my $teq = $self->equivalence( $target );
1105         # Nothing to do if they are already equivalent...
1106         return if $seq eq $teq;
1107         my $sourcepool = $self->eqreadings( $seq );
1108         # and add them to the target readings.
1109         push( @{$self->eqreadings( $teq )}, @$sourcepool );
1110         map { $self->set_equivalence( $_, $teq ) } @$sourcepool;
1111         # Then merge the nodes in the equivalence graph.
1112         foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
1113                 $self->equivalence_graph->add_edge( $pred, $teq );
1114         }
1115         foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
1116                 $self->equivalence_graph->add_edge( $teq, $succ );
1117         }
1118         $self->equivalence_graph->delete_vertex( $seq );
1119         # TODO enable this after collation parsing is done
1120         throw( "Graph got disconnected making $source / $target equivalence" )
1121                 if $self->_is_disconnected && $self->collation->tradition->_initialized;
1122 }
1123
1124 =head2 test_equivalence
1125
1126 Test whether, if two readings were equated with a 'colocated' relationship,
1127 the graph would still be valid.
1128
1129 =cut
1130
1131 sub test_equivalence {
1132         my( $self, $source, $target ) = @_;
1133         # Try merging the nodes in the equivalence graph; return a true value if
1134         # no cycle is introduced thereby. Restore the original graph first.
1135
1136         # Keep track of edges we add
1137         my %added_pred;
1138         my %added_succ;
1139         # Get the reading equivalents
1140         my $seq = $self->equivalence( $source );
1141         my $teq = $self->equivalence( $target );
1142         # Maybe this is easy?
1143         return 1 if $seq eq $teq;
1144
1145         # Save the first graph
1146         my $checkstr = $self->equivalence_graph->stringify();
1147         # Add and save relevant edges
1148         foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
1149                 if( $self->equivalence_graph->has_edge( $pred, $teq ) ) {
1150                         $added_pred{$pred} = 0;
1151                 } else {
1152                         $self->equivalence_graph->add_edge( $pred, $teq );
1153                         $added_pred{$pred} = 1;
1154                 }
1155         }
1156         foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
1157                 if( $self->equivalence_graph->has_edge( $teq, $succ ) ) {
1158                         $added_succ{$succ} = 0;
1159                 } else {
1160                         $self->equivalence_graph->add_edge( $teq, $succ );
1161                         $added_succ{$succ} = 1;
1162                 }
1163         }
1164         # Delete source equivalent and test
1165         $self->equivalence_graph->delete_vertex( $seq );
1166         my $ret = !$self->equivalence_graph->has_a_cycle;
1167
1168         # Restore what we changed
1169         $self->equivalence_graph->add_vertex( $seq );
1170         foreach my $pred ( keys %added_pred ) {
1171                 $self->equivalence_graph->add_edge( $pred, $seq );
1172                 $self->equivalence_graph->delete_edge( $pred, $teq ) if $added_pred{$pred};
1173         }
1174         foreach my $succ ( keys %added_succ ) {
1175                 $self->equivalence_graph->add_edge( $seq, $succ );
1176                 $self->equivalence_graph->delete_edge( $teq, $succ ) if $added_succ{$succ};
1177         }
1178         unless( $self->equivalence_graph->eq( $checkstr ) ) {
1179                 throw( "GRAPH CHANGED after testing" );
1180         }
1181         # Return our answer
1182         return $ret;
1183 }
1184
1185 # Unmake an equivalence link between two readings. Should only be called internally.
1186 sub _break_equivalence {
1187         my( $self, $source, $target ) = @_;
1188
1189         # This is the hard one. Need to reconstruct the equivalence groups without
1190         # the given link.
1191         my( %sng, %tng );
1192         map { $sng{$_} = 1 } $self->_find_equiv_without( $source, $target );
1193         map { $tng{$_} = 1 } $self->_find_equiv_without( $target, $source );
1194         # If these groups intersect, they are still connected; do nothing.
1195         foreach my $el ( keys %tng ) {
1196                 return if( exists $sng{$el} );
1197         }
1198         # If they don't intersect, then we split the nodes in the graph and in
1199         # the hashes. First figure out which group has which name
1200         my $oldgroup = $self->equivalence( $source ); # same as $target
1201         my $keepsource = $sng{$oldgroup};
1202         my $newgroup = $keepsource ? $target : $source;
1203         my( $oldmembers, $newmembers );
1204         if( $keepsource ) {
1205                 $oldmembers = [ keys %sng ];
1206                 $newmembers = [ keys %tng ];
1207         } else {
1208                 $oldmembers = [ keys %tng ];
1209                 $newmembers = [ keys %sng ];
1210         }
1211
1212         # First alter the old group in the hash
1213         $self->set_eqreadings( $oldgroup, $oldmembers );
1214         foreach my $el ( @$oldmembers ) {
1215                 $self->set_equivalence( $el, $oldgroup );
1216         }
1217
1218         # then add the new group back to the hash with its new key
1219         $self->set_eqreadings( $newgroup, $newmembers );
1220         foreach my $el ( @$newmembers ) {
1221                 $self->set_equivalence( $el, $newgroup );
1222         }
1223
1224         # Now add the new group back to the equivalence graph
1225         $self->equivalence_graph->add_vertex( $newgroup );
1226         # ...add the appropriate edges to the source group vertext
1227         my $c = $self->collation;
1228         foreach my $rdg ( @$newmembers ) {
1229                 foreach my $rp ( $c->sequence->predecessors( $rdg ) ) {
1230                         next unless $self->equivalence( $rp );
1231                         $self->equivalence_graph->add_edge( $self->equivalence( $rp ), $newgroup );
1232                 }
1233                 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
1234                         next unless $self->equivalence( $rs );
1235                         $self->equivalence_graph->add_edge( $newgroup, $self->equivalence( $rs ) );
1236                 }
1237         }
1238
1239         # ...and figure out which edges on the old group vertex to delete.
1240         my( %old_pred, %old_succ );
1241         foreach my $rdg ( @$oldmembers ) {
1242                 foreach my $rp ( $c->sequence->predecessors( $rdg ) ) {
1243                         next unless $self->equivalence( $rp );
1244                         $old_pred{$self->equivalence( $rp )} = 1;
1245                 }
1246                 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
1247                         next unless $self->equivalence( $rs );
1248                         $old_succ{$self->equivalence( $rs )} = 1;
1249                 }
1250         }
1251         foreach my $p ( $self->equivalence_graph->predecessors( $oldgroup ) ) {
1252                 unless( $old_pred{$p} ) {
1253                         $self->equivalence_graph->delete_edge( $p, $oldgroup );
1254                 }
1255         }
1256         foreach my $s ( $self->equivalence_graph->successors( $oldgroup ) ) {
1257                 unless( $old_succ{$s} ) {
1258                         $self->equivalence_graph->delete_edge( $oldgroup, $s );
1259                 }
1260         }
1261         # TODO enable this after collation parsing is done
1262         throw( "Graph got disconnected breaking $source / $target equivalence" )
1263                 if $self->_is_disconnected && $self->collation->tradition->_initialized;
1264 }
1265
1266 sub _find_equiv_without {
1267         my( $self, $first, $second ) = @_;
1268         my %found = ( $first => 1 );
1269         my $check = [ $first ];
1270         my $iter = 0;
1271         while( @$check ) {
1272                 my $more = [];
1273                 foreach my $r ( @$check ) {
1274                         foreach my $nr ( $self->graph->neighbors( $r ) ) {
1275                                 next if $r eq $second;
1276                                 if( $self->get_relationship( $r, $nr )->colocated ) {
1277                                         push( @$more, $nr ) unless exists $found{$nr};
1278                                         $found{$nr} = 1;
1279                                 }
1280                         }
1281                 }
1282                 $check = $more;
1283         }
1284         return keys %found;
1285 }
1286
1287 =head2 rebuild_equivalence
1288
1289 (Re)build the equivalence graph from scratch. Dumps the graph, makes a new one,
1290 adds all readings and edges, then makes an equivalence for all relationships.
1291
1292 =cut
1293
1294 sub rebuild_equivalence {
1295         my $self = shift;
1296         my $newgraph = Graph->new();
1297         # Set this as the new equivalence graph
1298         $self->_reset_equivalence( $newgraph );
1299         # Clear out the data hashes
1300         $self->_clear_equivalence;
1301         $self->_clear_eqreadings;
1302
1303         $self->collation->tradition->_init_done(0);
1304         # Add the readings
1305         foreach my $r ( $self->collation->readings ) {
1306                 my $rid = $r->id;
1307                 $newgraph->add_vertex( $rid );
1308                 $self->set_equivalence( $rid, $rid );
1309                 $self->set_eqreadings( $rid, [ $rid ] );
1310         }
1311
1312         # Now add the edges
1313         foreach my $e ( $self->collation->paths ) {
1314                 $self->add_equivalence_edge( @$e );
1315         }
1316
1317         # Now equate the colocated readings. This does no testing;
1318         # it assumes that all preexisting relationships are valid.
1319         foreach my $rel ( $self->relationships ) {
1320                 my $relobj = $self->get_relationship( $rel );
1321                 next unless $relobj && $relobj->colocated;
1322                 $self->_make_equivalence( @$rel );
1323         }
1324         $self->collation->tradition->_init_done(1);
1325 }
1326
1327 =head2 equivalence_ranks
1328
1329 Rank all vertices in the equivalence graph, and return a hash reference with
1330 vertex => rank mapping.
1331
1332 =cut
1333
1334 sub equivalence_ranks {
1335         my $self = shift;
1336         my $eqstart = $self->equivalence( $self->collation->start );
1337         my $eqranks = { $eqstart => 0 };
1338         my $rankeqs = { 0 => [ $eqstart ] };
1339         my @curr_origin = ( $eqstart );
1340     # A little iterative function.
1341     while( @curr_origin ) {
1342         @curr_origin = $self->_assign_rank( $eqranks, $rankeqs, @curr_origin );
1343     }
1344         return( $eqranks, $rankeqs );
1345 }
1346
1347 sub _assign_rank {
1348     my( $self, $node_ranks, $rank_nodes, @current_nodes ) = @_;
1349     my $graph = $self->equivalence_graph;
1350     # Look at each of the children of @current_nodes.  If all the child's
1351     # parents have a rank, assign it the highest rank + 1 and add it to
1352     # @next_nodes.  Otherwise skip it; we will return when the highest-ranked
1353     # parent gets a rank.
1354     my @next_nodes;
1355     foreach my $c ( @current_nodes ) {
1356         warn "Current reading $c has no rank!"
1357             unless exists $node_ranks->{$c};
1358         foreach my $child ( $graph->successors( $c ) ) {
1359             next if exists $node_ranks->{$child};
1360             my $highest_rank = -1;
1361             my $skip = 0;
1362             foreach my $parent ( $graph->predecessors( $child ) ) {
1363                 if( exists $node_ranks->{$parent} ) {
1364                     $highest_rank = $node_ranks->{$parent}
1365                         if $highest_rank <= $node_ranks->{$parent};
1366                 } else {
1367                     $skip = 1;
1368                     last;
1369                 }
1370             }
1371             next if $skip;
1372             my $c_rank = $highest_rank + 1;
1373             # print STDERR "Assigning rank $c_rank to node $child \n";
1374             $node_ranks->{$child} = $c_rank if $node_ranks;
1375             push( @{$rank_nodes->{$c_rank}}, $child ) if $rank_nodes;
1376             push( @next_nodes, $child );
1377         }
1378     }
1379     return @next_nodes;
1380 }
1381
1382 ### Output logic
1383
1384 sub _as_graphml {
1385         my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_;
1386
1387     my $rgraph = $xmlroot->addNewChild( $graphml_ns, 'graph' );
1388         $rgraph->setAttribute( 'edgedefault', 'directed' );
1389     $rgraph->setAttribute( 'id', 'relationships', );
1390     $rgraph->setAttribute( 'parse.edgeids', 'canonical' );
1391     $rgraph->setAttribute( 'parse.edges', 0 );
1392     $rgraph->setAttribute( 'parse.nodeids', 'canonical' );
1393     $rgraph->setAttribute( 'parse.nodes', 0 );
1394     $rgraph->setAttribute( 'parse.order', 'nodesfirst' );
1395
1396     # Add the vertices according to their XML IDs
1397     my %rdg_lookup = ( reverse %$node_hash );
1398     # my @nlist = sort _by_xmlid keys( %rdg_lookup ); ## CAUSES SEGFAULT
1399     my @nlist = sort keys( %rdg_lookup );
1400     foreach my $n ( @nlist ) {
1401         my $n_el = $rgraph->addNewChild( $graphml_ns, 'node' );
1402         $n_el->setAttribute( 'id', $n );
1403         _add_graphml_data( $n_el, $nodeid_key, $rdg_lookup{$n} );
1404     }
1405         $rgraph->setAttribute( 'parse.nodes', scalar @nlist );
1406
1407     # Add the relationship edges, with their object information
1408     my $edge_ctr = 0;
1409     foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->graph->edges ) {
1410         # Add an edge and fill in its relationship info.
1411         next unless( exists $node_hash->{$e->[0]} && exists $node_hash->{$e->[1]} );
1412                 my $edge_el = $rgraph->addNewChild( $graphml_ns, 'edge' );
1413                 $edge_el->setAttribute( 'source', $node_hash->{$e->[0]} );
1414                 $edge_el->setAttribute( 'target', $node_hash->{$e->[1]} );
1415                 $edge_el->setAttribute( 'id', 'e'.$edge_ctr++ );
1416
1417                 my $rel_obj = $self->get_relationship( @$e );
1418                 foreach my $key ( keys %$edge_keys ) {
1419                         my $value = $rel_obj->$key;
1420                         _add_graphml_data( $edge_el, $edge_keys->{$key}, $value )
1421                                 if defined $value;
1422                 }
1423         }
1424         $rgraph->setAttribute( 'parse.edges', $edge_ctr );
1425 }
1426
1427 sub _by_xmlid {
1428         my $tmp_a = $a;
1429         my $tmp_b = $b;
1430         $tmp_a =~ s/\D//g;
1431         $tmp_b =~ s/\D//g;
1432         return $tmp_a <=> $tmp_b;
1433 }
1434
1435 sub _add_graphml_data {
1436     my( $el, $key, $value ) = @_;
1437     return unless defined $value;
1438     my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
1439     $data_el->setAttribute( 'key', $key );
1440     $data_el->appendText( $value );
1441 }
1442
1443 sub dump_segment {
1444         my( $self, $from, $to ) = @_;
1445         open( DUMP, ">debug.svg" ) or die "Could not open debug.svg";
1446         binmode DUMP, ':utf8';
1447         print DUMP $self->collation->as_svg({ from => $from, to => $to, nocalc => 1 });
1448         close DUMP;
1449 }
1450
1451 sub throw {
1452         Text::Tradition::Error->throw(
1453                 'ident' => 'Relationship error',
1454                 'message' => $_[0],
1455                 );
1456 }
1457
1458 no Moose;
1459 __PACKAGE__->meta->make_immutable;
1460
1461 1;