lib/Text/Tradition/Collation.pm

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