X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FText%2FTradition%2FCollation.pm;h=5b3cd96c2c168abd51cba4998350d1153f7a75f7;hb=9fef629bd3a741a6d74d130f10056898d504fb47;hp=d4395a73492d9865b262e27ae2c22f585269feee;hpb=869a1ada82eb48bc46f2298823fa1ef6f417c671;p=scpubgit%2Fstemmatology.git diff --git a/lib/Text/Tradition/Collation.pm b/lib/Text/Tradition/Collation.pm index d4395a7..5b3cd96 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; @@ -416,6 +417,8 @@ sub merge_readings { $joinstr = $self->wordsep unless defined $joinstr; } $kept_obj->alter_text( join( $joinstr, $kept_obj->text, $del_obj->text ) ); + # Change this reading to a joining one if necessary + $kept_obj->_set_join_next( $del_obj->join_next ); $kept_obj->normal_form( join( $joinstr, $kept_obj->normal_form, $del_obj->normal_form ) ); # Combine the lexemes present in the readings @@ -426,6 +429,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 { @@ -917,13 +973,23 @@ is( scalar $st->collation->readings, $READINGS, "Reparsed collation has all read is( scalar $st->collation->paths, $PATHS, "Reparsed collation has all paths" ); is( scalar $st->collation->relationships, 3, "Reparsed collation has new relationships" ); -# Now add a stemma, write to GraphML, and parse again. +# Now add a stemma, write to GraphML, and look at the output. my $stemma = $tradition->add_stemma( 'dotfile' => 't/data/florilegium.dot' ); is( ref( $stemma ), 'Text::Tradition::Stemma', "Parsed dotfile into stemma" ); is( $tradition->stemmata, 1, "Tradition now has the stemma" ); $graphml = $c->as_graphml; like( $graphml, qr/digraph/, "Digraph declaration exists in GraphML" ); +# Now add a user, write to GraphML, and look at the output. +unlike( $graphml, qr/testuser/, "Test user name does not exist in GraphML yet" ); +my $testuser = Text::Tradition::User->new( + id => 'testuser', password => 'testpass' ); +is( ref( $testuser ), 'Text::Tradition::User', "Created test user object" ); +$testuser->add_tradition( $tradition ); +is( $tradition->user->id, $testuser->id, "Tradition assigned to test user" ); +$graphml = $c->as_graphml; +like( $graphml, qr/testuser/, "Test user name now exists in GraphML" ); + =end testing =cut @@ -994,14 +1060,25 @@ sub as_graphml { next unless $save_types{$attr->type_constraint->name}; $graph_attributes{$attr->name} = $save_types{$attr->type_constraint->name}; } - # Extra custom key for the tradition stemma(ta) - $graph_attributes{'stemmata'} = 'string'; + # Extra custom keys for complex objects that should be saved in some form. + # The subroutine should return a string, or undef/empty. + $graph_attributes{'stemmata'} = sub { + my @stemstrs; + map { push( @stemstrs, $_->editable( {linesep => ''} ) ) } + $self->tradition->stemmata; + join( "\n", @stemstrs ); + }; + $graph_attributes{'user'} = sub { + $self->tradition->user ? $self->tradition->user->id : undef + }; foreach my $datum ( sort keys %graph_attributes ) { $graph_data_keys{$datum} = 'dg'.$gdi++; my $key = $root->addNewChild( $graphml_ns, 'key' ); + my $dtype = ref( $graph_attributes{$datum} ) ? 'string' + : $graph_attributes{$datum}; $key->setAttribute( 'attr.name', $datum ); - $key->setAttribute( 'attr.type', $graph_attributes{$datum} ); + $key->setAttribute( 'attr.type', $dtype ); $key->setAttribute( 'for', 'graph' ); $key->setAttribute( 'id', $graph_data_keys{$datum} ); } @@ -1074,11 +1151,9 @@ sub as_graphml { my $value; if( $datum eq 'version' ) { $value = '3.2'; - } elsif( $datum eq 'stemmata' ) { - my @stemstrs; - map { push( @stemstrs, $_->editable( {linesep => ''} ) ) } - $self->tradition->stemmata; - $value = join( "\n", @stemstrs ); + } elsif( ref( $graph_attributes{$datum} ) ) { + my $sub = $graph_attributes{$datum}; + $value = &$sub(); } elsif( $gattr_from{$datum} eq 'Tradition' ) { $value = $self->tradition->$datum; } else { @@ -1234,7 +1309,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 +1334,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 +1559,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 +1690,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 +1852,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 +1860,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 +1871,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';