From: Tara L Andrews Date: Thu, 14 Jun 2012 17:09:45 +0000 (+0200) Subject: ease validation rules during collation init; fix bug in reading relationship merge X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=10943ab0b79fbd489f6beb3b81a13ed8cbcfafcf;p=scpubgit%2Fstemmatology.git 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 --- 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 --- 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 --- 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 --- 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 ); }