X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FText%2FTradition%2FCollation%2FRelationshipStore.pm;h=55d69431927c78ae1ba62f887a89cd24411ef9aa;hb=679f17e1a60a81370df8cbb49b94a2b5d19e3a98;hp=c9136b347ac17c8ff7d1619b20b946fba76b7f17;hpb=bbd064a9a0899c1ca82b094ecd81a11b312a3ed9;p=scpubgit%2Fstemmatology.git diff --git a/lib/Text/Tradition/Collation/RelationshipStore.pm b/lib/Text/Tradition/Collation/RelationshipStore.pm index c9136b3..55d6943 100644 --- a/lib/Text/Tradition/Collation/RelationshipStore.pm +++ b/lib/Text/Tradition/Collation/RelationshipStore.pm @@ -41,19 +41,15 @@ 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', +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( 'n8', 'n13' ); +@v2 = $c->del_relationship( 'n12', '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" ); -} +my @v3 = $c->del_relationship( 'n1', 'n2' ); +is( scalar @v3, 0, "Nothing deleted on non-existent relationship" ); =end testing @@ -167,13 +163,16 @@ non-locally. Key on whichever reading occurs first alphabetically. sub add_scoped_relationship { my( $self, $rel ) = @_; - my $r = $self->scoped_relationship( $rel->reading_a, $rel->reading_b ); + 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, $rel->reading_a, $rel->reading_b ); + $r->type, $rdga, $rdgb ); return; } - $self->scopedrels->{$rel->reading_a}->{$rel->reading_b} = $rel; + my( $first, $second ) = sort ( $rdga, $rdgb ); + $self->scopedrels->{$first}->{$second} = $rel; } =head2 scoped_relationship( $reading_a, $reading_b ) @@ -216,6 +215,7 @@ sub add_relationship { } else { # Check the options $options->{'scope'} = 'local' unless $options->{'scope'}; + $options->{'scope'} = 'local' if $options->{'type'} eq 'collated'; my( $is_valid, $reason ) = $self->relationship_valid( $source, $target, $options->{'type'} ); @@ -230,8 +230,12 @@ sub add_relationship { $options->{'orig_b'} = $target; if( $options->{'scope'} ne 'local' ) { # Is there a relationship with this a & b already? - my $otherrel = $self->scoped_relationship( $options->{reading_a}, - $options->{reading_b} ); + # 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"; @@ -243,28 +247,11 @@ sub add_relationship { # Find all the pairs for which we need to set the relationship. - my @vectors = ( [ $source, $target ] ); + my @vectors = [ $source, $target ]; if( $relationship->colocated && $relationship->nonlocal && !$thispaironly ) { - 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 ] ); - } - } + push( @vectors, $self->_find_applicable( $relationship ) ); } - + # Now set the relationship(s). my @pairs_set; foreach my $v ( @vectors ) { @@ -272,10 +259,11 @@ sub add_relationship { if( $rel && $rel ne $relationship ) { if( $rel->nonlocal ) { throw( "Found conflicting relationship at @$v" ); - } else { + } elsif( $rel->type ne 'collated' ) { + # Replace a collation relationship; leave any other sort in place. warn "Not overriding local relationship set at @$v"; + next; } - next; } $self->_set_relationship( $relationship, @$v ); push( @pairs_set, $v ); @@ -284,6 +272,47 @@ sub add_relationship { return @pairs_set; } +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 @@ -294,7 +323,7 @@ non-local, removes the relationship everywhere in the graph. sub del_relationship { my( $self, $source, $target ) = @_; my $rel = $self->get_relationship( $source, $target ); - throw( "No relationship defined between $source and $target" ) unless $rel; + return () unless $rel; # Nothing to delete; return an empty set. my @vectors = ( [ $source, $target ] ); $self->_remove_relationship( $source, $target ); if( $rel->nonlocal ) { @@ -456,12 +485,9 @@ sub merge_readings { # If kept changes its text, drop the relationship. next if $combined; - # If kept / rel already has a relationship, warn and keep the old + # If kept / rel already has a relationship, just 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; - } + next if $rel; # Otherwise, adopt the relationship that would be deleted. $rel = $self->get_relationship( @$edge );