From: Tara L Andrews <tla@mit.edu>
Date: Tue, 21 Apr 2015 21:37:45 +0000 (+0200)
Subject: Operations that change readings as side effect should return those readings. #38
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5fd7be0fdd663c7ac1adfa26b9ca7020d7951670;p=scpubgit%2Fstemmatology.git

Operations that change readings as side effect should return those readings. #38
---

diff --git a/base/lib/Text/Tradition/Collation.pm b/base/lib/Text/Tradition/Collation.pm
index 3957762..08ac94f 100644
--- a/base/lib/Text/Tradition/Collation.pm
+++ b/base/lib/Text/Tradition/Collation.pm
@@ -195,12 +195,15 @@ The readings may be specified by object or ID.
 
 Returns all Relationship objects in the collation.
 
-=head2 add_relationship( $reading, $other_reading, $options )
+=head2 add_relationship( $reading, $other_reading, $options, $changed_readings )
 
 Adds a new relationship of the type given in $options between the two readings,
 which may be specified by object or ID.  Returns a value of ( $status, @vectors)
 where $status is true on success, and @vectors is a list of relationship edges
-that were ultimately added.
+that were ultimately added. If an array reference is passed in as $changed_readings, 
+then any readings that were altered due to the relationship creation are added to
+the array.
+
 See L<Text::Tradition::Collation::Relationship> for the available options.
 
 =cut 
@@ -902,7 +905,7 @@ sub clear_witness {
 
 sub add_relationship {
 	my $self = shift;
-    my( $source, $target, $opts ) = $self->_stringify_args( @_ );
+    my( $source, $target, $opts, $altered_readings ) = $self->_stringify_args( @_ );
     my( @vectors ) = $self->relations->add_relationship( $source, $target, $opts );
     my $did_recalc;
     foreach my $v ( @vectors ) {
@@ -913,7 +916,10 @@ sub add_relationship {
     	# 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 );
+    		my @changed = $r1->relationship_added( $r2, $rel );
+    		if( ref( $altered_readings ) eq 'ARRAY' ) {
+    			push( @$altered_readings, @changed );
+    		}
     	}
     	next if $did_recalc;
     	if( $r1->has_rank && $r2->has_rank && $r1->rank ne $r2->rank ) {
diff --git a/base/lib/Text/Tradition/Collation/Reading.pm b/base/lib/Text/Tradition/Collation/Reading.pm
index 45040d1..323bd76 100644
--- a/base/lib/Text/Tradition/Collation/Reading.pm
+++ b/base/lib/Text/Tradition/Collation/Reading.pm
@@ -43,6 +43,8 @@ reading belongs.  Required.
 
 =item text - The word or other text of the reading.
 
+=item is_lemma - The reading serves as a lemma for the constructed text.
+
 =item is_start - The reading is the starting point for the collation.
 
 =item is_end - The reading is the ending point for the collation.
@@ -65,16 +67,26 @@ One of 'text', 'is_start', 'is_end', or 'is_lacuna' is required.
 
 =head2 text
 
+=head2 is_lemma
+
 =head2 is_start
 
 =head2 is_end
 
 =head2 is_lacuna
 
-=head2 rank
+=head2 rank( $new_rank )
 
 Accessor methods for the given attributes.
 
+=head2 alter_text
+
+Changes the text of the reading.
+
+=head2 make_lemma
+
+Sets this reading as a lemma for the constructed text.
+
 =cut
 
 has 'collation' => (
@@ -208,16 +220,32 @@ sub BUILD {
 	}
 }
 
+=head2 
+
+=cut
+
 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' )) {
-		$self->push_normal_form();
+	my @altered = ( $self );
+	if( $val ) {
+		# Unset the is_lemma flag for other readings at our rank
+		foreach my $rdg ( $self->collation->readings_at_rank( $self->rank ) ) {
+			next if $rdg eq $self;
+			if( $rdg->is_lemma ) {
+				$rdg->$orig( 0 );
+				push( @altered, $rdg );
+			}
+		}
+		# Call the morphology handler
+		if( $self->does( 'Text::Tradition::Morphology' ) ) {
+			push( @altered, $self->push_normal_form() );
+		}
 	}
 	$self->$orig( $val );
+	return @altered;
 };
 
 =head2 is_meta
diff --git a/base/lib/Text/Tradition/Parser/CollateText.pm b/base/lib/Text/Tradition/Parser/CollateText.pm
index 8413939..c27aba4 100644
--- a/base/lib/Text/Tradition/Parser/CollateText.pm
+++ b/base/lib/Text/Tradition/Parser/CollateText.pm
@@ -614,4 +614,8 @@ sub rstr {
     return $str;
 }
 
-1;
\ No newline at end of file
+1;
+
+=back
+
+=cut
\ No newline at end of file
diff --git a/morphology/lib/Text/Tradition/Morphology.pm b/morphology/lib/Text/Tradition/Morphology.pm
index 31a49ef..b6a9ef6 100644
--- a/morphology/lib/Text/Tradition/Morphology.pm
+++ b/morphology/lib/Text/Tradition/Morphology.pm
@@ -79,14 +79,17 @@ around 'normal_form' => sub {
 		# return the right default
 		return $self->_has_normal_form ? $self->$orig() : $self->text;
 	}
+	# If we are setting a new normal form, we return a list of the
+	# readings that were changed.
 	my $arg = shift;
+	my @altered = ( $self );
 	if( $arg && $arg eq $self->text ) {
 		$self->_clear_normal_form;
 	} else {
 		$self->$orig( $arg );
+		push( @altered, $self->push_normal_form() ) if $self->is_lemma;
 	}
-	$self->push_normal_form() if $self->is_lemma;
-	return $arg;
+	return @altered;
 };
 
 =head1 READING METHODS
@@ -98,15 +101,15 @@ strings ought to match the reading's normalized form.
 See L<Text::Tradition::Collation::Reading::Lexeme> for more information
 on Lexeme objects and their attributes.
 
-=head2 has_lexemes
+=head2 has_lexemes()
 
 Returns a true value if the reading has any attached lexemes.
 
-=head2 lexemes
+=head2 lexemes()
 
 Returns the Lexeme objects (if any) attached to the reading.
 
-=head2 clear_lexemes
+=head2 clear_lexemes()
 
 Wipes any associated Lexeme objects out of the reading.
 
@@ -114,7 +117,7 @@ Wipes any associated Lexeme objects out of the reading.
 
 Adds the Lexeme in $lexobj to the list of lexemes.
 
-=head2 lemmatize
+=head2 lemmatize()
 
 If the language of the reading is set, this method will use the appropriate
 Language model to determine the lexemes that belong to this reading.  See
@@ -243,11 +246,15 @@ after '_combine' => sub {
 	}
 };
 
-=head2 relationship_added
+=head2 relationship_added( $related_reading, $relationship )
 
 To be called when a relationship is set, to implement the consequences of 
 certain relationships.
 
+=head2 push_normal_form()
+
+Copy the normal form of a reading to all its orthographically related readings.
+
 =begin testing
 
 # Test that normal form follows lemma setting. Draws on code both here and in
@@ -263,14 +270,18 @@ 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');
+my @changed = $r1->normal_form('FOO');
+is_deeply( \@changed, [ $r1 ], "Normal form change produced no side effect" );
 $r2->normal_form('BAR');
 
-$r1->make_lemma( 1 );
+@changed = $r1->make_lemma( 1 );
+is_deeply( \@changed, [ $r1 ], "Lemma flag changed only the concerned reading" );
 is( $r1->normal_form, 'FOO', "nothing changed yet" );
 is( $r2->normal_form, 'BAR', "nothing changed yet" );
 
-$c->add_relationship( $r1, $r2, { type => 'spelling' } );
+@changed = ();
+$c->add_relationship( $r1, $r2, { type => 'spelling' }, \@changed );
+is_deeply( \@changed, [ $r2 ], "We were informed that reading 2 changed" );
 is( $r2->normal_form, 'FOO', "Normal form followed lemma" );
 
 # Now try setting relationships and then lemmatizing
@@ -281,18 +292,32 @@ $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 } );
+@changed = ();
+$c->add_relationship( $r3, $r4, { type => 'orthographic', propagate => 1 }, \@changed );
+$c->add_relationship( $r3, $r5, { type => 'orthographic', propagate => 1 }, \@changed );
+is( scalar( @changed ), 0, "No reading side effects yet" );
 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 );
+@changed = $r3->make_lemma( 1 );
+my %present;
+map { $present{$_->id} = 1 } @changed;
+ok( $present{$r3->id}, "Informed of change to reading 3" );
+ok( $present{$r4->id}, "Informed of change to reading 4" );
+ok( $present{$r5->id}, "Informed of change to reading 5" );
+is( scalar keys %present, 3, "Not informed of further changes" );
 is( $r4->normal_form, 'YAN', "normal form propagated" );
 is( $r5->normal_form, 'YAN', "normal form propagated" );
 
 # Now try modifying the normal form and making sure the change is propagated
-$r3->normal_form( 'JIGGIT' );
+@changed = $r3->normal_form( 'JIGGIT' );
+%present = ();
+map { $present{$_->id} = 1 } @changed;
+ok( $present{$r3->id}, "Informed of change to reading 3" );
+ok( $present{$r4->id}, "Informed of change to reading 4" );
+ok( $present{$r5->id}, "Informed of change to reading 5" );
+is( scalar keys %present, 3, "Not informed of further changes" );
 is( $r4->normal_form, 'JIGGIT', "new normal form propagated" );
 is( $r5->normal_form, 'JIGGIT', "new normal form propagated" );
 
@@ -309,8 +334,10 @@ $r6->normal_form('BAZ');
 $r7->normal_form('QUUX');
 $r6->make_lemma( 1 );
 
-$c->add_relationship( $r6, $r7, { type => 'grammatical' } );
+@changed = ();
+$c->add_relationship( $r6, $r7, { type => 'grammatical' }, \@changed );
 is( $r7->normal_form, 'QUUX', "normal form on grammatical relationship unchanged" );
+is( scalar @changed, 0, "No readings were marked as changed" );
 
 =end testing
 
@@ -319,25 +346,30 @@ is( $r7->normal_form, 'QUUX', "normal form on grammatical relationship unchanged
 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 );
+	my @altered_readings;
+	if( $lemma ) {
+		@altered_readings = $lemma->push_normal_form();
 	}
+	return @altered_readings;
 }
 
 sub push_normal_form {
 	my $self = shift;
 	# Set the normal form on all orthographically related readings to match
 	# the normal form on this one.
+	my @altered_readings;
 	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 );
+		if( $r->normal_form ne $self->normal_form ) {
+			$r->normal_form( $self->normal_form );
+			push( @altered_readings, $r );
+		}
 	}
+	return @altered_readings;
 }
 
 1;
diff --git a/morphology/t/text_tradition_morphology.t b/morphology/t/text_tradition_morphology.t
index db7483f..9ba0f76 100644
--- a/morphology/t/text_tradition_morphology.t
+++ b/morphology/t/text_tradition_morphology.t
@@ -21,14 +21,18 @@ 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');
+my @changed = $r1->normal_form('FOO');
+is_deeply( \@changed, [ $r1 ], "Normal form change produced no side effect" );
 $r2->normal_form('BAR');
 
-$r1->make_lemma( 1 );
+@changed = $r1->make_lemma( 1 );
+is_deeply( \@changed, [ $r1 ], "Lemma flag changed only the concerned reading" );
 is( $r1->normal_form, 'FOO', "nothing changed yet" );
 is( $r2->normal_form, 'BAR', "nothing changed yet" );
 
-$c->add_relationship( $r1, $r2, { type => 'spelling' } );
+@changed = ();
+$c->add_relationship( $r1, $r2, { type => 'spelling' }, \@changed );
+is_deeply( \@changed, [ $r2 ], "We were informed that reading 2 changed" );
 is( $r2->normal_form, 'FOO', "Normal form followed lemma" );
 
 # Now try setting relationships and then lemmatizing
@@ -39,18 +43,32 @@ $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 } );
+@changed = ();
+$c->add_relationship( $r3, $r4, { type => 'orthographic', propagate => 1 }, \@changed );
+$c->add_relationship( $r3, $r5, { type => 'orthographic', propagate => 1 }, \@changed );
+is( scalar( @changed ), 0, "No reading side effects yet" );
 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 );
+@changed = $r3->make_lemma( 1 );
+my %present;
+map { $present{$_->id} = 1 } @changed;
+ok( $present{$r3->id}, "Informed of change to reading 3" );
+ok( $present{$r4->id}, "Informed of change to reading 4" );
+ok( $present{$r5->id}, "Informed of change to reading 5" );
+is( scalar keys %present, 3, "Not informed of further changes" );
 is( $r4->normal_form, 'YAN', "normal form propagated" );
 is( $r5->normal_form, 'YAN', "normal form propagated" );
 
 # Now try modifying the normal form and making sure the change is propagated
-$r3->normal_form( 'JIGGIT' );
+@changed = $r3->normal_form( 'JIGGIT' );
+%present = ();
+map { $present{$_->id} = 1 } @changed;
+ok( $present{$r3->id}, "Informed of change to reading 3" );
+ok( $present{$r4->id}, "Informed of change to reading 4" );
+ok( $present{$r5->id}, "Informed of change to reading 5" );
+is( scalar keys %present, 3, "Not informed of further changes" );
 is( $r4->normal_form, 'JIGGIT', "new normal form propagated" );
 is( $r5->normal_form, 'JIGGIT', "new normal form propagated" );
 
@@ -67,8 +85,10 @@ $r6->normal_form('BAZ');
 $r7->normal_form('QUUX');
 $r6->make_lemma( 1 );
 
-$c->add_relationship( $r6, $r7, { type => 'grammatical' } );
+@changed = ();
+$c->add_relationship( $r6, $r7, { type => 'grammatical' }, \@changed );
 is( $r7->normal_form, 'QUUX', "normal form on grammatical relationship unchanged" );
+is( scalar @changed, 0, "No readings were marked as changed" );
 }