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