lib/Text/Tradition/Collation/RelationshipStore.pm

   1 package Text::Tradition::Collation::RelationshipStore;
   2
   3 use strict;
   4 use warnings;
   5 use Text::Tradition::Error;
   6 use Text::Tradition::Collation::Relationship;
   7 use TryCatch;
   8
   9 use Moose;
  10
  11 =head1 NAME
  12
  13 Text::Tradition::Collation::RelationshipStore - Keeps track of the relationships
  14 between readings in a given collation
  15
  16 =head1 DESCRIPTION
  17
  18 Text::Tradition is a library for representation and analysis of collated
  19 texts, particularly medieval ones.  The RelationshipStore is an internal object
  20 of the collation, to keep track of the defined relationships (both specific and
  21 general) between readings.
  22
  23 =begin testing
  24
  25 use Text::Tradition;
  26 use TryCatch;
  27
  28 use_ok( 'Text::Tradition::Collation::RelationshipStore' );
  29
  30 # Add some relationships, and delete them
  31
  32 my $cxfile = 't/data/Collatex-16.xml';
  33 my $t = Text::Tradition->new(
  34         'name'  => 'inline',
  35         'input' => 'CollateX',
  36         'file'  => $cxfile,
  37         );
  38 my $c = $t->collation;
  39
  40 my @v1 = $c->add_relationship( 'n21', 'n22', { 'type' => 'lexical' } );
  41 is( scalar @v1, 1, "Added a single relationship" );
  42 is( $v1[0]->[0], 'n21', "Got correct node 1" );
  43 is( $v1[0]->[1], 'n22', "Got correct node 2" );
  44 my @v2 = $c->add_relationship( 'n24', 'n23',
  45         { 'type' => 'spelling', 'scope' => 'global' } );
  46 is( scalar @v2, 2, "Added a global relationship with two instances" );
  47 @v1 = $c->del_relationship( 'n22', 'n21' );
  48 is( scalar @v1, 1, "Deleted first relationship" );
  49 @v2 = $c->del_relationship( 'n12', 'n13' );
  50 is( scalar @v2, 2, "Deleted second global relationship" );
  51 my @v3 = $c->del_relationship( 'n1', 'n2' );
  52 is( scalar @v3, 0, "Nothing deleted on non-existent relationship" );
  53
  54 =end testing
  55
  56 =head1 METHODS
  57
  58 =head2 new( collation => $collation );
  59
  60 Creates a new relationship store for the given collation.
  61
  62 =cut
  63
  64 has 'collation' => (
  65         is => 'ro',
  66         isa => 'Text::Tradition::Collation',
  67         required => 1,
  68         weak_ref => 1,
  69         );
  70
  71 has 'scopedrels' => (
  72         is => 'ro',
  73         isa => 'HashRef[HashRef[Text::Tradition::Collation::Relationship]]',
  74         default => sub { {} },
  75         );
  76
  77 has 'graph' => (
  78         is => 'ro',
  79         isa => 'Graph',
  80         default => sub { Graph->new( undirected => 1 ) },
  81     handles => {
  82         relationships => 'edges',
  83         add_reading => 'add_vertex',
  84         delete_reading => 'delete_vertex',
  85     },
  86         );
  87
  88 =head2 equivalence_graph()
  89
  90 Returns an equivalence graph of the collation, in which all readings
  91 related via a 'colocated' relationship are transformed into a single
  92 vertex. Can be used to determine the validity of a new relationship.
  93
  94 =cut
  95
  96 has 'equivalence_graph' => (
  97         is => 'ro',
  98         isa => 'Graph',
  99         default => sub { Graph->new() },
 100         writer => '_reset_equivalence',
 101         );
 102
 103 has '_node_equivalences' => (
 104         is => 'ro',
 105         traits => ['Hash'],
 106         handles => {
 107                 equivalence => 'get',
 108                 set_equivalence => 'set',
 109                 remove_equivalence => 'delete',
 110                 _clear_equivalence => 'clear',
 111         },
 112         );
 113
 114 has '_equivalence_readings' => (
 115         is => 'ro',
 116         traits => ['Hash'],
 117         handles => {
 118                 eqreadings => 'get',
 119                 set_eqreadings => 'set',
 120                 remove_eqreadings => 'delete',
 121                 _clear_eqreadings => 'clear',
 122         },
 123         );
 124
 125 around add_reading => sub {
 126         my $orig = shift;
 127         my $self = shift;
 128
 129         $self->equivalence_graph->add_vertex( @_ );
 130         $self->set_equivalence( $_[0], $_[0] );
 131         $self->set_eqreadings( $_[0], [ $_[0] ] );
 132         $self->$orig( @_ );
 133 };
 134
 135 around delete_reading => sub {
 136         my $orig = shift;
 137         my $self = shift;
 138
 139         $self->_remove_equivalence_node( @_ );
 140         $self->$orig( @_ );
 141 };
 142
 143 =head2 get_relationship
 144
 145 Return the relationship object, if any, that exists between two readings.
 146
 147 =cut
 148
 149 sub get_relationship {
 150         my $self = shift;
 151         my @vector;
 152         if( @_ == 1 && ref( $_[0] ) eq 'ARRAY' ) {
 153                 # Dereference the edge arrayref that was passed.
 154                 my $edge = shift;
 155                 @vector = @$edge;
 156         } else {
 157                 @vector = @_;
 158         }
 159         my $relationship;
 160         if( $self->graph->has_edge_attribute( @vector, 'object' ) ) {
 161                 $relationship = $self->graph->get_edge_attribute( @vector, 'object' );
 162         }
 163         return $relationship;
 164 }
 165
 166 sub _set_relationship {
 167         my( $self, $relationship, @vector ) = @_;
 168         $self->graph->add_edge( @vector );
 169         $self->graph->set_edge_attribute( @vector, 'object', $relationship );
 170         $self->_make_equivalence( @vector ) if $relationship->colocated;
 171 }
 172
 173 =head2 create
 174
 175 Create a new relationship with the given options and return it.
 176 Warn and return undef if the relationship cannot be created.
 177
 178 =cut
 179
 180 sub create {
 181         my( $self, $options ) = @_;
 182         # Check to see if a relationship exists between the two given readings
 183         my $source = delete $options->{'orig_a'};
 184         my $target = delete $options->{'orig_b'};
 185         my $rel = $self->get_relationship( $source, $target );
 186         if( $rel ) {
 187                 if( $rel->type eq 'collated' ) {
 188                         # Always replace a 'collated' relationship with a more descriptive
 189                         # one, if asked.
 190                         $self->del_relationship( $source, $target );
 191                 } elsif( $rel->type ne $options->{'type'} ) {
 192                         throw( "Another relationship of type " . $rel->type
 193                                 . " already exists between $source and $target" );
 194                 } else {
 195                         return $rel;
 196                 }
 197         }
 198
 199         # Check to see if a nonlocal relationship is defined for the two readings
 200         $rel = $self->scoped_relationship( $options->{'reading_a'},
 201                 $options->{'reading_b'} );
 202         if( $rel && $rel->type eq $options->{'type'} ) {
 203                 return $rel;
 204         } elsif( $rel ) {
 205                 throw( sprintf( "Relationship of type %s with scope %s already defined for readings %s and %s", $rel->type, $rel->scope, $options->{'reading_a'}, $options->{'reading_b'} ) );
 206         } else {
 207                 $rel = Text::Tradition::Collation::Relationship->new( $options );
 208                 $self->add_scoped_relationship( $rel ) if $rel->nonlocal;
 209                 return $rel;
 210         }
 211 }
 212
 213 =head2 add_scoped_relationship( $rel )
 214
 215 Keep track of relationships defined between specific readings that are scoped
 216 non-locally.  Key on whichever reading occurs first alphabetically.
 217
 218 =cut
 219
 220 sub add_scoped_relationship {
 221         my( $self, $rel ) = @_;
 222         my $rdga = $rel->type eq 'orthographic' ? $rel->reading_a : lc( $rel->reading_a );
 223         my $rdgb = $rel->type eq 'orthographic' ? $rel->reading_b : lc( $rel->reading_b );
 224         my $r = $self->scoped_relationship( $rdga, $rdgb );
 225         if( $r ) {
 226                 warn sprintf( "Scoped relationship of type %s already exists between %s and %s",
 227                         $r->type, $rdga, $rdgb );
 228                 return;
 229         }
 230         my( $first, $second ) = sort ( $rdga, $rdgb );
 231         $self->scopedrels->{$first}->{$second} = $rel;
 232 }
 233
 234 =head2 scoped_relationship( $reading_a, $reading_b )
 235
 236 Returns the general (document-level or global) relationship that has been defined
 237 between the two reading strings. Returns undef if there is no general relationship.
 238
 239 =cut
 240
 241 sub scoped_relationship {
 242         my( $self, $rdga, $rdgb ) = @_;
 243         my( $first, $second ) = sort( $rdga, $rdgb );
 244         if( exists $self->scopedrels->{$first}->{$second} ) {
 245                 return $self->scopedrels->{$first}->{$second};
 246         } else {
 247                 return undef;
 248         }
 249 }
 250
 251 =head2 add_relationship( $self, $source, $sourcetext, $target, $targettext, $opts )
 252
 253 Adds the relationship specified in $opts (see Text::Tradition::Collation::Relationship
 254 for the possible options) between the readings given in $source and $target.  Sets
 255 up a scoped relationship between $sourcetext and $targettext if the relationship is
 256 scoped non-locally.
 257
 258 Returns a status boolean and a list of all reading pairs connected by the call to
 259 add_relationship.
 260
 261 =begin testing
 262
 263 use Test::Warn;
 264 use Text::Tradition;
 265 use TryCatch;
 266
 267 my $t1;
 268 warning_is {
 269         $t1 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/legendfrag.xml' );
 270 } 'DROPPING r14.2 -> r8.1: Cannot set relationship on a meta reading',
 271         "Got expected relationship drop warning on parse";
 272
 273 # Test 1.1: try to equate nodes that are prevented with an intermediate collation
 274 ok( $t1, "Parsed test fragment file" );
 275 my $c1 = $t1->collation;
 276 my $trel = $c1->get_relationship( 'r9.2', 'r9.3' );
 277 is( ref( $trel ), 'Text::Tradition::Collation::Relationship',
 278         "Troublesome relationship exists" );
 279 is( $trel->type, 'collated', "Troublesome relationship is a collation" );
 280
 281 # Try to make the link we want
 282 try {
 283         $c1->add_relationship( 'r8.6', 'r10.3', { 'type' => 'orthographic' } );
 284         ok( 1, "Added cross-collation relationship as expected" );
 285 } catch( Text::Tradition::Error $e ) {
 286         ok( 0, "Existing collation blocked equivalence relationship: " . $e->message );
 287 }
 288
 289 try {
 290         $c1->calculate_ranks();
 291         ok( 1, "Successfully calculated ranks" );
 292 } catch ( Text::Tradition::Error $e ) {
 293         ok( 0, "Collation now has a cycle: " . $e->message );
 294 }
 295
 296 # Test 1.2: attempt merge of an identical reading
 297 try {
 298         $c1->merge_readings( 'r9.3', 'r11.5' );
 299         ok( 1, "Successfully merged reading 'pontifex'" );
 300 } catch ( Text::Tradition::Error $e ) {
 301         ok( 0, "Merge of mergeable readings failed: $e->message" );
 302
 303 }
 304
 305 # Test 1.3: attempt relationship with a meta reading (should fail)
 306 try {
 307         $c1->add_relationship( 'r8.1', 'r9.2', { 'type' => 'collated' } );
 308         ok( 0, "Allowed a meta-reading to be used in a relationship" );
 309 } catch ( Text::Tradition::Error $e ) {
 310         is( $e->message, 'Cannot set relationship on a meta reading',
 311                 "Relationship link prevented for a meta reading" );
 312 }
 313
 314 # Test 1.4: try to break a relationship near a meta reading
 315 $c1->add_relationship( 'r7.6', 'r7.3', { type => 'orthographic' } );
 316 try {
 317         $c1->del_relationship( 'r7.6', 'r7.7' );
 318         $c1->del_relationship( 'r7.6', 'r7.3' );
 319         ok( 1, "Relationship broken with a meta reading as neighbor" );
 320 } catch {
 321         ok( 0, "Relationship deletion failed with a meta reading as neighbor" );
 322 }
 323
 324 # Test 2.1: try to equate nodes that are prevented with a real intermediate
 325 # equivalence
 326 my $t2;
 327 warning_is {
 328         $t2 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/legendfrag.xml' );
 329 } 'DROPPING r14.2 -> r8.1: Cannot set relationship on a meta reading',
 330         "Got expected relationship drop warning on parse";
 331 my $c2 = $t2->collation;
 332 $c2->add_relationship( 'r9.2', 'r9.3', { 'type' => 'lexical' } );
 333 my $trel2 = $c2->get_relationship( 'r9.2', 'r9.3' );
 334 is( ref( $trel2 ), 'Text::Tradition::Collation::Relationship',
 335         "Created blocking relationship" );
 336 is( $trel2->type, 'lexical', "Blocking relationship is not a collation" );
 337 # This time the link ought to fail
 338 try {
 339         $c2->add_relationship( 'r8.6', 'r10.3', { 'type' => 'orthographic' } );
 340         ok( 0, "Added cross-equivalent bad relationship" );
 341 } catch ( Text::Tradition::Error $e ) {
 342         like( $e->message, qr/witness loop/,
 343                 "Existing equivalence blocked crossing relationship" );
 344 }
 345
 346 try {
 347         $c2->calculate_ranks();
 348         ok( 1, "Successfully calculated ranks" );
 349 } catch ( Text::Tradition::Error $e ) {
 350         ok( 0, "Collation now has a cycle: " . $e->message );
 351 }
 352
 353 # Test 3.1: make a straightforward pair of transpositions.
 354 my $t3 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/lf2.xml' );
 355 # Test 1: try to equate nodes that are prevented with an intermediate collation
 356 my $c3 = $t3->collation;
 357 try {
 358         $c3->add_relationship( 'r36.4', 'r38.3', { 'type' => 'transposition' } );
 359         ok( 1, "Added straightforward transposition" );
 360 } catch ( Text::Tradition::Error $e ) {
 361         ok( 0, "Failed to add normal transposition: " . $e->message );
 362 }
 363 try {
 364         $c3->add_relationship( 'r36.3', 'r38.2', { 'type' => 'transposition' } );
 365         ok( 1, "Added straightforward transposition complement" );
 366 } catch ( Text::Tradition::Error $e ) {
 367         ok( 0, "Failed to add normal transposition complement: " . $e->message );
 368 }
 369
 370 # Test 3.2: try to make a transposition that could be a parallel.
 371 try {
 372         $c3->add_relationship( 'r28.2', 'r29.2', { 'type' => 'transposition' } );
 373         ok( 0, "Added bad colocated transposition" );
 374 } catch ( Text::Tradition::Error $e ) {
 375         like( $e->message, qr/Readings appear to be colocated/,
 376                 "Prevented bad colocated transposition" );
 377 }
 378
 379 # Test 3.3: make the parallel, and then make the transposition again.
 380 try {
 381         $c3->add_relationship( 'r28.3', 'r29.3', { 'type' => 'orthographic' } );
 382         ok( 1, "Equated identical readings for transposition" );
 383 } catch ( Text::Tradition::Error $e ) {
 384         ok( 0, "Failed to equate identical readings: " . $e->message );
 385 }
 386 try {
 387         $c3->add_relationship( 'r28.2', 'r29.2', { 'type' => 'transposition' } );
 388         ok( 1, "Added straightforward transposition complement" );
 389 } catch ( Text::Tradition::Error $e ) {
 390         ok( 0, "Failed to add normal transposition complement: " . $e->message );
 391 }
 392
 393 =end testing
 394
 395 =cut
 396
 397 sub add_relationship {
 398         my( $self, $source, $target, $options ) = @_;
 399     my $c = $self->collation;
 400         my $sourceobj = $c->reading( $source );
 401         my $targetobj = $c->reading( $target );
 402         throw( "Adding self relationship at $source" ) if $source eq $target;
 403         throw( "Cannot set relationship on a meta reading" )
 404                 if( $sourceobj->is_meta || $targetobj->is_meta );
 405         my $relationship;
 406         my $thispaironly;
 407         my $droppedcolls = [];
 408         if( ref( $options ) eq 'Text::Tradition::Collation::Relationship' ) {
 409                 $relationship = $options;
 410                 $thispaironly = 1;  # If existing rel, set only where asked.
 411         } else {
 412                 # Check the options
 413                 $options->{'scope'} = 'local' unless $options->{'scope'};
 414                 $options->{'scope'} = 'local' if $options->{'type'} eq 'collated';
 415                 $options->{'scope'} = 'local' if $options->{'type'} eq 'transposition';
 416
 417                 my( $is_valid, $reason ) = $self->relationship_valid( $source, $target,
 418                         $options->{'type'}, $droppedcolls );
 419                 unless( $is_valid ) {
 420                         throw( "Invalid relationship: $reason" );
 421                 }
 422
 423                 # Try to create the relationship object.
 424                 $options->{'reading_a'} = $sourceobj->text;
 425                 $options->{'reading_b'} = $targetobj->text;
 426                 $options->{'orig_a'} = $source;
 427                 $options->{'orig_b'} = $target;
 428         if( $options->{'scope'} ne 'local' ) {
 429                         # Is there a relationship with this a & b already?
 430                         # Case-insensitive for non-orthographics.
 431                         my $rdga = $options->{'type'} eq 'orthographic'
 432                                 ? $options->{'reading_a'} : lc( $options->{'reading_a'} );
 433                         my $rdgb = $options->{'type'} eq 'orthographic'
 434                                 ? $options->{'reading_b'} : lc( $options->{'reading_b'} );
 435                         my $otherrel = $self->scoped_relationship( $rdga, $rdgb );
 436                         if( $otherrel && $otherrel->type eq $options->{type}
 437                                 && $otherrel->scope eq $options->{scope} ) {
 438                                 warn "Applying existing scoped relationship";
 439                                 $relationship = $otherrel;
 440                         }
 441         }
 442                 $relationship = $self->create( $options ) unless $relationship;  # Will throw on error
 443     }
 444
 445
 446         # Find all the pairs for which we need to set the relationship.
 447         my @vectors;
 448     if( $relationship->colocated && $relationship->nonlocal && !$thispaironly ) {
 449         push( @vectors, $self->_find_applicable( $relationship ) );
 450     }
 451
 452     # Now set the relationship(s).
 453     my @pairs_set;
 454         my $rel = $self->get_relationship( $source, $target );
 455         my $skip;
 456         if( $rel && $rel ne $relationship ) {
 457                 if( $rel->nonlocal ) {
 458                         throw( "Found conflicting relationship at $source - $target" );
 459                 } elsif( $rel->type ne 'collated' ) {
 460                         # Replace a collation relationship; leave any other sort in place.
 461                         my $r1ann = $rel->has_annotation ? $rel->annotation : '';
 462                         my $r2ann = $relationship->has_annotation ? $relationship->annotation : '';
 463                         unless( $rel->type eq $relationship->type && $r1ann eq $r2ann ) {
 464                                 warn sprintf( "Not overriding local relationship %s with global %s "
 465                                         . "set at %s -> %s (%s -> %s)", $rel->type, $relationship->type,
 466                                         $source, $target, $rel->reading_a, $rel->reading_b );
 467                                 $skip = 1;
 468                         }
 469                 }
 470         }
 471         $self->_set_relationship( $relationship, $source, $target ) unless $skip;
 472         push( @pairs_set, [ $source, $target ] );
 473
 474     # Set any additional relationships that might be in @vectors.
 475     foreach my $v ( @vectors ) {
 476         next if $v->[0] eq $source && $v->[1] eq $target;
 477         next if $v->[1] eq $source && $v->[0] eq $target;
 478         my @added = $self->add_relationship( @$v, $relationship );
 479         push( @pairs_set, @added );
 480     }
 481
 482     # Finally, restore whatever collations we can, and return.
 483     $self->_restore_collations( @$droppedcolls );
 484     return @pairs_set;
 485 }
 486
 487 =head2 del_scoped_relationship( $reading_a, $reading_b )
 488
 489 Returns the general (document-level or global) relationship that has been defined
 490 between the two reading strings. Returns undef if there is no general relationship.
 491
 492 =cut
 493
 494 sub del_scoped_relationship {
 495         my( $self, $rdga, $rdgb ) = @_;
 496         my( $first, $second ) = sort( $rdga, $rdgb );
 497         return delete $self->scopedrels->{$first}->{$second};
 498 }
 499
 500 sub _find_applicable {
 501         my( $self, $rel ) = @_;
 502         my $c = $self->collation;
 503         # TODO Someday we might use a case sensitive language.
 504         my $lang = $c->tradition->language;
 505         my @vectors;
 506         my @identical_readings;
 507         if( $rel->type eq 'orthographic' ) {
 508                 @identical_readings = grep { $_->text eq $rel->reading_a }
 509                         $c->readings;
 510         } else {
 511                 @identical_readings = grep { lc( $_->text ) eq lc( $rel->reading_a ) }
 512                         $c->readings;
 513         }
 514         foreach my $ir ( @identical_readings ) {
 515                 my @itarget;
 516                 if( $rel->type eq 'orthographic' ) {
 517                         @itarget = grep { $_->rank == $ir->rank
 518                                                           && $_->text eq $rel->reading_b } $c->readings;
 519                 } else {
 520                         @itarget = grep { $_->rank == $ir->rank
 521                                                           && lc( $_->text ) eq lc( $rel->reading_b ) } $c->readings;
 522                 }
 523                 if( @itarget ) {
 524                         # Warn if there is more than one hit with no orth link between them.
 525                         my $itmain = shift @itarget;
 526                         if( @itarget ) {
 527                                 my %all_targets;
 528                                 map { $all_targets{$_} = 1 } @itarget;
 529                                 map { delete $all_targets{$_} }
 530                                         $self->related_readings( $itmain,
 531                                                 sub { $_[0]->type eq 'orthographic' } );
 532                         warn "More than one unrelated reading with text " . $itmain->text
 533                                 . " at rank " . $ir->rank . "!" if keys %all_targets;
 534                         }
 535                         push( @vectors, [ $ir->id, $itmain->id ] );
 536                 }
 537         }
 538         return @vectors;
 539 }
 540
 541 =head2 del_relationship( $source, $target )
 542
 543 Removes the relationship between the given readings. If the relationship is
 544 non-local, removes the relationship everywhere in the graph.
 545
 546 =cut
 547
 548 sub del_relationship {
 549         my( $self, $source, $target ) = @_;
 550         my $rel = $self->get_relationship( $source, $target );
 551         return () unless $rel; # Nothing to delete; return an empty set.
 552         my $colo = $rel->colocated;
 553         my @vectors = ( [ $source, $target ] );
 554         $self->_remove_relationship( $colo, $source, $target );
 555         if( $rel->nonlocal ) {
 556                 # Remove the relationship wherever it occurs.
 557                 # Remove the relationship wherever it occurs.
 558                 my @rel_edges = grep { $self->get_relationship( @$_ ) == $rel }
 559                         $self->relationships;
 560                 foreach my $re ( @rel_edges ) {
 561                         $self->_remove_relationship( $colo, @$re );
 562                         push( @vectors, $re );
 563                 }
 564                 $self->del_scoped_relationship( $rel->reading_a, $rel->reading_b );
 565         }
 566         return @vectors;
 567 }
 568
 569 sub _remove_relationship {
 570         my( $self, $equiv, @vector ) = @_;
 571         $self->graph->delete_edge( @vector );
 572         $self->_break_equivalence( @vector ) if $equiv;
 573 }
 574
 575 =head2 relationship_valid( $source, $target, $type )
 576
 577 Checks whether a relationship of type $type may exist between the readings given
 578 in $source and $target.  Returns a tuple of ( status, message ) where status is
 579 a yes/no boolean and, if the answer is no, message gives the reason why.
 580
 581 =cut
 582
 583 sub relationship_valid {
 584     my( $self, $source, $target, $rel, $mustdrop ) = @_;
 585     $mustdrop = [] unless $mustdrop; # in case we were passed nothing
 586     my $c = $self->collation;
 587     ## Assume validity is okay if we are initializing from scratch.
 588     return ( 1, "initializing" ) unless $c->tradition->_initialized;
 589         if ( $rel eq 'transposition' || $rel eq 'repetition' ) {
 590                 # Check that the two readings do (for a repetition) or do not (for
 591                 # a transposition) appear in the same witness.
 592                 # TODO this might be called before witness paths are set...
 593                 my %seen_wits;
 594                 map { $seen_wits{$_} = 1 } $c->reading_witnesses( $source );
 595                 foreach my $w ( $c->reading_witnesses( $target ) ) {
 596                         if( $seen_wits{$w} ) {
 597                                 return ( 0, "Readings both occur in witness $w" )
 598                                         if $rel eq 'transposition';
 599                                 return ( 1, "ok" ) if $rel eq 'repetition';
 600                         }
 601                 }
 602                 return ( 0, "Readings occur only in distinct witnesses" )
 603                         if $rel eq 'repetition';
 604         }
 605         if ( $rel eq 'transposition' ) {
 606                 # We also need to check both that the readings occur in distinct
 607                 # witnesses, and that they are not in the same place. That is,
 608                 # proposing to link them should cause a witness loop.
 609                 if( $self->test_equivalence( $source, $target ) ) {
 610                         return ( 0, "Readings appear to be colocated, not transposed" );
 611                 } else {
 612                         return ( 1, "ok" );
 613                 }
 614
 615         } elsif( $rel ne 'repetition' ) {
 616                 # Check that linking the source and target in a relationship won't lead
 617                 # to a path loop for any witness.
 618                 # First, drop/stash any collations that might interfere
 619                 my $sourceobj = $c->reading( $source );
 620                 my $targetobj = $c->reading( $target );
 621                 my $sourcerank = $sourceobj->has_rank ? $sourceobj->rank : -1;
 622                 my $targetrank = $targetobj->has_rank ? $targetobj->rank : -1;
 623                 unless( $rel eq 'collated' || $sourcerank == $targetrank ) {
 624                         push( @$mustdrop, $self->_drop_collations( $source ) );
 625                         push( @$mustdrop, $self->_drop_collations( $target ) );
 626                         if( $c->end->has_rank ) {
 627                                 foreach my $rk ( $sourcerank .. $targetrank ) {
 628                                         map { push( @$mustdrop, $self->_drop_collations( $_->id ) ) }
 629                                                 $c->readings_at_rank( $rk );
 630                                 }
 631                         }
 632                 }
 633                 unless( $self->test_equivalence( $source, $target ) ) {
 634                         $self->_restore_collations( @$mustdrop );
 635                         return( 0, "Relationship would create witness loop" );
 636                 }
 637                 return ( 1, "ok" );
 638         }
 639 }
 640
 641 sub _drop_collations {
 642         my( $self, $reading ) = @_;
 643         my @dropped;
 644         foreach my $n ( $self->graph->neighbors( $reading ) ) {
 645                 if( $self->get_relationship( $reading, $n )->type eq 'collated' ) {
 646                         push( @dropped, [ $reading, $n ] );
 647                         $self->del_relationship( $reading, $n );
 648                         #print STDERR "Dropped collation $reading -> $n\n";
 649                 }
 650         }
 651         return @dropped;
 652 }
 653
 654 sub _restore_collations {
 655         my( $self, @vectors ) = @_;
 656         foreach my $v ( @vectors ) {
 657                 try {
 658                         $self->add_relationship( @$v, { 'type' => 'collated' } );
 659                         #print STDERR "Restored collation @$v\n";
 660                 } catch {
 661                         print STDERR $v->[0] . " - " . $v->[1] . " no longer collate\n";
 662                 }
 663         }
 664 }
 665
 666 =head2 filter_collations()
 667
 668 Utility function. Removes any redundant 'collated' relationships from the graph.
 669 A collated relationship is redundant if the readings in question would occupy
 670 the same rank regardless of the existence of the relationship.
 671
 672 =cut
 673
 674 sub filter_collations {
 675         my $self = shift;
 676         my $c = $self->collation;
 677         foreach my $r ( 1 .. $c->end->rank - 1 ) {
 678                 my $anchor;
 679                 my @need_collations;
 680                 foreach my $rdg ( $c->readings_at_rank( $r ) ) {
 681                         next if $rdg->is_meta;
 682                         my $ip = 0;
 683                         foreach my $pred ( $rdg->predecessors ) {
 684                                 if( $pred->rank == $r - 1 ) {
 685                                         $ip = 1;
 686                                         $anchor = $rdg unless( $anchor );
 687                                         last;
 688                                 }
 689                         }
 690                         push( @need_collations, $rdg ) unless $ip;
 691                         $c->relations->_drop_collations( "$rdg" );
 692                 }
 693                 $anchor
 694                         ? map { $c->add_relationship( $anchor, $_, { 'type' => 'collated' } )
 695                                                 unless $c->get_relationship( $anchor, $_ ) } @need_collations
 696                         : warn "No anchor found at $r";
 697         }
 698 }
 699
 700 =head2 related_readings( $reading, $filter )
 701
 702 Returns a list of readings that are connected via relationship links to $reading.
 703 If $filter is set to a subroutine ref, returns only those related readings where
 704 $filter( $relationship ) returns a true value.
 705
 706 =cut
 707
 708 sub related_readings {
 709         my( $self, $reading, $filter ) = @_;
 710         my $return_object;
 711         if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
 712                 $reading = $reading->id;
 713                 $return_object = 1;
 714         }
 715         my @answer;
 716         if( $filter ) {
 717                 # Backwards compat
 718                 if( $filter eq 'colocated' ) {
 719                         $filter = sub { $_[0]->colocated };
 720                 }
 721                 my %found = ( $reading => 1 );
 722                 my $check = [ $reading ];
 723                 my $iter = 0;
 724                 while( @$check ) {
 725                         my $more = [];
 726                         foreach my $r ( @$check ) {
 727                                 foreach my $nr ( $self->graph->neighbors( $r ) ) {
 728                                         if( &$filter( $self->get_relationship( $r, $nr ) ) ) {
 729                                                 push( @$more, $nr ) unless exists $found{$nr};
 730                                                 $found{$nr} = 1;
 731                                         }
 732                                 }
 733                         }
 734                         $check = $more;
 735                 }
 736                 delete $found{$reading};
 737                 @answer = keys %found;
 738         } else {
 739                 @answer = $self->graph->all_reachable( $reading );
 740         }
 741         if( $return_object ) {
 742                 my $c = $self->collation;
 743                 return map { $c->reading( $_ ) } @answer;
 744         } else {
 745                 return @answer;
 746         }
 747 }
 748
 749 =head2 merge_readings( $kept, $deleted );
 750
 751 Makes a best-effort merge of the relationship links between the given readings, and
 752 stops tracking the to-be-deleted reading.
 753
 754 =cut
 755
 756 sub merge_readings {
 757         my( $self, $kept, $deleted, $combined ) = @_;
 758         foreach my $edge ( $self->graph->edges_at( $deleted ) ) {
 759                 # Get the pair of kept / rel
 760                 my @vector = ( $kept );
 761                 push( @vector, $edge->[0] eq $deleted ? $edge->[1] : $edge->[0] );
 762                 next if $vector[0] eq $vector[1]; # Don't add a self loop
 763
 764                 # If kept changes its text, drop the relationship.
 765                 next if $combined;
 766
 767                 # If kept / rel already has a relationship, just keep the old
 768                 my $rel = $self->get_relationship( @vector );
 769                 next if $rel;
 770
 771                 # Otherwise, adopt the relationship that would be deleted.
 772                 $rel = $self->get_relationship( @$edge );
 773                 $self->_set_relationship( $rel, @vector );
 774         }
 775         $self->_make_equivalence( $deleted, $kept );
 776 }
 777
 778 ### Equivalence logic
 779
 780 sub _remove_equivalence_node {
 781         my( $self, $node ) = @_;
 782         my $group = $self->equivalence( $node );
 783         my $nodelist = $self->eqreadings( $group );
 784         if( @$nodelist == 1 && $nodelist->[0] eq $node ) {
 785                 $self->equivalence_graph->delete_vertex( $group );
 786                 $self->remove_eqreadings( $group );
 787                 $self->remove_equivalence( $group );
 788         } elsif( @$nodelist == 1 ) {
 789                 throw( "DATA INCONSISTENCY in equivalence graph: " . $nodelist->[0] .
 790                         " in group that should have only $node" );
 791         } else {
 792                 my @newlist = grep { $_ ne $node } @$nodelist;
 793                 $self->set_eqreadings( $group, \@newlist );
 794                 $self->remove_equivalence( $node );
 795         }
 796 }
 797
 798 =head2 add_equivalence_edge
 799
 800 Add an edge in the equivalence graph corresponding to $source -> $target in the
 801 collation. Should only be called by Collation.
 802
 803 =cut
 804
 805 sub add_equivalence_edge {
 806         my( $self, $source, $target ) = @_;
 807         my $seq = $self->equivalence( $source );
 808         my $teq = $self->equivalence( $target );
 809         $self->equivalence_graph->add_edge( $seq, $teq );
 810 }
 811
 812 =head2 delete_equivalence_edge
 813
 814 Remove an edge in the equivalence graph corresponding to $source -> $target in the
 815 collation. Should only be called by Collation.
 816
 817 =cut
 818
 819 sub delete_equivalence_edge {
 820         my( $self, $source, $target ) = @_;
 821         my $seq = $self->equivalence( $source );
 822         my $teq = $self->equivalence( $target );
 823         $self->equivalence_graph->delete_edge( $seq, $teq );
 824 }
 825
 826 sub _is_disconnected {
 827         my $self = shift;
 828         return( scalar $self->equivalence_graph->predecessorless_vertices > 1
 829                 || scalar $self->equivalence_graph->successorless_vertices > 1 );
 830 }
 831
 832 # Equate two readings in the equivalence graph
 833 sub _make_equivalence {
 834         my( $self, $source, $target ) = @_;
 835         # Get the source equivalent readings
 836         my $seq = $self->equivalence( $source );
 837         my $teq = $self->equivalence( $target );
 838         # Nothing to do if they are already equivalent...
 839         return if $seq eq $teq;
 840         my $sourcepool = $self->eqreadings( $seq );
 841         # and add them to the target readings.
 842         push( @{$self->eqreadings( $teq )}, @$sourcepool );
 843         map { $self->set_equivalence( $_, $teq ) } @$sourcepool;
 844         # Then merge the nodes in the equivalence graph.
 845         foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
 846                 $self->equivalence_graph->add_edge( $pred, $teq );
 847         }
 848         foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
 849                 $self->equivalence_graph->add_edge( $teq, $succ );
 850         }
 851         $self->equivalence_graph->delete_vertex( $seq );
 852         # TODO enable this after collation parsing is done
 853         throw( "Graph got disconnected making $source / $target equivalence" )
 854                 if $self->_is_disconnected && $self->collation->tradition->_initialized;
 855 }
 856
 857 =head2 test_equivalence
 858
 859 Test whether, if two readings were equated with a 'colocated' relationship,
 860 the graph would still be valid.
 861
 862 =cut
 863
 864 sub test_equivalence {
 865         my( $self, $source, $target ) = @_;
 866         # Try merging the nodes in the equivalence graph; return a true value if
 867         # no cycle is introduced thereby. Restore the original graph first.
 868
 869         # Keep track of edges we add
 870         my %added_pred;
 871         my %added_succ;
 872         # Get the reading equivalents
 873         my $seq = $self->equivalence( $source );
 874         my $teq = $self->equivalence( $target );
 875         # Maybe this is easy?
 876         return 1 if $seq eq $teq;
 877
 878         # Save the first graph
 879         my $checkstr = $self->equivalence_graph->stringify();
 880         # Add and save relevant edges
 881         foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
 882                 if( $self->equivalence_graph->has_edge( $pred, $teq ) ) {
 883                         $added_pred{$pred} = 0;
 884                 } else {
 885                         $self->equivalence_graph->add_edge( $pred, $teq );
 886                         $added_pred{$pred} = 1;
 887                 }
 888         }
 889         foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
 890                 if( $self->equivalence_graph->has_edge( $teq, $succ ) ) {
 891                         $added_succ{$succ} = 0;
 892                 } else {
 893                         $self->equivalence_graph->add_edge( $teq, $succ );
 894                         $added_succ{$succ} = 1;
 895                 }
 896         }
 897         # Delete source equivalent and test
 898         $self->equivalence_graph->delete_vertex( $seq );
 899         my $ret = !$self->equivalence_graph->has_a_cycle;
 900
 901         # Restore what we changed
 902         $self->equivalence_graph->add_vertex( $seq );
 903         foreach my $pred ( keys %added_pred ) {
 904                 $self->equivalence_graph->add_edge( $pred, $seq );
 905                 $self->equivalence_graph->delete_edge( $pred, $teq ) if $added_pred{$pred};
 906         }
 907         foreach my $succ ( keys %added_succ ) {
 908                 $self->equivalence_graph->add_edge( $seq, $succ );
 909                 $self->equivalence_graph->delete_edge( $teq, $succ ) if $added_succ{$succ};
 910         }
 911         unless( $self->equivalence_graph->eq( $checkstr ) ) {
 912                 warn "GRAPH CHANGED after testing";
 913         }
 914         # Return our answer
 915         return $ret;
 916 }
 917
 918 # Unmake an equivalence link between two readings. Should only be called internally.
 919 sub _break_equivalence {
 920         my( $self, $source, $target ) = @_;
 921
 922         # This is the hard one. Need to reconstruct the equivalence groups without
 923         # the given link.
 924         my( %sng, %tng );
 925         map { $sng{$_} = 1 } $self->_find_equiv_without( $source, $target );
 926         map { $tng{$_} = 1 } $self->_find_equiv_without( $target, $source );
 927         # If these groups intersect, they are still connected; do nothing.
 928         foreach my $el ( keys %tng ) {
 929                 return if( exists $sng{$el} );
 930         }
 931         # If they don't intersect, then we split the nodes in the graph and in
 932         # the hashes. First figure out which group has which name
 933         my $oldgroup = $self->equivalence( $source ); # same as $target
 934         my $keepsource = $sng{$oldgroup};
 935         my $newgroup = $keepsource ? $target : $source;
 936         my( $oldmembers, $newmembers );
 937         if( $keepsource ) {
 938                 $oldmembers = [ keys %sng ];
 939                 $newmembers = [ keys %tng ];
 940         } else {
 941                 $oldmembers = [ keys %tng ];
 942                 $newmembers = [ keys %sng ];
 943         }
 944
 945         # First alter the old group in the hash
 946         $self->set_eqreadings( $oldgroup, $oldmembers );
 947         foreach my $el ( @$oldmembers ) {
 948                 $self->set_equivalence( $el, $oldgroup );
 949         }
 950
 951         # then add the new group back to the hash with its new key
 952         $self->set_eqreadings( $newgroup, $newmembers );
 953         foreach my $el ( @$newmembers ) {
 954                 $self->set_equivalence( $el, $newgroup );
 955         }
 956
 957         # Now add the new group back to the equivalence graph
 958         $self->equivalence_graph->add_vertex( $newgroup );
 959         # ...add the appropriate edges to the source group vertext
 960         my $c = $self->collation;
 961         foreach my $rdg ( @$newmembers ) {
 962                 foreach my $rp ( $c->sequence->predecessors( $rdg ) ) {
 963                         next unless $self->equivalence( $rp );
 964                         $self->equivalence_graph->add_edge( $self->equivalence( $rp ), $newgroup );
 965                 }
 966                 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
 967                         next unless $self->equivalence( $rs );
 968                         $self->equivalence_graph->add_edge( $newgroup, $self->equivalence( $rs ) );
 969                 }
 970         }
 971
 972         # ...and figure out which edges on the old group vertex to delete.
 973         my( %old_pred, %old_succ );
 974         foreach my $rdg ( @$oldmembers ) {
 975                 foreach my $rp ( $c->sequence->predecessors( $rdg ) ) {
 976                         next unless $self->equivalence( $rp );
 977                         $old_pred{$self->equivalence( $rp )} = 1;
 978                 }
 979                 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
 980                         next unless $self->equivalence( $rs );
 981                         $old_succ{$self->equivalence( $rs )} = 1;
 982                 }
 983         }
 984         foreach my $p ( $self->equivalence_graph->predecessors( $oldgroup ) ) {
 985                 unless( $old_pred{$p} ) {
 986                         $self->equivalence_graph->delete_edge( $p, $oldgroup );
 987                 }
 988         }
 989         foreach my $s ( $self->equivalence_graph->successors( $oldgroup ) ) {
 990                 unless( $old_succ{$s} ) {
 991                         $self->equivalence_graph->delete_edge( $oldgroup, $s );
 992                 }
 993         }
 994         # TODO enable this after collation parsing is done
 995         throw( "Graph got disconnected breaking $source / $target equivalence" )
 996                 if $self->_is_disconnected && $self->collation->tradition->_initialized;
 997 }
 998
 999 sub _find_equiv_without {
1000         my( $self, $first, $second ) = @_;
1001         my %found = ( $first => 1 );
1002         my $check = [ $first ];
1003         my $iter = 0;
1004         while( @$check ) {
1005                 my $more = [];
1006                 foreach my $r ( @$check ) {
1007                         foreach my $nr ( $self->graph->neighbors( $r ) ) {
1008                                 next if $r eq $second;
1009                                 if( $self->get_relationship( $r, $nr )->colocated ) {
1010                                         push( @$more, $nr ) unless exists $found{$nr};
1011                                         $found{$nr} = 1;
1012                                 }
1013                         }
1014                 }
1015                 $check = $more;
1016         }
1017         return keys %found;
1018 }
1019
1020 =head2 rebuild_equivalence
1021
1022 (Re)build the equivalence graph from scratch. Dumps the graph, makes a new one,
1023 adds all readings and edges, then makes an equivalence for all relationships.
1024
1025 =cut
1026
1027 sub rebuild_equivalence {
1028         my $self = shift;
1029         my $newgraph = Graph->new();
1030         # Set this as the new equivalence graph
1031         $self->_reset_equivalence( $newgraph );
1032         # Clear out the data hashes
1033         $self->_clear_equivalence;
1034         $self->_clear_eqreadings;
1035
1036         # Add the readings
1037         foreach my $r ( $self->collation->readings ) {
1038                 my $rid = $r->id;
1039                 $newgraph->add_vertex( $rid );
1040                 $self->set_equivalence( $rid, $rid );
1041                 $self->set_eqreadings( $rid, [ $rid ] );
1042         }
1043
1044         # Now add the edges
1045         foreach my $e ( $self->collation->paths ) {
1046                 $self->add_equivalence_edge( @$e );
1047         }
1048
1049         # Now equate the colocated readings. This does no testing;
1050         # it assumes that all preexisting relationships are valid.
1051         foreach my $rel ( $self->relationships ) {
1052                 my $relobj = $self->get_relationship( $rel );
1053                 next unless $relobj && $relobj->colocated;
1054                 $self->_make_equivalence( @$rel );
1055         }
1056 }
1057
1058 =head2 equivalence_ranks
1059
1060 Rank all vertices in the equivalence graph, and return a hash reference with
1061 vertex => rank mapping.
1062
1063 =cut
1064
1065 sub equivalence_ranks {
1066         my $self = shift;
1067         my $eqstart = $self->equivalence( $self->collation->start );
1068         my $eqranks = { $eqstart => 0 };
1069         my $rankeqs = { 0 => [ $eqstart ] };
1070         my @curr_origin = ( $eqstart );
1071     # A little iterative function.
1072     while( @curr_origin ) {
1073         @curr_origin = $self->_assign_rank( $eqranks, $rankeqs, @curr_origin );
1074     }
1075         return( $eqranks, $rankeqs );
1076 }
1077
1078 sub _assign_rank {
1079     my( $self, $node_ranks, $rank_nodes, @current_nodes ) = @_;
1080     my $graph = $self->equivalence_graph;
1081     # Look at each of the children of @current_nodes.  If all the child's
1082     # parents have a rank, assign it the highest rank + 1 and add it to
1083     # @next_nodes.  Otherwise skip it; we will return when the highest-ranked
1084     # parent gets a rank.
1085     my @next_nodes;
1086     foreach my $c ( @current_nodes ) {
1087         warn "Current reading $c has no rank!"
1088             unless exists $node_ranks->{$c};
1089         foreach my $child ( $graph->successors( $c ) ) {
1090             next if exists $node_ranks->{$child};
1091             my $highest_rank = -1;
1092             my $skip = 0;
1093             foreach my $parent ( $graph->predecessors( $child ) ) {
1094                 if( exists $node_ranks->{$parent} ) {
1095                     $highest_rank = $node_ranks->{$parent}
1096                         if $highest_rank <= $node_ranks->{$parent};
1097                 } else {
1098                     $skip = 1;
1099                     last;
1100                 }
1101             }
1102             next if $skip;
1103             my $c_rank = $highest_rank + 1;
1104             # print STDERR "Assigning rank $c_rank to node $child \n";
1105             $node_ranks->{$child} = $c_rank if $node_ranks;
1106             push( @{$rank_nodes->{$c_rank}}, $child ) if $rank_nodes;
1107             push( @next_nodes, $child );
1108         }
1109     }
1110     return @next_nodes;
1111 }
1112
1113 ### Output logic
1114
1115 sub _as_graphml {
1116         my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_;
1117
1118     my $rgraph = $xmlroot->addNewChild( $graphml_ns, 'graph' );
1119         $rgraph->setAttribute( 'edgedefault', 'directed' );
1120     $rgraph->setAttribute( 'id', 'relationships', );
1121     $rgraph->setAttribute( 'parse.edgeids', 'canonical' );
1122     $rgraph->setAttribute( 'parse.edges', 0 );
1123     $rgraph->setAttribute( 'parse.nodeids', 'canonical' );
1124     $rgraph->setAttribute( 'parse.nodes', 0 );
1125     $rgraph->setAttribute( 'parse.order', 'nodesfirst' );
1126
1127     # Add the vertices according to their XML IDs
1128     my %rdg_lookup = ( reverse %$node_hash );
1129     # my @nlist = sort _by_xmlid keys( %rdg_lookup ); ## CAUSES SEGFAULT
1130     my @nlist = sort keys( %rdg_lookup );
1131     foreach my $n ( @nlist ) {
1132         my $n_el = $rgraph->addNewChild( $graphml_ns, 'node' );
1133         $n_el->setAttribute( 'id', $n );
1134         _add_graphml_data( $n_el, $nodeid_key, $rdg_lookup{$n} );
1135     }
1136         $rgraph->setAttribute( 'parse.nodes', scalar @nlist );
1137
1138     # Add the relationship edges, with their object information
1139     my $edge_ctr = 0;
1140     foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->graph->edges ) {
1141         # Add an edge and fill in its relationship info.
1142         next unless( exists $node_hash->{$e->[0]} && exists $node_hash->{$e->[1]} );
1143                 my $edge_el = $rgraph->addNewChild( $graphml_ns, 'edge' );
1144                 $edge_el->setAttribute( 'source', $node_hash->{$e->[0]} );
1145                 $edge_el->setAttribute( 'target', $node_hash->{$e->[1]} );
1146                 $edge_el->setAttribute( 'id', 'e'.$edge_ctr++ );
1147
1148                 my $rel_obj = $self->get_relationship( @$e );
1149                 foreach my $key ( keys %$edge_keys ) {
1150                         my $value = $rel_obj->$key;
1151                         _add_graphml_data( $edge_el, $edge_keys->{$key}, $value )
1152                                 if defined $value;
1153                 }
1154         }
1155         $rgraph->setAttribute( 'parse.edges', $edge_ctr );
1156 }
1157
1158 sub _by_xmlid {
1159         my $tmp_a = $a;
1160         my $tmp_b = $b;
1161         $tmp_a =~ s/\D//g;
1162         $tmp_b =~ s/\D//g;
1163         return $tmp_a <=> $tmp_b;
1164 }
1165
1166 sub _add_graphml_data {
1167     my( $el, $key, $value ) = @_;
1168     return unless defined $value;
1169     my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
1170     $data_el->setAttribute( 'key', $key );
1171     $data_el->appendText( $value );
1172 }
1173
1174 sub throw {
1175         Text::Tradition::Error->throw(
1176                 'ident' => 'Relationship error',
1177                 'message' => $_[0],
1178                 );
1179 }
1180
1181 no Moose;
1182 __PACKAGE__->meta->make_immutable;
1183
1184 1;