lib/Text/Tradition/Collation.pm

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