From: Tara L Andrews <tla@mit.edu>
Date: Tue, 17 May 2011 21:47:40 +0000 (+0200)
Subject: tests passing with new library, yay
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=de51424ae471a4d72edef3cb48b0fb7044c54333;p=scpubgit%2Fstemmatology.git

tests passing with new library, yay
---

diff --git a/lib/Text/Tradition.pm b/lib/Text/Tradition.pm
index 36c74ee..6cce95f 100644
--- a/lib/Text/Tradition.pm
+++ b/lib/Text/Tradition.pm
@@ -24,7 +24,6 @@ has 'witnesses' => (
 
 sub BUILD {
     my( $self, $init_args ) = @_;
-    print STDERR "Calling tradition build\n";
 
     if( exists $init_args->{'witnesses'} ) {
 	# We got passed an uncollated list of witnesses.  Make a
@@ -87,6 +86,17 @@ sub BUILD {
     }
 }
 
+sub witness {
+    my( $self, $sigil ) = @_;
+    my $requested_wit;
+    foreach my $wit ( @{$self->witnesses} ) {
+	$requested_wit = $wit if $wit->sigil eq $sigil;
+    }
+    warn "No such witness $sigil" unless $requested_wit;
+    return $requested_wit;
+}
+	
+
 sub add_witness {
     my $self = shift;
     my $new_wit = Text::Tradition::Witness->new( @_ );
diff --git a/lib/Text/Tradition/Collation.pm b/lib/Text/Tradition/Collation.pm
index 063d413..7a75c18 100644
--- a/lib/Text/Tradition/Collation.pm
+++ b/lib/Text/Tradition/Collation.pm
@@ -86,7 +86,7 @@ sub BUILD {
     $self->graph->set_attribute( 'node', 'shape', $shape );
 }
 
-# Wrappers around some methods
+# Wrappes around merge_nodes
 
 sub merge_readings {
     my $self = shift;
@@ -232,6 +232,10 @@ sub as_graphml {
 
 =back
 
+=head2 Navigation methods
+
+=over
+
 =item B<start>
 
 my $beginning = $collation->start();
@@ -313,6 +317,8 @@ sub _is_within {
     return $ret;
 }
 
+
+## INITIALIZATION METHODS - for use by parsers
 # Walk the paths for each witness in the graph, and return the nodes
 # that the graph has in common.
 
@@ -356,7 +362,7 @@ sub walk_witness_paths {
 
     # Mark all the nodes as either common or not.
     foreach my $cn ( @common_readings ) {
-	print STDERR "Setting " . $cn->name . " as common node\n";
+	print STDERR "Setting " . $cn->name . " / " . $cn->label . " as common node\n";
 	$cn->make_common;
     }
     foreach my $n ( $self->readings() ) {
@@ -369,7 +375,7 @@ sub walk_witness_paths {
 sub common_readings {
     my $self = shift;
     my @common = grep { $_->is_common } $self->readings();
-    return @common;
+    return sort { _cmp_position( $a->position, $b->position ) } @common;
 }
 
 # Calculate the relative positions of nodes in the graph, if they
@@ -382,7 +388,6 @@ sub calculate_positions {
     # is a hash per witness, whose key is the word node and whose
     # value is its position in the text.  Common nodes are always N,1
     # so have identical positions in each text.
-    $DB::single = 1;
 
     my $node_pos = {};
     foreach my $wit ( @{$self->tradition->witnesses} ) {
@@ -432,20 +437,28 @@ sub calculate_positions {
 
 sub _cmp_position {
     my( $a, $b ) = @_;
-    my @pos_a = split(/,/, $a );
-    my @pos_b = split(/,/, $b );
-
-    my $big_cmp = $pos_a[0] <=> $pos_b[0];
-    return $big_cmp if $big_cmp;
-    # else 
-    return $pos_a[1] <=> $pos_b[1];
+    if ( $a && $b ) {
+	my @pos_a = split(/,/, $a );
+	my @pos_b = split(/,/, $b );
+
+	my $big_cmp = $pos_a[0] <=> $pos_b[0];
+	return $big_cmp if $big_cmp;
+	# else 
+	return $pos_a[1] <=> $pos_b[1];
+    } elsif ( $b ) { # a is undefined
+	return -1;
+    } elsif ( $a ) { # b is undefined
+	return 1;
+    }
+    return 0; # they are both undefined
 }
 
 sub all_positions {
     my $self = shift;
     my %positions = ();
     map { $positions{$_->position} = 1 } $self->readings;
-    return keys( %positions );
+    my @answer = sort { _cmp_position( $a, $b ) } keys( %positions );
+    return @answer;
 }
 
 sub readings_at_position {
@@ -502,8 +515,7 @@ sub lemma_readings {
     # toggled off.
     my $positions_off = {};
     map { $positions_off->{ $_->position } = $_->name } @toggled_off_nodes;
- 
-    
+
     # Now for each position, we have to see if a node is on, and we
     # have to see if a node has been turned off.
     my @answer;
@@ -531,15 +543,80 @@ sub lemma_readings {
 	    # Push the state that is there. Arbitrarily use the first node
 	    # at that position.
 	    my @pos_nodes = $self->readings_at_position( $pos );
-	    push( @answer, [ $pos_nodes[0], $self->lemmata->{$pos} ] );
+	    push( @answer, [ $pos_nodes[0]->name, $self->lemmata->{$pos} ] );
 	}
     }
     
     return @answer;
 }
 
+=item B<toggle_reading>
+
+my @readings_delemmatized = $graph->toggle_reading( $reading_name );
+
+Takes a reading node name, and either lemmatizes or de-lemmatizes
+it. Returns a list of all readings that are de-lemmatized as a result
+of the toggle.
+
+=cut
+
+sub toggle_reading {
+    my( $self, $rname ) = @_;
+    
+    return unless $rname;
+    my $reading = $self->reading( $rname );
+    if( !$reading || $reading->is_common() ) {
+	# Do nothing, it's a common node.
+	return;
+    } 
+    
+    my $pos = $reading->position;
+    my $old_state = $self->lemmata->{$pos};
+    my @readings_off;
+    if( $old_state && $old_state eq $rname ) {
+	# Turn off the node. We turn on no others by default.
+	push( @readings_off, $reading );
+    } else {
+	# Turn on the node.
+	$self->lemmata->{$pos} = $rname;
+	# Any other 'on' readings in the same position should be off.
+	push( @readings_off, $self->same_position_as( $reading ) );
+	# Any node that is an identical transposed one should be off.
+	push( @readings_off, $reading->identical_readings );
+    }
+    @readings_off = unique_list( @readings_off );
+
+    # Turn off the readings that need to be turned off.
+    my @readings_delemmatized;
+    foreach my $n ( @readings_off ) {
+	my $state = $self->lemmata->{$n->position};
+	if( $state && $state eq $n->name ) { 
+	    # this reading is still on, so turn it off
+	    push( @readings_delemmatized, $n );
+	    my $new_state = undef;
+	    if( $n eq $reading ) {
+		# This is the reading that was clicked, so if there are no
+		# other readings there, turn off the position.  In all other
+		# cases, restore the ellipsis.
+		my @other_n = $self->same_position_as( $n );
+		$new_state = 0 unless @other_n;
+	    }
+	    $self->lemmata->{$n->position} = $new_state;
+	} elsif( $old_state && $old_state eq $n->name ) { 
+	    # another reading has already been turned on here
+	    push( @readings_delemmatized, $n );
+	} # else some other reading was on anyway, so pass.
+    }
+    return @readings_delemmatized;
+}
+
+sub same_position_as {
+    my( $self, $reading ) = @_;
+    my $pos = $reading->position;
+    my @same = grep { $_ ne $reading } $self->readings_at_position( $reading->position );
+    return @same;
+}
 
- 
 # Return the string that joins together a list of witnesses for
 # display on a single path.
 sub path_label {
@@ -548,10 +625,18 @@ sub path_label {
 }
 
 sub witnesses_of_label {
-    my $self = shift;
+    my( $self, $label ) = @_;
     my $regex = $self->wit_list_separator;
-    return split( /^\Q$regex\E$/, @_ );
+    my @answer = split( /\Q$regex\E/, $label );
+    return @answer;
 }    
 
+sub unique_list {
+    my( @list ) = @_;
+    my %h;
+    map { $h{$_->name} = $_ } @list;
+    return values( %h );
+}
+
 no Moose;
 __PACKAGE__->meta->make_immutable;
diff --git a/lib/Text/Tradition/Collation/Reading.pm b/lib/Text/Tradition/Collation/Reading.pm
index e3d6d6d..971a26b 100644
--- a/lib/Text/Tradition/Collation/Reading.pm
+++ b/lib/Text/Tradition/Collation/Reading.pm
@@ -85,6 +85,12 @@ sub set_identical {
     $self->same_as( $enlarged_pool );
 }   
 
+sub identical_readings {
+    my $self = shift;
+    my @same = grep { $_ ne $self } @{$self->same_as};
+    return @same;
+}
+
 sub _merge_array_pool {
     my( $pool, $main_pool ) = @_;
     my %poolhash;
diff --git a/lib/Text/Tradition/Witness.pm b/lib/Text/Tradition/Witness.pm
index 8480e71..cb461c5 100644
--- a/lib/Text/Tradition/Witness.pm
+++ b/lib/Text/Tradition/Witness.pm
@@ -14,6 +14,7 @@ has 'sigil' => (
 has 'text' => (
     is => 'rw',
     isa => 'ArrayRef[Str]',
+    predicate => 'has_text',
     );
 
 # Source.  This is where we read in the witness, if not from a
@@ -27,6 +28,7 @@ has 'source' => (
 has 'path' => (
     is => 'rw',
     isa => 'ArrayRef[Text::Tradition::Collation::Reading]',
+    predicate => 'has_path',
     );	       
 
 sub BUILD {
@@ -46,5 +48,19 @@ sub BUILD {
     }
 }
 
+# If the text is not present, and the path is, and this is a 'get'
+# request, generate text from path.
+around text => sub {
+    my $orig = shift;
+    my $self = shift;
+
+    if( $self->has_path && !$self->has_text && !@_ ) {
+	my @words = map { $_->label } @{$self->path};
+	$self->$orig( \@words );
+    }
+    
+    $self->$orig( @_ );
+};
+
 no Moose;
 __PACKAGE__->meta->make_immutable;
diff --git a/t/graph.t b/t/graph.t
index 08566c1..9209e8d 100644
--- a/t/graph.t
+++ b/t/graph.t
@@ -51,7 +51,8 @@ sub compare_active {
 	    "Element has same toggle value" );
 	if( defined $active_nodes[$_]->[1] ) {
 	    is( $active_nodes[$_]->[0], $expected_nodes[$_]->[0], 
-		"Active or toggled element has same node name" );
+		"Active or toggled element has same node name " 
+		. $active_nodes[$_]->[0] );
 	}
     }
 }
@@ -68,15 +69,13 @@ sub make_text {
     return join( ' ', @words );
 }
 
-__END__
-
 # Test the manuscript paths
 my $wit_a = '# when april with his showers sweet with fruit the drought of march has pierced unto the root #';
 my $wit_b = '# when showers sweet with april fruit the march of drought has pierced to the root #';
 my $wit_c = '# when showers sweet with april fruit the drought of march has pierced the rood #';
-is( $collation->text_for_witness( "A" ), $wit_a, "Correct path for witness A" );
-is( $collation->text_for_witness( "B" ), $wit_b, "Correct path for witness B" );
-is( $collation->text_for_witness( "C" ), $wit_c, "Correct path for witness C" );
+is( join( ' ', @{$tradition->witness( "A" )->text} ), $wit_a, "Correct path for witness A" );
+is( join( ' ', @{$tradition->witness( "B" )->text} ), $wit_b, "Correct path for witness B" );
+is( join( ' ', @{$tradition->witness( "C" )->text} ), $wit_c, "Correct path for witness C" );
 
 # Test the transposition identifiers
 my $transposition_pools = [ [ 'n2', 'n11' ], [ 'n14', 'n18' ], 
@@ -88,89 +87,92 @@ my $transposed_nodes = { 'n2' => $transposition_pools->[0],
 			 'n17' => $transposition_pools->[2],
 			 'n18' => $transposition_pools->[1],
 };
-foreach my $n ( $collation->readings() ) {
-    $transposed_nodes->{ $n->name() } = [ $n->name() ]
-	unless exists $transposed_nodes->{ $n->name() };
+
+my $real_transposed_nodes = {};
+foreach my $r ( $collation->readings ) {
+    my @same = map { $_->name } @{$r->same_as};
+    $real_transposed_nodes->{ $r->name } = \@same if @same > 1;
 }
-is_deeply( $collation->{'identical_nodes'}, $transposed_nodes, "Found the right transpositions" );
+    
+is_deeply( $real_transposed_nodes, $transposed_nodes, "Found the right transpositions" );
 
 # Test turning on a node
-my @off = $collation->toggle_node( 'n25' );
+my @off = $collation->toggle_reading( 'n25' );
 $expected_nodes[ 18 ] = [ "n25", 1 ];
-@active_nodes = $collation->active_nodes( @off );
+@active_nodes = $collation->lemma_readings( @off );
 subtest 'Turned on node for new location' => \&compare_active;
 $string = '# when ... ... ... showers sweet with ... fruit the ... of ... has pierced ... the rood #';
 is( make_text( @active_nodes ), $string, "Got the right text" );
  
 # Test the toggling effects of same-column
-@off = $collation->toggle_node( 'n26' );
+@off = $collation->toggle_reading( 'n26' );
 splice( @expected_nodes, 18, 1, ( [ "n25", 0 ], [ "n26", 1 ] ) );
-@active_nodes = $collation->active_nodes( @off );
+@active_nodes = $collation->lemma_readings( @off );
 subtest 'Turned on other node in that location' => \&compare_active;
 $string = '# when ... ... ... showers sweet with ... fruit the ... of ... has pierced ... the root #';
 is( make_text( @active_nodes ), $string, "Got the right text" );
 
 # Test the toggling effects of transposition
 
-@off = $collation->toggle_node( 'n14' );
+@off = $collation->toggle_reading( 'n14' );
 # Add the turned on node
 $expected_nodes[ 11 ] = [ "n14", 1 ];
 # Remove the 'off' for the previous node
 splice( @expected_nodes, 18, 1 );
-@active_nodes = $collation->active_nodes( @off );
+@active_nodes = $collation->lemma_readings( @off );
 subtest 'Turned on transposition node' => \&compare_active;
 $string = '# when ... ... ... showers sweet with ... fruit the drought of ... has pierced ... the root #';
 is( make_text( @active_nodes ), $string, "Got the right text" );
 
-@off = $collation->toggle_node( 'n18' );
+@off = $collation->toggle_reading( 'n18' );
 # Toggle on the new node
 $expected_nodes[ 13 ] = [ "n18", 1 ];
 # Toggle off the transposed node
 $expected_nodes[ 11 ] = [ "n14", undef ];
-@active_nodes = $collation->active_nodes( @off );
+@active_nodes = $collation->lemma_readings( @off );
 subtest 'Turned on that node\'s partner' => \&compare_active;
 $string = '# when ... ... ... showers sweet with ... fruit the ... of drought has pierced ... the root #';
 is( make_text( @active_nodes ), $string, "Got the right text" );
 
-@off = $collation->toggle_node( 'n14' );
+@off = $collation->toggle_reading( 'n14' );
 # Toggle on the new node
 $expected_nodes[ 11 ] = [ "n14", 1 ];
 # Toggle off the transposed node
 $expected_nodes[ 13 ] = [ "n18", undef ];
-@active_nodes = $collation->active_nodes( @off );
+@active_nodes = $collation->lemma_readings( @off );
 subtest 'Turned on the original node' => \&compare_active;
 $string = '# when ... ... ... showers sweet with ... fruit the drought of ... has pierced ... the root #';
 is( make_text( @active_nodes ), $string, "Got the right text" );
 
-@off = $collation->toggle_node( 'n15' );
+@off = $collation->toggle_reading( 'n15' );
 # Toggle on the new node, and off with the old
 splice( @expected_nodes, 11, 1, [ "n14", 0 ], [ "n15", 1 ] );
-@active_nodes = $collation->active_nodes( @off );
+@active_nodes = $collation->lemma_readings( @off );
 subtest 'Turned on the colocated node' => \&compare_active;
 $string = '# when ... ... ... showers sweet with ... fruit the march of ... has pierced ... the root #';
 is( make_text( @active_nodes ), $string, "Got the right text" );
 
-@off = $collation->toggle_node( 'n3' );
+@off = $collation->toggle_reading( 'n3' );
 # Toggle on the new node
 splice( @expected_nodes, 3, 1, [ "n3", 1 ] );
 # Remove the old toggle-off
 splice( @expected_nodes, 11, 1 );
-@active_nodes = $collation->active_nodes( @off );
+@active_nodes = $collation->lemma_readings( @off );
 subtest 'Turned on a singleton node' => \&compare_active;
 $string = '# when ... with ... showers sweet with ... fruit the march of ... has pierced ... the root #';
 is( make_text( @active_nodes ), $string, "Got the right text" );
 
-@off = $collation->toggle_node( 'n3' );
+@off = $collation->toggle_reading( 'n3' );
 # Toggle off this node
 splice( @expected_nodes, 3, 1, [ "n3", 0 ] );
-@active_nodes = $collation->active_nodes( @off );
+@active_nodes = $collation->lemma_readings( @off );
 subtest 'Turned off a singleton node' => \&compare_active;
 $string = '# when ... ... showers sweet with ... fruit the march of ... has pierced ... the root #';
 is( make_text( @active_nodes ), $string, "Got the right text" );
 
-@off = $collation->toggle_node( 'n21' );
+@off = $collation->toggle_reading( 'n21' );
 splice( @expected_nodes, 16, 1, [ "n21", 1 ] );
-@active_nodes = $collation->active_nodes( @off );
+@active_nodes = $collation->lemma_readings( @off );
 subtest 'Turned on a new node after singleton switchoff' => \&compare_active;
 $string = '# when ... ... showers sweet with ... fruit the march of ... has pierced unto the root #';
 is( make_text( @active_nodes ), $string, "Got the right text" );