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