make the rest of the tests work with the new Witness

[scpubgit/stemmatology.git] / lib / Text / Tradition / Parser / Tabular.pm

diff --git a/lib/Text/Tradition/Parser/Tabular.pm b/lib/Text/Tradition/Parser/Tabular.pm
index 4b53e3c..8783ff1 100644 (file)
--- a/lib/Text/Tradition/Parser/Tabular.pm
+++ b/lib/Text/Tradition/Parser/Tabular.pm
@@ -2,7 +2,7 @@ package Text::Tradition::Parser::Tabular;
 
 use strict;
 use warnings;
-use Text::CSV_XS;
+use Text::CSV;
 
 =head1 NAME
 
@@ -100,7 +100,7 @@ foreach my $k ( keys %seen_wits ) {
                ok( $wit->has_layertext, "Witness $k has an a.c. version" );
                my $origtext = join( ' ', @{$wit->layertext} );
                my $acsig = $wit->sigil . $t->collation->ac_label;
-               my $graphtext = $t->collation->path_text( $acsig, $wit->sigil );
+               my $graphtext = $t->collation->path_text( $acsig );
                is( $graphtext, $origtext, "Collation matches original a.c. for witness $k" );
        } else {
                ok( !$wit->is_layered, "Witness $k not marked as layered" );
@@ -115,10 +115,14 @@ foreach my $k ( keys %seen_wits ) {
 sub parse {
     my( $tradition, $opts ) = @_;
     my $c = $tradition->collation; # shorthand
-    my $csv = Text::CSV_XS->new( { 
-        binary => 1, # binary for UTF-8
-        sep_char => exists $opts->{'sep_char'} ? $opts->{'sep_char'} : "\t" } 
-        );
+    my $csv_options = { 'binary' => 1 };
+    $csv_options->{'sep_char'} = $opts->{'sep_char'} || "\t";
+    if( $csv_options->{'sep_char'} eq "\t" ) {
+       # If it is really tab separated, nothing is an escape char.
+       $csv_options->{'quote_char'} = undef;
+       $csv_options->{'escape_char'} = undef;
+    }
+    my $csv = Text::CSV->new( $csv_options );
     
     my $alignment_table;
     if( exists $opts->{'string' } ) {
@@ -147,14 +151,18 @@ sub parse {
     # Set up the witnesses we find in the first line
     my @witnesses;
     my %ac_wits;  # Track layered witness -> main witness mapping
+    my $aclabel = $c->ac_label;
     foreach my $sigil ( @{$alignment_table->[0]} ) {
-        my $wit = $tradition->add_witness( 'sigil' => $sigil );
-        $wit->path( [ $c->start ] );
-        push( @witnesses, $wit );
-        my $aclabel = $c->ac_label;
         if( $sigil =~ /^(.*)\Q$aclabel\E$/ ) {
+               # Sanitize the sigil name to an XML name
+               $sigil = $1 . '_layered';
             $ac_wits{$sigil} = $1;
         }
+        my $wit = $tradition->add_witness( 
+               'sigil' => $sigil, 'sourcetype' => 'collation' );
+        $wit->path( [ $c->start ] );
+        push( @witnesses, $wit );
+        my $aclabel = $c->ac_label;
     }
     
     # Save the original witness text sequences. Have to loop back through
@@ -173,7 +181,7 @@ sub parse {
     # add them to the witness paths.
     foreach my $idx ( 1 .. $#{$alignment_table} ) {
         my $row = $alignment_table->[$idx];
-        my $nodes = make_nodes( $c, $row, $idx );
+        my $nodes = _make_nodes( $c, $row, $idx );
         foreach my $w ( 0 .. $#{$row} ) {
             # push the appropriate node onto the appropriate witness path
             my $word = $row->[$w];
@@ -209,6 +217,7 @@ sub parse {
        my $ac_wit = $tradition->witness( $a );
         my $main_wit = $tradition->witness( $ac_wits{$a} );
         next unless $main_wit;
+        $main_wit->is_layered(1);
         $main_wit->uncorrected_path( $ac_wit->path );
         $tradition->del_witness( $ac_wit );
     }
@@ -219,13 +228,35 @@ sub parse {
        foreach my $rdg ( grep { $_->is_lacuna } $c->readings ) {
                $c->del_reading( $rdg ) unless $c->reading_witnesses( $rdg );
        }
+       
+       # Do a consistency check.
+       foreach my $wit ( $tradition->witnesses ) {
+               my $pathtext = $c->path_text( $wit->sigil );
+               my $origtext = join( ' ', @{$wit->text} );
+               warn "Text differs for witness " . $wit->sigil 
+                       unless $pathtext eq $origtext;
+               if( $wit->is_layered ) {
+                       $pathtext = $c->path_text( $wit->sigil.$c->ac_label );
+                       $origtext = join( ' ', @{$wit->layertext} );
+                       warn "Ante-corr text differs for witness " . $wit->sigil
+                               unless $pathtext eq $origtext;
+               } else {
+                       warn "Text " . $wit->sigil . " has a layered text but is not marked as layered"
+                               if $wit->has_layertext;
+               }
+       }
+       
+       # Note that our ranks and common readings are set.
+       $c->_graphcalc_done(1);
 }
 
-sub make_nodes {
+sub _make_nodes {
     my( $collation, $row, $index ) = @_;
     my %unique;
+    my $commonctr = 0; # Holds the number of unique readings + gaps, ex. lacunae.
     foreach my $w ( @$row ) {
         $unique{$w} = 1 if $w;
+        $commonctr +=1 unless ( $w && $w eq '#LACUNA#' );
     }
     my $ctr = 1;
     foreach my $w ( keys %unique ) {
@@ -234,11 +265,33 @@ sub make_nodes {
                'rank' => $index,
                'text' => $w,
                };
-       $rargs->{'is_lacuna'} = 1 if $w eq '#LACUNA#';
+       if( $w eq '#LACUNA#' ) {
+               $rargs->{'is_lacuna'} = 1;
+       } elsif( $commonctr == 1 ) {
+               $rargs->{'is_common'} = 1;
+       }
         my $r = $collation->add_reading( $rargs );
         $unique{$w} = $r;
         $ctr++;
     }
+    # Collate this sequence of readings via a single 'collation' relationship.
+    my @rankrdgs = values %unique;
+    my $collation_rel;
+    while( @rankrdgs ) {
+       my $r = shift @rankrdgs;
+       next if $r->is_meta;
+       foreach my $nr ( @rankrdgs ) {
+               if( $collation_rel ) {
+                       $collation->add_relationship( $r, $nr, $collation_rel );
+               } else {
+                       $collation->add_relationship( $r, $nr, 
+                               { 'type' => 'collated', 
+                                 'annotation' => "Parsed together for rank $index" } );
+                       $collation_rel = $collation->get_relationship( $r, $nr );
+               }
+       }
+    }
+    
     return \%unique;
 }