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 verify_or_delete( $reading1, $reading2 ) {
 951
 952 Given the existing relationship at ( $reading1, $reading2 ), make sure it is
 953 still valid. If it is not still valid, delete it. Use this only to check
 954 non-colocated relationships!
 955
 956 =cut
 957
 958 sub verify_or_delete {
 959         my( $self, @vector ) = @_;
 960         my $rel = $self->get_relationship( @vector );
 961         throw( "You should not now be verifying colocated relationships!" )
 962                 if $rel->colocated;
 963         my( $ok, $reason ) = $self->relationship_valid( @vector, $rel->type );
 964         unless( $ok ) {
 965                 $self->del_relationship( @vector );
 966         }
 967 }
 968
 969
 970 =head2 related_readings( $reading, $filter )
 971
 972 Returns a list of readings that are connected via direct relationship links
 973 to $reading. If $filter is set to a subroutine ref, returns only those
 974 related readings where $filter( $relationship ) returns a true value.
 975
 976 =cut
 977
 978 sub related_readings {
 979         my( $self, $reading, $filter ) = @_;
 980         my $return_object;
 981         if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
 982                 $reading = $reading->id;
 983                 $return_object = 1;
 984         }
 985         my @answer;
 986         if( $filter ) {
 987                 # Backwards compat
 988                 if( $filter eq 'colocated' ) {
 989                         $filter = sub { $_[0]->colocated };
 990                 } elsif( !ref( $filter ) ) {
 991                         my $type = $filter;
 992                         $filter = sub { $_[0]->type eq $type };
 993                 }
 994                 @answer = grep { &$filter( $self->get_relationship( $reading, $_ ) ) }
 995                         $self->graph->neighbors( $reading );
 996         } else {
 997                 @answer = $self->graph->neighbors( $reading );
 998         }
 999         if( $return_object ) {
1000                 my $c = $self->collation;
1001                 return map { $c->reading( $_ ) } @answer;
1002         } else {
1003                 return @answer;
1004         }
1005 }
1006
1007 =head2 propagate_relationship( $rel )
1008
1009 Apply the transitivity and binding level rules to propagate the consequences of
1010 the specified relationship link, ensuring all consequent relationships exist.
1011 For now, we only propagate colocation links if we are passed a colocation, and
1012 we only propagate displacement links if we are given a displacement.
1013
1014 Returns an array of tuples ( rdg1, rdg2, type ) for each new reading set.
1015
1016 =cut
1017
1018 sub propagate_relationship {
1019         my( $self, @rel ) = @_;
1020         ## Check that the vector is an arrayref
1021         my $rel = @rel > 1 ? \@rel : $rel[0];
1022         ## Get the relationship info
1023         my $relobj = $self->get_relationship( $rel );
1024         my $reltype = $self->type( $relobj->type );
1025         return () unless $reltype->is_transitive;
1026         my @newly_set;
1027
1028         my $colo = $reltype->is_colocation;
1029         my $bindlevel = $reltype->bindlevel;
1030
1031         ## Find all readings that are linked via this relationship type
1032         my %thislevel = ( $rel->[0] => 1, $rel->[1] => 1 );
1033         my $check = $rel;
1034         my $iter = 0;
1035         while( @$check ) {
1036                 my $more = [];
1037                 foreach my $r ( @$check ) {
1038                         push( @$more, grep { !exists $thislevel{$_}
1039                                 && $self->get_relationship( $r, $_ )
1040                                 && $self->get_relationship( $r, $_ )->type eq $relobj->type }
1041                                         $self->graph->neighbors( $r ) );
1042                 }
1043                 map { $thislevel{$_} = 1 } @$more;
1044                 $check = $more;
1045         }
1046
1047         ## Make sure every reading of our relationship type is linked to every other
1048         my @samelevel = keys %thislevel;
1049         while( @samelevel ) {
1050                 my $r = shift @samelevel;
1051                 foreach my $nr ( @samelevel ) {
1052                         my $existing = $self->get_relationship( $r, $nr );
1053                         my $skip;
1054                         if( $existing ) {
1055                                 my $extype = $self->type( $existing->type );
1056                                 unless( $extype->is_weak ) {
1057                                         # Check that it's a matching type, or a type subsumed by our
1058                                         # bindlevel
1059                                         throw( "Conflicting existing relationship of type "
1060                                                 . $existing->type . " at $r, $nr trying to propagate "
1061                                                 . $relobj->type . " relationship at @$rel" )
1062                                                 unless $existing->type eq $relobj->type
1063                                                         || $extype->bindlevel <= $reltype->bindlevel;
1064                                         $skip = 1;
1065                                 }
1066                         }
1067                         unless( $skip ) {
1068                                 # Try to add a new relationship here
1069                                 try {
1070                                         my @new = $self->add_relationship( $r, $nr, { type => $relobj->type,
1071                                                 annotation => "Propagated from relationship at @$rel" } );
1072                                         push( @newly_set, @new );
1073                                 } catch ( Text::Tradition::Error $e ) {
1074                                         throw( "Could not propagate " . $relobj->type .
1075                                                 " relationship (original @$rel) at $r -- $nr: " .
1076                                                 $e->message );
1077                                 }
1078                         }
1079                 }
1080
1081                 ## Now for each sibling our set, look for its direct connections to
1082                 ## transitive readings of a different bindlevel, and make sure that
1083                 ## all siblings are related to those readings.
1084                 my @other;
1085                 foreach my $n ( $self->graph->neighbors( $r ) ) {
1086                         my $crel = $self->get_relationship( $r, $n );
1087                         next unless $crel;
1088                         my $crt = $self->type( $crel->type );
1089                         if( $crt->is_transitive && $crt->is_colocation == $colo ) {
1090                                 next if $crt->bindlevel == $reltype->bindlevel;
1091                                 my $nrel = $crt->bindlevel < $reltype->bindlevel
1092                                         ? $reltype->name : $crt->name;
1093                                 push( @other, [ $n, $nrel ] );
1094                         }
1095                 }
1096                 # The @other array now contains tuples of ( reading, type ) where the
1097                 # reading is the non-sibling and the type is the type of relationship
1098                 # that the siblings should have to the non-sibling.
1099                 foreach ( @other ) {
1100                         my( $nr, $nrtype ) = @$_;
1101                         foreach my $sib ( keys %thislevel ) {
1102                                 next if $sib eq $r;
1103                                 next if $sib eq $nr; # can happen if linked to $r by tightrel
1104                                                                          # but linked to a sib of $r by thisrel
1105                                                                          # e.g. when a rel has been part propagated
1106                                 my $existing = $self->get_relationship( $sib, $nr );
1107                                 my $skip;
1108                                 if( $existing ) {
1109                                         # Check that it's compatible. The existing relationship type
1110                                         # should match or be subsumed by the looser of the two
1111                                         # relationships in play, whether the original relationship
1112                                         # being worked on or the relationship between $r and $or.
1113                                         my $extype = $self->type( $existing->type );
1114                                         unless( $extype->is_weak ) {
1115                                                 if( $nrtype ne $extype->name
1116                                                         && $self->type( $nrtype )->bindlevel <= $extype->bindlevel ) {
1117                                                         throw( "Conflicting existing relationship at $nr ( -> "
1118                                                                 . $self->get_relationship( $nr, $r )->type . " to $r) "
1119                                                                 . " -- $sib trying to propagate " . $relobj->type
1120                                                                 . " relationship at @$rel" );
1121                                                 }
1122                                                 $skip = 1;
1123                                         }
1124                                 }
1125                                 unless( $skip ) {
1126                                         # Try to add a new relationship here
1127                                         try {
1128                                                 my @new = $self->add_relationship( $sib, $nr, { type => $nrtype,
1129                                                         annotation => "Propagated from relationship at @$rel" } );
1130                                                 push( @newly_set, @new );
1131                                         } catch ( Text::Tradition::Error $e ) {
1132                                                 throw( "Could not propagate $nrtype relationship (original " .
1133                                                         $relobj->type . " at @$rel) at $sib -- $nr: " .
1134                                                         $e->message );
1135                                         }
1136                                 }
1137                         }
1138                 }
1139         }
1140
1141         return @newly_set;
1142 }
1143
1144 =head2 propagate_all_relationships
1145
1146 Apply propagation logic retroactively to all relationships in the tradition.
1147
1148 =cut
1149
1150 sub propagate_all_relationships {
1151         my $self = shift;
1152         my @allrels = sort { $self->_propagate_rel_order( $a, $b ) } $self->relationships;
1153         foreach my $rel ( @allrels ) {
1154                 my $relobj = $self->get_relationship( $rel );
1155                 if( $self->type( $relobj->type )->is_transitive ) {
1156                         my @added = $self->propagate_relationship( $rel );
1157                 }
1158         }
1159 }
1160
1161 # Helper sorting function for retroactive propagation order.
1162 sub _propagate_rel_order {
1163         my( $self, $a, $b ) = @_;
1164         my $aobj = $self->get_relationship( $a );
1165         my $bobj = $self->get_relationship( $b );
1166         my $at = $self->type( $aobj->type ); my $bt = $self->type( $bobj->type );
1167         # Apply strong relationships before weak
1168         return -1 if $bt->is_weak && !$at->is_weak;
1169         return 1 if $at->is_weak && !$bt->is_weak;
1170         # Apply more tightly bound relationships first
1171         return $at->bindlevel <=> $bt->bindlevel;
1172 }
1173
1174
1175 =head2 merge_readings( $kept, $deleted );
1176
1177 Makes a best-effort merge of the relationship links between the given readings, and
1178 stops tracking the to-be-deleted reading.
1179
1180 =cut
1181
1182 sub merge_readings {
1183         my( $self, $kept, $deleted, $combined ) = @_;
1184         foreach my $edge ( $self->graph->edges_at( $deleted ) ) {
1185                 # Get the pair of kept / rel
1186                 my @vector = ( $kept );
1187                 push( @vector, $edge->[0] eq $deleted ? $edge->[1] : $edge->[0] );
1188                 next if $vector[0] eq $vector[1]; # Don't add a self loop
1189
1190                 # If kept changes its text, drop the relationship.
1191                 next if $combined;
1192
1193                 # If kept / rel already has a relationship, just keep the old
1194                 my $rel = $self->get_relationship( @vector );
1195                 next if $rel;
1196
1197                 # Otherwise, adopt the relationship that would be deleted.
1198                 $rel = $self->get_relationship( @$edge );
1199                 $self->_set_relationship( $rel, @vector );
1200         }
1201         $self->_make_equivalence( $deleted, $kept );
1202 }
1203
1204 ### Equivalence logic
1205
1206 sub _remove_equivalence_node {
1207         my( $self, $node ) = @_;
1208         my $group = $self->equivalence( $node );
1209         my $nodelist = $self->eqreadings( $group );
1210         if( @$nodelist == 1 && $nodelist->[0] eq $node ) {
1211                 $self->equivalence_graph->delete_vertex( $group );
1212                 $self->remove_eqreadings( $group );
1213                 $self->remove_equivalence( $group );
1214         } elsif( @$nodelist == 1 ) {
1215                 throw( "DATA INCONSISTENCY in equivalence graph: " . $nodelist->[0] .
1216                         " in group that should have only $node" );
1217         } else {
1218                 my @newlist = grep { $_ ne $node } @$nodelist;
1219                 $self->set_eqreadings( $group, \@newlist );
1220                 $self->remove_equivalence( $node );
1221         }
1222 }
1223
1224 =head2 add_equivalence_edge
1225
1226 Add an edge in the equivalence graph corresponding to $source -> $target in the
1227 collation. Should only be called by Collation.
1228
1229 =cut
1230
1231 sub add_equivalence_edge {
1232         my( $self, $source, $target ) = @_;
1233         my $seq = $self->equivalence( $source );
1234         my $teq = $self->equivalence( $target );
1235         $self->equivalence_graph->add_edge( $seq, $teq );
1236 }
1237
1238 =head2 delete_equivalence_edge
1239
1240 Remove an edge in the equivalence graph corresponding to $source -> $target in the
1241 collation. Should only be called by Collation.
1242
1243 =cut
1244
1245 sub delete_equivalence_edge {
1246         my( $self, $source, $target ) = @_;
1247         my $seq = $self->equivalence( $source );
1248         my $teq = $self->equivalence( $target );
1249         $self->equivalence_graph->delete_edge( $seq, $teq );
1250 }
1251
1252 sub _is_disconnected {
1253         my $self = shift;
1254         return( scalar $self->equivalence_graph->predecessorless_vertices > 1
1255                 || scalar $self->equivalence_graph->successorless_vertices > 1 );
1256 }
1257
1258 # Equate two readings in the equivalence graph
1259 sub _make_equivalence {
1260         my( $self, $source, $target ) = @_;
1261         # Get the source equivalent readings
1262         my $seq = $self->equivalence( $source );
1263         my $teq = $self->equivalence( $target );
1264         # Nothing to do if they are already equivalent...
1265         return if $seq eq $teq;
1266         my $sourcepool = $self->eqreadings( $seq );
1267         # and add them to the target readings.
1268         push( @{$self->eqreadings( $teq )}, @$sourcepool );
1269         map { $self->set_equivalence( $_, $teq ) } @$sourcepool;
1270         # Then merge the nodes in the equivalence graph.
1271         foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
1272                 $self->equivalence_graph->add_edge( $pred, $teq );
1273         }
1274         foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
1275                 $self->equivalence_graph->add_edge( $teq, $succ );
1276         }
1277         $self->equivalence_graph->delete_vertex( $seq );
1278         # TODO enable this after collation parsing is done
1279         throw( "Graph got disconnected making $source / $target equivalence" )
1280                 if $self->_is_disconnected && $self->collation->tradition->_initialized;
1281 }
1282
1283 =head2 test_equivalence
1284
1285 Test whether, if two readings were equated with a 'colocated' relationship,
1286 the graph would still be valid.
1287
1288 =cut
1289
1290 # TODO Used the 'is_reachable' method; it killed performance. Think about doing away
1291 # with the equivalence graph in favor of a transitive closure graph (calculated ONCE)
1292 # on the sequence graph, and test that way.
1293
1294 sub test_equivalence {
1295         my( $self, $source, $target ) = @_;
1296         # Try merging the nodes in the equivalence graph; return a true value if
1297         # no cycle is introduced thereby. Restore the original graph first.
1298
1299         # Keep track of edges we add
1300         my %added_pred;
1301         my %added_succ;
1302         # Get the reading equivalents
1303         my $seq = $self->equivalence( $source );
1304         my $teq = $self->equivalence( $target );
1305         # Maybe this is easy?
1306         return 1 if $seq eq $teq;
1307
1308         # Save the first graph
1309         my $checkstr = $self->equivalence_graph->stringify();
1310         # Add and save relevant edges
1311         foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
1312                 if( $self->equivalence_graph->has_edge( $pred, $teq ) ) {
1313                         $added_pred{$pred} = 0;
1314                 } else {
1315                         $self->equivalence_graph->add_edge( $pred, $teq );
1316                         $added_pred{$pred} = 1;
1317                 }
1318         }
1319         foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
1320                 if( $self->equivalence_graph->has_edge( $teq, $succ ) ) {
1321                         $added_succ{$succ} = 0;
1322                 } else {
1323                         $self->equivalence_graph->add_edge( $teq, $succ );
1324                         $added_succ{$succ} = 1;
1325                 }
1326         }
1327         # Delete source equivalent and test
1328         $self->equivalence_graph->delete_vertex( $seq );
1329         my $ret = !$self->equivalence_graph->has_a_cycle;
1330
1331         # Restore what we changed
1332         $self->equivalence_graph->add_vertex( $seq );
1333         foreach my $pred ( keys %added_pred ) {
1334                 $self->equivalence_graph->add_edge( $pred, $seq );
1335                 $self->equivalence_graph->delete_edge( $pred, $teq ) if $added_pred{$pred};
1336         }
1337         foreach my $succ ( keys %added_succ ) {
1338                 $self->equivalence_graph->add_edge( $seq, $succ );
1339                 $self->equivalence_graph->delete_edge( $teq, $succ ) if $added_succ{$succ};
1340         }
1341         unless( $self->equivalence_graph->eq( $checkstr ) ) {
1342                 throw( "GRAPH CHANGED after testing" );
1343         }
1344         # Return our answer
1345         return $ret;
1346 }
1347
1348 # Unmake an equivalence link between two readings. Should only be called internally.
1349 sub _break_equivalence {
1350         my( $self, $source, $target ) = @_;
1351
1352         # This is the hard one. Need to reconstruct the equivalence groups without
1353         # the given link.
1354         my( %sng, %tng );
1355         map { $sng{$_} = 1 } $self->_find_equiv_without( $source, $target );
1356         map { $tng{$_} = 1 } $self->_find_equiv_without( $target, $source );
1357         # If these groups intersect, they are still connected; do nothing.
1358         foreach my $el ( keys %tng ) {
1359                 return if( exists $sng{$el} );
1360         }
1361         # If they don't intersect, then we split the nodes in the graph and in
1362         # the hashes. First figure out which group has which name
1363         my $oldgroup = $self->equivalence( $source ); # same as $target
1364         my $keepsource = $sng{$oldgroup};
1365         my $newgroup = $keepsource ? $target : $source;
1366         my( $oldmembers, $newmembers );
1367         if( $keepsource ) {
1368                 $oldmembers = [ keys %sng ];
1369                 $newmembers = [ keys %tng ];
1370         } else {
1371                 $oldmembers = [ keys %tng ];
1372                 $newmembers = [ keys %sng ];
1373         }
1374
1375         # First alter the old group in the hash
1376         $self->set_eqreadings( $oldgroup, $oldmembers );
1377         foreach my $el ( @$oldmembers ) {
1378                 $self->set_equivalence( $el, $oldgroup );
1379         }
1380
1381         # then add the new group back to the hash with its new key
1382         $self->set_eqreadings( $newgroup, $newmembers );
1383         foreach my $el ( @$newmembers ) {
1384                 $self->set_equivalence( $el, $newgroup );
1385         }
1386
1387         # Now add the new group back to the equivalence graph
1388         $self->equivalence_graph->add_vertex( $newgroup );
1389         # ...add the appropriate edges to the source group vertext
1390         my $c = $self->collation;
1391         foreach my $rdg ( @$newmembers ) {
1392                 foreach my $rp ( $c->sequence->predecessors( $rdg ) ) {
1393                         next unless $self->equivalence( $rp );
1394                         $self->equivalence_graph->add_edge( $self->equivalence( $rp ), $newgroup );
1395                 }
1396                 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
1397                         next unless $self->equivalence( $rs );
1398                         $self->equivalence_graph->add_edge( $newgroup, $self->equivalence( $rs ) );
1399                 }
1400         }
1401
1402         # ...and figure out which edges on the old group vertex to delete.
1403         my( %old_pred, %old_succ );
1404         foreach my $rdg ( @$oldmembers ) {
1405                 foreach my $rp ( $c->sequence->predecessors( $rdg ) ) {
1406                         next unless $self->equivalence( $rp );
1407                         $old_pred{$self->equivalence( $rp )} = 1;
1408                 }
1409                 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
1410                         next unless $self->equivalence( $rs );
1411                         $old_succ{$self->equivalence( $rs )} = 1;
1412                 }
1413         }
1414         foreach my $p ( $self->equivalence_graph->predecessors( $oldgroup ) ) {
1415                 unless( $old_pred{$p} ) {
1416                         $self->equivalence_graph->delete_edge( $p, $oldgroup );
1417                 }
1418         }
1419         foreach my $s ( $self->equivalence_graph->successors( $oldgroup ) ) {
1420                 unless( $old_succ{$s} ) {
1421                         $self->equivalence_graph->delete_edge( $oldgroup, $s );
1422                 }
1423         }
1424         # TODO enable this after collation parsing is done
1425         throw( "Graph got disconnected breaking $source / $target equivalence" )
1426                 if $self->_is_disconnected && $self->collation->tradition->_initialized;
1427 }
1428
1429 sub _find_equiv_without {
1430         my( $self, $first, $second ) = @_;
1431         my %found = ( $first => 1 );
1432         my $check = [ $first ];
1433         my $iter = 0;
1434         while( @$check ) {
1435                 my $more = [];
1436                 foreach my $r ( @$check ) {
1437                         foreach my $nr ( $self->graph->neighbors( $r ) ) {
1438                                 next if $r eq $second;
1439                                 if( $self->get_relationship( $r, $nr )->colocated ) {
1440                                         push( @$more, $nr ) unless exists $found{$nr};
1441                                         $found{$nr} = 1;
1442                                 }
1443                         }
1444                 }
1445                 $check = $more;
1446         }
1447         return keys %found;
1448 }
1449
1450 =head2 rebuild_equivalence
1451
1452 (Re)build the equivalence graph from scratch. Dumps the graph, makes a new one,
1453 adds all readings and edges, then makes an equivalence for all relationships.
1454
1455 =cut
1456
1457 sub rebuild_equivalence {
1458         my $self = shift;
1459         my $newgraph = Graph->new();
1460         # Set this as the new equivalence graph
1461         $self->_reset_equivalence( $newgraph );
1462         # Clear out the data hashes
1463         $self->_clear_equivalence;
1464         $self->_clear_eqreadings;
1465
1466         $self->collation->tradition->_init_done(0);
1467         # Add the readings
1468         foreach my $r ( $self->collation->readings ) {
1469                 my $rid = $r->id;
1470                 $newgraph->add_vertex( $rid );
1471                 $self->set_equivalence( $rid, $rid );
1472                 $self->set_eqreadings( $rid, [ $rid ] );
1473         }
1474
1475         # Now add the edges
1476         foreach my $e ( $self->collation->paths ) {
1477                 $self->add_equivalence_edge( @$e );
1478         }
1479
1480         # Now equate the colocated readings. This does no testing;
1481         # it assumes that all preexisting relationships are valid.
1482         foreach my $rel ( $self->relationships ) {
1483                 my $relobj = $self->get_relationship( $rel );
1484                 next unless $relobj && $relobj->colocated;
1485                 $self->_make_equivalence( @$rel );
1486         }
1487         $self->collation->tradition->_init_done(1);
1488 }
1489
1490 =head2 equivalence_ranks
1491
1492 Rank all vertices in the equivalence graph, and return a hash reference with
1493 vertex => rank mapping.
1494
1495 =cut
1496
1497 sub equivalence_ranks {
1498         my $self = shift;
1499         my $eqstart = $self->equivalence( $self->collation->start );
1500         my $eqranks = { $eqstart => 0 };
1501         my $rankeqs = { 0 => [ $eqstart ] };
1502         my @curr_origin = ( $eqstart );
1503     # A little iterative function.
1504     while( @curr_origin ) {
1505         @curr_origin = $self->_assign_rank( $eqranks, $rankeqs, @curr_origin );
1506     }
1507         return( $eqranks, $rankeqs );
1508 }
1509
1510 sub _assign_rank {
1511     my( $self, $node_ranks, $rank_nodes, @current_nodes ) = @_;
1512     my $graph = $self->equivalence_graph;
1513     # Look at each of the children of @current_nodes.  If all the child's
1514     # parents have a rank, assign it the highest rank + 1 and add it to
1515     # @next_nodes.  Otherwise skip it; we will return when the highest-ranked
1516     # parent gets a rank.
1517     my @next_nodes;
1518     foreach my $c ( @current_nodes ) {
1519         warn "Current reading $c has no rank!"
1520             unless exists $node_ranks->{$c};
1521         foreach my $child ( $graph->successors( $c ) ) {
1522             next if exists $node_ranks->{$child};
1523             my $highest_rank = -1;
1524             my $skip = 0;
1525             foreach my $parent ( $graph->predecessors( $child ) ) {
1526                 if( exists $node_ranks->{$parent} ) {
1527                     $highest_rank = $node_ranks->{$parent}
1528                         if $highest_rank <= $node_ranks->{$parent};
1529                 } else {
1530                     $skip = 1;
1531                     last;
1532                 }
1533             }
1534             next if $skip;
1535             my $c_rank = $highest_rank + 1;
1536             # print STDERR "Assigning rank $c_rank to node $child \n";
1537             $node_ranks->{$child} = $c_rank if $node_ranks;
1538             push( @{$rank_nodes->{$c_rank}}, $child ) if $rank_nodes;
1539             push( @next_nodes, $child );
1540         }
1541     }
1542     return @next_nodes;
1543 }
1544
1545 ### Output logic
1546
1547 sub _as_graphml {
1548         my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_;
1549
1550     my $rgraph = $xmlroot->addNewChild( $graphml_ns, 'graph' );
1551         $rgraph->setAttribute( 'edgedefault', 'directed' );
1552     $rgraph->setAttribute( 'id', 'relationships', );
1553     $rgraph->setAttribute( 'parse.edgeids', 'canonical' );
1554     $rgraph->setAttribute( 'parse.edges', 0 );
1555     $rgraph->setAttribute( 'parse.nodeids', 'canonical' );
1556     $rgraph->setAttribute( 'parse.nodes', 0 );
1557     $rgraph->setAttribute( 'parse.order', 'nodesfirst' );
1558
1559     # Add the vertices according to their XML IDs
1560     my %rdg_lookup = ( reverse %$node_hash );
1561     # my @nlist = sort _by_xmlid keys( %rdg_lookup ); ## CAUSES SEGFAULT
1562     my @nlist = sort keys( %rdg_lookup );
1563     foreach my $n ( @nlist ) {
1564         my $n_el = $rgraph->addNewChild( $graphml_ns, 'node' );
1565         $n_el->setAttribute( 'id', $n );
1566         _add_graphml_data( $n_el, $nodeid_key, $rdg_lookup{$n} );
1567     }
1568         $rgraph->setAttribute( 'parse.nodes', scalar @nlist );
1569
1570     # Add the relationship edges, with their object information
1571     my $edge_ctr = 0;
1572     foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->graph->edges ) {
1573         # Add an edge and fill in its relationship info.
1574         next unless( exists $node_hash->{$e->[0]} && exists $node_hash->{$e->[1]} );
1575                 my $edge_el = $rgraph->addNewChild( $graphml_ns, 'edge' );
1576                 $edge_el->setAttribute( 'source', $node_hash->{$e->[0]} );
1577                 $edge_el->setAttribute( 'target', $node_hash->{$e->[1]} );
1578                 $edge_el->setAttribute( 'id', 'e'.$edge_ctr++ );
1579
1580                 my $rel_obj = $self->get_relationship( @$e );
1581                 foreach my $key ( keys %$edge_keys ) {
1582                         my $value = $rel_obj->$key;
1583                         _add_graphml_data( $edge_el, $edge_keys->{$key}, $value )
1584                                 if defined $value;
1585                 }
1586         }
1587         $rgraph->setAttribute( 'parse.edges', $edge_ctr );
1588 }
1589
1590 sub _by_xmlid {
1591         my $tmp_a = $a;
1592         my $tmp_b = $b;
1593         $tmp_a =~ s/\D//g;
1594         $tmp_b =~ s/\D//g;
1595         return $tmp_a <=> $tmp_b;
1596 }
1597
1598 sub _add_graphml_data {
1599     my( $el, $key, $value ) = @_;
1600     return unless defined $value;
1601     my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
1602     $data_el->setAttribute( 'key', $key );
1603     $data_el->appendText( $value );
1604 }
1605
1606 sub dump_segment {
1607         my( $self, $from, $to ) = @_;
1608         open( DUMP, ">debug.svg" ) or die "Could not open debug.svg";
1609         binmode DUMP, ':utf8';
1610         print DUMP $self->collation->as_svg({ from => $from, to => $to, nocalc => 1 });
1611         close DUMP;
1612 }
1613
1614 sub throw {
1615         Text::Tradition::Error->throw(
1616                 'ident' => 'Relationship error',
1617                 'message' => $_[0],
1618                 );
1619 }
1620
1621 no Moose;
1622 __PACKAGE__->meta->make_immutable;
1623
1624 1;