lib/Text/Tradition/Parser/BaseText.pm

   1 package Text::Tradition::Parser::BaseText;
   2
   3 use strict;
   4 use warnings;
   5 use Module::Load;
   6 use TryCatch;
   7 use Text::Tradition::Parser::Util qw( collate_variants cmp_str
   8         check_for_repeated add_hash_entry );
   9
  10 =head1 NAME
  11
  12 Text::Tradition::Parser::BaseText
  13
  14 =head1 SYNOPSIS
  15
  16 use Text::Tradition::Parser::BaseText qw( merge_base );
  17 merge_base( $graph, 'reference.txt', @apparatus_entries )
  18
  19 =head1 DESCRIPTION
  20
  21 For an overview of the package, see the documentation for the
  22 Text::Tradition module.
  23
  24 This module is meant for use with certain of the other Parser classes
  25 - whenever a list of variants is given with reference to a base text,
  26 these must be joined into a single collation.  The parser should
  27 therefore make a list of variants and their locations, and BaseText
  28 will join those listed variants onto the reference text.
  29
  30 =head1 SUBROUTINES
  31
  32 =over
  33
  34 =item B<parse>
  35
  36 parse( $graph, $opts );
  37
  38 Takes an initialized graph and a hashref of options, which must include:
  39 - 'base' - the base text referenced by the variants
  40 - 'format' - the format of the variant list
  41 - 'data' - the variants, in the given format.
  42
  43 =cut
  44
  45 sub parse {
  46     my( $tradition, $opts ) = @_;
  47
  48     my $format_mod = 'Text::Tradition::Parser::' . $opts->{'input'};
  49     load( $format_mod );
  50     # TODO Handle a string someday if we ever have a format other than KUL
  51     my @apparatus_entries = $format_mod->can('read')->( $opts );
  52     merge_base( $tradition->collation, $opts, @apparatus_entries );
  53 }
  54
  55 =item B<merge_base>
  56
  57 merge_base( $graph, 'reference.txt', @apparatus_entries )
  58
  59 Takes three arguments: a newly-initialized Text::Tradition::Graph
  60 object, a text file containing the reference text, and a list of
  61 variants (apparatus entries).  Adds the base text to the graph, and
  62 joins the variants to that.
  63
  64 The list of variants is an array of hash references; each hash takes
  65 the form
  66  { '_id' => line reference,
  67    'rdg_0' => lemma reading,
  68    'rdg_1' => first variant,
  69    ...  # and so on until all distinct readings are listed
  70    'WitnessA' => 'rdg_0',
  71    'WitnessB' => 'rdg_1',
  72    ...  # and so on until all witnesses are listed with their readings
  73  }
  74
  75 Any hash key that is not of the form /^rdg_\d+$/ and that does not
  76 begin with an underscore is assumed to be a witness name.  Any 'meta'
  77 information to be passed must be passed in a key with a leading
  78 underscore in its name.
  79
  80 =cut
  81
  82 my $SHORTEND = ''; # Debug var - set this to limit the number of lines parsed
  83
  84 my %base_text_index;
  85 my $edits_required = {};
  86
  87 # edits_required -> wit -> [ { start_idx, end_idx, items } ]
  88
  89 sub merge_base {
  90     my( $collation, $opts, @app_entries ) = @_;
  91     my @base_line_starts = read_base( $opts->{'base'}, $collation );
  92
  93     my %all_witnesses;
  94     foreach my $app ( @app_entries ) {
  95         my( $line, $num ) = split( /\./, $app->{_id} );
  96         # DEBUG with a short graph
  97         last if $SHORTEND && $line > $SHORTEND;
  98         # DEBUG for problematic entries
  99         my $scrutinize = '';
 100         my $first_line_reading = $base_line_starts[ $line ];
 101         my $too_far = $base_line_starts[ $line+1 ];
 102
 103         my $lemma = $app->{rdg_0};
 104         my $seq = 1;
 105         # Is this the Nth occurrence of this reading in the line?
 106         if( $lemma =~ s/(_)?(\d)$// ) {
 107             $seq = $2;
 108         }
 109         my @lemma_words = split( /\s+/, $lemma );
 110
 111         # Now search for the lemma words within this line.
 112         my $lemma_start = $first_line_reading;
 113         my $lemma_end;
 114         my %seen;
 115         while( $lemma_start ne $too_far ) {
 116             # Loop detection
 117             if( $seen{ $lemma_start->id() } ) {
 118                 warn "Detected loop at " . $lemma_start->id() .
 119                     ", ref $line,$num";
 120                 last;
 121             }
 122             $seen{ $lemma_start->id() } = 1;
 123
 124             # Try to match the lemma.
 125             my $unmatch = 0;
 126             print STDERR "Matching " . cmp_str( $lemma_start) . " against " .
 127                 $lemma_words[0] . "...\n"
 128                 if "$line.$num" eq $scrutinize;
 129             if( cmp_str( $lemma_start ) eq $lemma_words[0] ) {
 130                 # Skip it if we need a match that is not the first.
 131                 if( --$seq < 1 ) {
 132                     # Now we have to compare the rest of the words here.
 133                     if( scalar( @lemma_words ) > 1 ) {
 134                         my $next_reading =
 135                             $collation->next_reading( $lemma_start );
 136                         foreach my $w ( @lemma_words[1..$#lemma_words] ) {
 137                             printf STDERR "Now matching %s against %s\n",
 138                                     cmp_str($next_reading), $w
 139                                 if "$line.$num" eq $scrutinize;
 140                             if( $w ne cmp_str($next_reading) ) {
 141                                 $unmatch = 1;
 142                                 last;
 143                             } else {
 144                                 $lemma_end = $next_reading;
 145                                 $next_reading =
 146                                     $collation->next_reading( $lemma_end );
 147                             }
 148                         }
 149                     } else {
 150                         $lemma_end = $lemma_start;
 151                     }
 152                 } else {
 153                     $unmatch = 1;
 154                 }
 155             }
 156             last unless ( $unmatch || !defined( $lemma_end ) );
 157             $lemma_end = undef;
 158             $lemma_start = $collation->next_reading( $lemma_start );
 159         }
 160
 161         unless( $lemma_end ) {
 162             warn "No match found for @lemma_words at $line.$num";
 163             next;
 164         }
 165
 166         # Now we have found the lemma; we will record an 'edit', in
 167         # terms of a splice operation, for each subsequent reading.
 168         # We also note which witnesses take the given edit.
 169
 170         my @lemma_set = $collation->reading_sequence( $lemma_start,
 171                                                       $lemma_end );
 172         my @reading_sets = [ @lemma_set ];
 173
 174         # For each reading that is not rdg_0, we create the variant
 175         # reading nodes, and store the range as an edit operation on
 176         # the base text.
 177         my $variant_objects;
 178         my %pc_seen; # Keep track of mss with explicit post-corr data
 179         foreach my $k ( grep { /^rdg/ } keys( %$app ) ) {
 180             my @mss = grep { $app->{$_} eq $k } keys( %$app );
 181
 182             # Keep track of what witnesses we have seen.
 183             @all_witnesses{ @mss } = ( 1 ) x scalar( @mss );
 184             # Keep track of which witnesses bear corrected readings here.
 185             foreach my $m ( @mss ) {
 186                 my $base = _is_post_corr( $m );
 187                 next unless $base;
 188                 $pc_seen{$base} = 1;
 189             }
 190             next if $k eq 'rdg_0';
 191
 192             # Parse the variant into reading tokens.
 193             # TODO don't hardcode the reading split operation
 194             my @variant = split( /\s+/, $app->{$k} );
 195             @variant = () if $app->{$k} eq '/'; # This is an omission.
 196
 197             my @variant_readings;
 198             my $ctr = 0;
 199             foreach my $vw ( @variant ) {
 200                 my $vwname = "$k/$line.$num.$ctr"; $ctr++;
 201                 my $vwreading = $collation->add_reading( {
 202                         'id' => $vwname,
 203                         'text' => $vw } );
 204                 push( @variant_readings, $vwreading );
 205             }
 206
 207             $variant_objects->{$k} = { 'mss' => \@mss,
 208                                        'reading' => \@variant_readings,
 209             };
 210             push( @reading_sets, \@variant_readings );
 211         }
 212
 213         # Now collate and collapse the identical readings within the
 214         # collated sets.  Modifies the reading sets that were passed.
 215         collate_variants( $collation, @reading_sets );
 216
 217         # Record any stated relationships between the nodes and the lemma.
 218         set_relationships( $collation, $app, \@lemma_set, $variant_objects );
 219
 220         # Now create the splice-edit objects that will be used
 221         # to reconstruct each witness.
 222
 223         foreach my $rkey ( keys %$variant_objects ) {
 224             # Object is argument list for splice, so:
 225             # offset, length, replacements
 226             my $edit_object = [ $lemma_start->id,
 227                                 scalar( @lemma_set ),
 228                                 $variant_objects->{$rkey}->{reading} ];
 229             foreach my $ms ( @{$variant_objects->{$rkey}->{mss}} ) {
 230                 # Is this a p.c. entry?
 231                 my $base = _is_post_corr( $ms );
 232                 if( $base ) { # this is a post-corr witness
 233                     my $pc_key = $base . "_post";
 234                     add_hash_entry( $edits_required, $pc_key, $edit_object );
 235                 } else { # this is an ante-corr witness
 236                     my $pc_key = $ms . "_post";
 237                     add_hash_entry( $edits_required, $ms, $edit_object );
 238                     unless( $pc_seen{$ms} ) {
 239                         # If this witness carries no correction, add this
 240                         # same object to its post-corrected state.
 241                         add_hash_entry( $edits_required, $pc_key,
 242                                          $edit_object );
 243                     }
 244                 }
 245             }
 246         }
 247     } # Finished going through the apparatus entries
 248
 249     # Now make the witness objects, and create their text sequences
 250     foreach my $w ( grep { $_ !~ /_post$/ } keys %$edits_required ) {
 251         print STDERR "Creating witness $w\n";
 252         my $witness_obj = $collation->tradition->add_witness(
 253                 sigil => $w, sourcetype => 'collation' );
 254         my $debug; #  = $w eq 'Vb11';
 255         my @ante_corr_seq = apply_edits( $collation, $edits_required->{$w}, $debug );
 256         my @post_corr_seq = apply_edits( $collation, $edits_required->{$w."_post"}, $debug )
 257             if exists( $edits_required->{$w."_post"} );
 258
 259         my @repeated = check_for_repeated( @ante_corr_seq );
 260         warn "Repeated elements @repeated in $w a.c."
 261             if @repeated;
 262         @repeated = check_for_repeated( @post_corr_seq );
 263         warn "Repeated elements @repeated in $w p.c."
 264             if @repeated;
 265
 266         # Now save these paths in my witness object
 267         if( @post_corr_seq ) {
 268             $witness_obj->path( \@post_corr_seq );
 269             $witness_obj->uncorrected_path( \@ante_corr_seq );
 270         } else {
 271             $witness_obj->path( \@ante_corr_seq );
 272         }
 273     }
 274
 275     # Now remove our 'base text' edges, which is to say, the only
 276     # ones we have created so far.  Also remove any unwitnessed
 277     # lemma nodes (TODO unless we are treating base as witness)
 278     foreach ( $collation->paths() ) {
 279         $collation->del_path( $_, $collation->baselabel );
 280     }
 281
 282     ### HACKY HACKY Do some one-off path corrections here.
 283     if( $opts->{'input'} eq 'KUL' ) {
 284                 require 'data/boodts/s158.HACK';
 285                 KUL::HACK::pre_path_hack( $collation );
 286         }
 287
 288     # Now walk paths and calculate positional rank.
 289     $collation->make_witness_paths();
 290     # Now delete any orphaned readings.
 291         foreach my $r ( $collation->sequence->isolated_vertices ) {
 292                 print STDERR "Deleting unconnected reading $r / " .
 293                         $collation->reading( $r )->text . "\n";
 294                 $collation->del_reading( $r );
 295         }
 296
 297     KUL::HACK::post_path_hack( $collation ) if $opts->{'input'} eq 'KUL';
 298     # Have to check relationship validity at this point, because before that
 299     # we had no paths.
 300 #     foreach my $rel ( $collation->relationships ) {
 301 #         next unless $rel->equal_rank;
 302 #         unless( Text::Tradition::Collation::relationship_valid( $rel->from, $rel->to ) ) {
 303 #             warn sprintf( "Relationship type %s between %s and %s is invalid, deleting",
 304 #                             $rel->type, $rel->from->id, $rel->to->id );
 305 #         }
 306 #     }
 307     $collation->calculate_common_readings(); # will implicitly rank
 308 }
 309
 310 =item B<read_base>
 311
 312 my @line_beginnings = read_base( 'reference.txt', $collation );
 313
 314 Takes a text file and a (presumed empty) collation object, adds the
 315 words as simple linear readings to the collation, and returns a
 316 list of readings that represent the beginning of lines. This collation
 317 is now the starting point for application of apparatus entries in
 318 merge_base, e.g. from a CSV file or a Classical Text Editor file.
 319
 320 =cut
 321
 322 sub read_base {
 323     my( $base_file, $collation ) = @_;
 324
 325     # This array gives the first reading for each line.  We put the
 326     # common starting point in line zero.
 327     my $last_reading = $collation->start;
 328     $base_text_index{$last_reading->id} = 0;
 329     my $lineref_array = [ $last_reading ]; # There is no line zero.
 330
 331     open( BASE, $base_file ) or die "Could not open file $base_file: $!";
 332     my $i = 1;
 333     while(<BASE>) {
 334         # Make the readings, and connect them up for the base, but
 335         # also save the first reading of each line in an array for the
 336         # purpose.
 337         # TODO use configurable reading separator
 338         chomp;
 339         my @words = split;
 340         my $started = 0;
 341         my $wordref = 0;
 342         my $lineref = scalar @$lineref_array;
 343         last if $SHORTEND && $lineref > $SHORTEND;
 344         foreach my $w ( @words ) {
 345             my $readingref = join( ',', $lineref, ++$wordref );
 346             my $reading = $collation->add_reading( { id => $readingref, text => $w } );
 347             unless( $started ) {
 348                 push( @$lineref_array, $reading );
 349                 $started = 1;
 350             }
 351             # Add edge paths in the graph, for easier tracking when
 352             # we start applying corrections.  These paths will be
 353             # removed when we're done.
 354             my $path = $collation->add_path( $last_reading, $reading,
 355                                              $collation->baselabel );
 356             $last_reading = $reading;
 357
 358             # Note an array index for the reading, for later correction splices.
 359             $base_text_index{$readingref} = $i++;
 360         }
 361     }
 362     close BASE;
 363     # Ending point for all texts
 364     $collation->add_path( $last_reading, $collation->end, $collation->baselabel );
 365     push( @$lineref_array, $collation->end );
 366     $base_text_index{$collation->end->id} = $i;
 367
 368     return( @$lineref_array );
 369 }
 370
 371 sub set_relationships {
 372     my( $collation, $app, $lemma, $variants ) = @_;
 373     foreach my $rkey ( keys %$variants ) {
 374         my $var = $variants->{$rkey}->{'reading'};
 375         my $type = $app->{sprintf( "_%s_type", $rkey )};
 376         my $noncorr = $app->{sprintf( "_%s_non_corr", $rkey )};
 377         my $nonindep = $app->{sprintf( "_%s_non_indep", $rkey )};
 378
 379         my %rel_options = ();
 380         $rel_options{'non_correctable'} = $noncorr if $noncorr && $noncorr =~ /^\d$/;
 381         $rel_options{'non_indep'} = $nonindep if $nonindep && $nonindep =~ /^\d$/;
 382
 383         if( $type =~ /^(inv|tr|rep)$/i ) {
 384             # Transposition or repetition: look for nodes with the
 385             # same label but different IDs and mark them.
 386             $type = 'repetition' if $type =~ /^rep/i;
 387             $rel_options{'type'} = $type;
 388             $rel_options{'equal_rank'} = undef;
 389             my %labels;
 390             foreach my $r ( @$lemma ) {
 391                 $labels{cmp_str( $r )} = $r;
 392             }
 393             foreach my $r( @$var ) {
 394                 if( exists $labels{$r->text} &&
 395                     $r->id ne $labels{$r->text}->id ) {
 396                     if( $type eq 'repetition' ) {
 397                         # Repetition
 398                         try {
 399                                 $collation->add_relationship( $r, $labels{$r->text}, \%rel_options );
 400                         } catch( Text::Tradition::Error $e ) {
 401                                 warn "Could not set repetition relationship $r -> "
 402                                         . $labels{$r->text} . ": " . $e->message;
 403                         }
 404                     } else {
 405                         # Transposition
 406                         try {
 407                                 $r->set_identical( $labels{$r->text} );
 408                         } catch( Text::Tradition::Error $e ) {
 409                                 warn "Could not set transposition relationship $r -> "
 410                                         . $labels{$r->text} . ": " . $e->message;
 411                         }
 412                     }
 413                 }
 414             }
 415         } elsif( $type =~ /^(gr|sp(el)?)$/i ) {
 416
 417             # Grammar/spelling/lexical: this can be a one-to-one or
 418             # one-to-many mapping.  We should think about merging
 419             # readings if it is one-to-many.
 420
 421             $type = 'grammatical' if $type =~ /gr/i;
 422             $type = 'spelling' if $type =~ /sp/i;
 423             $type = 'repetition' if $type =~ /rep/i;
 424             # $type = 'lexical' if $type =~ /lex/i;
 425             $rel_options{'type'} = $type;
 426             $rel_options{'equal_rank'} = 1;
 427             if( @$lemma == @$var ) {
 428                 foreach my $i ( 0 .. $#{$lemma} ) {
 429                         try {
 430                                                 $collation->add_relationship( $var->[$i], $lemma->[$i],
 431                                                         \%rel_options );
 432                                         } catch( Text::Tradition::Error $e ) {
 433                                                 warn "Could not set $type relationship " . $var->[$i] . " -> "
 434                                                         . $lemma->[$i] . ": " . $e->message;
 435                                         }
 436                 }
 437             } else {
 438                 # An uneven many-to-many mapping.  Skip for now.
 439                 # We really want to make a segment out of whatever we have.
 440                 # my $lemseg = @$lemma > 1 ? $collation->add_segment( @$lemma ) : $lemma->[0];
 441                 # my $varseg = @$var > 1 ? $collation->add_segment( @$var ) : $var->[0];
 442                 # $collation->add_relationship( $varseg, $lemseg, \%rel_options );
 443                 # if( @$lemma == 1 && @$var == 1 ) {
 444                 #     $collation->add_relationship( $lemma->[0], $var->[0], \%rel_options );
 445                 # }
 446             }
 447         } elsif( $type !~ /^(add|om|lex)$/i ) {
 448             warn "Unrecognized type $type";
 449         }
 450     }
 451 }
 452
 453
 454
 455 sub apply_edits {
 456     my( $collation, $edit_sequence, $debug ) = @_;
 457     my @lemma_text = $collation->reading_sequence(
 458         $collation->start, $collation->end );
 459     my $drift = 0;
 460     foreach my $correction ( @$edit_sequence ) {
 461         my( $lemma_start, $length, $items ) = @$correction;
 462         my $offset = $base_text_index{$lemma_start};
 463         my $realoffset = $offset + $drift;
 464         if( $debug ||
 465             $lemma_text[$realoffset]->id ne $lemma_start ) {
 466             my @this_phrase = @lemma_text[$realoffset..$realoffset+$length-1];
 467             my @base_phrase;
 468             my $i = $realoffset;
 469             my $l = $collation->reading( $lemma_start );
 470             while( $i < $realoffset+$length ) {
 471                 push( @base_phrase, $l );
 472                 $l = $collation->next_reading( $l );
 473                 $i++;
 474             }
 475
 476             print STDERR sprintf( "Trying to replace %s (%s) starting at %d " .
 477                                   "with %s (%s) with drift %d\n",
 478                                   join( ' ', map {$_->text} @base_phrase ),
 479                                   join( ' ', map {$_->id} @base_phrase ),
 480                                   $realoffset,
 481                                   join( ' ', map {$_->text} @$items ),
 482                                   join( ' ', map {$_->id} @$items ),
 483                                   $drift,
 484                                   ) if $debug;
 485
 486             if( $lemma_text[$realoffset]->id ne $lemma_start ) {
 487                 warn( sprintf( "Should be replacing %s (%s) with %s (%s) " .
 488                                "but %s (%s) is there instead",
 489                                join( ' ', map {$_->text} @base_phrase ),
 490                                join( ' ', map {$_->id} @base_phrase ),
 491                                join( ' ', map {$_->text} @$items ),
 492                                join( ' ', map {$_->id} @$items ),
 493                                join( ' ', map {$_->text} @this_phrase ),
 494                                join( ' ', map {$_->id} @this_phrase ),
 495                       ) );
 496                 # next;
 497             }
 498         }
 499         splice( @lemma_text, $realoffset, $length, @$items );
 500         $drift += @$items - $length;
 501     }
 502     return @lemma_text;
 503 }
 504
 505
 506 # Helper function. Given a witness sigil, if it is a post-correctione
 507 # sigil,return the base witness.  If not, return a false value.
 508 sub _is_post_corr {
 509     my( $sigil ) = @_;
 510     if( $sigil =~ /^(.*?)(\s*\(?p\.\s*c\.\)?)$/ ) {
 511         return $1;
 512     }
 513     return undef;
 514 }
 515
 516
 517 =back
 518
 519 =head1 LICENSE
 520
 521 This package is free software and is provided "as is" without express
 522 or implied warranty.  You can redistribute it and/or modify it under
 523 the same terms as Perl itself.
 524
 525 =head1 AUTHOR
 526
 527 Tara L Andrews, aurum@cpan.org
 528
 529 =cut
 530
 531 1;