1 package Text::Tradition::Collation::RelationshipStore;
5 use Text::Tradition::Error;
6 use Text::Tradition::Collation::Relationship;
13 Text::Tradition::Collation::RelationshipStore - Keeps track of the relationships
14 between readings in a given collation
18 Text::Tradition is a library for representation and analysis of collated
19 texts, particularly medieval ones. The RelationshipStore is an internal object
20 of the collation, to keep track of the defined relationships (both specific and
21 general) between readings.
27 use_ok( 'Text::Tradition::Collation::RelationshipStore' );
33 =head2 new( collation => $collation );
35 Creates a new relationship store for the given collation.
41 isa => 'Text::Tradition::Collation',
48 isa => 'HashRef[HashRef[Text::Tradition::Collation::Relationship]]',
49 default => sub { {} },
55 default => sub { Graph->new( undirected => 1 ) },
57 relationships => 'edges',
58 add_reading => 'add_vertex',
59 delete_reading => 'delete_vertex',
63 =head2 get_relationship
65 Return the relationship object, if any, that exists between two readings.
69 sub get_relationship {
70 my( $self, @vector ) = @_;
72 if( $self->graph->has_edge_attribute( @vector, 'object' ) ) {
73 $relationship = $self->graph->get_edge_attribute( @vector, 'object' );
78 sub _set_relationship {
79 my( $self, $relationship, @vector ) = @_;
80 $self->graph->add_edge( @vector );
81 $self->graph->set_edge_attribute( @vector, 'object', $relationship );
84 sub _remove_relationship {
85 my( $self, @vector ) = @_;
86 $self->graph->delete_edge( @vector );
91 Create a new relationship with the given options and return it.
92 Warn and return undef if the relationship cannot be created.
97 my( $self, $options ) = @_;
98 # Check to see if a relationship exists between the two given readings
99 my $source = delete $options->{'orig_a'};
100 my $target = delete $options->{'orig_b'};
101 my $rel = $self->get_relationship( $source, $target );
103 if( $rel->type ne $options->{'type'} ) {
104 throw( "Another relationship of type " . $rel->type
105 . " already exists between $source and $target" );
111 # Check to see if a nonlocal relationship is defined for the two readings
112 $rel = $self->scoped_relationship( $options->{'reading_a'},
113 $options->{'reading_b'} );
114 if( $rel && $rel->type eq $options->{'type'} ) {
117 throw( 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'} ) );
119 $rel = Text::Tradition::Collation::Relationship->new( $options );
120 $self->add_scoped_relationship( $rel ) if $rel->nonlocal;
125 =head2 add_scoped_relationship( $rel )
127 Keep track of relationships defined between specific readings that are scoped
128 non-locally. Key on whichever reading occurs first alphabetically.
132 sub add_scoped_relationship {
133 my( $self, $rel ) = @_;
134 my $r = $self->scoped_relationship( $rel->reading_a, $rel->reading_b );
136 warn sprintf( "Scoped relationship of type %s already exists between %s and %s",
137 $r->type, $rel->reading_a, $rel->reading_b );
140 $self->scopedrels->{$rel->reading_a}->{$rel->reading_b} = $rel;
143 =head2 scoped_relationship( $reading_a, $reading_b )
145 Returns the general (document-level or global) relationship that has been defined
146 between the two reading strings. Returns undef if there is no general relationship.
150 sub scoped_relationship {
151 my( $self, $rdga, $rdgb ) = @_;
152 my( $first, $second ) = sort( $rdga, $rdgb );
153 if( exists $self->scopedrels->{$first}->{$second} ) {
154 return $self->scopedrels->{$first}->{$second};
160 =head2 add_relationship( $self, $source, $sourcetext, $target, $targettext, $opts )
162 Adds the relationship specified in $opts (see Text::Tradition::Collation::Relationship
163 for the possible options) between the readings given in $source and $target. Sets
164 up a scoped relationship between $sourcetext and $targettext if the relationship is
167 Returns a status boolean and a list of all reading pairs connected by the call to
172 sub add_relationship {
173 my( $self, $source, $source_rdg, $target, $target_rdg, $options ) = @_;
176 $options->{'scope'} = 'local' unless $options->{'scope'};
178 my( $is_valid, $reason ) =
179 $self->relationship_valid( $source, $target, $options->{'type'} );
180 unless( $is_valid ) {
181 throw( "Invalid relationship: $reason" );
184 # Try to create the relationship object.
185 $options->{'reading_a'} = $source_rdg->text;
186 $options->{'reading_b'} = $target_rdg->text;
187 $options->{'orig_a'} = $source;
188 $options->{'orig_b'} = $target;
189 my $relationship = $self->create( $options ); # Will throw on error
191 # Find all the pairs for which we need to set the relationship.
192 my @vectors = ( [ $source, $target ] );
193 if( $relationship->colocated && $relationship->nonlocal ) {
194 my $c = $self->collation;
195 # Set the same relationship everywhere we can, throughout the graph.
196 my @identical_readings = grep { $_->text eq $relationship->reading_a }
198 foreach my $ir ( @identical_readings ) {
199 next if $ir->id eq $source;
200 # Check to see if there is a target reading with the same text at
203 { $_->rank == $ir->rank && $_->text eq $relationship->reading_b }
207 warn "More than one reading with text " . $target_rdg->text
208 . " at rank " . $ir->rank . "!" if @itarget > 1;
209 push( @vectors, [ $ir->id, $itarget[0]->id ] );
214 # Now set the relationship(s).
216 foreach my $v ( @vectors ) {
217 my $rel = $self->get_relationship( @$v );
219 if( $rel->nonlocal ) {
220 throw( "Found conflicting relationship at @$v" );
222 warn "Not overriding local relationship set at @$v";
226 $self->_set_relationship( $relationship, @$v );
227 push( @pairs_set, $v );
233 =head2 relationship_valid( $source, $target, $type )
235 Checks whether a relationship of type $type may exist between the readings given
236 in $source and $target. Returns a tuple of ( status, message ) where status is
237 a yes/no boolean and, if the answer is no, message gives the reason why.
241 sub relationship_valid {
242 my( $self, $source, $target, $rel ) = @_;
243 my $c = $self->collation;
244 if ( $rel eq 'transposition' || $rel eq 'repetition' ) {
245 # Check that the two readings do (for a repetition) or do not (for
246 # a transposition) appear in the same witness.
248 map { $seen_wits{$_} = 1 } $c->reading_witnesses( $source );
249 foreach my $w ( $c->reading_witnesses( $target ) ) {
250 if( $seen_wits{$w} ) {
251 return ( 0, "Readings both occur in witness $w" )
252 if $rel eq 'transposition';
253 return ( 1, "ok" ) if $rel eq 'repetition';
255 return $rel eq 'transposition' ? ( 1, "ok" )
256 : ( 0, "Readings occur only in distinct witnesses" );
259 # Check that linking the source and target in a relationship won't lead
260 # to a path loop for any witness. If they have the same rank then fine.
262 if $c->reading( $source )->has_rank
263 && $c->reading( $target )->has_rank
264 && $c->reading( $source )->rank == $c->reading( $target )->rank;
266 # Otherwise, first make a lookup table of all the
267 # readings related to either the source or the target.
268 my @proposed_related = ( $source, $target );
269 push( @proposed_related, $self->related_readings( $source, 'colocated' ) );
270 push( @proposed_related, $self->related_readings( $target, 'colocated' ) );
272 map { $pr_ids{ $_ } = 1 } @proposed_related;
274 # The cumulative predecessors and successors of the proposed-related readings
275 # should not overlap.
278 foreach my $pr ( keys %pr_ids ) {
279 map { $all_pred{$_} = 1 } $c->sequence->all_predecessors( $pr );
280 map { $all_succ{$_} = 1 } $c->sequence->all_successors( $pr );
282 foreach my $k ( keys %all_pred ) {
283 return( 0, "Relationship would create witness loop" )
284 if exists $all_succ{$k};
286 foreach my $k ( keys %pr_ids ) {
287 return( 0, "Relationship would create witness loop" )
288 if exists $all_pred{$k} || exists $all_succ{$k};
294 =head2 related_readings( $reading, $colocated_only )
296 Returns a list of readings that are connected via relationship links to $reading.
297 If $colocated_only is true, restricts the list to those readings that are in the
298 same logical location (and therefore have the same rank in the collation graph.)
302 sub related_readings {
303 my( $self, $reading, $colocated ) = @_;
305 if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
306 $reading = $reading->id;
311 my %found = ( $reading => 1 );
312 my $check = [ $reading ];
316 foreach my $r ( @$check ) {
317 foreach my $nr ( $self->graph->neighbors( $r ) ) {
318 if( $self->get_relationship( $r, $nr )->colocated ) {
319 push( @$more, $nr ) unless exists $found{$nr};
326 @answer = keys %found;
328 @answer = $self->graph->all_reachable( $reading );
330 if( $return_object ) {
331 my $c = $self->collation;
332 return map { $c->reading( $_ ) } @answer;
338 =head2 merge_readings( $kept, $deleted );
340 Makes a best-effort merge of the relationship links between the given readings, and
341 stops tracking the to-be-deleted reading.
346 my( $self, $kept, $deleted, $combined ) = @_;
347 foreach my $edge ( $self->graph->edges_at( $deleted ) ) {
348 # Get the pair of kept / rel
349 my @vector = ( $kept );
350 push( @vector, $edge->[0] eq $deleted ? $edge->[1] : $edge->[0] );
351 next if $vector[0] eq $vector[1]; # Don't add a self loop
353 # If kept changes its text, drop the relationship.
356 # If kept / rel already has a relationship, warn and keep the old
357 my $rel = $self->get_relationship( @vector );
359 warn sprintf( "Readings %s and %s have existing relationship; dropping link with %s", @vector, $deleted );
363 # Otherwise, adopt the relationship that would be deleted.
364 $rel = $self->get_relationship( @$edge );
365 $self->_set_relationship( $rel, @vector );
367 $self->delete_reading( $deleted );
371 my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_;
373 my $rgraph = $xmlroot->addNewChild( $graphml_ns, 'graph' );
374 $rgraph->setAttribute( 'edgedefault', 'directed' );
375 $rgraph->setAttribute( 'id', 'relationships', );
376 $rgraph->setAttribute( 'parse.edgeids', 'canonical' );
377 $rgraph->setAttribute( 'parse.edges', scalar($self->graph->edges) );
378 $rgraph->setAttribute( 'parse.nodeids', 'canonical' );
379 $rgraph->setAttribute( 'parse.nodes', scalar($self->graph->vertices) );
380 $rgraph->setAttribute( 'parse.order', 'nodesfirst' );
382 # Add the vertices according to their XML IDs
383 my %rdg_lookup = ( reverse %$node_hash );
384 foreach my $n ( sort _by_xmlid keys( %rdg_lookup ) ) {
385 my $n_el = $rgraph->addNewChild( $graphml_ns, 'node' );
386 $n_el->setAttribute( 'id', $n );
387 _add_graphml_data( $n_el, $nodeid_key, $rdg_lookup{$n} );
390 # Add the relationship edges, with their object information
392 foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->graph->edges ) {
393 # Add an edge and fill in its relationship info.
394 my $edge_el = $rgraph->addNewChild( $graphml_ns, 'edge' );
395 $edge_el->setAttribute( 'source', $node_hash->{$e->[0]} );
396 $edge_el->setAttribute( 'target', $node_hash->{$e->[1]} );
397 $edge_el->setAttribute( 'id', 'e'.$edge_ctr++ );
399 my $rel_obj = $self->get_relationship( @$e );
400 _add_graphml_data( $edge_el, $edge_keys->{'relationship'}, $rel_obj->type );
401 _add_graphml_data( $edge_el, $edge_keys->{'scope'}, $rel_obj->scope );
402 _add_graphml_data( $edge_el, $edge_keys->{'non_correctable'},
403 $rel_obj->non_correctable ) if $rel_obj->noncorr_set;
404 _add_graphml_data( $edge_el, $edge_keys->{'non_independent'},
405 $rel_obj->non_independent ) if $rel_obj->nonind_set;
414 return $tmp_a <=> $tmp_b;
417 sub _add_graphml_data {
418 my( $el, $key, $value ) = @_;
419 return unless defined $value;
420 my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
421 $data_el->setAttribute( 'key', $key );
422 $data_el->appendText( $value );
426 Text::Tradition::Error->throw(
427 'ident' => 'Relationship error',
433 __PACKAGE__->meta->make_immutable;