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 = 'base text' unless $witness;
 304     my @readings = ( $start );
 305     my %seen;
 306     my $n = $start;
 307     while( $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.  TODO These are badly named.
 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.  TODO These are badly named.
 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 'base text' ) {
 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         if( @common_readings ) {
 431             my @cn;
 432             foreach my $n ( @wit_path ) {
 433                 push( @cn, $n ) if grep { $_ eq $n } @common_readings;
 434             }
 435             @common_readings = ();
 436             push( @common_readings, @cn );
 437         } else {
 438             push( @common_readings, @wit_path );
 439         }
 440     }
 441
 442     # Mark all the nodes as either common or not.
 443     foreach my $cn ( @common_readings ) {
 444         print STDERR "Setting " . $cn->name . " / " . $cn->label
 445             . " as common node\n";
 446         $cn->make_common;
 447     }
 448     foreach my $n ( $self->readings() ) {
 449         $n->make_variant unless $n->is_common;
 450     }
 451     # Return an array of the common nodes in order.
 452     return @common_readings;
 453 }
 454
 455 # An alternative to walk_witness_paths, for use when a collation is
 456 # constructed from a base text and an apparatus.  Also modifies the
 457 # collation graph to remove all 'base text' paths and replace them
 458 # with real witness paths.
 459
 460 sub walk_and_expand_base {
 461     my( $self, $end ) = @_;
 462
 463     foreach my $wit ( @{$self->tradition->witnesses} ) {
 464         my $sig = $wit->sigil;
 465         my $post_sig;
 466         $post_sig = $wit->post_correctione
 467             if $wit->has_post_correctione;
 468         my @wit_path = $self->reading_sequence( $self->start, $end, $sig );
 469         $wit->path( \@wit_path );
 470         $self->connect_readings_for_witness( $wit );
 471
 472         # If there is a post-correctio, get its path and compare.
 473         # Add a correction range for each divergence.
 474         if( $post_sig ) {
 475             # TODO this is looping
 476             my @corr_wit_path = $self->reading_sequence( $self->start, $end,
 477                                                          "$sig$post_sig", $sig );
 478
 479             # Map ante-corr readings to their indices
 480             my %in_orig;
 481             my $i = 0;
 482             map { $in_orig{$_->name} = $i++ } @wit_path;
 483
 484             # Look for divergences
 485             my $diverged = 0;
 486             my $last_common;
 487             my @correction;
 488             foreach my $rdg ( @corr_wit_path ) {
 489                 if( exists( $in_orig{$rdg->name} ) && !$diverged ) {
 490                     # We are reading the same here
 491                     $last_common = $in_orig{$rdg->name};
 492                     next;
 493                 } elsif ( exists( $in_orig{$rdg->name} ) ) {
 494                     # We have been diverging but are reading the same again.
 495                     # Add the correction to the witness.
 496                     my $offset = $last_common;
 497                     my $length = $in_orig{$rdg->name} - $last_common;
 498                     $wit->add_correction( $offset, $length, \@correction );
 499                     $diverged = 0;
 500                     @correction = ();
 501                     $last_common = $in_orig{$rdg->name};
 502                 } elsif( $diverged ) {
 503                     # We are in the middle of a divergence.
 504                     push( @correction, $rdg );
 505                 } else {
 506                     # We have started to diverge.  Note it.
 507                     $diverged = 1;
 508                     push( @correction, $rdg );
 509                 }
 510             }
 511             # Add any divergence that is at the end of the line
 512             if( $diverged ) {
 513                 $wit->add_correction( $last_common, $#wit_path, \@correction );
 514             }
 515         }
 516     }
 517
 518     # Remove any 'base text' paths.
 519     foreach my $path ( $self->paths ) {
 520         $self->del_path( $path )
 521             if $path->label eq $self->baselabel;
 522     }
 523 }
 524
 525 sub connect_readings_for_witness {
 526     my( $self, $wit ) = @_;
 527     my @chain = @{$wit->path};
 528     foreach my $idx ( 0 .. $#chain-1 ) {
 529         $self->add_path( $chain[$idx], $chain[$idx+1], $wit->sigil );
 530     }
 531 }
 532
 533 sub common_readings {
 534     my $self = shift;
 535     my @common = grep { $_->is_common } $self->readings();
 536     return sort { _cmp_position( $a->position, $b->position ) } @common;
 537 }
 538
 539 # Calculate the relative positions of nodes in the graph, if they
 540 # were not given to us.
 541 sub calculate_positions {
 542     my( $self, @ordered_common ) = @_;
 543
 544     # We have to calculate the position identifiers for each word,
 545     # keyed on the common nodes.  This will be 'fun'.  The end result
 546     # is a hash per witness, whose key is the word node and whose
 547     # value is its position in the text.  Common nodes are always N,1
 548     # so have identical positions in each text.
 549
 550     my $node_pos = {};
 551     foreach my $wit ( @{$self->tradition->witnesses} ) {
 552         # First we walk each path, making a matrix for each witness that
 553         # corresponds to its eventual position identifier.  Common nodes
 554         # always start a new row, and are thus always in the first column.
 555
 556         my $wit_matrix = [];
 557         my $cn = 0;  # We should hit the common readings in order.
 558         my $row = [];
 559         foreach my $wn ( @{$wit->path} ) {
 560             if( $wn eq $ordered_common[$cn] ) {
 561                 # Set up to look for the next common node, and
 562                 # start a new row of words.
 563                 $cn++;
 564                 push( @$wit_matrix, $row ) if scalar( @$row );
 565                 $row = [];
 566             }
 567             push( @$row, $wn );
 568         }
 569         push( @$wit_matrix, $row );  # Push the last row onto the matrix
 570
 571         # Now we have a matrix per witness, so that each row in the
 572         # matrix begins with a common node, and continues with all the
 573         # variant words that appear in the witness.  We turn this into
 574         # real positions in row,cell format.  But we need some
 575         # trickery in order to make sure that each node gets assigned
 576         # to only one position.
 577
 578         foreach my $li ( 1..scalar(@$wit_matrix) ) {
 579             foreach my $di ( 1..scalar(@{$wit_matrix->[$li-1]}) ) {
 580                 my $reading = $wit_matrix->[$li-1]->[$di-1];
 581                 my $position = "$li,$di";
 582                 # If we have seen this node before, we need to compare
 583                 # its position with what went before.
 584                 unless( $reading->has_position &&
 585                         _cmp_position( $position, $reading->position ) < 1 ) {
 586                     # The new position ID replaces the old one.
 587                     $reading->position( $position );
 588                 } # otherwise, the old position needs to stay.
 589             }
 590         }
 591     }
 592
 593     $self->init_lemmata();
 594 }
 595
 596 sub _cmp_position {
 597     my( $a, $b ) = @_;
 598     if ( $a && $b ) {
 599         my @pos_a = split(/,/, $a );
 600         my @pos_b = split(/,/, $b );
 601
 602         my $big_cmp = $pos_a[0] <=> $pos_b[0];
 603         return $big_cmp if $big_cmp;
 604         # else
 605         return $pos_a[1] <=> $pos_b[1];
 606     } elsif ( $b ) { # a is undefined
 607         return -1;
 608     } elsif ( $a ) { # b is undefined
 609         return 1;
 610     }
 611     return 0; # they are both undefined
 612 }
 613
 614 sub all_positions {
 615     my $self = shift;
 616     my %positions = ();
 617     map { $positions{$_->position} = 1 } $self->readings;
 618     my @answer = sort { _cmp_position( $a, $b ) } keys( %positions );
 619     return @answer;
 620 }
 621
 622 sub readings_at_position {
 623     my( $self, $pos ) = @_;
 624     my @answer = grep { $_->position eq $pos } $self->readings;
 625     return @answer;
 626 }
 627
 628 ## Lemmatizer functions
 629
 630 sub init_lemmata {
 631     my $self = shift;
 632
 633     foreach my $position ( $self->all_positions ) {
 634         $self->lemmata->{$position} = undef;
 635     }
 636
 637     foreach my $cr ( $self->common_readings ) {
 638         $self->lemmata->{$cr->position} = $cr->name;
 639     }
 640 }
 641
 642 =item B<lemma_readings>
 643
 644 my @state = $graph->lemma_readings( @readings_delemmatized );
 645
 646 Takes a list of readings that have just been delemmatized, and returns
 647 a set of tuples of the form ['reading', 'state'] that indicates what
 648 changes need to be made to the graph.
 649
 650 =over
 651
 652 =item *
 653
 654 A state of 1 means 'lemmatize this reading'
 655
 656 =item *
 657
 658 A state of 0 means 'delemmatize this reading'
 659
 660 =item *
 661
 662 A state of undef means 'an ellipsis belongs in the text here because
 663 no decision has been made / an earlier decision was backed out'
 664
 665 =back
 666
 667 =cut
 668
 669 sub lemma_readings {
 670     my( $self, @toggled_off_nodes ) = @_;
 671
 672     # First get the positions of those nodes which have been
 673     # toggled off.
 674     my $positions_off = {};
 675     map { $positions_off->{ $_->position } = $_->name } @toggled_off_nodes;
 676
 677     # Now for each position, we have to see if a node is on, and we
 678     # have to see if a node has been turned off.
 679     my @answer;
 680     foreach my $pos ( $self->all_positions() ) {
 681         # Find the state of this position.  If there is an active node,
 682         # its name will be the state; otherwise the state will be 0
 683         # (nothing at this position) or undef (ellipsis at this position)
 684         my $active = $self->lemmata->{$pos};
 685
 686         # Is there a formerly active node that was toggled off?
 687         if( exists( $positions_off->{$pos} ) ) {
 688             my $off_node = $positions_off->{$pos};
 689             if( $active && $active ne $off_node) {
 690                 push( @answer, [ $off_node, 0 ], [ $active, 1 ] );
 691             } else {
 692                 push( @answer, [ $off_node, $active ] );
 693             }
 694
 695         # No formerly active node, so we just see if there is a currently
 696         # active one.
 697         } elsif( $active ) {
 698             # Push the active node, whatever it is.
 699             push( @answer, [ $active, 1 ] );
 700         } else {
 701             # Push the state that is there. Arbitrarily use the first node
 702             # at that position.
 703             my @pos_nodes = $self->readings_at_position( $pos );
 704             push( @answer, [ $pos_nodes[0]->name, $self->lemmata->{$pos} ] );
 705         }
 706     }
 707
 708     return @answer;
 709 }
 710
 711 =item B<toggle_reading>
 712
 713 my @readings_delemmatized = $graph->toggle_reading( $reading_name );
 714
 715 Takes a reading node name, and either lemmatizes or de-lemmatizes
 716 it. Returns a list of all readings that are de-lemmatized as a result
 717 of the toggle.
 718
 719 =cut
 720
 721 sub toggle_reading {
 722     my( $self, $rname ) = @_;
 723
 724     return unless $rname;
 725     my $reading = $self->reading( $rname );
 726     if( !$reading || $reading->is_common() ) {
 727         # Do nothing, it's a common node.
 728         return;
 729     }
 730
 731     my $pos = $reading->position;
 732     my $old_state = $self->lemmata->{$pos};
 733     my @readings_off;
 734     if( $old_state && $old_state eq $rname ) {
 735         # Turn off the node. We turn on no others by default.
 736         push( @readings_off, $reading );
 737     } else {
 738         # Turn on the node.
 739         $self->lemmata->{$pos} = $rname;
 740         # Any other 'on' readings in the same position should be off.
 741         push( @readings_off, $self->same_position_as( $reading ) );
 742         # Any node that is an identical transposed one should be off.
 743         push( @readings_off, $reading->identical_readings );
 744     }
 745     @readings_off = unique_list( @readings_off );
 746
 747     # Turn off the readings that need to be turned off.
 748     my @readings_delemmatized;
 749     foreach my $n ( @readings_off ) {
 750         my $state = $self->lemmata->{$n->position};
 751         if( $state && $state eq $n->name ) {
 752             # this reading is still on, so turn it off
 753             push( @readings_delemmatized, $n );
 754             my $new_state = undef;
 755             if( $n eq $reading ) {
 756                 # This is the reading that was clicked, so if there are no
 757                 # other readings there, turn off the position.  In all other
 758                 # cases, restore the ellipsis.
 759                 my @other_n = $self->same_position_as( $n );
 760                 $new_state = 0 unless @other_n;
 761             }
 762             $self->lemmata->{$n->position} = $new_state;
 763         } elsif( $old_state && $old_state eq $n->name ) {
 764             # another reading has already been turned on here
 765             push( @readings_delemmatized, $n );
 766         } # else some other reading was on anyway, so pass.
 767     }
 768     return @readings_delemmatized;
 769 }
 770
 771 sub same_position_as {
 772     my( $self, $reading ) = @_;
 773     my $pos = $reading->position;
 774     my @same = grep { $_ ne $reading } $self->readings_at_position( $reading->position );
 775     return @same;
 776 }
 777
 778 # Return the string that joins together a list of witnesses for
 779 # display on a single path.
 780 sub path_label {
 781     my $self = shift;
 782     return join( $self->wit_list_separator, @_ );
 783 }
 784
 785 sub witnesses_of_label {
 786     my( $self, $label ) = @_;
 787     my $regex = $self->wit_list_separator;
 788     my @answer = split( /\Q$regex\E/, $label );
 789     return @answer;
 790 }
 791
 792 sub unique_list {
 793     my( @list ) = @_;
 794     my %h;
 795     map { $h{$_->name} = $_ } @list;
 796     return values( %h );
 797 }
 798
 799 no Moose;
 800 __PACKAGE__->meta->make_immutable;