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