1 package Text::Tradition::Collation::RelationshipStore;
5 use Text::Tradition::Collation::Relationship;
11 Text::Tradition::Collation::Reading - represents a reading (usually a word) in a collation.
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.
22 =head2 new( collation => $collation );
24 Creates a new relationship store for the given collation.
30 isa => 'Text::Tradition::Collation',
37 isa => 'HashRef[HashRef[Text::Tradition::Collation::Relationship]]',
38 default => sub { {} },
44 default => sub { Graph->new( undirected => 1 ) },
46 relationships => 'edges',
47 add_reading => 'add_vertex',
48 delete_reading => 'delete_vertex',
54 Create a new relationship with the given options and return it.
55 Warn and return undef if the relationship cannot be created.
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'};
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";
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'} ) {
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'} );
85 $rel = Text::Tradition::Collation::Relationship->new( $options );
86 $self->add_scoped_relationship( $rel ) if $rel->nonlocal;
91 =head2 add_scoped_relationship( $rel )
93 Keep track of relationships defined between specific readings that are scoped
94 non-locally. Key on whichever reading occurs first alphabetically.
98 sub add_scoped_relationship {
99 my( $self, $rel ) = @_;
100 my $r = $self->scoped_relationship( $rel->reading_a, $rel->reading_b );
102 warn sprintf( "Scoped relationship of type %s already exists between %s and %s",
103 $r->type, $rel->reading_a, $rel->reading_b );
106 $self->scopedrels->{$rel->reading_a}->{$rel->reading_b} = $rel;
109 =head2 scoped_relationship( $reading_a, $reading_b )
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.
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};
126 =head2 add_relationship( $self, $source, $sourcetext, $target, $targettext, $opts )
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
133 Returns a status boolean and a list of all reading pairs connected by the call to
138 sub add_relationship {
139 my( $self, $source, $source_rdg, $target, $target_rdg, $options ) = @_;
142 $options->{'scope'} = 'local' unless $options->{'scope'};
144 my( $is_valid, $reason ) =
145 $self->relationship_valid( $source, $target, $options->{'type'} );
146 unless( $is_valid ) {
147 return ( undef, $reason );
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;
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 }
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
170 { $_->rank == $ir->rank && $_->text eq $relationship->reading_b }
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 ] );
181 # Now set the relationship(s).
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 );
187 if( $rel->nonlocal ) {
188 # TODO I think we should not be able to get here.
189 warn "Found conflicting relationship at @$v";
191 warn "Not overriding local relationship set at @$v";
195 $self->graph->add_edge( @$v );
196 $self->graph->set_edge_attribute( @$v, 'object', $relationship );
197 push( @pairs_set, $v );
200 return( 1, @pairs_set );
203 =head2 relationship_valid( $source, $target, $type )
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.
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.
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';
225 return $rel eq 'transposition' ? ( 1, "ok" )
226 : ( 0, "Readings occur only in distinct witnesses" );
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' ) );
236 map { $pr_ids{ $_ } = 1 } @proposed_related;
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};
250 =head2 related_readings( $reading, $colocated_only )
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.)
258 sub related_readings {
259 my( $self, $reading, $colocated ) = @_;
261 if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
262 $reading = $reading->id;
265 my @related = $self->graph->all_reachable( $reading );
268 foreach my $r ( @related ) {
269 my $obj = $self->graph->get_edge_attribute( $reading, $r, 'object' );
270 push( @colo, $r ) if $obj->colocated;
274 if( $return_object ) {
275 my $c = $self->collation;
276 return map { $c->reading( $_ ) } @related;
282 =head2 merge_readings( $kept, $deleted );
284 Makes a best-effort merge of the relationship links between the given readings, and
285 stops tracking the to-be-deleted reading.
290 my( $self, $kept, $deleted, $combined ) = @_;
291 foreach my $edge ( $self->graph->edges_at( $deleted ) ) {
292 # Get the pair of kept / rel
293 my @vector = ( $kept );
294 push( @vector, $edge->[0] eq $deleted ? $edge->[1] : $edge->[0] );
295 next if $vector[0] eq $vector[1]; # Don't add a self loop
297 # If kept changes its text, drop the relationship.
300 # If kept / rel already has a relationship, warn and keep the old
301 if( $self->graph->has_edge( @vector ) ) {
302 warn sprintf( "Readings %s and %s have existing relationship; dropping link with %s", @vector, $deleted );
306 # Otherwise, adopt the relationship that would be deleted.
307 my $rel = $self->graph->get_edge_attribute( @$edge, 'object' );
308 $self->graph->add_edge( @vector );
309 $self->graph->set_edge_attribute( @vector, 'object', $rel );
311 $self->delete_reading( $deleted );
314 sub as_graphml { ## TODO
319 __PACKAGE__->meta->make_immutable;