lib/Text/Tradition/Collation.pm

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