X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=scpubgit%2Fstemmatology.git;a=blobdiff_plain;f=lib%2FText%2FTradition%2FStemma.pm;fp=lib%2FText%2FTradition%2FStemma.pm;h=864ed439b8ce86f096083a03edfc99dcf6f50d77;hp=661c2058a1ee304f4f4729ef413d90de622cd1ba;hb=5c44c598044623ef4cda3986b43c91d60636cd84;hpb=c30a4fdbd9929f2a74ea5801f0d7ad2518ddb9f1

diff --git a/lib/Text/Tradition/Stemma.pm b/lib/Text/Tradition/Stemma.pm
index 661c205..864ed43 100644
--- a/lib/Text/Tradition/Stemma.pm
+++ b/lib/Text/Tradition/Stemma.pm
@@ -158,7 +158,9 @@ sub as_dot {
 	## See if we are including any a.c. witnesses in this graph.
 	my $graph = $self->graph;
 	if( exists $opts->{'layerwits'} ) {
-		$graph = $self->extend_graph( $opts->{'layerwits'} );
+		my $extant = {};
+		map { $extant->{$_} = 1 } $self->witnesses;
+		$graph = $self->situation_graph( $extant, $opts->{'layerwits'} );
 	}
 
     # Get default and specified options
@@ -212,30 +214,39 @@ sub as_dot {
 
 =head2 editable( $opts )
 
+=head2 editable_graph( $graph, $opts )
+
 Returns a version of the graph rendered in our definition format.  The
 output separates statements with a newline; set $opts->{'linesep'} to the 
 empty string or to a space if the result is to be sent via JSON.
 
-Any layer witnesses to be included should be passed via $opts->{'layerwits'}.
+If a situational version of the stemma is required, the arguments for 
+situation_graph should be passed via $opts->{'extant'} and $opts->{'layerwits'}.
 
 =cut
 
 sub editable {
-	my( $self, $opts ) = @_;
-	
-	## See if we are including any a.c. witnesses in this graph.
+	my( $self, $opts ) = @_;	
 	my $graph = $self->graph;
-	if( exists $opts->{'layerwits'} ) {
-		$graph = $self->extend_graph( $opts->{'layerwits'} );
+	## See if we need an editable version of a situational graph.
+	if( exists $opts->{'layerwits'} || exists $opts->{'extant'} ) {
+		my $extant = delete $opts->{'extant'} || {};
+		my $layerwits = delete $opts->{'layerwits'} || [];
+		$graph = $self->situation_graph( $extant, $layerwits );
 	}
+	return editable_graph( $graph, $opts );
+}
+
+sub editable_graph {
+	my( $graph, $opts ) = @_;
 
 	# Create the graph
 	my $join = ( $opts && exists $opts->{'linesep'} ) ? $opts->{'linesep'} : "\n";
 	my @dotlines;
 	push( @dotlines, 'digraph stemma {' );
 	my @real; # A cheap sort
-    foreach my $n ( sort $self->graph->vertices ) {
-    	my $c = $self->graph->get_vertex_attribute( $n, 'class' );
+    foreach my $n ( sort $graph->vertices ) {
+    	my $c = $graph->get_vertex_attribute( $n, 'class' );
     	$c = 'extant' unless $c;
     	if( $c eq 'extant' ) {
     		push( @real, $n );
@@ -247,7 +258,7 @@ sub editable {
 	foreach my $n ( @real ) {
 		push( @dotlines, _make_dotline( $n, 'class' => 'extant' ) );
 	}
-	foreach my $e ( sort _by_vertex $self->graph->edges ) {
+	foreach my $e ( sort _by_vertex $graph->edges ) {
 		my( $from, $to ) = map { _dotquote( $_ ) } @$e;
 		push( @dotlines, "  $from -> $to;" );
 	}
@@ -277,29 +288,40 @@ sub _by_vertex {
 	return $a->[0].$a->[1] cmp $b->[0].$b->[1];
 }
 
-=head2 extend_graph( $layered_witnesses )
+=head2 situation_graph( $extant, $layered )
 
-Returns a graph which is the original stemma with witness layers added for the
-list in @$layered_witnesses.  A layered (a.c.) witness is added as a parent
-of its main version, and additionally shares all other parents and children with
-that version.
+Returns a graph which is the original stemma with all witnesses not in the
+%$extant hash marked as hypothetical, and witness layers added to the graph
+according to the list in @$layered.  A layered (a.c.) witness is added as a
+parent of its main version, and additionally shares all other parents and
+children with that version.
 
 =cut
 
-sub extend_graph {
-	my( $self, $layerwits ) = @_;
+sub situation_graph {
+	my( $self, $extant, $layerwits ) = @_;
+	
+	my $graph = $self->graph->copy;
+	foreach my $vertex ( $graph->vertices ) {
+		# Set as extant any vertex that is extant in the stemma AND 
+		# exists in the $extant hash.
+		my $class = 'hypothetical';
+		$class = 'extant' if exists $extant->{$vertex} && $extant->{$vertex} &&
+			$self->graph->get_vertex_attribute( $vertex, 'class' ) ne 'hypothetical';
+		$graph->set_vertex_attribute( $vertex, 'class', $class );
+	}
+	
 	# For each 'layered' witness in the layerwits array, add it to the graph
 	# as an ancestor of the 'main' witness, and otherwise with the same parent/
 	# child links as its main analogue.
 	# TOOD Handle case where B is copied from A but corrected from C
-	
-	# Iterate through, adding a.c. witnesses
-	my $actag = $self->collation->ac_label;
-	my $graph = $self->graph->deep_copy;
+	my $aclabel = $self->collation->ac_label;
 	foreach my $lw ( @$layerwits ) {
 		# Add the layered witness and set it with the same attributes as
 		# its 'main' analogue
-		my $lwac = $lw . $self->collation->ac_label;
+		throw( "Cannot add a layer to a hypothetical witness $lw" )
+			unless $graph->get_vertex_attribute( $lw, 'class' ) eq 'extant';
+		my $lwac = $lw . $aclabel;
 		$graph->add_vertex( $lwac );
 		$graph->set_vertex_attributes( $lwac,
 			$graph->get_vertex_attributes( $lw ) );
@@ -313,14 +335,14 @@ sub extend_graph {
 		foreach my $v ( $graph->predecessors( $lw ) ) {
 			next if $v eq $lwac; # Don't add a loop
 			$graph->add_edge( $v, $lwac );
-			$graph->add_edge( $v.$self->collation->ac_label, $lwac )
-				if $graph->has_vertex( $v.$self->collation->ac_label );
+			$graph->add_edge( $v.$aclabel, $lwac )
+				if $graph->has_vertex( $v.$aclabel );
 		}
 		foreach my $v ( $graph->successors( $lw ) ) {
 			next if $v eq $lwac; # but this shouldn't occur
 			$graph->add_edge( $lwac, $v );
-			$graph->add_edge( $lwac, $v.$self->collation->ac_label )
-				if $graph->has_vertex( $v.$self->collation->ac_label );
+			$graph->add_edge( $lwac, $v.$aclabel )
+				if $graph->has_vertex( $v.$aclabel );
 		}
 	}
 	return $graph;