base/lib/Text/Tradition/Collation/RelationshipStore.pm

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