| Commit | Line | Data |
|---|
| 22222af9 |
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; |
projects / scpubgit/stemmatology.git / blame