X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FText%2FTradition%2FCollation.pm;h=9ec858ea9e0d3b4e3e6979997db7ac5730dfe01d;hb=ca6e6095920ad91d131ee8365872ca8501849f08;hp=2b5dbeb1e9723118e90d7edc19ef5bbcd34ef49d;hpb=9317e522bb0299ab6bdcfe2d999750719e893407;p=scpubgit%2Fstemmatology.git

diff --git a/lib/Text/Tradition/Collation.pm b/lib/Text/Tradition/Collation.pm
index 2b5dbeb..9ec858e 100644
--- a/lib/Text/Tradition/Collation.pm
+++ b/lib/Text/Tradition/Collation.pm
@@ -2,6 +2,7 @@ package Text::Tradition::Collation;
 
 use Encode qw( decode_utf8 );
 use File::Temp;
+use File::Which;
 use Graph;
 use IPC::Run qw( run binary );
 use Text::CSV_XS;
@@ -27,6 +28,7 @@ has 'relations' => (
 	handles => {
 		relationships => 'relationships',
 		related_readings => 'related_readings',
+		get_relationship => 'get_relationship',
 		del_relationship => 'del_relationship',
 	},
 	writer => '_set_relations',
@@ -95,6 +97,19 @@ has 'cached_svg' => (
 	predicate => 'has_cached_svg',
 	clearer => 'wipe_svg',
 	);
+	
+has 'cached_table' => (
+	is => 'rw',
+	isa => 'HashRef',
+	predicate => 'has_cached_table',
+	clearer => 'wipe_table',
+	);
+	
+has '_graphcalc_done' => (
+	is => 'rw',
+	isa => 'Bool',
+	default => undef,
+	); 
 
 =head1 NAME
 
@@ -258,6 +273,7 @@ sub add_reading {
 	if( $self->reading( $reading->id ) ) {
 		throw( "Collation already has a reading with id " . $reading->id );
 	}
+	$self->_graphcalc_done(0);
 	$self->_add_reading( $reading->id => $reading );
 	# Once the reading has been added, put it in both graphs.
 	$self->sequence->add_vertex( $reading->id );
@@ -274,6 +290,7 @@ around del_reading => sub {
 		$arg = $arg->id;
 	}
 	# Remove the reading from the graphs.
+	$self->_graphcalc_done(0);
 	$self->sequence->delete_vertex( $arg );
 	$self->relations->delete_reading( $arg );
 	
@@ -289,6 +306,7 @@ sub merge_readings {
 	# We only need the IDs for adding paths to the graph, not the reading
 	# objects themselves.
     my( $kept, $deleted, $combine_char ) = $self->_stringify_args( @_ );
+	$self->_graphcalc_done(0);
 
     # The kept reading should inherit the paths and the relationships
     # of the deleted reading.
@@ -344,6 +362,7 @@ sub add_path {
 	# objects themselves.
     my( $source, $target, $wit ) = $self->_stringify_args( @_ );
 
+	$self->_graphcalc_done(0);
 	# Connect the readings
     $self->sequence->add_edge( $source, $target );
     # Note the witness in question
@@ -364,6 +383,7 @@ sub del_path {
 	# objects themselves.
     my( $source, $target, $wit ) = $self->_stringify_args( @args );
 
+	$self->_graphcalc_done(0);
 	if( $self->sequence->has_edge_attribute( $source, $target, $wit ) ) {
 		$self->sequence->delete_edge_attribute( $source, $target, $wit );
 	}
@@ -392,6 +412,7 @@ be called via $tradition->del_witness.
 sub clear_witness {
 	my( $self, @sigils ) = @_;
 
+	$self->_graphcalc_done(0);
 	# Clear the witness(es) out of the paths
 	foreach my $e ( $self->paths ) {
 		foreach my $sig ( @sigils ) {
@@ -412,11 +433,21 @@ sub add_relationship {
     my( $source, $target, $opts ) = $self->_stringify_args( @_ );
     my( @vectors ) = $self->relations->add_relationship( $source, 
     	$self->reading( $source ), $target, $self->reading( $target ), $opts );
-    # Force a full rank recalculation every time. Yuck.
-    $self->calculate_ranks() if $self->end->has_rank;
+	$self->_graphcalc_done(0);
     return @vectors;
 }
 
+around qw/ get_relationship del_relationship / => sub {
+	my $orig = shift;
+	my $self = shift;
+	my @args = @_;
+	if( @args == 1 && ref( $args[0] ) eq 'ARRAY' ) {
+		@args = @{$_[0]};
+	}
+	my( $source, $target ) = $self->_stringify_args( @args );
+	$self->$orig( $source, $target );
+};
+
 =head2 reading_witnesses( $reading )
 
 Return a list of sigils corresponding to the witnesses in which the reading appears.
@@ -435,6 +466,10 @@ sub reading_witnesses {
 		my $wits = $self->sequence->get_edge_attributes( @$e );
 		@all_witnesses{ keys %$wits } = 1;
 	}
+	my $acstr = $self->ac_label;
+	foreach my $acwit ( grep { $_ =~ s/^(.*)\Q$acstr\E$/$1/ } keys %all_witnesses ) {
+		delete $all_witnesses{$acwit.$acstr} if exists $all_witnesses{$acwit};
+	}
 	return keys %all_witnesses;
 }
 
@@ -443,13 +478,16 @@ sub reading_witnesses {
 =head2 as_svg( \%options )
 
 Returns an SVG string that represents the graph, via as_dot and graphviz.
-See as_dot for a list of options.
+See as_dot for a list of options.  Must have GraphViz (dot) installed to run.
 
 =cut
 
 sub as_svg {
     my( $self, $opts ) = @_;
+    throw( "Need GraphViz installed to output SVG" )
+    	unless File::Which::which( 'dot' );
     my $want_subgraph = exists $opts->{'from'} || exists $opts->{'to'};
+    $self->calculate_ranks() unless $self->_graphcalc_done;
     if( !$self->has_cached_svg || $opts->{'recalc'}	|| $want_subgraph ) {        
 		my @cmd = qw/dot -Tsvg/;
 		my( $svg, $err );
@@ -555,6 +593,8 @@ sub as_dot {
         next if $reading->id eq $reading->text;
         my $rattrs;
         my $label = $reading->text;
+        $label .= '-' if $reading->join_next;
+        $label = "-$label" if $reading->join_prior;
         $label =~ s/\"/\\\"/g;
 		$rattrs->{'label'} = $label;
 		$rattrs->{'fillcolor'} = '#b3f36d' if $reading->is_common && $color_common;
@@ -688,7 +728,16 @@ sub _path_display_label {
 		return join( ', ', @wits );
 	}
 }
-		
+
+=head2 witnesses_at_rank
+
+Returns a list of witnesses that are not lacunose, for a given rank.
+
+=cut
+
+sub witnesses_at_rank {
+	my( $self, $rank ) = @_;
+}		
 
 =head2 as_graphml
 
@@ -738,7 +787,8 @@ is( scalar $st->collation->relationships, 3, "Reparsed collation has new relatio
 
 sub as_graphml {
     my( $self ) = @_;
-
+	$self->calculate_ranks unless $self->_graphcalc_done;
+	
     # Some namespaces
     my $graphml_ns = 'http://graphml.graphdrawing.org/xmlns';
     my $xsi_ns = 'http://www.w3.org/2001/XMLSchema-instance';
@@ -775,6 +825,9 @@ sub as_graphml {
     	is_start => 'boolean',
     	is_end => 'boolean',
     	is_lacuna => 'boolean',
+    	is_common => 'boolean',
+    	join_prior => 'boolean',
+    	join_next => 'boolean',
     	);
     foreach my $datum ( keys %node_data ) {
         $node_data_keys{$datum} = 'dn'.$ndi++;
@@ -794,6 +847,7 @@ sub as_graphml {
     	relationship => 'string',		# ID/label for a relationship
     	extra => 'boolean',				# Path key
     	scope => 'string',				# Relationship key
+    	annotation => 'string',			# Relationship key
     	non_correctable => 'boolean',	# Relationship key
     	non_independent => 'boolean',	# Relationship key
     	);
@@ -893,7 +947,7 @@ row per witness (or witness uncorrected.)
 
 sub as_csv {
     my( $self ) = @_;
-    my $table = $self->make_alignment_table;
+    my $table = $self->alignment_table;
     my $csv = Text::CSV_XS->new( { binary => 1, quote_null => 0 } );    
     my @result;
     # Make the header row
@@ -902,14 +956,14 @@ sub as_csv {
     # Make the rest of the rows
     foreach my $idx ( 0 .. $table->{'length'} - 1 ) {
     	my @rowobjs = map { $_->{'tokens'}->[$idx] } @{$table->{'alignment'}};
-    	my @row = map { $_ ? $_->{'t'} : $_ } @rowobjs;
+    	my @row = map { $_ ? $_->{'t'}->text : $_ } @rowobjs;
         $csv->combine( @row );
         push( @result, decode_utf8( $csv->string ) );
     }
     return join( "\n", @result );
 }
 
-=head2 make_alignment_table( $use_refs, $include_witnesses )
+=head2 alignment_table( $use_refs, $include_witnesses )
 
 Return a reference to an alignment table, in a slightly enhanced CollateX
 format which looks like this:
@@ -929,8 +983,11 @@ keys have a true hash value will be included.
 
 =cut
 
-sub make_alignment_table {
-    my( $self, $noderefs, $include ) = @_;
+sub alignment_table {
+    my( $self ) = @_;
+    $self->calculate_ranks() unless $self->_graphcalc_done;
+    return $self->cached_table if $self->has_cached_table;
+    
     # Make sure we can do this
 	throw( "Need a linear graph in order to make an alignment table" )
 		unless $self->linear;
@@ -939,27 +996,25 @@ sub make_alignment_table {
     my $table = { 'alignment' => [], 'length' => $self->end->rank - 1 };
     my @all_pos = ( 1 .. $self->end->rank - 1 );
     foreach my $wit ( sort { $a->sigil cmp $b->sigil } $self->tradition->witnesses ) {
-    	if( $include ) {
-    		next unless $include->{$wit->sigil};
-    	}
         # print STDERR "Making witness row(s) for " . $wit->sigil . "\n";
         my @wit_path = $self->reading_sequence( $self->start, $self->end, $wit->sigil );
-        my @row = _make_witness_row( \@wit_path, \@all_pos, $noderefs );
+        my @row = _make_witness_row( \@wit_path, \@all_pos );
         push( @{$table->{'alignment'}}, 
         	{ 'witness' => $wit->sigil, 'tokens' => \@row } );
         if( $wit->is_layered ) {
         	my @wit_ac_path = $self->reading_sequence( $self->start, $self->end, 
         		$wit->sigil.$self->ac_label );
-            my @ac_row = _make_witness_row( \@wit_ac_path, \@all_pos, $noderefs );
+            my @ac_row = _make_witness_row( \@wit_ac_path, \@all_pos );
 			push( @{$table->{'alignment'}},
 				{ 'witness' => $wit->sigil.$self->ac_label, 'tokens' => \@ac_row } );
         }           
     }
-	return $table;
+    $self->cached_table( $table );
+    return $table;
 }
 
 sub _make_witness_row {
-    my( $path, $positions, $noderefs ) = @_;
+    my( $path, $positions ) = @_;
     my %char_hash;
     map { $char_hash{$_} = undef } @$positions;
     my $debug = 0;
@@ -968,8 +1023,7 @@ sub _make_witness_row {
         $rtext = '#LACUNA#' if $rdg->is_lacuna;
         print STDERR "rank " . $rdg->rank . "\n" if $debug;
         # print STDERR "No rank for " . $rdg->id . "\n" unless defined $rdg->rank;
-        $char_hash{$rdg->rank} = $noderefs ? { 't' => $rdg } 
-        								   : { 't' => $rtext };
+        $char_hash{$rdg->rank} = { 't' => $rdg };
     }
     my @row = map { $char_hash{$_} } @$positions;
     # Fill in lacuna markers for undef spots in the row
@@ -978,8 +1032,8 @@ sub _make_witness_row {
     foreach my $el ( @row ) {
         # If we are using node reference, make the lacuna node appear many times
         # in the table.  If not, use the lacuna tag.
-        if( $last_el && _el_is_lacuna( $last_el ) && !defined $el ) {
-            $el = $noderefs ? $last_el : { 't' => '#LACUNA#' };
+        if( $last_el && $last_el->{'t'}->is_lacuna && !defined $el ) {
+            $el = $last_el;
         }
         push( @filled_row, $el );
         $last_el = $el;
@@ -987,30 +1041,6 @@ sub _make_witness_row {
     return @filled_row;
 }
 
-# Tiny utility function to say if a table element is a lacuna
-sub _el_is_lacuna {
-    my $el = shift;
-    return 1 if $el->{'t'} eq '#LACUNA#';
-    return 1 if ref( $el->{'t'} ) eq 'Text::Tradition::Collation::Reading'
-        && $el->{'t'}->is_lacuna;
-    return 0;
-}
-
-# Helper to turn the witnesses along columns rather than rows.  Assumes
-# equal-sized rows.
-sub _turn_table {
-    my( $table ) = @_;
-    my $result = [];
-    return $result unless scalar @$table;
-    my $nrows = scalar @{$table->[0]};
-    foreach my $idx ( 0 .. $nrows - 1 ) {
-        foreach my $wit ( 0 .. $#{$table} ) {
-            $result->[$idx]->[$wit] = $table->[$wit]->[$idx];
-        }
-    }
-    return $result;        
-}
-
 =head1 NAVIGATION METHODS
 
 =head2 reading_sequence( $first, $last, $sigil, $backup )
@@ -1179,7 +1209,17 @@ sub path_text {
 	$start = $self->start unless $start;
 	$end = $self->end unless $end;
 	my @path = grep { !$_->is_meta } $self->reading_sequence( $start, $end, $wit );
-	return join( ' ', map { $_->text } @path );
+	my $pathtext = '';
+	my $last;
+	foreach my $r ( @path ) {
+		if( $r->join_prior || !$last || $last->join_next ) {
+			$pathtext .= $r->text;
+		} else {
+			$pathtext .= ' ' . $r->text;
+		}
+		$last = $r;
+	}
+	return $pathtext;
 }
 
 =head1 INITIALIZATION METHODS
@@ -1250,14 +1290,13 @@ my $t = Text::Tradition->new(
 my $c = $t->collation;
 
 # Make an svg
-my $svg = $c->as_svg;
-is( substr( $svg, 0, 5 ), '<?xml', "Got XML doc for svg" );
-ok( $c->has_cached_svg, "SVG was cached" );
-is( $c->as_svg, $svg, "Cached SVG returned upon second call" );
+my $table = $c->alignment_table;
+ok( $c->has_cached_table, "Alignment table was cached" );
+is( $c->alignment_table, $table, "Cached table returned upon second call" );
 $c->calculate_ranks;
-is( $c->as_svg, $svg, "Cached SVG retained with no rank change" );
+is( $c->alignment_table, $table, "Cached table retained with no rank change" );
 $c->add_relationship( 'n9', 'n23', { 'type' => 'spelling' } );
-isnt( $c->as_svg, $svg, "SVG changed after relationship add" );
+isnt( $c->alignment_table, $table, "Alignment table changed after relationship add" );
 
 =end testing
 
@@ -1324,14 +1363,19 @@ sub calculate_ranks {
             throw( "Ranks not calculated after $last - do you have a cycle in the graph?" );
         }
     }
-    # Do we need to invalidate the cached SVG?
-    if( $self->has_cached_svg ) {
+    # Do we need to invalidate the cached data?
+    if( $self->has_cached_svg || $self->has_cached_table ) {
     	foreach my $r ( $self->readings ) {
-    		next if $existing_ranks{$r} == $r->rank;
-    		$self->wipe_svg;
+    		next if $existing_ranks{$r} && $existing_ranks{$r} == $r->rank;
+    		# Something has changed, so clear the cache
+    		$self->_clear_cache;
+			# ...and recalculate the common readings.
+			$self->calculate_common_readings();
     		last;
     	}
     }
+	# The graph calculation information is now up to date.
+	$self->_graphcalc_done(1);
 }
 
 sub _assign_rank {
@@ -1369,6 +1413,13 @@ sub _assign_rank {
     return @next_nodes;
 }
 
+sub _clear_cache {
+	my $self = shift;
+	$self->wipe_svg if $self->has_cached_svg;
+	$self->wipe_table if $self->has_cached_table;
+}	
+
+
 =head2 flatten_ranks
 
 A convenience method for parsing collation data.  Searches the graph for readings
@@ -1392,44 +1443,6 @@ sub flatten_ranks {
         }
     }
 }
-
-=head2 remove_collations
-
-Another convenience method for parsing. Removes all 'collation' relationships
-that were defined in order to get the reading ranks to be correct.
-
-=begin testing
-
-use Text::Tradition;
-
-my $cxfile = 't/data/Collatex-16.xml';
-my $t = Text::Tradition->new( 
-    'name'  => 'inline', 
-    'input' => 'CollateX',
-    'file'  => $cxfile,
-    );
-my $c = $t->collation;
-
-isnt( $c->reading('n23')->rank, $c->reading('n9')->rank, "Rank skew exists" );
-$c->add_relationship( 'n23', 'n9', { 'type' => 'collated', 'scope' => 'local' } );
-is( scalar $c->relationships, 4, "Found all expected relationships" );
-$c->remove_collations;
-is( scalar $c->relationships, 3, "Collated relationships now gone" );
-is( $c->reading('n23')->rank, $c->reading('n9')->rank, "Aligned ranks were preserved" );
-
-=end testing
-
-=cut
-
-sub remove_collations {
-	my $self = shift;
-	foreach my $reledge ( $self->relationships ) {
-		my $relobj = $self->relations->get_relationship( $reledge );
-		if( $relobj && $relobj->type eq 'collated' ) {
-			$self->relations->delete_relationship( $reledge );
-		}
-	}
-}
 	
 
 =head2 calculate_common_readings
@@ -1464,9 +1477,13 @@ is_deeply( \@marked, \@expected, "Found correct list of common readings" );
 sub calculate_common_readings {
 	my $self = shift;
 	my @common;
-	my $table = $self->make_alignment_table( 1 );
+	map { $_->is_common( 0 ) } $self->readings;
+	# Implicitly calls calculate_ranks
+	my $table = $self->alignment_table;
 	foreach my $idx ( 0 .. $table->{'length'} - 1 ) {
-		my @row = map { $_->{'tokens'}->[$idx]->{'t'} } @{$table->{'alignment'}};
+		my @row = map { $_->{'tokens'}->[$idx] 
+							? $_->{'tokens'}->[$idx]->{'t'} : '' } 
+					@{$table->{'alignment'}};
 		my %hash;
 		foreach my $r ( @row ) {
 			if( $r ) {