lib/Text/Tradition/Collation/RelationshipStore.pm

   1 package Text::Tradition::Collation::RelationshipStore;
   2
   3 use strict;
   4 use warnings;
   5 use Text::Tradition::Collation::Relationship;
   6
   7 use Moose;
   8
   9 =head1 NAME
  10
  11 Text::Tradition::Collation::RelationshipStore - Keeps track of the relationships
  12 between readings in a given collation
  13
  14 =head1 DESCRIPTION
  15
  16 Text::Tradition is a library for representation and analysis of collated
  17 texts, particularly medieval ones.  The RelationshipStore is an internal object
  18 of the collation, to keep track of the defined relationships (both specific and
  19 general) between readings.
  20
  21 =head1 METHODS
  22
  23 =head2 new( collation => $collation );
  24
  25 Creates a new relationship store for the given collation.
  26
  27 =cut
  28
  29 has 'collation' => (
  30         is => 'ro',
  31         isa => 'Text::Tradition::Collation',
  32         required => 1,
  33         weak_ref => 1,
  34         );
  35
  36 has 'scopedrels' => (
  37         is => 'ro',
  38         isa => 'HashRef[HashRef[Text::Tradition::Collation::Relationship]]',
  39         default => sub { {} },
  40         );
  41
  42 has 'graph' => (
  43         is => 'ro',
  44         isa => 'Graph',
  45         default => sub { Graph->new( undirected => 1 ) },
  46     handles => {
  47         relationships => 'edges',
  48         add_reading => 'add_vertex',
  49         delete_reading => 'delete_vertex',
  50     },
  51         );
  52
  53 =head2 create
  54
  55 Create a new relationship with the given options and return it.
  56 Warn and return undef if the relationship cannot be created.
  57
  58 =cut
  59
  60 sub create {
  61         my( $self, $options ) = @_;
  62         # Check to see if a relationship exists between the two given readings
  63         my $source = delete $options->{'orig_a'};
  64         my $target = delete $options->{'orig_b'};
  65         my $rel;
  66         if( $self->graph->has_edge( $source, $target ) ) {
  67                 $rel = $self->graph->get_edge_attribute( $source, $target, 'object' );
  68                 if( $rel->type ne $options->type ) {
  69                         warn "Another relationship of type " . $rel->type
  70                                 . "already exists between $source and $target";
  71                         return;
  72                 } else {
  73                         return $rel;
  74                 }
  75         }
  76
  77         # Check to see if a nonlocal relationship is defined for the two readings
  78         $rel = $self->scoped_relationship( $options->{'reading_a'},
  79                 $options->{'reading_b'} );
  80         if( $rel && $rel->type eq $options->{'type'} ) {
  81                 return $rel;
  82         } elsif( $rel ) {
  83                 warn 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'} );
  84                 return;
  85         } else {
  86                 $rel = Text::Tradition::Collation::Relationship->new( $options );
  87                 $self->add_scoped_relationship( $rel ) if $rel->nonlocal;
  88                 return $rel;
  89         }
  90 }
  91
  92 =head2 add_scoped_relationship( $rel )
  93
  94 Keep track of relationships defined between specific readings that are scoped
  95 non-locally.  Key on whichever reading occurs first alphabetically.
  96
  97 =cut
  98
  99 sub add_scoped_relationship {
 100         my( $self, $rel ) = @_;
 101         my $r = $self->scoped_relationship( $rel->reading_a, $rel->reading_b );
 102         if( $r ) {
 103                 warn sprintf( "Scoped relationship of type %s already exists between %s and %s",
 104                         $r->type, $rel->reading_a, $rel->reading_b );
 105                 return;
 106         }
 107         $self->scopedrels->{$rel->reading_a}->{$rel->reading_b} = $rel;
 108 }
 109
 110 =head2 scoped_relationship( $reading_a, $reading_b )
 111
 112 Returns the general (document-level or global) relationship that has been defined
 113 between the two reading strings. Returns undef if there is no general relationship.
 114
 115 =cut
 116
 117 sub scoped_relationship {
 118         my( $self, $rdga, $rdgb ) = @_;
 119         my( $first, $second ) = sort( $rdga, $rdgb );
 120         if( exists $self->scopedrels->{$first}->{$second} ) {
 121                 return $self->scopedrels->{$first}->{$second};
 122         } else {
 123                 return undef;
 124         }
 125 }
 126
 127 =head2 add_relationship( $self, $source, $sourcetext, $target, $targettext, $opts )
 128
 129 Adds the relationship specified in $opts (see Text::Tradition::Collation::Relationship
 130 for the possible options) between the readings given in $source and $target.  Sets
 131 up a scoped relationship between $sourcetext and $targettext if the relationship is
 132 scoped non-locally.
 133
 134 Returns a status boolean and a list of all reading pairs connected by the call to
 135 add_relationship.
 136
 137 =cut
 138
 139 sub add_relationship {
 140         my( $self, $source, $source_rdg, $target, $target_rdg, $options ) = @_;
 141
 142         # Check the options
 143         $options->{'scope'} = 'local' unless $options->{'scope'};
 144
 145         my( $is_valid, $reason ) =
 146                 $self->relationship_valid( $source, $target, $options->{'type'} );
 147     unless( $is_valid ) {
 148         return ( undef, $reason );
 149     }
 150
 151     # Try to create the relationship object.
 152     $options->{'reading_a'} = $source_rdg->text;
 153     $options->{'reading_b'} = $target_rdg->text;
 154     $options->{'orig_a'} = $source;
 155     $options->{'orig_b'} = $target;
 156     my $relationship = $self->create( $options );
 157         return( undef, "Relationship creation failed" ) unless $relationship;
 158
 159         # Find all the pairs for which we need to set the relationship.
 160         my @vectors = ( [ $source, $target ] );
 161     if( $relationship->colocated && $relationship->nonlocal ) {
 162         my $c = $self->collation;
 163         # Set the same relationship everywhere we can, throughout the graph.
 164         my @identical_readings = grep { $_->text eq $relationship->reading_a }
 165                 $c->readings;
 166         foreach my $ir ( @identical_readings ) {
 167                 next if $ir->id eq $source;
 168                 # Check to see if there is a target reading with the same text at
 169                 # the same rank.
 170                 my @itarget = grep
 171                         { $_->rank == $ir->rank && $_->text eq $relationship->reading_b }
 172                         $c->readings;
 173                 if( @itarget ) {
 174                         # We found a hit.
 175                         warn "More than one reading with text " . $target_rdg->text
 176                                 . " at rank " . $ir->rank . "!" if @itarget > 1;
 177                         push( @vectors, [ $ir->id, $itarget[0]->id ] );
 178                 }
 179         }
 180     }
 181
 182     # Now set the relationship(s).
 183     my @pairs_set;
 184     foreach my $v ( @vectors ) {
 185         if( $self->graph->has_edge( @$v ) ) {
 186                 # Is it locally scoped?
 187                 my $rel = $self->graph->get_edge_attribute( @$v, 'object' );
 188                 if( $rel->nonlocal ) {
 189                         # TODO I think we should not be able to get here.
 190                         warn "Found conflicting relationship at @$v";
 191                 } else {
 192                         warn "Not overriding local relationship set at @$v";
 193                         next;
 194                 }
 195         }
 196         $self->graph->add_edge( @$v );
 197         $self->graph->set_edge_attribute( @$v, 'object', $relationship );
 198         push( @pairs_set, $v );
 199     }
 200
 201     return( 1, @pairs_set );
 202 }
 203
 204 =head2 relationship_valid( $source, $target, $type )
 205
 206 Checks whether a relationship of type $type may exist between the readings given
 207 in $source and $target.  Returns a tuple of ( status, message ) where status is
 208 a yes/no boolean and, if the answer is no, message gives the reason why.
 209
 210 =cut
 211
 212 sub relationship_valid {
 213     my( $self, $source, $target, $rel ) = @_;
 214     my $c = $self->collation;
 215     if ( $rel eq 'transposition' || $rel eq 'repetition' ) {
 216                 # Check that the two readings do (for a repetition) or do not (for
 217                 # a transposition) appear in the same witness.
 218                 my %seen_wits;
 219                 map { $seen_wits{$_} = 1 } $c->reading_witnesses( $source );
 220                 foreach my $w ( $c->reading_witnesses( $target ) ) {
 221                         if( $seen_wits{$w} ) {
 222                                 return ( 0, "Readings both occur in witness $w" )
 223                                         if $rel eq 'transposition';
 224                                 return ( 1, "ok" ) if $rel eq 'repetition';
 225                 }
 226                 return $rel eq 'transposition' ? ( 1, "ok" )
 227                         : ( 0, "Readings occur only in distinct witnesses" );
 228                 }
 229         } else {
 230                 # Check that linking the source and target in a relationship won't lead
 231                 # to a path loop for any witness.  First make a lookup table of all the
 232                 # readings related to either the source or the target.
 233                 my @proposed_related = ( $source, $target );
 234                 push( @proposed_related, $self->related_readings( $source, 'colocated' ) );
 235                 push( @proposed_related, $self->related_readings( $target, 'colocated' ) );
 236                 my %pr_ids;
 237                 map { $pr_ids{ $_ } = 1 } @proposed_related;
 238
 239                 # None of these proposed related readings should have a neighbor that
 240                 # is also in proposed_related.
 241                 foreach my $pr ( keys %pr_ids ) {
 242                         foreach my $neighbor( $c->sequence->neighbors( $pr ) ) {
 243                                 return( 0, "Would relate neighboring readings $pr and $neighbor" )
 244                                         if exists $pr_ids{$neighbor};
 245                         }
 246                 }
 247                 return ( 1, "ok" );
 248         }
 249 }
 250
 251 =head2 related_readings( $reading, $colocated_only )
 252
 253 Returns a list of readings that are connected via relationship links to $reading.
 254 If $colocated_only is true, restricts the list to those readings that are in the
 255 same logical location (and therefore have the same rank in the collation graph.)
 256
 257 =cut
 258
 259 sub related_readings {
 260         my( $self, $reading, $colocated ) = @_;
 261         my $return_object;
 262         if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
 263                 $reading = $reading->id;
 264                 $return_object = 1;
 265         }
 266         my @answer;
 267         if( $colocated ) {
 268                 my %found = ( $reading => 1 );
 269                 my $check = [ $reading ];
 270                 my $iter = 0;
 271                 while( @$check ) {
 272                         $DB::single = 1 if $iter++ > 100;
 273                         my $more = [];
 274                         foreach my $r ( @$check ) {
 275                                 foreach my $nr ( $self->graph->neighbors( $r ) ) {
 276                                         if( $self->graph->get_edge_attribute( $r, $nr, 'object' )->colocated ) {
 277                                                 push( @$more, $nr ) unless exists $found{$nr};
 278                                                 $found{$nr} = 1;
 279                                         }
 280                                 }
 281                         }
 282                         $check = $more;
 283                 }
 284                 @answer = keys %found;
 285         } else {
 286                 @answer = $self->graph->all_reachable( $reading );
 287         }
 288         if( $return_object ) {
 289                 my $c = $self->collation;
 290                 return map { $c->reading( $_ ) } @answer;
 291         } else {
 292                 return @answer;
 293         }
 294 }
 295
 296 =head2 merge_readings( $kept, $deleted );
 297
 298 Makes a best-effort merge of the relationship links between the given readings, and
 299 stops tracking the to-be-deleted reading.
 300
 301 =cut
 302
 303 sub merge_readings {
 304         my( $self, $kept, $deleted, $combined ) = @_;
 305         foreach my $edge ( $self->graph->edges_at( $deleted ) ) {
 306                 # Get the pair of kept / rel
 307                 my @vector = ( $kept );
 308                 push( @vector, $edge->[0] eq $deleted ? $edge->[1] : $edge->[0] );
 309                 next if $vector[0] eq $vector[1]; # Don't add a self loop
 310
 311                 # If kept changes its text, drop the relationship.
 312                 next if $combined;
 313
 314                 # If kept / rel already has a relationship, warn and keep the old
 315                 if( $self->graph->has_edge( @vector ) ) {
 316                         warn sprintf( "Readings %s and %s have existing relationship; dropping link with %s", @vector, $deleted );
 317                         next;
 318                 }
 319
 320                 # Otherwise, adopt the relationship that would be deleted.
 321                 my $rel = $self->graph->get_edge_attribute( @$edge, 'object' );
 322                 $self->graph->add_edge( @vector );
 323                 $self->graph->set_edge_attribute( @vector, 'object', $rel );
 324         }
 325         $self->delete_reading( $deleted );
 326 }
 327
 328 sub as_graphml {
 329         my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_;
 330
 331     my $rgraph = $xmlroot->addNewChild( $graphml_ns, 'graph' );
 332         $rgraph->setAttribute( 'edgedefault', 'directed' );
 333     $rgraph->setAttribute( 'id', 'relationships', );
 334     $rgraph->setAttribute( 'parse.edgeids', 'canonical' );
 335     $rgraph->setAttribute( 'parse.edges', scalar($self->graph->edges) );
 336     $rgraph->setAttribute( 'parse.nodeids', 'canonical' );
 337     $rgraph->setAttribute( 'parse.nodes', scalar($self->graph->vertices) );
 338     $rgraph->setAttribute( 'parse.order', 'nodesfirst' );
 339
 340     # Add the vertices according to their XML IDs
 341     my %rdg_lookup = ( reverse %$node_hash );
 342     foreach my $n ( sort _by_xmlid keys( %rdg_lookup ) ) {
 343         my $n_el = $rgraph->addNewChild( $graphml_ns, 'node' );
 344         $n_el->setAttribute( 'id', $n );
 345         _add_graphml_data( $n_el, $nodeid_key, $rdg_lookup{$n} );
 346     }
 347
 348     # Add the relationship edges, with their object information
 349     my $edge_ctr = 0;
 350     foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->graph->edges ) {
 351         # Add an edge and fill in its relationship info.
 352                 my $edge_el = $rgraph->addNewChild( $graphml_ns, 'edge' );
 353                 $edge_el->setAttribute( 'source', $node_hash->{$e->[0]} );
 354                 $edge_el->setAttribute( 'target', $node_hash->{$e->[1]} );
 355                 $edge_el->setAttribute( 'id', 'e'.$edge_ctr++ );
 356
 357                 my $rel_obj = $self->graph->get_edge_attribute( @$e, 'object' );
 358                 _add_graphml_data( $edge_el, $edge_keys->{'relationship'}, $rel_obj->type );
 359                 _add_graphml_data( $edge_el, $edge_keys->{'scope'}, $rel_obj->scope );
 360                 _add_graphml_data( $edge_el, $edge_keys->{'non_correctable'},
 361                         $rel_obj->non_correctable ) if $rel_obj->noncorr_set;
 362                 _add_graphml_data( $edge_el, $edge_keys->{'non_independent'},
 363                         $rel_obj->non_independent ) if $rel_obj->nonind_set;
 364         }
 365 }
 366
 367 sub _by_xmlid {
 368         my $tmp_a = $a;
 369         my $tmp_b = $b;
 370         $tmp_a =~ s/\D//g;
 371         $tmp_b =~ s/\D//g;
 372         return $tmp_a <=> $tmp_b;
 373 }
 374
 375 sub _add_graphml_data {
 376     my( $el, $key, $value ) = @_;
 377     return unless defined $value;
 378     my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
 379     $data_el->setAttribute( 'key', $key );
 380     $data_el->appendText( $value );
 381 }
 382
 383 no Moose;
 384 __PACKAGE__->meta->make_immutable;
 385
 386 1;