From: Tara L Andrews <tla@mit.edu>
Date: Wed, 11 Jul 2012 19:30:23 +0000 (+0200)
Subject: move main functionality of join_readings into the library
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=scpubgit%2Fstemmatology.git;a=commitdiff_plain;h=6771a1b11e560c54e9cb8cbcb7c18200021894cf

move main functionality of join_readings into the library
---

diff --git a/lib/Text/Tradition/Collation.pm b/lib/Text/Tradition/Collation.pm
index d4395a7..bd3b58d 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;
@@ -426,6 +427,59 @@ sub merge_readings {
 	$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 {
@@ -1234,7 +1288,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'}}, 
@@ -1259,8 +1313,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;
@@ -1484,7 +1538,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 );
     }
 }
@@ -1615,7 +1669,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.
@@ -1777,7 +1831,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
@@ -1785,7 +1839,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';
@@ -1796,7 +1850,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';
diff --git a/script/join_readings.pl b/script/join_readings.pl
old mode 100644
new mode 100755
index 4105a7c..0b803a8
--- a/script/join_readings.pl
+++ b/script/join_readings.pl
@@ -41,40 +41,19 @@ foreach my $tinfo ( $dir->traditionlist() ) {
 	# 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 } $c->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( $c->sequence->successors( $rdg ) == 1 ) {
-			my( $next ) = $c->reading( $c->sequence->successors( $rdg ) );
-			die "Infinite loop" if $seen{$next->id};
-			$seen{$next->id} = 1;
-			last if $c->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";
-			$c->merge_readings( $rdg, $next, 1 );
-		}
-	}
-	# Make sure we haven't screwed anything up
+	
+	# Save/update the current path texts
 	foreach my $wit ( $tradition->witnesses ) {
-		my $pathtext = $c->path_text( $wit->sigil );
-		my $origtext = join( ' ', @{$wit->text} );
-		die "Text differs for witness " . $wit->sigil 
-			unless $pathtext eq $origtext;
+		my @pathtext = split( /\s+/, $c->path_text( $wit->sigil ) );
+		$wit->text( \@pathtext );
 		if( $wit->is_layered ) {
-			$pathtext = $c->path_text( $wit->sigil.$c->ac_label );
-			$origtext = join( ' ', @{$wit->layertext} );
-			die "Ante-corr text differs for witness " . $wit->sigil
-				unless $pathtext eq $origtext;
+			my @layertext = split( /\s+/, $c->path_text( $wit->sigil.$c->ac_label ) );
+			$wit->layertext( \@layertext );
 		}
 	}
-
-	$c->relations->rebuild_equivalence();
-	$c->calculate_ranks();
+	
+	# Do the deed
+	$c->compress_readings();
+	# ...and save it.
 	$dir->save( $tradition );
 }
\ No newline at end of file