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     foreach my $reading ( $self->readings ) {
 536         # Only output readings within our rank range.
 537         next if $startrank && $reading->rank < $startrank;
 538         next if $endrank && $reading->rank > $endrank;
 539         $used{$reading->id} = 1;
 540         # Need not output nodes without separate labels
 541         next if $reading->id eq $reading->text;
 542         my $label = $reading->punctuated_form;
 543         $label =~ s/\"/\\\"/g;
 544         $dot .= sprintf( "\t\"%s\" [ label=\"%s\" ];\n", $reading->id, $label );
 545     }
 546
 547         # Add the real edges
 548     my @edges = $self->paths;
 549         my( %substart, %subend );
 550     foreach my $edge ( @edges ) {
 551         # Do we need to output this edge?
 552         $DB::single = 1 if $edge->[0] =~ /n(8|13)/;
 553         if( $used{$edge->[0]} && $used{$edge->[1]} ) {;
 554                         my %variables = ( 'color' => '#000000',
 555                                                           'fontcolor' => '#000000',
 556                                                           'label' => join( ', ', $self->path_display_label( $self->path_witnesses( $edge ) ) ),
 557                                 );
 558                         my $varopts = join( ', ', map { $_.'="'.$variables{$_}.'"' } sort keys %variables );
 559                         # Account for the rank gap if necessary
 560                         my $rankgap = $self->reading( $edge->[1] )->rank
 561                                 - $self->reading( $edge->[0] )->rank;
 562                         $varopts .= ", minlen=$rankgap" if $rankgap > 1;
 563                         $dot .= sprintf( "\t\"%s\" -> \"%s\" [ %s ];\n",
 564                                                          $edge->[0], $edge->[1], $varopts );
 565         } elsif( $used{$edge->[0]} ) {
 566                 $subend{$edge->[0]} = 1;
 567         } elsif( $used{$edge->[1]} ) {
 568                 $substart{$edge->[1]} = 1;
 569         }
 570     }
 571     # Add substitute start and end edges if necessary
 572     foreach my $node ( keys %substart ) {
 573         my $witstr = $self->path_display_label ( $self->reading_witnesses( $self->reading( $node ) ) );
 574         my %variables = ( 'color' => '#000000',
 575                           'fontcolor' => '#000000',
 576                           'label' => $witstr,
 577             );
 578         my $varopts = join( ', ', map { $_.'="'.$variables{$_}.'"' } sort keys %variables );
 579                 $dot .= sprintf( "\t\"#SUBSTART#\" -> \"%s\" [ %s ];\n", $node, $varopts );
 580         }
 581     foreach my $node ( keys %subend ) {
 582         my $witstr = $self->path_display_label ( $self->reading_witnesses( $self->reading( $node ) ) );
 583         my %variables = ( 'color' => '#000000',
 584                           'fontcolor' => '#000000',
 585                           'label' => $witstr,
 586             );
 587         my $varopts = join( ', ', map { $_.'="'.$variables{$_}.'"' } sort keys %variables );
 588                 $dot .= sprintf( "\t\"%s\" -> \"#SUBEND#\" [ %s ];\n", $node, $varopts );
 589         }
 590
 591     $dot .= "}\n";
 592     return $dot;
 593 }
 594
 595 sub path_witnesses {
 596         my( $self, @edge ) = @_;
 597         # If edge is an arrayref, cope.
 598         if( @edge == 1 && ref( $edge[0] ) eq 'ARRAY' ) {
 599                 my $e = shift @edge;
 600                 @edge = @$e;
 601         }
 602         my @wits = keys %{$self->sequence->get_edge_attributes( @edge )};
 603         return sort @wits;
 604 }
 605
 606 sub path_display_label {
 607         my( $self, @wits ) = @_;
 608         my $maj = scalar( $self->tradition->witnesses ) * 0.6;
 609         if( scalar @wits > $maj ) {
 610                 return 'majority';
 611         } else {
 612                 return join( ', ', @wits );
 613         }
 614 }
 615
 616
 617 =head2 as_graphml
 618
 619 Returns a GraphML representation of the collation.  The GraphML will contain
 620 two graphs. The first expresses the attributes of the readings and the witness
 621 paths that link them; the second expresses the relationships that link the
 622 readings.  This is the native transfer format for a tradition.
 623
 624 =begin testing
 625
 626 use Text::Tradition;
 627
 628 my $READINGS = 311;
 629 my $PATHS = 361;
 630
 631 my $datafile = 't/data/florilegium_tei_ps.xml';
 632 my $tradition = Text::Tradition->new( 'input' => 'TEI',
 633                                       'name' => 'test0',
 634                                       'file' => $datafile,
 635                                       'linear' => 1 );
 636
 637 ok( $tradition, "Got a tradition object" );
 638 is( scalar $tradition->witnesses, 13, "Found all witnesses" );
 639 ok( $tradition->collation, "Tradition has a collation" );
 640
 641 my $c = $tradition->collation;
 642 is( scalar $c->readings, $READINGS, "Collation has all readings" );
 643 is( scalar $c->paths, $PATHS, "Collation has all paths" );
 644 is( scalar $c->relationships, 0, "Collation has all relationships" );
 645
 646 # Add a few relationships
 647 $c->add_relationship( 'w123', 'w125', { 'type' => 'collated' } );
 648 $c->add_relationship( 'w193', 'w196', { 'type' => 'collated' } );
 649 $c->add_relationship( 'w257', 'w262', { 'type' => 'transposition' } );
 650
 651 # Now write it to GraphML and parse it again.
 652
 653 my $graphml = $c->as_graphml;
 654 my $st = Text::Tradition->new( 'input' => 'Self', 'string' => $graphml );
 655 is( scalar $st->collation->readings, $READINGS, "Reparsed collation has all readings" );
 656 is( scalar $st->collation->paths, $PATHS, "Reparsed collation has all paths" );
 657 is( scalar $st->collation->relationships, 3, "Reparsed collation has new relationships" );
 658
 659 =end testing
 660
 661 =cut
 662
 663 sub as_graphml {
 664     my( $self ) = @_;
 665
 666     # Some namespaces
 667     my $graphml_ns = 'http://graphml.graphdrawing.org/xmlns';
 668     my $xsi_ns = 'http://www.w3.org/2001/XMLSchema-instance';
 669     my $graphml_schema = 'http://graphml.graphdrawing.org/xmlns ' .
 670         'http://graphml.graphdrawing.org/xmlns/1.0/graphml.xsd';
 671
 672     # Create the document and root node
 673     my $graphml = XML::LibXML->createDocument( "1.0", "UTF-8" );
 674     my $root = $graphml->createElementNS( $graphml_ns, 'graphml' );
 675     $graphml->setDocumentElement( $root );
 676     $root->setNamespace( $xsi_ns, 'xsi', 0 );
 677     $root->setAttributeNS( $xsi_ns, 'schemaLocation', $graphml_schema );
 678
 679     # Add the data keys for the graph
 680     my %graph_data_keys;
 681     my $gdi = 0;
 682     my @graph_attributes = qw/ version wit_list_separator baselabel linear ac_label /;
 683     foreach my $datum ( @graph_attributes ) {
 684         $graph_data_keys{$datum} = 'dg'.$gdi++;
 685         my $key = $root->addNewChild( $graphml_ns, 'key' );
 686         $key->setAttribute( 'attr.name', $datum );
 687         $key->setAttribute( 'attr.type', $key eq 'linear' ? 'boolean' : 'string' );
 688         $key->setAttribute( 'for', 'graph' );
 689         $key->setAttribute( 'id', $graph_data_keys{$datum} );
 690     }
 691
 692     # Add the data keys for nodes
 693     my %node_data_keys;
 694     my $ndi = 0;
 695     my %node_data = (
 696         id => 'string',
 697         text => 'string',
 698         rank => 'string',
 699         is_start => 'boolean',
 700         is_end => 'boolean',
 701         is_lacuna => 'boolean',
 702         );
 703     foreach my $datum ( keys %node_data ) {
 704         $node_data_keys{$datum} = 'dn'.$ndi++;
 705         my $key = $root->addNewChild( $graphml_ns, 'key' );
 706         $key->setAttribute( 'attr.name', $datum );
 707         $key->setAttribute( 'attr.type', $node_data{$datum} );
 708         $key->setAttribute( 'for', 'node' );
 709         $key->setAttribute( 'id', $node_data_keys{$datum} );
 710     }
 711
 712     # Add the data keys for edges, i.e. witnesses
 713     my $edi = 0;
 714     my %edge_data_keys;
 715     my %edge_data = (
 716         class => 'string',                              # Class, deprecated soon
 717         witness => 'string',                    # ID/label for a path
 718         relationship => 'string',               # ID/label for a relationship
 719         extra => 'boolean',                             # Path key
 720         scope => 'string',                              # Relationship key
 721         non_correctable => 'boolean',   # Relationship key
 722         non_independent => 'boolean',   # Relationship key
 723         );
 724     foreach my $datum ( keys %edge_data ) {
 725         $edge_data_keys{$datum} = 'de'.$edi++;
 726         my $key = $root->addNewChild( $graphml_ns, 'key' );
 727         $key->setAttribute( 'attr.name', $datum );
 728         $key->setAttribute( 'attr.type', $edge_data{$datum} );
 729         $key->setAttribute( 'for', 'edge' );
 730         $key->setAttribute( 'id', $edge_data_keys{$datum} );
 731     }
 732
 733     # Add the collation graph itself
 734     my $sgraph = $root->addNewChild( $graphml_ns, 'graph' );
 735     $sgraph->setAttribute( 'edgedefault', 'directed' );
 736     $sgraph->setAttribute( 'id', $self->tradition->name );
 737     $sgraph->setAttribute( 'parse.edgeids', 'canonical' );
 738     $sgraph->setAttribute( 'parse.edges', scalar($self->paths) );
 739     $sgraph->setAttribute( 'parse.nodeids', 'canonical' );
 740     $sgraph->setAttribute( 'parse.nodes', scalar($self->readings) );
 741     $sgraph->setAttribute( 'parse.order', 'nodesfirst' );
 742
 743     # Collation attribute data
 744     foreach my $datum ( @graph_attributes ) {
 745         my $value = $datum eq 'version' ? '3.0' : $self->$datum;
 746                 _add_graphml_data( $sgraph, $graph_data_keys{$datum}, $value );
 747         }
 748
 749     my $node_ctr = 0;
 750     my %node_hash;
 751     # Add our readings to the graph
 752     foreach my $n ( sort { $a->id cmp $b->id } $self->readings ) {
 753         # Add to the main graph
 754         my $node_el = $sgraph->addNewChild( $graphml_ns, 'node' );
 755         my $node_xmlid = 'n' . $node_ctr++;
 756         $node_hash{ $n->id } = $node_xmlid;
 757         $node_el->setAttribute( 'id', $node_xmlid );
 758         foreach my $d ( keys %node_data ) {
 759                 my $nval = $n->$d;
 760                 $nval = $n->punctuated_form if $d eq 'text';
 761                 _add_graphml_data( $node_el, $node_data_keys{$d}, $nval )
 762                         if defined $nval;
 763         }
 764     }
 765
 766     # Add the path edges to the sequence graph
 767     my $edge_ctr = 0;
 768     foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->sequence->edges() ) {
 769         # We add an edge in the graphml for every witness in $e.
 770         foreach my $wit ( $self->path_witnesses( $e ) ) {
 771                         my( $id, $from, $to ) = ( 'e'.$edge_ctr++,
 772                                                                                 $node_hash{ $e->[0] },
 773                                                                                 $node_hash{ $e->[1] } );
 774                         my $edge_el = $sgraph->addNewChild( $graphml_ns, 'edge' );
 775                         $edge_el->setAttribute( 'source', $from );
 776                         $edge_el->setAttribute( 'target', $to );
 777                         $edge_el->setAttribute( 'id', $id );
 778
 779                         # It's a witness path, so add the witness
 780                         my $base = $wit;
 781                         my $key = $edge_data_keys{'witness'};
 782                         # Is this an ante-corr witness?
 783                         my $aclabel = $self->ac_label;
 784                         if( $wit =~ /^(.*)\Q$aclabel\E$/ ) {
 785                                 # Keep the base witness
 786                                 $base = $1;
 787                                 # ...and record that this is an 'extra' reading path
 788                                 _add_graphml_data( $edge_el, $edge_data_keys{'extra'}, $aclabel );
 789                         }
 790                         _add_graphml_data( $edge_el, $edge_data_keys{'witness'}, $base );
 791                         _add_graphml_data( $edge_el, $edge_data_keys{'class'}, 'path' );
 792                 }
 793         }
 794
 795         # Add the relationship graph to the XML
 796         $self->relations->as_graphml( $graphml_ns, $root, \%node_hash,
 797                 $node_data_keys{'id'}, \%edge_data_keys );
 798
 799     # Save and return the thing
 800     my $result = decode_utf8( $graphml->toString(1) );
 801     return $result;
 802 }
 803
 804 sub _add_graphml_data {
 805     my( $el, $key, $value ) = @_;
 806     return unless defined $value;
 807     my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
 808     $data_el->setAttribute( 'key', $key );
 809     $data_el->appendText( $value );
 810 }
 811
 812 =head2 as_csv
 813
 814 Returns a CSV alignment table representation of the collation graph, one
 815 row per witness (or witness uncorrected.)
 816
 817 =cut
 818
 819 sub as_csv {
 820     my( $self ) = @_;
 821     my $table = $self->make_alignment_table;
 822     my $csv = Text::CSV_XS->new( { binary => 1, quote_null => 0 } );
 823     my @result;
 824     # Make the header row
 825     $csv->combine( map { $_->{'witness'} } @{$table->{'alignment'}} );
 826         push( @result, decode_utf8( $csv->string ) );
 827     # Make the rest of the rows
 828     foreach my $idx ( 0 .. $table->{'length'} - 1 ) {
 829         my @rowobjs = map { $_->{'tokens'}->[$idx] } @{$table->{'alignment'}};
 830         my @row = map { $_ ? $_->{'t'} : $_ } @rowobjs;
 831         $csv->combine( @row );
 832         push( @result, decode_utf8( $csv->string ) );
 833     }
 834     return join( "\n", @result );
 835 }
 836
 837 =head2 make_alignment_table( $use_refs, $include_witnesses )
 838
 839 Return a reference to an alignment table, in a slightly enhanced CollateX
 840 format which looks like this:
 841
 842  $table = { alignment => [ { witness => "SIGIL",
 843                              tokens => [ { t => "TEXT" }, ... ] },
 844                            { witness => "SIG2",
 845                              tokens => [ { t => "TEXT" }, ... ] },
 846                            ... ],
 847             length => TEXTLEN };
 848
 849 If $use_refs is set to 1, the reading object is returned in the table
 850 instead of READINGTEXT; if not, the text of the reading is returned.
 851
 852 If $include_witnesses is set to a hashref, only the witnesses whose sigil
 853 keys have a true hash value will be included.
 854
 855 =cut
 856
 857 sub make_alignment_table {
 858     my( $self, $noderefs, $include ) = @_;
 859     unless( $self->linear ) {
 860         warn "Need a linear graph in order to make an alignment table";
 861         return;
 862     }
 863     my $table = { 'alignment' => [], 'length' => $self->end->rank - 1 };
 864     my @all_pos = ( 1 .. $self->end->rank - 1 );
 865     foreach my $wit ( sort { $a->sigil cmp $b->sigil } $self->tradition->witnesses ) {
 866         if( $include ) {
 867                 next unless $include->{$wit->sigil};
 868         }
 869         # print STDERR "Making witness row(s) for " . $wit->sigil . "\n";
 870         my @wit_path = $self->reading_sequence( $self->start, $self->end, $wit->sigil );
 871         my @row = _make_witness_row( \@wit_path, \@all_pos, $noderefs );
 872         push( @{$table->{'alignment'}},
 873                 { 'witness' => $wit->sigil, 'tokens' => \@row } );
 874         if( $wit->is_layered ) {
 875                 my @wit_ac_path = $self->reading_sequence( $self->start, $self->end,
 876                         $wit->sigil.$self->ac_label, $wit->sigil );
 877             my @ac_row = _make_witness_row( \@wit_ac_path, \@all_pos, $noderefs );
 878                         push( @{$table->{'alignment'}},
 879                                 { 'witness' => $wit->sigil.$self->ac_label, 'tokens' => \@ac_row } );
 880         }
 881     }
 882         return $table;
 883 }
 884
 885 sub _make_witness_row {
 886     my( $path, $positions, $noderefs ) = @_;
 887     my %char_hash;
 888     map { $char_hash{$_} = undef } @$positions;
 889     my $debug = 0;
 890     foreach my $rdg ( @$path ) {
 891         my $rtext = $rdg->text;
 892         $rtext = '#LACUNA#' if $rdg->is_lacuna;
 893         print STDERR "rank " . $rdg->rank . "\n" if $debug;
 894         # print STDERR "No rank for " . $rdg->id . "\n" unless defined $rdg->rank;
 895         $char_hash{$rdg->rank} = $noderefs ? { 't' => $rdg }
 896                                                                            : { 't' => $rtext };
 897     }
 898     my @row = map { $char_hash{$_} } @$positions;
 899     # Fill in lacuna markers for undef spots in the row
 900     my $last_el = shift @row;
 901     my @filled_row = ( $last_el );
 902     foreach my $el ( @row ) {
 903         # If we are using node reference, make the lacuna node appear many times
 904         # in the table.  If not, use the lacuna tag.
 905         if( $last_el && _el_is_lacuna( $last_el ) && !defined $el ) {
 906             $el = $noderefs ? $last_el : { 't' => '#LACUNA#' };
 907         }
 908         push( @filled_row, $el );
 909         $last_el = $el;
 910     }
 911     return @filled_row;
 912 }
 913
 914 # Tiny utility function to say if a table element is a lacuna
 915 sub _el_is_lacuna {
 916     my $el = shift;
 917     return 1 if $el->{'t'} eq '#LACUNA#';
 918     return 1 if ref( $el->{'t'} ) eq 'Text::Tradition::Collation::Reading'
 919         && $el->{'t'}->is_lacuna;
 920     return 0;
 921 }
 922
 923 # Helper to turn the witnesses along columns rather than rows.  Assumes
 924 # equal-sized rows.
 925 sub _turn_table {
 926     my( $table ) = @_;
 927     my $result = [];
 928     return $result unless scalar @$table;
 929     my $nrows = scalar @{$table->[0]};
 930     foreach my $idx ( 0 .. $nrows - 1 ) {
 931         foreach my $wit ( 0 .. $#{$table} ) {
 932             $result->[$idx]->[$wit] = $table->[$wit]->[$idx];
 933         }
 934     }
 935     return $result;
 936 }
 937
 938 =head1 NAVIGATION METHODS
 939
 940 =head2 reading_sequence( $first, $last, $sigil, $backup )
 941
 942 Returns the ordered list of readings, starting with $first and ending
 943 with $last, for the witness given in $sigil. If a $backup sigil is
 944 specified (e.g. when walking a layered witness), it will be used wherever
 945 no $sigil path exists.  If there is a base text reading, that will be
 946 used wherever no path exists for $sigil or $backup.
 947
 948 =cut
 949
 950 # TODO Think about returning some lazy-eval iterator.
 951
 952 sub reading_sequence {
 953     my( $self, $start, $end, $witness, $backup ) = @_;
 954
 955     $witness = $self->baselabel unless $witness;
 956     my @readings = ( $start );
 957     my %seen;
 958     my $n = $start;
 959     while( $n && $n->id ne $end->id ) {
 960         if( exists( $seen{$n->id} ) ) {
 961             warn "Detected loop at " . $n->id;
 962             last;
 963         }
 964         $seen{$n->id} = 1;
 965
 966         my $next = $self->next_reading( $n, $witness, $backup );
 967         unless( $next ) {
 968             warn "Did not find any path for $witness from reading " . $n->id;
 969             last;
 970         }
 971         push( @readings, $next );
 972         $n = $next;
 973     }
 974     # Check that the last reading is our end reading.
 975     my $last = $readings[$#readings];
 976     warn "Last reading found from " . $start->text .
 977         " for witness $witness is not the end!"
 978         unless $last->id eq $end->id;
 979
 980     return @readings;
 981 }
 982
 983 =head2 next_reading( $reading, $sigil );
 984
 985 Returns the reading that follows the given reading along the given witness
 986 path.
 987
 988 =cut
 989
 990 sub next_reading {
 991     # Return the successor via the corresponding path.
 992     my $self = shift;
 993     my $answer = $self->_find_linked_reading( 'next', @_ );
 994         return undef unless $answer;
 995     return $self->reading( $answer );
 996 }
 997
 998 =head2 prior_reading( $reading, $sigil )
 999
1000 Returns the reading that precedes the given reading along the given witness
1001 path.
1002
1003 =cut
1004
1005 sub prior_reading {
1006     # Return the predecessor via the corresponding path.
1007     my $self = shift;
1008     my $answer = $self->_find_linked_reading( 'prior', @_ );
1009     return $self->reading( $answer );
1010 }
1011
1012 sub _find_linked_reading {
1013     my( $self, $direction, $node, $path, $alt_path ) = @_;
1014     my @linked_paths = $direction eq 'next'
1015         ? $self->sequence->edges_from( $node )
1016         : $self->sequence->edges_to( $node );
1017     return undef unless scalar( @linked_paths );
1018
1019     # We have to find the linked path that contains all of the
1020     # witnesses supplied in $path.
1021     my( @path_wits, @alt_path_wits );
1022     @path_wits = sort( $self->_witnesses_of_label( $path ) ) if $path;
1023     @alt_path_wits = sort( $self->_witnesses_of_label( $alt_path ) ) if $alt_path;
1024     my $base_le;
1025     my $alt_le;
1026     foreach my $le ( @linked_paths ) {
1027         if( $self->sequence->has_edge_attribute( @$le, $self->baselabel ) ) {
1028             $base_le = $le;
1029         }
1030                 my @le_wits = $self->path_witnesses( $le );
1031                 if( _is_within( \@path_wits, \@le_wits ) ) {
1032                         # This is the right path.
1033                         return $direction eq 'next' ? $le->[1] : $le->[0];
1034                 } elsif( _is_within( \@alt_path_wits, \@le_wits ) ) {
1035                         $alt_le = $le;
1036                 }
1037     }
1038     # Got this far? Return the alternate path if it exists.
1039     return $direction eq 'next' ? $alt_le->[1] : $alt_le->[0]
1040         if $alt_le;
1041
1042     # Got this far? Return the base path if it exists.
1043     return $direction eq 'next' ? $base_le->[1] : $base_le->[0]
1044         if $base_le;
1045
1046     # Got this far? We have no appropriate path.
1047     warn "Could not find $direction node from " . $node->id
1048         . " along path $path";
1049     return undef;
1050 }
1051
1052 # Some set logic.
1053 sub _is_within {
1054     my( $set1, $set2 ) = @_;
1055     my $ret = @$set1; # will be 0, i.e. false, if set1 is empty
1056     foreach my $el ( @$set1 ) {
1057         $ret = 0 unless grep { /^\Q$el\E$/ } @$set2;
1058     }
1059     return $ret;
1060 }
1061
1062 # Return the string that joins together a list of witnesses for
1063 # display on a single path.
1064 sub _witnesses_of_label {
1065     my( $self, $label ) = @_;
1066     my $regex = $self->wit_list_separator;
1067     my @answer = split( /\Q$regex\E/, $label );
1068     return @answer;
1069 }
1070
1071
1072 =head1 INITIALIZATION METHODS
1073
1074 These are mostly for use by parsers.
1075
1076 =head2 make_witness_path( $witness )
1077
1078 Link the array of readings contained in $witness->path (and in
1079 $witness->uncorrected_path if it exists) into collation paths.
1080 Clear out the arrays when finished.
1081
1082 =head2 make_witness_paths
1083
1084 Call make_witness_path for all witnesses in the tradition.
1085
1086 =cut
1087
1088 # For use when a collation is constructed from a base text and an apparatus.
1089 # We have the sequences of readings and just need to add path edges.
1090 # When we are done, clear out the witness path attributes, as they are no
1091 # longer needed.
1092 # TODO Find a way to replace the witness path attributes with encapsulated functions?
1093
1094 sub make_witness_paths {
1095     my( $self ) = @_;
1096     foreach my $wit ( $self->tradition->witnesses ) {
1097         # print STDERR "Making path for " . $wit->sigil . "\n";
1098         $self->make_witness_path( $wit );
1099     }
1100 }
1101
1102 sub make_witness_path {
1103     my( $self, $wit ) = @_;
1104     my @chain = @{$wit->path};
1105     my $sig = $wit->sigil;
1106     foreach my $idx ( 0 .. $#chain-1 ) {
1107         $self->add_path( $chain[$idx], $chain[$idx+1], $sig );
1108     }
1109     if( $wit->is_layered ) {
1110         @chain = @{$wit->uncorrected_path};
1111         foreach my $idx( 0 .. $#chain-1 ) {
1112             my $source = $chain[$idx];
1113             my $target = $chain[$idx+1];
1114             $self->add_path( $source, $target, $sig.$self->ac_label )
1115                 unless $self->has_path( $source, $target, $sig );
1116         }
1117     }
1118     $wit->clear_path;
1119     $wit->clear_uncorrected_path;
1120 }
1121
1122 =head2 calculate_ranks
1123
1124 Calculate the reading ranks (that is, their aligned positions relative
1125 to each other) for the graph.  This can only be called on linear collations.
1126
1127 =cut
1128
1129 sub calculate_ranks {
1130     my $self = shift;
1131     # Walk a version of the graph where every node linked by a relationship
1132     # edge is fundamentally the same node, and do a topological ranking on
1133     # the nodes in this graph.
1134     my $topo_graph = Graph->new();
1135     my %rel_containers;
1136     my $rel_ctr = 0;
1137     # Add the nodes
1138     foreach my $r ( $self->readings ) {
1139         next if exists $rel_containers{$r->id};
1140         my @rels = $r->related_readings( 'colocated' );
1141         if( @rels ) {
1142             # Make a relationship container.
1143             push( @rels, $r );
1144             my $rn = 'rel_container_' . $rel_ctr++;
1145             $topo_graph->add_vertex( $rn );
1146             foreach( @rels ) {
1147                 $rel_containers{$_->id} = $rn;
1148             }
1149         } else {
1150             # Add a new node to mirror the old node.
1151             $rel_containers{$r->id} = $r->id;
1152             $topo_graph->add_vertex( $r->id );
1153         }
1154     }
1155
1156     # Add the edges.
1157     foreach my $r ( $self->readings ) {
1158         foreach my $n ( $self->sequence->successors( $r->id ) ) {
1159                 my( $tfrom, $tto ) = ( $rel_containers{$r->id},
1160                         $rel_containers{$n} );
1161                 # $DB::single = 1 unless $tfrom && $tto;
1162             $topo_graph->add_edge( $tfrom, $tto );
1163         }
1164     }
1165
1166     # Now do the rankings, starting with the start node.
1167     my $topo_start = $rel_containers{$self->start->id};
1168     my $node_ranks = { $topo_start => 0 };
1169     my @curr_origin = ( $topo_start );
1170     # A little iterative function.
1171     while( @curr_origin ) {
1172         @curr_origin = _assign_rank( $topo_graph, $node_ranks, @curr_origin );
1173     }
1174     # Transfer our rankings from the topological graph to the real one.
1175     foreach my $r ( $self->readings ) {
1176         if( defined $node_ranks->{$rel_containers{$r->id}} ) {
1177             $r->rank( $node_ranks->{$rel_containers{$r->id}} );
1178         } else {
1179             die "No rank calculated for node " . $r->id
1180                 . " - do you have a cycle in the graph?";
1181         }
1182     }
1183 }
1184
1185 sub _assign_rank {
1186     my( $graph, $node_ranks, @current_nodes ) = @_;
1187     # Look at each of the children of @current_nodes.  If all the child's
1188     # parents have a rank, assign it the highest rank + 1 and add it to
1189     # @next_nodes.  Otherwise skip it; we will return when the highest-ranked
1190     # parent gets a rank.
1191     my @next_nodes;
1192     foreach my $c ( @current_nodes ) {
1193         warn "Current reading $c has no rank!"
1194             unless exists $node_ranks->{$c};
1195         # print STDERR "Looking at child of node $c, rank "
1196         #     . $node_ranks->{$c} . "\n";
1197         foreach my $child ( $graph->successors( $c ) ) {
1198             next if exists $node_ranks->{$child};
1199             my $highest_rank = -1;
1200             my $skip = 0;
1201             foreach my $parent ( $graph->predecessors( $child ) ) {
1202                 if( exists $node_ranks->{$parent} ) {
1203                     $highest_rank = $node_ranks->{$parent}
1204                         if $highest_rank <= $node_ranks->{$parent};
1205                 } else {
1206                     $skip = 1;
1207                     last;
1208                 }
1209             }
1210             next if $skip;
1211             my $c_rank = $highest_rank + 1;
1212             # print STDERR "Assigning rank $c_rank to node $child \n";
1213             $node_ranks->{$child} = $c_rank;
1214             push( @next_nodes, $child );
1215         }
1216     }
1217     return @next_nodes;
1218 }
1219
1220 =head2 flatten_ranks
1221
1222 A convenience method for parsing collation data.  Searches the graph for readings
1223 with the same text at the same rank, and merges any that are found.
1224
1225 =cut
1226
1227 sub flatten_ranks {
1228     my $self = shift;
1229     my %unique_rank_rdg;
1230     foreach my $rdg ( $self->readings ) {
1231         next unless $rdg->has_rank;
1232         my $key = $rdg->rank . "||" . $rdg->text;
1233         if( exists $unique_rank_rdg{$key} ) {
1234             # Combine!
1235                 # print STDERR "Combining readings at same rank: $key\n";
1236             $self->merge_readings( $unique_rank_rdg{$key}, $rdg );
1237         } else {
1238             $unique_rank_rdg{$key} = $rdg;
1239         }
1240     }
1241 }
1242
1243
1244 =head1 UTILITY FUNCTIONS
1245
1246 =head2 common_predecessor( $reading_a, $reading_b )
1247
1248 Find the last reading that occurs in sequence before both the given readings.
1249
1250 =head2 common_successor( $reading_a, $reading_b )
1251
1252 Find the first reading that occurs in sequence after both the given readings.
1253
1254 =begin testing
1255
1256 use Text::Tradition;
1257
1258 my $cxfile = 't/data/Collatex-16.xml';
1259 my $t = Text::Tradition->new(
1260     'name'  => 'inline',
1261     'input' => 'CollateX',
1262     'file'  => $cxfile,
1263     );
1264 my $c = $t->collation;
1265
1266 is( $c->common_predecessor( 'n9', 'n23' )->id,
1267     'n20', "Found correct common predecessor" );
1268 is( $c->common_successor( 'n9', 'n23' )->id,
1269     '#END#', "Found correct common successor" );
1270
1271 is( $c->common_predecessor( 'n19', 'n17' )->id,
1272     'n16', "Found correct common predecessor for readings on same path" );
1273 is( $c->common_successor( 'n21', 'n26' )->id,
1274     '#END#', "Found correct common successor for readings on same path" );
1275
1276 =end testing
1277
1278 =cut
1279
1280 ## Return the closest reading that is a predecessor of both the given readings.
1281 sub common_predecessor {
1282         my $self = shift;
1283         my( $r1, $r2 ) = $self->_objectify_args( @_ );
1284         return $self->common_in_path( $r1, $r2, 'predecessors' );
1285 }
1286
1287 sub common_successor {
1288         my $self = shift;
1289         my( $r1, $r2 ) = $self->_objectify_args( @_ );
1290         return $self->common_in_path( $r1, $r2, 'successors' );
1291 }
1292
1293 sub common_in_path {
1294         my( $self, $r1, $r2, $dir ) = @_;
1295         my $iter = $r1->rank > $r2->rank ? $r1->rank : $r2->rank;
1296         $iter = $self->end->rank - $iter if $dir eq 'successors';
1297         my @candidates;
1298         my @last_checked = ( $r1, $r2 );
1299         my %all_seen;
1300         while( !@candidates ) {
1301                 my @new_lc;
1302                 foreach my $lc ( @last_checked ) {
1303                         foreach my $p ( $lc->$dir ) {
1304                                 if( $all_seen{$p->id} ) {
1305                                         push( @candidates, $p );
1306                                 } else {
1307                                         $all_seen{$p->id} = 1;
1308                                         push( @new_lc, $p );
1309                                 }
1310                         }
1311                 }
1312                 @last_checked = @new_lc;
1313         }
1314         my @answer = sort { $a->rank <=> $b->rank } @candidates;
1315         return $dir eq 'predecessors' ? pop( @answer ) : shift ( @answer );
1316 }
1317
1318 no Moose;
1319 __PACKAGE__->meta->make_immutable;
1320
1321 =head1 BUGS / TODO
1322
1323 =over
1324
1325 =item * Get rid of $backup in reading_sequence
1326
1327 =back