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; |