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         return unless $seq && $teq;
 810         $self->equivalence_graph->add_edge( $seq, $teq );
 811 }
 812
 813 =head2 delete_equivalence_edge
 814
 815 Remove an edge in the equivalence graph corresponding to $source -> $target in the
 816 collation. Should only be called by Collation.
 817
 818 =cut
 819
 820 sub delete_equivalence_edge {
 821         my( $self, $source, $target ) = @_;
 822         my $seq = $self->equivalence( $source );
 823         my $teq = $self->equivalence( $target );
 824         $self->equivalence_graph->delete_edge( $seq, $teq );
 825 }
 826
 827 sub _is_disconnected {
 828         my $self = shift;
 829         return( scalar $self->equivalence_graph->predecessorless_vertices > 1
 830                 || scalar $self->equivalence_graph->successorless_vertices > 1 );
 831 }
 832
 833 # Equate two readings in the equivalence graph
 834 sub _make_equivalence {
 835         my( $self, $source, $target ) = @_;
 836         # Get the source equivalent readings
 837         my $seq = $self->equivalence( $source );
 838         my $teq = $self->equivalence( $target );
 839         # Nothing to do if they are already equivalent...
 840         return if $seq eq $teq;
 841         my $sourcepool = $self->eqreadings( $seq );
 842         # and add them to the target readings.
 843         push( @{$self->eqreadings( $teq )}, @$sourcepool );
 844         map { $self->set_equivalence( $_, $teq ) } @$sourcepool;
 845         # Then merge the nodes in the equivalence graph.
 846         foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
 847                 $self->equivalence_graph->add_edge( $pred, $teq );
 848         }
 849         foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
 850                 $self->equivalence_graph->add_edge( $teq, $succ );
 851         }
 852         $self->equivalence_graph->delete_vertex( $seq );
 853         # TODO enable this after collation parsing is done
 854         throw( "Graph got disconnected making $source / $target equivalence" )
 855                 if $self->_is_disconnected && $self->collation->tradition->_initialized;
 856 }
 857
 858 =head2 test_equivalence
 859
 860 Test whether, if two readings were equated with a 'colocated' relationship,
 861 the graph would still be valid.
 862
 863 =cut
 864
 865 sub test_equivalence {
 866         my( $self, $source, $target ) = @_;
 867         # Try merging the nodes in the equivalence graph; return a true value if
 868         # no cycle is introduced thereby. Restore the original graph first.
 869
 870         # Keep track of edges we add
 871         my %added_pred;
 872         my %added_succ;
 873         # Get the reading equivalents
 874         my $seq = $self->equivalence( $source );
 875         my $teq = $self->equivalence( $target );
 876         # Maybe this is easy?
 877         return 1 if $seq eq $teq;
 878
 879         # Save the first graph
 880         my $checkstr = $self->equivalence_graph->stringify();
 881         # Add and save relevant edges
 882         foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
 883                 if( $self->equivalence_graph->has_edge( $pred, $teq ) ) {
 884                         $added_pred{$pred} = 0;
 885                 } else {
 886                         $self->equivalence_graph->add_edge( $pred, $teq );
 887                         $added_pred{$pred} = 1;
 888                 }
 889         }
 890         foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
 891                 if( $self->equivalence_graph->has_edge( $teq, $succ ) ) {
 892                         $added_succ{$succ} = 0;
 893                 } else {
 894                         $self->equivalence_graph->add_edge( $teq, $succ );
 895                         $added_succ{$succ} = 1;
 896                 }
 897         }
 898         # Delete source equivalent and test
 899         $self->equivalence_graph->delete_vertex( $seq );
 900         my $ret = !$self->equivalence_graph->has_a_cycle;
 901
 902         # Restore what we changed
 903         $self->equivalence_graph->add_vertex( $seq );
 904         foreach my $pred ( keys %added_pred ) {
 905                 $self->equivalence_graph->add_edge( $pred, $seq );
 906                 $self->equivalence_graph->delete_edge( $pred, $teq ) if $added_pred{$pred};
 907         }
 908         foreach my $succ ( keys %added_succ ) {
 909                 $self->equivalence_graph->add_edge( $seq, $succ );
 910                 $self->equivalence_graph->delete_edge( $teq, $succ ) if $added_succ{$succ};
 911         }
 912         unless( $self->equivalence_graph->eq( $checkstr ) ) {
 913                 warn "GRAPH CHANGED after testing";
 914         }
 915         # Return our answer
 916         return $ret;
 917 }
 918
 919 # Unmake an equivalence link between two readings. Should only be called internally.
 920 sub _break_equivalence {
 921         my( $self, $source, $target ) = @_;
 922
 923         # This is the hard one. Need to reconstruct the equivalence groups without
 924         # the given link.
 925         my( %sng, %tng );
 926         map { $sng{$_} = 1 } $self->_find_equiv_without( $source, $target );
 927         map { $tng{$_} = 1 } $self->_find_equiv_without( $target, $source );
 928         # If these groups intersect, they are still connected; do nothing.
 929         foreach my $el ( keys %tng ) {
 930                 return if( exists $sng{$el} );
 931         }
 932         # If they don't intersect, then we split the nodes in the graph and in
 933         # the hashes. First figure out which group has which name
 934         my $oldgroup = $self->equivalence( $source ); # same as $target
 935         my $keepsource = $sng{$oldgroup};
 936         my $newgroup = $keepsource ? $target : $source;
 937         my( $oldmembers, $newmembers );
 938         if( $keepsource ) {
 939                 $oldmembers = [ keys %sng ];
 940                 $newmembers = [ keys %tng ];
 941         } else {
 942                 $oldmembers = [ keys %tng ];
 943                 $newmembers = [ keys %sng ];
 944         }
 945
 946         # First alter the old group in the hash
 947         $self->set_eqreadings( $oldgroup, $oldmembers );
 948         foreach my $el ( @$oldmembers ) {
 949                 $self->set_equivalence( $el, $oldgroup );
 950         }
 951
 952         # then add the new group back to the hash with its new key
 953         $self->set_eqreadings( $newgroup, $newmembers );
 954         foreach my $el ( @$newmembers ) {
 955                 $self->set_equivalence( $el, $newgroup );
 956         }
 957
 958         # Now add the new group back to the equivalence graph
 959         $self->equivalence_graph->add_vertex( $newgroup );
 960         # ...add the appropriate edges to the source group vertext
 961         my $c = $self->collation;
 962         foreach my $rdg ( @$newmembers ) {
 963                 foreach my $rp ( $c->sequence->predecessors( $rdg ) ) {
 964                         next unless $self->equivalence( $rp );
 965                         $self->equivalence_graph->add_edge( $self->equivalence( $rp ), $newgroup );
 966                 }
 967                 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
 968                         next unless $self->equivalence( $rs );
 969                         $self->equivalence_graph->add_edge( $newgroup, $self->equivalence( $rs ) );
 970                 }
 971         }
 972
 973         # ...and figure out which edges on the old group vertex to delete.
 974         my( %old_pred, %old_succ );
 975         foreach my $rdg ( @$oldmembers ) {
 976                 foreach my $rp ( $c->sequence->predecessors( $rdg ) ) {
 977                         next unless $self->equivalence( $rp );
 978                         $old_pred{$self->equivalence( $rp )} = 1;
 979                 }
 980                 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
 981                         next unless $self->equivalence( $rs );
 982                         $old_succ{$self->equivalence( $rs )} = 1;
 983                 }
 984         }
 985         foreach my $p ( $self->equivalence_graph->predecessors( $oldgroup ) ) {
 986                 unless( $old_pred{$p} ) {
 987                         $self->equivalence_graph->delete_edge( $p, $oldgroup );
 988                 }
 989         }
 990         foreach my $s ( $self->equivalence_graph->successors( $oldgroup ) ) {
 991                 unless( $old_succ{$s} ) {
 992                         $self->equivalence_graph->delete_edge( $oldgroup, $s );
 993                 }
 994         }
 995         # TODO enable this after collation parsing is done
 996         throw( "Graph got disconnected breaking $source / $target equivalence" )
 997                 if $self->_is_disconnected && $self->collation->tradition->_initialized;
 998 }
 999
1000 sub _find_equiv_without {
1001         my( $self, $first, $second ) = @_;
1002         my %found = ( $first => 1 );
1003         my $check = [ $first ];
1004         my $iter = 0;
1005         while( @$check ) {
1006                 my $more = [];
1007                 foreach my $r ( @$check ) {
1008                         foreach my $nr ( $self->graph->neighbors( $r ) ) {
1009                                 next if $r eq $second;
1010                                 if( $self->get_relationship( $r, $nr )->colocated ) {
1011                                         push( @$more, $nr ) unless exists $found{$nr};
1012                                         $found{$nr} = 1;
1013                                 }
1014                         }
1015                 }
1016                 $check = $more;
1017         }
1018         return keys %found;
1019 }
1020
1021 =head2 rebuild_equivalence
1022
1023 (Re)build the equivalence graph from scratch. Dumps the graph, makes a new one,
1024 adds all readings and edges, then makes an equivalence for all relationships.
1025
1026 =cut
1027
1028 sub rebuild_equivalence {
1029         my $self = shift;
1030         my $newgraph = Graph->new();
1031         # Set this as the new equivalence graph
1032         $self->_reset_equivalence( $newgraph );
1033         # Clear out the data hashes
1034         $self->_clear_equivalence;
1035         $self->_clear_eqreadings;
1036
1037         # Add the readings
1038         foreach my $r ( $self->collation->readings ) {
1039                 my $rid = $r->id;
1040                 $newgraph->add_vertex( $rid );
1041                 $self->set_equivalence( $rid, $rid );
1042                 $self->set_eqreadings( $rid, [ $rid ] );
1043         }
1044
1045         # Now add the edges
1046         foreach my $e ( $self->collation->paths ) {
1047                 $self->add_equivalence_edge( @$e );
1048         }
1049
1050         # Now equate the colocated readings. This does no testing;
1051         # it assumes that all preexisting relationships are valid.
1052         foreach my $rel ( $self->relationships ) {
1053                 my $relobj = $self->get_relationship( $rel );
1054                 next unless $relobj && $relobj->colocated;
1055                 $self->_make_equivalence( @$rel );
1056         }
1057 }
1058
1059 =head2 equivalence_ranks
1060
1061 Rank all vertices in the equivalence graph, and return a hash reference with
1062 vertex => rank mapping.
1063
1064 =cut
1065
1066 sub equivalence_ranks {
1067         my $self = shift;
1068         my $eqstart = $self->equivalence( $self->collation->start );
1069         my $eqranks = { $eqstart => 0 };
1070         my $rankeqs = { 0 => [ $eqstart ] };
1071         my @curr_origin = ( $eqstart );
1072     # A little iterative function.
1073     while( @curr_origin ) {
1074         @curr_origin = $self->_assign_rank( $eqranks, $rankeqs, @curr_origin );
1075     }
1076         return( $eqranks, $rankeqs );
1077 }
1078
1079 sub _assign_rank {
1080     my( $self, $node_ranks, $rank_nodes, @current_nodes ) = @_;
1081     my $graph = $self->equivalence_graph;
1082     # Look at each of the children of @current_nodes.  If all the child's
1083     # parents have a rank, assign it the highest rank + 1 and add it to
1084     # @next_nodes.  Otherwise skip it; we will return when the highest-ranked
1085     # parent gets a rank.
1086     my @next_nodes;
1087     foreach my $c ( @current_nodes ) {
1088         warn "Current reading $c has no rank!"
1089             unless exists $node_ranks->{$c};
1090         foreach my $child ( $graph->successors( $c ) ) {
1091             next if exists $node_ranks->{$child};
1092             my $highest_rank = -1;
1093             my $skip = 0;
1094             foreach my $parent ( $graph->predecessors( $child ) ) {
1095                 if( exists $node_ranks->{$parent} ) {
1096                     $highest_rank = $node_ranks->{$parent}
1097                         if $highest_rank <= $node_ranks->{$parent};
1098                 } else {
1099                     $skip = 1;
1100                     last;
1101                 }
1102             }
1103             next if $skip;
1104             my $c_rank = $highest_rank + 1;
1105             # print STDERR "Assigning rank $c_rank to node $child \n";
1106             $node_ranks->{$child} = $c_rank if $node_ranks;
1107             push( @{$rank_nodes->{$c_rank}}, $child ) if $rank_nodes;
1108             push( @next_nodes, $child );
1109         }
1110     }
1111     return @next_nodes;
1112 }
1113
1114 ### Output logic
1115
1116 sub _as_graphml {
1117         my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_;
1118
1119     my $rgraph = $xmlroot->addNewChild( $graphml_ns, 'graph' );
1120         $rgraph->setAttribute( 'edgedefault', 'directed' );
1121     $rgraph->setAttribute( 'id', 'relationships', );
1122     $rgraph->setAttribute( 'parse.edgeids', 'canonical' );
1123     $rgraph->setAttribute( 'parse.edges', 0 );
1124     $rgraph->setAttribute( 'parse.nodeids', 'canonical' );
1125     $rgraph->setAttribute( 'parse.nodes', 0 );
1126     $rgraph->setAttribute( 'parse.order', 'nodesfirst' );
1127
1128     # Add the vertices according to their XML IDs
1129     my %rdg_lookup = ( reverse %$node_hash );
1130     # my @nlist = sort _by_xmlid keys( %rdg_lookup ); ## CAUSES SEGFAULT
1131     my @nlist = sort keys( %rdg_lookup );
1132     foreach my $n ( @nlist ) {
1133         my $n_el = $rgraph->addNewChild( $graphml_ns, 'node' );
1134         $n_el->setAttribute( 'id', $n );
1135         _add_graphml_data( $n_el, $nodeid_key, $rdg_lookup{$n} );
1136     }
1137         $rgraph->setAttribute( 'parse.nodes', scalar @nlist );
1138
1139     # Add the relationship edges, with their object information
1140     my $edge_ctr = 0;
1141     foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->graph->edges ) {
1142         # Add an edge and fill in its relationship info.
1143         next unless( exists $node_hash->{$e->[0]} && exists $node_hash->{$e->[1]} );
1144                 my $edge_el = $rgraph->addNewChild( $graphml_ns, 'edge' );
1145                 $edge_el->setAttribute( 'source', $node_hash->{$e->[0]} );
1146                 $edge_el->setAttribute( 'target', $node_hash->{$e->[1]} );
1147                 $edge_el->setAttribute( 'id', 'e'.$edge_ctr++ );
1148
1149                 my $rel_obj = $self->get_relationship( @$e );
1150                 foreach my $key ( keys %$edge_keys ) {
1151                         my $value = $rel_obj->$key;
1152                         _add_graphml_data( $edge_el, $edge_keys->{$key}, $value )
1153                                 if defined $value;
1154                 }
1155         }
1156         $rgraph->setAttribute( 'parse.edges', $edge_ctr );
1157 }
1158
1159 sub _by_xmlid {
1160         my $tmp_a = $a;
1161         my $tmp_b = $b;
1162         $tmp_a =~ s/\D//g;
1163         $tmp_b =~ s/\D//g;
1164         return $tmp_a <=> $tmp_b;
1165 }
1166
1167 sub _add_graphml_data {
1168     my( $el, $key, $value ) = @_;
1169     return unless defined $value;
1170     my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
1171     $data_el->setAttribute( 'key', $key );
1172     $data_el->appendText( $value );
1173 }
1174
1175 sub throw {
1176         Text::Tradition::Error->throw(
1177                 'ident' => 'Relationship error',
1178                 'message' => $_[0],
1179                 );
1180 }
1181
1182 no Moose;
1183 __PACKAGE__->meta->make_immutable;
1184
1185 1;