X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FText%2FTradition%2FCollation.pm;h=d4395a73492d9865b262e27ae2c22f585269feee;hb=869a1ada82eb48bc46f2298823fa1ef6f417c671;hp=fcdd1ff78959c66662fc5ac00a9481fba6afdf90;hpb=2a8127263ef278f3f14b480a12b84f9aa4f92fdc;p=scpubgit%2Fstemmatology.git

diff --git a/lib/Text/Tradition/Collation.pm b/lib/Text/Tradition/Collation.pm
index fcdd1ff..d4395a7 100644
--- a/lib/Text/Tradition/Collation.pm
+++ b/lib/Text/Tradition/Collation.pm
@@ -274,8 +274,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 +286,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( 
@@ -369,11 +375,23 @@ is( $c->reading('n21p0')->text, 'unto', "Reading n21p0 merged correctly" );
 sub merge_readings {
 	my $self = shift;
 
+	# Sanity check
+	my( $kept_obj, $del_obj, $combine, $combine_char ) = $self->_objectify_args( @_ );
+	my $mergemeta = $kept_obj->is_meta;
+	throw( "Cannot merge meta and non-meta reading" )
+		unless ( $mergemeta && $del_obj->is_meta )
+			|| ( !$mergemeta && !$del_obj->is_meta );
+	if( $mergemeta ) {
+		throw( "Cannot merge with start or end node" )
+			if( $kept_obj eq $self->start || $kept_obj eq $self->end
+				|| $del_obj eq $self->start || $del_obj eq $self->end );
+	}
 	# We only need the IDs for adding paths to the graph, not the reading
 	# objects themselves.
-    my( $kept, $deleted, $combine, $combine_char ) = $self->_stringify_args( @_ );
+	my $kept = $kept_obj->id;
+	my $deleted = $del_obj->id;
 	$self->_graphcalc_done(0);
-
+	
     # The kept reading should inherit the paths and the relationships
     # of the deleted reading.
 	foreach my $path ( $self->sequence->edges_at( $deleted ) ) {
@@ -387,18 +405,23 @@ sub merge_readings {
 		@wits{keys %$fwits} = values %$fwits;
 		$self->sequence->set_edge_attributes( @vector, \%wits );
 	}
-	$self->relations->merge_readings( $kept, $deleted, $combine_char );
+	$self->relations->merge_readings( $kept, $deleted, $combine );
 	
 	# Do the deletion deed.
 	if( $combine ) {
-		my $kept_obj = $self->reading( $kept );
-		my $del_obj = $self->reading( $deleted );
+		# 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 ) );
+		$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 );
 }
@@ -560,7 +583,8 @@ sub as_svg {
     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 || $opts->{'nocalc'} );
+    $self->calculate_ranks() 
+    	unless( $self->_graphcalc_done || $opts->{'nocalc'} || !$self->linear );
     if( !$self->has_cached_svg || $opts->{'recalc'}	|| $want_subgraph ) {        
 		my @cmd = qw/dot -Tsvg/;
 		my( $svg, $err );
@@ -712,23 +736,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 ) {
@@ -817,6 +846,7 @@ sub _path_display_label {
 	
 	# See if we are in a majority situation.
 	my $maj = scalar( $self->tradition->witnesses ) * 0.6;
+	$maj = $maj > 5 ? $maj : 5;
 	if( scalar keys %wits > $maj ) {
 		unshift( @disp_ac, 'majority' );
 		return join( ', ', @disp_ac );
@@ -1077,6 +1107,8 @@ sub as_graphml {
 				# serialize them. Otherwise set nval to undef so that the
 				# key is excluded from this reading.
         		$nval = $nval ? $n->_serialize_lexemes : undef;
+        	} elsif( $d eq 'normal_form' && $n->normal_form eq $n->text ) {
+        		$nval = undef;
         	}
         	if( $rankoffset && $d eq 'rank' && $n ne $self->start ) {
         		# Adjust the ranks within the subgraph.
@@ -1520,14 +1552,8 @@ sub calculate_ranks {
 
     # 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( $self->equivalence_graph, 
-        	$node_ranks, @curr_origin );
-    }
+    my ( $node_ranks, $rank_nodes ) = $self->relations->equivalence_ranks();
+
     # Transfer our rankings from the topological graph to the real one.
     foreach my $r ( $self->readings ) {
         if( defined $node_ranks->{$self->equivalence( $r->id )} ) {
@@ -1557,41 +1583,6 @@ sub calculate_ranks {
 	$self->_graphcalc_done(1);
 }
 
-sub _assign_rank {
-    my( $graph, $node_ranks, @current_nodes ) = @_;
-    # Look at each of the children of @current_nodes.  If all the child's 
-    # parents have a rank, assign it the highest rank + 1 and add it to 
-    # @next_nodes.  Otherwise skip it; we will return when the highest-ranked
-    # parent gets a rank.
-    my @next_nodes;
-    foreach my $c ( @current_nodes ) {
-        warn "Current reading $c has no rank!"
-            unless exists $node_ranks->{$c};
-        # print STDERR "Looking at child of node $c, rank " 
-        #     . $node_ranks->{$c} . "\n";
-        foreach my $child ( $graph->successors( $c ) ) {
-            next if exists $node_ranks->{$child};
-            my $highest_rank = -1;
-            my $skip = 0;
-            foreach my $parent ( $graph->predecessors( $child ) ) {
-                if( exists $node_ranks->{$parent} ) {
-                    $highest_rank = $node_ranks->{$parent} 
-                        if $highest_rank <= $node_ranks->{$parent};
-                } else {
-                    $skip = 1;
-                    last;
-                }
-            }
-            next if $skip;
-            my $c_rank = $highest_rank + 1;
-            # print STDERR "Assigning rank $c_rank to node $child \n";
-            $node_ranks->{$child} = $c_rank;
-            push( @next_nodes, $child );
-        }
-    }
-    return @next_nodes;
-}
-
 sub _clear_cache {
 	my $self = shift;
 	$self->wipe_svg if $self->has_cached_svg;
@@ -1614,8 +1605,17 @@ sub flatten_ranks {
         next unless $rdg->has_rank;
         my $key = $rdg->rank . "||" . $rdg->text;
         if( exists $unique_rank_rdg{$key} ) {
+        	# Make sure they don't have different grammatical forms
+			my $ur = $unique_rank_rdg{$key};
+			if( $rdg->disambiguated && $ur->disambiguated ) {
+				my $rform = join( '//', map { $_->form->to_string } $rdg->lexemes );
+				my $uform = join( '//', map { $_->form->to_string } $ur->lexemes );
+				next unless $rform eq $uform;
+			} elsif( $rdg->disambiguated xor $ur->disambiguated ) {
+				next;
+			}
             # Combine!
-        	# print STDERR "Combining readings at same rank: $key\n";
+        	#print STDERR "Combining readings at same rank: $key\n";
         	$changed = 1;
             $self->merge_readings( $unique_rank_rdg{$key}, $rdg );
             # TODO see if this now makes a common point.