[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' => 'lexical' } );
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( 'n24', '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( 'n12', 'n13' );
is( scalar @v2, 2, "Deleted second global relationship" );
my @v3 = $c->del_relationship( 'n1', 'n2' );
is( scalar @v3, 0, "Nothing deleted on non-existent relationship" );

=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',
    },
	);
	
=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 );
}

=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 $rdga = $rel->type eq 'orthographic' ? $rel->reading_a : lc( $rel->reading_a );
	my $rdgb = $rel->type eq 'orthographic' ? $rel->reading_b : lc( $rel->reading_b );	
	my $r = $self->scoped_relationship( $rdga, $rdgb );
	if( $r ) {
		warn sprintf( "Scoped relationship of type %s already exists between %s and %s",
			$r->type, $rdga, $rdgb );
		return;
	}
	my( $first, $second ) = sort ( $rdga, $rdgb );
	$self->scopedrels->{$first}->{$second} = $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 ) = @_;

	my $relationship;
	my $thispaironly;
	if( ref( $options ) eq 'Text::Tradition::Collation::Relationship' ) {
		$relationship = $options;
		$thispaironly = 1;  # If existing rel, set only where asked.
	} else {
		# Check the options
		$options->{'scope'} = 'local' unless $options->{'scope'};
		$options->{'scope'} = 'local' if $options->{'type'} eq 'collated';
		$options->{'scope'} = 'local' if $options->{'type'} eq 'transposition';
		
		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;
    	if( $options->{'scope'} ne 'local' ) {
			# Is there a relationship with this a & b already?
			# Case-insensitive for non-orthographics.
			my $rdga = $options->{'type'} eq 'orthographic' 
				? $options->{'reading_a'} : lc( $options->{'reading_a'} );
			my $rdgb = $options->{'type'} eq 'orthographic' 
				? $options->{'reading_b'} : lc( $options->{'reading_b'} );
			my $otherrel = $self->scoped_relationship( $rdga, $rdgb );
			if( $otherrel && $otherrel->type eq $options->{type}
				&& $otherrel->scope eq $options->{scope} ) {
				warn "Applying existing scoped relationship";
				$relationship = $otherrel;
			}
    	}
		$relationship = $self->create( $options ) unless $relationship;  # 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 && !$thispaironly ) {
    	push( @vectors, $self->_find_applicable( $relationship ) );
    }
        
    # Now set the relationship(s).
    my @pairs_set;
    foreach my $v ( @vectors ) {
		my $rel = $self->get_relationship( @$v );
    	if( $rel && $rel ne $relationship ) {
    		if( $rel->nonlocal ) {
    			throw( "Found conflicting relationship at @$v" );
    		} elsif( $rel->type ne 'collated' ) {
    			# Replace a collation relationship; leave any other sort in place.
    			warn "Not overriding local relationship set at @$v";
				next;
    		}
    	}
    	map { $self->_drop_collations( $_ ) } @$v;
    	$self->_set_relationship( $relationship, @$v );
    	push( @pairs_set, $v );
    }
    
    return @pairs_set;
}

=head2 del_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 del_scoped_relationship {
	my( $self, $rdga, $rdgb ) = @_;
	my( $first, $second ) = sort( $rdga, $rdgb );
	return delete $self->scopedrels->{$first}->{$second};
}

sub _find_applicable {
	my( $self, $rel ) = @_;
	my $c = $self->collation;
	# TODO Someday we might use a case sensitive language.
	my $lang = $c->tradition->language;
	my @vectors;
	my @identical_readings;
	if( $rel->type eq 'orthographic' ) {
		@identical_readings = grep { $_->text eq $rel->reading_a } 
			$c->readings;
	} else {
		@identical_readings = grep { lc( $_->text ) eq lc( $rel->reading_a ) }
			$c->readings;
	}
	foreach my $ir ( @identical_readings ) {
		my @itarget;
		if( $rel->type eq 'orthographic' ) {
			@itarget = grep { $_->rank == $ir->rank 
							  && $_->text eq $rel->reading_b } $c->readings;
		} else {
			@itarget = grep { $_->rank == $ir->rank 
							  && lc( $_->text ) eq lc( $rel->reading_b ) } $c->readings;
		}
		if( @itarget ) {
			# Warn if there is more than one hit with no orth link between them.
			my $itmain = shift @itarget;
			if( @itarget ) {
				my %all_targets;
				map { $all_targets{$_} = 1 } @itarget;
				map { delete $all_targets{$_} } 
					$self->related_readings( $itmain, 
						sub { $_[0]->type eq 'orthographic' } );
    			warn "More than one unrelated reading with text " . $itmain->text
    				. " at rank " . $ir->rank . "!" if keys %all_targets;
			}
			push( @vectors, [ $ir->id, $itmain->id ] );
		}
	}
	return @vectors;
}

=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 );
	return () unless $rel; # Nothing to delete; return an empty set.
	my @vectors = ( [ $source, $target ] );
	$self->_remove_relationship( $source, $target );
	if( $rel->nonlocal ) {
		# Remove the relationship wherever it occurs.
		# 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 );
		}
		$self->del_scoped_relationship( $rel->reading_a, $rel->reading_b );
	}
	return @vectors;
}

sub _remove_relationship {
	my( $self, @vector ) = @_;
	$self->graph->delete_edge( @vector );
}
	
=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 );
		# Drop the collation links of source and target, unless we want to
		# add a collation relationship.
		foreach my $r ( ( $source, $target ) ) {
			$self->_drop_collations( $r ) unless $rel eq 'collated';
			push( @proposed_related, $self->related_readings( $r, '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" );
	}
}

sub _drop_collations {
	my( $self, $reading ) = @_;
	foreach my $n ( $self->graph->neighbors( $reading ) ) {
		if( $self->get_relationship( $reading, $n )->type eq 'collated' ) {
			$self->del_relationship( $reading, $n );
		}
	}
}

=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, just keep the old
		my $rel = $self->get_relationship( @vector );
		next if $rel;
		
		# 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 );
		foreach my $key ( keys %$edge_keys ) {
			my $value = $rel_obj->$key;
			_add_graphml_data( $edge_el, $edge_keys->{$key}, $value ) 
				if defined $value;
		}
	}
}

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