From: Tara L Andrews <tla@mit.edu>
Date: Tue, 19 Apr 2011 18:45:21 +0000 (+0200)
Subject: Make transposition data go into pool arrays
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c2d1687521cae0aed0f6e221c9f137193b4705e1;p=scpubgit%2Fstemmatology.git

Make transposition data go into pool arrays
---

diff --git a/lib/Traditions/Graph.pm b/lib/Traditions/Graph.pm
index 558de2f..2c9efe8 100644
--- a/lib/Traditions/Graph.pm
+++ b/lib/Traditions/Graph.pm
@@ -119,9 +119,13 @@ sub edge {
     return $self->{'graph'}->edge( @_ );
 }
 
+# Not only adds the node, but also initializes internal data
+# about the node.
 sub add_node {
     my $self = shift;
-    return $self->{'graph'}->add_node( @_ );
+    my $node = $self->{'graph'}->add_node( @_ );
+    $self->{'identical_nodes'}->{ $node->name() } = [ $node->name() ];
+    return $node;
 }
 
 sub add_edge {
@@ -131,6 +135,26 @@ sub add_edge {
 
 sub del_node {
     my $self = shift;
+    my $node = $_[0];
+
+    # Delete this node out of any relevant transposition pool.
+    if( ref $node eq 'Graph::Easy::Node' ) {
+	$node = $node->name();
+    }
+    my @ident = $self->identical_nodes( $node );
+    if( @ident ) {
+	# Get the pool.
+	my $pool = $self->{'identical_nodes'}->{ $ident[0] };
+	foreach my $i ( 0 .. scalar(@$pool)-1 ) {
+	    if( $pool->[$i] eq $node ) {
+		splice( @$pool, $i, 1 );
+		last;
+	    }
+	}
+    }
+    delete $self->{'identical_nodes'}->{ $node };
+
+    # Now delete the node.
     return $self->{'graph'}->del_node( @_ );
 }
 
@@ -161,14 +185,37 @@ sub start {
     my $self = shift;
     my( $new_start ) = @_;
     if( $new_start ) {
+	# Fix the node transposition data
+	delete $self->{'identical_nodes'}->{ $new_start->name() };
+	$self->{'identical_nodes'}->{'#START#'} = [ '#START#' ];
 	$self->{'graph'}->rename_node( $new_start, '#START#' );
     }
     return $self->{'graph'}->node('#START#');
 }
 
-sub set_identical_nodes {
-    my( $self, $node_hash ) = @_;
-    $self->{'identical_nodes'} = $node_hash;
+# Record that nodes A and B are really the same (transposed) node.
+# We do this by maintaining some pools of transposed nodes, and
+# we have a lookup hash so that each member of that 
+sub set_identical_node {
+    my( $self, $node, $same_node ) = @_;
+    my $pool = $self->{'identical_nodes'}->{ $node };
+    my $same_pool = $self->{'identical_nodes'}->{ $same_node };
+    my %poolhash;
+    foreach ( @$pool ) {
+	$poolhash{$_} = 1;
+    }
+    foreach( @$same_pool ) {
+	push( @$pool, $_ ) unless $poolhash{$_};
+    }
+
+    $self->{'identical_nodes'}->{ $same_node } = $pool;
+}
+
+sub identical_nodes {
+    my( $self, $node ) = @_;
+    my @others = grep { $_ !~ /^$node$/ } 
+        @{$self->{'identical_nodes'}->{ $node }};
+    return @others;
 }
 
 sub next_word {
@@ -420,13 +467,6 @@ sub colocated_nodes {
     return $self->{'positions'}->colocated_nodes( @_ );
 }
 
-sub identical_nodes {
-    my( $self, $node ) = @_;
-    return undef unless exists $self->{'identical_nodes'} &&
-	exists $self->{'identical_nodes'}->{$node};
-    return $self->{'identical_nodes'}->{$node};
-}
-
 sub text_of_node {
     my( $self, $node_id ) = @_;
     # This is the label of the given node.
diff --git a/lib/Traditions/Parser/GraphML.pm b/lib/Traditions/Parser/GraphML.pm
index 3656eb9..4662296 100644
--- a/lib/Traditions/Parser/GraphML.pm
+++ b/lib/Traditions/Parser/GraphML.pm
@@ -77,16 +77,15 @@ sub parse {
     my %node_id = reverse %node_name;
 
     ## Record the nodes that are marked as transposed.
-    my $id_xpath = '//g:node[g:data[@key="' . $nodedata{'identity'} . '"]]';
-    my $transposed_nodes = $xpc->find( $id_xpath );
-    my $identical_nodes;
-    foreach my $tn ( @$transposed_nodes ) {
-        $identical_nodes->{ $node_name{ $tn->getAttribute('id') }} = 
-            $node_name{ $xpc->findvalue( './g:data[@key="' 
-					 . $nodedata{'identity'} 
-					 . '"]/text()', $tn ) };
+    my $tr_xpath = '//g:node[g:data[@key="' . $nodedata{'identity'} . '"]]';
+    my $transposition_nodes = $xpc->find( $tr_xpath );
+    foreach my $tn ( @$transposition_nodes ) {
+	my $id_xpath = sprintf( './g:data[@key="%s"]/text()', 
+				$nodedata{'identity'} );
+	$graph->set_identical_node( $node_name{ $tn->getAttribute( 'id' ) },
+				    $node_name{ $xpc->findvalue( $id_xpath, 
+								 $tn ) } );
     }
-    $graph->set_identical_nodes( $identical_nodes );
 
 
     # Find the beginning and end nodes of the graph.  The beginning node
diff --git a/t/graph.t b/t/graph.t
index a60353d..91f9311 100644
--- a/t/graph.t
+++ b/t/graph.t
@@ -76,13 +76,18 @@ is( $graph->text_for_witness( "B" ), $wit_b, "Correct path for witness B" );
 is( $graph->text_for_witness( "C" ), $wit_c, "Correct path for witness C" );
 
 # Test the transposition identifiers
-my $transposed_nodes = { 2 => 9,
-			 9 => 2,
-			 14 => 18,
-			 15 => 17,
-			 17 => 15,
-			 18 => 14
+my $transposition_pools = [ [ 2, 9 ], [ 14, 18 ], [ 15, 17 ] ];
+my $transposed_nodes = { 2 => $transposition_pools->[0],
+			 9 => $transposition_pools->[0],
+			 14 => $transposition_pools->[1],
+			 15 => $transposition_pools->[2],
+			 17 => $transposition_pools->[2],
+			 18 => $transposition_pools->[1],
 };
+foreach my $n ( $graph->nodes() ) {
+    $transposed_nodes->{ $n->name() } = [ $n->name() ]
+	unless exists $transposed_nodes->{ $n->name() };
+}
 is_deeply( $graph->{'identical_nodes'}, $transposed_nodes, "Found the right transpositions" );
 
 # Test turning on a node