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