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