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

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

# Add some relationships, and delete them

my $cxfile = 't/data/Collatex-16.xml';
my $t = Text::Tradition->new( 
    'name'  => 'inline', 
    'input' => 'CollateX',
    'file'  => $cxfile,
    );
my $c = $t->collation;

my @v1 = $c->add_relationship( 'n21', 'n22', { 'type' => 'meaning' } );
is( scalar @v1, 1, "Added a single relationship" );
is( $v1[0]->[0], 'n21', "Got correct node 1" );
is( $v1[0]->[1], 'n22', "Got correct node 2" );
my @v2 = $c->add_relationship( 'n9', 'n23', 
	{ 'type' => 'spelling', 'scope' => 'global' } );
is( scalar @v2, 2, "Added a global relationship with two instances" );
@v1 = $c->del_relationship( 'n22', 'n21' );
is( scalar @v1, 1, "Deleted first relationship" );
@v2 = $c->del_relationship( 'n8', 'n13' );
is( scalar @v2, 2, "Deleted second global relationship" );
try {
	my @v3 = $c->del_relationship( 'n1', 'n2' );
	ok( 0, "Should have errored on non-existent relationship" );
} catch( Text::Tradition::Error $e ) {
	like( $e->message, qr/No relationship defined/, "Attempt to delete non-existent relationship errored" );
}

=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 eq 'collated' ) {
			# Always replace a 'collated' relationship with a more descriptive
			# one, if asked.
			$self->del_relationship( $source, $target );
		} elsif( $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 del_relationship( $source, $target )

Removes the relationship between the given readings. If the relationship is
non-local, removes the relationship everywhere in the graph.

=cut

sub del_relationship {
	my( $self, $source, $target ) = @_;
	my $rel = $self->get_relationship( $source, $target );
	throw( "No relationship defined between $source and $target" ) unless $rel;
	my @vectors = ( [ $source, $target ] );
	$self->_remove_relationship( $source, $target );
	if( $rel->nonlocal ) {
		# Remove the relationship wherever it occurs.
		my @rel_edges = grep { $self->get_relationship( @$_ ) == $rel }
			$self->relationships;
		foreach my $re ( @rel_edges ) {
			$self->_remove_relationship( @$re );
			push( @vectors, $re );
		}
	}
	return @vectors;
}

=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.
		# TODO this might be called before witness paths are set...
		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, $filter )

Returns a list of readings that are connected via relationship links to $reading.
If $filter is set to a subroutine ref, returns only those related readings where
$filter( $relationship ) returns a true value.

=cut

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