From: tla <tla@mit.edu>
Date: Sat, 18 Apr 2015 12:17:54 +0000 (+0200)
Subject: Add logic for normalized form of lemma to propagate on orth/spelling links
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=45095bee79060ca64adcf64b2782695a417c187a;p=scpubgit%2Fstemmatology.git

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