X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FText%2FTradition%2FCollation.pm;h=465ef1e9caf72db4c9ba068eb7b2f01b74958c5f;hb=339786dd0b0c493786af4df1ec3bc7ef2bf497e2;hp=ad7e7e3759732f1ad3df96f728537f78d17e4408;hpb=cecbe56d2d40d98548a5d2a155fbf847ce0e7bbc;p=scpubgit%2Fstemmatology.git

diff --git a/lib/Text/Tradition/Collation.pm b/lib/Text/Tradition/Collation.pm
index ad7e7e3..465ef1e 100644
--- a/lib/Text/Tradition/Collation.pm
+++ b/lib/Text/Tradition/Collation.pm
@@ -1,5 +1,6 @@
 package Text::Tradition::Collation;
 
+use feature 'say';
 use Encode qw( decode_utf8 );
 use File::Temp;
 use File::Which;
@@ -274,8 +275,10 @@ See L<Text::Tradition::Collation::Relationship> for the available options.
 sub BUILD {
     my $self = shift;
     $self->_set_relations( Text::Tradition::Collation::RelationshipStore->new( 'collation' => $self ) );
-    $self->_set_start( $self->add_reading( { 'collation' => $self, 'is_start' => 1 } ) );
-    $self->_set_end( $self->add_reading( { 'collation' => $self, 'is_end' => 1 } ) );
+    $self->_set_start( $self->add_reading( 
+    	{ 'collation' => $self, 'is_start' => 1, 'init' => 1 } ) );
+    $self->_set_end( $self->add_reading( 
+    	{ 'collation' => $self, 'is_end' => 1, 'init' => 1 } ) );
 }
 
 ### Reading construct/destruct functions
@@ -284,7 +287,11 @@ 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'} ) {
+		if( $args{'init'} ) {
+			# If we are initializing an empty collation, don't assume that we
+			# have set a tradition.
+			delete $args{'init'};
+		} elsif( $self->tradition->has_language && !exists $args{'language'} ) {
 			$args{'language'} = $self->tradition->language;
 		}
 		$reading = Text::Tradition::Collation::Reading->new( 
@@ -403,16 +410,78 @@ sub merge_readings {
 	
 	# Do the deletion deed.
 	if( $combine ) {
+		# Combine the text of the readings
 		my $joinstr = $combine_char;
 		unless( defined $joinstr ) {
 			$joinstr = '' if $kept_obj->join_next || $del_obj->join_prior;
 			$joinstr = $self->wordsep unless defined $joinstr;
 		}
 		$kept_obj->alter_text( join( $joinstr, $kept_obj->text, $del_obj->text ) );
+		# Change this reading to a joining one if necessary
+		$kept_obj->_set_join_next( $del_obj->join_next );
+		$kept_obj->normal_form( 
+			join( $joinstr, $kept_obj->normal_form, $del_obj->normal_form ) );
+		# Combine the lexemes present in the readings
+		if( $kept_obj->has_lexemes && $del_obj->has_lexemes ) {
+			$kept_obj->add_lexeme( $del_obj->lexemes );
+		}
 	}
 	$self->del_reading( $deleted );
 }
 
+=head2 compress_readings
+
+Where possible in the graph, compresses plain sequences of readings into a
+single reading. The sequences must consist of readings with no
+relationships to other readings, with only a single witness path between
+them and no other witness paths from either that would skip the other. The
+readings must also not be marked as nonsense or bad grammar.
+
+WARNING: This operation cannot be undone.
+
+=cut
+
+sub compress_readings {
+	my $self = shift;
+	# Anywhere in the graph that there is a reading that joins only to a single
+	# successor, and neither of these have any relationships, just join the two
+	# readings.
+	my %gobbled;
+	foreach my $rdg ( sort { $a->rank <=> $b->rank } $self->readings ) {
+		next if $rdg->is_meta;
+		next if $gobbled{$rdg->id};
+		next if $rdg->grammar_invalid || $rdg->is_nonsense;
+		next if $rdg->related_readings();
+		my %seen;
+		while( $self->sequence->successors( $rdg ) == 1 ) {
+			my( $next ) = $self->reading( $self->sequence->successors( $rdg ) );
+			throw( "Infinite loop" ) if $seen{$next->id};
+			$seen{$next->id} = 1;
+			last if $self->sequence->predecessors( $next ) > 1;
+			last if $next->is_meta;
+			last if $next->grammar_invalid || $next->is_nonsense;
+			last if $next->related_readings();
+			say "Joining readings $rdg and $next";
+			$self->merge_readings( $rdg, $next, 1 );
+		}
+	}
+	# Make sure we haven't screwed anything up
+	foreach my $wit ( $self->tradition->witnesses ) {
+		my $pathtext = $self->path_text( $wit->sigil );
+		my $origtext = join( ' ', @{$wit->text} );
+		throw( "Text differs for witness " . $wit->sigil )
+			unless $pathtext eq $origtext;
+		if( $wit->is_layered ) {
+			$pathtext = $self->path_text( $wit->sigil.$self->ac_label );
+			$origtext = join( ' ', @{$wit->layertext} );
+			throw( "Ante-corr text differs for witness " . $wit->sigil )
+				unless $pathtext eq $origtext;
+		}
+	}
+
+	$self->relations->rebuild_equivalence();
+	$self->calculate_ranks();
+}
 
 # Helper function for manipulating the graph.
 sub _stringify_args {
@@ -723,23 +792,28 @@ sub as_dot {
 			$dot .= sprintf( "\t\"%s\" -> \"%s\" %s;\n", 
 				$edge->[0], $edge->[1], $varopts );
         } elsif( $used{$edge->[0]} ) {
-        	$subend{$edge->[0]} = 1;
+        	$subend{$edge->[0]} = $edge->[1];
         } elsif( $used{$edge->[1]} ) {
-        	$substart{$edge->[1]} = 1;
+        	$substart{$edge->[1]} = $edge->[0];
         }
     }
     # Add substitute start and end edges if necessary
     foreach my $node ( keys %substart ) {
-    	my $witstr = $self->_path_display_label ( $self->reading_witnesses( $self->reading( $node ) ) );
+    	my $witstr = $self->_path_display_label ( $self->path_witnesses( $substart{$node}, $node ) );
     	my $variables = { %edge_attrs, 'label' => $witstr };
+    	my $nrdg = $self->reading( $node );
+    	if( $nrdg->has_rank && $nrdg->rank > $startrank ) {
+    		# Substart is actually one lower than $startrank
+    		$variables->{'minlen'} = $nrdg->rank - ( $startrank - 1 );
+    	}	
         my $varopts = _dot_attr_string( $variables );
-        $dot .= "\t\"__SUBSTART__\" -> \"$node\" $varopts;";
+        $dot .= "\t\"__SUBSTART__\" -> \"$node\" $varopts;\n";
 	}
     foreach my $node ( keys %subend ) {
-    	my $witstr = $self->_path_display_label ( $self->reading_witnesses( $self->reading( $node ) ) );
+    	my $witstr = $self->_path_display_label ( $self->path_witnesses( $node, $subend{$node} ) );
     	my $variables = { %edge_attrs, 'label' => $witstr };
         my $varopts = _dot_attr_string( $variables );
-        $dot .= "\t\"$node\" -> \"__SUBEND__\" $varopts;";
+        $dot .= "\t\"$node\" -> \"__SUBEND__\" $varopts;\n";
 	}
 	# HACK part 2
 	if( $STRAIGHTENHACK ) {
@@ -1216,7 +1290,7 @@ sub 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 ) {
-        # print STDERR "Making witness row(s) for " . $wit->sigil . "\n";
+        # say STDERR "Making witness row(s) for " . $wit->sigil;
         my @wit_path = $self->reading_sequence( $self->start, $self->end, $wit->sigil );
         my @row = _make_witness_row( \@wit_path, \@all_pos );
         push( @{$table->{'alignment'}}, 
@@ -1241,8 +1315,8 @@ sub _make_witness_row {
     foreach my $rdg ( @$path ) {
         my $rtext = $rdg->text;
         $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;
+        say STDERR "rank " . $rdg->rank if $debug;
+        # say STDERR "No rank for " . $rdg->id unless defined $rdg->rank;
         $char_hash{$rdg->rank} = { 't' => $rdg };
     }
     my @row = map { $char_hash{$_} } @$positions;
@@ -1466,7 +1540,7 @@ Call make_witness_path for all witnesses in the tradition.
 sub make_witness_paths {
     my( $self ) = @_;
     foreach my $wit ( $self->tradition->witnesses ) {
-        # print STDERR "Making path for " . $wit->sigil . "\n";
+        # say STDERR "Making path for " . $wit->sigil;
         $self->make_witness_path( $wit );
     }
 }
@@ -1597,7 +1671,7 @@ sub flatten_ranks {
 				next;
 			}
             # Combine!
-        	#print STDERR "Combining readings at same rank: $key\n";
+        	#say STDERR "Combining readings at same rank: $key";
         	$changed = 1;
             $self->merge_readings( $unique_rank_rdg{$key}, $rdg );
             # TODO see if this now makes a common point.
@@ -1759,7 +1833,7 @@ sub _common_in_path {
 	my @last_r2 = ( $r2 );
 	# my %all_seen = ( $r1 => 'r1', $r2 => 'r2' );
 	my %all_seen;
-	# print STDERR "Finding common $dir for $r1, $r2\n";
+	# say STDERR "Finding common $dir for $r1, $r2";
 	while( !@candidates ) {
 		last unless $iter--;  # Avoid looping infinitely
 		# Iterate separately down the graph from r1 and r2
@@ -1767,7 +1841,7 @@ sub _common_in_path {
 		foreach my $lc ( @last_r1 ) {
 			foreach my $p ( $lc->$dir ) {
 				if( $all_seen{$p->id} && $all_seen{$p->id} ne 'r1' ) {
-					# print STDERR "Path candidate $p from $lc\n";
+					# say STDERR "Path candidate $p from $lc";
 					push( @candidates, $p );
 				} elsif( !$all_seen{$p->id} ) {
 					$all_seen{$p->id} = 'r1';
@@ -1778,7 +1852,7 @@ sub _common_in_path {
 		foreach my $lc ( @last_r2 ) {
 			foreach my $p ( $lc->$dir ) {
 				if( $all_seen{$p->id} && $all_seen{$p->id} ne 'r2' ) {
-					# print STDERR "Path candidate $p from $lc\n";
+					# say STDERR "Path candidate $p from $lc";
 					push( @candidates, $p );
 				} elsif( !$all_seen{$p->id} ) {
 					$all_seen{$p->id} = 'r2';