base/lib/Text/Tradition/Collation.pm

   1 package Text::Tradition::Collation;
   2
   3 use feature 'say';
   4 use Encode qw( decode_utf8 );
   5 use File::Temp;
   6 use File::Which;
   7 use Graph;
   8 use IPC::Run qw( run binary );
   9 use Text::CSV;
  10 use Text::Tradition::Collation::Data;
  11 use Text::Tradition::Collation::Reading;
  12 use Text::Tradition::Collation::RelationshipStore;
  13 use Text::Tradition::Error;
  14 use XML::Easy::Syntax qw( $xml10_namestartchar_rx $xml10_namechar_rx );
  15 use XML::LibXML;
  16 use XML::LibXML::XPathContext;
  17 use Moose;
  18
  19 has _data => (
  20         isa      => 'Text::Tradition::Collation::Data',
  21         is       => 'ro',
  22         required => 1,
  23         handles  => [ qw(
  24                 sequence
  25                 paths
  26                 _set_relations
  27                 relations
  28                 _set_start
  29                 _set_end
  30                 ac_label
  31                 has_cached_table
  32                 relationships
  33                 related_readings
  34                 get_relationship
  35                 del_relationship
  36                 equivalence
  37                 equivalence_graph
  38                 readings
  39                 reading
  40                 _add_reading
  41                 del_reading
  42                 has_reading
  43                 wit_list_separator
  44                 baselabel
  45                 linear
  46                 wordsep
  47                 start
  48                 end
  49                 cached_table
  50                 _graphcalc_done
  51                 has_cached_svg
  52                 wipe_table
  53         )]
  54 );
  55
  56 has 'tradition' => (
  57     is => 'ro',
  58     isa => 'Text::Tradition',
  59     writer => '_set_tradition',
  60     weak_ref => 1,
  61     );
  62
  63 =head1 NAME
  64
  65 Text::Tradition::Collation - a software model for a text collation
  66
  67 =head1 SYNOPSIS
  68
  69   use Text::Tradition;
  70   my $t = Text::Tradition->new(
  71     'name' => 'this is a text',
  72     'input' => 'TEI',
  73     'file' => '/path/to/tei_parallel_seg_file.xml' );
  74
  75   my $c = $t->collation;
  76   my @readings = $c->readings;
  77   my @paths = $c->paths;
  78   my @relationships = $c->relationships;
  79
  80   my $svg_variant_graph = $t->collation->as_svg();
  81
  82 =head1 DESCRIPTION
  83
  84 Text::Tradition is a library for representation and analysis of collated
  85 texts, particularly medieval ones.  The Collation is the central feature of
  86 a Tradition, where the text, its sequence of readings, and its relationships
  87 between readings are actually kept.
  88
  89 =head1 CONSTRUCTOR
  90
  91 =head2 new
  92
  93 The constructor.  Takes a hash or hashref of the following arguments:
  94
  95 =over
  96
  97 =item * tradition - The Text::Tradition object to which the collation
  98 belongs. Required.
  99
 100 =item * linear - Whether the collation should be linear; that is, whether
 101 transposed readings should be treated as two linked readings rather than one,
 102 and therefore whether the collation graph is acyclic.  Defaults to true.
 103
 104 =item * baselabel - The default label for the path taken by a base text
 105 (if any). Defaults to 'base text'.
 106
 107 =item * wit_list_separator - The string to join a list of witnesses for
 108 purposes of making labels in display graphs.  Defaults to ', '.
 109
 110 =item * ac_label - The extra label to tack onto a witness sigil when
 111 representing another layer of path for the given witness - that is, when
 112 a text has more than one possible reading due to scribal corrections or
 113 the like.  Defaults to ' (a.c.)'.
 114
 115 =item * wordsep - The string used to separate words in the original text.
 116 Defaults to ' '.
 117
 118 =back
 119
 120 =head1 ACCESSORS
 121
 122 =head2 tradition
 123
 124 =head2 linear
 125
 126 =head2 wit_list_separator
 127
 128 =head2 baselabel
 129
 130 =head2 ac_label
 131
 132 =head2 wordsep
 133
 134 Simple accessors for collation attributes.
 135
 136 =head2 start
 137
 138 The meta-reading at the start of every witness path.
 139
 140 =head2 end
 141
 142 The meta-reading at the end of every witness path.
 143
 144 =head2 readings
 145
 146 Returns all Reading objects in the graph.
 147
 148 =head2 reading( $id )
 149
 150 Returns the Reading object corresponding to the given ID.
 151
 152 =head2 add_reading( $reading_args )
 153
 154 Adds a new reading object to the collation.
 155 See L<Text::Tradition::Collation::Reading> for the available arguments.
 156
 157 =head2 del_reading( $object_or_id )
 158
 159 Removes the given reading from the collation, implicitly removing its
 160 paths and relationships.
 161
 162 =head2 merge_readings( $main, $second, $concatenate, $with_str )
 163
 164 Merges the $second reading into the $main one. If $concatenate is true, then
 165 the merged node will carry the text of both readings, concatenated with either
 166 $with_str (if specified) or a sensible default (the empty string if the
 167 appropriate 'join_*' flag is set on either reading, or else $self->wordsep.)
 168
 169 The first two arguments may be either readings or reading IDs.
 170
 171 =head2 has_reading( $id )
 172
 173 Predicate to see whether a given reading ID is in the graph.
 174
 175 =head2 reading_witnesses( $object_or_id )
 176
 177 Returns a list of sigils whose witnesses contain the reading.
 178
 179 =head2 paths
 180
 181 Returns all reading paths within the document - that is, all edges in the
 182 collation graph.  Each path is an arrayref of [ $source, $target ] reading IDs.
 183
 184 =head2 add_path( $source, $target, $sigil )
 185
 186 Links the given readings in the collation in sequence, under the given witness
 187 sigil.  The readings may be specified by object or ID.
 188
 189 =head2 del_path( $source, $target, $sigil )
 190
 191 Links the given readings in the collation in sequence, under the given witness
 192 sigil.  The readings may be specified by object or ID.
 193
 194 =head2 has_path( $source, $target );
 195
 196 Returns true if the two readings are linked in sequence in any witness.
 197 The readings may be specified by object or ID.
 198
 199 =head2 relationships
 200
 201 Returns all Relationship objects in the collation.
 202
 203 =head2 add_relationship( $reading, $other_reading, $options )
 204
 205 Adds a new relationship of the type given in $options between the two readings,
 206 which may be specified by object or ID.  Returns a value of ( $status, @vectors)
 207 where $status is true on success, and @vectors is a list of relationship edges
 208 that were ultimately added.
 209 See L<Text::Tradition::Collation::Relationship> for the available options.
 210
 211 =cut
 212
 213 sub BUILDARGS {
 214         my ( $class, @args ) = @_;
 215         my %args = @args == 1 ? %{ $args[0] } : @args;
 216         # TODO determine these from the Moose::Meta object
 217         my @delegate_attrs = qw(sequence relations readings wit_list_separator baselabel
 218                 linear wordsep start end cached_table _graphcalc_done);
 219         my %data_args;
 220         for my $attr (@delegate_attrs) {
 221                 $data_args{$attr} = delete $args{$attr} if exists $args{$attr};
 222         }
 223         $args{_data} = Text::Tradition::Collation::Data->new(%data_args);
 224         return \%args;
 225 }
 226
 227 sub BUILD {
 228     my $self = shift;
 229     $self->_set_relations( Text::Tradition::Collation::RelationshipStore->new( 'collation' => $self ) );
 230     $self->_set_start( $self->add_reading(
 231         { 'collation' => $self, 'is_start' => 1, 'init' => 1 } ) );
 232     $self->_set_end( $self->add_reading(
 233         { 'collation' => $self, 'is_end' => 1, 'init' => 1 } ) );
 234 }
 235
 236 ### Reading construct/destruct functions
 237
 238 sub add_reading {
 239         my( $self, $reading ) = @_;
 240         unless( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
 241                 my %args = %$reading;
 242                 if( $args{'init'} ) {
 243                         # If we are initializing an empty collation, don't assume that we
 244                         # have set a tradition.
 245                         delete $args{'init'};
 246                 } elsif( $self->tradition->has_language && !exists $args{'language'} ) {
 247                         $args{'language'} = $self->tradition->language;
 248                 }
 249                 $reading = Text::Tradition::Collation::Reading->new(
 250                         'collation' => $self,
 251                         %args );
 252         }
 253         # First check to see if a reading with this ID exists.
 254         if( $self->reading( $reading->id ) ) {
 255                 throw( "Collation already has a reading with id " . $reading->id );
 256         }
 257         $self->_graphcalc_done(0);
 258         $self->_add_reading( $reading->id => $reading );
 259         # Once the reading has been added, put it in both graphs.
 260         $self->sequence->add_vertex( $reading->id );
 261         $self->relations->add_reading( $reading->id );
 262         return $reading;
 263 };
 264
 265 around del_reading => sub {
 266         my $orig = shift;
 267         my $self = shift;
 268         my $arg = shift;
 269
 270         if( ref( $arg ) eq 'Text::Tradition::Collation::Reading' ) {
 271                 $arg = $arg->id;
 272         }
 273         # Remove the reading from the graphs.
 274         $self->_graphcalc_done(0);
 275         $self->_clear_cache; # Explicitly clear caches to GC the reading
 276         $self->sequence->delete_vertex( $arg );
 277         $self->relations->delete_reading( $arg );
 278
 279         # Carry on.
 280         $self->$orig( $arg );
 281 };
 282
 283 =begin testing
 284
 285 use Text::Tradition;
 286
 287 my $cxfile = 't/data/Collatex-16.xml';
 288 my $t = Text::Tradition->new(
 289     'name'  => 'inline',
 290     'input' => 'CollateX',
 291     'file'  => $cxfile,
 292     );
 293 my $c = $t->collation;
 294
 295 my $rno = scalar $c->readings;
 296 # Split n21 for testing purposes
 297 my $new_r = $c->add_reading( { 'id' => 'n21p0', 'text' => 'un', 'join_next' => 1 } );
 298 my $old_r = $c->reading( 'n21' );
 299 $old_r->alter_text( 'to' );
 300 $c->del_path( 'n20', 'n21', 'A' );
 301 $c->add_path( 'n20', 'n21p0', 'A' );
 302 $c->add_path( 'n21p0', 'n21', 'A' );
 303 $c->flatten_ranks();
 304 ok( $c->reading( 'n21p0' ), "New reading exists" );
 305 is( scalar $c->readings, $rno, "Reading add offset by flatten_ranks" );
 306
 307 # Combine n3 and n4 ( with his )
 308 $c->merge_readings( 'n3', 'n4', 1 );
 309 ok( !$c->reading('n4'), "Reading n4 is gone" );
 310 is( $c->reading('n3')->text, 'with his', "Reading n3 has both words" );
 311
 312 # Collapse n9 and n10 ( rood / root )
 313 $c->merge_readings( 'n9', 'n10' );
 314 ok( !$c->reading('n10'), "Reading n10 is gone" );
 315 is( $c->reading('n9')->text, 'rood', "Reading n9 has an unchanged word" );
 316
 317 # Combine n21 and n21p0
 318 my $remaining = $c->reading('n21');
 319 $remaining ||= $c->reading('n22');  # one of these should still exist
 320 $c->merge_readings( 'n21p0', $remaining, 1 );
 321 ok( !$c->reading('n21'), "Reading $remaining is gone" );
 322 is( $c->reading('n21p0')->text, 'unto', "Reading n21p0 merged correctly" );
 323
 324 =end testing
 325
 326 =cut
 327
 328 sub merge_readings {
 329         my $self = shift;
 330
 331         # Sanity check
 332         my( $kept_obj, $del_obj, $combine, $combine_char ) = $self->_objectify_args( @_ );
 333         my $mergemeta = $kept_obj->is_meta;
 334         throw( "Cannot merge meta and non-meta reading" )
 335                 unless ( $mergemeta && $del_obj->is_meta )
 336                         || ( !$mergemeta && !$del_obj->is_meta );
 337         if( $mergemeta ) {
 338                 throw( "Cannot merge with start or end node" )
 339                         if( $kept_obj eq $self->start || $kept_obj eq $self->end
 340                                 || $del_obj eq $self->start || $del_obj eq $self->end );
 341         }
 342         # We only need the IDs for adding paths to the graph, not the reading
 343         # objects themselves.
 344         my $kept = $kept_obj->id;
 345         my $deleted = $del_obj->id;
 346         $self->_graphcalc_done(0);
 347
 348     # The kept reading should inherit the paths and the relationships
 349     # of the deleted reading.
 350         foreach my $path ( $self->sequence->edges_at( $deleted ) ) {
 351                 my @vector = ( $kept );
 352                 push( @vector, $path->[1] ) if $path->[0] eq $deleted;
 353                 unshift( @vector, $path->[0] ) if $path->[1] eq $deleted;
 354                 next if $vector[0] eq $vector[1]; # Don't add a self loop
 355                 my %wits = %{$self->sequence->get_edge_attributes( @$path )};
 356                 $self->sequence->add_edge( @vector );
 357                 my $fwits = $self->sequence->get_edge_attributes( @vector );
 358                 @wits{keys %$fwits} = values %$fwits;
 359                 $self->sequence->set_edge_attributes( @vector, \%wits );
 360         }
 361         $self->relations->merge_readings( $kept, $deleted, $combine );
 362
 363         # Do the deletion deed.
 364         if( $combine ) {
 365                 # Combine the text of the readings
 366                 my $joinstr = $combine_char;
 367                 unless( defined $joinstr ) {
 368                         $joinstr = '' if $kept_obj->join_next || $del_obj->join_prior;
 369                         $joinstr = $self->wordsep unless defined $joinstr;
 370                 }
 371                 $kept_obj->alter_text( join( $joinstr, $kept_obj->text, $del_obj->text ) );
 372                 # Change this reading to a joining one if necessary
 373                 $kept_obj->_set_join_next( $del_obj->join_next );
 374                 $kept_obj->normal_form(
 375                         join( $joinstr, $kept_obj->normal_form, $del_obj->normal_form ) );
 376                 # Combine the lexemes present in the readings
 377                 if( $kept_obj->has_lexemes && $del_obj->has_lexemes ) {
 378                         $kept_obj->add_lexeme( $del_obj->lexemes );
 379                 }
 380         }
 381         $self->del_reading( $deleted );
 382 }
 383
 384 =head2 compress_readings
 385
 386 Where possible in the graph, compresses plain sequences of readings into a
 387 single reading. The sequences must consist of readings with no
 388 relationships to other readings, with only a single witness path between
 389 them and no other witness paths from either that would skip the other. The
 390 readings must also not be marked as nonsense or bad grammar.
 391
 392 WARNING: This operation cannot be undone.
 393
 394 =cut
 395
 396 sub compress_readings {
 397         my $self = shift;
 398         # Anywhere in the graph that there is a reading that joins only to a single
 399         # successor, and neither of these have any relationships, just join the two
 400         # readings.
 401         my %gobbled;
 402         foreach my $rdg ( sort { $a->rank <=> $b->rank } $self->readings ) {
 403                 # While we are here, get rid of any extra wordforms from a disambiguated
 404                 # reading.
 405                 if( $rdg->disambiguated ) {
 406                         foreach my $lex ( $rdg->lexemes ) {
 407                                 $lex->clear_matching_forms();
 408                                 $lex->add_matching_form( $lex->form );
 409                         }
 410                 }
 411                 # Now look for readings that can be joined to their successors.
 412                 next if $rdg->is_meta;
 413                 next if $gobbled{$rdg->id};
 414                 next if $rdg->grammar_invalid || $rdg->is_nonsense;
 415                 next if $rdg->related_readings();
 416                 my %seen;
 417                 while( $self->sequence->successors( $rdg ) == 1 ) {
 418                         my( $next ) = $self->reading( $self->sequence->successors( $rdg ) );
 419                         throw( "Infinite loop" ) if $seen{$next->id};
 420                         $seen{$next->id} = 1;
 421                         last if $self->sequence->predecessors( $next ) > 1;
 422                         last if $next->is_meta;
 423                         last if $next->grammar_invalid || $next->is_nonsense;
 424                         last if $next->related_readings();
 425                         say "Joining readings $rdg and $next";
 426                         $self->merge_readings( $rdg, $next, 1 );
 427                 }
 428         }
 429         # Make sure we haven't screwed anything up
 430         foreach my $wit ( $self->tradition->witnesses ) {
 431                 my $pathtext = $self->path_text( $wit->sigil );
 432                 my $origtext = join( ' ', @{$wit->text} );
 433                 throw( "Text differs for witness " . $wit->sigil )
 434                         unless $pathtext eq $origtext;
 435                 if( $wit->is_layered ) {
 436                         $pathtext = $self->path_text( $wit->sigil.$self->ac_label );
 437                         $origtext = join( ' ', @{$wit->layertext} );
 438                         throw( "Ante-corr text differs for witness " . $wit->sigil )
 439                                 unless $pathtext eq $origtext;
 440                 }
 441         }
 442
 443         $self->relations->rebuild_equivalence();
 444         $self->calculate_ranks();
 445 }
 446
 447 # Helper function for manipulating the graph.
 448 sub _stringify_args {
 449         my( $self, $first, $second, @args ) = @_;
 450     $first = $first->id
 451         if ref( $first ) eq 'Text::Tradition::Collation::Reading';
 452     $second = $second->id
 453         if ref( $second ) eq 'Text::Tradition::Collation::Reading';
 454     return( $first, $second, @args );
 455 }
 456
 457 # Helper function for manipulating the graph.
 458 sub _objectify_args {
 459         my( $self, $first, $second, $arg ) = @_;
 460     $first = $self->reading( $first )
 461         unless ref( $first ) eq 'Text::Tradition::Collation::Reading';
 462     $second = $self->reading( $second )
 463         unless ref( $second ) eq 'Text::Tradition::Collation::Reading';
 464     return( $first, $second, $arg );
 465 }
 466 ### Path logic
 467
 468 sub add_path {
 469         my $self = shift;
 470
 471         # We only need the IDs for adding paths to the graph, not the reading
 472         # objects themselves.
 473     my( $source, $target, $wit ) = $self->_stringify_args( @_ );
 474
 475         $self->_graphcalc_done(0);
 476         # Connect the readings
 477         unless( $self->sequence->has_edge( $source, $target ) ) {
 478             $self->sequence->add_edge( $source, $target );
 479             $self->relations->add_equivalence_edge( $source, $target );
 480         }
 481     # Note the witness in question
 482     $self->sequence->set_edge_attribute( $source, $target, $wit, 1 );
 483 }
 484
 485 sub del_path {
 486         my $self = shift;
 487         my @args;
 488         if( ref( $_[0] ) eq 'ARRAY' ) {
 489                 my $e = shift @_;
 490                 @args = ( @$e, @_ );
 491         } else {
 492                 @args = @_;
 493         }
 494
 495         # We only need the IDs for adding paths to the graph, not the reading
 496         # objects themselves.
 497     my( $source, $target, $wit ) = $self->_stringify_args( @args );
 498
 499         $self->_graphcalc_done(0);
 500         if( $self->sequence->has_edge_attribute( $source, $target, $wit ) ) {
 501                 $self->sequence->delete_edge_attribute( $source, $target, $wit );
 502         }
 503         unless( keys %{$self->sequence->get_edge_attributes( $source, $target )} ) {
 504                 $self->sequence->delete_edge( $source, $target );
 505                 $self->relations->delete_equivalence_edge( $source, $target );
 506         }
 507 }
 508
 509
 510 # Extra graph-alike utility
 511 sub has_path {
 512         my $self = shift;
 513     my( $source, $target, $wit ) = $self->_stringify_args( @_ );
 514         return undef unless $self->sequence->has_edge( $source, $target );
 515         return $self->sequence->has_edge_attribute( $source, $target, $wit );
 516 }
 517
 518 =head2 clear_witness( @sigil_list )
 519
 520 Clear the given witnesses out of the collation entirely, removing references
 521 to them in paths, and removing readings that belong only to them.  Should only
 522 be called via $tradition->del_witness.
 523
 524 =cut
 525
 526 sub clear_witness {
 527         my( $self, @sigils ) = @_;
 528
 529         $self->_graphcalc_done(0);
 530         # Clear the witness(es) out of the paths
 531         foreach my $e ( $self->paths ) {
 532                 foreach my $sig ( @sigils ) {
 533                         $self->del_path( $e, $sig );
 534                 }
 535         }
 536
 537         # Clear out the newly unused readings
 538         foreach my $r ( $self->readings ) {
 539                 unless( $self->reading_witnesses( $r ) ) {
 540                         $self->del_reading( $r );
 541                 }
 542         }
 543 }
 544
 545 sub add_relationship {
 546         my $self = shift;
 547     my( $source, $target, $opts ) = $self->_stringify_args( @_ );
 548     my( @vectors ) = $self->relations->add_relationship( $source, $target, $opts );
 549         $self->_graphcalc_done(0);
 550     return @vectors;
 551 }
 552
 553 around qw/ get_relationship del_relationship / => sub {
 554         my $orig = shift;
 555         my $self = shift;
 556         my @args = @_;
 557         if( @args == 1 && ref( $args[0] ) eq 'ARRAY' ) {
 558                 @args = @{$_[0]};
 559         }
 560         my( $source, $target ) = $self->_stringify_args( @args );
 561         $self->$orig( $source, $target );
 562 };
 563
 564 =head2 reading_witnesses( $reading )
 565
 566 Return a list of sigils corresponding to the witnesses in which the reading appears.
 567
 568 =cut
 569
 570 sub reading_witnesses {
 571         my( $self, $reading ) = @_;
 572         # We need only check either the incoming or the outgoing edges; I have
 573         # arbitrarily chosen "incoming".  Thus, special-case the start node.
 574         if( $reading eq $self->start ) {
 575                 return map { $_->sigil } $self->tradition->witnesses;
 576         }
 577         my %all_witnesses;
 578         foreach my $e ( $self->sequence->edges_to( $reading ) ) {
 579                 my $wits = $self->sequence->get_edge_attributes( @$e );
 580                 @all_witnesses{ keys %$wits } = 1;
 581         }
 582         my $acstr = $self->ac_label;
 583         foreach my $acwit ( grep { $_ =~ s/^(.*)\Q$acstr\E$/$1/ } keys %all_witnesses ) {
 584                 delete $all_witnesses{$acwit.$acstr} if exists $all_witnesses{$acwit};
 585         }
 586         return keys %all_witnesses;
 587 }
 588
 589 =head1 OUTPUT METHODS
 590
 591 =head2 as_svg( \%options )
 592
 593 Returns an SVG string that represents the graph, via as_dot and graphviz.
 594 See as_dot for a list of options.  Must have GraphViz (dot) installed to run.
 595
 596 =cut
 597
 598 sub as_svg {
 599     my( $self, $opts ) = @_;
 600     throw( "Need GraphViz installed to output SVG" )
 601         unless File::Which::which( 'dot' );
 602     my $want_subgraph = exists $opts->{'from'} || exists $opts->{'to'};
 603     $self->calculate_ranks()
 604         unless( $self->_graphcalc_done || $opts->{'nocalc'} || !$self->linear );
 605         my @cmd = qw/dot -Tsvg/;
 606         my( $svg, $err );
 607         my $dotfile = File::Temp->new();
 608         ## USE FOR DEBUGGING
 609         # $dotfile->unlink_on_destroy(0);
 610         binmode $dotfile, ':utf8';
 611         print $dotfile $self->as_dot( $opts );
 612         push( @cmd, $dotfile->filename );
 613         run( \@cmd, ">", binary(), \$svg );
 614         $svg = decode_utf8( $svg );
 615         return $svg;
 616 }
 617
 618
 619 =head2 as_dot( \%options )
 620
 621 Returns a string that is the collation graph expressed in dot
 622 (i.e. GraphViz) format.  Options include:
 623
 624 =over 4
 625
 626 =item * from
 627
 628 =item * to
 629
 630 =item * color_common
 631
 632 =back
 633
 634 =cut
 635
 636 sub as_dot {
 637     my( $self, $opts ) = @_;
 638     my $startrank = $opts->{'from'} if $opts;
 639     my $endrank = $opts->{'to'} if $opts;
 640     my $color_common = $opts->{'color_common'} if $opts;
 641     my $STRAIGHTENHACK = !$startrank && !$endrank && $self->end->rank
 642        && $self->end->rank > 100;
 643     $STRAIGHTENHACK = 1 if $opts->{'straight'}; # even for subgraphs or small graphs
 644
 645     # Check the arguments
 646     if( $startrank ) {
 647         return if $endrank && $startrank > $endrank;
 648         return if $startrank > $self->end->rank;
 649         }
 650         if( defined $endrank ) {
 651                 return if $endrank < 0;
 652                 $endrank = undef if $endrank == $self->end->rank;
 653         }
 654
 655     my $graph_name = $self->tradition->name;
 656     $graph_name =~ s/[^\w\s]//g;
 657     $graph_name = join( '_', split( /\s+/, $graph_name ) );
 658
 659     my %graph_attrs = (
 660         'rankdir' => 'LR',
 661         'bgcolor' => 'none',
 662         );
 663     my %node_attrs = (
 664         'fontsize' => 14,
 665         'fillcolor' => 'white',
 666         'style' => 'filled',
 667         'shape' => 'ellipse'
 668         );
 669     my %edge_attrs = (
 670         'arrowhead' => 'open',
 671         'color' => '#000000',
 672         'fontcolor' => '#000000',
 673         );
 674
 675     my $dot = sprintf( "digraph %s {\n", $graph_name );
 676     $dot .= "\tgraph " . _dot_attr_string( \%graph_attrs ) . ";\n";
 677     $dot .= "\tnode " . _dot_attr_string( \%node_attrs ) . ";\n";
 678
 679         # Output substitute start/end readings if necessary
 680         if( $startrank ) {
 681                 $dot .= "\t\"__SUBSTART__\" [ label=\"...\",id=\"__START__\" ];\n";
 682         }
 683         if( $endrank ) {
 684                 $dot .= "\t\"__SUBEND__\" [ label=\"...\",id=\"__END__\" ];\n";
 685         }
 686         if( $STRAIGHTENHACK ) {
 687                 ## HACK part 1
 688                 my $startlabel = $startrank ? '__SUBSTART__' : '__START__';
 689                 $dot .= "\tsubgraph { rank=same \"$startlabel\" \"#SILENT#\" }\n";
 690                 $dot .= "\t\"#SILENT#\" [ shape=diamond,color=white,penwidth=0,label=\"\" ];"
 691         }
 692         my %used;  # Keep track of the readings that actually appear in the graph
 693         # Sort the readings by rank if we have ranks; this speeds layout.
 694         my @all_readings = $self->end->has_rank
 695                 ? sort { $a->rank <=> $b->rank } $self->readings
 696                 : $self->readings;
 697         # TODO Refrain from outputting lacuna nodes - just grey out the edges.
 698     foreach my $reading ( @all_readings ) {
 699         # Only output readings within our rank range.
 700         next if $startrank && $reading->rank < $startrank;
 701         next if $endrank && $reading->rank > $endrank;
 702         $used{$reading->id} = 1;
 703         # Need not output nodes without separate labels
 704         next if $reading->id eq $reading->text;
 705         my $rattrs;
 706         my $label = $reading->text;
 707         $label .= '-' if $reading->join_next;
 708         $label = "-$label" if $reading->join_prior;
 709         $label =~ s/\"/\\\"/g;
 710                 $rattrs->{'label'} = $label;
 711                 $rattrs->{'id'} = $reading->id;
 712                 $rattrs->{'fillcolor'} = '#b3f36d' if $reading->is_common && $color_common;
 713         $dot .= sprintf( "\t\"%s\" %s;\n", $reading->id, _dot_attr_string( $rattrs ) );
 714     }
 715
 716         # Add the real edges. Need to weight one edge per rank jump, in a
 717         # continuous line.
 718         # my $weighted = $self->_add_edge_weights;
 719     my @edges = $self->paths;
 720         my( %substart, %subend );
 721     foreach my $edge ( @edges ) {
 722         # Do we need to output this edge?
 723         if( $used{$edge->[0]} && $used{$edge->[1]} ) {
 724                 my $label = $self->_path_display_label( $self->path_witnesses( $edge ) );
 725                         my $variables = { %edge_attrs, 'label' => $label };
 726
 727                         # Account for the rank gap if necessary
 728                         my $rank0 = $self->reading( $edge->[0] )->rank
 729                                 if $self->reading( $edge->[0] )->has_rank;
 730                         my $rank1 = $self->reading( $edge->[1] )->rank
 731                                 if $self->reading( $edge->[1] )->has_rank;
 732                         if( defined $rank0 && defined $rank1 && $rank1 - $rank0 > 1 ) {
 733                                 $variables->{'minlen'} = $rank1 - $rank0;
 734                         }
 735
 736                         # Add the calculated edge weights
 737                         # if( exists $weighted->{$edge->[0]}
 738                         #       && $weighted->{$edge->[0]} eq $edge->[1] ) {
 739                         #       # $variables->{'color'} = 'red';
 740                         #       $variables->{'weight'} = 3.0;
 741                         # }
 742
 743                         # EXPERIMENTAL: make edge width reflect no. of witnesses
 744                         my $extrawidth = scalar( $self->path_witnesses( $edge ) ) * 0.2;
 745                         $variables->{'penwidth'} = $extrawidth + 0.8; # gives 1 for a single wit
 746
 747                         my $varopts = _dot_attr_string( $variables );
 748                         $dot .= sprintf( "\t\"%s\" -> \"%s\" %s;\n",
 749                                 $edge->[0], $edge->[1], $varopts );
 750         } elsif( $used{$edge->[0]} ) {
 751                 $subend{$edge->[0]} = $edge->[1];
 752         } elsif( $used{$edge->[1]} ) {
 753                 $substart{$edge->[1]} = $edge->[0];
 754         }
 755     }
 756     # Add substitute start and end edges if necessary
 757     foreach my $node ( keys %substart ) {
 758         my $witstr = $self->_path_display_label ( $self->path_witnesses( $substart{$node}, $node ) );
 759         my $variables = { %edge_attrs, 'label' => $witstr };
 760         my $nrdg = $self->reading( $node );
 761         if( $nrdg->has_rank && $nrdg->rank > $startrank ) {
 762                 # Substart is actually one lower than $startrank
 763                 $variables->{'minlen'} = $nrdg->rank - ( $startrank - 1 );
 764         }
 765         my $varopts = _dot_attr_string( $variables );
 766         $dot .= "\t\"__SUBSTART__\" -> \"$node\" $varopts;\n";
 767         }
 768     foreach my $node ( keys %subend ) {
 769         my $witstr = $self->_path_display_label ( $self->path_witnesses( $node, $subend{$node} ) );
 770         my $variables = { %edge_attrs, 'label' => $witstr };
 771         my $varopts = _dot_attr_string( $variables );
 772         $dot .= "\t\"$node\" -> \"__SUBEND__\" $varopts;\n";
 773         }
 774         # HACK part 2
 775         if( $STRAIGHTENHACK ) {
 776                 my $endlabel = $endrank ? '__SUBEND__' : '__END__';
 777                 $dot .= "\t\"$endlabel\" -> \"#SILENT#\" [ color=white,penwidth=0 ];\n";
 778         }
 779
 780     $dot .= "}\n";
 781     return $dot;
 782 }
 783
 784 sub _dot_attr_string {
 785         my( $hash ) = @_;
 786         my @attrs;
 787         foreach my $k ( sort keys %$hash ) {
 788                 my $v = $hash->{$k};
 789                 push( @attrs, $k.'="'.$v.'"' );
 790         }
 791         return( '[ ' . join( ', ', @attrs ) . ' ]' );
 792 }
 793
 794 sub _add_edge_weights {
 795         my $self = shift;
 796         # Walk the graph from START to END, choosing the successor node with
 797         # the largest number of witness paths each time.
 798         my $weighted = {};
 799         my $curr = $self->start->id;
 800         my $ranked = $self->end->has_rank;
 801         while( $curr ne $self->end->id ) {
 802                 my $rank = $ranked ? $self->reading( $curr )->rank : 0;
 803                 my @succ = sort { $self->path_witnesses( $curr, $a )
 804                                                         <=> $self->path_witnesses( $curr, $b ) }
 805                         $self->sequence->successors( $curr );
 806                 my $next = pop @succ;
 807                 my $nextrank = $ranked ? $self->reading( $next )->rank : 0;
 808                 # Try to avoid lacunae in the weighted path.
 809                 while( @succ &&
 810                            ( $self->reading( $next )->is_lacuna ||
 811                                  $nextrank - $rank > 1 ) ){
 812                         $next = pop @succ;
 813                 }
 814                 $weighted->{$curr} = $next;
 815                 $curr = $next;
 816         }
 817         return $weighted;
 818 }
 819
 820 =head2 path_witnesses( $edge )
 821
 822 Returns the list of sigils whose witnesses are associated with the given edge.
 823 The edge can be passed as either an array or an arrayref of ( $source, $target ).
 824
 825 =cut
 826
 827 sub path_witnesses {
 828         my( $self, @edge ) = @_;
 829         # If edge is an arrayref, cope.
 830         if( @edge == 1 && ref( $edge[0] ) eq 'ARRAY' ) {
 831                 my $e = shift @edge;
 832                 @edge = @$e;
 833         }
 834         my @wits = keys %{$self->sequence->get_edge_attributes( @edge )};
 835         return @wits;
 836 }
 837
 838 # Helper function. Make a display label for the given witnesses, showing a.c.
 839 # witnesses only where the main witness is not also in the list.
 840 sub _path_display_label {
 841         my $self = shift;
 842         my %wits;
 843         map { $wits{$_} = 1 } @_;
 844
 845         # If an a.c. wit is listed, remove it if the main wit is also listed.
 846         # Otherwise keep it for explicit listing.
 847         my $aclabel = $self->ac_label;
 848         my @disp_ac;
 849         foreach my $w ( sort keys %wits ) {
 850                 if( $w =~ /^(.*)\Q$aclabel\E$/ ) {
 851                         if( exists $wits{$1} ) {
 852                                 delete $wits{$w};
 853                         } else {
 854                                 push( @disp_ac, $w );
 855                         }
 856                 }
 857         }
 858
 859         # See if we are in a majority situation.
 860         my $maj = scalar( $self->tradition->witnesses ) * 0.6;
 861         $maj = $maj > 5 ? $maj : 5;
 862         if( scalar keys %wits > $maj ) {
 863                 unshift( @disp_ac, 'majority' );
 864                 return join( ', ', @disp_ac );
 865         } else {
 866                 return join( ', ', sort keys %wits );
 867         }
 868 }
 869
 870 =head2 readings_at_rank( $rank )
 871
 872 Returns a list of readings at a given rank, taken from the alignment table.
 873
 874 =cut
 875
 876 sub readings_at_rank {
 877         my( $self, $rank ) = @_;
 878         my $table = $self->alignment_table;
 879         # Table rank is real rank - 1.
 880         my @elements = map { $_->{'tokens'}->[$rank-1] } @{$table->{'alignment'}};
 881         my %readings;
 882         foreach my $e ( @elements ) {
 883                 next unless ref( $e ) eq 'HASH';
 884                 next unless exists $e->{'t'};
 885                 $readings{$e->{'t'}->id} = $e->{'t'};
 886         }
 887         return values %readings;
 888 }
 889
 890 =head2 as_graphml
 891
 892 Returns a GraphML representation of the collation.  The GraphML will contain
 893 two graphs. The first expresses the attributes of the readings and the witness
 894 paths that link them; the second expresses the relationships that link the
 895 readings.  This is the native transfer format for a tradition.
 896
 897 =begin testing
 898
 899 use Text::Tradition;
 900 use TryCatch;
 901
 902 my $READINGS = 311;
 903 my $PATHS = 361;
 904
 905 my $datafile = 't/data/florilegium_tei_ps.xml';
 906 my $tradition = Text::Tradition->new( 'input' => 'TEI',
 907                                       'name' => 'test0',
 908                                       'file' => $datafile,
 909                                       'linear' => 1 );
 910
 911 ok( $tradition, "Got a tradition object" );
 912 is( scalar $tradition->witnesses, 13, "Found all witnesses" );
 913 ok( $tradition->collation, "Tradition has a collation" );
 914
 915 my $c = $tradition->collation;
 916 is( scalar $c->readings, $READINGS, "Collation has all readings" );
 917 is( scalar $c->paths, $PATHS, "Collation has all paths" );
 918 is( scalar $c->relationships, 0, "Collation has all relationships" );
 919
 920 # Add a few relationships
 921 $c->add_relationship( 'w123', 'w125', { 'type' => 'collated' } );
 922 $c->add_relationship( 'w193', 'w196', { 'type' => 'collated' } );
 923 $c->add_relationship( 'w257', 'w262', { 'type' => 'transposition' } );
 924
 925 # Now write it to GraphML and parse it again.
 926
 927 my $graphml = $c->as_graphml;
 928 my $st = Text::Tradition->new( 'input' => 'Self', 'string' => $graphml );
 929 is( scalar $st->collation->readings, $READINGS, "Reparsed collation has all readings" );
 930 is( scalar $st->collation->paths, $PATHS, "Reparsed collation has all paths" );
 931 is( scalar $st->collation->relationships, 3, "Reparsed collation has new relationships" );
 932
 933 # Now add a stemma, write to GraphML, and look at the output.
 934 my $SKIP_STEMMA;
 935 try {
 936         $tradition->enable_stemmata;
 937 } catch {
 938         $SKIP_STEMMA = 1;
 939 }
 940 SKIP: {
 941         skip "Analysis module not present", 3 if $SKIP_STEMMA;
 942         my $stemma = $tradition->add_stemma( 'dotfile' => 't/data/florilegium.dot' );
 943         is( ref( $stemma ), 'Text::Tradition::Stemma', "Parsed dotfile into stemma" );
 944         is( $tradition->stemmata, 1, "Tradition now has the stemma" );
 945         $graphml = $c->as_graphml;
 946         like( $graphml, qr/digraph/, "Digraph declaration exists in GraphML" );
 947 }
 948
 949 # Now add a user, write to GraphML, and look at the output.
 950 unlike( $graphml, qr/testuser/, "Test user name does not exist in GraphML yet" );
 951 my $testuser = Text::Tradition::User->new(
 952         id => 'testuser', password => 'testpass' );
 953 is( ref( $testuser ), 'Text::Tradition::User', "Created test user object" );
 954 $testuser->add_tradition( $tradition );
 955 is( $tradition->user->id, $testuser->id, "Tradition assigned to test user" );
 956 $graphml = $c->as_graphml;
 957 like( $graphml, qr/testuser/, "Test user name now exists in GraphML" );
 958
 959 =end testing
 960
 961 =cut
 962
 963 ## TODO MOVE this to Tradition.pm
 964 sub as_graphml {
 965     my( $self, $options ) = @_;
 966         $self->calculate_ranks unless $self->_graphcalc_done;
 967
 968         my $start = $options->{'from'}
 969                 ? $self->reading( $options->{'from'} ) : $self->start;
 970         my $end = $options->{'to'}
 971                 ? $self->reading( $options->{'to'} ) : $self->end;
 972         if( $start->has_rank && $end->has_rank && $end->rank < $start->rank ) {
 973                 throw( 'Start node must be before end node' );
 974         }
 975         # The readings need to be ranked for this to work.
 976         $start = $self->start unless $start->has_rank;
 977         $end = $self->end unless $end->has_rank;
 978         my $rankoffset = 0;
 979         unless( $start eq $self->start ) {
 980                 $rankoffset = $start->rank - 1;
 981         }
 982         my %use_readings;
 983
 984     # Some namespaces
 985     my $graphml_ns = 'http://graphml.graphdrawing.org/xmlns';
 986     my $xsi_ns = 'http://www.w3.org/2001/XMLSchema-instance';
 987     my $graphml_schema = 'http://graphml.graphdrawing.org/xmlns ' .
 988         'http://graphml.graphdrawing.org/xmlns/1.0/graphml.xsd';
 989
 990     # Create the document and root node
 991     require XML::LibXML;
 992     my $graphml = XML::LibXML->createDocument( "1.0", "UTF-8" );
 993     my $root = $graphml->createElementNS( $graphml_ns, 'graphml' );
 994     $graphml->setDocumentElement( $root );
 995     $root->setNamespace( $xsi_ns, 'xsi', 0 );
 996     $root->setAttributeNS( $xsi_ns, 'schemaLocation', $graphml_schema );
 997
 998     # List of attribute types to save on our objects and their corresponding
 999     # GraphML types
1000     my %save_types = (
1001         'Str' => 'string',
1002         'Int' => 'int',
1003         'Bool' => 'boolean',
1004         'ReadingID' => 'string',
1005         'RelationshipType' => 'string',
1006         'RelationshipScope' => 'string',
1007     );
1008
1009     # Add the data keys for the graph. Include an extra key 'version' for the
1010     # GraphML output version.
1011     my %graph_data_keys;
1012     my $gdi = 0;
1013     my %graph_attributes = ( 'version' => 'string' );
1014         # Graph attributes include those of Tradition and those of Collation.
1015         my %gattr_from;
1016         my $tmeta = $self->tradition->meta;
1017         my $cmeta = $self->meta;
1018         map { $gattr_from{$_->name} = 'Tradition' } $tmeta->get_all_attributes;
1019         map { $gattr_from{$_->name} = 'Collation' } $cmeta->get_all_attributes;
1020         foreach my $attr ( ( $tmeta->get_all_attributes, $cmeta->get_all_attributes ) ) {
1021                 next if $attr->name =~ /^_/;
1022                 next unless $save_types{$attr->type_constraint->name};
1023                 $graph_attributes{$attr->name} = $save_types{$attr->type_constraint->name};
1024         }
1025     # Extra custom keys for complex objects that should be saved in some form.
1026     # The subroutine should return a string, or undef/empty.
1027     if( $tmeta->has_method('stemmata') ) {
1028                 $graph_attributes{'stemmata'} = sub {
1029                         my @stemstrs;
1030                         map { push( @stemstrs, $_->editable( {linesep => ''} ) ) }
1031                                 $self->tradition->stemmata;
1032                         join( "\n", @stemstrs );
1033                 };
1034         }
1035
1036     $graph_attributes{'user'} = sub {
1037         $self->tradition->user ? $self->tradition->user->id : undef
1038     };
1039
1040     foreach my $datum ( sort keys %graph_attributes ) {
1041         $graph_data_keys{$datum} = 'dg'.$gdi++;
1042         my $key = $root->addNewChild( $graphml_ns, 'key' );
1043         my $dtype = ref( $graph_attributes{$datum} ) ? 'string'
1044                 : $graph_attributes{$datum};
1045         $key->setAttribute( 'attr.name', $datum );
1046         $key->setAttribute( 'attr.type', $dtype );
1047         $key->setAttribute( 'for', 'graph' );
1048         $key->setAttribute( 'id', $graph_data_keys{$datum} );
1049     }
1050
1051     # Add the data keys for reading nodes
1052     my %reading_attributes;
1053     my $rmeta = Text::Tradition::Collation::Reading->meta;
1054     foreach my $attr( $rmeta->get_all_attributes ) {
1055                 next if $attr->name =~ /^_/;
1056                 next unless $save_types{$attr->type_constraint->name};
1057                 $reading_attributes{$attr->name} = $save_types{$attr->type_constraint->name};
1058         }
1059         # Extra custom key for the reading morphology
1060         $reading_attributes{'lexemes'} = 'string';
1061
1062     my %node_data_keys;
1063     my $ndi = 0;
1064     foreach my $datum ( sort keys %reading_attributes ) {
1065         $node_data_keys{$datum} = 'dn'.$ndi++;
1066         my $key = $root->addNewChild( $graphml_ns, 'key' );
1067         $key->setAttribute( 'attr.name', $datum );
1068         $key->setAttribute( 'attr.type', $reading_attributes{$datum} );
1069         $key->setAttribute( 'for', 'node' );
1070         $key->setAttribute( 'id', $node_data_keys{$datum} );
1071     }
1072
1073     # Add the data keys for edges, that is, paths and relationships. Path
1074     # data does not come from a Moose class so is here manually.
1075     my $edi = 0;
1076     my %edge_data_keys;
1077     my %edge_attributes = (
1078         witness => 'string',                    # ID/label for a path
1079         extra => 'boolean',                             # Path key
1080         );
1081     my @path_attributes = keys %edge_attributes; # track our manual additions
1082     my $pmeta = Text::Tradition::Collation::Relationship->meta;
1083     foreach my $attr( $pmeta->get_all_attributes ) {
1084                 next if $attr->name =~ /^_/;
1085                 next unless $save_types{$attr->type_constraint->name};
1086                 $edge_attributes{$attr->name} = $save_types{$attr->type_constraint->name};
1087         }
1088     foreach my $datum ( sort keys %edge_attributes ) {
1089         $edge_data_keys{$datum} = 'de'.$edi++;
1090         my $key = $root->addNewChild( $graphml_ns, 'key' );
1091         $key->setAttribute( 'attr.name', $datum );
1092         $key->setAttribute( 'attr.type', $edge_attributes{$datum} );
1093         $key->setAttribute( 'for', 'edge' );
1094         $key->setAttribute( 'id', $edge_data_keys{$datum} );
1095     }
1096
1097     # Add the collation graph itself. First, sanitize the name to a valid XML ID.
1098     my $xmlidname = $self->tradition->name;
1099     $xmlidname =~ s/(?!$xml10_namechar_rx)./_/g;
1100     if( $xmlidname !~ /^$xml10_namestartchar_rx/ ) {
1101         $xmlidname = '_'.$xmlidname;
1102     }
1103     my $sgraph = $root->addNewChild( $graphml_ns, 'graph' );
1104     $sgraph->setAttribute( 'edgedefault', 'directed' );
1105     $sgraph->setAttribute( 'id', $xmlidname );
1106     $sgraph->setAttribute( 'parse.edgeids', 'canonical' );
1107     $sgraph->setAttribute( 'parse.edges', 0 ); # fill in later
1108     $sgraph->setAttribute( 'parse.nodeids', 'canonical' );
1109     $sgraph->setAttribute( 'parse.nodes', 0 ); # fill in later
1110     $sgraph->setAttribute( 'parse.order', 'nodesfirst' );
1111
1112     # Tradition/collation attribute data
1113     foreach my $datum ( keys %graph_attributes ) {
1114         my $value;
1115         if( $datum eq 'version' ) {
1116                 $value = '3.2';
1117         } elsif( ref( $graph_attributes{$datum} ) ) {
1118                 my $sub = $graph_attributes{$datum};
1119                 $value = &$sub();
1120         } elsif( $gattr_from{$datum} eq 'Tradition' ) {
1121                 $value = $self->tradition->$datum;
1122         } else {
1123                 $value = $self->$datum;
1124         }
1125                 _add_graphml_data( $sgraph, $graph_data_keys{$datum}, $value );
1126         }
1127
1128     my $node_ctr = 0;
1129     my %node_hash;
1130     # Add our readings to the graph
1131     foreach my $n ( sort { $a->id cmp $b->id } $self->readings ) {
1132         next if $n->has_rank && $n ne $self->start && $n ne $self->end &&
1133                 ( $n->rank < $start->rank || $n->rank > $end->rank );
1134         $use_readings{$n->id} = 1;
1135         # Add to the main graph
1136         my $node_el = $sgraph->addNewChild( $graphml_ns, 'node' );
1137         my $node_xmlid = 'n' . $node_ctr++;
1138         $node_hash{ $n->id } = $node_xmlid;
1139         $node_el->setAttribute( 'id', $node_xmlid );
1140         foreach my $d ( keys %reading_attributes ) {
1141                 my $nval = $n->$d;
1142                 # Custom serialization
1143                 if( $d eq 'lexemes' ) {
1144                                 # If nval is a true value, we have lexemes so we need to
1145                                 # serialize them. Otherwise set nval to undef so that the
1146                                 # key is excluded from this reading.
1147                         $nval = $nval ? $n->_serialize_lexemes : undef;
1148                 } elsif( $d eq 'normal_form' && $n->normal_form eq $n->text ) {
1149                         $nval = undef;
1150                 }
1151                 if( $rankoffset && $d eq 'rank' && $n ne $self->start ) {
1152                         # Adjust the ranks within the subgraph.
1153                         $nval = $n eq $self->end ? $end->rank - $rankoffset + 1
1154                                 : $nval - $rankoffset;
1155                 }
1156                 _add_graphml_data( $node_el, $node_data_keys{$d}, $nval )
1157                         if defined $nval;
1158         }
1159     }
1160
1161     # Add the path edges to the sequence graph
1162     my $edge_ctr = 0;
1163     foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->sequence->edges() ) {
1164         # We add an edge in the graphml for every witness in $e.
1165         next unless( $use_readings{$e->[0]} || $use_readings{$e->[1]} );
1166         my @edge_wits = sort $self->path_witnesses( $e );
1167         $e->[0] = $self->start->id unless $use_readings{$e->[0]};
1168         $e->[1] = $self->end->id unless $use_readings{$e->[1]};
1169         # Skip any path from start to end; that witness is not in the subgraph.
1170         next if ( $e->[0] eq $self->start->id && $e->[1] eq $self->end->id );
1171         foreach my $wit ( @edge_wits ) {
1172                         my( $id, $from, $to ) = ( 'e'.$edge_ctr++,
1173                                                                                 $node_hash{ $e->[0] },
1174                                                                                 $node_hash{ $e->[1] } );
1175                         my $edge_el = $sgraph->addNewChild( $graphml_ns, 'edge' );
1176                         $edge_el->setAttribute( 'source', $from );
1177                         $edge_el->setAttribute( 'target', $to );
1178                         $edge_el->setAttribute( 'id', $id );
1179
1180                         # It's a witness path, so add the witness
1181                         my $base = $wit;
1182                         my $key = $edge_data_keys{'witness'};
1183                         # Is this an ante-corr witness?
1184                         my $aclabel = $self->ac_label;
1185                         if( $wit =~ /^(.*)\Q$aclabel\E$/ ) {
1186                                 # Keep the base witness
1187                                 $base = $1;
1188                                 # ...and record that this is an 'extra' reading path
1189                                 _add_graphml_data( $edge_el, $edge_data_keys{'extra'}, $aclabel );
1190                         }
1191                         _add_graphml_data( $edge_el, $edge_data_keys{'witness'}, $base );
1192                 }
1193         }
1194
1195         # Report the actual number of nodes and edges that went in
1196         $sgraph->setAttribute( 'parse.edges', $edge_ctr );
1197         $sgraph->setAttribute( 'parse.nodes', $node_ctr );
1198
1199         # Add the relationship graph to the XML
1200         map { delete $edge_data_keys{$_} } @path_attributes;
1201         $self->relations->_as_graphml( $graphml_ns, $root, \%node_hash,
1202                 $node_data_keys{'id'}, \%edge_data_keys );
1203
1204     # Save and return the thing
1205     my $result = decode_utf8( $graphml->toString(1) );
1206     return $result;
1207 }
1208
1209 sub _add_graphml_data {
1210     my( $el, $key, $value ) = @_;
1211     return unless defined $value;
1212     my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
1213     $data_el->setAttribute( 'key', $key );
1214     $data_el->appendText( $value );
1215 }
1216
1217 =head2 as_csv
1218
1219 Returns a CSV alignment table representation of the collation graph, one
1220 row per witness (or witness uncorrected.)
1221
1222 =cut
1223
1224 sub as_csv {
1225     my( $self ) = @_;
1226     my $table = $self->alignment_table;
1227     my $csv = Text::CSV->new( { binary => 1, quote_null => 0 } );
1228     my @result;
1229     # Make the header row
1230     $csv->combine( map { $_->{'witness'} } @{$table->{'alignment'}} );
1231         push( @result, decode_utf8( $csv->string ) );
1232     # Make the rest of the rows
1233     foreach my $idx ( 0 .. $table->{'length'} - 1 ) {
1234         my @rowobjs = map { $_->{'tokens'}->[$idx] } @{$table->{'alignment'}};
1235         my @row = map { $_ ? $_->{'t'}->text : $_ } @rowobjs;
1236         $csv->combine( @row );
1237         push( @result, decode_utf8( $csv->string ) );
1238     }
1239     return join( "\n", @result );
1240 }
1241
1242 =head2 alignment_table( $use_refs, $include_witnesses )
1243
1244 Return a reference to an alignment table, in a slightly enhanced CollateX
1245 format which looks like this:
1246
1247  $table = { alignment => [ { witness => "SIGIL",
1248                              tokens => [ { t => "TEXT" }, ... ] },
1249                            { witness => "SIG2",
1250                              tokens => [ { t => "TEXT" }, ... ] },
1251                            ... ],
1252             length => TEXTLEN };
1253
1254 If $use_refs is set to 1, the reading object is returned in the table
1255 instead of READINGTEXT; if not, the text of the reading is returned.
1256
1257 If $include_witnesses is set to a hashref, only the witnesses whose sigil
1258 keys have a true hash value will be included.
1259
1260 =cut
1261
1262 sub alignment_table {
1263     my( $self ) = @_;
1264     $self->calculate_ranks() unless $self->_graphcalc_done;
1265     return $self->cached_table if $self->has_cached_table;
1266
1267     # Make sure we can do this
1268         throw( "Need a linear graph in order to make an alignment table" )
1269                 unless $self->linear;
1270         $self->calculate_ranks unless $self->end->has_rank;
1271
1272     my $table = { 'alignment' => [], 'length' => $self->end->rank - 1 };
1273     my @all_pos = ( 1 .. $self->end->rank - 1 );
1274     foreach my $wit ( sort { $a->sigil cmp $b->sigil } $self->tradition->witnesses ) {
1275         # say STDERR "Making witness row(s) for " . $wit->sigil;
1276         my @wit_path = $self->reading_sequence( $self->start, $self->end, $wit->sigil );
1277         my @row = _make_witness_row( \@wit_path, \@all_pos );
1278         push( @{$table->{'alignment'}},
1279                 { 'witness' => $wit->sigil, 'tokens' => \@row } );
1280         if( $wit->is_layered ) {
1281                 my @wit_ac_path = $self->reading_sequence( $self->start, $self->end,
1282                         $wit->sigil.$self->ac_label );
1283             my @ac_row = _make_witness_row( \@wit_ac_path, \@all_pos );
1284                         push( @{$table->{'alignment'}},
1285                                 { 'witness' => $wit->sigil.$self->ac_label, 'tokens' => \@ac_row } );
1286         }
1287     }
1288     $self->cached_table( $table );
1289     return $table;
1290 }
1291
1292 sub _make_witness_row {
1293     my( $path, $positions ) = @_;
1294     my %char_hash;
1295     map { $char_hash{$_} = undef } @$positions;
1296     my $debug = 0;
1297     foreach my $rdg ( @$path ) {
1298         say STDERR "rank " . $rdg->rank if $debug;
1299         # say STDERR "No rank for " . $rdg->id unless defined $rdg->rank;
1300         $char_hash{$rdg->rank} = { 't' => $rdg };
1301     }
1302     my @row = map { $char_hash{$_} } @$positions;
1303     # Fill in lacuna markers for undef spots in the row
1304     my $last_el = shift @row;
1305     my @filled_row = ( $last_el );
1306     foreach my $el ( @row ) {
1307         # If we are using node reference, make the lacuna node appear many times
1308         # in the table.  If not, use the lacuna tag.
1309         if( $last_el && $last_el->{'t'}->is_lacuna && !defined $el ) {
1310             $el = $last_el;
1311         }
1312         push( @filled_row, $el );
1313         $last_el = $el;
1314     }
1315     return @filled_row;
1316 }
1317
1318 =head1 NAVIGATION METHODS
1319
1320 =head2 reading_sequence( $first, $last, $sigil, $backup )
1321
1322 Returns the ordered list of readings, starting with $first and ending
1323 with $last, for the witness given in $sigil. If a $backup sigil is
1324 specified (e.g. when walking a layered witness), it will be used wherever
1325 no $sigil path exists.  If there is a base text reading, that will be
1326 used wherever no path exists for $sigil or $backup.
1327
1328 =cut
1329
1330 # TODO Think about returning some lazy-eval iterator.
1331 # TODO Get rid of backup; we should know from what witness is whether we need it.
1332
1333 sub reading_sequence {
1334     my( $self, $start, $end, $witness ) = @_;
1335
1336     $witness = $self->baselabel unless $witness;
1337     my @readings = ( $start );
1338     my %seen;
1339     my $n = $start;
1340     while( $n && $n->id ne $end->id ) {
1341         if( exists( $seen{$n->id} ) ) {
1342             throw( "Detected loop for $witness at " . $n->id );
1343         }
1344         $seen{$n->id} = 1;
1345
1346         my $next = $self->next_reading( $n, $witness );
1347         unless( $next ) {
1348             throw( "Did not find any path for $witness from reading " . $n->id );
1349         }
1350         push( @readings, $next );
1351         $n = $next;
1352     }
1353     # Check that the last reading is our end reading.
1354     my $last = $readings[$#readings];
1355     throw( "Last reading found from " . $start->text .
1356         " for witness $witness is not the end!" ) # TODO do we get this far?
1357         unless $last->id eq $end->id;
1358
1359     return @readings;
1360 }
1361
1362 =head2 next_reading( $reading, $sigil );
1363
1364 Returns the reading that follows the given reading along the given witness
1365 path.
1366
1367 =cut
1368
1369 sub next_reading {
1370     # Return the successor via the corresponding path.
1371     my $self = shift;
1372     my $answer = $self->_find_linked_reading( 'next', @_ );
1373         return undef unless $answer;
1374     return $self->reading( $answer );
1375 }
1376
1377 =head2 prior_reading( $reading, $sigil )
1378
1379 Returns the reading that precedes the given reading along the given witness
1380 path.
1381
1382 =cut
1383
1384 sub prior_reading {
1385     # Return the predecessor via the corresponding path.
1386     my $self = shift;
1387     my $answer = $self->_find_linked_reading( 'prior', @_ );
1388     return $self->reading( $answer );
1389 }
1390
1391 sub _find_linked_reading {
1392     my( $self, $direction, $node, $path ) = @_;
1393
1394     # Get a backup if we are dealing with a layered witness
1395     my $alt_path;
1396     my $aclabel = $self->ac_label;
1397     if( $path && $path =~ /^(.*)\Q$aclabel\E$/ ) {
1398         $alt_path = $1;
1399     }
1400
1401     my @linked_paths = $direction eq 'next'
1402         ? $self->sequence->edges_from( $node )
1403         : $self->sequence->edges_to( $node );
1404     return undef unless scalar( @linked_paths );
1405
1406     # We have to find the linked path that contains all of the
1407     # witnesses supplied in $path.
1408     my( @path_wits, @alt_path_wits );
1409     @path_wits = sort( $self->_witnesses_of_label( $path ) ) if $path;
1410     @alt_path_wits = sort( $self->_witnesses_of_label( $alt_path ) ) if $alt_path;
1411     my $base_le;
1412     my $alt_le;
1413     foreach my $le ( @linked_paths ) {
1414         if( $self->sequence->has_edge_attribute( @$le, $self->baselabel ) ) {
1415             $base_le = $le;
1416         }
1417                 my @le_wits = sort $self->path_witnesses( $le );
1418                 if( _is_within( \@path_wits, \@le_wits ) ) {
1419                         # This is the right path.
1420                         return $direction eq 'next' ? $le->[1] : $le->[0];
1421                 } elsif( _is_within( \@alt_path_wits, \@le_wits ) ) {
1422                         $alt_le = $le;
1423                 }
1424     }
1425     # Got this far? Return the alternate path if it exists.
1426     return $direction eq 'next' ? $alt_le->[1] : $alt_le->[0]
1427         if $alt_le;
1428
1429     # Got this far? Return the base path if it exists.
1430     return $direction eq 'next' ? $base_le->[1] : $base_le->[0]
1431         if $base_le;
1432
1433     # Got this far? We have no appropriate path.
1434     warn "Could not find $direction node from " . $node->id
1435         . " along path $path";
1436     return undef;
1437 }
1438
1439 # Some set logic.
1440 sub _is_within {
1441     my( $set1, $set2 ) = @_;
1442     my $ret = @$set1; # will be 0, i.e. false, if set1 is empty
1443     foreach my $el ( @$set1 ) {
1444         $ret = 0 unless grep { /^\Q$el\E$/ } @$set2;
1445     }
1446     return $ret;
1447 }
1448
1449 # Return the string that joins together a list of witnesses for
1450 # display on a single path.
1451 sub _witnesses_of_label {
1452     my( $self, $label ) = @_;
1453     my $regex = $self->wit_list_separator;
1454     my @answer = split( /\Q$regex\E/, $label );
1455     return @answer;
1456 }
1457
1458 =head2 common_readings
1459
1460 Returns the list of common readings in the graph (i.e. those readings that are
1461 shared by all non-lacunose witnesses.)
1462
1463 =cut
1464
1465 sub common_readings {
1466         my $self = shift;
1467         my @common = grep { $_->is_common } $self->readings;
1468         return @common;
1469 }
1470
1471 =head2 path_text( $sigil, [, $start, $end ] )
1472
1473 Returns the text of a witness (plus its backup, if we are using a layer)
1474 as stored in the collation.  The text is returned as a string, where the
1475 individual readings are joined with spaces and the meta-readings (e.g.
1476 lacunae) are omitted.  Optional specification of $start and $end allows
1477 the generation of a subset of the witness text.
1478
1479 =cut
1480
1481 sub path_text {
1482         my( $self, $wit, $start, $end ) = @_;
1483         $start = $self->start unless $start;
1484         $end = $self->end unless $end;
1485         my @path = grep { !$_->is_meta } $self->reading_sequence( $start, $end, $wit );
1486         my $pathtext = '';
1487         my $last;
1488         foreach my $r ( @path ) {
1489                 unless ( $r->join_prior || !$last || $last->join_next ) {
1490                         $pathtext .= ' ';
1491                 }
1492                 $pathtext .= $r->text;
1493                 $last = $r;
1494         }
1495         return $pathtext;
1496 }
1497
1498 =head1 INITIALIZATION METHODS
1499
1500 These are mostly for use by parsers.
1501
1502 =head2 make_witness_path( $witness )
1503
1504 Link the array of readings contained in $witness->path (and in
1505 $witness->uncorrected_path if it exists) into collation paths.
1506 Clear out the arrays when finished.
1507
1508 =head2 make_witness_paths
1509
1510 Call make_witness_path for all witnesses in the tradition.
1511
1512 =cut
1513
1514 # For use when a collation is constructed from a base text and an apparatus.
1515 # We have the sequences of readings and just need to add path edges.
1516 # When we are done, clear out the witness path attributes, as they are no
1517 # longer needed.
1518 # TODO Find a way to replace the witness path attributes with encapsulated functions?
1519
1520 sub make_witness_paths {
1521     my( $self ) = @_;
1522     foreach my $wit ( $self->tradition->witnesses ) {
1523         # say STDERR "Making path for " . $wit->sigil;
1524         $self->make_witness_path( $wit );
1525     }
1526 }
1527
1528 sub make_witness_path {
1529     my( $self, $wit ) = @_;
1530     my @chain = @{$wit->path};
1531     my $sig = $wit->sigil;
1532     # Add start and end if necessary
1533     unshift( @chain, $self->start ) unless $chain[0] eq $self->start;
1534     push( @chain, $self->end ) unless $chain[-1] eq $self->end;
1535     foreach my $idx ( 0 .. $#chain-1 ) {
1536         $self->add_path( $chain[$idx], $chain[$idx+1], $sig );
1537     }
1538     if( $wit->is_layered ) {
1539         @chain = @{$wit->uncorrected_path};
1540                 unshift( @chain, $self->start ) unless $chain[0] eq $self->start;
1541                 push( @chain, $self->end ) unless $chain[-1] eq $self->end;
1542         foreach my $idx( 0 .. $#chain-1 ) {
1543             my $source = $chain[$idx];
1544             my $target = $chain[$idx+1];
1545             $self->add_path( $source, $target, $sig.$self->ac_label )
1546                 unless $self->has_path( $source, $target, $sig );
1547         }
1548     }
1549     $wit->clear_path;
1550     $wit->clear_uncorrected_path;
1551 }
1552
1553 =head2 calculate_ranks
1554
1555 Calculate the reading ranks (that is, their aligned positions relative
1556 to each other) for the graph.  This can only be called on linear collations.
1557
1558 =begin testing
1559
1560 use Text::Tradition;
1561
1562 my $cxfile = 't/data/Collatex-16.xml';
1563 my $t = Text::Tradition->new(
1564     'name'  => 'inline',
1565     'input' => 'CollateX',
1566     'file'  => $cxfile,
1567     );
1568 my $c = $t->collation;
1569
1570 # Make an svg
1571 my $table = $c->alignment_table;
1572 ok( $c->has_cached_table, "Alignment table was cached" );
1573 is( $c->alignment_table, $table, "Cached table returned upon second call" );
1574 $c->calculate_ranks;
1575 is( $c->alignment_table, $table, "Cached table retained with no rank change" );
1576 $c->add_relationship( 'n24', 'n23', { 'type' => 'spelling' } );
1577 isnt( $c->alignment_table, $table, "Alignment table changed after relationship add" );
1578
1579 =end testing
1580
1581 =cut
1582
1583 sub calculate_ranks {
1584     my $self = shift;
1585     # Save the existing ranks, in case we need to invalidate the cached SVG.
1586     my %existing_ranks;
1587     map { $existing_ranks{$_} = $_->rank } $self->readings;
1588
1589     # Do the rankings based on the relationship equivalence graph, starting
1590     # with the start node.
1591     my ( $node_ranks, $rank_nodes ) = $self->relations->equivalence_ranks();
1592
1593     # Transfer our rankings from the topological graph to the real one.
1594     foreach my $r ( $self->readings ) {
1595         if( defined $node_ranks->{$self->equivalence( $r->id )} ) {
1596             $r->rank( $node_ranks->{$self->equivalence( $r->id )} );
1597         } else {
1598                 # Die. Find the last rank we calculated.
1599                 my @all_defined = sort { ( $node_ranks->{$self->equivalence( $a->id )}||-1 )
1600                                  <=> ( $node_ranks->{$self->equivalence( $b->id )}||-1 ) }
1601                         $self->readings;
1602                 my $last = pop @all_defined;
1603             throw( "Ranks not calculated after $last - do you have a cycle in the graph?" );
1604         }
1605     }
1606     # Do we need to invalidate the cached data?
1607     if( $self->has_cached_table ) {
1608         foreach my $r ( $self->readings ) {
1609                 next if defined( $existing_ranks{$r} )
1610                         && $existing_ranks{$r} == $r->rank;
1611                 # Something has changed, so clear the cache
1612                 $self->_clear_cache;
1613                         # ...and recalculate the common readings.
1614                         $self->calculate_common_readings();
1615                 last;
1616         }
1617     }
1618         # The graph calculation information is now up to date.
1619         $self->_graphcalc_done(1);
1620 }
1621
1622 sub _clear_cache {
1623         my $self = shift;
1624         $self->wipe_table if $self->has_cached_table;
1625 }
1626
1627
1628 =head2 flatten_ranks
1629
1630 A convenience method for parsing collation data.  Searches the graph for readings
1631 with the same text at the same rank, and merges any that are found.
1632
1633 =cut
1634
1635 sub flatten_ranks {
1636     my $self = shift;
1637     my %unique_rank_rdg;
1638     my $changed;
1639     foreach my $rdg ( $self->readings ) {
1640         next unless $rdg->has_rank;
1641         my $key = $rdg->rank . "||" . $rdg->text;
1642         if( exists $unique_rank_rdg{$key} ) {
1643                 # Make sure they don't have different grammatical forms
1644                         my $ur = $unique_rank_rdg{$key};
1645                         if( $rdg->disambiguated && $ur->disambiguated ) {
1646                                 my $rform = join( '//', map { $_->form->to_string } $rdg->lexemes );
1647                                 my $uform = join( '//', map { $_->form->to_string } $ur->lexemes );
1648                                 next unless $rform eq $uform;
1649                         } elsif( $rdg->disambiguated xor $ur->disambiguated ) {
1650                                 next;
1651                         }
1652             # Combine!
1653                 #say STDERR "Combining readings at same rank: $key";
1654                 $changed = 1;
1655             $self->merge_readings( $unique_rank_rdg{$key}, $rdg );
1656             # TODO see if this now makes a common point.
1657         } else {
1658             $unique_rank_rdg{$key} = $rdg;
1659         }
1660     }
1661     # If we merged readings, the ranks are still fine but the alignment
1662     # table is wrong. Wipe it.
1663     $self->wipe_table() if $changed;
1664 }
1665
1666
1667 =head2 calculate_common_readings
1668
1669 Goes through the graph identifying the readings that appear in every witness
1670 (apart from those with lacunae at that spot.) Marks them as common and returns
1671 the list.
1672
1673 =begin testing
1674
1675 use Text::Tradition;
1676
1677 my $cxfile = 't/data/Collatex-16.xml';
1678 my $t = Text::Tradition->new(
1679     'name'  => 'inline',
1680     'input' => 'CollateX',
1681     'file'  => $cxfile,
1682     );
1683 my $c = $t->collation;
1684
1685 my @common = $c->calculate_common_readings();
1686 is( scalar @common, 8, "Found correct number of common readings" );
1687 my @marked = sort $c->common_readings();
1688 is( scalar @common, 8, "All common readings got marked as such" );
1689 my @expected = qw/ n1 n11 n16 n19 n20 n5 n6 n7 /;
1690 is_deeply( \@marked, \@expected, "Found correct list of common readings" );
1691
1692 =end testing
1693
1694 =cut
1695
1696 sub calculate_common_readings {
1697         my $self = shift;
1698         my @common;
1699         map { $_->is_common( 0 ) } $self->readings;
1700         # Implicitly calls calculate_ranks
1701         my $table = $self->alignment_table;
1702         foreach my $idx ( 0 .. $table->{'length'} - 1 ) {
1703                 my @row = map { $_->{'tokens'}->[$idx]
1704                                                         ? $_->{'tokens'}->[$idx]->{'t'} : '' }
1705                                         @{$table->{'alignment'}};
1706                 my %hash;
1707                 foreach my $r ( @row ) {
1708                         if( $r ) {
1709                                 $hash{$r->id} = $r unless $r->is_meta;
1710                         } else {
1711                                 $hash{'UNDEF'} = $r;
1712                         }
1713                 }
1714                 if( keys %hash == 1 && !exists $hash{'UNDEF'} ) {
1715                         my( $r ) = values %hash;
1716                         $r->is_common( 1 );
1717                         push( @common, $r );
1718                 }
1719         }
1720         return @common;
1721 }
1722
1723 =head2 text_from_paths
1724
1725 Calculate the text array for all witnesses from the path, for later consistency
1726 checking.  Only to be used if there is no non-graph-based way to know the
1727 original texts.
1728
1729 =cut
1730
1731 sub text_from_paths {
1732         my $self = shift;
1733     foreach my $wit ( $self->tradition->witnesses ) {
1734         my @readings = $self->reading_sequence( $self->start, $self->end, $wit->sigil );
1735         my @text;
1736         foreach my $r ( @readings ) {
1737                 next if $r->is_meta;
1738                 push( @text, $r->text );
1739         }
1740         $wit->text( \@text );
1741         if( $wit->is_layered ) {
1742                         my @ucrdgs = $self->reading_sequence( $self->start, $self->end,
1743                                                                                                   $wit->sigil.$self->ac_label );
1744                         my @uctext;
1745                         foreach my $r ( @ucrdgs ) {
1746                                 next if $r->is_meta;
1747                                 push( @uctext, $r->text );
1748                         }
1749                         $wit->layertext( \@uctext );
1750         }
1751     }
1752 }
1753
1754 =head1 UTILITY FUNCTIONS
1755
1756 =head2 common_predecessor( $reading_a, $reading_b )
1757
1758 Find the last reading that occurs in sequence before both the given readings.
1759 At the very least this should be $self->start.
1760
1761 =head2 common_successor( $reading_a, $reading_b )
1762
1763 Find the first reading that occurs in sequence after both the given readings.
1764 At the very least this should be $self->end.
1765
1766 =begin testing
1767
1768 use Text::Tradition;
1769
1770 my $cxfile = 't/data/Collatex-16.xml';
1771 my $t = Text::Tradition->new(
1772     'name'  => 'inline',
1773     'input' => 'CollateX',
1774     'file'  => $cxfile,
1775     );
1776 my $c = $t->collation;
1777
1778 is( $c->common_predecessor( 'n24', 'n23' )->id,
1779     'n20', "Found correct common predecessor" );
1780 is( $c->common_successor( 'n24', 'n23' )->id,
1781     '__END__', "Found correct common successor" );
1782
1783 is( $c->common_predecessor( 'n19', 'n17' )->id,
1784     'n16', "Found correct common predecessor for readings on same path" );
1785 is( $c->common_successor( 'n21', 'n10' )->id,
1786     '__END__', "Found correct common successor for readings on same path" );
1787
1788 =end testing
1789
1790 =cut
1791
1792 ## Return the closest reading that is a predecessor of both the given readings.
1793 sub common_predecessor {
1794         my $self = shift;
1795         my( $r1, $r2 ) = $self->_objectify_args( @_ );
1796         return $self->_common_in_path( $r1, $r2, 'predecessors' );
1797 }
1798
1799 sub common_successor {
1800         my $self = shift;
1801         my( $r1, $r2 ) = $self->_objectify_args( @_ );
1802         return $self->_common_in_path( $r1, $r2, 'successors' );
1803 }
1804
1805
1806 # TODO think about how to do this without ranks...
1807 sub _common_in_path {
1808         my( $self, $r1, $r2, $dir ) = @_;
1809         my $iter = $self->end->rank;
1810         my @candidates;
1811         my @last_r1 = ( $r1 );
1812         my @last_r2 = ( $r2 );
1813         # my %all_seen = ( $r1 => 'r1', $r2 => 'r2' );
1814         my %all_seen;
1815         # say STDERR "Finding common $dir for $r1, $r2";
1816         while( !@candidates ) {
1817                 last unless $iter--;  # Avoid looping infinitely
1818                 # Iterate separately down the graph from r1 and r2
1819                 my( @new_lc1, @new_lc2 );
1820                 foreach my $lc ( @last_r1 ) {
1821                         foreach my $p ( $lc->$dir ) {
1822                                 if( $all_seen{$p->id} && $all_seen{$p->id} ne 'r1' ) {
1823                                         # say STDERR "Path candidate $p from $lc";
1824                                         push( @candidates, $p );
1825                                 } elsif( !$all_seen{$p->id} ) {
1826                                         $all_seen{$p->id} = 'r1';
1827                                         push( @new_lc1, $p );
1828                                 }
1829                         }
1830                 }
1831                 foreach my $lc ( @last_r2 ) {
1832                         foreach my $p ( $lc->$dir ) {
1833                                 if( $all_seen{$p->id} && $all_seen{$p->id} ne 'r2' ) {
1834                                         # say STDERR "Path candidate $p from $lc";
1835                                         push( @candidates, $p );
1836                                 } elsif( !$all_seen{$p->id} ) {
1837                                         $all_seen{$p->id} = 'r2';
1838                                         push( @new_lc2, $p );
1839                                 }
1840                         }
1841                 }
1842                 @last_r1 = @new_lc1;
1843                 @last_r2 = @new_lc2;
1844         }
1845         my @answer = sort { $a->rank <=> $b->rank } @candidates;
1846         return $dir eq 'predecessors' ? pop( @answer ) : shift ( @answer );
1847 }
1848
1849 sub throw {
1850         Text::Tradition::Error->throw(
1851                 'ident' => 'Collation error',
1852                 'message' => $_[0],
1853                 );
1854 }
1855
1856 no Moose;
1857 __PACKAGE__->meta->make_immutable;
1858
1859 =head1 LICENSE
1860
1861 This package is free software and is provided "as is" without express
1862 or implied warranty.  You can redistribute it and/or modify it under
1863 the same terms as Perl itself.
1864
1865 =head1 AUTHOR
1866
1867 Tara L Andrews E<lt>aurum@cpan.orgE<gt>