lib/Text/Tradition/Collation.pm

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