X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FText%2FTradition%2FCollation.pm;h=21b3c964a6096dac9a94f1b55ecdc520cee5b0f1;hb=15d2d3dfe4461e506cb78a1c4b96e69f4ed6126f;hp=7a75c18d5ef1290e7905aea2d63a72fd1fd039da;hpb=de51424ae471a4d72edef3cb48b0fb7044c54333;p=scpubgit%2Fstemmatology.git

diff --git a/lib/Text/Tradition/Collation.pm b/lib/Text/Tradition/Collation.pm
index 7a75c18..21b3c96 100644
--- a/lib/Text/Tradition/Collation.pm
+++ b/lib/Text/Tradition/Collation.pm
@@ -57,10 +57,28 @@ has 'lemmata' => (
     );
 
 has 'wit_list_separator' => (
-			     is => 'rw',
-			     isa => 'Str',
-			     default => ', ',
-			     );
+    is => 'rw',
+    isa => 'Str',
+    default => ', ',
+    );
+
+has 'baselabel' => (
+    is => 'rw',
+    isa => 'Str',
+    default => 'base text',
+    );
+
+has 'collapsed' => (
+    is => 'rw',
+    isa => 'Bool',
+    );
+
+has 'linear' => (
+    is => 'rw',
+    isa => 'Bool',
+    default => 1,
+    );
+
 
 # The collation can be created two ways:
 # 1. Collate a set of witnesses (with CollateX I guess) and process
@@ -86,7 +104,33 @@ sub BUILD {
     $self->graph->set_attribute( 'node', 'shape', $shape );
 }
 
-# Wrappes around merge_nodes
+# Wrapper around add_path 
+
+around add_path => sub {
+    my $orig = shift;
+    my $self = shift;
+
+    # Make sure there are three arguments
+    unless( @_ == 3 ) {
+	warn "Call add_path with args source, target, witness";
+	return;
+    }
+    # Make sure the proposed path does not yet exist
+    my( $source, $target, $wit ) = @_;
+    $source = $self->reading( $source )
+	unless ref( $source ) eq 'Text::Tradition::Collation::Reading';
+    $target = $self->reading( $target )
+	unless ref( $target ) eq 'Text::Tradition::Collation::Reading';
+    foreach my $path ( $source->edges_to( $target ) ) {
+	if( $path->label eq $wit ) {
+	    return;
+	}
+    }
+    # Do the deed
+    $self->$orig( @_ );
+};
+
+# Wrapper around merge_nodes
 
 sub merge_readings {
     my $self = shift;
@@ -97,6 +141,14 @@ sub merge_readings {
     return $self->graph->merge_nodes( @_ );
 }
 
+# Extra graph-alike utility
+sub has_path {
+    my( $self, $source, $target, $label ) = @_;
+    my @paths = $source->edges_to( $target );
+    my @relevant = grep { $_->label eq $label } @paths;
+    return scalar @paths;
+}
+
 =head2 Output method(s)
 
 =over
@@ -116,6 +168,7 @@ sub as_svg {
     my( $self, $recalc ) = @_;
     return $self->svg if $self->has_svg;
     
+    $self->collapse_graph_edges();
     $self->_save_graphviz( $self->graph->as_graphviz() )
 	unless( $self->has_graphviz && !$recalc );
     
@@ -124,6 +177,7 @@ sub as_svg {
     my $in = $self->graphviz;
     run( \@cmd, \$in, ">", binary(), \$svg );
     $self->{'svg'} = $svg;
+    $self->expand_graph_edges();
     return $svg;
 }
 
@@ -168,7 +222,7 @@ sub as_graphml {
     # Add the data keys for edges
     my %wit_hash;
     my $wit_ctr = 0;
-    foreach my $wit ( $self->getWitnessList ) {
+    foreach my $wit ( @{$self->tradition->witnesses} ) {
 	my $wit_key = 'w' . $wit_ctr++;
 	$wit_hash{$wit} = $wit_key;
 	my $key = $root->addNewChild( $graphml_ns, 'key' );
@@ -179,6 +233,7 @@ sub as_graphml {
     }
 
     # Add the graph, its nodes, and its edges
+    $self->collapse_graph_edges();
     my $graph = $root->addNewChild( $graphml_ns, 'graph' );
     $graph->setAttribute( 'edgedefault', 'directed' );
     $graph->setAttribute( 'id', 'g0' ); # TODO make this meaningful
@@ -214,7 +269,7 @@ sub as_graphml {
 	}
     }
 
-    foreach my $e ( $self->edges() ) {
+    foreach my $e ( $self->paths() ) {
 	my( $name, $from, $to ) = ( $e->name,
 				    $node_hash{ $e->from()->name() },
 				    $node_hash{ $e->to()->name() } );
@@ -227,9 +282,86 @@ sub as_graphml {
 
     # Return the thing
     $self->_save_graphml( $graphml );
+    $self->expand_graph_edges();
     return $graphml;
 }
 
+sub collapse_graph_edges {
+    my $self = shift;
+    # Our collation graph has an edge per witness.  This is great for
+    # calculation purposes, but terrible for display.  Thus we want to
+    # display only one edge between any two nodes.
+
+    return if $self->collapsed;
+
+    print STDERR "Collapsing path edges in graph...\n";
+
+    # Don't list out every witness if we have more than half to list.
+    my $majority = int( scalar( @{$self->tradition->witnesses} ) / 2 ) + 1;
+    foreach my $node( $self->readings ) {
+	my $newlabels = {};
+	# We will visit each node, so we only look ahead.
+	foreach my $edge ( $node->outgoing() ) {
+	    add_hash_entry( $newlabels, $edge->to->name, $edge->name );
+	    $self->del_path( $edge );
+	}
+
+	foreach my $newdest ( keys %$newlabels ) {
+	    my $label;
+	    my @compressed_wits = ();
+	    if( @{$newlabels->{$newdest}} < $majority ) {
+		$label = join( ', ', @{$newlabels->{$newdest}} );
+	    } else {
+		## TODO FIX THIS HACK
+		my @aclabels;
+		foreach my $wit ( @{$newlabels->{$newdest}} ) {
+		    if( $wit =~ /^(.*?)(\s*\(?a\.\s*c\.\)?)$/ ) {
+			push( @aclabels, $wit );
+		    } else {
+			push( @compressed_wits, $wit );
+		    }
+		}
+		$label = join( ', ', 'majority', @aclabels );
+	    }
+	    
+	    my $newedge = 
+		$self->add_path( $node, $self->reading( $newdest ), $label );
+	    if( @compressed_wits ) {
+		## TODO fix this hack too.
+		$newedge->set_attribute( 'class', 
+					 join( '|', @compressed_wits ) );
+	    }
+	}
+    }
+
+    $self->collapsed( 1 );
+}
+
+sub expand_graph_edges {
+    my $self = shift;
+    # Our collation graph has only one edge between any two nodes.
+    # This is great for display, but not so great for analysis.
+    # Expand this so that each witness has its own edge between any
+    # two reading nodes.
+    return unless $self->collapsed;
+    
+    print STDERR "Expanding path edges in graph...\n";
+
+    foreach my $edge( $self->paths ) {
+	my $from = $edge->from;
+	my $to = $edge->to;
+	my @wits = split( /, /, $edge->label );
+	if( grep { $_ eq 'majority' } @wits ) {
+	    push( @wits, split( /\|/, $edge->get_attribute( 'class' ) ) );
+	}
+	$self->del_path( $edge );
+	foreach ( @wits ) {
+	    $self->add_path( $from, $to, $_ );
+	}
+    }
+    $self->collapsed( 0 );
+}
+
 =back
 
 =head2 Navigation methods
@@ -255,17 +387,56 @@ sub start {
     return $self->reading('#START#');
 }
 
+=item B<reading_sequence>
+
+my @readings = $graph->reading_sequence( $first, $last, $path[, $alt_path] );
+
+Returns the ordered list of readings, starting with $first and ending
+with $last, along the given witness path.  If no path is specified,
+assume that the path is that of the base text (if any.)
+
+=cut
+
+sub reading_sequence {
+    my( $self, $start, $end, $witness, $backup ) = @_;
+
+    $witness = $self->baselabel unless $witness;
+    my @readings = ( $start );
+    my %seen;
+    my $n = $start;
+    while( $n && $n ne $end ) {
+	if( exists( $seen{$n->name()} ) ) {
+	    warn "Detected loop at " . $n->name();
+	    last;
+	}
+	$seen{$n->name()} = 1;
+	
+	my $next = $self->next_reading( $n, $witness, $backup );
+	warn "Did not find any path for $witness from reading " . $n->name
+	    unless $next;
+	push( @readings, $next );
+	$n = $next;
+    }
+    # Check that the last reading is our end reading.
+    my $last = $readings[$#readings];
+    warn "Last reading found from " . $start->label() .
+	" for witness $witness is not the end!"
+	unless $last eq $end;
+    
+    return @readings;
+}
+
 =item B<next_reading>
 
 my $next_reading = $graph->next_reading( $reading, $witpath );
 
 Returns the reading that follows the given reading along the given witness
-path.  TODO These are badly named.
+path.  
 
 =cut
 
 sub next_reading {
-    # Return the successor via the corresponding edge.
+    # Return the successor via the corresponding path.
     my $self = shift;
     return $self->_find_linked_reading( 'next', @_ );
 }
@@ -275,42 +446,60 @@ sub next_reading {
 my $prior_reading = $graph->prior_reading( $reading, $witpath );
 
 Returns the reading that precedes the given reading along the given witness
-path.  TODO These are badly named.
+path.  
 
 =cut
 
 sub prior_reading {
-    # Return the predecessor via the corresponding edge.
+    # Return the predecessor via the corresponding path.
     my $self = shift;
     return $self->_find_linked_reading( 'prior', @_ );
 }
 
 sub _find_linked_reading {
-    my( $self, $direction, $node, $edge ) = @_;
-    $edge = 'base text' unless $edge;
-    my @linked_edges = $direction eq 'next' 
+    my( $self, $direction, $node, $path, $alt_path ) = @_;
+    my @linked_paths = $direction eq 'next' 
 	? $node->outgoing() : $node->incoming();
-    return undef unless scalar( @linked_edges );
+    return undef unless scalar( @linked_paths );
     
-    # We have to find the linked edge that contains all of the
-    # witnesses supplied in $edge.
-    my @edge_wits = $self->witnesses_of_label( $edge );
-    foreach my $le ( @linked_edges ) {
-	my @le_wits = $self->witnesses_of_label( $le->name );
-	if( _is_within( \@edge_wits, \@le_wits ) ) {
-	    # This is the right edge.
-	    return $direction eq 'next' ? $le->to() : $le->from();
+    # We have to find the linked path that contains all of the
+    # witnesses supplied in $path.
+    my( @path_wits, @alt_path_wits );
+    @path_wits = $self->witnesses_of_label( $path ) if $path;
+    @alt_path_wits = $self->witnesses_of_label( $alt_path ) if $alt_path;
+    my $base_le;
+    my $alt_le;
+    foreach my $le ( @linked_paths ) {
+	if( $le->name eq $self->baselabel ) {
+	    $base_le = $le;
+	} else {
+	    my @le_wits = $self->witnesses_of_label( $le->name );
+	    if( _is_within( \@path_wits, \@le_wits ) ) {
+		# This is the right path.
+		return $direction eq 'next' ? $le->to() : $le->from();
+	    } elsif( _is_within( \@alt_path_wits, \@le_wits ) ) {
+		$alt_le = $le;
+	    }
 	}
     }
+    # Got this far? Return the alternate path if it exists.
+    return $direction eq 'next' ? $alt_le->to() : $alt_le->from()
+	if $alt_le;
+
+    # Got this far? Return the base path if it exists.
+    return $direction eq 'next' ? $base_le->to() : $base_le->from()
+	if $base_le;
+
+    # Got this far? We have no appropriate path.
     warn "Could not find $direction node from " . $node->label 
-	. " along edge $edge";
+	. " along path $path";
     return undef;
 }
 
 # Some set logic.
 sub _is_within {
     my( $set1, $set2 ) = @_;
-    my $ret = 1;
+    my $ret = @$set1; # will be 0, i.e. false, if set1 is empty
     foreach my $el ( @$set1 ) {
 	$ret = 0 unless grep { /^\Q$el\E$/ } @$set2;
     }
@@ -320,7 +509,8 @@ sub _is_within {
 
 ## INITIALIZATION METHODS - for use by parsers
 # Walk the paths for each witness in the graph, and return the nodes
-# that the graph has in common.
+# that the graph has in common.  If $using_base is true, some 
+# different logic is needed.
 
 sub walk_witness_paths {
     my( $self, $end ) = @_;
@@ -332,37 +522,18 @@ sub walk_witness_paths {
     my @common_readings;
     foreach my $wit ( @{$self->tradition->witnesses} ) {
 	my $curr_reading = $self->start;
-	my @wit_path = ( $curr_reading );
-	my %seen_readings;
-	# TODO Detect loops at some point
-	while( $curr_reading->name ne $end->name ) {
-	    if( $seen_readings{$curr_reading->name} ) {
-		warn "Detected loop walking path for witness " . $wit->sigil
-		    . " at reading " . $curr_reading->name;
-		last;
-	    }
-	    my $next_reading = $self->next_reading( $curr_reading, 
-						    $wit->sigil );
-	    push( @wit_path, $next_reading );
-	    $seen_readings{$curr_reading->name} = 1;
-	    $curr_reading = $next_reading;
-	}
+	my @wit_path = $self->reading_sequence( $self->start, $end, 
+						$wit->sigil );
 	$wit->path( \@wit_path );
-	if( @common_readings ) {
-	    my @cn;
-	    foreach my $n ( @wit_path ) {
-		push( @cn, $n ) if grep { $_ eq $n } @common_readings;
-	    }
-	    @common_readings = ();
-	    push( @common_readings, @cn );
-	} else {
-	    push( @common_readings, @wit_path );
-	}
+
+	# Detect the common readings.
+	@common_readings = _find_common( \@common_readings, \@wit_path );
     }
 
     # Mark all the nodes as either common or not.
     foreach my $cn ( @common_readings ) {
-	print STDERR "Setting " . $cn->name . " / " . $cn->label . " as common node\n";
+	print STDERR "Setting " . $cn->name . " / " . $cn->label 
+	    . " as common node\n";
 	$cn->make_common;
     }
     foreach my $n ( $self->readings() ) {
@@ -372,6 +543,64 @@ sub walk_witness_paths {
     return @common_readings;
 }
 
+sub _find_common {
+    my( $common_readings, $new_path ) = @_;
+    my @cr;
+    if( @$common_readings ) {
+	foreach my $n ( @$new_path ) {
+	    push( @cr, $n ) if grep { $_ eq $n } @$common_readings;
+	}
+    } else {
+	push( @cr, @$new_path );
+    }
+    return @cr;
+}
+
+sub _remove_common {
+    my( $common_readings, $divergence ) = @_;
+    my @cr;
+    my %diverged;
+    map { $diverged{$_->name} = 1 } @$divergence;
+    foreach( @$common_readings ) {
+	push( @cr, $_ ) unless $diverged{$_->name};
+    }
+    return @cr;
+}
+
+
+# An alternative to walk_witness_paths, for use when a collation is
+# constructed from a base text and an apparatus.  We have the
+# sequences of readings and just need to add path edges.
+
+sub make_witness_paths {
+    my( $self ) = @_;
+
+    my @common_readings;
+    foreach my $wit ( @{$self->tradition->witnesses} ) {
+	print STDERR "Making path for " . $wit->sigil . "\n";
+	$self->make_witness_path( $wit );
+	@common_readings = _find_common( \@common_readings, $wit->path );
+	@common_readings = _find_common( \@common_readings, $wit->uncorrected_path );
+    }
+    return @common_readings;
+}
+
+sub make_witness_path {
+    my( $self, $wit ) = @_;
+    my @chain = @{$wit->path};
+    my $sig = $wit->sigil;
+    foreach my $idx ( 0 .. $#chain-1 ) {
+	$self->add_path( $chain[$idx], $chain[$idx+1], $sig );
+    }
+    @chain = @{$wit->uncorrected_path};
+    foreach my $idx( 0 .. $#chain-1 ) {
+	my $source = $chain[$idx];
+	my $target = $chain[$idx+1];
+	$self->add_path( $source, $target, "$sig (a.c.)" )
+	    unless $self->has_path( $source, $target, $sig );
+    }
+}
+
 sub common_readings {
     my $self = shift;
     my @common = grep { $_->is_common } $self->readings();
@@ -391,50 +620,66 @@ sub calculate_positions {
 
     my $node_pos = {};
     foreach my $wit ( @{$self->tradition->witnesses} ) {
-	# First we walk each path, making a matrix for each witness that
-	# corresponds to its eventual position identifier.  Common nodes
-	# always start a new row, and are thus always in the first column.
-
-	my $wit_matrix = [];
-	my $cn = 0;  # We should hit the common readings in order.
-	my $row = [];
-	foreach my $wn ( @{$wit->path} ) {
-	    if( $wn eq $ordered_common[$cn] ) {
-		# Set up to look for the next common node, and
-		# start a new row of words.
-		$cn++;
-		push( @$wit_matrix, $row ) if scalar( @$row );
-		$row = [];
-	    }
-	    push( @$row, $wn );
-	}
-	push( @$wit_matrix, $row );  # Push the last row onto the matrix
-
-	# Now we have a matrix per witness, so that each row in the
-	# matrix begins with a common node, and continues with all the
-	# variant words that appear in the witness.  We turn this into
-	# real positions in row,cell format.  But we need some
-	# trickery in order to make sure that each node gets assigned
-	# to only one position.
-
-	foreach my $li ( 1..scalar(@$wit_matrix) ) {
-	    foreach my $di ( 1..scalar(@{$wit_matrix->[$li-1]}) ) {
-		my $reading = $wit_matrix->[$li-1]->[$di-1];
-		my $position = "$li,$di";
-		# If we have seen this node before, we need to compare
-		# its position with what went before.
-		unless( $reading->has_position &&
-			_cmp_position( $position, $reading->position ) < 1 ) {
-		    # The new position ID replaces the old one.
-		    $reading->position( $position );
-		} # otherwise, the old position needs to stay.
-	    }
-	}
+	print STDERR "Calculating positions in " . $wit->sigil . "\n";
+	_update_positions_from_path( $wit->path, @ordered_common );
+	_update_positions_from_path( $wit->uncorrected_path, @ordered_common )
+	    if $wit->has_ante_corr;
+    }
+    
+    # DEBUG
+    foreach my $r ( $self->readings() ) {
+	print STDERR "Reading " . $r->name . "/" . $r->label . " has no position\n"
+	    unless( $r->has_position );
     }
 
     $self->init_lemmata();
 }
 
+sub _update_positions_from_path {
+    my( $path, @ordered_common ) = @_;
+
+    # First we walk the given path, making a matrix for the witness
+    # that corresponds to its eventual position identifier.  Common
+    # nodes always start a new row, and are thus always in the first
+    # column.
+    my $wit_matrix = [];
+    my $cn = 0;  # We should hit the common readings in order.
+    my $row = [];
+    foreach my $wn ( @{$path} ) {
+	if( $wn eq $ordered_common[$cn] ) {
+	    # Set up to look for the next common node, and
+	    # start a new row of words.
+	    $cn++;
+	    push( @$wit_matrix, $row ) if scalar( @$row );
+	    $row = [];
+	}
+	push( @$row, $wn );
+    }
+    push( @$wit_matrix, $row );  # Push the last row onto the matrix
+
+    # Now we have a matrix per witness, so that each row in the
+    # matrix begins with a common node, and continues with all the
+    # variant words that appear in the witness.  We turn this into
+    # real positions in row,cell format.  But we need some
+    # trickery in order to make sure that each node gets assigned
+    # to only one position.
+    
+    foreach my $li ( 1..scalar(@$wit_matrix) ) {
+	foreach my $di ( 1..scalar(@{$wit_matrix->[$li-1]}) ) {
+	    my $reading = $wit_matrix->[$li-1]->[$di-1];
+	    my $position = "$li,$di";
+
+	    # If we have seen this node before, we need to compare
+	    # its position with what went before.
+	    unless( $reading->has_position &&
+		    _cmp_position( $position, $reading->position ) < 1 ) {
+		# The new position ID replaces the old one.
+		$reading->position( $position );
+	    } # otherwise, the old position needs to stay.
+	}
+    }
+}
+
 sub _cmp_position {
     my( $a, $b ) = @_;
     if ( $a && $b ) {
@@ -638,5 +883,14 @@ sub unique_list {
     return values( %h );
 }
 
+sub add_hash_entry {
+    my( $hash, $key, $entry ) = @_;
+    if( exists $hash->{$key} ) {
+	push( @{$hash->{$key}}, $entry );
+    } else {
+	$hash->{$key} = [ $entry ];
+    }
+}
+
 no Moose;
 __PACKAGE__->meta->make_immutable;