ease validation rules during collation init; fix bug in reading relationship merge

diff --git a/lib/Text/Tradition.pm b/lib/Text/Tradition.pm
index 62b50f4..9a0f8b5 100644 (file)
--- a/lib/Text/Tradition.pm
+++ b/lib/Text/Tradition.pm
@@ -54,6 +54,13 @@ has 'stemmata' => (
        default => sub { [] },
        );
   
+has 'initialized' => (
+       is => 'ro',
+       isa => 'Bool',
+       default => undef,
+       writer => '_init_done',
+       ); 
+
 # Create the witness before trying to add it
 around 'add_witness' => sub {
     my $orig = shift;
@@ -288,6 +295,7 @@ sub BUILD {
             $mod->can('parse')->( $self, $init_args );
         }
     }
+    $self->_init_done( 1 );
     return $self;
 }
 

diff --git a/lib/Text/Tradition/Collation.pm b/lib/Text/Tradition/Collation.pm
index fcdd1ff..3c65b4c 100644 (file)
--- a/lib/Text/Tradition/Collation.pm
+++ b/lib/Text/Tradition/Collation.pm
@@ -373,7 +373,7 @@ sub merge_readings {
        # objects themselves.
     my( $kept, $deleted, $combine, $combine_char ) = $self->_stringify_args( @_ );
        $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,7 +387,7 @@ 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 ) {

diff --git a/lib/Text/Tradition/Collation/RelationshipStore.pm b/lib/Text/Tradition/Collation/RelationshipStore.pm
index bbfc50d..40aa684 100644 (file)
--- a/lib/Text/Tradition/Collation/RelationshipStore.pm
+++ b/lib/Text/Tradition/Collation/RelationshipStore.pm
@@ -564,10 +564,12 @@ sub relationship_valid {
     my( $self, $source, $target, $rel, $mustdrop ) = @_;
     $mustdrop = [] unless $mustdrop; # in case we were passed nothing
     my $c = $self->collation;
+    ## Assume validity is okay if we are initializing from scratch.
+    return ( 1, "initializing" ) unless $c->tradition->initialized;
+    
     if ( $rel eq 'transposition' || $rel eq 'repetition' ) {
                # Check that the two readings do (for a repetition) or do not (for
                # a transposition) appear in the same witness.
-               # TODO this might be called before witness paths are set...
                my %seen_wits;
                map { $seen_wits{$_} = 1 } $c->reading_witnesses( $source );
                foreach my $w ( $c->reading_witnesses( $target ) ) {
@@ -750,7 +752,7 @@ sub merge_readings {
                $rel = $self->get_relationship( @$edge );
                $self->_set_relationship( $rel, @vector );
        }
-       $self->_make_equivalence( $deleted, $kept );
+       $self->_make_equivalence( $deleted, $kept, 1 );
 }
 
 ### Equivalence logic
@@ -807,27 +809,33 @@ sub _is_disconnected {
 
 # Equate two readings in the equivalence graph
 sub _make_equivalence {
-       my( $self, $source, $target ) = @_;
+       my( $self, $source, $target, $removing ) = @_;
        # Get the source equivalent readings
        my $seq = $self->equivalence( $source );
        my $teq = $self->equivalence( $target );
        # Nothing to do if they are already equivalent...
        return if $seq eq $teq;
-       my $sourcepool = $self->eqreadings( $seq );
+       # Get the readings equivalent to source
+       my @sourcepool = @{$self->eqreadings( $seq )};
+       # If we are removing the source reading entirely, don't push
+       # it into the target pool.
+       @sourcepool = grep { $_ ne $seq } @sourcepool if $removing;
        # and add them to the target readings.
-       push( @{$self->eqreadings( $teq )}, @$sourcepool );
-       map { $self->set_equivalence( $_, $teq ) } @$sourcepool;
+       push( @{$self->eqreadings( $teq )}, @sourcepool );
+       map { $self->set_equivalence( $_, $teq ) } @sourcepool;
        # Then merge the nodes in the equivalence graph.
        foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
-               $self->equivalence_graph->add_edge( $pred, $teq );
+               $self->equivalence_graph->add_edge( $pred, $teq )
+                       unless $teq eq $pred;
        }
        foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
-               $self->equivalence_graph->add_edge( $teq, $succ );
+               $self->equivalence_graph->add_edge( $teq, $succ )
+                       unless $teq eq $succ;
        }
        $self->equivalence_graph->delete_vertex( $seq );
        # TODO enable this after collation parsing is done
-#      throw( "Graph got disconnected making $source / $target equivalence" )
-#              if $self->_is_disconnected;
+       throw( "Graph got disconnected making $source / $target equivalence" )
+               if $self->_is_disconnected && $self->collation->tradition->initialized;
 }
 
 =head2 test_equivalence
@@ -964,8 +972,8 @@ sub _break_equivalence {
                }
        }
        # TODO enable this after collation parsing is done
-#      throw( "Graph got disconnected breaking $source / $target equivalence" )
-#              if $self->_is_disconnected;
+       throw( "Graph got disconnected breaking $source / $target equivalence" )
+               if $self->_is_disconnected && $self->collation->tradition->initialized;
 }
 
 sub _find_equiv_without {

diff --git a/script/make_tradition.pl b/script/make_tradition.pl
index 591e56e..50aab73 100755 (executable)
--- a/script/make_tradition.pl
+++ b/script/make_tradition.pl
@@ -13,10 +13,11 @@ binmode STDERR, ":utf8";
 binmode STDOUT, ":utf8";
 eval { no warnings; binmode $DB::OUT, ":utf8"; };
 
-my( $informat, $inbase, $outformat, $help, $language, $name, $sep, $stemmafile, 
-       $dsn, $dbuser, $dbpass, $from, $to, $dbid ) 
-    = ( '', '', '', '', 'Default', 'Tradition', "\t", '',
-       "dbi:SQLite:dbname=stemmaweb/db/traditions.db", undef, undef, undef, undef, undef );
+# Variables with defaults
+my( $informat, $outformat, $language, $name, $sep, $dsn )  = ( '', '', 'Default', 
+       'Tradition', "\t", "dbi:SQLite:dbname=stemmaweb/db/traditions.db" );
+# Variables with no default
+my( $inbase, $help, $stemmafile,  $dbuser, $dbpass, $from, $to, $dbid, $debug );
 
 GetOptions( 'i|in=s'    => \$informat,
             'b|base=s'  => \$inbase,
@@ -32,6 +33,7 @@ GetOptions( 'i|in=s'    => \$informat,
             'sep=s'            => \$sep,
             'dsn=s'            => \$dsn,
            'dbid=s'    => \$dbid,
+               'debug'     => \$debug
     );
 
 if( $help ) {
@@ -111,6 +113,7 @@ if( $outformat eq 'stemma' ) {
     my $opts = {};
     $opts->{'from'} = $from if $from;
     $opts->{'to'} = $to if $to;
+    $opts->{'nocalc'} = 1 if $debug;
     print $tradition->collation->$output( $opts );
 }