[scpubgit/stemmatology.git] / lib / Text / Tradition / Collation / RelationshipStore.pm

package Text::Tradition::Collation::RelationshipStore;

use strict;
use warnings;
use Text::Tradition::Error;
use Text::Tradition::Collation::Relationship;
use TryCatch;

use Moose;

=head1 NAME

Text::Tradition::Collation::RelationshipStore - Keeps track of the relationships
between readings in a given collation
    
=head1 DESCRIPTION

Text::Tradition is a library for representation and analysis of collated
texts, particularly medieval ones.  The RelationshipStore is an internal object
of the collation, to keep track of the defined relationships (both specific and
general) between readings.

=begin testing

use Text::Tradition;

use_ok( 'Text::Tradition::Collation::RelationshipStore' );

=end testing

=head1 METHODS

=head2 new( collation => $collation );

Creates a new relationship store for the given collation.

=cut

has 'collation' => (
	is => 'ro',
	isa => 'Text::Tradition::Collation',
	required => 1,
	weak_ref => 1,
	);

has 'scopedrels' => (
	is => 'ro',
	isa => 'HashRef[HashRef[Text::Tradition::Collation::Relationship]]',
	default => sub { {} },
	);

has 'graph' => (
	is => 'ro',
	isa => 'Graph',
	default => sub { Graph->new( undirected => 1 ) },
    handles => {
    	relationships => 'edges',
    	add_reading => 'add_vertex',
    	delete_reading => 'delete_vertex',
    	delete_relationship => 'delete_edge',
    },
	);
	
around 'delete_relationship' => sub {
	my $orig = shift;
	my $self = shift;
	my @vector;
	if( @_ == 1 && ref( $_[0] ) eq 'ARRAY' ) {
		# Dereference the edge arrayref that was passed.
		my $edge = shift;
		@vector = @$edge;
	} else {
		@vector = @_;
	}
	return $self->$orig( @vector );
};
	
=head2 get_relationship

Return the relationship object, if any, that exists between two readings.

=cut

sub get_relationship {
	my $self = shift;
	my @vector;
	if( @_ == 1 && ref( $_[0] ) eq 'ARRAY' ) {
		# Dereference the edge arrayref that was passed.
		my $edge = shift;
		@vector = @$edge;
	} else {
		@vector = @_;
	}
	my $relationship;
	if( $self->graph->has_edge_attribute( @vector, 'object' ) ) {
		$relationship = $self->graph->get_edge_attribute( @vector, 'object' );
	}
	return $relationship;
}

sub _set_relationship {
	my( $self, $relationship, @vector ) = @_;
	$self->graph->add_edge( @vector );
	$self->graph->set_edge_attribute( @vector, 'object', $relationship );
}

sub _remove_relationship {
	my( $self, @vector ) = @_;
	$self->graph->delete_edge( @vector );
}
	
=head2 create

Create a new relationship with the given options and return it.
Warn and return undef if the relationship cannot be created.

=cut

sub create {
	my( $self, $options ) = @_;
	# Check to see if a relationship exists between the two given readings
	my $source = delete $options->{'orig_a'};
	my $target = delete $options->{'orig_b'};
	my $rel = $self->get_relationship( $source, $target );
	if( $rel ) {
		if( $rel->type ne $options->{'type'} ) {
			throw( "Another relationship of type " . $rel->type 
				. " already exists between $source and $target" );
		} else {
			return $rel;
		}
	}
	
	# Check to see if a nonlocal relationship is defined for the two readings
	$rel = $self->scoped_relationship( $options->{'reading_a'}, 
		$options->{'reading_b'} );
	if( $rel && $rel->type eq $options->{'type'} ) {
		return $rel;
	} elsif( $rel ) {
		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'} ) );
	} else {
		$rel = Text::Tradition::Collation::Relationship->new( $options );
		$self->add_scoped_relationship( $rel ) if $rel->nonlocal;
		return $rel;
	}
}

=head2 add_scoped_relationship( $rel )

Keep track of relationships defined between specific readings that are scoped
non-locally.  Key on whichever reading occurs first alphabetically.

=cut

sub add_scoped_relationship {
	my( $self, $rel ) = @_;
	my $r = $self->scoped_relationship( $rel->reading_a, $rel->reading_b );
	if( $r ) {
		warn sprintf( "Scoped relationship of type %s already exists between %s and %s",
			$r->type, $rel->reading_a, $rel->reading_b );
		return;
	}
	$self->scopedrels->{$rel->reading_a}->{$rel->reading_b} = $rel;
}

=head2 scoped_relationship( $reading_a, $reading_b )

Returns the general (document-level or global) relationship that has been defined 
between the two reading strings. Returns undef if there is no general relationship.

=cut

sub scoped_relationship {
	my( $self, $rdga, $rdgb ) = @_;
	my( $first, $second ) = sort( $rdga, $rdgb );
	if( exists $self->scopedrels->{$first}->{$second} ) {
		return $self->scopedrels->{$first}->{$second};
	} else {
		return undef;
	}
}

=head2 add_relationship( $self, $source, $sourcetext, $target, $targettext, $opts )

Adds the relationship specified in $opts (see Text::Tradition::Collation::Relationship 
for the possible options) between the readings given in $source and $target.  Sets
up a scoped relationship between $sourcetext and $targettext if the relationship is
scoped non-locally.

Returns a status boolean and a list of all reading pairs connected by the call to
add_relationship.

=cut

sub add_relationship {
	my( $self, $source, $source_rdg, $target, $target_rdg, $options ) = @_;

	# Check the options
	$options->{'scope'} = 'local' unless $options->{'scope'};
	
	my( $is_valid, $reason ) = 
		$self->relationship_valid( $source, $target, $options->{'type'} );
    unless( $is_valid ) {
        throw( "Invalid relationship: $reason" );
    }
    
    # Try to create the relationship object.
    $options->{'reading_a'} = $source_rdg->text;
    $options->{'reading_b'} = $target_rdg->text;
    $options->{'orig_a'} = $source;
    $options->{'orig_b'} = $target;
    my $relationship = $self->create( $options );  # Will throw on error

	# Find all the pairs for which we need to set the relationship.
	my @vectors = ( [ $source, $target ] );	
    if( $relationship->colocated && $relationship->nonlocal ) {
    	my $c = $self->collation;
    	# Set the same relationship everywhere we can, throughout the graph.
    	my @identical_readings = grep { $_->text eq $relationship->reading_a }
    		$c->readings;
    	foreach my $ir ( @identical_readings ) {
    		next if $ir->id eq $source;
    		# Check to see if there is a target reading with the same text at
    		# the same rank.
    		my @itarget = grep 
    			{ $_->rank == $ir->rank && $_->text eq $relationship->reading_b }
    			$c->readings;
    		if( @itarget ) {
    			# We found a hit.
    			warn "More than one reading with text " . $target_rdg->text
    				. " at rank " . $ir->rank . "!" if @itarget > 1;
    			push( @vectors, [ $ir->id, $itarget[0]->id ] );
    		}
    	}	
    }
    
    # Now set the relationship(s).
    my @pairs_set;
    foreach my $v ( @vectors ) {
		my $rel = $self->get_relationship( @$v );
    	if( $rel ) {
    		if( $rel->nonlocal ) {
    			throw( "Found conflicting relationship at @$v" );
    		} else {
    			warn "Not overriding local relationship set at @$v";
    		}
    		next;
    	}
    	$self->_set_relationship( $relationship, @$v );
    	push( @pairs_set, $v );
    }
    
    return @pairs_set;
}

=head2 relationship_valid( $source, $target, $type )

Checks whether a relationship of type $type may exist between the readings given
in $source and $target.  Returns a tuple of ( status, message ) where status is
a yes/no boolean and, if the answer is no, message gives the reason why.

=cut

sub relationship_valid {
    my( $self, $source, $target, $rel ) = @_;
    my $c = $self->collation;
    if ( $rel eq 'transposition' || $rel eq 'repetition' ) {
		# Check that the two readings do (for a repetition) or do not (for
		# a transposition) appear in the same witness.
		my %seen_wits;
		map { $seen_wits{$_} = 1 } $c->reading_witnesses( $source );
		foreach my $w ( $c->reading_witnesses( $target ) ) {
			if( $seen_wits{$w} ) {
				return ( 0, "Readings both occur in witness $w" ) 
					if $rel eq 'transposition';
				return ( 1, "ok" ) if $rel eq 'repetition';
		}
		return $rel eq 'transposition' ? ( 1, "ok" )
			: ( 0, "Readings occur only in distinct witnesses" );
		}
	} else {
		# Check that linking the source and target in a relationship won't lead
		# to a path loop for any witness.  If they have the same rank then fine.
		return( 1, "ok" ) 
			if $c->reading( $source )->has_rank
				&& $c->reading( $target )->has_rank
				&& $c->reading( $source )->rank == $c->reading( $target )->rank;
		
		# Otherwise, first make a lookup table of all the
		# readings related to either the source or the target.
		my @proposed_related = ( $source, $target );
		push( @proposed_related, $self->related_readings( $source, 'colocated' ) );
		push( @proposed_related, $self->related_readings( $target, 'colocated' ) );
		my %pr_ids;
		map { $pr_ids{ $_ } = 1 } @proposed_related;
	
		# The cumulative predecessors and successors of the proposed-related readings
		# should not overlap.
		my %all_pred;
		my %all_succ;
		foreach my $pr ( keys %pr_ids ) {
			map { $all_pred{$_} = 1 } $c->sequence->all_predecessors( $pr );
			map { $all_succ{$_} = 1 } $c->sequence->all_successors( $pr );
		}
		foreach my $k ( keys %all_pred ) {
			return( 0, "Relationship would create witness loop" )
				if exists $all_succ{$k};
		}
		foreach my $k ( keys %pr_ids ) {
			return( 0, "Relationship would create witness loop" )
				if exists $all_pred{$k} || exists $all_succ{$k};
		}
		return ( 1, "ok" );
	}
}

=head2 related_readings( $reading, $colocated_only )

Returns a list of readings that are connected via relationship links to $reading.
If $colocated_only is true, restricts the list to those readings that are in the
same logical location (and therefore have the same rank in the collation graph.)

=cut

sub related_readings {
	my( $self, $reading, $colocated ) = @_;
	my $return_object;
	if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
		$reading = $reading->id;
		$return_object = 1;
	}
	my @answer;
	if( $colocated ) {
		my %found = ( $reading => 1 );
		my $check = [ $reading ];
		my $iter = 0;
		while( @$check ) {
			my $more = [];
			foreach my $r ( @$check ) {
				foreach my $nr ( $self->graph->neighbors( $r ) ) {
					if( $self->get_relationship( $r, $nr )->colocated ) {
						push( @$more, $nr ) unless exists $found{$nr};
						$found{$nr} = 1;
					}
				}
			}
			$check = $more;
		}
		@answer = keys %found;
	} else {
		@answer = $self->graph->all_reachable( $reading );
	}
	if( $return_object ) {
		my $c = $self->collation;
		return map { $c->reading( $_ ) } @answer;
	} else {
		return @answer;
	}
}

=head2 merge_readings( $kept, $deleted );

Makes a best-effort merge of the relationship links between the given readings, and
stops tracking the to-be-deleted reading.

=cut

sub merge_readings {
	my( $self, $kept, $deleted, $combined ) = @_;
	foreach my $edge ( $self->graph->edges_at( $deleted ) ) {
		# Get the pair of kept / rel
		my @vector = ( $kept );
		push( @vector, $edge->[0] eq $deleted ? $edge->[1] : $edge->[0] );
		next if $vector[0] eq $vector[1]; # Don't add a self loop
		
		# If kept changes its text, drop the relationship.
		next if $combined;
			
		# If kept / rel already has a relationship, warn and keep the old
		my $rel = $self->get_relationship( @vector );
		if( $rel ) {
			warn sprintf( "Readings %s and %s have existing relationship; dropping link with %s", @vector, $deleted );
			next;
		}
		
		# Otherwise, adopt the relationship that would be deleted.
		$rel = $self->get_relationship( @$edge );
		$self->_set_relationship( $rel, @vector );
	}
	$self->delete_reading( $deleted );
}

sub _as_graphml { 
	my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_;
	
    my $rgraph = $xmlroot->addNewChild( $graphml_ns, 'graph' );
	$rgraph->setAttribute( 'edgedefault', 'directed' );
    $rgraph->setAttribute( 'id', 'relationships', );
    $rgraph->setAttribute( 'parse.edgeids', 'canonical' );
    $rgraph->setAttribute( 'parse.edges', scalar($self->graph->edges) );
    $rgraph->setAttribute( 'parse.nodeids', 'canonical' );
    $rgraph->setAttribute( 'parse.nodes', scalar($self->graph->vertices) );
    $rgraph->setAttribute( 'parse.order', 'nodesfirst' );
    
    # Add the vertices according to their XML IDs
    my %rdg_lookup = ( reverse %$node_hash );
    foreach my $n ( sort _by_xmlid keys( %rdg_lookup ) ) {
    	my $n_el = $rgraph->addNewChild( $graphml_ns, 'node' );
    	$n_el->setAttribute( 'id', $n );
    	_add_graphml_data( $n_el, $nodeid_key, $rdg_lookup{$n} );
    }
    
    # Add the relationship edges, with their object information
    my $edge_ctr = 0;
    foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->graph->edges ) {
    	# Add an edge and fill in its relationship info.
		my $edge_el = $rgraph->addNewChild( $graphml_ns, 'edge' );
		$edge_el->setAttribute( 'source', $node_hash->{$e->[0]} );
		$edge_el->setAttribute( 'target', $node_hash->{$e->[1]} );
		$edge_el->setAttribute( 'id', 'e'.$edge_ctr++ );

		my $rel_obj = $self->get_relationship( @$e );
		_add_graphml_data( $edge_el, $edge_keys->{'relationship'}, $rel_obj->type );
		_add_graphml_data( $edge_el, $edge_keys->{'scope'}, $rel_obj->scope );
		_add_graphml_data( $edge_el, $edge_keys->{'non_correctable'}, 
			$rel_obj->non_correctable ) if $rel_obj->noncorr_set;
		_add_graphml_data( $edge_el, $edge_keys->{'non_independent'}, 
			$rel_obj->non_independent ) if $rel_obj->nonind_set;
	}
}

sub _by_xmlid {
	my $tmp_a = $a;
	my $tmp_b = $b;
	$tmp_a =~ s/\D//g;
	$tmp_b =~ s/\D//g;
	return $tmp_a <=> $tmp_b;
}

sub _add_graphml_data {
    my( $el, $key, $value ) = @_;
    return unless defined $value;
    my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
    $data_el->setAttribute( 'key', $key );
    $data_el->appendText( $value );
}

sub throw {
	Text::Tradition::Error->throw( 
		'ident' => 'Relationship error',
		'message' => $_[0],
		);
}

no Moose;
__PACKAGE__->meta->make_immutable;

1;
Commit	Line	Data
22222af9	1	package Text::Tradition::Collation::RelationshipStore;
	2
	3	use strict;
	4	use warnings;
63778331	5	use Text::Tradition::Error;
22222af9	6	use Text::Tradition::Collation::Relationship;
a1615ee4	7	use TryCatch;
22222af9	8
	9	use Moose;
	10
	11	=head1 NAME
	12
2626f709	13	Text::Tradition::Collation::RelationshipStore - Keeps track of the relationships
2626f709	14	between readings in a given collation
22222af9	15
	16	=head1 DESCRIPTION
	17
	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.
	22
3ae5e2ad	23	=begin testing
	24
	25	use Text::Tradition;
	26
	27	use_ok( 'Text::Tradition::Collation::RelationshipStore' );
	28
	29	=end testing
	30
22222af9	31	=head1 METHODS
	32
	33	=head2 new( collation => $collation );
	34
	35	Creates a new relationship store for the given collation.
	36
	37	=cut
	38
	39	has 'collation' => (
	40	is => 'ro',
	41	isa => 'Text::Tradition::Collation',
	42	required => 1,
	43	weak_ref => 1,
	44	);
	45
	46	has 'scopedrels' => (
	47	is => 'ro',
	48	isa => 'HashRef[HashRef[Text::Tradition::Collation::Relationship]]',
	49	default => sub { {} },
	50	);
	51
	52	has 'graph' => (
	53	is => 'ro',
	54	isa => 'Graph',
	55	default => sub { Graph->new( undirected => 1 ) },
	56	handles => {
	57	relationships => 'edges',
	58	add_reading => 'add_vertex',
	59	delete_reading => 'delete_vertex',
4633f9e4	60	delete_relationship => 'delete_edge',
22222af9	61	},
	62	);
	63
4633f9e4	64	around 'delete_relationship' => sub {
	65	my $orig = shift;
	66	my $self = shift;
	67	my @vector;
	68	if( @_ == 1 && ref( $_[0] ) eq 'ARRAY' ) {
	69	# Dereference the edge arrayref that was passed.
	70	my $edge = shift;
	71	@vector = @$edge;
	72	} else {
	73	@vector = @_;
	74	}
	75	return $self->$orig( @vector );
	76	};
	77
3ae5e2ad	78	=head2 get_relationship
	79
	80	Return the relationship object, if any, that exists between two readings.
	81
	82	=cut
	83
	84	sub get_relationship {
4633f9e4	85	my $self = shift;
	86	my @vector;
	87	if( @_ == 1 && ref( $_[0] ) eq 'ARRAY' ) {
	88	# Dereference the edge arrayref that was passed.
	89	my $edge = shift;
	90	@vector = @$edge;
	91	} else {
	92	@vector = @_;
	93	}
3ae5e2ad	94	my $relationship;
	95	if( $self->graph->has_edge_attribute( @vector, 'object' ) ) {
	96	$relationship = $self->graph->get_edge_attribute( @vector, 'object' );
	97	}
	98	return $relationship;
	99	}
	100
	101	sub _set_relationship {
	102	my( $self, $relationship, @vector ) = @_;
	103	$self->graph->add_edge( @vector );
	104	$self->graph->set_edge_attribute( @vector, 'object', $relationship );
	105	}
a1615ee4	106
	107	sub _remove_relationship {
	108	my( $self, @vector ) = @_;
	109	$self->graph->delete_edge( @vector );
	110	}
3ae5e2ad	111
22222af9	112	=head2 create
	113
	114	Create a new relationship with the given options and return it.
	115	Warn and return undef if the relationship cannot be created.
	116
	117	=cut
	118
	119	sub create {
	120	my( $self, $options ) = @_;
	121	# Check to see if a relationship exists between the two given readings
	122	my $source = delete $options->{'orig_a'};
	123	my $target = delete $options->{'orig_b'};
3ae5e2ad	124	my $rel = $self->get_relationship( $source, $target );
3ae5e2ad	125	if( $rel ) {
a7037072	126	if( $rel->type ne $options->{'type'} ) {
63778331	127	throw( "Another relationship of type " . $rel->type
63778331	128	. " already exists between $source and $target" );
22222af9	129	} else {
	130	return $rel;
	131	}
	132	}
	133
	134	# Check to see if a nonlocal relationship is defined for the two readings
	135	$rel = $self->scoped_relationship( $options->{'reading_a'},
	136	$options->{'reading_b'} );
	137	if( $rel && $rel->type eq $options->{'type'} ) {
	138	return $rel;
	139	} elsif( $rel ) {
63778331	140	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'} ) );
22222af9	141	} else {
	142	$rel = Text::Tradition::Collation::Relationship->new( $options );
	143	$self->add_scoped_relationship( $rel ) if $rel->nonlocal;
	144	return $rel;
	145	}
	146	}
	147
	148	=head2 add_scoped_relationship( $rel )
	149
	150	Keep track of relationships defined between specific readings that are scoped
	151	non-locally. Key on whichever reading occurs first alphabetically.
	152
	153	=cut
	154
	155	sub add_scoped_relationship {
	156	my( $self, $rel ) = @_;
	157	my $r = $self->scoped_relationship( $rel->reading_a, $rel->reading_b );
	158	if( $r ) {
	159	warn sprintf( "Scoped relationship of type %s already exists between %s and %s",
	160	$r->type, $rel->reading_a, $rel->reading_b );
	161	return;
	162	}
	163	$self->scopedrels->{$rel->reading_a}->{$rel->reading_b} = $rel;
	164	}
	165
	166	=head2 scoped_relationship( $reading_a, $reading_b )
	167
	168	Returns the general (document-level or global) relationship that has been defined
	169	between the two reading strings. Returns undef if there is no general relationship.
	170
	171	=cut
	172
	173	sub scoped_relationship {
	174	my( $self, $rdga, $rdgb ) = @_;
	175	my( $first, $second ) = sort( $rdga, $rdgb );
	176	if( exists $self->scopedrels->{$first}->{$second} ) {
	177	return $self->scopedrels->{$first}->{$second};
	178	} else {
	179	return undef;
	180	}
	181	}
	182
	183	=head2 add_relationship( $self, $source, $sourcetext, $target, $targettext, $opts )
	184
	185	Adds the relationship specified in $opts (see Text::Tradition::Collation::Relationship
	186	for the possible options) between the readings given in $source and $target. Sets
	187	up a scoped relationship between $sourcetext and $targettext if the relationship is
	188	scoped non-locally.
	189
	190	Returns a status boolean and a list of all reading pairs connected by the call to
	191	add_relationship.
	192
	193	=cut
	194
	195	sub add_relationship {
	196	my( $self, $source, $source_rdg, $target, $target_rdg, $options ) = @_;
	197
	198	# Check the options
	199	$options->{'scope'} = 'local' unless $options->{'scope'};
	200
	201	my( $is_valid, $reason ) =
	202	$self->relationship_valid( $source, $target, $options->{'type'} );
	203	unless( $is_valid ) {
63778331	204	throw( "Invalid relationship: $reason" );
22222af9	205	}
	206
	207	# Try to create the relationship object.
	208	$options->{'reading_a'} = $source_rdg->text;
	209	$options->{'reading_b'} = $target_rdg->text;
	210	$options->{'orig_a'} = $source;
	211	$options->{'orig_b'} = $target;
63778331	212	my $relationship = $self->create( $options ); # Will throw on error
22222af9	213
	214	# Find all the pairs for which we need to set the relationship.
	215	my @vectors = ( [ $source, $target ] );
	216	if( $relationship->colocated && $relationship->nonlocal ) {
	217	my $c = $self->collation;
	218	# Set the same relationship everywhere we can, throughout the graph.
	219	my @identical_readings = grep { $_->text eq $relationship->reading_a }
	220	$c->readings;
	221	foreach my $ir ( @identical_readings ) {
cf6c01be	222	next if $ir->id eq $source;
22222af9	223	# Check to see if there is a target reading with the same text at
	224	# the same rank.
	225	my @itarget = grep
	226	{ $_->rank == $ir->rank && $_->text eq $relationship->reading_b }
	227	$c->readings;
	228	if( @itarget ) {
	229	# We found a hit.
	230	warn "More than one reading with text " . $target_rdg->text
	231	. " at rank " . $ir->rank . "!" if @itarget > 1;
cf6c01be	232	push( @vectors, [ $ir->id, $itarget[0]->id ] );
22222af9	233	}
	234	}
	235	}
	236
	237	# Now set the relationship(s).
	238	my @pairs_set;
	239	foreach my $v ( @vectors ) {
3ae5e2ad	240	my $rel = $self->get_relationship( @$v );
3ae5e2ad	241	if( $rel ) {
63778331	242	if( $rel->nonlocal ) {
	243	throw( "Found conflicting relationship at @$v" );
	244	} else {
	245	warn "Not overriding local relationship set at @$v";
	246	}
3ae5e2ad	247	next;
22222af9	248	}
3ae5e2ad	249	$self->_set_relationship( $relationship, @$v );
22222af9	250	push( @pairs_set, $v );
	251	}
	252
63778331	253	return @pairs_set;
22222af9	254	}
	255
	256	=head2 relationship_valid( $source, $target, $type )
	257
	258	Checks whether a relationship of type $type may exist between the readings given
	259	in $source and $target. Returns a tuple of ( status, message ) where status is
	260	a yes/no boolean and, if the answer is no, message gives the reason why.
	261
	262	=cut
	263
	264	sub relationship_valid {
	265	my( $self, $source, $target, $rel ) = @_;
	266	my $c = $self->collation;
	267	if ( $rel eq 'transposition' \|\| $rel eq 'repetition' ) {
	268	# Check that the two readings do (for a repetition) or do not (for
	269	# a transposition) appear in the same witness.
	270	my %seen_wits;
	271	map { $seen_wits{$_} = 1 } $c->reading_witnesses( $source );
	272	foreach my $w ( $c->reading_witnesses( $target ) ) {
	273	if( $seen_wits{$w} ) {
	274	return ( 0, "Readings both occur in witness $w" )
	275	if $rel eq 'transposition';
	276	return ( 1, "ok" ) if $rel eq 'repetition';
	277	}
	278	return $rel eq 'transposition' ? ( 1, "ok" )
	279	: ( 0, "Readings occur only in distinct witnesses" );
	280	}
	281	} else {
	282	# Check that linking the source and target in a relationship won't lead
a1615ee4	283	# to a path loop for any witness. If they have the same rank then fine.
a1615ee4	284	return( 1, "ok" )
84d4ca78	285	if $c->reading( $source )->has_rank
	286	&& $c->reading( $target )->has_rank
	287	&& $c->reading( $source )->rank == $c->reading( $target )->rank;
a1615ee4	288
a1615ee4	289	# Otherwise, first make a lookup table of all the
22222af9	290	# readings related to either the source or the target.
	291	my @proposed_related = ( $source, $target );
	292	push( @proposed_related, $self->related_readings( $source, 'colocated' ) );
	293	push( @proposed_related, $self->related_readings( $target, 'colocated' ) );
	294	my %pr_ids;
	295	map { $pr_ids{ $_ } = 1 } @proposed_related;
	296
a1615ee4	297	# The cumulative predecessors and successors of the proposed-related readings
	298	# should not overlap.
	299	my %all_pred;
	300	my %all_succ;
22222af9	301	foreach my $pr ( keys %pr_ids ) {
a1615ee4	302	map { $all_pred{$_} = 1 } $c->sequence->all_predecessors( $pr );
	303	map { $all_succ{$_} = 1 } $c->sequence->all_successors( $pr );
	304	}
	305	foreach my $k ( keys %all_pred ) {
	306	return( 0, "Relationship would create witness loop" )
	307	if exists $all_succ{$k};
	308	}
	309	foreach my $k ( keys %pr_ids ) {
	310	return( 0, "Relationship would create witness loop" )
	311	if exists $all_pred{$k} \|\| exists $all_succ{$k};
	312	}
22222af9	313	return ( 1, "ok" );
	314	}
	315	}
	316
	317	=head2 related_readings( $reading, $colocated_only )
	318
	319	Returns a list of readings that are connected via relationship links to $reading.
	320	If $colocated_only is true, restricts the list to those readings that are in the
	321	same logical location (and therefore have the same rank in the collation graph.)
	322
	323	=cut
	324
	325	sub related_readings {
	326	my( $self, $reading, $colocated ) = @_;
	327	my $return_object;
	328	if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
	329	$reading = $reading->id;
	330	$return_object = 1;
	331	}
c84275ff	332	my @answer;
22222af9	333	if( $colocated ) {
c84275ff	334	my %found = ( $reading => 1 );
	335	my $check = [ $reading ];
	336	my $iter = 0;
	337	while( @$check ) {
c84275ff	338	my $more = [];
	339	foreach my $r ( @$check ) {
	340	foreach my $nr ( $self->graph->neighbors( $r ) ) {
3ae5e2ad	341	if( $self->get_relationship( $r, $nr )->colocated ) {
c84275ff	342	push( @$more, $nr ) unless exists $found{$nr};
	343	$found{$nr} = 1;
	344	}
	345	}
	346	}
	347	$check = $more;
22222af9	348	}
c84275ff	349	@answer = keys %found;
	350	} else {
	351	@answer = $self->graph->all_reachable( $reading );
22222af9	352	}
	353	if( $return_object ) {
	354	my $c = $self->collation;
c84275ff	355	return map { $c->reading( $_ ) } @answer;
22222af9	356	} else {
c84275ff	357	return @answer;
22222af9	358	}
	359	}
	360
	361	=head2 merge_readings( $kept, $deleted );
	362
	363	Makes a best-effort merge of the relationship links between the given readings, and
	364	stops tracking the to-be-deleted reading.
	365
	366	=cut
	367
	368	sub merge_readings {
	369	my( $self, $kept, $deleted, $combined ) = @_;
	370	foreach my $edge ( $self->graph->edges_at( $deleted ) ) {
	371	# Get the pair of kept / rel
	372	my @vector = ( $kept );
	373	push( @vector, $edge->[0] eq $deleted ? $edge->[1] : $edge->[0] );
	374	next if $vector[0] eq $vector[1]; # Don't add a self loop
	375
	376	# If kept changes its text, drop the relationship.
	377	next if $combined;
	378
	379	# If kept / rel already has a relationship, warn and keep the old
3ae5e2ad	380	my $rel = $self->get_relationship( @vector );
3ae5e2ad	381	if( $rel ) {
22222af9	382	warn sprintf( "Readings %s and %s have existing relationship; dropping link with %s", @vector, $deleted );
	383	next;
	384	}
	385
	386	# Otherwise, adopt the relationship that would be deleted.
3ae5e2ad	387	$rel = $self->get_relationship( @$edge );
3ae5e2ad	388	$self->_set_relationship( $rel, @vector );
22222af9	389	}
	390	$self->delete_reading( $deleted );
	391	}
	392
027d819c	393	sub _as_graphml {
2626f709	394	my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_;
c84275ff	395
	396	my $rgraph = $xmlroot->addNewChild( $graphml_ns, 'graph' );
	397	$rgraph->setAttribute( 'edgedefault', 'directed' );
	398	$rgraph->setAttribute( 'id', 'relationships', );
	399	$rgraph->setAttribute( 'parse.edgeids', 'canonical' );
	400	$rgraph->setAttribute( 'parse.edges', scalar($self->graph->edges) );
	401	$rgraph->setAttribute( 'parse.nodeids', 'canonical' );
	402	$rgraph->setAttribute( 'parse.nodes', scalar($self->graph->vertices) );
	403	$rgraph->setAttribute( 'parse.order', 'nodesfirst' );
	404
	405	# Add the vertices according to their XML IDs
2626f709	406	my %rdg_lookup = ( reverse %$node_hash );
2626f709	407	foreach my $n ( sort _by_xmlid keys( %rdg_lookup ) ) {
c84275ff	408	my $n_el = $rgraph->addNewChild( $graphml_ns, 'node' );
c84275ff	409	$n_el->setAttribute( 'id', $n );
2626f709	410	_add_graphml_data( $n_el, $nodeid_key, $rdg_lookup{$n} );
c84275ff	411	}
	412
	413	# Add the relationship edges, with their object information
	414	my $edge_ctr = 0;
	415	foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->graph->edges ) {
	416	# Add an edge and fill in its relationship info.
	417	my $edge_el = $rgraph->addNewChild( $graphml_ns, 'edge' );
	418	$edge_el->setAttribute( 'source', $node_hash->{$e->[0]} );
	419	$edge_el->setAttribute( 'target', $node_hash->{$e->[1]} );
	420	$edge_el->setAttribute( 'id', 'e'.$edge_ctr++ );
	421
3ae5e2ad	422	my $rel_obj = $self->get_relationship( @$e );
c84275ff	423	_add_graphml_data( $edge_el, $edge_keys->{'relationship'}, $rel_obj->type );
	424	_add_graphml_data( $edge_el, $edge_keys->{'scope'}, $rel_obj->scope );
	425	_add_graphml_data( $edge_el, $edge_keys->{'non_correctable'},
	426	$rel_obj->non_correctable ) if $rel_obj->noncorr_set;
	427	_add_graphml_data( $edge_el, $edge_keys->{'non_independent'},
	428	$rel_obj->non_independent ) if $rel_obj->nonind_set;
	429	}
	430	}
	431
	432	sub _by_xmlid {
2626f709	433	my $tmp_a = $a;
	434	my $tmp_b = $b;
	435	$tmp_a =~ s/\D//g;
	436	$tmp_b =~ s/\D//g;
	437	return $tmp_a <=> $tmp_b;
c84275ff	438	}
	439
	440	sub _add_graphml_data {
	441	my( $el, $key, $value ) = @_;
	442	return unless defined $value;
	443	my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
	444	$data_el->setAttribute( 'key', $key );
	445	$data_el->appendText( $value );
83d5ac3a	446	}
83d5ac3a	447
63778331	448	sub throw {
	449	Text::Tradition::Error->throw(
	450	'ident' => 'Relationship error',
	451	'message' => $_[0],
	452	);
	453	}
	454
22222af9	455	no Moose;
	456	__PACKAGE__->meta->make_immutable;
	457
	458	1;