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