lib/Text/Tradition/Collation.pm

   1 package Text::Tradition::Collation;
   2
   3 use Graph::Easy;
   4 use IPC::Run qw( run binary );
   5 use Text::Tradition::Collation::Reading;
   6 use Moose;
   7
   8 has 'graph' => (
   9     is => 'ro',
  10     isa => 'Graph::Easy',
  11     handles => {
  12         add_reading => 'add_node',
  13         del_reading => 'del_node',
  14         add_path => 'add_edge',
  15         del_path => 'del_edge',
  16         reading => 'node',
  17         path => 'edge',
  18         readings => 'nodes',
  19         paths => 'edges',
  20     },
  21     default => sub { Graph::Easy->new( undirected => 0 ) },
  22     );
  23
  24
  25 has 'tradition' => (
  26     is => 'rw',
  27     isa => 'Text::Tradition',
  28     );
  29
  30 has 'svg' => (
  31     is => 'ro',
  32     isa => 'Str',
  33     writer => '_save_svg',
  34     predicate => 'has_svg',
  35     );
  36
  37 has 'graphviz' => (
  38     is => 'ro',
  39     isa => 'Str',
  40     writer => '_save_graphviz',
  41     predicate => 'has_graphviz',
  42     );
  43
  44 has 'graphml' => (
  45     is => 'ro',
  46     isa => 'XML::LibXML::Document',
  47     writer => '_save_graphml',
  48     predicate => 'has_graphml',
  49     );
  50
  51 # Keeps track of the lemmas within the collation.  At most one lemma
  52 # per position in the graph.
  53 has 'lemmata' => (
  54     is => 'ro',
  55     isa => 'HashRef[Maybe[Str]]',
  56     default => sub { {} },
  57     );
  58
  59 has 'wit_list_separator' => (
  60     is => 'rw',
  61     isa => 'Str',
  62     default => ', ',
  63     );
  64
  65 has 'baselabel' => (
  66     is => 'rw',
  67     isa => 'Str',
  68     default => 'base text',
  69     );
  70
  71 # The collation can be created two ways:
  72 # 1. Collate a set of witnesses (with CollateX I guess) and process
  73 #    the results as in 2.
  74 # 2. Read a pre-prepared collation in one of a variety of formats,
  75 #    and make the graph from that.
  76
  77 # The graph itself will (for now) be immutable, and the positions
  78 # within the graph will also be immutable.  We need to calculate those
  79 # positions upon graph construction.  The equivalences between graph
  80 # nodes will be mutable, entirely determined by the user (or possibly
  81 # by some semantic pre-processing provided by the user.)  So the
  82 # constructor should just make an empty equivalences object.  The
  83 # constructor will also need to make the witness objects, if we didn't
  84 # come through option 1.
  85
  86 sub BUILD {
  87     my( $self, $args ) = @_;
  88     $self->graph->use_class('node', 'Text::Tradition::Collation::Reading');
  89
  90     # Pass through any graph-specific options.
  91     my $shape = exists( $args->{'shape'} ) ? $args->{'shape'} : 'ellipse';
  92     $self->graph->set_attribute( 'node', 'shape', $shape );
  93 }
  94
  95 # Wrapper around add_path
  96
  97 around add_path => sub {
  98     my $orig = shift;
  99     my $self = shift;
 100
 101     # Make sure there are three arguments
 102     unless( @_ == 3 ) {
 103         warn "Call add_path with args source, target, witness";
 104         return;
 105     }
 106     # Make sure the proposed path does not yet exist
 107     my( $source, $target, $wit ) = @_;
 108     $source = $self->reading( $source )
 109         unless ref( $source ) eq 'Text::Tradition::Collation::Reading';
 110     $target = $self->reading( $target )
 111         unless ref( $target ) eq 'Text::Tradition::Collation::Reading';
 112     foreach my $path ( $source->edges_to( $target ) ) {
 113         if( $path->label eq $wit ) {
 114             return;
 115         }
 116     }
 117     # Do the deed
 118     $self->$orig( @_ );
 119 };
 120
 121 # Wrapper around merge_nodes
 122
 123 sub merge_readings {
 124     my $self = shift;
 125     my $first_node = shift;
 126     my $second_node = shift;
 127     $first_node->merge_from( $second_node );
 128     unshift( @_, $first_node, $second_node );
 129     return $self->graph->merge_nodes( @_ );
 130 }
 131
 132 =head2 Output method(s)
 133
 134 =over
 135
 136 =item B<as_svg>
 137
 138 print $graph->as_svg( $recalculate );
 139
 140 Returns an SVG string that represents the graph.  Uses GraphViz to do
 141 this, because Graph::Easy doesn\'t cope well with long graphs. Unless
 142 $recalculate is passed (and is a true value), the method will return a
 143 cached copy of the SVG after the first call to the method.
 144
 145 =cut
 146
 147 sub as_svg {
 148     my( $self, $recalc ) = @_;
 149     return $self->svg if $self->has_svg;
 150
 151     $self->_save_graphviz( $self->graph->as_graphviz() )
 152         unless( $self->has_graphviz && !$recalc );
 153
 154     my @cmd = qw/dot -Tsvg/;
 155     my( $svg, $err );
 156     my $in = $self->graphviz;
 157     run( \@cmd, \$in, ">", binary(), \$svg );
 158     $self->{'svg'} = $svg;
 159     return $svg;
 160 }
 161
 162 =item B<as_graphml>
 163
 164 print $graph->as_graphml( $recalculate )
 165
 166 Returns a GraphML representation of the collation graph, with
 167 transposition information and position information. Unless
 168 $recalculate is passed (and is a true value), the method will return a
 169 cached copy of the SVG after the first call to the method.
 170
 171 =cut
 172
 173 sub as_graphml {
 174     my( $self, $recalc ) = @_;
 175     return $self->graphml if $self->has_graphml;
 176
 177     # Some namespaces
 178     my $graphml_ns = 'http://graphml.graphdrawing.org/xmlns';
 179     my $xsi_ns = 'http://www.w3.org/2001/XMLSchema-instance';
 180     my $graphml_schema = 'http://graphml.graphdrawing.org/xmlns ' .
 181         'http://graphml.graphdrawing.org/xmlns/1.0/graphml.xsd';
 182
 183     # Create the document and root node
 184     my $graphml = XML::LibXML->createDocument( "1.0", "UTF-8" );
 185     my $root = $graphml->createElementNS( $graphml_ns, 'graphml' );
 186     $graphml->setDocumentElement( $root );
 187     $root->setNamespace( $xsi_ns, 'xsi', 0 );
 188     $root->setAttributeNS( $xsi_ns, 'schemaLocation', $graphml_schema );
 189
 190     # Add the data keys for nodes
 191     my @node_data = ( 'name', 'token', 'identical', 'position' );
 192     foreach my $ndi ( 0 .. $#node_data ) {
 193         my $key = $root->addNewChild( $graphml_ns, 'key' );
 194         $key->setAttribute( 'attr.name', $node_data[$ndi] );
 195         $key->setAttribute( 'attr.type', 'string' );
 196         $key->setAttribute( 'for', 'node' );
 197         $key->setAttribute( 'id', 'd'.$ndi );
 198     }
 199
 200     # Add the data keys for edges
 201     my %wit_hash;
 202     my $wit_ctr = 0;
 203     foreach my $wit ( $self->getWitnessList ) {
 204         my $wit_key = 'w' . $wit_ctr++;
 205         $wit_hash{$wit} = $wit_key;
 206         my $key = $root->addNewChild( $graphml_ns, 'key' );
 207         $key->setAttribute( 'attr.name', $wit );
 208         $key->setAttribute( 'attr.type', 'string' );
 209         $key->setAttribute( 'for', 'edge' );
 210         $key->setAttribute( 'id', $wit_key );
 211     }
 212
 213     # Add the graph, its nodes, and its edges
 214     my $graph = $root->addNewChild( $graphml_ns, 'graph' );
 215     $graph->setAttribute( 'edgedefault', 'directed' );
 216     $graph->setAttribute( 'id', 'g0' ); # TODO make this meaningful
 217     $graph->setAttribute( 'parse.edgeids', 'canonical' );
 218     $graph->setAttribute( 'parse.edges', $self->edges() );
 219     $graph->setAttribute( 'parse.nodeids', 'canonical' );
 220     $graph->setAttribute( 'parse.nodes', $self->nodes() );
 221     $graph->setAttribute( 'parse.order', 'nodesfirst' );
 222
 223     my $node_ctr = 0;
 224     my %node_hash;
 225     foreach my $n ( $self->readings ) {
 226         my %this_node_data = ();
 227         foreach my $ndi ( 0 .. $#node_data ) {
 228             my $value;
 229             $this_node_data{'d'.$ndi} = $n->name if $node_data[$ndi] eq 'name';
 230             $this_node_data{'d'.$ndi} = $n->label
 231                 if $node_data[$ndi] eq 'token';
 232             $this_node_data{'d'.$ndi} = $n->primary->name if $n->has_primary;
 233             $this_node_data{'d'.$ndi} =
 234                 $self->{'positions'}->node_position( $n )
 235                 if $node_data[$ndi] eq 'position';
 236         }
 237         my $node_el = $graph->addNewChild( $graphml_ns, 'node' );
 238         my $node_xmlid = 'n' . $node_ctr++;
 239         $node_hash{ $n->name } = $node_xmlid;
 240         $node_el->setAttribute( 'id', $node_xmlid );
 241
 242         foreach my $dk ( keys %this_node_data ) {
 243             my $d_el = $node_el->addNewChild( $graphml_ns, 'data' );
 244             $d_el->setAttribute( 'key', $dk );
 245             $d_el->appendTextChild( $this_node_data{$dk} );
 246         }
 247     }
 248
 249     foreach my $e ( $self->edges() ) {
 250         my( $name, $from, $to ) = ( $e->name,
 251                                     $node_hash{ $e->from()->name() },
 252                                     $node_hash{ $e->to()->name() } );
 253         my $edge_el = $graph->addNewChild( $graphml_ns, 'edge' );
 254         $edge_el->setAttribute( 'source', $from );
 255         $edge_el->setAttribute( 'target', $to );
 256         $edge_el->setAttribute( 'id', $name );
 257         # TODO Got to add the witnesses
 258     }
 259
 260     # Return the thing
 261     $self->_save_graphml( $graphml );
 262     return $graphml;
 263 }
 264
 265 =back
 266
 267 =head2 Navigation methods
 268
 269 =over
 270
 271 =item B<start>
 272
 273 my $beginning = $collation->start();
 274
 275 Returns the beginning of the collation, a meta-reading with label '#START#'.
 276
 277 =cut
 278
 279 sub start {
 280     # Return the beginning reading of the graph.
 281     my $self = shift;
 282     my( $new_start ) = @_;
 283     if( $new_start ) {
 284         $self->del_reading( '#START#' );
 285         $self->graph->rename_node( $new_start, '#START#' );
 286     }
 287     return $self->reading('#START#');
 288 }
 289
 290 =item B<reading_sequence>
 291
 292 my @readings = $graph->reading_sequence( $first, $last, $path[, $alt_path] );
 293
 294 Returns the ordered list of readings, starting with $first and ending
 295 with $last, along the given witness path.  If no path is specified,
 296 assume that the path is that of the base text (if any.)
 297
 298 =cut
 299
 300 sub reading_sequence {
 301     my( $self, $start, $end, $witness, $backup ) = @_;
 302
 303     $witness = $self->baselabel unless $witness;
 304     my @readings = ( $start );
 305     my %seen;
 306     my $n = $start;
 307     while( $n && $n ne $end ) {
 308         if( exists( $seen{$n->name()} ) ) {
 309             warn "Detected loop at " . $n->name();
 310             last;
 311         }
 312         $seen{$n->name()} = 1;
 313
 314         my $next = $self->next_reading( $n, $witness, $backup );
 315         warn "Did not find any path for $witness from reading " . $n->name
 316             unless $next;
 317         push( @readings, $next );
 318         $n = $next;
 319     }
 320     # Check that the last reading is our end reading.
 321     my $last = $readings[$#readings];
 322     warn "Last reading found from " . $start->label() .
 323         " for witness $witness is not the end!"
 324         unless $last eq $end;
 325
 326     return @readings;
 327 }
 328
 329 =item B<next_reading>
 330
 331 my $next_reading = $graph->next_reading( $reading, $witpath );
 332
 333 Returns the reading that follows the given reading along the given witness
 334 path.
 335
 336 =cut
 337
 338 sub next_reading {
 339     # Return the successor via the corresponding path.
 340     my $self = shift;
 341     return $self->_find_linked_reading( 'next', @_ );
 342 }
 343
 344 =item B<prior_reading>
 345
 346 my $prior_reading = $graph->prior_reading( $reading, $witpath );
 347
 348 Returns the reading that precedes the given reading along the given witness
 349 path.
 350
 351 =cut
 352
 353 sub prior_reading {
 354     # Return the predecessor via the corresponding path.
 355     my $self = shift;
 356     return $self->_find_linked_reading( 'prior', @_ );
 357 }
 358
 359 sub _find_linked_reading {
 360     my( $self, $direction, $node, $path, $alt_path ) = @_;
 361     my @linked_paths = $direction eq 'next'
 362         ? $node->outgoing() : $node->incoming();
 363     return undef unless scalar( @linked_paths );
 364
 365     # We have to find the linked path that contains all of the
 366     # witnesses supplied in $path.
 367     my( @path_wits, @alt_path_wits );
 368     @path_wits = $self->witnesses_of_label( $path ) if $path;
 369     @alt_path_wits = $self->witnesses_of_label( $alt_path ) if $alt_path;
 370     my $base_le;
 371     my $alt_le;
 372     foreach my $le ( @linked_paths ) {
 373         if( $le->name eq $self->baselabel ) {
 374             $base_le = $le;
 375         } else {
 376             my @le_wits = $self->witnesses_of_label( $le->name );
 377             if( _is_within( \@path_wits, \@le_wits ) ) {
 378                 # This is the right path.
 379                 return $direction eq 'next' ? $le->to() : $le->from();
 380             } elsif( _is_within( \@alt_path_wits, \@le_wits ) ) {
 381                 $alt_le = $le;
 382             }
 383         }
 384     }
 385     # Got this far? Return the alternate path if it exists.
 386     return $direction eq 'next' ? $alt_le->to() : $alt_le->from()
 387         if $alt_le;
 388
 389     # Got this far? Return the base path if it exists.
 390     return $direction eq 'next' ? $base_le->to() : $base_le->from()
 391         if $base_le;
 392
 393     # Got this far? We have no appropriate path.
 394     warn "Could not find $direction node from " . $node->label
 395         . " along path $path";
 396     return undef;
 397 }
 398
 399 # Some set logic.
 400 sub _is_within {
 401     my( $set1, $set2 ) = @_;
 402     my $ret = @$set1; # will be 0, i.e. false, if set1 is empty
 403     foreach my $el ( @$set1 ) {
 404         $ret = 0 unless grep { /^\Q$el\E$/ } @$set2;
 405     }
 406     return $ret;
 407 }
 408
 409
 410 ## INITIALIZATION METHODS - for use by parsers
 411 # Walk the paths for each witness in the graph, and return the nodes
 412 # that the graph has in common.  If $using_base is true, some
 413 # different logic is needed.
 414
 415 sub walk_witness_paths {
 416     my( $self, $end ) = @_;
 417     # For each witness, walk the path through the graph.
 418     # Then we need to find the common nodes.
 419     # TODO This method is going to fall down if we have a very gappy
 420     # text in the collation.
 421     my $paths = {};
 422     my @common_readings;
 423     foreach my $wit ( @{$self->tradition->witnesses} ) {
 424         my $curr_reading = $self->start;
 425         my @wit_path = $self->reading_sequence( $self->start, $end,
 426                                                 $wit->sigil );
 427         $wit->path( \@wit_path );
 428
 429         # Detect the common readings.
 430         @common_readings = _find_common( \@common_readings, \@wit_path );
 431     }
 432
 433     # Mark all the nodes as either common or not.
 434     foreach my $cn ( @common_readings ) {
 435         print STDERR "Setting " . $cn->name . " / " . $cn->label
 436             . " as common node\n";
 437         $cn->make_common;
 438     }
 439     foreach my $n ( $self->readings() ) {
 440         $n->make_variant unless $n->is_common;
 441     }
 442     # Return an array of the common nodes in order.
 443     return @common_readings;
 444 }
 445
 446 sub _find_common {
 447     my( $common_readings, $new_path ) = @_;
 448     my @cr;
 449     if( @$common_readings ) {
 450         foreach my $n ( @$new_path ) {
 451             push( @cr, $n ) if grep { $_ eq $n } @$common_readings;
 452         }
 453     } else {
 454         push( @cr, @$new_path );
 455     }
 456     return @cr;
 457 }
 458
 459 sub _remove_common {
 460     my( $common_readings, $divergence ) = @_;
 461     my @cr;
 462     my %diverged;
 463     map { $diverged{$_->name} = 1 } @$divergence;
 464     foreach( @$common_readings ) {
 465         push( @cr, $_ ) unless $diverged{$_->name};
 466     }
 467     return @cr;
 468 }
 469
 470
 471 # An alternative to walk_witness_paths, for use when a collation is
 472 # constructed from a base text and an apparatus.  Also modifies the
 473 # collation graph to remove all 'base text' paths and replace them
 474 # with real witness paths.
 475
 476 sub walk_and_expand_base {
 477     my( $self, $end ) = @_;
 478
 479     my @common_readings;
 480     foreach my $wit ( @{$self->tradition->witnesses} ) {
 481         my $sig = $wit->sigil;
 482         my $post_sig;
 483         $post_sig = $wit->post_correctione
 484             if $wit->has_post_correctione;
 485
 486         # $DB::single = 1 if $wit->sigil eq 'Vb11';
 487         my @wit_path = $self->reading_sequence( $self->start, $end, $sig );
 488         $wit->path( \@wit_path );
 489         $self->connect_readings_for_witness( $wit );
 490         @common_readings = _find_common( \@common_readings, \@wit_path );
 491
 492         # If there is a post-correctio, get its path and compare.
 493         # Add a correction range for each divergence.
 494         if( $post_sig ) {
 495             my @corr_wit_path = $self->reading_sequence( $self->start, $end,
 496                                                          "$sig$post_sig", $sig );
 497
 498             # Map ante-corr readings to their indices
 499             my %in_orig;
 500             my $i = 0;
 501             map { $in_orig{$_->name} = $i++ } @wit_path;
 502
 503             # Look for divergences
 504             my $diverged = 0;
 505             my $last_common;
 506             my @correction;
 507             $DB::single = 1 if $sig eq 'Vb12';
 508             foreach my $rdg ( @corr_wit_path ) {
 509                 if( exists( $in_orig{$rdg->name} ) && !$diverged ) {
 510                     # We are reading the same here
 511                     $last_common = $in_orig{$rdg->name};
 512                 } elsif ( exists( $in_orig{$rdg->name} ) ) {
 513                     # We have been diverging but are reading the same again.
 514                     # Add the correction to the witness.
 515                     my $offset = $last_common + 1;
 516                     my $length = $in_orig{$rdg->name} - $offset;
 517                     $wit->add_correction( $offset, $length, @correction );
 518                     $diverged = 0;
 519                     @common_readings = _remove_common( \@common_readings, \@correction );
 520                     @correction = ();
 521                     $last_common = $in_orig{$rdg->name};
 522                 } elsif( $diverged ) {
 523                     # We are in the middle of a divergence.
 524                     push( @correction, $rdg );
 525                 } else {
 526                     # We have started to diverge.  Note it.
 527                     $diverged = 1;
 528                     push( @correction, $rdg );
 529                 }
 530             }
 531             # Add any divergence that is at the end of the text
 532             if( $diverged ) {
 533                 $wit->add_correction( $last_common+1, $#wit_path, \@correction );
 534             }
 535         }
 536     }
 537
 538     # Remove any 'base text' paths.
 539     foreach my $path ( $self->paths ) {
 540         $self->del_path( $path )
 541             if $path->label eq $self->baselabel;
 542     }
 543 }
 544
 545 sub connect_readings_for_witness {
 546     my( $self, $wit ) = @_;
 547     my @chain = @{$wit->path};
 548     foreach my $idx ( 0 .. $#chain-1 ) {
 549         $self->add_path( $chain[$idx], $chain[$idx+1], $wit->sigil );
 550     }
 551 }
 552
 553 sub common_readings {
 554     my $self = shift;
 555     my @common = grep { $_->is_common } $self->readings();
 556     return sort { _cmp_position( $a->position, $b->position ) } @common;
 557 }
 558
 559 # Calculate the relative positions of nodes in the graph, if they
 560 # were not given to us.
 561 sub calculate_positions {
 562     my( $self, @ordered_common ) = @_;
 563
 564     # We have to calculate the position identifiers for each word,
 565     # keyed on the common nodes.  This will be 'fun'.  The end result
 566     # is a hash per witness, whose key is the word node and whose
 567     # value is its position in the text.  Common nodes are always N,1
 568     # so have identical positions in each text.
 569
 570     my $node_pos = {};
 571     foreach my $wit ( @{$self->tradition->witnesses} ) {
 572         print STDERR "Calculating positions in " . $wit->sigil . "\n";
 573         _update_positions_from_path( $wit->path, @ordered_common );
 574         _update_positions_from_path( $wit->corrected_path, @ordered_common )
 575             if $wit->has_post_correctione;
 576     }
 577
 578     # DEBUG
 579     foreach my $r ( $self->readings() ) {
 580         print STDERR "Reading " . $r->name . "/" . $r->label . " has no position\n"
 581             unless( $r->has_position );
 582     }
 583
 584     $self->init_lemmata();
 585 }
 586
 587 sub _update_positions_from_path {
 588     my( $path, @ordered_common ) = @_;
 589
 590     # First we walk the given path, making a matrix for the witness
 591     # that corresponds to its eventual position identifier.  Common
 592     # nodes always start a new row, and are thus always in the first
 593     # column.
 594
 595     my $wit_matrix = [];
 596     my $cn = 0;  # We should hit the common readings in order.
 597     my $row = [];
 598     foreach my $wn ( @{$path} ) {
 599         if( $wn eq $ordered_common[$cn] ) {
 600             # Set up to look for the next common node, and
 601             # start a new row of words.
 602             $cn++;
 603             push( @$wit_matrix, $row ) if scalar( @$row );
 604             $row = [];
 605         }
 606         push( @$row, $wn );
 607     }
 608     push( @$wit_matrix, $row );  # Push the last row onto the matrix
 609
 610     # Now we have a matrix per witness, so that each row in the
 611     # matrix begins with a common node, and continues with all the
 612     # variant words that appear in the witness.  We turn this into
 613     # real positions in row,cell format.  But we need some
 614     # trickery in order to make sure that each node gets assigned
 615     # to only one position.
 616
 617     foreach my $li ( 1..scalar(@$wit_matrix) ) {
 618         foreach my $di ( 1..scalar(@{$wit_matrix->[$li-1]}) ) {
 619             my $reading = $wit_matrix->[$li-1]->[$di-1];
 620             my $position = "$li,$di";
 621             # If we have seen this node before, we need to compare
 622             # its position with what went before.
 623             unless( $reading->has_position &&
 624                     _cmp_position( $position, $reading->position ) < 1 ) {
 625                 # The new position ID replaces the old one.
 626                 $reading->position( $position );
 627             } # otherwise, the old position needs to stay.
 628         }
 629     }
 630 }
 631
 632 sub _cmp_position {
 633     my( $a, $b ) = @_;
 634     if ( $a && $b ) {
 635         my @pos_a = split(/,/, $a );
 636         my @pos_b = split(/,/, $b );
 637
 638         my $big_cmp = $pos_a[0] <=> $pos_b[0];
 639         return $big_cmp if $big_cmp;
 640         # else
 641         return $pos_a[1] <=> $pos_b[1];
 642     } elsif ( $b ) { # a is undefined
 643         return -1;
 644     } elsif ( $a ) { # b is undefined
 645         return 1;
 646     }
 647     return 0; # they are both undefined
 648 }
 649
 650 sub all_positions {
 651     my $self = shift;
 652     my %positions = ();
 653     map { $positions{$_->position} = 1 } $self->readings;
 654     my @answer = sort { _cmp_position( $a, $b ) } keys( %positions );
 655     return @answer;
 656 }
 657
 658 sub readings_at_position {
 659     my( $self, $pos ) = @_;
 660     my @answer = grep { $_->position eq $pos } $self->readings;
 661     return @answer;
 662 }
 663
 664 ## Lemmatizer functions
 665
 666 sub init_lemmata {
 667     my $self = shift;
 668
 669     foreach my $position ( $self->all_positions ) {
 670         $self->lemmata->{$position} = undef;
 671     }
 672
 673     foreach my $cr ( $self->common_readings ) {
 674         $self->lemmata->{$cr->position} = $cr->name;
 675     }
 676 }
 677
 678 =item B<lemma_readings>
 679
 680 my @state = $graph->lemma_readings( @readings_delemmatized );
 681
 682 Takes a list of readings that have just been delemmatized, and returns
 683 a set of tuples of the form ['reading', 'state'] that indicates what
 684 changes need to be made to the graph.
 685
 686 =over
 687
 688 =item *
 689
 690 A state of 1 means 'lemmatize this reading'
 691
 692 =item *
 693
 694 A state of 0 means 'delemmatize this reading'
 695
 696 =item *
 697
 698 A state of undef means 'an ellipsis belongs in the text here because
 699 no decision has been made / an earlier decision was backed out'
 700
 701 =back
 702
 703 =cut
 704
 705 sub lemma_readings {
 706     my( $self, @toggled_off_nodes ) = @_;
 707
 708     # First get the positions of those nodes which have been
 709     # toggled off.
 710     my $positions_off = {};
 711     map { $positions_off->{ $_->position } = $_->name } @toggled_off_nodes;
 712
 713     # Now for each position, we have to see if a node is on, and we
 714     # have to see if a node has been turned off.
 715     my @answer;
 716     foreach my $pos ( $self->all_positions() ) {
 717         # Find the state of this position.  If there is an active node,
 718         # its name will be the state; otherwise the state will be 0
 719         # (nothing at this position) or undef (ellipsis at this position)
 720         my $active = $self->lemmata->{$pos};
 721
 722         # Is there a formerly active node that was toggled off?
 723         if( exists( $positions_off->{$pos} ) ) {
 724             my $off_node = $positions_off->{$pos};
 725             if( $active && $active ne $off_node) {
 726                 push( @answer, [ $off_node, 0 ], [ $active, 1 ] );
 727             } else {
 728                 push( @answer, [ $off_node, $active ] );
 729             }
 730
 731         # No formerly active node, so we just see if there is a currently
 732         # active one.
 733         } elsif( $active ) {
 734             # Push the active node, whatever it is.
 735             push( @answer, [ $active, 1 ] );
 736         } else {
 737             # Push the state that is there. Arbitrarily use the first node
 738             # at that position.
 739             my @pos_nodes = $self->readings_at_position( $pos );
 740             push( @answer, [ $pos_nodes[0]->name, $self->lemmata->{$pos} ] );
 741         }
 742     }
 743
 744     return @answer;
 745 }
 746
 747 =item B<toggle_reading>
 748
 749 my @readings_delemmatized = $graph->toggle_reading( $reading_name );
 750
 751 Takes a reading node name, and either lemmatizes or de-lemmatizes
 752 it. Returns a list of all readings that are de-lemmatized as a result
 753 of the toggle.
 754
 755 =cut
 756
 757 sub toggle_reading {
 758     my( $self, $rname ) = @_;
 759
 760     return unless $rname;
 761     my $reading = $self->reading( $rname );
 762     if( !$reading || $reading->is_common() ) {
 763         # Do nothing, it's a common node.
 764         return;
 765     }
 766
 767     my $pos = $reading->position;
 768     my $old_state = $self->lemmata->{$pos};
 769     my @readings_off;
 770     if( $old_state && $old_state eq $rname ) {
 771         # Turn off the node. We turn on no others by default.
 772         push( @readings_off, $reading );
 773     } else {
 774         # Turn on the node.
 775         $self->lemmata->{$pos} = $rname;
 776         # Any other 'on' readings in the same position should be off.
 777         push( @readings_off, $self->same_position_as( $reading ) );
 778         # Any node that is an identical transposed one should be off.
 779         push( @readings_off, $reading->identical_readings );
 780     }
 781     @readings_off = unique_list( @readings_off );
 782
 783     # Turn off the readings that need to be turned off.
 784     my @readings_delemmatized;
 785     foreach my $n ( @readings_off ) {
 786         my $state = $self->lemmata->{$n->position};
 787         if( $state && $state eq $n->name ) {
 788             # this reading is still on, so turn it off
 789             push( @readings_delemmatized, $n );
 790             my $new_state = undef;
 791             if( $n eq $reading ) {
 792                 # This is the reading that was clicked, so if there are no
 793                 # other readings there, turn off the position.  In all other
 794                 # cases, restore the ellipsis.
 795                 my @other_n = $self->same_position_as( $n );
 796                 $new_state = 0 unless @other_n;
 797             }
 798             $self->lemmata->{$n->position} = $new_state;
 799         } elsif( $old_state && $old_state eq $n->name ) {
 800             # another reading has already been turned on here
 801             push( @readings_delemmatized, $n );
 802         } # else some other reading was on anyway, so pass.
 803     }
 804     return @readings_delemmatized;
 805 }
 806
 807 sub same_position_as {
 808     my( $self, $reading ) = @_;
 809     my $pos = $reading->position;
 810     my @same = grep { $_ ne $reading } $self->readings_at_position( $reading->position );
 811     return @same;
 812 }
 813
 814 # Return the string that joins together a list of witnesses for
 815 # display on a single path.
 816 sub path_label {
 817     my $self = shift;
 818     return join( $self->wit_list_separator, @_ );
 819 }
 820
 821 sub witnesses_of_label {
 822     my( $self, $label ) = @_;
 823     my $regex = $self->wit_list_separator;
 824     my @answer = split( /\Q$regex\E/, $label );
 825     return @answer;
 826 }
 827
 828 sub unique_list {
 829     my( @list ) = @_;
 830     my %h;
 831     map { $h{$_->name} = $_ } @list;
 832     return values( %h );
 833 }
 834
 835 no Moose;
 836 __PACKAGE__->meta->make_immutable;