7 use Text::Tradition::Stemma;
9 binmode STDERR, ":utf8";
10 binmode STDOUT, ":utf8";
11 eval { no warnings; binmode $DB::OUT, ":utf8"; };
17 # Parse the tradition data
21 open( INFILE, "$input" ) or die "Could not read $input";
22 binmode INFILE, ':utf8';
25 $input = join( '', @lines );
27 my %args = ( $informat => $input,
28 'linear' => $linear );
29 $args{'base'} = $inbase if $inbase;
30 my $tradition = Text::Tradition->new( %args );
32 # Parse the stemma hypothesis
33 my $stemma = Text::Tradition::Stemma->new(
34 'collation' => $tradition->collation,
38 # We have the collation, so get the alignment table with witnesses in rows.
40 my $all_wits_table = $tradition->collation->make_alignment_table( 1 );
42 # For each column in the alignment table, we want to see if the existing
43 # groupings of witnesses match our stemma hypothesis. First let's just go
44 # through the groupings.
46 # Strip the list of sigla and save it for correlation to the readings.
47 my $col_wits = shift @$all_wits_table;
49 # For each column in the table, group the readings by witness.
52 foreach my $i ( 0 .. $#$all_wits_table ) {
54 my $col_rdgs = shift @$all_wits_table;
55 foreach my $j ( 0 .. $#{$col_rdgs} ) {
56 my $rdg = $col_rdgs->[$j];
57 $rdg = '' unless $rdg; # We care about empty readings
58 $rdg = undef if $rdg eq '#LACUNA#'; # ... unless they're lacunas
60 $rdg_wits->{$rdg} = [] unless $rdg_wits->{$rdg};
61 add_variant_wit( $rdg_wits->{$rdg}, $col_wits->[$j] );
65 my( $groups, $readings ) = useful_variant( $rdg_wits );
66 next unless $groups && $readings;
68 # For all the groups with more than one member, make a group that contains
69 # all contiguous vertices to connect them.
70 # TODO Need to do pairwise comparison of groups - a variant location can
71 # have both coincidental and genealogical variants!
74 foreach my $g ( @$groups ) {
75 my @members = split( /,/, $g );
76 next unless @members > 1;
77 map { $contig{$_} = $g } @members;
78 my $curr = pop @members;
79 foreach my $m ( @members ) {
80 foreach my $v ( $stemma->apsp->path_vertices( $curr, $m ) ) {
81 $contig{$v} = $g unless exists $contig{$v};
82 next if $contig{$v} eq $g;
83 # print STDERR "Conflict at $v between group $g and group "
84 # . $contig{$v} . "\n";
89 print join( " / ", @$groups ) . ' - ' . join( " / ", @$readings ) . ' - ';
90 print $conflict ? "coincidental" : "genealogical";
95 print "Found $useful_vars useful variants\n";
97 # Add the variant, subject to a.c. representation logic.
98 # This assumes that we will see the 'main' version before the a.c. version.
100 my( $arr, $wit ) = @_;
101 my $acstr = $tradition->collation->ac_label;
103 if( $wit =~ /^(.*)\Q$acstr\E$/ ) {
105 $skip = grep { $_ =~ /^\Q$real\E$/ } @$arr;
107 push( @$arr, $wit ) unless $skip;
110 # Return an answer if the variant is useful, i.e. if there are at least 2 variants
111 # with at least 2 witnesses each.
113 my( $readings ) = @_;
114 my $total = keys %$readings;
115 foreach my $var ( keys %$readings ) {
116 $total-- if @{$readings->{$var}} == 1;
118 return( undef, undef ) if $total <= 1;
119 my( $groups, $text );
120 foreach my $var ( keys %$readings ) {
121 push( @$groups, join( ',', @{$readings->{$var}} ) );
122 push( @$text, $var );
124 return( $groups, $text );