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