Add logic for normalized form of lemma to propagate on orth/spelling links

diff --git a/base/lib/Text/Tradition/Collation.pm b/base/lib/Text/Tradition/Collation.pm
index 22814f2..70e471a 100644 (file)
--- a/base/lib/Text/Tradition/Collation.pm
+++ b/base/lib/Text/Tradition/Collation.pm
@@ -901,13 +901,22 @@ sub add_relationship {
        my $self = shift;
     my( $source, $target, $opts ) = $self->_stringify_args( @_ );
     my( @vectors ) = $self->relations->add_relationship( $source, $target, $opts );
+    my $did_recalc;
     foreach my $v ( @vectors ) {
-       next unless $self->get_relationship( $v )->colocated;
-       if( $self->reading( $v->[0] )->has_rank && $self->reading( $v->[1] )->has_rank
-               && $self->reading( $v->[0] )->rank ne $self->reading( $v->[1] )->rank ) {
+       my $rel = $self->get_relationship( $v );
+       next unless $rel->colocated;
+       my $r1 = $self->reading( $v->[0] );
+       my $r2 =  $self->reading( $v->[1] );
+       # If it's a spelling or orthographic relationship, and one is marked
+       # as a lemma, set the normal form on the non-lemma to reflect that.
+       if( $r1->does( 'Text::Tradition::Morphology' ) ) {
+               $r1->relationship_added( $r2, $rel );
+       }
+       next if $did_recalc;
+       if( $r1->has_rank && $r2->has_rank && $r1->rank ne $r2->rank ) {
                        $self->_graphcalc_done(0);
                        $self->_clear_cache;
-                       last;
+                       $did_recalc = 1;
        }
     }
     return @vectors;

diff --git a/base/lib/Text/Tradition/Collation/Reading.pm b/base/lib/Text/Tradition/Collation/Reading.pm
index 6852a34..88c1d5d 100644 (file)
--- a/base/lib/Text/Tradition/Collation/Reading.pm
+++ b/base/lib/Text/Tradition/Collation/Reading.pm
@@ -208,6 +208,27 @@ sub BUILD {
        }
 }
 
+around make_lemma => sub {
+       my $orig = shift;
+       my $self = shift;
+       my $val = shift;
+
+       # TODO unset the lemma from any other reading at the same rank.
+       if( $val && $self->does( 'Text::Tradition::Morphology' )) {
+               # Set the normal form on all orthographically related readings to match
+               # the normal form on this one.
+               my $filter = sub { 
+                       my $rl = shift; 
+                       my $rltype = $self->collation->relations->type( $rl->type );
+                       return $rltype->bindlevel < 2 
+               };
+               foreach my $r ( $self->related_readings( $filter ) ) {
+                       $r->normal_form( $self->normal_form );
+               }
+       }
+       $self->$orig( $val );
+};
+
 =head2 is_meta
 
 A meta attribute (ha ha), which should be true if any of our 'special'

diff --git a/morphology/lib/Text/Tradition/Morphology.pm b/morphology/lib/Text/Tradition/Morphology.pm
index fc59bd9..286ef33 100644 (file)
--- a/morphology/lib/Text/Tradition/Morphology.pm
+++ b/morphology/lib/Text/Tradition/Morphology.pm
@@ -239,6 +239,78 @@ after '_combine' => sub {
        }
 };
 
+=head2 relationship_added
+
+To be called when a relationship is set, to implement the consequences of 
+certain relationships.
+
+=begin testing
+
+# Test that normal form follows lemma setting. Draws on code both here and in
+# the base module.
+
+use Text::Tradition;
+
+my $t = Text::Tradition->new(
+       input => 'Self',
+       file => 't/data/florilegium_graphml.xml' );
+my $c = $t->collation;
+
+# First try lemmatizing and then adding a relationship
+my $r1 = $c->reading('w42');
+my $r2 = $c->reading('w44');
+$r1->normal_form('FOO');
+$r2->normal_form('BAR');
+
+$r1->make_lemma( 1 );
+is( $r1->normal_form, 'FOO', "nothing changed yet" );
+is( $r2->normal_form, 'BAR', "nothing changed yet" );
+
+$c->add_relationship( $r1, $r2, { type => 'spelling' } );
+is( $r2->normal_form, 'FOO', "Normal form followed lemma" );
+
+# Now try setting relationships and then lemmatizing
+my $r3 = $c->reading('w98');
+my $r4 = $c->reading('w100');
+my $r5 = $c->reading('w103');
+$r3->normal_form('YAN');
+$r4->normal_form('TAN');
+$r5->normal_form('TETHERA');
+
+$c->add_relationship( $r3, $r4, { type => 'orthographic', propagate => 1 } );
+$c->add_relationship( $r3, $r5, { type => 'orthographic', propagate => 1 } );
+is( $r3->normal_form, 'YAN', "nothing changed yet" );
+is( $r4->normal_form, 'TAN', "nothing changed yet" );
+is( $r5->normal_form, 'TETHERA', "nothing changed yet" );
+
+$r3->make_lemma( 1 );
+is( $r4->normal_form, 'YAN', "normal form propagated" );
+is( $r5->normal_form, 'YAN', "normal form propagated" );
+
+# Finally, try a relationship that shouldn't propagate the normal form
+my $r6 = $c->reading('w91');
+my $r7 = $c->reading('w92');
+$r6->normal_form('BAZ');
+$r7->normal_form('QUUX');
+$r6->make_lemma( 1 );
+
+$c->add_relationship( $r6, $r7, { type => 'grammatical' } );
+is( $r7->normal_form, 'QUUX', "normal form on grammatical relationship unchanged" );
+
+=end testing
+
+=cut
+
+sub relationship_added {
+       my( $rdg1, $rdg2, $rel ) = @_;
+       my $lemma = $rdg1->is_lemma ? $rdg1 : ( $rdg2->is_lemma ? $rdg2 : undef );
+       if( $rel->type =~ /^(spelling|orthographic)$/ && $lemma ) {
+               my $other = $lemma->id eq $rdg1->id ? $rdg2 : $rdg1;
+               # Set the normal form on $other to match $lemma.
+               $other->normal_form( $lemma->normal_form );
+       }
+}
+
 1;
 
 =head1 LICENSE

diff --git a/morphology/t/text_tradition_morphology.t b/morphology/t/text_tradition_morphology.t
new file mode 100644 (file)
index 0000000..c78772e
--- /dev/null
+++ b/morphology/t/text_tradition_morphology.t
@@ -0,0 +1,66 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More 'no_plan';
+$| = 1;
+
+
+
+# =begin testing
+{
+# Test that normal form follows lemma setting. Draws on code both here and in
+# the base module.
+
+use Text::Tradition;
+
+my $t = Text::Tradition->new(
+       input => 'Self',
+       file => 't/data/florilegium_graphml.xml' );
+my $c = $t->collation;
+
+# First try lemmatizing and then adding a relationship
+my $r1 = $c->reading('w42');
+my $r2 = $c->reading('w44');
+$r1->normal_form('FOO');
+$r2->normal_form('BAR');
+
+$r1->make_lemma( 1 );
+is( $r1->normal_form, 'FOO', "nothing changed yet" );
+is( $r2->normal_form, 'BAR', "nothing changed yet" );
+
+$c->add_relationship( $r1, $r2, { type => 'spelling' } );
+is( $r2->normal_form, 'FOO', "Normal form followed lemma" );
+
+# Now try setting relationships and then lemmatizing
+my $r3 = $c->reading('w98');
+my $r4 = $c->reading('w100');
+my $r5 = $c->reading('w103');
+$r3->normal_form('YAN');
+$r4->normal_form('TAN');
+$r5->normal_form('TETHERA');
+
+$c->add_relationship( $r3, $r4, { type => 'orthographic', propagate => 1 } );
+$c->add_relationship( $r3, $r5, { type => 'orthographic', propagate => 1 } );
+is( $r3->normal_form, 'YAN', "nothing changed yet" );
+is( $r4->normal_form, 'TAN', "nothing changed yet" );
+is( $r5->normal_form, 'TETHERA', "nothing changed yet" );
+
+$r3->make_lemma( 1 );
+is( $r4->normal_form, 'YAN', "normal form propagated" );
+is( $r5->normal_form, 'YAN', "normal form propagated" );
+
+# Finally, try a relationship that shouldn't propagate the normal form
+my $r6 = $c->reading('w91');
+my $r7 = $c->reading('w92');
+$r6->normal_form('BAZ');
+$r7->normal_form('QUUX');
+$r6->make_lemma( 1 );
+
+$c->add_relationship( $r6, $r7, { type => 'grammatical' } );
+is( $r7->normal_form, 'QUUX', "normal form on grammatical relationship unchanged" );
+}
+
+
+
+
+1;