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