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