X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FText%2FTradition%2FCollation.pm;h=a77f74f519bd6b7d7e7c2ee78e9a4bd129c5ed10;hb=7cd9f181280b397e3ef6c95845270d48368fc11f;hp=e854128a525a180285151d456ea54aaee6f7bf67;hpb=414cc046fb54e81ac48d607b5e05c11623934533;p=scpubgit%2Fstemmatology.git

diff --git a/lib/Text/Tradition/Collation.pm b/lib/Text/Tradition/Collation.pm
index e854128..a77f74f 100644
--- a/lib/Text/Tradition/Collation.pm
+++ b/lib/Text/Tradition/Collation.pm
@@ -9,6 +9,7 @@ use Text::CSV;
 use Text::Tradition::Collation::Reading;
 use Text::Tradition::Collation::RelationshipStore;
 use Text::Tradition::Error;
+use XML::Easy::Syntax qw( $xml10_namestartchar_rx $xml10_namechar_rx );
 use XML::LibXML;
 use XML::LibXML::XPathContext;
 use Moose;
@@ -30,6 +31,8 @@ has 'relations' => (
 		related_readings => 'related_readings',
 		get_relationship => 'get_relationship',
 		del_relationship => 'del_relationship',
+		equivalence => 'equivalence',
+		equivalence_graph => 'equivalence_graph',
 	},
 	writer => '_set_relations',
 	);
@@ -281,6 +284,9 @@ sub add_reading {
 	my( $self, $reading ) = @_;
 	unless( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
 		my %args = %$reading;
+		if( $self->tradition->has_language && !exists $args{'language'} ) {
+			$args{'language'} = $self->tradition->language;
+		}
 		$reading = Text::Tradition::Collation::Reading->new( 
 			'collation' => $self,
 			%args );
@@ -428,10 +434,13 @@ sub add_path {
 
 	$self->_graphcalc_done(0);
 	# Connect the readings
-    $self->sequence->add_edge( $source, $target );
+	unless( $self->sequence->has_edge( $source, $target ) ) {
+	    $self->sequence->add_edge( $source, $target );
+	    $self->relations->add_equivalence_edge( $source, $target );
+	}
     # Note the witness in question
     $self->sequence->set_edge_attribute( $source, $target, $wit, 1 );
-};
+}
 
 sub del_path {
 	my $self = shift;
@@ -453,6 +462,7 @@ sub del_path {
 	}
 	unless( keys %{$self->sequence->get_edge_attributes( $source, $target )} ) {
 		$self->sequence->delete_edge( $source, $target );
+		$self->relations->delete_equivalence_edge( $source, $target );
 	}
 }
 
@@ -964,6 +974,9 @@ sub as_graphml {
 		next unless $save_types{$attr->type_constraint->name};
 		$reading_attributes{$attr->name} = $save_types{$attr->type_constraint->name};
 	}
+	# Extra custom key for the reading morphology
+	$reading_attributes{'lexemes'} = 'string';
+	
     my %node_data_keys;
     my $ndi = 0;
     foreach my $datum ( sort keys %reading_attributes ) {
@@ -1000,14 +1013,19 @@ sub as_graphml {
         $key->setAttribute( 'id', $edge_data_keys{$datum} );
     }
 
-    # Add the collation graph itself
+    # Add the collation graph itself. First, sanitize the name to a valid XML ID.
+    my $xmlidname = $self->tradition->name;
+    $xmlidname =~ s/(?!$xml10_namechar_rx)./_/g;
+    if( $xmlidname !~ /^$xml10_namestartchar_rx/ ) {
+    	$xmlidname = '_'.$xmlidname;
+    }
     my $sgraph = $root->addNewChild( $graphml_ns, 'graph' );
     $sgraph->setAttribute( 'edgedefault', 'directed' );
-    $sgraph->setAttribute( 'id', $self->tradition->name );
+    $sgraph->setAttribute( 'id', $xmlidname );
     $sgraph->setAttribute( 'parse.edgeids', 'canonical' );
-    $sgraph->setAttribute( 'parse.edges', scalar($self->paths) );
+    $sgraph->setAttribute( 'parse.edges', 0 ); # fill in later
     $sgraph->setAttribute( 'parse.nodeids', 'canonical' );
-    $sgraph->setAttribute( 'parse.nodes', scalar($self->readings) );
+    $sgraph->setAttribute( 'parse.nodes', 0 ); # fill in later
     $sgraph->setAttribute( 'parse.order', 'nodesfirst' );
     	    
     # Collation attribute data
@@ -1037,9 +1055,17 @@ sub as_graphml {
         $node_el->setAttribute( 'id', $node_xmlid );
         foreach my $d ( keys %reading_attributes ) {
         	my $nval = $n->$d;
-        	if( $rankoffset && $d eq 'rank' ) {
+        	# Custom serialization
+        	if( $d eq 'lexemes' ) {
+				# If nval is a true value, we have lexemes so we need to
+				# serialize them. Otherwise set nval to undef so that the
+				# key is excluded from this reading.
+        		$nval = $nval ? $n->_serialize_lexemes : undef;
+        	}
+        	if( $rankoffset && $d eq 'rank' && $n ne $self->start ) {
         		# Adjust the ranks within the subgraph.
-        		$nval = $n eq $self->end ? $end->rank + 1 : $nval - $rankoffset;
+        		$nval = $n eq $self->end ? $end->rank - $rankoffset + 1 
+        			: $nval - $rankoffset;
         	}
         	_add_graphml_data( $node_el, $node_data_keys{$d}, $nval )
         		if defined $nval;
@@ -1052,8 +1078,10 @@ sub as_graphml {
     	# We add an edge in the graphml for every witness in $e.
     	next unless( $use_readings{$e->[0]} || $use_readings{$e->[1]} );
     	my @edge_wits = sort $self->path_witnesses( $e );
-    	$e->[0] = $self->start unless $use_readings{$e->[0]};
-    	$e->[1] = $self->end unless $use_readings{$e->[1]};
+    	$e->[0] = $self->start->id unless $use_readings{$e->[0]};
+    	$e->[1] = $self->end->id unless $use_readings{$e->[1]};
+    	# Skip any path from start to end; that witness is not in the subgraph.
+    	next if ( $e->[0] eq $self->start->id && $e->[1] eq $self->end->id );
     	foreach my $wit ( @edge_wits ) {
 			my( $id, $from, $to ) = ( 'e'.$edge_ctr++,
 										$node_hash{ $e->[0] },
@@ -1078,10 +1106,14 @@ sub as_graphml {
 		}
 	}
 	
+	# Report the actual number of nodes and edges that went in
+	$sgraph->setAttribute( 'parse.edges', $edge_ctr );
+	$sgraph->setAttribute( 'parse.nodes', $node_ctr );
+		
 	# Add the relationship graph to the XML
 	map { delete $edge_data_keys{$_} } @path_attributes;
-	# $self->relations->_as_graphml( $graphml_ns, $root, \%node_hash, 
-	#	$node_data_keys{'id'}, \%edge_data_keys );
+	$self->relations->_as_graphml( $graphml_ns, $root, \%node_hash, 
+		$node_data_keys{'id'}, \%edge_data_keys );
 
     # Save and return the thing
     my $result = decode_utf8( $graphml->toString(1) );
@@ -1370,11 +1402,10 @@ sub path_text {
 	my $pathtext = '';
 	my $last;
 	foreach my $r ( @path ) {
-		if( $r->join_prior || !$last || $last->join_next ) {
-			$pathtext .= $r->text;
-		} else {
-			$pathtext .= ' ' . $r->text;
-		}
+		unless ( $r->join_prior || !$last || $last->join_next ) {
+			$pathtext .= ' ';
+		} 
+		$pathtext .= $r->text;
 		$last = $r;
 	}
 	return $pathtext;
@@ -1435,69 +1466,6 @@ sub make_witness_path {
     $wit->clear_uncorrected_path;
 }
 
-=head2 equivalence_graph( \%readingmap, $startrank, $endrank, @testvector )
-
-Returns an equivalence graph of the collation, in which all readings
-related via a 'colocated' relationship are transformed into a single
-vertex. Can be used to determine the validity of a new relationship.  The
-mapping between equivalence vertices and reading IDs will be stored in the
-hash whose reference is passed as readingmap. For a subset of the graph,
-pass in a start and/or an ending rank (this only works if L<calculate_ranks>
-has been called at least once.)
-
-It is also possible to pass in a test relationship in @testvector, and get
-the resulting equivalence graph before the relationship has been made.
-
-=cut
-
-sub equivalence_graph {
-	my( $self, $map, $start, $end, @newvector ) = @_;
-	$start = undef unless $self->end->has_rank;
-	$end = undef unless $self->end->has_rank;
-	my $eqgraph = Graph->new();
-    my $rel_ctr = 0;
-    # Add the nodes
-    foreach my $r ( $self->readings ) {
-    	unless( $r eq $self->start || $r eq $self->end ) {
-			next if $start && $r->rank < $start;
-			next if $end && $r->rank > $end;
-        }
-		next if exists $map->{$r->id};
-        my @rels = $self->related_readings( $r->id, 'colocated' );
-        push( @rels, $r->id );
-		# Make an equivalence vertex
-		my $rn = 'equivalence_' . $rel_ctr++;
-		$eqgraph->add_vertex( $rn );
-		# Note which readings belong to this vertex.
-		push( @rels, $r->id );
-		foreach( @rels ) {
-			$map->{$_} = $rn;
-		}
-    }
-
-    # Add the edges.
-    foreach my $p ( $self->paths ) {
-    	my $efrom = exists $map->{$p->[0]} ? $map->{$p->[0]} 
-    		: $map->{$self->start->id};
-    	my $eto = exists $map->{$p->[1]} ? $map->{$p->[1]} 
-    		: $map->{$self->end->id};
-    	$eqgraph->add_edge( $efrom, $eto );
-    }
-    
-    # Collapse the vertices in @newvector if applicable.
-    if( @newvector ) {
-		my( $eqs, $eqt ) = map { $map->{$_} } @newvector;
-		$DB::single = 1 unless $eqs && $eqt;
-		unless( $eqs eq $eqt ) {
-			# Combine the vertices.
-			map { $eqgraph->add_edge( $eqs, $_ ) } $eqgraph->successors( $eqt );
-			map { $eqgraph->add_edge( $_, $eqs ) } $eqgraph->predecessors( $eqt );
-			$eqgraph->delete_vertex( $eqt );
-		}
-	}
-    return $eqgraph;
-}
-
 =head2 calculate_ranks
 
 Calculate the reading ranks (that is, their aligned positions relative
@@ -1533,28 +1501,25 @@ sub calculate_ranks {
     # Save the existing ranks, in case we need to invalidate the cached SVG.
     my %existing_ranks;
     map { $existing_ranks{$_} = $_->rank } $self->readings;
-    # Walk a version of the graph where every node linked by a relationship 
-    # edge is fundamentally the same node, and do a topological ranking on
-    # the nodes in this graph.
-    my %rel_containers;
-    my $topo_graph = $self->equivalence_graph( \%rel_containers );
-    
-    # Now do the rankings, starting with the start node.
-    my $topo_start = $rel_containers{$self->start->id};
+
+    # Do the rankings based on the relationship equivalence graph, starting 
+    # with the start node.
+    my $topo_start = $self->equivalence( $self->start->id );
     my $node_ranks = { $topo_start => 0 };
     my @curr_origin = ( $topo_start );
     # A little iterative function.
     while( @curr_origin ) {
-        @curr_origin = _assign_rank( $topo_graph, $node_ranks, @curr_origin );
+        @curr_origin = _assign_rank( $self->equivalence_graph, 
+        	$node_ranks, @curr_origin );
     }
     # Transfer our rankings from the topological graph to the real one.
     foreach my $r ( $self->readings ) {
-        if( defined $node_ranks->{$rel_containers{$r->id}} ) {
-            $r->rank( $node_ranks->{$rel_containers{$r->id}} );
+        if( defined $node_ranks->{$self->equivalence( $r->id )} ) {
+            $r->rank( $node_ranks->{$self->equivalence( $r->id )} );
         } else {
         	# Die. Find the last rank we calculated.
-        	my @all_defined = sort { ( $node_ranks->{$rel_containers{$a->id}}||-1 )
-        			 <=> ( $node_ranks->{$rel_containers{$b->id}}||-1 ) }
+        	my @all_defined = sort { ( $node_ranks->{$self->equivalence( $a->id )}||-1 )
+        			 <=> ( $node_ranks->{$self->equivalence( $b->id )}||-1 ) }
         		$self->readings;
         	my $last = pop @all_defined;
             throw( "Ranks not calculated after $last - do you have a cycle in the graph?" );
@@ -1806,7 +1771,7 @@ sub _common_in_path {
 				if( $all_seen{$p->id} && $all_seen{$p->id} ne 'r1' ) {
 					# print STDERR "Path candidate $p from $lc\n";
 					push( @candidates, $p );
-				} else {
+				} elsif( !$all_seen{$p->id} ) {
 					$all_seen{$p->id} = 'r1';
 					push( @new_lc1, $p );
 				}
@@ -1817,7 +1782,7 @@ sub _common_in_path {
 				if( $all_seen{$p->id} && $all_seen{$p->id} ne 'r2' ) {
 					# print STDERR "Path candidate $p from $lc\n";
 					push( @candidates, $p );
-				} else {
+				} elsif( !$all_seen{$p->id} ) {
 					$all_seen{$p->id} = 'r2';
 					push( @new_lc2, $p );
 				}