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 Text::Tradition;
 264 use TryCatch;
 265
 266 my $t1 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/legendfrag.xml' );
 267 # Test 1.1: try to equate nodes that are prevented with an intermediate collation
 268 ok( $t1, "Parsed test fragment file" );
 269 my $c1 = $t1->collation;
 270 my $trel = $c1->get_relationship( '9,2', '9,3' );
 271 is( ref( $trel ), 'Text::Tradition::Collation::Relationship',
 272         "Troublesome relationship exists" );
 273 is( $trel->type, 'collated', "Troublesome relationship is a collation" );
 274
 275 # Try to make the link we want
 276 try {
 277         $c1->add_relationship( '8,6', '10,3', { 'type' => 'orthographic' } );
 278         ok( 1, "Added cross-collation relationship as expected" );
 279 } catch( Text::Tradition::Error $e ) {
 280         ok( 0, "Existing collation blocked equivalence relationship: " . $e->message );
 281 }
 282
 283 try {
 284         $c1->calculate_ranks();
 285         ok( 1, "Successfully calculated ranks" );
 286 } catch ( Text::Tradition::Error $e ) {
 287         ok( 0, "Collation now has a cycle: " . $e->message );
 288 }
 289
 290 # Test 1.2: attempt merge of an identical reading
 291 try {
 292         $c1->merge_readings( '9,3', '11,5' );
 293         ok( 1, "Successfully merged reading 'pontifex'" );
 294 } catch ( Text::Tradition::Error $e ) {
 295         ok( 0, "Merge of mergeable readings failed: $e->message" );
 296
 297 }
 298
 299 # Test 1.3: attempt relationship with a meta reading (should fail)
 300 try {
 301         $c1->add_relationship( '8,1', '9,2', { 'type' => 'collated' } );
 302         ok( 0, "Allowed a meta-reading to be used in a relationship" );
 303 } catch ( Text::Tradition::Error $e ) {
 304         is( $e->message, 'Cannot set relationship on a meta reading',
 305                 "Relationship link prevented for a meta reading" );
 306 }
 307
 308 # Test 2.1: try to equate nodes that are prevented with a real intermediate
 309 # equivalence
 310 my $t2 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/legendfrag.xml' );
 311 my $c2 = $t2->collation;
 312 $c2->add_relationship( '9,2', '9,3', { 'type' => 'lexical' } );
 313 my $trel2 = $c2->get_relationship( '9,2', '9,3' );
 314 is( ref( $trel2 ), 'Text::Tradition::Collation::Relationship',
 315         "Created blocking relationship" );
 316 is( $trel2->type, 'lexical', "Blocking relationship is not a collation" );
 317 # This time the link ought to fail
 318 try {
 319         $c2->add_relationship( '8,6', '10,3', { 'type' => 'orthographic' } );
 320         ok( 0, "Added cross-equivalent bad relationship" );
 321 } catch ( Text::Tradition::Error $e ) {
 322         like( $e->message, qr/witness loop/,
 323                 "Existing equivalence blocked crossing relationship" );
 324 }
 325
 326 try {
 327         $c2->calculate_ranks();
 328         ok( 1, "Successfully calculated ranks" );
 329 } catch ( Text::Tradition::Error $e ) {
 330         ok( 0, "Collation now has a cycle: " . $e->message );
 331 }
 332
 333 # Test 3.1: make a straightforward pair of transpositions.
 334 my $t3 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/lf2.xml' );
 335 # Test 1: try to equate nodes that are prevented with an intermediate collation
 336 my $c3 = $t3->collation;
 337 try {
 338         $c3->add_relationship( '36,4', '38,3', { 'type' => 'transposition' } );
 339         ok( 1, "Added straightforward transposition" );
 340 } catch ( Text::Tradition::Error $e ) {
 341         ok( 0, "Failed to add normal transposition: " . $e->message );
 342 }
 343 try {
 344         $c3->add_relationship( '36,3', '38,2', { 'type' => 'transposition' } );
 345         ok( 1, "Added straightforward transposition complement" );
 346 } catch ( Text::Tradition::Error $e ) {
 347         ok( 0, "Failed to add normal transposition complement: " . $e->message );
 348 }
 349
 350 # Test 3.2: try to make a transposition that could be a parallel.
 351 try {
 352         $c3->add_relationship( '28,2', '29,2', { 'type' => 'transposition' } );
 353         ok( 0, "Added bad colocated transposition" );
 354 } catch ( Text::Tradition::Error $e ) {
 355         like( $e->message, qr/Readings appear to be colocated/,
 356                 "Prevented bad colocated transposition" );
 357 }
 358
 359 # Test 3.3: make the parallel, and then make the transposition again.
 360 try {
 361         $c3->add_relationship( '28,3', '29,3', { 'type' => 'orthographic' } );
 362         ok( 1, "Equated identical readings for transposition" );
 363 } catch ( Text::Tradition::Error $e ) {
 364         ok( 0, "Failed to equate identical readings: " . $e->message );
 365 }
 366 try {
 367         $c3->add_relationship( '28,2', '29,2', { 'type' => 'transposition' } );
 368         ok( 1, "Added straightforward transposition complement" );
 369 } catch ( Text::Tradition::Error $e ) {
 370         ok( 0, "Failed to add normal transposition complement: " . $e->message );
 371 }
 372
 373 =end testing
 374
 375 =cut
 376
 377 sub add_relationship {
 378         my( $self, $source, $target, $options ) = @_;
 379     my $c = $self->collation;
 380         my $sourceobj = $c->reading( $source );
 381         my $targetobj = $c->reading( $target );
 382         throw( "Adding self relationship at $source" ) if $source eq $target;
 383         throw( "Cannot set relationship on a meta reading" )
 384                 if( $sourceobj->is_meta || $targetobj->is_meta );
 385         my $relationship;
 386         my $thispaironly;
 387         my $droppedcolls = [];
 388         if( ref( $options ) eq 'Text::Tradition::Collation::Relationship' ) {
 389                 $relationship = $options;
 390                 $thispaironly = 1;  # If existing rel, set only where asked.
 391         } else {
 392                 # Check the options
 393                 $options->{'scope'} = 'local' unless $options->{'scope'};
 394                 $options->{'scope'} = 'local' if $options->{'type'} eq 'collated';
 395                 $options->{'scope'} = 'local' if $options->{'type'} eq 'transposition';
 396
 397                 my( $is_valid, $reason ) = $self->relationship_valid( $source, $target,
 398                         $options->{'type'}, $droppedcolls );
 399                 unless( $is_valid ) {
 400                         throw( "Invalid relationship: $reason" );
 401                 }
 402
 403                 # Try to create the relationship object.
 404                 $options->{'reading_a'} = $sourceobj->text;
 405                 $options->{'reading_b'} = $targetobj->text;
 406                 $options->{'orig_a'} = $source;
 407                 $options->{'orig_b'} = $target;
 408         if( $options->{'scope'} ne 'local' ) {
 409                         # Is there a relationship with this a & b already?
 410                         # Case-insensitive for non-orthographics.
 411                         my $rdga = $options->{'type'} eq 'orthographic'
 412                                 ? $options->{'reading_a'} : lc( $options->{'reading_a'} );
 413                         my $rdgb = $options->{'type'} eq 'orthographic'
 414                                 ? $options->{'reading_b'} : lc( $options->{'reading_b'} );
 415                         my $otherrel = $self->scoped_relationship( $rdga, $rdgb );
 416                         if( $otherrel && $otherrel->type eq $options->{type}
 417                                 && $otherrel->scope eq $options->{scope} ) {
 418                                 warn "Applying existing scoped relationship";
 419                                 $relationship = $otherrel;
 420                         }
 421         }
 422                 $relationship = $self->create( $options ) unless $relationship;  # Will throw on error
 423     }
 424
 425
 426         # Find all the pairs for which we need to set the relationship.
 427         my @vectors;
 428     if( $relationship->colocated && $relationship->nonlocal && !$thispaironly ) {
 429         push( @vectors, $self->_find_applicable( $relationship ) );
 430     }
 431
 432     # Now set the relationship(s).
 433     my @pairs_set;
 434         my $rel = $self->get_relationship( $source, $target );
 435         my $skip;
 436         if( $rel && $rel ne $relationship ) {
 437                 if( $rel->nonlocal ) {
 438                         throw( "Found conflicting relationship at $source - $target" );
 439                 } elsif( $rel->type ne 'collated' ) {
 440                         # Replace a collation relationship; leave any other sort in place.
 441                         my $r1ann = $rel->has_annotation ? $rel->annotation : '';
 442                         my $r2ann = $relationship->has_annotation ? $relationship->annotation : '';
 443                         unless( $rel->type eq $relationship->type && $r1ann eq $r2ann ) {
 444                                 warn sprintf( "Not overriding local relationship %s with global %s "
 445                                         . "set at %s -> %s (%s -> %s)", $rel->type, $relationship->type,
 446                                         $source, $target, $rel->reading_a, $rel->reading_b );
 447                                 $skip = 1;
 448                         }
 449                 }
 450         }
 451         $self->_set_relationship( $relationship, $source, $target ) unless $skip;
 452         push( @pairs_set, [ $source, $target ] );
 453
 454     # Set any additional relationships that might be in @vectors.
 455     foreach my $v ( @vectors ) {
 456         next if $v->[0] eq $source && $v->[1] eq $target;
 457         next if $v->[1] eq $source && $v->[0] eq $target;
 458         my @added = $self->add_relationship( @$v, $relationship );
 459         push( @pairs_set, @added );
 460     }
 461
 462     # Finally, restore whatever collations we can, and return.
 463     $self->_restore_collations( @$droppedcolls );
 464     return @pairs_set;
 465 }
 466
 467 =head2 del_scoped_relationship( $reading_a, $reading_b )
 468
 469 Returns the general (document-level or global) relationship that has been defined
 470 between the two reading strings. Returns undef if there is no general relationship.
 471
 472 =cut
 473
 474 sub del_scoped_relationship {
 475         my( $self, $rdga, $rdgb ) = @_;
 476         my( $first, $second ) = sort( $rdga, $rdgb );
 477         return delete $self->scopedrels->{$first}->{$second};
 478 }
 479
 480 sub _find_applicable {
 481         my( $self, $rel ) = @_;
 482         my $c = $self->collation;
 483         # TODO Someday we might use a case sensitive language.
 484         my $lang = $c->tradition->language;
 485         my @vectors;
 486         my @identical_readings;
 487         if( $rel->type eq 'orthographic' ) {
 488                 @identical_readings = grep { $_->text eq $rel->reading_a }
 489                         $c->readings;
 490         } else {
 491                 @identical_readings = grep { lc( $_->text ) eq lc( $rel->reading_a ) }
 492                         $c->readings;
 493         }
 494         foreach my $ir ( @identical_readings ) {
 495                 my @itarget;
 496                 if( $rel->type eq 'orthographic' ) {
 497                         @itarget = grep { $_->rank == $ir->rank
 498                                                           && $_->text eq $rel->reading_b } $c->readings;
 499                 } else {
 500                         @itarget = grep { $_->rank == $ir->rank
 501                                                           && lc( $_->text ) eq lc( $rel->reading_b ) } $c->readings;
 502                 }
 503                 if( @itarget ) {
 504                         # Warn if there is more than one hit with no orth link between them.
 505                         my $itmain = shift @itarget;
 506                         if( @itarget ) {
 507                                 my %all_targets;
 508                                 map { $all_targets{$_} = 1 } @itarget;
 509                                 map { delete $all_targets{$_} }
 510                                         $self->related_readings( $itmain,
 511                                                 sub { $_[0]->type eq 'orthographic' } );
 512                         warn "More than one unrelated reading with text " . $itmain->text
 513                                 . " at rank " . $ir->rank . "!" if keys %all_targets;
 514                         }
 515                         push( @vectors, [ $ir->id, $itmain->id ] );
 516                 }
 517         }
 518         return @vectors;
 519 }
 520
 521 =head2 del_relationship( $source, $target )
 522
 523 Removes the relationship between the given readings. If the relationship is
 524 non-local, removes the relationship everywhere in the graph.
 525
 526 =cut
 527
 528 sub del_relationship {
 529         my( $self, $source, $target ) = @_;
 530         my $rel = $self->get_relationship( $source, $target );
 531         return () unless $rel; # Nothing to delete; return an empty set.
 532         my $colo = $rel->colocated;
 533         my @vectors = ( [ $source, $target ] );
 534         $self->_remove_relationship( $colo, $source, $target );
 535         if( $rel->nonlocal ) {
 536                 # Remove the relationship wherever it occurs.
 537                 # Remove the relationship wherever it occurs.
 538                 my @rel_edges = grep { $self->get_relationship( @$_ ) == $rel }
 539                         $self->relationships;
 540                 foreach my $re ( @rel_edges ) {
 541                         $self->_remove_relationship( $colo, @$re );
 542                         push( @vectors, $re );
 543                 }
 544                 $self->del_scoped_relationship( $rel->reading_a, $rel->reading_b );
 545         }
 546         return @vectors;
 547 }
 548
 549 sub _remove_relationship {
 550         my( $self, $equiv, @vector ) = @_;
 551         $self->graph->delete_edge( @vector );
 552         $self->_break_equivalence( @vector ) if $equiv;
 553 }
 554
 555 =head2 relationship_valid( $source, $target, $type )
 556
 557 Checks whether a relationship of type $type may exist between the readings given
 558 in $source and $target.  Returns a tuple of ( status, message ) where status is
 559 a yes/no boolean and, if the answer is no, message gives the reason why.
 560
 561 =cut
 562
 563 sub relationship_valid {
 564     my( $self, $source, $target, $rel, $mustdrop ) = @_;
 565     $mustdrop = [] unless $mustdrop; # in case we were passed nothing
 566     my $c = $self->collation;
 567     if ( $rel eq 'transposition' || $rel eq 'repetition' ) {
 568                 # Check that the two readings do (for a repetition) or do not (for
 569                 # a transposition) appear in the same witness.
 570                 # TODO this might be called before witness paths are set...
 571                 my %seen_wits;
 572                 map { $seen_wits{$_} = 1 } $c->reading_witnesses( $source );
 573                 foreach my $w ( $c->reading_witnesses( $target ) ) {
 574                         if( $seen_wits{$w} ) {
 575                                 return ( 0, "Readings both occur in witness $w" )
 576                                         if $rel eq 'transposition';
 577                                 return ( 1, "ok" ) if $rel eq 'repetition';
 578                         }
 579                 }
 580                 return ( 0, "Readings occur only in distinct witnesses" )
 581                         if $rel eq 'repetition';
 582         }
 583         if ( $rel eq 'transposition' ) {
 584                 # We also need to check both that the readings occur in distinct
 585                 # witnesses, and that they are not in the same place. That is,
 586                 # proposing to link them should cause a witness loop.
 587                 if( $self->test_equivalence( $source, $target ) ) {
 588                         return ( 0, "Readings appear to be colocated, not transposed" );
 589                 } else {
 590                         return ( 1, "ok" );
 591                 }
 592
 593         } elsif( $rel ne 'repetition' ) {
 594                 # Check that linking the source and target in a relationship won't lead
 595                 # to a path loop for any witness.
 596                 # First, drop/stash any collations that might interfere
 597                 my $sourceobj = $c->reading( $source );
 598                 my $targetobj = $c->reading( $target );
 599                 my $sourcerank = $sourceobj->has_rank ? $sourceobj->rank : -1;
 600                 my $targetrank = $targetobj->has_rank ? $targetobj->rank : -1;
 601                 unless( $rel eq 'collated' || $sourcerank == $targetrank ) {
 602                         push( @$mustdrop, $self->_drop_collations( $source ) );
 603                         push( @$mustdrop, $self->_drop_collations( $target ) );
 604                         if( $c->end->has_rank ) {
 605                                 foreach my $rk ( $sourcerank .. $targetrank ) {
 606                                         map { push( @$mustdrop, $self->_drop_collations( $_->id ) ) }
 607                                                 $c->readings_at_rank( $rk );
 608                                 }
 609                         }
 610                 }
 611                 unless( $self->test_equivalence( $source, $target ) ) {
 612                         $self->_restore_collations( @$mustdrop );
 613                         return( 0, "Relationship would create witness loop" );
 614                 }
 615                 return ( 1, "ok" );
 616         }
 617 }
 618
 619 sub _drop_collations {
 620         my( $self, $reading ) = @_;
 621         my @dropped;
 622         foreach my $n ( $self->graph->neighbors( $reading ) ) {
 623                 if( $self->get_relationship( $reading, $n )->type eq 'collated' ) {
 624                         push( @dropped, [ $reading, $n ] );
 625                         $self->del_relationship( $reading, $n );
 626                         #print STDERR "Dropped collation $reading -> $n\n";
 627                 }
 628         }
 629         return @dropped;
 630 }
 631
 632 sub _restore_collations {
 633         my( $self, @vectors ) = @_;
 634         foreach my $v ( @vectors ) {
 635                 try {
 636                         $self->add_relationship( @$v, { 'type' => 'collated' } );
 637                         #print STDERR "Restored collation @$v\n";
 638                 } catch {
 639                         print STDERR $v->[0] . " - " . $v->[1] . " no longer collate\n";
 640                 }
 641         }
 642 }
 643
 644 =head2 filter_collations()
 645
 646 Utility function. Removes any redundant 'collated' relationships from the graph.
 647 A collated relationship is redundant if the readings in question would occupy
 648 the same rank regardless of the existence of the relationship.
 649
 650 =cut
 651
 652 sub filter_collations {
 653         my $self = shift;
 654         my $c = $self->collation;
 655         foreach my $r ( 1 .. $c->end->rank - 1 ) {
 656                 my $anchor;
 657                 my @need_collations;
 658                 foreach my $rdg ( $c->readings_at_rank( $r ) ) {
 659                         next if $rdg->is_meta;
 660                         my $ip = 0;
 661                         foreach my $pred ( $rdg->predecessors ) {
 662                                 if( $pred->rank == $r - 1 ) {
 663                                         $ip = 1;
 664                                         $anchor = $rdg unless( $anchor );
 665                                         last;
 666                                 }
 667                         }
 668                         push( @need_collations, $rdg ) unless $ip;
 669                         $c->relations->_drop_collations( "$rdg" );
 670                 }
 671                 $anchor
 672                         ? map { $c->add_relationship( $anchor, $_, { 'type' => 'collated' } )
 673                                                 unless $c->get_relationship( $anchor, $_ ) } @need_collations
 674                         : warn "No anchor found at $r";
 675         }
 676 }
 677
 678 =head2 related_readings( $reading, $filter )
 679
 680 Returns a list of readings that are connected via relationship links to $reading.
 681 If $filter is set to a subroutine ref, returns only those related readings where
 682 $filter( $relationship ) returns a true value.
 683
 684 =cut
 685
 686 sub related_readings {
 687         my( $self, $reading, $filter ) = @_;
 688         my $return_object;
 689         if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
 690                 $reading = $reading->id;
 691                 $return_object = 1;
 692         }
 693         my @answer;
 694         if( $filter ) {
 695                 # Backwards compat
 696                 if( $filter eq 'colocated' ) {
 697                         $filter = sub { $_[0]->colocated };
 698                 }
 699                 my %found = ( $reading => 1 );
 700                 my $check = [ $reading ];
 701                 my $iter = 0;
 702                 while( @$check ) {
 703                         my $more = [];
 704                         foreach my $r ( @$check ) {
 705                                 foreach my $nr ( $self->graph->neighbors( $r ) ) {
 706                                         if( &$filter( $self->get_relationship( $r, $nr ) ) ) {
 707                                                 push( @$more, $nr ) unless exists $found{$nr};
 708                                                 $found{$nr} = 1;
 709                                         }
 710                                 }
 711                         }
 712                         $check = $more;
 713                 }
 714                 delete $found{$reading};
 715                 @answer = keys %found;
 716         } else {
 717                 @answer = $self->graph->all_reachable( $reading );
 718         }
 719         if( $return_object ) {
 720                 my $c = $self->collation;
 721                 return map { $c->reading( $_ ) } @answer;
 722         } else {
 723                 return @answer;
 724         }
 725 }
 726
 727 =head2 merge_readings( $kept, $deleted );
 728
 729 Makes a best-effort merge of the relationship links between the given readings, and
 730 stops tracking the to-be-deleted reading.
 731
 732 =cut
 733
 734 sub merge_readings {
 735         my( $self, $kept, $deleted, $combined ) = @_;
 736         foreach my $edge ( $self->graph->edges_at( $deleted ) ) {
 737                 # Get the pair of kept / rel
 738                 my @vector = ( $kept );
 739                 push( @vector, $edge->[0] eq $deleted ? $edge->[1] : $edge->[0] );
 740                 next if $vector[0] eq $vector[1]; # Don't add a self loop
 741
 742                 # If kept changes its text, drop the relationship.
 743                 next if $combined;
 744
 745                 # If kept / rel already has a relationship, just keep the old
 746                 my $rel = $self->get_relationship( @vector );
 747                 next if $rel;
 748
 749                 # Otherwise, adopt the relationship that would be deleted.
 750                 $rel = $self->get_relationship( @$edge );
 751                 $self->_set_relationship( $rel, @vector );
 752         }
 753         $self->_make_equivalence( $deleted, $kept );
 754 }
 755
 756 ### Equivalence logic
 757
 758 sub _remove_equivalence_node {
 759         my( $self, $node ) = @_;
 760         my $group = $self->equivalence( $node );
 761         my $nodelist = $self->eqreadings( $group );
 762         if( @$nodelist == 1 && $nodelist->[0] eq $node ) {
 763                 print STDERR "Removing equivalence $group for $node\n" if $node eq '451,2';
 764                 $self->remove_eqreadings( $group );
 765         } elsif( @$nodelist == 1 ) {
 766                 warn "DATA INCONSISTENCY in equivalence graph: " . $nodelist->[0] .
 767                         " in group that should have only $node";
 768         } else {
 769                 print STDERR "Removing $node from equivalence $group\n" if $node eq '451,2';
 770                 my @newlist = grep { $_ ne $node } @$nodelist;
 771                 $self->set_eqreadings( $group, \@newlist );
 772                 $self->remove_equivalence( $node );
 773         }
 774 }
 775
 776 =head2 add_equivalence_edge
 777
 778 Add an edge in the equivalence graph corresponding to $source -> $target in the
 779 collation. Should only be called by Collation.
 780
 781 =cut
 782
 783 sub add_equivalence_edge {
 784         my( $self, $source, $target ) = @_;
 785         my $seq = $self->equivalence( $source );
 786         my $teq = $self->equivalence( $target );
 787         $self->equivalence_graph->add_edge( $seq, $teq );
 788 }
 789
 790 =head2 delete_equivalence_edge
 791
 792 Remove an edge in the equivalence graph corresponding to $source -> $target in the
 793 collation. Should only be called by Collation.
 794
 795 =cut
 796
 797 sub delete_equivalence_edge {
 798         my( $self, $source, $target ) = @_;
 799         my $seq = $self->equivalence( $source );
 800         my $teq = $self->equivalence( $target );
 801         print STDERR "Deleting equivalence edge $seq -> $teq for $source -> $target\n"
 802                 if grep { $_ eq '451,2' } @_;
 803         $self->equivalence_graph->delete_edge( $seq, $teq );
 804 }
 805
 806 sub _is_disconnected {
 807         my $self = shift;
 808         return( scalar $self->equivalence_graph->predecessorless_vertices > 1
 809                 || scalar $self->equivalence_graph->successorless_vertices > 1 );
 810 }
 811
 812 # Equate two readings in the equivalence graph
 813 sub _make_equivalence {
 814         my( $self, $source, $target ) = @_;
 815         # Get the source equivalent readings
 816         my $seq = $self->equivalence( $source );
 817         my $teq = $self->equivalence( $target );
 818         # Nothing to do if they are already equivalent...
 819         return if $seq eq $teq;
 820         print STDERR "Making equivalence for $source -> $target\n"
 821                 if grep { $_ eq '451,2' } @_;
 822         my $sourcepool = $self->eqreadings( $seq );
 823         # and add them to the target readings.
 824         print STDERR "Moving readings '@$sourcepool' from group $seq to $teq\n"
 825                 if grep { $_ eq '451,2' } @_;
 826         push( @{$self->eqreadings( $teq )}, @$sourcepool );
 827         map { $self->set_equivalence( $_, $teq ) } @$sourcepool;
 828         # Then merge the nodes in the equivalence graph.
 829         foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
 830                 $self->equivalence_graph->add_edge( $pred, $teq );
 831         }
 832         foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
 833                 $self->equivalence_graph->add_edge( $teq, $succ );
 834         }
 835         $self->equivalence_graph->delete_vertex( $seq );
 836         # TODO enable this after collation parsing is done
 837 #       throw( "Graph got disconnected making $source / $target equivalence" )
 838 #               if $self->_is_disconnected;
 839 }
 840
 841 =head2 test_equivalence
 842
 843 Test whether, if two readings were equated with a 'colocated' relationship,
 844 the graph would still be valid.
 845
 846 =cut
 847
 848 sub test_equivalence {
 849         my( $self, $source, $target ) = @_;
 850         # Try merging the nodes in the equivalence graph; return a true value if
 851         # no cycle is introduced thereby. Restore the original graph first.
 852
 853         # Keep track of edges we add
 854         my %added_pred;
 855         my %added_succ;
 856         # Get the reading equivalents
 857         my $seq = $self->equivalence( $source );
 858         my $teq = $self->equivalence( $target );
 859         # Maybe this is easy?
 860         return 1 if $seq eq $teq;
 861
 862         # Save the first graph
 863         my $checkstr = $self->equivalence_graph->stringify();
 864         # Add and save relevant edges
 865         foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
 866                 if( $self->equivalence_graph->has_edge( $pred, $teq ) ) {
 867                         $added_pred{$pred} = 0;
 868                 } else {
 869                         $self->equivalence_graph->add_edge( $pred, $teq );
 870                         $added_pred{$pred} = 1;
 871                 }
 872         }
 873         foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
 874                 if( $self->equivalence_graph->has_edge( $teq, $succ ) ) {
 875                         $added_succ{$succ} = 0;
 876                 } else {
 877                         $self->equivalence_graph->add_edge( $teq, $succ );
 878                         $added_succ{$succ} = 1;
 879                 }
 880         }
 881         # Delete source equivalent and test
 882         $self->equivalence_graph->delete_vertex( $seq );
 883         my $ret = !$self->equivalence_graph->has_a_cycle;
 884
 885         # Restore what we changed
 886         $self->equivalence_graph->add_vertex( $seq );
 887         foreach my $pred ( keys %added_pred ) {
 888                 $self->equivalence_graph->add_edge( $pred, $seq );
 889                 $self->equivalence_graph->delete_edge( $pred, $teq ) if $added_pred{$pred};
 890         }
 891         foreach my $succ ( keys %added_succ ) {
 892                 $self->equivalence_graph->add_edge( $seq, $succ );
 893                 $self->equivalence_graph->delete_edge( $teq, $succ ) if $added_succ{$succ};
 894         }
 895         unless( $self->equivalence_graph->eq( $checkstr ) ) {
 896                 warn "GRAPH CHANGED after testing";
 897         }
 898         # Return our answer
 899         return $ret;
 900 }
 901
 902 # Unmake an equivalence link between two readings. Should only be called internally.
 903 sub _break_equivalence {
 904         my( $self, $source, $target ) = @_;
 905
 906         # This is the hard one. Need to reconstruct the equivalence groups without
 907         # the given link.
 908         my( %sng, %tng );
 909         map { $sng{$_} = 1 } $self->_find_equiv_without( $source, $target );
 910         map { $tng{$_} = 1 } $self->_find_equiv_without( $target, $source );
 911         # If these groups intersect, they are still connected; do nothing.
 912         foreach my $el ( keys %tng ) {
 913                 if( exists $sng{$el} ) {
 914                         print STDERR "Equivalence break $source / $target is a noop\n"
 915                                 if grep { $_ eq '451,2' } @_;
 916                         return;
 917                 }
 918         }
 919         print STDERR "Breaking equivalence $source / $target\n"
 920                 if grep { $_ eq '451,2' } @_;
 921         # If they don't intersect, then we split the nodes in the graph and in
 922         # the hashes. First figure out which group has which name
 923         my $oldgroup = $self->equivalence( $source ); # same as $target
 924         my $keepsource = $sng{$oldgroup};
 925         my $newgroup = $keepsource ? $target : $source;
 926         my( $oldmembers, $newmembers );
 927         if( $keepsource ) {
 928                 $oldmembers = [ keys %sng ];
 929                 $newmembers = [ keys %tng ];
 930         } else {
 931                 $oldmembers = [ keys %tng ];
 932                 $newmembers = [ keys %sng ];
 933         }
 934
 935         # First alter the old group in the hash
 936         $self->set_eqreadings( $oldgroup, $oldmembers );
 937         foreach my $el ( @$oldmembers ) {
 938                 $self->set_equivalence( $el, $oldgroup );
 939         }
 940
 941         # then add the new group back to the hash with its new key
 942         $self->set_eqreadings( $newgroup, $newmembers );
 943         foreach my $el ( @$newmembers ) {
 944                 $self->set_equivalence( $el, $newgroup );
 945         }
 946
 947         # Now add the new group back to the equivalence graph
 948         $self->equivalence_graph->add_vertex( $newgroup );
 949         # ...add the appropriate edges to the source group vertext
 950         my $c = $self->collation;
 951         foreach my $rdg ( @$newmembers ) {
 952                 foreach my $rp ( $c->sequence->predecessors( $rdg ) ) {
 953                         $self->equivalence_graph->add_edge( $self->equivalence( $rp ), $newgroup );
 954                 }
 955                 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
 956                         $self->equivalence_graph->add_edge( $newgroup, $self->equivalence( $rs ) );
 957                 }
 958         }
 959
 960         # ...and figure out which edges on the old group vertex to delete.
 961         my( %old_pred, %old_succ );
 962         foreach my $rdg ( @$oldmembers ) {
 963                 foreach my $rp ( $c->sequence->predecessors( $rdg ) ) {
 964                         $old_pred{$self->equivalence( $rp )} = 1;
 965                 }
 966                 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
 967                         $old_succ{$self->equivalence( $rs )} = 1;
 968                 }
 969         }
 970         foreach my $p ( $self->equivalence_graph->predecessors( $oldgroup ) ) {
 971                 unless( $old_pred{$p} ) {
 972                         $self->equivalence_graph->delete_edge( $p, $oldgroup );
 973                 }
 974         }
 975         foreach my $s ( $self->equivalence_graph->successors( $oldgroup ) ) {
 976                 unless( $old_succ{$s} ) {
 977                         $self->equivalence_graph->delete_edge( $oldgroup, $s );
 978                 }
 979         }
 980         # TODO enable this after collation parsing is done
 981 #       throw( "Graph got disconnected breaking $source / $target equivalence" )
 982 #               if $self->_is_disconnected;
 983 }
 984
 985 sub _find_equiv_without {
 986         my( $self, $first, $second ) = @_;
 987         my %found = ( $first => 1 );
 988         my $check = [ $first ];
 989         my $iter = 0;
 990         while( @$check ) {
 991                 my $more = [];
 992                 foreach my $r ( @$check ) {
 993                         foreach my $nr ( $self->graph->neighbors( $r ) ) {
 994                                 next if $r eq $second;
 995                                 if( $self->get_relationship( $r, $nr )->colocated ) {
 996                                         push( @$more, $nr ) unless exists $found{$nr};
 997                                         $found{$nr} = 1;
 998                                 }
 999                         }
1000                 }
1001                 $check = $more;
1002         }
1003         return keys %found;
1004 }
1005
1006 =head2 rebuild_equivalence
1007
1008 (Re)build the equivalence graph from scratch. Dumps the graph, makes a new one,
1009 adds all readings and edges, then makes an equivalence for all relationships.
1010
1011 =cut
1012
1013 sub rebuild_equivalence {
1014         my $self = shift;
1015         my $newgraph = Graph->new();
1016         # Set this as the new equivalence graph
1017         $self->_reset_equivalence( $newgraph );
1018         # Clear out the data hashes
1019         $self->_clear_equivalence;
1020         $self->_clear_eqreadings;
1021
1022         # Add the readings
1023         foreach my $r ( $self->collation->readings ) {
1024                 my $rid = $r->id;
1025                 $newgraph->add_vertex( $rid );
1026                 $self->set_equivalence( $rid, $rid );
1027                 $self->set_eqreadings( $rid, [ $rid ] );
1028         }
1029
1030         # Now add the edges
1031         foreach my $e ( $self->collation->paths ) {
1032                 $self->add_equivalence_edge( @$e );
1033         }
1034
1035         # Now equate the colocated readings. This does no testing;
1036         # it assumes that all preexisting relationships are valid.
1037         foreach my $rel ( $self->relationships ) {
1038                 my $relobj = $self->get_relationship( $rel );
1039                 next unless $relobj && $relobj->colocated;
1040                 $self->_make_equivalence( @$rel );
1041         }
1042 }
1043
1044 ### Output logic
1045
1046 sub _as_graphml {
1047         my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_;
1048
1049     my $rgraph = $xmlroot->addNewChild( $graphml_ns, 'graph' );
1050         $rgraph->setAttribute( 'edgedefault', 'directed' );
1051     $rgraph->setAttribute( 'id', 'relationships', );
1052     $rgraph->setAttribute( 'parse.edgeids', 'canonical' );
1053     $rgraph->setAttribute( 'parse.edges', 0 );
1054     $rgraph->setAttribute( 'parse.nodeids', 'canonical' );
1055     $rgraph->setAttribute( 'parse.nodes', 0 );
1056     $rgraph->setAttribute( 'parse.order', 'nodesfirst' );
1057
1058     # Add the vertices according to their XML IDs
1059     my %rdg_lookup = ( reverse %$node_hash );
1060     # my @nlist = sort _by_xmlid keys( %rdg_lookup ); ## CAUSES SEGFAULT
1061     my @nlist = sort keys( %rdg_lookup );
1062     foreach my $n ( @nlist ) {
1063         my $n_el = $rgraph->addNewChild( $graphml_ns, 'node' );
1064         $n_el->setAttribute( 'id', $n );
1065         _add_graphml_data( $n_el, $nodeid_key, $rdg_lookup{$n} );
1066     }
1067         $rgraph->setAttribute( 'parse.nodes', scalar @nlist );
1068
1069     # Add the relationship edges, with their object information
1070     my $edge_ctr = 0;
1071     foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->graph->edges ) {
1072         # Add an edge and fill in its relationship info.
1073         next unless( exists $node_hash->{$e->[0]} && exists $node_hash->{$e->[1]} );
1074                 my $edge_el = $rgraph->addNewChild( $graphml_ns, 'edge' );
1075                 $edge_el->setAttribute( 'source', $node_hash->{$e->[0]} );
1076                 $edge_el->setAttribute( 'target', $node_hash->{$e->[1]} );
1077                 $edge_el->setAttribute( 'id', 'e'.$edge_ctr++ );
1078
1079                 my $rel_obj = $self->get_relationship( @$e );
1080                 foreach my $key ( keys %$edge_keys ) {
1081                         my $value = $rel_obj->$key;
1082                         _add_graphml_data( $edge_el, $edge_keys->{$key}, $value )
1083                                 if defined $value;
1084                 }
1085         }
1086         $rgraph->setAttribute( 'parse.edges', $edge_ctr );
1087 }
1088
1089 sub _by_xmlid {
1090         my $tmp_a = $a;
1091         my $tmp_b = $b;
1092         $tmp_a =~ s/\D//g;
1093         $tmp_b =~ s/\D//g;
1094         return $tmp_a <=> $tmp_b;
1095 }
1096
1097 sub _add_graphml_data {
1098     my( $el, $key, $value ) = @_;
1099     return unless defined $value;
1100     my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
1101     $data_el->setAttribute( 'key', $key );
1102     $data_el->appendText( $value );
1103 }
1104
1105 sub throw {
1106         Text::Tradition::Error->throw(
1107                 'ident' => 'Relationship error',
1108                 'message' => $_[0],
1109                 );
1110 }
1111
1112 no Moose;
1113 __PACKAGE__->meta->make_immutable;
1114
1115 1;