lib/Text/Tradition/Collation.pm

   1 package Text::Tradition::Collation;
   2
   3 use Encode qw( decode_utf8 );
   4 use File::Temp;
   5 use Graph;
   6 use IPC::Run qw( run binary );
   7 use Text::CSV_XS;
   8 use Text::Tradition::Collation::Reading;
   9 use Text::Tradition::Collation::RelationshipStore;
  10 use XML::LibXML;
  11 use Moose;
  12
  13 has 'sequence' => (
  14     is => 'ro',
  15     isa => 'Graph',
  16     default => sub { Graph->new() },
  17     handles => {
  18         paths => 'edges',
  19     },
  20     );
  21
  22 has 'relations' => (
  23         is => 'ro',
  24         isa => 'Text::Tradition::Collation::RelationshipStore',
  25         handles => {
  26                 relationships => 'relationships',
  27                 related_readings => 'related_readings',
  28         },
  29         writer => '_set_relations',
  30         );
  31
  32 has 'tradition' => (
  33     is => 'ro',
  34     isa => 'Text::Tradition',
  35     weak_ref => 1,
  36     );
  37
  38 has 'readings' => (
  39         isa => 'HashRef[Text::Tradition::Collation::Reading]',
  40         traits => ['Hash'],
  41     handles => {
  42         reading     => 'get',
  43         _add_reading => 'set',
  44         del_reading => 'delete',
  45         has_reading => 'exists',
  46         readings   => 'values',
  47     },
  48     default => sub { {} },
  49         );
  50
  51 has 'wit_list_separator' => (
  52     is => 'rw',
  53     isa => 'Str',
  54     default => ', ',
  55     );
  56
  57 has 'baselabel' => (
  58     is => 'rw',
  59     isa => 'Str',
  60     default => 'base text',
  61     );
  62
  63 has 'linear' => (
  64     is => 'rw',
  65     isa => 'Bool',
  66     default => 1,
  67     );
  68
  69 has 'collapse_punctuation' => (
  70         is => 'rw',
  71         isa => 'Bool',
  72         default => 1,
  73         );
  74
  75 has 'ac_label' => (
  76     is => 'rw',
  77     isa => 'Str',
  78     default => ' (a.c.)',
  79     );
  80
  81 has 'start' => (
  82         is => 'ro',
  83         isa => 'Text::Tradition::Collation::Reading',
  84         writer => '_set_start',
  85         weak_ref => 1,
  86         );
  87
  88 has 'end' => (
  89         is => 'ro',
  90         isa => 'Text::Tradition::Collation::Reading',
  91         writer => '_set_end',
  92         weak_ref => 1,
  93         );
  94
  95 =head1 NAME
  96
  97 Text::Tradition::Collation - a software model for a text collation
  98
  99 =head1 SYNOPSIS
 100
 101   use Text::Tradition;
 102   my $t = Text::Tradition->new(
 103     'name' => 'this is a text',
 104     'input' => 'TEI',
 105     'file' => '/path/to/tei_parallel_seg_file.xml' );
 106
 107   my $c = $t->collation;
 108   my @readings = $c->readings;
 109   my @paths = $c->paths;
 110   my @relationships = $c->relationships;
 111
 112   my $svg_variant_graph = $t->collation->as_svg();
 113
 114 =head1 DESCRIPTION
 115
 116 Text::Tradition is a library for representation and analysis of collated
 117 texts, particularly medieval ones.  The Collation is the central feature of
 118 a Tradition, where the text, its sequence of readings, and its relationships
 119 between readings are actually kept.
 120
 121 =head1 CONSTRUCTOR
 122
 123 =head2 new
 124
 125 The constructor.  Takes a hash or hashref of the following arguments:
 126
 127 =over
 128
 129 =item * tradition - The Text::Tradition object to which the collation
 130 belongs. Required.
 131
 132 =item * linear - Whether the collation should be linear; that is, whether
 133 transposed readings should be treated as two linked readings rather than one,
 134 and therefore whether the collation graph is acyclic.  Defaults to true.
 135
 136 =item * collapse_punctuation - TODO
 137
 138 =item * baselabel - The default label for the path taken by a base text
 139 (if any). Defaults to 'base text'.
 140
 141 =item * wit_list_separator - The string to join a list of witnesses for
 142 purposes of making labels in display graphs.  Defaults to ', '.
 143
 144 =item * ac_label - The extra label to tack onto a witness sigil when
 145 representing another layer of path for the given witness - that is, when
 146 a text has more than one possible reading due to scribal corrections or
 147 the like.  Defaults to ' (a.c.)'.
 148
 149 =back
 150
 151 =head1 ACCESSORS
 152
 153 =head2 tradition
 154
 155 =head2 linear
 156
 157 =head2 collapse_punctuation
 158
 159 =head2 wit_list_separator
 160
 161 =head2 baselabel
 162
 163 =head2 ac_label
 164
 165 Simple accessors for collation attributes.
 166
 167 =head2 start
 168
 169 The meta-reading at the start of every witness path.
 170
 171 =head2 end
 172
 173 The meta-reading at the end of every witness path.
 174
 175 =head2 readings
 176
 177 Returns all Reading objects in the graph.
 178
 179 =head2 reading( $id )
 180
 181 Returns the Reading object corresponding to the given ID.
 182
 183 =head2 add_reading( $reading_args )
 184
 185 Adds a new reading object to the collation.
 186 See L<Text::Tradition::Collation::Reading> for the available arguments.
 187
 188 =head2 del_reading( $object_or_id )
 189
 190 Removes the given reading from the collation, implicitly removing its
 191 paths and relationships.
 192
 193 =head2 merge_readings( $main, $second )
 194
 195 Merges the $second reading into the $main one.
 196 The arguments may be either readings or reading IDs.
 197
 198 =head2 has_reading( $id )
 199
 200 Predicate to see whether a given reading ID is in the graph.
 201
 202 =head2 reading_witnesses( $object_or_id )
 203
 204 Returns a list of sigils whose witnesses contain the reading.
 205
 206 =head2 paths
 207
 208 Returns all reading paths within the document - that is, all edges in the
 209 collation graph.  Each path is an arrayref of [ $source, $target ] reading IDs.
 210
 211 =head2 add_path( $source, $target, $sigil )
 212
 213 Links the given readings in the collation in sequence, under the given witness
 214 sigil.  The readings may be specified by object or ID.
 215
 216 =head2 del_path( $source, $target, $sigil )
 217
 218 Links the given readings in the collation in sequence, under the given witness
 219 sigil.  The readings may be specified by object or ID.
 220
 221 =head2 has_path( $source, $target );
 222
 223 Returns true if the two readings are linked in sequence in any witness.
 224 The readings may be specified by object or ID.
 225
 226 =head2 relationships
 227
 228 Returns all Relationship objects in the collation.
 229
 230 =head2 add_relationship( $reading, $other_reading, $options )
 231
 232 Adds a new relationship of the type given in $options between the two readings,
 233 which may be specified by object or ID.  Returns a value of ( $status, @vectors)
 234 where $status is true on success, and @vectors is a list of relationship edges
 235 that were ultimately added.
 236 See L<Text::Tradition::Collation::Relationship> for the available options.
 237
 238 =cut
 239
 240 sub BUILD {
 241     my $self = shift;
 242     $self->_set_relations( Text::Tradition::Collation::RelationshipStore->new( 'collation' => $self ) );
 243     $self->_set_start( $self->add_reading( { 'collation' => $self, 'is_start' => 1 } ) );
 244     $self->_set_end( $self->add_reading( { 'collation' => $self, 'is_end' => 1 } ) );
 245 }
 246
 247 ### Reading construct/destruct functions
 248
 249 sub add_reading {
 250         my( $self, $reading ) = @_;
 251         unless( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
 252                 my %args = %$reading;
 253                 $reading = Text::Tradition::Collation::Reading->new(
 254                         'collation' => $self,
 255                         %args );
 256         }
 257         # First check to see if a reading with this ID exists.
 258         if( $self->reading( $reading->id ) ) {
 259                 warn "Collation already has a reading with id " . $reading->id;
 260                 return undef;
 261         }
 262         $self->_add_reading( $reading->id => $reading );
 263         # Once the reading has been added, put it in both graphs.
 264         $self->sequence->add_vertex( $reading->id );
 265         $self->relations->add_reading( $reading->id );
 266         return $reading;
 267 };
 268
 269 around del_reading => sub {
 270         my $orig = shift;
 271         my $self = shift;
 272         my $arg = shift;
 273
 274         if( ref( $arg ) eq 'Text::Tradition::Collation::Reading' ) {
 275                 $arg = $arg->id;
 276         }
 277         # Remove the reading from the graphs.
 278         $self->sequence->delete_vertex( $arg );
 279         $self->relations->delete_reading( $arg );
 280
 281         # Carry on.
 282         $self->$orig( $arg );
 283 };
 284
 285 # merge_readings( $main, $to_be_deleted );
 286
 287 sub merge_readings {
 288         my $self = shift;
 289
 290         # We only need the IDs for adding paths to the graph, not the reading
 291         # objects themselves.
 292     my( $kept, $deleted, $combine_char ) = $self->_stringify_args( @_ );
 293
 294     # The kept reading should inherit the paths and the relationships
 295     # of the deleted reading.
 296         foreach my $path ( $self->sequence->edges_at( $deleted ) ) {
 297                 my @vector = ( $kept );
 298                 push( @vector, $path->[1] ) if $path->[0] eq $deleted;
 299                 unshift( @vector, $path->[0] ) if $path->[1] eq $deleted;
 300                 next if $vector[0] eq $vector[1]; # Don't add a self loop
 301                 my %wits = %{$self->sequence->get_edge_attributes( @$path )};
 302                 $self->sequence->add_edge( @vector );
 303                 my $fwits = $self->sequence->get_edge_attributes( @vector );
 304                 @wits{keys %$fwits} = values %$fwits;
 305                 $self->sequence->set_edge_attributes( @vector, \%wits );
 306         }
 307         $self->relations->merge_readings( $kept, $deleted, $combine_char );
 308
 309         # Do the deletion deed.
 310         if( $combine_char ) {
 311                 my $kept_obj = $self->reading( $kept );
 312                 my $new_text = join( $combine_char, $kept_obj->text,
 313                         $self->reading( $deleted )->text );
 314                 $kept_obj->alter_text( $new_text );
 315         }
 316         $self->del_reading( $deleted );
 317 }
 318
 319
 320 # Helper function for manipulating the graph.
 321 sub _stringify_args {
 322         my( $self, $first, $second, $arg ) = @_;
 323     $first = $first->id
 324         if ref( $first ) eq 'Text::Tradition::Collation::Reading';
 325     $second = $second->id
 326         if ref( $second ) eq 'Text::Tradition::Collation::Reading';
 327     return( $first, $second, $arg );
 328 }
 329
 330 # Helper function for manipulating the graph.
 331 sub _objectify_args {
 332         my( $self, $first, $second, $arg ) = @_;
 333     $first = $self->reading( $first )
 334         unless ref( $first ) eq 'Text::Tradition::Collation::Reading';
 335     $second = $self->reading( $second )
 336         unless ref( $second ) eq 'Text::Tradition::Collation::Reading';
 337     return( $first, $second, $arg );
 338 }
 339 ### Path logic
 340
 341 sub add_path {
 342         my $self = shift;
 343
 344         # We only need the IDs for adding paths to the graph, not the reading
 345         # objects themselves.
 346     my( $source, $target, $wit ) = $self->_stringify_args( @_ );
 347
 348         # Connect the readings
 349     $self->sequence->add_edge( $source, $target );
 350     # Note the witness in question
 351     $self->sequence->set_edge_attribute( $source, $target, $wit, 1 );
 352 };
 353
 354 sub del_path {
 355         my $self = shift;
 356         my @args;
 357         if( ref( $_[0] ) eq 'ARRAY' ) {
 358                 my $e = shift @_;
 359                 @args = ( @$e, @_ );
 360         } else {
 361                 @args = @_;
 362         }
 363
 364         # We only need the IDs for adding paths to the graph, not the reading
 365         # objects themselves.
 366     my( $source, $target, $wit ) = $self->_stringify_args( @args );
 367
 368         if( $self->sequence->has_edge_attribute( $source, $target, $wit ) ) {
 369                 $self->sequence->delete_edge_attribute( $source, $target, $wit );
 370         }
 371         unless( keys %{$self->sequence->get_edge_attributes( $source, $target )} ) {
 372                 $self->sequence->delete_edge( $source, $target );
 373         }
 374 }
 375
 376
 377 # Extra graph-alike utility
 378 sub has_path {
 379         my $self = shift;
 380     my( $source, $target, $wit ) = $self->_stringify_args( @_ );
 381         return undef unless $self->sequence->has_edge( $source, $target );
 382         return $self->sequence->has_edge_attribute( $source, $target, $wit );
 383 }
 384
 385 =head2 clear_witness( @sigil_list )
 386
 387 Clear the given witnesses out of the collation entirely, removing references
 388 to them in paths, and removing readings that belong only to them.  Should only
 389 be called via $tradition->del_witness.
 390
 391 =cut
 392
 393 sub clear_witness {
 394         my( $self, @sigils ) = @_;
 395
 396         # Clear the witness(es) out of the paths
 397         foreach my $e ( $self->paths ) {
 398                 foreach my $sig ( @sigils ) {
 399                         $self->del_path( $e, $sig );
 400                 }
 401         }
 402
 403         # Clear out the newly unused readings
 404         foreach my $r ( $self->readings ) {
 405                 unless( $self->reading_witnesses( $r ) ) {
 406                         $self->del_reading( $r );
 407                 }
 408         }
 409 }
 410
 411 sub add_relationship {
 412         my $self = shift;
 413     my( $source, $target, $opts ) = $self->_stringify_args( @_ );
 414     my( $ret, @vectors ) = $self->relations->add_relationship( $source,
 415         $self->reading( $source ), $target, $self->reading( $target ), $opts );
 416     # Force a full rank recalculation every time. Yuck.
 417     $self->calculate_ranks() if $ret && $self->end->has_rank;
 418     return( $ret, @vectors );
 419 }
 420
 421 =head2 reading_witnesses( $reading )
 422
 423 Return a list of sigils corresponding to the witnesses in which the reading appears.
 424
 425 =cut
 426
 427 sub reading_witnesses {
 428         my( $self, $reading ) = @_;
 429         # We need only check either the incoming or the outgoing edges; I have
 430         # arbitrarily chosen "incoming".  Thus, special-case the start node.
 431         if( $reading eq $self->start ) {
 432                 return map { $_->sigil } $self->tradition->witnesses;
 433         }
 434         my %all_witnesses;
 435         foreach my $e ( $self->sequence->edges_to( $reading ) ) {
 436                 my $wits = $self->sequence->get_edge_attributes( @$e );
 437                 @all_witnesses{ keys %$wits } = 1;
 438         }
 439         return keys %all_witnesses;
 440 }
 441
 442 =head1 OUTPUT METHODS
 443
 444 =head2 as_svg
 445
 446 Returns an SVG string that represents the graph, via as_dot and graphviz.
 447
 448 =cut
 449
 450 sub as_svg {
 451     my( $self ) = @_;
 452
 453     my @cmd = qw/dot -Tsvg/;
 454     my( $svg, $err );
 455     my $dotfile = File::Temp->new();
 456     ## TODO REMOVE
 457     # $dotfile->unlink_on_destroy(0);
 458     binmode $dotfile, ':utf8';
 459     print $dotfile $self->as_dot();
 460     push( @cmd, $dotfile->filename );
 461     run( \@cmd, ">", binary(), \$svg );
 462     $svg = decode_utf8( $svg );
 463     return $svg;
 464 }
 465
 466 =head2 svg_subgraph( $from, $to )
 467
 468 Returns an SVG string that represents the portion of the graph given by the
 469 specified range.  The $from and $to variables refer to ranks within the graph.
 470
 471 =cut
 472
 473 sub svg_subgraph {
 474     my( $self, $from, $to ) = @_;
 475
 476     my $dot = $self->as_dot( $from, $to );
 477     unless( $dot ) {
 478         warn "Could not output a graph with range $from - $to";
 479         return;
 480     }
 481
 482     my @cmd = qw/dot -Tsvg/;
 483     my( $svg, $err );
 484     my $dotfile = File::Temp->new();
 485     ## TODO REMOVE
 486     # $dotfile->unlink_on_destroy(0);
 487     binmode $dotfile, ':utf8';
 488     print $dotfile $dot;
 489     push( @cmd, $dotfile->filename );
 490     run( \@cmd, ">", binary(), \$svg );
 491     $svg = decode_utf8( $svg );
 492     return $svg;
 493 }
 494
 495
 496 =head2 as_dot( $from, $to )
 497
 498 Returns a string that is the collation graph expressed in dot
 499 (i.e. GraphViz) format.  If $from or $to is passed, as_dot creates
 500 a subgraph rather than the entire graph.
 501
 502 =cut
 503
 504 sub as_dot {
 505     my( $self, $startrank, $endrank ) = @_;
 506
 507     # Check the arguments
 508     if( $startrank ) {
 509         return if $endrank && $startrank > $endrank;
 510         return if $startrank > $self->end->rank;
 511         }
 512         if( defined $endrank ) {
 513                 return if $endrank < 0;
 514                 $endrank = undef if $endrank == $self->end->rank;
 515         }
 516
 517     # TODO consider making some of these things configurable
 518     my $graph_name = $self->tradition->name;
 519     $graph_name =~ s/[^\w\s]//g;
 520     $graph_name = join( '_', split( /\s+/, $graph_name ) );
 521     my $dot = sprintf( "digraph %s {\n", $graph_name );
 522     $dot .= "\tedge [ arrowhead=open ];\n";
 523     $dot .= "\tgraph [ rankdir=LR,bgcolor=none ];\n";
 524     $dot .= sprintf( "\tnode [ fontsize=%d, fillcolor=%s, style=%s, shape=%s ];\n",
 525                      11, "white", "filled", "ellipse" );
 526
 527         # Output substitute start/end readings if necessary
 528         if( $startrank ) {
 529                 $dot .= "\t\"#SUBSTART#\" [ label=\"...\" ];\n";
 530         }
 531         if( $endrank ) {
 532                 $dot .= "\t\"#SUBEND#\" [ label=\"...\" ];\n";
 533         }
 534         my %used;  # Keep track of the readings that actually appear in the graph
 535         my %subedges;
 536         my %subend;
 537     foreach my $reading ( $self->readings ) {
 538         # Only output readings within our rank range.
 539         next if $startrank && $reading->rank < $startrank;
 540         next if $endrank && $reading->rank > $endrank;
 541         $used{$reading->id} = 1;
 542         $subedges{$reading->id} = '#SUBSTART#'
 543                 if $startrank && $startrank == $reading->rank;
 544         $subedges{$reading->id} = '#SUBEND#'
 545                 if $endrank && $endrank == $reading->rank;
 546         # Need not output nodes without separate labels
 547         next if $reading->id eq $reading->text;
 548         my $label = $reading->punctuated_form;
 549         $label =~ s/\"/\\\"/g;
 550         $dot .= sprintf( "\t\"%s\" [ label=\"%s\" ];\n", $reading->id, $label );
 551     }
 552
 553     # Add substitute start and end edges if necessary
 554     foreach my $node ( keys %subedges ) {
 555                 my @vector = ( $subedges{$node}, $node );
 556                 @vector = reverse( @vector ) if $vector[0] =~ /END/;
 557         my $witstr = join( ', ', sort $self->reading_witnesses( $self->reading( $node ) ) );
 558         my %variables = ( 'color' => '#000000',
 559                           'fontcolor' => '#000000',
 560                           'label' => $witstr,
 561             );
 562         my $varopts = join( ', ', map { $_.'="'.$variables{$_}.'"' } sort keys %variables );
 563                 $dot .= sprintf( "\t\"%s\" -> \"%s\" [ %s ];\n", @vector, $varopts );
 564         }
 565
 566         # Add the real edges
 567     my @edges = $self->paths;
 568     foreach my $edge ( @edges ) {
 569         # Do we need to output this edge?
 570         if( $used{$edge->[0]} && $used{$edge->[1]} ) {;
 571                         my %variables = ( 'color' => '#000000',
 572                                                           'fontcolor' => '#000000',
 573                                                           'label' => join( ', ', $self->path_display_label( $edge ) ),
 574                                 );
 575                         my $varopts = join( ', ', map { $_.'="'.$variables{$_}.'"' } sort keys %variables );
 576                         # Account for the rank gap if necessary
 577                         my $rankgap = $self->reading( $edge->[1] )->rank
 578                                 - $self->reading( $edge->[0] )->rank;
 579                         $varopts .= ", minlen=$rankgap" if $rankgap > 1;
 580                         $dot .= sprintf( "\t\"%s\" -> \"%s\" [ %s ];\n",
 581                                                          $edge->[0], $edge->[1], $varopts );
 582         }
 583     }
 584
 585     $dot .= "}\n";
 586     return $dot;
 587 }
 588
 589 sub path_witnesses {
 590         my( $self, @edge ) = @_;
 591         # If edge is an arrayref, cope.
 592         if( @edge == 1 && ref( $edge[0] ) eq 'ARRAY' ) {
 593                 my $e = shift @edge;
 594                 @edge = @$e;
 595         }
 596         my @wits = keys %{$self->sequence->get_edge_attributes( @edge )};
 597         return sort @wits;
 598 }
 599
 600 sub path_display_label {
 601         my( $self, $edge ) = @_;
 602         my @wits = $self->path_witnesses( $edge );
 603         my $maj = scalar( $self->tradition->witnesses ) * 0.6;
 604         if( scalar @wits > $maj ) {
 605                 return 'majority';
 606         } else {
 607                 return join( ', ', @wits );
 608         }
 609 }
 610
 611
 612 =head2 as_graphml
 613
 614 Returns a GraphML representation of the collation.  The GraphML will contain
 615 two graphs. The first expresses the attributes of the readings and the witness
 616 paths that link them; the second expresses the relationships that link the
 617 readings.  This is the native transfer format for a tradition.
 618
 619 =begin testing
 620
 621 use Text::Tradition;
 622
 623 my $READINGS = 311;
 624 my $PATHS = 361;
 625
 626 my $datafile = 't/data/florilegium_tei_ps.xml';
 627 my $tradition = Text::Tradition->new( 'input' => 'TEI',
 628                                       'name' => 'test0',
 629                                       'file' => $datafile,
 630                                       'linear' => 1 );
 631
 632 ok( $tradition, "Got a tradition object" );
 633 is( scalar $tradition->witnesses, 13, "Found all witnesses" );
 634 ok( $tradition->collation, "Tradition has a collation" );
 635
 636 my $c = $tradition->collation;
 637 is( scalar $c->readings, $READINGS, "Collation has all readings" );
 638 is( scalar $c->paths, $PATHS, "Collation has all paths" );
 639 is( scalar $c->relationships, 0, "Collation has all relationships" );
 640
 641 # Add a few relationships
 642 $c->add_relationship( 'w123', 'w125', { 'type' => 'collated' } );
 643 $c->add_relationship( 'w193', 'w196', { 'type' => 'collated' } );
 644 $c->add_relationship( 'w257', 'w262', { 'type' => 'transposition' } );
 645
 646 # Now write it to GraphML and parse it again.
 647
 648 my $graphml = $c->as_graphml;
 649 my $st = Text::Tradition->new( 'input' => 'Self', 'string' => $graphml );
 650 is( scalar $st->collation->readings, $READINGS, "Reparsed collation has all readings" );
 651 is( scalar $st->collation->paths, $PATHS, "Reparsed collation has all paths" );
 652 is( scalar $st->collation->relationships, 3, "Reparsed collation has new relationships" );
 653
 654 =end testing
 655
 656 =cut
 657
 658 sub as_graphml {
 659     my( $self ) = @_;
 660
 661     # Some namespaces
 662     my $graphml_ns = 'http://graphml.graphdrawing.org/xmlns';
 663     my $xsi_ns = 'http://www.w3.org/2001/XMLSchema-instance';
 664     my $graphml_schema = 'http://graphml.graphdrawing.org/xmlns ' .
 665         'http://graphml.graphdrawing.org/xmlns/1.0/graphml.xsd';
 666
 667     # Create the document and root node
 668     my $graphml = XML::LibXML->createDocument( "1.0", "UTF-8" );
 669     my $root = $graphml->createElementNS( $graphml_ns, 'graphml' );
 670     $graphml->setDocumentElement( $root );
 671     $root->setNamespace( $xsi_ns, 'xsi', 0 );
 672     $root->setAttributeNS( $xsi_ns, 'schemaLocation', $graphml_schema );
 673
 674     # Add the data keys for the graph
 675     my %graph_data_keys;
 676     my $gdi = 0;
 677     my @graph_attributes = qw/ version wit_list_separator baselabel linear ac_label /;
 678     foreach my $datum ( @graph_attributes ) {
 679         $graph_data_keys{$datum} = 'dg'.$gdi++;
 680         my $key = $root->addNewChild( $graphml_ns, 'key' );
 681         $key->setAttribute( 'attr.name', $datum );
 682         $key->setAttribute( 'attr.type', $key eq 'linear' ? 'boolean' : 'string' );
 683         $key->setAttribute( 'for', 'graph' );
 684         $key->setAttribute( 'id', $graph_data_keys{$datum} );
 685     }
 686
 687     # Add the data keys for nodes
 688     my %node_data_keys;
 689     my $ndi = 0;
 690     my %node_data = (
 691         id => 'string',
 692         text => 'string',
 693         rank => 'string',
 694         is_start => 'boolean',
 695         is_end => 'boolean',
 696         is_lacuna => 'boolean',
 697         );
 698     foreach my $datum ( keys %node_data ) {
 699         $node_data_keys{$datum} = 'dn'.$ndi++;
 700         my $key = $root->addNewChild( $graphml_ns, 'key' );
 701         $key->setAttribute( 'attr.name', $datum );
 702         $key->setAttribute( 'attr.type', $node_data{$datum} );
 703         $key->setAttribute( 'for', 'node' );
 704         $key->setAttribute( 'id', $node_data_keys{$datum} );
 705     }
 706
 707     # Add the data keys for edges, i.e. witnesses
 708     my $edi = 0;
 709     my %edge_data_keys;
 710     my %edge_data = (
 711         class => 'string',                              # Class, deprecated soon
 712         witness => 'string',                    # ID/label for a path
 713         relationship => 'string',               # ID/label for a relationship
 714         extra => 'boolean',                             # Path key
 715         scope => 'string',                              # Relationship key
 716         non_correctable => 'boolean',   # Relationship key
 717         non_independent => 'boolean',   # Relationship key
 718         );
 719     foreach my $datum ( keys %edge_data ) {
 720         $edge_data_keys{$datum} = 'de'.$edi++;
 721         my $key = $root->addNewChild( $graphml_ns, 'key' );
 722         $key->setAttribute( 'attr.name', $datum );
 723         $key->setAttribute( 'attr.type', $edge_data{$datum} );
 724         $key->setAttribute( 'for', 'edge' );
 725         $key->setAttribute( 'id', $edge_data_keys{$datum} );
 726     }
 727
 728     # Add the collation graph itself
 729     my $sgraph = $root->addNewChild( $graphml_ns, 'graph' );
 730     $sgraph->setAttribute( 'edgedefault', 'directed' );
 731     $sgraph->setAttribute( 'id', $self->tradition->name );
 732     $sgraph->setAttribute( 'parse.edgeids', 'canonical' );
 733     $sgraph->setAttribute( 'parse.edges', scalar($self->paths) );
 734     $sgraph->setAttribute( 'parse.nodeids', 'canonical' );
 735     $sgraph->setAttribute( 'parse.nodes', scalar($self->readings) );
 736     $sgraph->setAttribute( 'parse.order', 'nodesfirst' );
 737
 738     # Collation attribute data
 739     foreach my $datum ( @graph_attributes ) {
 740         my $value = $datum eq 'version' ? '3.0' : $self->$datum;
 741                 _add_graphml_data( $sgraph, $graph_data_keys{$datum}, $value );
 742         }
 743
 744     my $node_ctr = 0;
 745     my %node_hash;
 746     # Add our readings to the graph
 747     foreach my $n ( sort { $a->id cmp $b->id } $self->readings ) {
 748         # Add to the main graph
 749         my $node_el = $sgraph->addNewChild( $graphml_ns, 'node' );
 750         my $node_xmlid = 'n' . $node_ctr++;
 751         $node_hash{ $n->id } = $node_xmlid;
 752         $node_el->setAttribute( 'id', $node_xmlid );
 753         foreach my $d ( keys %node_data ) {
 754                 my $nval = $n->$d;
 755                 $nval = $n->punctuated_form if $d eq 'text';
 756                 _add_graphml_data( $node_el, $node_data_keys{$d}, $nval )
 757                         if defined $nval;
 758         }
 759     }
 760
 761     # Add the path edges to the sequence graph
 762     my $edge_ctr = 0;
 763     foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->sequence->edges() ) {
 764         # We add an edge in the graphml for every witness in $e.
 765         foreach my $wit ( $self->path_witnesses( $e ) ) {
 766                         my( $id, $from, $to ) = ( 'e'.$edge_ctr++,
 767                                                                                 $node_hash{ $e->[0] },
 768                                                                                 $node_hash{ $e->[1] } );
 769                         my $edge_el = $sgraph->addNewChild( $graphml_ns, 'edge' );
 770                         $edge_el->setAttribute( 'source', $from );
 771                         $edge_el->setAttribute( 'target', $to );
 772                         $edge_el->setAttribute( 'id', $id );
 773
 774                         # It's a witness path, so add the witness
 775                         my $base = $wit;
 776                         my $key = $edge_data_keys{'witness'};
 777                         # Is this an ante-corr witness?
 778                         my $aclabel = $self->ac_label;
 779                         if( $wit =~ /^(.*)\Q$aclabel\E$/ ) {
 780                                 # Keep the base witness
 781                                 $base = $1;
 782                                 # ...and record that this is an 'extra' reading path
 783                                 _add_graphml_data( $edge_el, $edge_data_keys{'extra'}, $aclabel );
 784                         }
 785                         _add_graphml_data( $edge_el, $edge_data_keys{'witness'}, $base );
 786                         _add_graphml_data( $edge_el, $edge_data_keys{'class'}, 'path' );
 787                 }
 788         }
 789
 790         # Add the relationship graph to the XML
 791         $self->relations->as_graphml( $graphml_ns, $root, \%node_hash,
 792                 $node_data_keys{'id'}, \%edge_data_keys );
 793
 794     # Save and return the thing
 795     my $result = decode_utf8( $graphml->toString(1) );
 796     return $result;
 797 }
 798
 799 sub _add_graphml_data {
 800     my( $el, $key, $value ) = @_;
 801     return unless defined $value;
 802     my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
 803     $data_el->setAttribute( 'key', $key );
 804     $data_el->appendText( $value );
 805 }
 806
 807 =head2 as_csv
 808
 809 Returns a CSV alignment table representation of the collation graph, one
 810 row per witness (or witness uncorrected.)
 811
 812 =cut
 813
 814 sub as_csv {
 815     my( $self ) = @_;
 816     my $table = $self->make_alignment_table;
 817     my $csv = Text::CSV_XS->new( { binary => 1, quote_null => 0 } );
 818     my @result;
 819     # Make the header row
 820     $csv->combine( map { $_->{'witness'} } @{$table->{'alignment'}} );
 821         push( @result, decode_utf8( $csv->string ) );
 822     # Make the rest of the rows
 823     foreach my $idx ( 0 .. $table->{'length'} - 1 ) {
 824         my @rowobjs = map { $_->{'tokens'}->[$idx] } @{$table->{'alignment'}};
 825         my @row = map { $_ ? $_->{'t'} : $_ } @rowobjs;
 826         $csv->combine( @row );
 827         push( @result, decode_utf8( $csv->string ) );
 828     }
 829     return join( "\n", @result );
 830 }
 831
 832 =head2 make_alignment_table( $use_refs, $include_witnesses )
 833
 834 Return a reference to an alignment table, in a slightly enhanced CollateX
 835 format which looks like this:
 836
 837  $table = { alignment => [ { witness => "SIGIL",
 838                              tokens => [ { t => "TEXT" }, ... ] },
 839                            { witness => "SIG2",
 840                              tokens => [ { t => "TEXT" }, ... ] },
 841                            ... ],
 842             length => TEXTLEN };
 843
 844 If $use_refs is set to 1, the reading object is returned in the table
 845 instead of READINGTEXT; if not, the text of the reading is returned.
 846
 847 If $include_witnesses is set to a hashref, only the witnesses whose sigil
 848 keys have a true hash value will be included.
 849
 850 =cut
 851
 852 sub make_alignment_table {
 853     my( $self, $noderefs, $include ) = @_;
 854     unless( $self->linear ) {
 855         warn "Need a linear graph in order to make an alignment table";
 856         return;
 857     }
 858     my $table = { 'alignment' => [], 'length' => $self->end->rank - 1 };
 859     my @all_pos = ( 1 .. $self->end->rank - 1 );
 860     foreach my $wit ( sort { $a->sigil cmp $b->sigil } $self->tradition->witnesses ) {
 861         if( $include ) {
 862                 next unless $include->{$wit->sigil};
 863         }
 864         # print STDERR "Making witness row(s) for " . $wit->sigil . "\n";
 865         my @wit_path = $self->reading_sequence( $self->start, $self->end, $wit->sigil );
 866         my @row = _make_witness_row( \@wit_path, \@all_pos, $noderefs );
 867         push( @{$table->{'alignment'}},
 868                 { 'witness' => $wit->sigil, 'tokens' => \@row } );
 869         if( $wit->is_layered ) {
 870                 my @wit_ac_path = $self->reading_sequence( $self->start, $self->end,
 871                         $wit->sigil.$self->ac_label, $wit->sigil );
 872             my @ac_row = _make_witness_row( \@wit_ac_path, \@all_pos, $noderefs );
 873                         push( @{$table->{'alignment'}},
 874                                 { 'witness' => $wit->sigil.$self->ac_label, 'tokens' => \@ac_row } );
 875         }
 876     }
 877         return $table;
 878 }
 879
 880 sub _make_witness_row {
 881     my( $path, $positions, $noderefs ) = @_;
 882     my %char_hash;
 883     map { $char_hash{$_} = undef } @$positions;
 884     my $debug = 0;
 885     foreach my $rdg ( @$path ) {
 886         my $rtext = $rdg->text;
 887         $rtext = '#LACUNA#' if $rdg->is_lacuna;
 888         print STDERR "rank " . $rdg->rank . "\n" if $debug;
 889         # print STDERR "No rank for " . $rdg->id . "\n" unless defined $rdg->rank;
 890         $char_hash{$rdg->rank} = $noderefs ? { 't' => $rdg }
 891                                                                            : { 't' => $rtext };
 892     }
 893     my @row = map { $char_hash{$_} } @$positions;
 894     # Fill in lacuna markers for undef spots in the row
 895     my $last_el = shift @row;
 896     my @filled_row = ( $last_el );
 897     foreach my $el ( @row ) {
 898         # If we are using node reference, make the lacuna node appear many times
 899         # in the table.  If not, use the lacuna tag.
 900         if( $last_el && _el_is_lacuna( $last_el ) && !defined $el ) {
 901             $el = $noderefs ? $last_el : { 't' => '#LACUNA#' };
 902         }
 903         push( @filled_row, $el );
 904         $last_el = $el;
 905     }
 906     return @filled_row;
 907 }
 908
 909 # Tiny utility function to say if a table element is a lacuna
 910 sub _el_is_lacuna {
 911     my $el = shift;
 912     return 1 if $el->{'t'} eq '#LACUNA#';
 913     return 1 if ref( $el->{'t'} ) eq 'Text::Tradition::Collation::Reading'
 914         && $el->{'t'}->is_lacuna;
 915     return 0;
 916 }
 917
 918 # Helper to turn the witnesses along columns rather than rows.  Assumes
 919 # equal-sized rows.
 920 sub _turn_table {
 921     my( $table ) = @_;
 922     my $result = [];
 923     return $result unless scalar @$table;
 924     my $nrows = scalar @{$table->[0]};
 925     foreach my $idx ( 0 .. $nrows - 1 ) {
 926         foreach my $wit ( 0 .. $#{$table} ) {
 927             $result->[$idx]->[$wit] = $table->[$wit]->[$idx];
 928         }
 929     }
 930     return $result;
 931 }
 932
 933 =head1 NAVIGATION METHODS
 934
 935 =head2 reading_sequence( $first, $last, $sigil, $backup )
 936
 937 Returns the ordered list of readings, starting with $first and ending
 938 with $last, for the witness given in $sigil. If a $backup sigil is
 939 specified (e.g. when walking a layered witness), it will be used wherever
 940 no $sigil path exists.  If there is a base text reading, that will be
 941 used wherever no path exists for $sigil or $backup.
 942
 943 =cut
 944
 945 # TODO Think about returning some lazy-eval iterator.
 946
 947 sub reading_sequence {
 948     my( $self, $start, $end, $witness, $backup ) = @_;
 949
 950     $witness = $self->baselabel unless $witness;
 951     my @readings = ( $start );
 952     my %seen;
 953     my $n = $start;
 954     while( $n && $n->id ne $end->id ) {
 955         if( exists( $seen{$n->id} ) ) {
 956             warn "Detected loop at " . $n->id;
 957             last;
 958         }
 959         $seen{$n->id} = 1;
 960
 961         my $next = $self->next_reading( $n, $witness, $backup );
 962         unless( $next ) {
 963             warn "Did not find any path for $witness from reading " . $n->id;
 964             last;
 965         }
 966         push( @readings, $next );
 967         $n = $next;
 968     }
 969     # Check that the last reading is our end reading.
 970     my $last = $readings[$#readings];
 971     warn "Last reading found from " . $start->text .
 972         " for witness $witness is not the end!"
 973         unless $last->id eq $end->id;
 974
 975     return @readings;
 976 }
 977
 978 =head2 next_reading( $reading, $sigil );
 979
 980 Returns the reading that follows the given reading along the given witness
 981 path.
 982
 983 =cut
 984
 985 sub next_reading {
 986     # Return the successor via the corresponding path.
 987     my $self = shift;
 988     my $answer = $self->_find_linked_reading( 'next', @_ );
 989         return undef unless $answer;
 990     return $self->reading( $answer );
 991 }
 992
 993 =head2 prior_reading( $reading, $sigil )
 994
 995 Returns the reading that precedes the given reading along the given witness
 996 path.
 997
 998 =cut
 999
1000 sub prior_reading {
1001     # Return the predecessor via the corresponding path.
1002     my $self = shift;
1003     my $answer = $self->_find_linked_reading( 'prior', @_ );
1004     return $self->reading( $answer );
1005 }
1006
1007 sub _find_linked_reading {
1008     my( $self, $direction, $node, $path, $alt_path ) = @_;
1009     my @linked_paths = $direction eq 'next'
1010         ? $self->sequence->edges_from( $node )
1011         : $self->sequence->edges_to( $node );
1012     return undef unless scalar( @linked_paths );
1013
1014     # We have to find the linked path that contains all of the
1015     # witnesses supplied in $path.
1016     my( @path_wits, @alt_path_wits );
1017     @path_wits = sort( $self->_witnesses_of_label( $path ) ) if $path;
1018     @alt_path_wits = sort( $self->_witnesses_of_label( $alt_path ) ) if $alt_path;
1019     my $base_le;
1020     my $alt_le;
1021     foreach my $le ( @linked_paths ) {
1022         if( $self->sequence->has_edge_attribute( @$le, $self->baselabel ) ) {
1023             $base_le = $le;
1024         }
1025                 my @le_wits = $self->path_witnesses( $le );
1026                 if( _is_within( \@path_wits, \@le_wits ) ) {
1027                         # This is the right path.
1028                         return $direction eq 'next' ? $le->[1] : $le->[0];
1029                 } elsif( _is_within( \@alt_path_wits, \@le_wits ) ) {
1030                         $alt_le = $le;
1031                 }
1032     }
1033     # Got this far? Return the alternate path if it exists.
1034     return $direction eq 'next' ? $alt_le->[1] : $alt_le->[0]
1035         if $alt_le;
1036
1037     # Got this far? Return the base path if it exists.
1038     return $direction eq 'next' ? $base_le->[1] : $base_le->[0]
1039         if $base_le;
1040
1041     # Got this far? We have no appropriate path.
1042     warn "Could not find $direction node from " . $node->id
1043         . " along path $path";
1044     return undef;
1045 }
1046
1047 # Some set logic.
1048 sub _is_within {
1049     my( $set1, $set2 ) = @_;
1050     my $ret = @$set1; # will be 0, i.e. false, if set1 is empty
1051     foreach my $el ( @$set1 ) {
1052         $ret = 0 unless grep { /^\Q$el\E$/ } @$set2;
1053     }
1054     return $ret;
1055 }
1056
1057 # Return the string that joins together a list of witnesses for
1058 # display on a single path.
1059 sub _witnesses_of_label {
1060     my( $self, $label ) = @_;
1061     my $regex = $self->wit_list_separator;
1062     my @answer = split( /\Q$regex\E/, $label );
1063     return @answer;
1064 }
1065
1066
1067 =head1 INITIALIZATION METHODS
1068
1069 These are mostly for use by parsers.
1070
1071 =head2 make_witness_path( $witness )
1072
1073 Link the array of readings contained in $witness->path (and in
1074 $witness->uncorrected_path if it exists) into collation paths.
1075 Clear out the arrays when finished.
1076
1077 =head2 make_witness_paths
1078
1079 Call make_witness_path for all witnesses in the tradition.
1080
1081 =cut
1082
1083 # For use when a collation is constructed from a base text and an apparatus.
1084 # We have the sequences of readings and just need to add path edges.
1085 # When we are done, clear out the witness path attributes, as they are no
1086 # longer needed.
1087 # TODO Find a way to replace the witness path attributes with encapsulated functions?
1088
1089 sub make_witness_paths {
1090     my( $self ) = @_;
1091     foreach my $wit ( $self->tradition->witnesses ) {
1092         # print STDERR "Making path for " . $wit->sigil . "\n";
1093         $self->make_witness_path( $wit );
1094     }
1095 }
1096
1097 sub make_witness_path {
1098     my( $self, $wit ) = @_;
1099     my @chain = @{$wit->path};
1100     my $sig = $wit->sigil;
1101     foreach my $idx ( 0 .. $#chain-1 ) {
1102         $self->add_path( $chain[$idx], $chain[$idx+1], $sig );
1103     }
1104     if( $wit->is_layered ) {
1105         @chain = @{$wit->uncorrected_path};
1106         foreach my $idx( 0 .. $#chain-1 ) {
1107             my $source = $chain[$idx];
1108             my $target = $chain[$idx+1];
1109             $self->add_path( $source, $target, $sig.$self->ac_label )
1110                 unless $self->has_path( $source, $target, $sig );
1111         }
1112     }
1113     $wit->clear_path;
1114     $wit->clear_uncorrected_path;
1115 }
1116
1117 =head2 calculate_ranks
1118
1119 Calculate the reading ranks (that is, their aligned positions relative
1120 to each other) for the graph.  This can only be called on linear collations.
1121
1122 =cut
1123
1124 sub calculate_ranks {
1125     my $self = shift;
1126     # Walk a version of the graph where every node linked by a relationship
1127     # edge is fundamentally the same node, and do a topological ranking on
1128     # the nodes in this graph.
1129     my $topo_graph = Graph->new();
1130     my %rel_containers;
1131     my $rel_ctr = 0;
1132     # Add the nodes
1133     foreach my $r ( $self->readings ) {
1134         next if exists $rel_containers{$r->id};
1135         my @rels = $r->related_readings( 'colocated' );
1136         if( @rels ) {
1137             # Make a relationship container.
1138             push( @rels, $r );
1139             my $rn = 'rel_container_' . $rel_ctr++;
1140             $topo_graph->add_vertex( $rn );
1141             foreach( @rels ) {
1142                 $rel_containers{$_->id} = $rn;
1143             }
1144         } else {
1145             # Add a new node to mirror the old node.
1146             $rel_containers{$r->id} = $r->id;
1147             $topo_graph->add_vertex( $r->id );
1148         }
1149     }
1150
1151     # Add the edges.
1152     foreach my $r ( $self->readings ) {
1153         foreach my $n ( $self->sequence->successors( $r->id ) ) {
1154                 my( $tfrom, $tto ) = ( $rel_containers{$r->id},
1155                         $rel_containers{$n} );
1156                 # $DB::single = 1 unless $tfrom && $tto;
1157             $topo_graph->add_edge( $tfrom, $tto );
1158         }
1159     }
1160
1161     # Now do the rankings, starting with the start node.
1162     my $topo_start = $rel_containers{$self->start->id};
1163     my $node_ranks = { $topo_start => 0 };
1164     my @curr_origin = ( $topo_start );
1165     # A little iterative function.
1166     while( @curr_origin ) {
1167         @curr_origin = _assign_rank( $topo_graph, $node_ranks, @curr_origin );
1168     }
1169     # Transfer our rankings from the topological graph to the real one.
1170     foreach my $r ( $self->readings ) {
1171         if( defined $node_ranks->{$rel_containers{$r->id}} ) {
1172             $r->rank( $node_ranks->{$rel_containers{$r->id}} );
1173         } else {
1174             die "No rank calculated for node " . $r->id
1175                 . " - do you have a cycle in the graph?";
1176         }
1177     }
1178 }
1179
1180 sub _assign_rank {
1181     my( $graph, $node_ranks, @current_nodes ) = @_;
1182     # Look at each of the children of @current_nodes.  If all the child's
1183     # parents have a rank, assign it the highest rank + 1 and add it to
1184     # @next_nodes.  Otherwise skip it; we will return when the highest-ranked
1185     # parent gets a rank.
1186     my @next_nodes;
1187     foreach my $c ( @current_nodes ) {
1188         warn "Current reading $c has no rank!"
1189             unless exists $node_ranks->{$c};
1190         # print STDERR "Looking at child of node $c, rank "
1191         #     . $node_ranks->{$c} . "\n";
1192         foreach my $child ( $graph->successors( $c ) ) {
1193             next if exists $node_ranks->{$child};
1194             my $highest_rank = -1;
1195             my $skip = 0;
1196             foreach my $parent ( $graph->predecessors( $child ) ) {
1197                 if( exists $node_ranks->{$parent} ) {
1198                     $highest_rank = $node_ranks->{$parent}
1199                         if $highest_rank <= $node_ranks->{$parent};
1200                 } else {
1201                     $skip = 1;
1202                     last;
1203                 }
1204             }
1205             next if $skip;
1206             my $c_rank = $highest_rank + 1;
1207             # print STDERR "Assigning rank $c_rank to node $child \n";
1208             $node_ranks->{$child} = $c_rank;
1209             push( @next_nodes, $child );
1210         }
1211     }
1212     return @next_nodes;
1213 }
1214
1215 =head2 flatten_ranks
1216
1217 A convenience method for parsing collation data.  Searches the graph for readings
1218 with the same text at the same rank, and merges any that are found.
1219
1220 =cut
1221
1222 sub flatten_ranks {
1223     my $self = shift;
1224     my %unique_rank_rdg;
1225     foreach my $rdg ( $self->readings ) {
1226         next unless $rdg->has_rank;
1227         my $key = $rdg->rank . "||" . $rdg->text;
1228         if( exists $unique_rank_rdg{$key} ) {
1229             # Combine!
1230                 # print STDERR "Combining readings at same rank: $key\n";
1231             $self->merge_readings( $unique_rank_rdg{$key}, $rdg );
1232         } else {
1233             $unique_rank_rdg{$key} = $rdg;
1234         }
1235     }
1236 }
1237
1238
1239 =head1 UTILITY FUNCTIONS
1240
1241 =head2 common_predecessor( $reading_a, $reading_b )
1242
1243 Find the last reading that occurs in sequence before both the given readings.
1244
1245 =head2 common_successor( $reading_a, $reading_b )
1246
1247 Find the first reading that occurs in sequence after both the given readings.
1248
1249 =begin testing
1250
1251 use Text::Tradition;
1252
1253 my $cxfile = 't/data/Collatex-16.xml';
1254 my $t = Text::Tradition->new(
1255     'name'  => 'inline',
1256     'input' => 'CollateX',
1257     'file'  => $cxfile,
1258     );
1259 my $c = $t->collation;
1260
1261 is( $c->common_predecessor( 'n9', 'n23' )->id,
1262     'n20', "Found correct common predecessor" );
1263 is( $c->common_successor( 'n9', 'n23' )->id,
1264     '#END#', "Found correct common successor" );
1265
1266 is( $c->common_predecessor( 'n19', 'n17' )->id,
1267     'n16', "Found correct common predecessor for readings on same path" );
1268 is( $c->common_successor( 'n21', 'n26' )->id,
1269     '#END#', "Found correct common successor for readings on same path" );
1270
1271 =end testing
1272
1273 =cut
1274
1275 ## Return the closest reading that is a predecessor of both the given readings.
1276 sub common_predecessor {
1277         my $self = shift;
1278         my( $r1, $r2 ) = $self->_objectify_args( @_ );
1279         return $self->common_in_path( $r1, $r2, 'predecessors' );
1280 }
1281
1282 sub common_successor {
1283         my $self = shift;
1284         my( $r1, $r2 ) = $self->_objectify_args( @_ );
1285         return $self->common_in_path( $r1, $r2, 'successors' );
1286 }
1287
1288 sub common_in_path {
1289         my( $self, $r1, $r2, $dir ) = @_;
1290         my $iter = $r1->rank > $r2->rank ? $r1->rank : $r2->rank;
1291         $iter = $self->end->rank - $iter if $dir eq 'successors';
1292         my @candidates;
1293         my @last_checked = ( $r1, $r2 );
1294         my %all_seen;
1295         while( !@candidates ) {
1296                 my @new_lc;
1297                 foreach my $lc ( @last_checked ) {
1298                         foreach my $p ( $lc->$dir ) {
1299                                 if( $all_seen{$p->id} ) {
1300                                         push( @candidates, $p );
1301                                 } else {
1302                                         $all_seen{$p->id} = 1;
1303                                         push( @new_lc, $p );
1304                                 }
1305                         }
1306                 }
1307                 @last_checked = @new_lc;
1308         }
1309         my @answer = sort { $a->rank <=> $b->rank } @candidates;
1310         return $dir eq 'predecessors' ? pop( @answer ) : shift ( @answer );
1311 }
1312
1313 no Moose;
1314 __PACKAGE__->meta->make_immutable;
1315
1316 =head1 BUGS / TODO
1317
1318 =over
1319
1320 =item * Get rid of $backup in reading_sequence
1321
1322 =back