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 = $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( $sc->get_relationship( 'n130', 'n135' ), undef, "Bad transposition relationship is gone" );
 489
 490 # Fix the collation
 491 ok( $sc->merge_readings( 'n124', 'n131_0' ), "Collated the readings correctly" );
 492 my @pairs = $sc->identical_readings( start => 'n124', end => $csucc->id );
 493 is( $sc->end->rank, 11, "The ranks shifted appropriately" );
 494 is( scalar @pairs, 3, "Found three more identical readings" );
 495 $sc->flatten_ranks();
 496 is( scalar( $sc->readings ), $numr - 3, "Now we are collated correctly" );
 497
 498 =end testing
 499
 500 =cut
 501
 502 sub duplicate_reading {
 503         my( $self, $r, @wits ) = @_;
 504         # Add the new reading, duplicating $r.
 505         unless( ref( $r ) eq 'Text::Tradition::Collation::Reading' ) {
 506                 $r = $self->reading( $r );
 507         }
 508         throw( "Cannot duplicate a meta-reading" )
 509                 if $r->is_meta;
 510
 511         # Get all the reading attributes and duplicate them.
 512         my $rmeta = Text::Tradition::Collation::Reading->meta;
 513         my %args;
 514     foreach my $attr( $rmeta->get_all_attributes ) {
 515                 next if $attr->name =~ /^_/;
 516                 my $acc = $attr->get_read_method;
 517                 if( !$acc && $attr->has_applied_traits ) {
 518                         my $tr = $attr->applied_traits;
 519                         if( $tr->[0] =~ /::(Array|Hash)$/ ) {
 520                                 my $which = $1;
 521                                 my %methods = reverse %{$attr->handles};
 522                                 $acc = $methods{elements};
 523                                 $args{$attr->name} = $which eq 'Array'
 524                                         ? [ $r->$acc ] : { $r->$acc };
 525                         }
 526                 } else {
 527                         $args{$attr->name} = $r->$acc if $acc;
 528                 }
 529         }
 530         # By definition the new reading will no longer be common.
 531         $args{is_common} = 0;
 532         # The new reading also needs its own ID.
 533         $args{id} = $self->_generate_dup_id( $r->id );
 534
 535         # Try to make the new reading.
 536         my $newr = $self->add_reading( \%args );
 537         # The old reading is also no longer common.
 538         $r->is_common( 0 );
 539
 540         # For each of the witnesses, dissociate from the old reading and
 541         # associate with the new.
 542         foreach my $wit ( @wits ) {
 543                 my $prior = $self->prior_reading( $r, $wit );
 544                 my $next = $self->next_reading( $r, $wit );
 545                 $self->del_path( $prior, $r, $wit );
 546                 $self->add_path( $prior, $newr, $wit );
 547                 $self->del_path( $r, $next, $wit );
 548                 $self->add_path( $newr, $next, $wit );
 549         }
 550
 551         # If the graph is ranked, we need to look for relationships that are now
 552         # invalid (i.e. 'non-colocation' types that might now be colocated) and
 553         # remove them. If not, we can skip it.
 554         my $succ;
 555         my %rrk;
 556         if( $self->end->has_rank ) {
 557                 # Find the point where we can stop checking
 558                 $succ = $self->common_successor( $r, $newr );
 559
 560                 # Hash the existing ranks
 561                 foreach my $rdg ( $self->readings ) {
 562                         $rrk{$rdg->id} = $rdg->rank;
 563                 }
 564                 # Calculate the new ranks
 565                 $self->calculate_ranks();
 566
 567                 # Check for invalid non-colocated relationships among changed-rank readings
 568                 # from where the ranks start changing up to $succ
 569                 my $lastrank = $succ->rank;
 570                 foreach my $rdg ( $self->readings ) {
 571                         next if $rdg->rank > $lastrank;
 572                         next if $rdg->rank == $rrk{$rdg->id};
 573                         my @noncolo = $rdg->related_readings( sub { !$_[0]->colocated } );
 574                         next unless @noncolo;
 575                         foreach my $nc ( @noncolo ) {
 576                                 $self->relations->verify_or_delete( $rdg, $nc );
 577                         }
 578                 }
 579         }
 580         return $newr;
 581 }
 582
 583 sub _generate_dup_id {
 584         my( $self, $rid ) = @_;
 585         my $newid;
 586         my $i = 0;
 587         while( !$newid ) {
 588                 $newid = $rid."_$i";
 589                 if( $self->has_reading( $newid ) ) {
 590                         $newid = '';
 591                         $i++;
 592                 }
 593         }
 594         return $newid;
 595 }
 596
 597 ### Path logic
 598
 599 sub add_path {
 600         my $self = shift;
 601
 602         # We only need the IDs for adding paths to the graph, not the reading
 603         # objects themselves.
 604     my( $source, $target, $wit ) = $self->_stringify_args( @_ );
 605
 606         $self->_graphcalc_done(0);
 607         # Connect the readings
 608         unless( $self->sequence->has_edge( $source, $target ) ) {
 609             $self->sequence->add_edge( $source, $target );
 610             $self->relations->add_equivalence_edge( $source, $target );
 611         }
 612     # Note the witness in question
 613     $self->sequence->set_edge_attribute( $source, $target, $wit, 1 );
 614 }
 615
 616 sub del_path {
 617         my $self = shift;
 618         my @args;
 619         if( ref( $_[0] ) eq 'ARRAY' ) {
 620                 my $e = shift @_;
 621                 @args = ( @$e, @_ );
 622         } else {
 623                 @args = @_;
 624         }
 625
 626         # We only need the IDs for removing paths from the graph, not the reading
 627         # objects themselves.
 628     my( $source, $target, $wit ) = $self->_stringify_args( @args );
 629
 630         $self->_graphcalc_done(0);
 631         if( $self->sequence->has_edge_attribute( $source, $target, $wit ) ) {
 632                 $self->sequence->delete_edge_attribute( $source, $target, $wit );
 633         }
 634         unless( $self->sequence->has_edge_attributes( $source, $target ) ) {
 635                 $self->sequence->delete_edge( $source, $target );
 636                 $self->relations->delete_equivalence_edge( $source, $target );
 637         }
 638 }
 639
 640
 641 # Extra graph-alike utility
 642 sub has_path {
 643         my $self = shift;
 644     my( $source, $target, $wit ) = $self->_stringify_args( @_ );
 645         return undef unless $self->sequence->has_edge( $source, $target );
 646         return $self->sequence->has_edge_attribute( $source, $target, $wit );
 647 }
 648
 649 =head2 clear_witness( @sigil_list )
 650
 651 Clear the given witnesses out of the collation entirely, removing references
 652 to them in paths, and removing readings that belong only to them.  Should only
 653 be called via $tradition->del_witness.
 654
 655 =cut
 656
 657 sub clear_witness {
 658         my( $self, @sigils ) = @_;
 659
 660         $self->_graphcalc_done(0);
 661         # Clear the witness(es) out of the paths
 662         foreach my $e ( $self->paths ) {
 663                 foreach my $sig ( @sigils ) {
 664                         $self->del_path( $e, $sig );
 665                 }
 666         }
 667
 668         # Clear out the newly unused readings
 669         foreach my $r ( $self->readings ) {
 670                 unless( $self->reading_witnesses( $r ) ) {
 671                         $self->del_reading( $r );
 672                 }
 673         }
 674 }
 675
 676 sub add_relationship {
 677         my $self = shift;
 678     my( $source, $target, $opts ) = $self->_stringify_args( @_ );
 679     my( @vectors ) = $self->relations->add_relationship( $source, $target, $opts );
 680     foreach my $v ( @vectors ) {
 681         next unless $self->get_relationship( $v )->colocated;
 682         if( $self->reading( $v->[0] )->has_rank && $self->reading( $v->[1] )->has_rank
 683                 && $self->reading( $v->[0] )->rank ne $self->reading( $v->[1] )->rank ) {
 684                         $self->_graphcalc_done(0);
 685                         $self->_clear_cache;
 686                         last;
 687         }
 688     }
 689     return @vectors;
 690 }
 691
 692 around qw/ get_relationship del_relationship / => sub {
 693         my $orig = shift;
 694         my $self = shift;
 695         my @args = @_;
 696         if( @args == 1 && ref( $args[0] ) eq 'ARRAY' ) {
 697                 @args = @{$_[0]};
 698         }
 699         my( $source, $target ) = $self->_stringify_args( @args );
 700         $self->$orig( $source, $target );
 701 };
 702
 703 =head2 reading_witnesses( $reading )
 704
 705 Return a list of sigils corresponding to the witnesses in which the reading appears.
 706
 707 =cut
 708
 709 sub reading_witnesses {
 710         my( $self, $reading ) = @_;
 711         # We need only check either the incoming or the outgoing edges; I have
 712         # arbitrarily chosen "incoming".  Thus, special-case the start node.
 713         if( $reading eq $self->start ) {
 714                 return map { $_->sigil } grep { $_->is_collated } $self->tradition->witnesses;
 715         }
 716         my %all_witnesses;
 717         foreach my $e ( $self->sequence->edges_to( $reading ) ) {
 718                 my $wits = $self->sequence->get_edge_attributes( @$e );
 719                 @all_witnesses{ keys %$wits } = 1;
 720         }
 721         my $acstr = $self->ac_label;
 722         foreach my $acwit ( grep { $_ =~ s/^(.*)\Q$acstr\E$/$1/ } keys %all_witnesses ) {
 723                 delete $all_witnesses{$acwit.$acstr} if exists $all_witnesses{$acwit};
 724         }
 725         return keys %all_witnesses;
 726 }
 727
 728 =head1 OUTPUT METHODS
 729
 730 =head2 as_svg( \%options )
 731
 732 Returns an SVG string that represents the graph, via as_dot and graphviz.
 733 See as_dot for a list of options.  Must have GraphViz (dot) installed to run.
 734
 735 =cut
 736
 737 sub as_svg {
 738     my( $self, $opts ) = @_;
 739     throw( "Need GraphViz installed to output SVG" )
 740         unless File::Which::which( 'dot' );
 741     my $want_subgraph = exists $opts->{'from'} || exists $opts->{'to'};
 742     $self->calculate_ranks()
 743         unless( $self->_graphcalc_done || $opts->{'nocalc'} || !$self->linear );
 744         my @cmd = qw/dot -Tsvg/;
 745         my( $svg, $err );
 746         my $dotfile = File::Temp->new();
 747         ## USE FOR DEBUGGING
 748         # $dotfile->unlink_on_destroy(0);
 749         binmode $dotfile, ':utf8';
 750         print $dotfile $self->as_dot( $opts );
 751         push( @cmd, $dotfile->filename );
 752         run( \@cmd, ">", binary(), \$svg );
 753         $svg = decode_utf8( $svg );
 754         return $svg;
 755 }
 756
 757
 758 =head2 as_dot( \%options )
 759
 760 Returns a string that is the collation graph expressed in dot
 761 (i.e. GraphViz) format.  Options include:
 762
 763 =over 4
 764
 765 =item * from
 766
 767 =item * to
 768
 769 =item * color_common
 770
 771 =back
 772
 773 =cut
 774
 775 sub as_dot {
 776     my( $self, $opts ) = @_;
 777     my $startrank = $opts->{'from'} if $opts;
 778     my $endrank = $opts->{'to'} if $opts;
 779     my $color_common = $opts->{'color_common'} if $opts;
 780     my $STRAIGHTENHACK = !$startrank && !$endrank && $self->end->rank
 781        && $self->end->rank > 100;
 782     $STRAIGHTENHACK = 1 if $opts->{'straight'}; # even for subgraphs or small graphs
 783
 784     # Check the arguments
 785     if( $startrank ) {
 786         return if $endrank && $startrank > $endrank;
 787         return if $startrank > $self->end->rank;
 788         }
 789         if( defined $endrank ) {
 790                 return if $endrank < 0;
 791                 $endrank = undef if $endrank == $self->end->rank;
 792         }
 793
 794     my $graph_name = $self->tradition->name;
 795     $graph_name =~ s/[^\w\s]//g;
 796     $graph_name = join( '_', split( /\s+/, $graph_name ) );
 797
 798     my %graph_attrs = (
 799         'rankdir' => 'LR',
 800         'bgcolor' => 'none',
 801         );
 802     my %node_attrs = (
 803         'fontsize' => 14,
 804         'fillcolor' => 'white',
 805         'style' => 'filled',
 806         'shape' => 'ellipse'
 807         );
 808     my %edge_attrs = (
 809         'arrowhead' => 'open',
 810         'color' => '#000000',
 811         'fontcolor' => '#000000',
 812         );
 813
 814     my $dot = sprintf( "digraph %s {\n", $graph_name );
 815     $dot .= "\tgraph " . _dot_attr_string( \%graph_attrs ) . ";\n";
 816     $dot .= "\tnode " . _dot_attr_string( \%node_attrs ) . ";\n";
 817
 818         # Output substitute start/end readings if necessary
 819         if( $startrank ) {
 820                 $dot .= "\t\"__SUBSTART__\" [ label=\"...\",id=\"__START__\" ];\n";
 821         }
 822         if( $endrank ) {
 823                 $dot .= "\t\"__SUBEND__\" [ label=\"...\",id=\"__END__\" ];\n";
 824         }
 825         if( $STRAIGHTENHACK ) {
 826                 ## HACK part 1
 827                 my $startlabel = $startrank ? '__SUBSTART__' : '__START__';
 828                 $dot .= "\tsubgraph { rank=same \"$startlabel\" \"#SILENT#\" }\n";
 829                 $dot .= "\t\"#SILENT#\" [ shape=diamond,color=white,penwidth=0,label=\"\" ];"
 830         }
 831         my %used;  # Keep track of the readings that actually appear in the graph
 832         # Sort the readings by rank if we have ranks; this speeds layout.
 833         my @all_readings = $self->end->has_rank
 834                 ? sort { $a->rank <=> $b->rank } $self->readings
 835                 : $self->readings;
 836         # TODO Refrain from outputting lacuna nodes - just grey out the edges.
 837     foreach my $reading ( @all_readings ) {
 838         # Only output readings within our rank range.
 839         next if $startrank && $reading->rank < $startrank;
 840         next if $endrank && $reading->rank > $endrank;
 841         $used{$reading->id} = 1;
 842         # Need not output nodes without separate labels
 843         next if $reading->id eq $reading->text;
 844         my $rattrs;
 845         my $label = $reading->text;
 846         $label .= '-' if $reading->join_next;
 847         $label = "-$label" if $reading->join_prior;
 848         $label =~ s/\"/\\\"/g;
 849                 $rattrs->{'label'} = $label;
 850                 $rattrs->{'id'} = $reading->id;
 851                 $rattrs->{'fillcolor'} = '#b3f36d' if $reading->is_common && $color_common;
 852         $dot .= sprintf( "\t\"%s\" %s;\n", $reading->id, _dot_attr_string( $rattrs ) );
 853     }
 854
 855         # Add the real edges. Need to weight one edge per rank jump, in a
 856         # continuous line.
 857         # my $weighted = $self->_add_edge_weights;
 858     my @edges = $self->paths;
 859         my( %substart, %subend );
 860     foreach my $edge ( @edges ) {
 861         # Do we need to output this edge?
 862         if( $used{$edge->[0]} && $used{$edge->[1]} ) {
 863                 my $label = $self->_path_display_label( $self->path_witnesses( $edge ) );
 864                         my $variables = { %edge_attrs, 'label' => $label };
 865
 866                         # Account for the rank gap if necessary
 867                         my $rank0 = $self->reading( $edge->[0] )->rank
 868                                 if $self->reading( $edge->[0] )->has_rank;
 869                         my $rank1 = $self->reading( $edge->[1] )->rank
 870                                 if $self->reading( $edge->[1] )->has_rank;
 871                         if( defined $rank0 && defined $rank1 && $rank1 - $rank0 > 1 ) {
 872                                 $variables->{'minlen'} = $rank1 - $rank0;
 873                         }
 874
 875                         # Add the calculated edge weights
 876                         # if( exists $weighted->{$edge->[0]}
 877                         #       && $weighted->{$edge->[0]} eq $edge->[1] ) {
 878                         #       # $variables->{'color'} = 'red';
 879                         #       $variables->{'weight'} = 3.0;
 880                         # }
 881
 882                         # EXPERIMENTAL: make edge width reflect no. of witnesses
 883                         my $extrawidth = scalar( $self->path_witnesses( $edge ) ) * 0.2;
 884                         $variables->{'penwidth'} = $extrawidth + 0.8; # gives 1 for a single wit
 885
 886                         my $varopts = _dot_attr_string( $variables );
 887                         $dot .= sprintf( "\t\"%s\" -> \"%s\" %s;\n",
 888                                 $edge->[0], $edge->[1], $varopts );
 889         } elsif( $used{$edge->[0]} ) {
 890                 $subend{$edge->[0]} = $edge->[1];
 891         } elsif( $used{$edge->[1]} ) {
 892                 $substart{$edge->[1]} = $edge->[0];
 893         }
 894     }
 895
 896     # If we are asked to, add relationship links
 897     if( exists $opts->{show_relations} ) {
 898         my $filter = $opts->{show_relations}; # can be 'transposition' or 'all'
 899         if( $filter eq 'transposition' ) {
 900                 $filter =~ qr/^transposition$/;
 901         }
 902         foreach my $redge ( $self->relationships ) {
 903                 if( $used{$redge->[0]} && $used{$redge->[1]} ) {
 904                         if( $filter ne 'all' ) {
 905                                 my $rel = $self->get_relationship( $redge );
 906                                 next unless $rel->type =~ /$filter/;
 907                                         my $variables = {
 908                                                 arrowhead => 'none',
 909                                                 color => '#FFA14F',
 910                                                 constraint => 'false',
 911                                                 label => uc( substr( $rel->type, 0, 4 ) ),
 912                                                 penwidth => '3',
 913                                         };
 914                                         $dot .= sprintf( "\t\"%s\" -> \"%s\" %s;\n",
 915                                                 $redge->[0], $redge->[1], _dot_attr_string( $variables ) );
 916                                 }
 917                 }
 918         }
 919     }
 920
 921     # Add substitute start and end edges if necessary
 922     foreach my $node ( keys %substart ) {
 923         my $witstr = $self->_path_display_label ( $self->path_witnesses( $substart{$node}, $node ) );
 924         my $variables = { %edge_attrs, 'label' => $witstr };
 925         my $nrdg = $self->reading( $node );
 926         if( $nrdg->has_rank && $nrdg->rank > $startrank ) {
 927                 # Substart is actually one lower than $startrank
 928                 $variables->{'minlen'} = $nrdg->rank - ( $startrank - 1 );
 929         }
 930         my $varopts = _dot_attr_string( $variables );
 931         $dot .= "\t\"__SUBSTART__\" -> \"$node\" $varopts;\n";
 932         }
 933     foreach my $node ( keys %subend ) {
 934         my $witstr = $self->_path_display_label ( $self->path_witnesses( $node, $subend{$node} ) );
 935         my $variables = { %edge_attrs, 'label' => $witstr };
 936         my $varopts = _dot_attr_string( $variables );
 937         $dot .= "\t\"$node\" -> \"__SUBEND__\" $varopts;\n";
 938         }
 939         # HACK part 2
 940         if( $STRAIGHTENHACK ) {
 941                 my $endlabel = $endrank ? '__SUBEND__' : '__END__';
 942                 $dot .= "\t\"$endlabel\" -> \"#SILENT#\" [ color=white,penwidth=0 ];\n";
 943         }
 944
 945     $dot .= "}\n";
 946     return $dot;
 947 }
 948
 949 sub _dot_attr_string {
 950         my( $hash ) = @_;
 951         my @attrs;
 952         foreach my $k ( sort keys %$hash ) {
 953                 my $v = $hash->{$k};
 954                 push( @attrs, $k.'="'.$v.'"' );
 955         }
 956         return( '[ ' . join( ', ', @attrs ) . ' ]' );
 957 }
 958
 959 sub _add_edge_weights {
 960         my $self = shift;
 961         # Walk the graph from START to END, choosing the successor node with
 962         # the largest number of witness paths each time.
 963         my $weighted = {};
 964         my $curr = $self->start->id;
 965         my $ranked = $self->end->has_rank;
 966         while( $curr ne $self->end->id ) {
 967                 my $rank = $ranked ? $self->reading( $curr )->rank : 0;
 968                 my @succ = sort { $self->path_witnesses( $curr, $a )
 969                                                         <=> $self->path_witnesses( $curr, $b ) }
 970                         $self->sequence->successors( $curr );
 971                 my $next = pop @succ;
 972                 my $nextrank = $ranked ? $self->reading( $next )->rank : 0;
 973                 # Try to avoid lacunae in the weighted path.
 974                 while( @succ &&
 975                            ( $self->reading( $next )->is_lacuna ||
 976                                  $nextrank - $rank > 1 ) ){
 977                         $next = pop @succ;
 978                 }
 979                 $weighted->{$curr} = $next;
 980                 $curr = $next;
 981         }
 982         return $weighted;
 983 }
 984
 985 =head2 path_witnesses( $edge )
 986
 987 Returns the list of sigils whose witnesses are associated with the given edge.
 988 The edge can be passed as either an array or an arrayref of ( $source, $target ).
 989
 990 =cut
 991
 992 sub path_witnesses {
 993         my( $self, @edge ) = @_;
 994         # If edge is an arrayref, cope.
 995         if( @edge == 1 && ref( $edge[0] ) eq 'ARRAY' ) {
 996                 my $e = shift @edge;
 997                 @edge = @$e;
 998         }
 999         my @wits = keys %{$self->sequence->get_edge_attributes( @edge )};
1000         return @wits;
1001 }
1002
1003 # Helper function. Make a display label for the given witnesses, showing a.c.
1004 # witnesses only where the main witness is not also in the list.
1005 sub _path_display_label {
1006         my $self = shift;
1007         my %wits;
1008         map { $wits{$_} = 1 } @_;
1009
1010         # If an a.c. wit is listed, remove it if the main wit is also listed.
1011         # Otherwise keep it for explicit listing.
1012         my $aclabel = $self->ac_label;
1013         my @disp_ac;
1014         foreach my $w ( sort keys %wits ) {
1015                 if( $w =~ /^(.*)\Q$aclabel\E$/ ) {
1016                         if( exists $wits{$1} ) {
1017                                 delete $wits{$w};
1018                         } else {
1019                                 push( @disp_ac, $w );
1020                         }
1021                 }
1022         }
1023
1024         # See if we are in a majority situation.
1025         my $maj = scalar( $self->tradition->witnesses ) * 0.6;
1026         $maj = $maj > 5 ? $maj : 5;
1027         if( scalar keys %wits > $maj ) {
1028                 unshift( @disp_ac, 'majority' );
1029                 return join( ', ', @disp_ac );
1030         } else {
1031                 return join( ', ', sort keys %wits );
1032         }
1033 }
1034
1035 =head2 readings_at_rank( $rank )
1036
1037 Returns a list of readings at a given rank, taken from the alignment table.
1038
1039 =cut
1040
1041 sub readings_at_rank {
1042         my( $self, $rank ) = @_;
1043         my $table = $self->alignment_table;
1044         # Table rank is real rank - 1.
1045         my @elements = map { $_->{'tokens'}->[$rank-1] } @{$table->{'alignment'}};
1046         my %readings;
1047         foreach my $e ( @elements ) {
1048                 next unless ref( $e ) eq 'HASH';
1049                 next unless exists $e->{'t'};
1050                 $readings{$e->{'t'}->id} = $e->{'t'};
1051         }
1052         return values %readings;
1053 }
1054
1055 =head2 as_graphml
1056
1057 Returns a GraphML representation of the collation.  The GraphML will contain
1058 two graphs. The first expresses the attributes of the readings and the witness
1059 paths that link them; the second expresses the relationships that link the
1060 readings.  This is the native transfer format for a tradition.
1061
1062 =begin testing
1063
1064 use Text::Tradition;
1065 use TryCatch;
1066
1067 my $READINGS = 311;
1068 my $PATHS = 361;
1069
1070 my $datafile = 't/data/florilegium_tei_ps.xml';
1071 my $tradition = Text::Tradition->new( 'input' => 'TEI',
1072                                       'name' => 'test0',
1073                                       'file' => $datafile,
1074                                       'linear' => 1 );
1075
1076 ok( $tradition, "Got a tradition object" );
1077 is( scalar $tradition->witnesses, 13, "Found all witnesses" );
1078 ok( $tradition->collation, "Tradition has a collation" );
1079
1080 my $c = $tradition->collation;
1081 is( scalar $c->readings, $READINGS, "Collation has all readings" );
1082 is( scalar $c->paths, $PATHS, "Collation has all paths" );
1083 is( scalar $c->relationships, 0, "Collation has all relationships" );
1084
1085 # Add a few relationships
1086 $c->add_relationship( 'w123', 'w125', { 'type' => 'collated' } );
1087 $c->add_relationship( 'w193', 'w196', { 'type' => 'collated' } );
1088 $c->add_relationship( 'w257', 'w262', { 'type' => 'transposition' } );
1089
1090 # Now write it to GraphML and parse it again.
1091
1092 my $graphml = $c->as_graphml;
1093 my $st = Text::Tradition->new( 'input' => 'Self', 'string' => $graphml );
1094 is( scalar $st->collation->readings, $READINGS, "Reparsed collation has all readings" );
1095 is( scalar $st->collation->paths, $PATHS, "Reparsed collation has all paths" );
1096 is( scalar $st->collation->relationships, 3, "Reparsed collation has new relationships" );
1097
1098 # Now add a stemma, write to GraphML, and look at the output.
1099 SKIP: {
1100         skip "Analysis module not present", 3 unless $tradition->can( 'add_stemma' );
1101         my $stemma = $tradition->add_stemma( 'dotfile' => 't/data/florilegium.dot' );
1102         is( ref( $stemma ), 'Text::Tradition::Stemma', "Parsed dotfile into stemma" );
1103         is( $tradition->stemmata, 1, "Tradition now has the stemma" );
1104         $graphml = $c->as_graphml;
1105         like( $graphml, qr/digraph/, "Digraph declaration exists in GraphML" );
1106 }
1107
1108 =end testing
1109
1110 =cut
1111
1112 ## TODO MOVE this to Tradition.pm and modularize it better
1113 sub as_graphml {
1114     my( $self, $options ) = @_;
1115         $self->calculate_ranks unless $self->_graphcalc_done;
1116
1117         my $start = $options->{'from'}
1118                 ? $self->reading( $options->{'from'} ) : $self->start;
1119         my $end = $options->{'to'}
1120                 ? $self->reading( $options->{'to'} ) : $self->end;
1121         if( $start->has_rank && $end->has_rank && $end->rank < $start->rank ) {
1122                 throw( 'Start node must be before end node' );
1123         }
1124         # The readings need to be ranked for this to work.
1125         $start = $self->start unless $start->has_rank;
1126         $end = $self->end unless $end->has_rank;
1127         my $rankoffset = 0;
1128         unless( $start eq $self->start ) {
1129                 $rankoffset = $start->rank - 1;
1130         }
1131         my %use_readings;
1132
1133     # Some namespaces
1134     my $graphml_ns = 'http://graphml.graphdrawing.org/xmlns';
1135     my $xsi_ns = 'http://www.w3.org/2001/XMLSchema-instance';
1136     my $graphml_schema = 'http://graphml.graphdrawing.org/xmlns ' .
1137         'http://graphml.graphdrawing.org/xmlns/1.0/graphml.xsd';
1138
1139     # Create the document and root node
1140     require XML::LibXML;
1141     my $graphml = XML::LibXML->createDocument( "1.0", "UTF-8" );
1142     my $root = $graphml->createElementNS( $graphml_ns, 'graphml' );
1143     $graphml->setDocumentElement( $root );
1144     $root->setNamespace( $xsi_ns, 'xsi', 0 );
1145     $root->setAttributeNS( $xsi_ns, 'schemaLocation', $graphml_schema );
1146
1147     # List of attribute types to save on our objects and their corresponding
1148     # GraphML types
1149     my %save_types = (
1150         'Str' => 'string',
1151         'Int' => 'int',
1152         'Bool' => 'boolean',
1153         'ReadingID' => 'string',
1154         'RelationshipType' => 'string',
1155         'RelationshipScope' => 'string',
1156     );
1157
1158     # Add the data keys for the graph. Include an extra key 'version' for the
1159     # GraphML output version.
1160     my %graph_data_keys;
1161     my $gdi = 0;
1162     my %graph_attributes = ( 'version' => 'string' );
1163         # Graph attributes include those of Tradition and those of Collation.
1164         my %gattr_from;
1165         # TODO Use meta introspection method from duplicate_reading to do this
1166         # instead of naming custom keys.
1167         my $tmeta = $self->tradition->meta;
1168         my $cmeta = $self->meta;
1169         map { $gattr_from{$_->name} = 'Tradition' } $tmeta->get_all_attributes;
1170         map { $gattr_from{$_->name} = 'Collation' } $cmeta->get_all_attributes;
1171         foreach my $attr ( ( $tmeta->get_all_attributes, $cmeta->get_all_attributes ) ) {
1172                 next if $attr->name =~ /^_/;
1173                 next unless $save_types{$attr->type_constraint->name};
1174                 $graph_attributes{$attr->name} = $save_types{$attr->type_constraint->name};
1175         }
1176     # Extra custom keys for complex objects that should be saved in some form.
1177     # The subroutine should return a string, or undef/empty.
1178     if( $tmeta->has_method('stemmata') ) {
1179                 $graph_attributes{'stemmata'} = sub {
1180                         my @stemstrs;
1181                         map { push( @stemstrs, $_->editable( {linesep => ''} ) ) }
1182                                 $self->tradition->stemmata;
1183                         join( "\n", @stemstrs );
1184                 };
1185         }
1186
1187         if( $tmeta->has_method('user') ) {
1188                 $graph_attributes{'user'} = sub {
1189                         $self->tradition->user ? $self->tradition->user->id : undef
1190                 };
1191         }
1192
1193     foreach my $datum ( sort keys %graph_attributes ) {
1194         $graph_data_keys{$datum} = 'dg'.$gdi++;
1195         my $key = $root->addNewChild( $graphml_ns, 'key' );
1196         my $dtype = ref( $graph_attributes{$datum} ) ? 'string'
1197                 : $graph_attributes{$datum};
1198         $key->setAttribute( 'attr.name', $datum );
1199         $key->setAttribute( 'attr.type', $dtype );
1200         $key->setAttribute( 'for', 'graph' );
1201         $key->setAttribute( 'id', $graph_data_keys{$datum} );
1202     }
1203
1204     # Add the data keys for reading nodes
1205     my %reading_attributes;
1206     my $rmeta = Text::Tradition::Collation::Reading->meta;
1207     foreach my $attr( $rmeta->get_all_attributes ) {
1208                 next if $attr->name =~ /^_/;
1209                 next unless $save_types{$attr->type_constraint->name};
1210                 $reading_attributes{$attr->name} = $save_types{$attr->type_constraint->name};
1211         }
1212         if( $self->start->does('Text::Tradition::Morphology' ) ) {
1213                 # Extra custom key for the reading morphology
1214                 $reading_attributes{'lexemes'} = 'string';
1215         }
1216
1217     my %node_data_keys;
1218     my $ndi = 0;
1219     foreach my $datum ( sort keys %reading_attributes ) {
1220         $node_data_keys{$datum} = 'dn'.$ndi++;
1221         my $key = $root->addNewChild( $graphml_ns, 'key' );
1222         $key->setAttribute( 'attr.name', $datum );
1223         $key->setAttribute( 'attr.type', $reading_attributes{$datum} );
1224         $key->setAttribute( 'for', 'node' );
1225         $key->setAttribute( 'id', $node_data_keys{$datum} );
1226     }
1227
1228     # Add the data keys for edges, that is, paths and relationships. Path
1229     # data does not come from a Moose class so is here manually.
1230     my $edi = 0;
1231     my %edge_data_keys;
1232     my %edge_attributes = (
1233         witness => 'string',                    # ID/label for a path
1234         extra => 'boolean',                             # Path key
1235         );
1236     my @path_attributes = keys %edge_attributes; # track our manual additions
1237     my $pmeta = Text::Tradition::Collation::Relationship->meta;
1238     foreach my $attr( $pmeta->get_all_attributes ) {
1239                 next if $attr->name =~ /^_/;
1240                 next unless $save_types{$attr->type_constraint->name};
1241                 $edge_attributes{$attr->name} = $save_types{$attr->type_constraint->name};
1242         }
1243     foreach my $datum ( sort keys %edge_attributes ) {
1244         $edge_data_keys{$datum} = 'de'.$edi++;
1245         my $key = $root->addNewChild( $graphml_ns, 'key' );
1246         $key->setAttribute( 'attr.name', $datum );
1247         $key->setAttribute( 'attr.type', $edge_attributes{$datum} );
1248         $key->setAttribute( 'for', 'edge' );
1249         $key->setAttribute( 'id', $edge_data_keys{$datum} );
1250     }
1251
1252     # Add the collation graph itself. First, sanitize the name to a valid XML ID.
1253     my $xmlidname = $self->tradition->name;
1254     $xmlidname =~ s/(?!$xml10_namechar_rx)./_/g;
1255     if( $xmlidname !~ /^$xml10_namestartchar_rx/ ) {
1256         $xmlidname = '_'.$xmlidname;
1257     }
1258     my $sgraph = $root->addNewChild( $graphml_ns, 'graph' );
1259     $sgraph->setAttribute( 'edgedefault', 'directed' );
1260     $sgraph->setAttribute( 'id', $xmlidname );
1261     $sgraph->setAttribute( 'parse.edgeids', 'canonical' );
1262     $sgraph->setAttribute( 'parse.edges', 0 ); # fill in later
1263     $sgraph->setAttribute( 'parse.nodeids', 'canonical' );
1264     $sgraph->setAttribute( 'parse.nodes', 0 ); # fill in later
1265     $sgraph->setAttribute( 'parse.order', 'nodesfirst' );
1266
1267     # Tradition/collation attribute data
1268     foreach my $datum ( keys %graph_attributes ) {
1269         my $value;
1270         if( $datum eq 'version' ) {
1271                 $value = '3.2';
1272         } elsif( ref( $graph_attributes{$datum} ) ) {
1273                 my $sub = $graph_attributes{$datum};
1274                 $value = &$sub();
1275         } elsif( $gattr_from{$datum} eq 'Tradition' ) {
1276                 $value = $self->tradition->$datum;
1277         } else {
1278                 $value = $self->$datum;
1279         }
1280                 _add_graphml_data( $sgraph, $graph_data_keys{$datum}, $value );
1281         }
1282
1283     my $node_ctr = 0;
1284     my %node_hash;
1285     # Add our readings to the graph
1286     foreach my $n ( sort { $a->id cmp $b->id } $self->readings ) {
1287         next if $n->has_rank && $n ne $self->start && $n ne $self->end &&
1288                 ( $n->rank < $start->rank || $n->rank > $end->rank );
1289         $use_readings{$n->id} = 1;
1290         # Add to the main graph
1291         my $node_el = $sgraph->addNewChild( $graphml_ns, 'node' );
1292         my $node_xmlid = 'n' . $node_ctr++;
1293         $node_hash{ $n->id } = $node_xmlid;
1294         $node_el->setAttribute( 'id', $node_xmlid );
1295         foreach my $d ( keys %reading_attributes ) {
1296                 my $nval = $n->$d;
1297                 # Custom serialization
1298                 if( $d eq 'lexemes' ) {
1299                                 # If nval is a true value, we have lexemes so we need to
1300                                 # serialize them. Otherwise set nval to undef so that the
1301                                 # key is excluded from this reading.
1302                         $nval = $nval ? $n->_serialize_lexemes : undef;
1303                 } elsif( $d eq 'normal_form' && $n->normal_form eq $n->text ) {
1304                         $nval = undef;
1305                 }
1306                 if( $rankoffset && $d eq 'rank' && $n ne $self->start ) {
1307                         # Adjust the ranks within the subgraph.
1308                         $nval = $n eq $self->end ? $end->rank - $rankoffset + 1
1309                                 : $nval - $rankoffset;
1310                 }
1311                 _add_graphml_data( $node_el, $node_data_keys{$d}, $nval )
1312                         if defined $nval;
1313         }
1314     }
1315
1316     # Add the path edges to the sequence graph
1317     my $edge_ctr = 0;
1318     foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->sequence->edges() ) {
1319         # We add an edge in the graphml for every witness in $e.
1320         next unless( $use_readings{$e->[0]} || $use_readings{$e->[1]} );
1321         my @edge_wits = sort $self->path_witnesses( $e );
1322         $e->[0] = $self->start->id unless $use_readings{$e->[0]};
1323         $e->[1] = $self->end->id unless $use_readings{$e->[1]};
1324         # Skip any path from start to end; that witness is not in the subgraph.
1325         next if ( $e->[0] eq $self->start->id && $e->[1] eq $self->end->id );
1326         foreach my $wit ( @edge_wits ) {
1327                         my( $id, $from, $to ) = ( 'e'.$edge_ctr++,
1328                                                                                 $node_hash{ $e->[0] },
1329                                                                                 $node_hash{ $e->[1] } );
1330                         my $edge_el = $sgraph->addNewChild( $graphml_ns, 'edge' );
1331                         $edge_el->setAttribute( 'source', $from );
1332                         $edge_el->setAttribute( 'target', $to );
1333                         $edge_el->setAttribute( 'id', $id );
1334
1335                         # It's a witness path, so add the witness
1336                         my $base = $wit;
1337                         my $key = $edge_data_keys{'witness'};
1338                         # Is this an ante-corr witness?
1339                         my $aclabel = $self->ac_label;
1340                         if( $wit =~ /^(.*)\Q$aclabel\E$/ ) {
1341                                 # Keep the base witness
1342                                 $base = $1;
1343                                 # ...and record that this is an 'extra' reading path
1344                                 _add_graphml_data( $edge_el, $edge_data_keys{'extra'}, $aclabel );
1345                         }
1346                         _add_graphml_data( $edge_el, $edge_data_keys{'witness'}, $base );
1347                 }
1348         }
1349
1350         # Report the actual number of nodes and edges that went in
1351         $sgraph->setAttribute( 'parse.edges', $edge_ctr );
1352         $sgraph->setAttribute( 'parse.nodes', $node_ctr );
1353
1354         # Add the relationship graph to the XML
1355         map { delete $edge_data_keys{$_} } @path_attributes;
1356         $self->relations->_as_graphml( $graphml_ns, $root, \%node_hash,
1357                 $node_data_keys{'id'}, \%edge_data_keys );
1358
1359     # Save and return the thing
1360     my $result = decode_utf8( $graphml->toString(1) );
1361     return $result;
1362 }
1363
1364 sub _add_graphml_data {
1365     my( $el, $key, $value ) = @_;
1366     return unless defined $value;
1367     my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
1368     $data_el->setAttribute( 'key', $key );
1369     $data_el->appendText( $value );
1370 }
1371
1372 =head2 as_csv
1373
1374 Returns a CSV alignment table representation of the collation graph, one
1375 row per witness (or witness uncorrected.)
1376
1377 =cut
1378
1379 sub as_csv {
1380     my( $self ) = @_;
1381     my $table = $self->alignment_table;
1382     my $csv = Text::CSV->new( { binary => 1, quote_null => 0 } );
1383     my @result;
1384     # Make the header row
1385     $csv->combine( map { $_->{'witness'} } @{$table->{'alignment'}} );
1386         push( @result, decode_utf8( $csv->string ) );
1387     # Make the rest of the rows
1388     foreach my $idx ( 0 .. $table->{'length'} - 1 ) {
1389         my @rowobjs = map { $_->{'tokens'}->[$idx] } @{$table->{'alignment'}};
1390         my @row = map { $_ ? $_->{'t'}->text : $_ } @rowobjs;
1391         $csv->combine( @row );
1392         push( @result, decode_utf8( $csv->string ) );
1393     }
1394     return join( "\n", @result );
1395 }
1396
1397 =head2 alignment_table
1398
1399 Return a reference to an alignment table, in a slightly enhanced CollateX
1400 format which looks like this:
1401
1402  $table = { alignment => [ { witness => "SIGIL",
1403                              tokens => [ { t => "TEXT" }, ... ] },
1404                            { witness => "SIG2",
1405                              tokens => [ { t => "TEXT" }, ... ] },
1406                            ... ],
1407             length => TEXTLEN };
1408
1409 =cut
1410
1411 sub alignment_table {
1412     my( $self ) = @_;
1413     return $self->cached_table if $self->has_cached_table;
1414
1415     # Make sure we can do this
1416         throw( "Need a linear graph in order to make an alignment table" )
1417                 unless $self->linear;
1418     $self->calculate_ranks()
1419         unless $self->_graphcalc_done && $self->end->has_rank;
1420
1421     my $table = { 'alignment' => [], 'length' => $self->end->rank - 1 };
1422     my @all_pos = ( 1 .. $self->end->rank - 1 );
1423     foreach my $wit ( sort { $a->sigil cmp $b->sigil } $self->tradition->witnesses ) {
1424         # say STDERR "Making witness row(s) for " . $wit->sigil;
1425         my @wit_path = $self->reading_sequence( $self->start, $self->end, $wit->sigil );
1426         my @row = _make_witness_row( \@wit_path, \@all_pos );
1427         my $witobj = { 'witness' => $wit->sigil, 'tokens' => \@row };
1428         $witobj->{'identifier'} = $wit->identifier if $wit->identifier;
1429         push( @{$table->{'alignment'}}, $witobj );
1430         if( $wit->is_layered ) {
1431                 my @wit_ac_path = $self->reading_sequence( $self->start, $self->end,
1432                         $wit->sigil.$self->ac_label );
1433             my @ac_row = _make_witness_row( \@wit_ac_path, \@all_pos );
1434             my $witacobj = { 'witness' => $wit->sigil.$self->ac_label,
1435                 'tokens' => \@ac_row };
1436             $witacobj->{'identifier'} = $wit->identifier if $wit->identifier;
1437                         push( @{$table->{'alignment'}}, $witacobj );
1438         }
1439     }
1440     $self->cached_table( $table );
1441     return $table;
1442 }
1443
1444 sub _make_witness_row {
1445     my( $path, $positions ) = @_;
1446     my %char_hash;
1447     map { $char_hash{$_} = undef } @$positions;
1448     my $debug = 0;
1449     foreach my $rdg ( @$path ) {
1450         say STDERR "rank " . $rdg->rank if $debug;
1451         # say STDERR "No rank for " . $rdg->id unless defined $rdg->rank;
1452         $char_hash{$rdg->rank} = { 't' => $rdg };
1453     }
1454     my @row = map { $char_hash{$_} } @$positions;
1455     # Fill in lacuna markers for undef spots in the row
1456     my $last_el = shift @row;
1457     my @filled_row = ( $last_el );
1458     foreach my $el ( @row ) {
1459         # If we are using node reference, make the lacuna node appear many times
1460         # in the table.  If not, use the lacuna tag.
1461         if( $last_el && $last_el->{'t'}->is_lacuna && !defined $el ) {
1462             $el = $last_el;
1463         }
1464         push( @filled_row, $el );
1465         $last_el = $el;
1466     }
1467     return @filled_row;
1468 }
1469
1470
1471 =head1 NAVIGATION METHODS
1472
1473 =head2 reading_sequence( $first, $last, $sigil, $backup )
1474
1475 Returns the ordered list of readings, starting with $first and ending
1476 with $last, for the witness given in $sigil. If a $backup sigil is
1477 specified (e.g. when walking a layered witness), it will be used wherever
1478 no $sigil path exists.  If there is a base text reading, that will be
1479 used wherever no path exists for $sigil or $backup.
1480
1481 =cut
1482
1483 # TODO Think about returning some lazy-eval iterator.
1484 # TODO Get rid of backup; we should know from what witness is whether we need it.
1485
1486 sub reading_sequence {
1487     my( $self, $start, $end, $witness ) = @_;
1488
1489     $witness = $self->baselabel unless $witness;
1490     my @readings = ( $start );
1491     my %seen;
1492     my $n = $start;
1493     while( $n && $n->id ne $end->id ) {
1494         if( exists( $seen{$n->id} ) ) {
1495             throw( "Detected loop for $witness at " . $n->id );
1496         }
1497         $seen{$n->id} = 1;
1498
1499         my $next = $self->next_reading( $n, $witness );
1500         unless( $next ) {
1501             throw( "Did not find any path for $witness from reading " . $n->id );
1502         }
1503         push( @readings, $next );
1504         $n = $next;
1505     }
1506     # Check that the last reading is our end reading.
1507     my $last = $readings[$#readings];
1508     throw( "Last reading found from " . $start->text .
1509         " for witness $witness is not the end!" ) # TODO do we get this far?
1510         unless $last->id eq $end->id;
1511
1512     return @readings;
1513 }
1514
1515 =head2 next_reading( $reading, $sigil );
1516
1517 Returns the reading that follows the given reading along the given witness
1518 path.
1519
1520 =cut
1521
1522 sub next_reading {
1523     # Return the successor via the corresponding path.
1524     my $self = shift;
1525     my $answer = $self->_find_linked_reading( 'next', @_ );
1526         return undef unless $answer;
1527     return $self->reading( $answer );
1528 }
1529
1530 =head2 prior_reading( $reading, $sigil )
1531
1532 Returns the reading that precedes the given reading along the given witness
1533 path.
1534
1535 =cut
1536
1537 sub prior_reading {
1538     # Return the predecessor via the corresponding path.
1539     my $self = shift;
1540     my $answer = $self->_find_linked_reading( 'prior', @_ );
1541     return $self->reading( $answer );
1542 }
1543
1544 sub _find_linked_reading {
1545     my( $self, $direction, $node, $path ) = @_;
1546
1547     # Get a backup if we are dealing with a layered witness
1548     my $alt_path;
1549     my $aclabel = $self->ac_label;
1550     if( $path && $path =~ /^(.*)\Q$aclabel\E$/ ) {
1551         $alt_path = $1;
1552     }
1553
1554     my @linked_paths = $direction eq 'next'
1555         ? $self->sequence->edges_from( $node )
1556         : $self->sequence->edges_to( $node );
1557     return undef unless scalar( @linked_paths );
1558
1559     # We have to find the linked path that contains all of the
1560     # witnesses supplied in $path.
1561     my( @path_wits, @alt_path_wits );
1562     @path_wits = sort( $self->_witnesses_of_label( $path ) ) if $path;
1563     @alt_path_wits = sort( $self->_witnesses_of_label( $alt_path ) ) if $alt_path;
1564     my $base_le;
1565     my $alt_le;
1566     foreach my $le ( @linked_paths ) {
1567         if( $self->sequence->has_edge_attribute( @$le, $self->baselabel ) ) {
1568             $base_le = $le;
1569         }
1570                 my @le_wits = sort $self->path_witnesses( $le );
1571                 if( _is_within( \@path_wits, \@le_wits ) ) {
1572                         # This is the right path.
1573                         return $direction eq 'next' ? $le->[1] : $le->[0];
1574                 } elsif( _is_within( \@alt_path_wits, \@le_wits ) ) {
1575                         $alt_le = $le;
1576                 }
1577     }
1578     # Got this far? Return the alternate path if it exists.
1579     return $direction eq 'next' ? $alt_le->[1] : $alt_le->[0]
1580         if $alt_le;
1581
1582     # Got this far? Return the base path if it exists.
1583     return $direction eq 'next' ? $base_le->[1] : $base_le->[0]
1584         if $base_le;
1585
1586     # Got this far? We have no appropriate path.
1587     warn "Could not find $direction node from " . $node->id
1588         . " along path $path";
1589     return undef;
1590 }
1591
1592 # Some set logic.
1593 sub _is_within {
1594     my( $set1, $set2 ) = @_;
1595     my $ret = @$set1; # will be 0, i.e. false, if set1 is empty
1596     foreach my $el ( @$set1 ) {
1597         $ret = 0 unless grep { /^\Q$el\E$/ } @$set2;
1598     }
1599     return $ret;
1600 }
1601
1602 # Return the string that joins together a list of witnesses for
1603 # display on a single path.
1604 sub _witnesses_of_label {
1605     my( $self, $label ) = @_;
1606     my $regex = $self->wit_list_separator;
1607     my @answer = split( /\Q$regex\E/, $label );
1608     return @answer;
1609 }
1610
1611 =head2 common_readings
1612
1613 Returns the list of common readings in the graph (i.e. those readings that are
1614 shared by all non-lacunose witnesses.)
1615
1616 =cut
1617
1618 sub common_readings {
1619         my $self = shift;
1620         my @common = grep { $_->is_common } $self->readings;
1621         return @common;
1622 }
1623
1624 =head2 path_text( $sigil, [, $start, $end ] )
1625
1626 Returns the text of a witness (plus its backup, if we are using a layer)
1627 as stored in the collation.  The text is returned as a string, where the
1628 individual readings are joined with spaces and the meta-readings (e.g.
1629 lacunae) are omitted.  Optional specification of $start and $end allows
1630 the generation of a subset of the witness text.
1631
1632 =cut
1633
1634 sub path_text {
1635         my( $self, $wit, $start, $end ) = @_;
1636         $start = $self->start unless $start;
1637         $end = $self->end unless $end;
1638         my @path = grep { !$_->is_meta } $self->reading_sequence( $start, $end, $wit );
1639         my $pathtext = '';
1640         my $last;
1641         foreach my $r ( @path ) {
1642                 unless ( $r->join_prior || !$last || $last->join_next ) {
1643                         $pathtext .= ' ';
1644                 }
1645                 $pathtext .= $r->text;
1646                 $last = $r;
1647         }
1648         return $pathtext;
1649 }
1650
1651 =head1 INITIALIZATION METHODS
1652
1653 These are mostly for use by parsers.
1654
1655 =head2 make_witness_path( $witness )
1656
1657 Link the array of readings contained in $witness->path (and in
1658 $witness->uncorrected_path if it exists) into collation paths.
1659 Clear out the arrays when finished.
1660
1661 =head2 make_witness_paths
1662
1663 Call make_witness_path for all witnesses in the tradition.
1664
1665 =cut
1666
1667 # For use when a collation is constructed from a base text and an apparatus.
1668 # We have the sequences of readings and just need to add path edges.
1669 # When we are done, clear out the witness path attributes, as they are no
1670 # longer needed.
1671 # TODO Find a way to replace the witness path attributes with encapsulated functions?
1672
1673 sub make_witness_paths {
1674     my( $self ) = @_;
1675     foreach my $wit ( $self->tradition->witnesses ) {
1676         # say STDERR "Making path for " . $wit->sigil;
1677         $self->make_witness_path( $wit );
1678     }
1679 }
1680
1681 sub make_witness_path {
1682     my( $self, $wit ) = @_;
1683     my @chain = @{$wit->path};
1684     my $sig = $wit->sigil;
1685     # Add start and end if necessary
1686     unshift( @chain, $self->start ) unless $chain[0] eq $self->start;
1687     push( @chain, $self->end ) unless $chain[-1] eq $self->end;
1688     foreach my $idx ( 0 .. $#chain-1 ) {
1689         $self->add_path( $chain[$idx], $chain[$idx+1], $sig );
1690     }
1691     if( $wit->is_layered ) {
1692         @chain = @{$wit->uncorrected_path};
1693                 unshift( @chain, $self->start ) unless $chain[0] eq $self->start;
1694                 push( @chain, $self->end ) unless $chain[-1] eq $self->end;
1695         foreach my $idx( 0 .. $#chain-1 ) {
1696             my $source = $chain[$idx];
1697             my $target = $chain[$idx+1];
1698             $self->add_path( $source, $target, $sig.$self->ac_label )
1699                 unless $self->has_path( $source, $target, $sig );
1700         }
1701     }
1702     $wit->clear_path;
1703     $wit->clear_uncorrected_path;
1704 }
1705
1706 =head2 calculate_ranks
1707
1708 Calculate the reading ranks (that is, their aligned positions relative
1709 to each other) for the graph.  This can only be called on linear collations.
1710
1711 =begin testing
1712
1713 use Text::Tradition;
1714
1715 my $cxfile = 't/data/Collatex-16.xml';
1716 my $t = Text::Tradition->new(
1717     'name'  => 'inline',
1718     'input' => 'CollateX',
1719     'file'  => $cxfile,
1720     );
1721 my $c = $t->collation;
1722
1723 # Make an svg
1724 my $table = $c->alignment_table;
1725 ok( $c->has_cached_table, "Alignment table was cached" );
1726 is( $c->alignment_table, $table, "Cached table returned upon second call" );
1727 $c->calculate_ranks;
1728 is( $c->alignment_table, $table, "Cached table retained with no rank change" );
1729 $c->add_relationship( 'n13', 'n23', { type => 'repetition' } );
1730 is( $c->alignment_table, $table, "Alignment table unchanged after non-colo relationship add" );
1731 $c->add_relationship( 'n24', 'n23', { type => 'spelling' } );
1732 isnt( $c->alignment_table, $table, "Alignment table changed after colo relationship add" );
1733
1734 =end testing
1735
1736 =cut
1737
1738 sub calculate_ranks {
1739     my $self = shift;
1740     # Save the existing ranks, in case we need to invalidate the cached SVG.
1741     my %existing_ranks;
1742     map { $existing_ranks{$_} = $_->rank } $self->readings;
1743
1744     # Do the rankings based on the relationship equivalence graph, starting
1745     # with the start node.
1746     my ( $node_ranks, $rank_nodes ) = $self->relations->equivalence_ranks();
1747
1748     # Transfer our rankings from the topological graph to the real one.
1749     foreach my $r ( $self->readings ) {
1750         if( defined $node_ranks->{$self->equivalence( $r->id )} ) {
1751             $r->rank( $node_ranks->{$self->equivalence( $r->id )} );
1752         } else {
1753                 # Die. Find the last rank we calculated.
1754                 my @all_defined = sort { ( $node_ranks->{$self->equivalence( $a->id )}||-1 )
1755                                  <=> ( $node_ranks->{$self->equivalence( $b->id )}||-1 ) }
1756                         $self->readings;
1757                 my $last = pop @all_defined;
1758             throw( "Ranks not calculated after $last - do you have a cycle in the graph?" );
1759         }
1760     }
1761     # Do we need to invalidate the cached data?
1762     if( $self->has_cached_table ) {
1763         foreach my $r ( $self->readings ) {
1764                 next if defined( $existing_ranks{$r} )
1765                         && $existing_ranks{$r} == $r->rank;
1766                 # Something has changed, so clear the cache
1767                 $self->_clear_cache;
1768                         # ...and recalculate the common readings.
1769                         $self->calculate_common_readings();
1770                 last;
1771         }
1772     }
1773         # The graph calculation information is now up to date.
1774         $self->_graphcalc_done(1);
1775 }
1776
1777 sub _clear_cache {
1778         my $self = shift;
1779         $self->wipe_table if $self->has_cached_table;
1780 }
1781
1782
1783 =head2 flatten_ranks
1784
1785 A convenience method for parsing collation data.  Searches the graph for readings
1786 with the same text at the same rank, and merges any that are found.
1787
1788 =cut
1789
1790 sub flatten_ranks {
1791     my ( $self, %args ) = shift;
1792     my %unique_rank_rdg;
1793     my $changed;
1794     foreach my $p ( $self->identical_readings( %args ) ) {
1795                 # say STDERR "Combining readings at same rank: @$p";
1796                 $changed = 1;
1797                 $self->merge_readings( @$p );
1798                 # TODO see if this now makes a common point.
1799     }
1800     # If we merged readings, the ranks are still fine but the alignment
1801     # table is wrong. Wipe it.
1802     $self->wipe_table() if $changed;
1803 }
1804
1805 =head2 identical_readings
1806 =head2 identical_readings( start => $startnode, end => $endnode )
1807 =head2 identical_readings( startrank => $startrank, endrank => $endrank )
1808
1809 Goes through the graph identifying all pairs of readings that appear to be
1810 identical, and therefore able to be merged into a single reading. Returns the
1811 relevant identical pairs. Can be restricted to run over only a part of the
1812 graph, specified either by node or by rank.
1813
1814 =cut
1815
1816 sub identical_readings {
1817         my ( $self, %args ) = @_;
1818     # Find where we should start and end.
1819     $DB::single = 1;
1820     my $startrank = $args{startrank} || 0;
1821     if( $args{start} ) {
1822         throw( "Starting reading has no rank" ) unless $self->reading( $args{start} )
1823                 && $self->reading( $args{start} )->has_rank;
1824         $startrank = $self->reading( $args{start} )->rank;
1825     }
1826     my $endrank = $args{endrank} || $self->end->rank;
1827     if( $args{end} ) {
1828         throw( "Ending reading has no rank" ) unless $self->reading( $args{end} )
1829                 && $self->reading( $args{end} )->has_rank;
1830         $endrank = $self->reading( $args{end} )->rank;
1831     }
1832
1833     # Make sure the ranks are correct.
1834     unless( $self->_graphcalc_done ) {
1835         $self->calculate_ranks;
1836     }
1837     # Go through the readings looking for duplicates.
1838     my %unique_rank_rdg;
1839     my @pairs;
1840     foreach my $rdg ( $self->readings ) {
1841         next unless $rdg->has_rank;
1842         my $rk = $rdg->rank;
1843         next if $rk > $endrank || $rk < $startrank;
1844         my $key = $rk . "||" . $rdg->text;
1845         if( exists $unique_rank_rdg{$key} ) {
1846                 # Make sure they don't have different grammatical forms
1847                         my $ur = $unique_rank_rdg{$key};
1848                 if( $rdg->is_identical( $ur ) ) {
1849                                 push( @pairs, [ $ur, $rdg ] );
1850                         }
1851         } else {
1852             $unique_rank_rdg{$key} = $rdg;
1853         }
1854     }
1855
1856     return @pairs;
1857 }
1858
1859
1860 =head2 calculate_common_readings
1861
1862 Goes through the graph identifying the readings that appear in every witness
1863 (apart from those with lacunae at that spot.) Marks them as common and returns
1864 the list.
1865
1866 =begin testing
1867
1868 use Text::Tradition;
1869
1870 my $cxfile = 't/data/Collatex-16.xml';
1871 my $t = Text::Tradition->new(
1872     'name'  => 'inline',
1873     'input' => 'CollateX',
1874     'file'  => $cxfile,
1875     );
1876 my $c = $t->collation;
1877
1878 my @common = $c->calculate_common_readings();
1879 is( scalar @common, 8, "Found correct number of common readings" );
1880 my @marked = sort $c->common_readings();
1881 is( scalar @common, 8, "All common readings got marked as such" );
1882 my @expected = qw/ n1 n11 n16 n19 n20 n5 n6 n7 /;
1883 is_deeply( \@marked, \@expected, "Found correct list of common readings" );
1884
1885 =end testing
1886
1887 =cut
1888
1889 sub calculate_common_readings {
1890         my $self = shift;
1891         my @common;
1892         map { $_->is_common( 0 ) } $self->readings;
1893         # Implicitly calls calculate_ranks
1894         my $table = $self->alignment_table;
1895         foreach my $idx ( 0 .. $table->{'length'} - 1 ) {
1896                 my @row = map { $_->{'tokens'}->[$idx]
1897                                                         ? $_->{'tokens'}->[$idx]->{'t'} : '' }
1898                                         @{$table->{'alignment'}};
1899                 my %hash;
1900                 foreach my $r ( @row ) {
1901                         if( $r ) {
1902                                 $hash{$r->id} = $r unless $r->is_meta;
1903                         } else {
1904                                 $hash{'UNDEF'} = $r;
1905                         }
1906                 }
1907                 if( keys %hash == 1 && !exists $hash{'UNDEF'} ) {
1908                         my( $r ) = values %hash;
1909                         $r->is_common( 1 );
1910                         push( @common, $r );
1911                 }
1912         }
1913         return @common;
1914 }
1915
1916 =head2 text_from_paths
1917
1918 Calculate the text array for all witnesses from the path, for later consistency
1919 checking.  Only to be used if there is no non-graph-based way to know the
1920 original texts.
1921
1922 =cut
1923
1924 sub text_from_paths {
1925         my $self = shift;
1926     foreach my $wit ( $self->tradition->witnesses ) {
1927         my @readings = $self->reading_sequence( $self->start, $self->end, $wit->sigil );
1928         my @text;
1929         foreach my $r ( @readings ) {
1930                 next if $r->is_meta;
1931                 push( @text, $r->text );
1932         }
1933         $wit->text( \@text );
1934         if( $wit->is_layered ) {
1935                         my @ucrdgs = $self->reading_sequence( $self->start, $self->end,
1936                                                                                                   $wit->sigil.$self->ac_label );
1937                         my @uctext;
1938                         foreach my $r ( @ucrdgs ) {
1939                                 next if $r->is_meta;
1940                                 push( @uctext, $r->text );
1941                         }
1942                         $wit->layertext( \@uctext );
1943         }
1944     }
1945 }
1946
1947 =head1 UTILITY FUNCTIONS
1948
1949 =head2 common_predecessor( $reading_a, $reading_b )
1950
1951 Find the last reading that occurs in sequence before both the given readings.
1952 At the very least this should be $self->start.
1953
1954 =head2 common_successor( $reading_a, $reading_b )
1955
1956 Find the first reading that occurs in sequence after both the given readings.
1957 At the very least this should be $self->end.
1958
1959 =begin testing
1960
1961 use Text::Tradition;
1962
1963 my $cxfile = 't/data/Collatex-16.xml';
1964 my $t = Text::Tradition->new(
1965     'name'  => 'inline',
1966     'input' => 'CollateX',
1967     'file'  => $cxfile,
1968     );
1969 my $c = $t->collation;
1970
1971 is( $c->common_predecessor( 'n24', 'n23' )->id,
1972     'n20', "Found correct common predecessor" );
1973 is( $c->common_successor( 'n24', 'n23' )->id,
1974     '__END__', "Found correct common successor" );
1975
1976 is( $c->common_predecessor( 'n19', 'n17' )->id,
1977     'n16', "Found correct common predecessor for readings on same path" );
1978 is( $c->common_successor( 'n21', 'n10' )->id,
1979     '__END__', "Found correct common successor for readings on same path" );
1980
1981 =end testing
1982
1983 =cut
1984
1985 ## Return the closest reading that is a predecessor of both the given readings.
1986 sub common_predecessor {
1987         my $self = shift;
1988         my( $r1, $r2 ) = $self->_objectify_args( @_ );
1989         return $self->_common_in_path( $r1, $r2, 'predecessors' );
1990 }
1991
1992 sub common_successor {
1993         my $self = shift;
1994         my( $r1, $r2 ) = $self->_objectify_args( @_ );
1995         return $self->_common_in_path( $r1, $r2, 'successors' );
1996 }
1997
1998
1999 # TODO think about how to do this without ranks...
2000 sub _common_in_path {
2001         my( $self, $r1, $r2, $dir ) = @_;
2002         my $iter = $self->end->rank;
2003         my @candidates;
2004         my @last_r1 = ( $r1 );
2005         my @last_r2 = ( $r2 );
2006         # my %all_seen = ( $r1 => 'r1', $r2 => 'r2' );
2007         my %all_seen;
2008         # say STDERR "Finding common $dir for $r1, $r2";
2009         while( !@candidates ) {
2010                 last unless $iter--;  # Avoid looping infinitely
2011                 # Iterate separately down the graph from r1 and r2
2012                 my( @new_lc1, @new_lc2 );
2013                 foreach my $lc ( @last_r1 ) {
2014                         foreach my $p ( $lc->$dir ) {
2015                                 if( $all_seen{$p->id} && $all_seen{$p->id} ne 'r1' ) {
2016                                         # say STDERR "Path candidate $p from $lc";
2017                                         push( @candidates, $p );
2018                                 } elsif( !$all_seen{$p->id} ) {
2019                                         $all_seen{$p->id} = 'r1';
2020                                         push( @new_lc1, $p );
2021                                 }
2022                         }
2023                 }
2024                 foreach my $lc ( @last_r2 ) {
2025                         foreach my $p ( $lc->$dir ) {
2026                                 if( $all_seen{$p->id} && $all_seen{$p->id} ne 'r2' ) {
2027                                         # say STDERR "Path candidate $p from $lc";
2028                                         push( @candidates, $p );
2029                                 } elsif( !$all_seen{$p->id} ) {
2030                                         $all_seen{$p->id} = 'r2';
2031                                         push( @new_lc2, $p );
2032                                 }
2033                         }
2034                 }
2035                 @last_r1 = @new_lc1;
2036                 @last_r2 = @new_lc2;
2037         }
2038         my @answer = sort { $a->rank <=> $b->rank } @candidates;
2039         return $dir eq 'predecessors' ? pop( @answer ) : shift ( @answer );
2040 }
2041
2042 sub throw {
2043         Text::Tradition::Error->throw(
2044                 'ident' => 'Collation error',
2045                 'message' => $_[0],
2046                 );
2047 }
2048
2049 no Moose;
2050 __PACKAGE__->meta->make_immutable;
2051
2052 =head1 BUGS/TODO
2053
2054 =over
2055
2056 =item * Rework XML serialization in a more modular way
2057
2058 =back
2059
2060 =head1 LICENSE
2061
2062 This package is free software and is provided "as is" without express
2063 or implied warranty.  You can redistribute it and/or modify it under
2064 the same terms as Perl itself.
2065
2066 =head1 AUTHOR
2067
2068 Tara L Andrews E<lt>aurum@cpan.orgE<gt>