base/lib/Text/Tradition/Collation.pm

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