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