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                 # Check to see if there is a target reading with the same text at
 167                 # the same rank.
 168                 my @itarget = grep
 169                         { $_->rank == $ir->rank && $_->text eq $relationship->reading_b }
 170                         $c->readings;
 171                 if( @itarget ) {
 172                         # We found a hit.
 173                         warn "More than one reading with text " . $target_rdg->text
 174                                 . " at rank " . $ir->rank . "!" if @itarget > 1;
 175                         push( @vectors, [ $ir, $itarget[0] ] );
 176                 }
 177         }
 178     }
 179
 180     # Now set the relationship(s).
 181     my @pairs_set;
 182     foreach my $v ( @vectors ) {
 183         if( $self->graph->has_edge( @$v ) ) {
 184                 # Is it locally scoped?
 185                 my $rel = $self->graph->get_edge_attribute( @$v );
 186                 if( $rel->nonlocal ) {
 187                         # TODO I think we should not be able to get here.
 188                         warn "Found conflicting relationship at @$v";
 189                 } else {
 190                         warn "Not overriding local relationship set at @$v";
 191                         next;
 192                 }
 193         }
 194         $self->graph->add_edge( @$v );
 195         $self->graph->set_edge_attribute( @$v, 'object', $relationship );
 196         push( @pairs_set, $v );
 197     }
 198
 199     return( 1, @pairs_set );
 200 }
 201
 202 =head2 relationship_valid( $source, $target, $type )
 203
 204 Checks whether a relationship of type $type may exist between the readings given
 205 in $source and $target.  Returns a tuple of ( status, message ) where status is
 206 a yes/no boolean and, if the answer is no, message gives the reason why.
 207
 208 =cut
 209
 210 sub relationship_valid {
 211     my( $self, $source, $target, $rel ) = @_;
 212     my $c = $self->collation;
 213     if ( $rel eq 'transposition' || $rel eq 'repetition' ) {
 214                 # Check that the two readings do (for a repetition) or do not (for
 215                 # a transposition) appear in the same witness.
 216                 my %seen_wits;
 217                 map { $seen_wits{$_} = 1 } $c->reading_witnesses( $source );
 218                 foreach my $w ( $c->reading_witnesses( $target ) ) {
 219                         if( $seen_wits{$w} ) {
 220                                 return ( 0, "Readings both occur in witness $w" )
 221                                         if $rel eq 'transposition';
 222                                 return ( 1, "ok" ) if $rel eq 'repetition';
 223                 }
 224                 return $rel eq 'transposition' ? ( 1, "ok" )
 225                         : ( 0, "Readings occur only in distinct witnesses" );
 226                 }
 227         } else {
 228                 # Check that linking the source and target in a relationship won't lead
 229                 # to a path loop for any witness.  First make a lookup table of all the
 230                 # readings related to either the source or the target.
 231                 my @proposed_related = ( $source, $target );
 232                 push( @proposed_related, $self->related_readings( $source, 'colocated' ) );
 233                 push( @proposed_related, $self->related_readings( $target, 'colocated' ) );
 234                 my %pr_ids;
 235                 map { $pr_ids{ $_ } = 1 } @proposed_related;
 236
 237                 # None of these proposed related readings should have a neighbor that
 238                 # is also in proposed_related.
 239                 foreach my $pr ( keys %pr_ids ) {
 240                         foreach my $neighbor( $c->sequence->neighbors( $pr ) ) {
 241                                 return( 0, "Would relate neighboring readings $pr and $neighbor" )
 242                                         if exists $pr_ids{$neighbor};
 243                         }
 244                 }
 245                 return ( 1, "ok" );
 246         }
 247 }
 248
 249 =head2 related_readings( $reading, $colocated_only )
 250
 251 Returns a list of readings that are connected via relationship links to $reading.
 252 If $colocated_only is true, restricts the list to those readings that are in the
 253 same logical location (and therefore have the same rank in the collation graph.)
 254
 255 =cut
 256
 257 sub related_readings {
 258         my( $self, $reading, $colocated ) = @_;
 259         my $return_object;
 260         if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
 261                 $reading = $reading->id;
 262                 $return_object = 1;
 263         }
 264         my @related = $self->graph->all_reachable( $reading );
 265         if( $colocated ) {
 266                 my @colo;
 267                 foreach my $r ( @related ) {
 268                         my $obj = $self->graph->get_edge_attribute( $reading, $r, 'object' );
 269                         push( @colo, $r ) if $obj->colocated;
 270                 }
 271                 @related = @colo;
 272         }
 273         if( $return_object ) {
 274                 my $c = $self->collation;
 275                 return map { $c->reading( $_ ) } @related;
 276         } else {
 277                 return @related;
 278         }
 279 }
 280
 281 =head2 merge_readings( $kept, $deleted );
 282
 283 Makes a best-effort merge of the relationship links between the given readings, and
 284 stops tracking the to-be-deleted reading.
 285
 286 =cut
 287
 288 sub merge_readings {
 289         my( $self, $kept, $deleted, $combined ) = @_;
 290         foreach my $edge ( $self->graph->edges_at( $deleted ) ) {
 291                 # Get the pair of kept / rel
 292                 my @vector = ( $kept );
 293                 push( @vector, $edge->[0] eq $deleted ? $edge->[1] : $edge->[0] );
 294                 next if $vector[0] eq $vector[1]; # Don't add a self loop
 295
 296                 # If kept changes its text, drop the relationship.
 297                 next if $combined;
 298
 299                 # If kept / rel already has a relationship, warn and keep the old
 300                 if( $self->graph->has_edge( @vector ) ) {
 301                         warn sprintf( "Readings %s and %s have existing relationship; dropping link with %s", @vector, $deleted );
 302                         next;
 303                 }
 304
 305                 # Otherwise, adopt the relationship that would be deleted.
 306                 my $rel = $self->graph->get_edge_attribute( @$edge, 'object' );
 307                 $self->graph->add_edge( @vector );
 308                 $self->graph->set_edge_attribute( @vector, 'object', $rel );
 309         }
 310         $self->delete_reading( $deleted );
 311 }
 312
 313 no Moose;
 314 __PACKAGE__->meta->make_immutable;
 315
 316 1;