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( $self->path_witnesses( $edge ) );
 871                         my $variables = { %edge_attrs, 'label' => $label };
 872
 873                         # Account for the rank gap if necessary
 874                         my $rank0 = $self->reading( $edge->[0] )->rank
 875                                 if $self->reading( $edge->[0] )->has_rank;
 876                         my $rank1 = $self->reading( $edge->[1] )->rank
 877                                 if $self->reading( $edge->[1] )->has_rank;
 878                         if( defined $rank0 && defined $rank1 && $rank1 - $rank0 > 1 ) {
 879                                 $variables->{'minlen'} = $rank1 - $rank0;
 880                         }
 881
 882                         # Add the calculated edge weights
 883                         # if( exists $weighted->{$edge->[0]}
 884                         #       && $weighted->{$edge->[0]} eq $edge->[1] ) {
 885                         #       # $variables->{'color'} = 'red';
 886                         #       $variables->{'weight'} = 3.0;
 887                         # }
 888
 889                         # EXPERIMENTAL: make edge width reflect no. of witnesses
 890                         my $extrawidth = scalar( $self->path_witnesses( $edge ) ) * 0.2;
 891                         $variables->{'penwidth'} = $extrawidth + 0.8; # gives 1 for a single wit
 892
 893                         my $varopts = _dot_attr_string( $variables );
 894                         $dot .= sprintf( "\t\"%s\" -> \"%s\" %s;\n",
 895                                 $edge->[0], $edge->[1], $varopts );
 896         } elsif( $used{$edge->[0]} ) {
 897                 $subend{$edge->[0]} = $edge->[1];
 898         } elsif( $used{$edge->[1]} ) {
 899                 $substart{$edge->[1]} = $edge->[0];
 900         }
 901     }
 902
 903     # If we are asked to, add relationship links
 904     if( exists $opts->{show_relations} ) {
 905         my $filter = $opts->{show_relations}; # can be 'transposition' or 'all'
 906         if( $filter eq 'transposition' ) {
 907                 $filter =~ qr/^transposition$/;
 908         }
 909         foreach my $redge ( $self->relationships ) {
 910                 if( $used{$redge->[0]} && $used{$redge->[1]} ) {
 911                         if( $filter ne 'all' ) {
 912                                 my $rel = $self->get_relationship( $redge );
 913                                 next unless $rel->type =~ /$filter/;
 914                                         my $variables = {
 915                                                 arrowhead => 'none',
 916                                                 color => '#FFA14F',
 917                                                 constraint => 'false',
 918                                                 label => uc( substr( $rel->type, 0, 4 ) ),
 919                                                 penwidth => '3',
 920                                         };
 921                                         $dot .= sprintf( "\t\"%s\" -> \"%s\" %s;\n",
 922                                                 $redge->[0], $redge->[1], _dot_attr_string( $variables ) );
 923                                 }
 924                 }
 925         }
 926     }
 927
 928     # Add substitute start and end edges if necessary
 929     foreach my $node ( keys %substart ) {
 930         my $witstr = $self->_path_display_label ( $self->path_witnesses( $substart{$node}, $node ) );
 931         my $variables = { %edge_attrs, 'label' => $witstr };
 932         my $nrdg = $self->reading( $node );
 933         if( $nrdg->has_rank && $nrdg->rank > $startrank ) {
 934                 # Substart is actually one lower than $startrank
 935                 $variables->{'minlen'} = $nrdg->rank - ( $startrank - 1 );
 936         }
 937         my $varopts = _dot_attr_string( $variables );
 938         $dot .= "\t\"__SUBSTART__\" -> \"$node\" $varopts;\n";
 939         }
 940     foreach my $node ( keys %subend ) {
 941         my $witstr = $self->_path_display_label ( $self->path_witnesses( $node, $subend{$node} ) );
 942         my $variables = { %edge_attrs, 'label' => $witstr };
 943         my $varopts = _dot_attr_string( $variables );
 944         $dot .= "\t\"$node\" -> \"__SUBEND__\" $varopts;\n";
 945         }
 946         # HACK part 2
 947         if( $STRAIGHTENHACK ) {
 948                 my $endlabel = $endrank ? '__SUBEND__' : '__END__';
 949                 $dot .= "\t\"$endlabel\" -> \"#SILENT#\" [ color=white,penwidth=0 ];\n";
 950         }
 951
 952     $dot .= "}\n";
 953     return $dot;
 954 }
 955
 956 sub _dot_attr_string {
 957         my( $hash ) = @_;
 958         my @attrs;
 959         foreach my $k ( sort keys %$hash ) {
 960                 my $v = $hash->{$k};
 961                 push( @attrs, $k.'="'.$v.'"' );
 962         }
 963         return( '[ ' . join( ', ', @attrs ) . ' ]' );
 964 }
 965
 966 sub _add_edge_weights {
 967         my $self = shift;
 968         # Walk the graph from START to END, choosing the successor node with
 969         # the largest number of witness paths each time.
 970         my $weighted = {};
 971         my $curr = $self->start->id;
 972         my $ranked = $self->end->has_rank;
 973         while( $curr ne $self->end->id ) {
 974                 my $rank = $ranked ? $self->reading( $curr )->rank : 0;
 975                 my @succ = sort { $self->path_witnesses( $curr, $a )
 976                                                         <=> $self->path_witnesses( $curr, $b ) }
 977                         $self->sequence->successors( $curr );
 978                 my $next = pop @succ;
 979                 my $nextrank = $ranked ? $self->reading( $next )->rank : 0;
 980                 # Try to avoid lacunae in the weighted path.
 981                 while( @succ &&
 982                            ( $self->reading( $next )->is_lacuna ||
 983                                  $nextrank - $rank > 1 ) ){
 984                         $next = pop @succ;
 985                 }
 986                 $weighted->{$curr} = $next;
 987                 $curr = $next;
 988         }
 989         return $weighted;
 990 }
 991
 992 =head2 path_witnesses( $edge )
 993
 994 Returns the list of sigils whose witnesses are associated with the given edge.
 995 The edge can be passed as either an array or an arrayref of ( $source, $target ).
 996
 997 =cut
 998
 999 sub path_witnesses {
1000         my( $self, @edge ) = @_;
1001         # If edge is an arrayref, cope.
1002         if( @edge == 1 && ref( $edge[0] ) eq 'ARRAY' ) {
1003                 my $e = shift @edge;
1004                 @edge = @$e;
1005         }
1006         my @wits = keys %{$self->sequence->get_edge_attributes( @edge )};
1007         return @wits;
1008 }
1009
1010 # Helper function. Make a display label for the given witnesses, showing a.c.
1011 # witnesses only where the main witness is not also in the list.
1012 sub _path_display_label {
1013         my $self = shift;
1014         my %wits;
1015         map { $wits{$_} = 1 } @_;
1016
1017         # If an a.c. wit is listed, remove it if the main wit is also listed.
1018         # Otherwise keep it for explicit listing.
1019         my $aclabel = $self->ac_label;
1020         my @disp_ac;
1021         foreach my $w ( sort keys %wits ) {
1022                 if( $w =~ /^(.*)\Q$aclabel\E$/ ) {
1023                         if( exists $wits{$1} ) {
1024                                 delete $wits{$w};
1025                         } else {
1026                                 push( @disp_ac, $w );
1027                         }
1028                 }
1029         }
1030
1031         # See if we are in a majority situation.
1032         my $maj = scalar( $self->tradition->witnesses ) * 0.6;
1033         $maj = $maj > 5 ? $maj : 5;
1034         if( scalar keys %wits > $maj ) {
1035                 unshift( @disp_ac, 'majority' );
1036                 return join( ', ', @disp_ac );
1037         } else {
1038                 return join( ', ', sort keys %wits );
1039         }
1040 }
1041
1042 =head2 readings_at_rank( $rank )
1043
1044 Returns a list of readings at a given rank, taken from the alignment table.
1045
1046 =cut
1047
1048 sub readings_at_rank {
1049         my( $self, $rank ) = @_;
1050         my $table = $self->alignment_table;
1051         # Table rank is real rank - 1.
1052         my @elements = map { $_->{'tokens'}->[$rank-1] } @{$table->{'alignment'}};
1053         my %readings;
1054         foreach my $e ( @elements ) {
1055                 next unless ref( $e ) eq 'HASH';
1056                 next unless exists $e->{'t'};
1057                 $readings{$e->{'t'}->id} = $e->{'t'};
1058         }
1059         return values %readings;
1060 }
1061
1062 =head2 as_graphml
1063
1064 Returns a GraphML representation of the collation.  The GraphML will contain
1065 two graphs. The first expresses the attributes of the readings and the witness
1066 paths that link them; the second expresses the relationships that link the
1067 readings.  This is the native transfer format for a tradition.
1068
1069 =begin testing
1070
1071 use Text::Tradition;
1072 use TryCatch;
1073
1074 my $READINGS = 311;
1075 my $PATHS = 361;
1076
1077 my $datafile = 't/data/florilegium_tei_ps.xml';
1078 my $tradition = Text::Tradition->new( 'input' => 'TEI',
1079                                       'name' => 'test0',
1080                                       'file' => $datafile,
1081                                       'linear' => 1 );
1082
1083 ok( $tradition, "Got a tradition object" );
1084 is( scalar $tradition->witnesses, 13, "Found all witnesses" );
1085 ok( $tradition->collation, "Tradition has a collation" );
1086
1087 my $c = $tradition->collation;
1088 is( scalar $c->readings, $READINGS, "Collation has all readings" );
1089 is( scalar $c->paths, $PATHS, "Collation has all paths" );
1090 is( scalar $c->relationships, 0, "Collation has all relationships" );
1091
1092 # Add a few relationships
1093 $c->add_relationship( 'w123', 'w125', { 'type' => 'collated' } );
1094 $c->add_relationship( 'w193', 'w196', { 'type' => 'collated' } );
1095 $c->add_relationship( 'w257', 'w262', { 'type' => 'transposition' } );
1096
1097 # Now write it to GraphML and parse it again.
1098
1099 my $graphml = $c->as_graphml;
1100 my $st = Text::Tradition->new( 'input' => 'Self', 'string' => $graphml );
1101 is( scalar $st->collation->readings, $READINGS, "Reparsed collation has all readings" );
1102 is( scalar $st->collation->paths, $PATHS, "Reparsed collation has all paths" );
1103 is( scalar $st->collation->relationships, 3, "Reparsed collation has new relationships" );
1104
1105 # Now add a stemma, write to GraphML, and look at the output.
1106 SKIP: {
1107         skip "Analysis module not present", 3 unless $tradition->can( 'add_stemma' );
1108         my $stemma = $tradition->add_stemma( 'dotfile' => 't/data/florilegium.dot' );
1109         is( ref( $stemma ), 'Text::Tradition::Stemma', "Parsed dotfile into stemma" );
1110         is( $tradition->stemmata, 1, "Tradition now has the stemma" );
1111         $graphml = $c->as_graphml;
1112         like( $graphml, qr/digraph/, "Digraph declaration exists in GraphML" );
1113 }
1114
1115 =end testing
1116
1117 =cut
1118
1119 ## TODO MOVE this to Tradition.pm and modularize it better
1120 sub as_graphml {
1121     my( $self, $options ) = @_;
1122         $self->calculate_ranks unless $self->_graphcalc_done;
1123
1124         my $start = $options->{'from'}
1125                 ? $self->reading( $options->{'from'} ) : $self->start;
1126         my $end = $options->{'to'}
1127                 ? $self->reading( $options->{'to'} ) : $self->end;
1128         if( $start->has_rank && $end->has_rank && $end->rank < $start->rank ) {
1129                 throw( 'Start node must be before end node' );
1130         }
1131         # The readings need to be ranked for this to work.
1132         $start = $self->start unless $start->has_rank;
1133         $end = $self->end unless $end->has_rank;
1134         my $rankoffset = 0;
1135         unless( $start eq $self->start ) {
1136                 $rankoffset = $start->rank - 1;
1137         }
1138         my %use_readings;
1139
1140     # Some namespaces
1141     my $graphml_ns = 'http://graphml.graphdrawing.org/xmlns';
1142     my $xsi_ns = 'http://www.w3.org/2001/XMLSchema-instance';
1143     my $graphml_schema = 'http://graphml.graphdrawing.org/xmlns ' .
1144         'http://graphml.graphdrawing.org/xmlns/1.0/graphml.xsd';
1145
1146     # Create the document and root node
1147     require XML::LibXML;
1148     my $graphml = XML::LibXML->createDocument( "1.0", "UTF-8" );
1149     my $root = $graphml->createElementNS( $graphml_ns, 'graphml' );
1150     $graphml->setDocumentElement( $root );
1151     $root->setNamespace( $xsi_ns, 'xsi', 0 );
1152     $root->setAttributeNS( $xsi_ns, 'schemaLocation', $graphml_schema );
1153
1154     # List of attribute types to save on our objects and their corresponding
1155     # GraphML types
1156     my %save_types = (
1157         'Str' => 'string',
1158         'Int' => 'int',
1159         'Bool' => 'boolean',
1160         'ReadingID' => 'string',
1161         'RelationshipType' => 'string',
1162         'RelationshipScope' => 'string',
1163     );
1164
1165     # Add the data keys for the graph. Include an extra key 'version' for the
1166     # GraphML output version.
1167     my %graph_data_keys;
1168     my $gdi = 0;
1169     my %graph_attributes = ( 'version' => 'string' );
1170         # Graph attributes include those of Tradition and those of Collation.
1171         my %gattr_from;
1172         # TODO Use meta introspection method from duplicate_reading to do this
1173         # instead of naming custom keys.
1174         my $tmeta = $self->tradition->meta;
1175         my $cmeta = $self->meta;
1176         map { $gattr_from{$_->name} = 'Tradition' } $tmeta->get_all_attributes;
1177         map { $gattr_from{$_->name} = 'Collation' } $cmeta->get_all_attributes;
1178         foreach my $attr ( ( $tmeta->get_all_attributes, $cmeta->get_all_attributes ) ) {
1179                 next if $attr->name =~ /^_/;
1180                 next unless $save_types{$attr->type_constraint->name};
1181                 $graph_attributes{$attr->name} = $save_types{$attr->type_constraint->name};
1182         }
1183     # Extra custom keys for complex objects that should be saved in some form.
1184     # The subroutine should return a string, or undef/empty.
1185     if( $tmeta->has_method('stemmata') ) {
1186                 $graph_attributes{'stemmata'} = sub {
1187                         my @stemstrs;
1188                         map { push( @stemstrs, $_->editable( {linesep => ''} ) ) }
1189                                 $self->tradition->stemmata;
1190                         join( "\n", @stemstrs );
1191                 };
1192         }
1193
1194         if( $tmeta->has_method('user') ) {
1195                 $graph_attributes{'user'} = sub {
1196                         $self->tradition->user ? $self->tradition->user->id : undef
1197                 };
1198         }
1199
1200     foreach my $datum ( sort keys %graph_attributes ) {
1201         $graph_data_keys{$datum} = 'dg'.$gdi++;
1202         my $key = $root->addNewChild( $graphml_ns, 'key' );
1203         my $dtype = ref( $graph_attributes{$datum} ) ? 'string'
1204                 : $graph_attributes{$datum};
1205         $key->setAttribute( 'attr.name', $datum );
1206         $key->setAttribute( 'attr.type', $dtype );
1207         $key->setAttribute( 'for', 'graph' );
1208         $key->setAttribute( 'id', $graph_data_keys{$datum} );
1209     }
1210
1211     # Add the data keys for reading nodes
1212     my %reading_attributes;
1213     my $rmeta = Text::Tradition::Collation::Reading->meta;
1214     foreach my $attr( $rmeta->get_all_attributes ) {
1215                 next if $attr->name =~ /^_/;
1216                 next unless $save_types{$attr->type_constraint->name};
1217                 $reading_attributes{$attr->name} = $save_types{$attr->type_constraint->name};
1218         }
1219         if( $self->start->does('Text::Tradition::Morphology' ) ) {
1220                 # Extra custom key for the reading morphology
1221                 $reading_attributes{'lexemes'} = 'string';
1222         }
1223
1224     my %node_data_keys;
1225     my $ndi = 0;
1226     foreach my $datum ( sort keys %reading_attributes ) {
1227         $node_data_keys{$datum} = 'dn'.$ndi++;
1228         my $key = $root->addNewChild( $graphml_ns, 'key' );
1229         $key->setAttribute( 'attr.name', $datum );
1230         $key->setAttribute( 'attr.type', $reading_attributes{$datum} );
1231         $key->setAttribute( 'for', 'node' );
1232         $key->setAttribute( 'id', $node_data_keys{$datum} );
1233     }
1234
1235     # Add the data keys for edges, that is, paths and relationships. Path
1236     # data does not come from a Moose class so is here manually.
1237     my $edi = 0;
1238     my %edge_data_keys;
1239     my %edge_attributes = (
1240         witness => 'string',                    # ID/label for a path
1241         extra => 'boolean',                             # Path key
1242         );
1243     my @path_attributes = keys %edge_attributes; # track our manual additions
1244     my $pmeta = Text::Tradition::Collation::Relationship->meta;
1245     foreach my $attr( $pmeta->get_all_attributes ) {
1246                 next if $attr->name =~ /^_/;
1247                 next unless $save_types{$attr->type_constraint->name};
1248                 $edge_attributes{$attr->name} = $save_types{$attr->type_constraint->name};
1249         }
1250     foreach my $datum ( sort keys %edge_attributes ) {
1251         $edge_data_keys{$datum} = 'de'.$edi++;
1252         my $key = $root->addNewChild( $graphml_ns, 'key' );
1253         $key->setAttribute( 'attr.name', $datum );
1254         $key->setAttribute( 'attr.type', $edge_attributes{$datum} );
1255         $key->setAttribute( 'for', 'edge' );
1256         $key->setAttribute( 'id', $edge_data_keys{$datum} );
1257     }
1258
1259     # Add the collation graph itself. First, sanitize the name to a valid XML ID.
1260     my $xmlidname = $self->tradition->name;
1261     $xmlidname =~ s/(?!$xml10_namechar_rx)./_/g;
1262     if( $xmlidname !~ /^$xml10_namestartchar_rx/ ) {
1263         $xmlidname = '_'.$xmlidname;
1264     }
1265     my $sgraph = $root->addNewChild( $graphml_ns, 'graph' );
1266     $sgraph->setAttribute( 'edgedefault', 'directed' );
1267     $sgraph->setAttribute( 'id', $xmlidname );
1268     $sgraph->setAttribute( 'parse.edgeids', 'canonical' );
1269     $sgraph->setAttribute( 'parse.edges', 0 ); # fill in later
1270     $sgraph->setAttribute( 'parse.nodeids', 'canonical' );
1271     $sgraph->setAttribute( 'parse.nodes', 0 ); # fill in later
1272     $sgraph->setAttribute( 'parse.order', 'nodesfirst' );
1273
1274     # Tradition/collation attribute data
1275     foreach my $datum ( keys %graph_attributes ) {
1276         my $value;
1277         if( $datum eq 'version' ) {
1278                 $value = '3.2';
1279         } elsif( ref( $graph_attributes{$datum} ) ) {
1280                 my $sub = $graph_attributes{$datum};
1281                 $value = &$sub();
1282         } elsif( $gattr_from{$datum} eq 'Tradition' ) {
1283                 $value = $self->tradition->$datum;
1284         } else {
1285                 $value = $self->$datum;
1286         }
1287                 _add_graphml_data( $sgraph, $graph_data_keys{$datum}, $value );
1288         }
1289
1290     my $node_ctr = 0;
1291     my %node_hash;
1292     # Add our readings to the graph
1293     foreach my $n ( sort { $a->id cmp $b->id } $self->readings ) {
1294         next if $n->has_rank && $n ne $self->start && $n ne $self->end &&
1295                 ( $n->rank < $start->rank || $n->rank > $end->rank );
1296         $use_readings{$n->id} = 1;
1297         # Add to the main graph
1298         my $node_el = $sgraph->addNewChild( $graphml_ns, 'node' );
1299         my $node_xmlid = 'n' . $node_ctr++;
1300         $node_hash{ $n->id } = $node_xmlid;
1301         $node_el->setAttribute( 'id', $node_xmlid );
1302         foreach my $d ( keys %reading_attributes ) {
1303                 my $nval = $n->$d;
1304                 # Custom serialization
1305                 if( $d eq 'lexemes' ) {
1306                                 # If nval is a true value, we have lexemes so we need to
1307                                 # serialize them. Otherwise set nval to undef so that the
1308                                 # key is excluded from this reading.
1309                         $nval = $nval ? $n->_serialize_lexemes : undef;
1310                 } elsif( $d eq 'normal_form' && $n->normal_form eq $n->text ) {
1311                         $nval = undef;
1312                 }
1313                 if( $rankoffset && $d eq 'rank' && $n ne $self->start ) {
1314                         # Adjust the ranks within the subgraph.
1315                         $nval = $n eq $self->end ? $end->rank - $rankoffset + 1
1316                                 : $nval - $rankoffset;
1317                 }
1318                 _add_graphml_data( $node_el, $node_data_keys{$d}, $nval )
1319                         if defined $nval;
1320         }
1321     }
1322
1323     # Add the path edges to the sequence graph
1324     my $edge_ctr = 0;
1325     foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->sequence->edges() ) {
1326         # We add an edge in the graphml for every witness in $e.
1327         next unless( $use_readings{$e->[0]} || $use_readings{$e->[1]} );
1328         my @edge_wits = sort $self->path_witnesses( $e );
1329         $e->[0] = $self->start->id unless $use_readings{$e->[0]};
1330         $e->[1] = $self->end->id unless $use_readings{$e->[1]};
1331         # Skip any path from start to end; that witness is not in the subgraph.
1332         next if ( $e->[0] eq $self->start->id && $e->[1] eq $self->end->id );
1333         foreach my $wit ( @edge_wits ) {
1334                         my( $id, $from, $to ) = ( 'e'.$edge_ctr++,
1335                                                                                 $node_hash{ $e->[0] },
1336                                                                                 $node_hash{ $e->[1] } );
1337                         my $edge_el = $sgraph->addNewChild( $graphml_ns, 'edge' );
1338                         $edge_el->setAttribute( 'source', $from );
1339                         $edge_el->setAttribute( 'target', $to );
1340                         $edge_el->setAttribute( 'id', $id );
1341
1342                         # It's a witness path, so add the witness
1343                         my $base = $wit;
1344                         my $key = $edge_data_keys{'witness'};
1345                         # Is this an ante-corr witness?
1346                         my $aclabel = $self->ac_label;
1347                         if( $wit =~ /^(.*)\Q$aclabel\E$/ ) {
1348                                 # Keep the base witness
1349                                 $base = $1;
1350                                 # ...and record that this is an 'extra' reading path
1351                                 _add_graphml_data( $edge_el, $edge_data_keys{'extra'}, $aclabel );
1352                         }
1353                         _add_graphml_data( $edge_el, $edge_data_keys{'witness'}, $base );
1354                 }
1355         }
1356
1357         # Report the actual number of nodes and edges that went in
1358         $sgraph->setAttribute( 'parse.edges', $edge_ctr );
1359         $sgraph->setAttribute( 'parse.nodes', $node_ctr );
1360
1361         # Add the relationship graph to the XML
1362         map { delete $edge_data_keys{$_} } @path_attributes;
1363         $self->relations->_as_graphml( $graphml_ns, $root, \%node_hash,
1364                 $node_data_keys{'id'}, \%edge_data_keys );
1365
1366     # Save and return the thing
1367     my $result = decode_utf8( $graphml->toString(1) );
1368     return $result;
1369 }
1370
1371 sub _add_graphml_data {
1372     my( $el, $key, $value ) = @_;
1373     return unless defined $value;
1374     my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
1375     $data_el->setAttribute( 'key', $key );
1376     $data_el->appendText( $value );
1377 }
1378
1379 =head2 as_csv
1380
1381 Returns a CSV alignment table representation of the collation graph, one
1382 row per witness (or witness uncorrected.)
1383
1384 =cut
1385
1386 sub as_csv {
1387     my( $self ) = @_;
1388     my $table = $self->alignment_table;
1389     my $csv = Text::CSV->new( { binary => 1, quote_null => 0 } );
1390     my @result;
1391     # Make the header row
1392     $csv->combine( map { $_->{'witness'} } @{$table->{'alignment'}} );
1393         push( @result, decode_utf8( $csv->string ) );
1394     # Make the rest of the rows
1395     foreach my $idx ( 0 .. $table->{'length'} - 1 ) {
1396         my @rowobjs = map { $_->{'tokens'}->[$idx] } @{$table->{'alignment'}};
1397         my @row = map { $_ ? $_->{'t'}->text : $_ } @rowobjs;
1398         $csv->combine( @row );
1399         push( @result, decode_utf8( $csv->string ) );
1400     }
1401     return join( "\n", @result );
1402 }
1403
1404 =head2 alignment_table
1405
1406 Return a reference to an alignment table, in a slightly enhanced CollateX
1407 format which looks like this:
1408
1409  $table = { alignment => [ { witness => "SIGIL",
1410                              tokens => [ { t => "TEXT" }, ... ] },
1411                            { witness => "SIG2",
1412                              tokens => [ { t => "TEXT" }, ... ] },
1413                            ... ],
1414             length => TEXTLEN };
1415
1416 =cut
1417
1418 sub alignment_table {
1419     my( $self ) = @_;
1420     return $self->cached_table if $self->has_cached_table;
1421
1422     # Make sure we can do this
1423         throw( "Need a linear graph in order to make an alignment table" )
1424                 unless $self->linear;
1425     $self->calculate_ranks()
1426         unless $self->_graphcalc_done && $self->end->has_rank;
1427
1428     my $table = { 'alignment' => [], 'length' => $self->end->rank - 1 };
1429     my @all_pos = ( 1 .. $self->end->rank - 1 );
1430     foreach my $wit ( sort { $a->sigil cmp $b->sigil } $self->tradition->witnesses ) {
1431         # say STDERR "Making witness row(s) for " . $wit->sigil;
1432         my @wit_path = $self->reading_sequence( $self->start, $self->end, $wit->sigil );
1433         my @row = _make_witness_row( \@wit_path, \@all_pos );
1434         my $witobj = { 'witness' => $wit->sigil, 'tokens' => \@row };
1435         $witobj->{'identifier'} = $wit->identifier if $wit->identifier;
1436         push( @{$table->{'alignment'}}, $witobj );
1437         if( $wit->is_layered ) {
1438                 my @wit_ac_path = $self->reading_sequence( $self->start, $self->end,
1439                         $wit->sigil.$self->ac_label );
1440             my @ac_row = _make_witness_row( \@wit_ac_path, \@all_pos );
1441             my $witacobj = { 'witness' => $wit->sigil.$self->ac_label,
1442                 'tokens' => \@ac_row };
1443             $witacobj->{'identifier'} = $wit->identifier if $wit->identifier;
1444                         push( @{$table->{'alignment'}}, $witacobj );
1445         }
1446     }
1447     $self->cached_table( $table );
1448     return $table;
1449 }
1450
1451 sub _make_witness_row {
1452     my( $path, $positions ) = @_;
1453     my %char_hash;
1454     map { $char_hash{$_} = undef } @$positions;
1455     my $debug = 0;
1456     foreach my $rdg ( @$path ) {
1457         say STDERR "rank " . $rdg->rank if $debug;
1458         # say STDERR "No rank for " . $rdg->id unless defined $rdg->rank;
1459         $char_hash{$rdg->rank} = { 't' => $rdg };
1460     }
1461     my @row = map { $char_hash{$_} } @$positions;
1462     # Fill in lacuna markers for undef spots in the row
1463     my $last_el = shift @row;
1464     my @filled_row = ( $last_el );
1465     foreach my $el ( @row ) {
1466         # If we are using node reference, make the lacuna node appear many times
1467         # in the table.  If not, use the lacuna tag.
1468         if( $last_el && $last_el->{'t'}->is_lacuna && !defined $el ) {
1469             $el = $last_el;
1470         }
1471         push( @filled_row, $el );
1472         $last_el = $el;
1473     }
1474     return @filled_row;
1475 }
1476
1477
1478 =head1 NAVIGATION METHODS
1479
1480 =head2 reading_sequence( $first, $last, $sigil, $backup )
1481
1482 Returns the ordered list of readings, starting with $first and ending
1483 with $last, for the witness given in $sigil. If a $backup sigil is
1484 specified (e.g. when walking a layered witness), it will be used wherever
1485 no $sigil path exists.  If there is a base text reading, that will be
1486 used wherever no path exists for $sigil or $backup.
1487
1488 =cut
1489
1490 # TODO Think about returning some lazy-eval iterator.
1491 # TODO Get rid of backup; we should know from what witness is whether we need it.
1492
1493 sub reading_sequence {
1494     my( $self, $start, $end, $witness ) = @_;
1495
1496     $witness = $self->baselabel unless $witness;
1497     my @readings = ( $start );
1498     my %seen;
1499     my $n = $start;
1500     while( $n && $n->id ne $end->id ) {
1501         if( exists( $seen{$n->id} ) ) {
1502             throw( "Detected loop for $witness at " . $n->id );
1503         }
1504         $seen{$n->id} = 1;
1505
1506         my $next = $self->next_reading( $n, $witness );
1507         unless( $next ) {
1508             throw( "Did not find any path for $witness from reading " . $n->id );
1509         }
1510         push( @readings, $next );
1511         $n = $next;
1512     }
1513     # Check that the last reading is our end reading.
1514     my $last = $readings[$#readings];
1515     throw( "Last reading found from " . $start->text .
1516         " for witness $witness is not the end!" ) # TODO do we get this far?
1517         unless $last->id eq $end->id;
1518
1519     return @readings;
1520 }
1521
1522 =head2 next_reading( $reading, $sigil );
1523
1524 Returns the reading that follows the given reading along the given witness
1525 path.
1526
1527 =cut
1528
1529 sub next_reading {
1530     # Return the successor via the corresponding path.
1531     my $self = shift;
1532     my $answer = $self->_find_linked_reading( 'next', @_ );
1533         return undef unless $answer;
1534     return $self->reading( $answer );
1535 }
1536
1537 =head2 prior_reading( $reading, $sigil )
1538
1539 Returns the reading that precedes the given reading along the given witness
1540 path.
1541
1542 =cut
1543
1544 sub prior_reading {
1545     # Return the predecessor via the corresponding path.
1546     my $self = shift;
1547     my $answer = $self->_find_linked_reading( 'prior', @_ );
1548     return $self->reading( $answer );
1549 }
1550
1551 sub _find_linked_reading {
1552     my( $self, $direction, $node, $path ) = @_;
1553
1554     # Get a backup if we are dealing with a layered witness
1555     my $alt_path;
1556     my $aclabel = $self->ac_label;
1557     if( $path && $path =~ /^(.*)\Q$aclabel\E$/ ) {
1558         $alt_path = $1;
1559     }
1560
1561     my @linked_paths = $direction eq 'next'
1562         ? $self->sequence->edges_from( $node )
1563         : $self->sequence->edges_to( $node );
1564     return undef unless scalar( @linked_paths );
1565
1566     # We have to find the linked path that contains all of the
1567     # witnesses supplied in $path.
1568     my( @path_wits, @alt_path_wits );
1569     @path_wits = sort( $self->_witnesses_of_label( $path ) ) if $path;
1570     @alt_path_wits = sort( $self->_witnesses_of_label( $alt_path ) ) if $alt_path;
1571     my $base_le;
1572     my $alt_le;
1573     foreach my $le ( @linked_paths ) {
1574         if( $self->sequence->has_edge_attribute( @$le, $self->baselabel ) ) {
1575             $base_le = $le;
1576         }
1577                 my @le_wits = sort $self->path_witnesses( $le );
1578                 if( _is_within( \@path_wits, \@le_wits ) ) {
1579                         # This is the right path.
1580                         return $direction eq 'next' ? $le->[1] : $le->[0];
1581                 } elsif( _is_within( \@alt_path_wits, \@le_wits ) ) {
1582                         $alt_le = $le;
1583                 }
1584     }
1585     # Got this far? Return the alternate path if it exists.
1586     return $direction eq 'next' ? $alt_le->[1] : $alt_le->[0]
1587         if $alt_le;
1588
1589     # Got this far? Return the base path if it exists.
1590     return $direction eq 'next' ? $base_le->[1] : $base_le->[0]
1591         if $base_le;
1592
1593     # Got this far? We have no appropriate path.
1594     warn "Could not find $direction node from " . $node->id
1595         . " along path $path";
1596     return undef;
1597 }
1598
1599 # Some set logic.
1600 sub _is_within {
1601     my( $set1, $set2 ) = @_;
1602     my $ret = @$set1; # will be 0, i.e. false, if set1 is empty
1603     foreach my $el ( @$set1 ) {
1604         $ret = 0 unless grep { /^\Q$el\E$/ } @$set2;
1605     }
1606     return $ret;
1607 }
1608
1609 # Return the string that joins together a list of witnesses for
1610 # display on a single path.
1611 sub _witnesses_of_label {
1612     my( $self, $label ) = @_;
1613     my $regex = $self->wit_list_separator;
1614     my @answer = split( /\Q$regex\E/, $label );
1615     return @answer;
1616 }
1617
1618 =head2 common_readings
1619
1620 Returns the list of common readings in the graph (i.e. those readings that are
1621 shared by all non-lacunose witnesses.)
1622
1623 =cut
1624
1625 sub common_readings {
1626         my $self = shift;
1627         my @common = grep { $_->is_common } $self->readings;
1628         return @common;
1629 }
1630
1631 =head2 path_text( $sigil, [, $start, $end ] )
1632
1633 Returns the text of a witness (plus its backup, if we are using a layer)
1634 as stored in the collation.  The text is returned as a string, where the
1635 individual readings are joined with spaces and the meta-readings (e.g.
1636 lacunae) are omitted.  Optional specification of $start and $end allows
1637 the generation of a subset of the witness text.
1638
1639 =cut
1640
1641 sub path_text {
1642         my( $self, $wit, $start, $end ) = @_;
1643         $start = $self->start unless $start;
1644         $end = $self->end unless $end;
1645         my @path = grep { !$_->is_meta } $self->reading_sequence( $start, $end, $wit );
1646         my $pathtext = '';
1647         my $last;
1648         foreach my $r ( @path ) {
1649                 unless ( $r->join_prior || !$last || $last->join_next ) {
1650                         $pathtext .= ' ';
1651                 }
1652                 $pathtext .= $r->text;
1653                 $last = $r;
1654         }
1655         return $pathtext;
1656 }
1657
1658 =head1 INITIALIZATION METHODS
1659
1660 These are mostly for use by parsers.
1661
1662 =head2 make_witness_path( $witness )
1663
1664 Link the array of readings contained in $witness->path (and in
1665 $witness->uncorrected_path if it exists) into collation paths.
1666 Clear out the arrays when finished.
1667
1668 =head2 make_witness_paths
1669
1670 Call make_witness_path for all witnesses in the tradition.
1671
1672 =cut
1673
1674 # For use when a collation is constructed from a base text and an apparatus.
1675 # We have the sequences of readings and just need to add path edges.
1676 # When we are done, clear out the witness path attributes, as they are no
1677 # longer needed.
1678 # TODO Find a way to replace the witness path attributes with encapsulated functions?
1679
1680 sub make_witness_paths {
1681     my( $self ) = @_;
1682     foreach my $wit ( $self->tradition->witnesses ) {
1683         # say STDERR "Making path for " . $wit->sigil;
1684         $self->make_witness_path( $wit );
1685     }
1686 }
1687
1688 sub make_witness_path {
1689     my( $self, $wit ) = @_;
1690     my @chain = @{$wit->path};
1691     my $sig = $wit->sigil;
1692     # Add start and end if necessary
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         $self->add_path( $chain[$idx], $chain[$idx+1], $sig );
1697     }
1698     if( $wit->is_layered ) {
1699         @chain = @{$wit->uncorrected_path};
1700                 unshift( @chain, $self->start ) unless $chain[0] eq $self->start;
1701                 push( @chain, $self->end ) unless $chain[-1] eq $self->end;
1702         foreach my $idx( 0 .. $#chain-1 ) {
1703             my $source = $chain[$idx];
1704             my $target = $chain[$idx+1];
1705             $self->add_path( $source, $target, $sig.$self->ac_label )
1706                 unless $self->has_path( $source, $target, $sig );
1707         }
1708     }
1709     $wit->clear_path;
1710     $wit->clear_uncorrected_path;
1711 }
1712
1713 =head2 calculate_ranks
1714
1715 Calculate the reading ranks (that is, their aligned positions relative
1716 to each other) for the graph.  This can only be called on linear collations.
1717
1718 =begin testing
1719
1720 use Text::Tradition;
1721
1722 my $cxfile = 't/data/Collatex-16.xml';
1723 my $t = Text::Tradition->new(
1724     'name'  => 'inline',
1725     'input' => 'CollateX',
1726     'file'  => $cxfile,
1727     );
1728 my $c = $t->collation;
1729
1730 # Make an svg
1731 my $table = $c->alignment_table;
1732 ok( $c->has_cached_table, "Alignment table was cached" );
1733 is( $c->alignment_table, $table, "Cached table returned upon second call" );
1734 $c->calculate_ranks;
1735 is( $c->alignment_table, $table, "Cached table retained with no rank change" );
1736 $c->add_relationship( 'n13', 'n23', { type => 'repetition' } );
1737 is( $c->alignment_table, $table, "Alignment table unchanged after non-colo relationship add" );
1738 $c->add_relationship( 'n24', 'n23', { type => 'spelling' } );
1739 isnt( $c->alignment_table, $table, "Alignment table changed after colo relationship add" );
1740
1741 =end testing
1742
1743 =cut
1744
1745 sub calculate_ranks {
1746     my $self = shift;
1747     # Save the existing ranks, in case we need to invalidate the cached SVG.
1748     my %existing_ranks;
1749     map { $existing_ranks{$_} = $_->rank } $self->readings;
1750
1751     # Do the rankings based on the relationship equivalence graph, starting
1752     # with the start node.
1753     my ( $node_ranks, $rank_nodes ) = $self->relations->equivalence_ranks();
1754
1755     # Transfer our rankings from the topological graph to the real one.
1756     foreach my $r ( $self->readings ) {
1757         if( defined $node_ranks->{$self->equivalence( $r->id )} ) {
1758             $r->rank( $node_ranks->{$self->equivalence( $r->id )} );
1759         } else {
1760                 # Die. Find the last rank we calculated.
1761                 my @all_defined = sort { ( $node_ranks->{$self->equivalence( $a->id )}||-1 )
1762                                  <=> ( $node_ranks->{$self->equivalence( $b->id )}||-1 ) }
1763                         $self->readings;
1764                 my $last = pop @all_defined;
1765             throw( "Ranks not calculated after $last - do you have a cycle in the graph?" );
1766         }
1767     }
1768     # Do we need to invalidate the cached data?
1769     if( $self->has_cached_table ) {
1770         foreach my $r ( $self->readings ) {
1771                 next if defined( $existing_ranks{$r} )
1772                         && $existing_ranks{$r} == $r->rank;
1773                 # Something has changed, so clear the cache
1774                 $self->_clear_cache;
1775                         # ...and recalculate the common readings.
1776                         $self->calculate_common_readings();
1777                 last;
1778         }
1779     }
1780         # The graph calculation information is now up to date.
1781         $self->_graphcalc_done(1);
1782 }
1783
1784 sub _clear_cache {
1785         my $self = shift;
1786         $self->wipe_table if $self->has_cached_table;
1787 }
1788
1789
1790 =head2 flatten_ranks
1791
1792 A convenience method for parsing collation data.  Searches the graph for readings
1793 with the same text at the same rank, and merges any that are found.
1794
1795 =cut
1796
1797 sub flatten_ranks {
1798     my ( $self, %args ) = shift;
1799     my %unique_rank_rdg;
1800     my $changed;
1801     foreach my $p ( $self->identical_readings( %args ) ) {
1802                 # say STDERR "Combining readings at same rank: @$p";
1803                 $changed = 1;
1804                 $self->merge_readings( @$p );
1805                 # TODO see if this now makes a common point.
1806     }
1807     # If we merged readings, the ranks are still fine but the alignment
1808     # table is wrong. Wipe it.
1809     $self->wipe_table() if $changed;
1810 }
1811
1812 =head2 identical_readings
1813 =head2 identical_readings( start => $startnode, end => $endnode )
1814 =head2 identical_readings( startrank => $startrank, endrank => $endrank )
1815
1816 Goes through the graph identifying all pairs of readings that appear to be
1817 identical, and therefore able to be merged into a single reading. Returns the
1818 relevant identical pairs. Can be restricted to run over only a part of the
1819 graph, specified either by node or by rank.
1820
1821 =cut
1822
1823 sub identical_readings {
1824         my ( $self, %args ) = @_;
1825     # Find where we should start and end.
1826     my $startrank = $args{startrank} || 0;
1827     if( $args{start} ) {
1828         throw( "Starting reading has no rank" ) unless $self->reading( $args{start} )
1829                 && $self->reading( $args{start} )->has_rank;
1830         $startrank = $self->reading( $args{start} )->rank;
1831     }
1832     my $endrank = $args{endrank} || $self->end->rank;
1833     if( $args{end} ) {
1834         throw( "Ending reading has no rank" ) unless $self->reading( $args{end} )
1835                 && $self->reading( $args{end} )->has_rank;
1836         $endrank = $self->reading( $args{end} )->rank;
1837     }
1838
1839     # Make sure the ranks are correct.
1840     unless( $self->_graphcalc_done ) {
1841         $self->calculate_ranks;
1842     }
1843     # Go through the readings looking for duplicates.
1844     my %unique_rank_rdg;
1845     my @pairs;
1846     foreach my $rdg ( $self->readings ) {
1847         next unless $rdg->has_rank;
1848         my $rk = $rdg->rank;
1849         next if $rk > $endrank || $rk < $startrank;
1850         my $key = $rk . "||" . $rdg->text;
1851         if( exists $unique_rank_rdg{$key} ) {
1852                 # Make sure they don't have different grammatical forms
1853                         my $ur = $unique_rank_rdg{$key};
1854                 if( $rdg->is_identical( $ur ) ) {
1855                                 push( @pairs, [ $ur, $rdg ] );
1856                         }
1857         } else {
1858             $unique_rank_rdg{$key} = $rdg;
1859         }
1860     }
1861
1862     return @pairs;
1863 }
1864
1865
1866 =head2 calculate_common_readings
1867
1868 Goes through the graph identifying the readings that appear in every witness
1869 (apart from those with lacunae at that spot.) Marks them as common and returns
1870 the list.
1871
1872 =begin testing
1873
1874 use Text::Tradition;
1875
1876 my $cxfile = 't/data/Collatex-16.xml';
1877 my $t = Text::Tradition->new(
1878     'name'  => 'inline',
1879     'input' => 'CollateX',
1880     'file'  => $cxfile,
1881     );
1882 my $c = $t->collation;
1883
1884 my @common = $c->calculate_common_readings();
1885 is( scalar @common, 8, "Found correct number of common readings" );
1886 my @marked = sort $c->common_readings();
1887 is( scalar @common, 8, "All common readings got marked as such" );
1888 my @expected = qw/ n1 n11 n16 n19 n20 n5 n6 n7 /;
1889 is_deeply( \@marked, \@expected, "Found correct list of common readings" );
1890
1891 =end testing
1892
1893 =cut
1894
1895 sub calculate_common_readings {
1896         my $self = shift;
1897         my @common;
1898         map { $_->is_common( 0 ) } $self->readings;
1899         # Implicitly calls calculate_ranks
1900         my $table = $self->alignment_table;
1901         foreach my $idx ( 0 .. $table->{'length'} - 1 ) {
1902                 my @row = map { $_->{'tokens'}->[$idx]
1903                                                         ? $_->{'tokens'}->[$idx]->{'t'} : '' }
1904                                         @{$table->{'alignment'}};
1905                 my %hash;
1906                 foreach my $r ( @row ) {
1907                         if( $r ) {
1908                                 $hash{$r->id} = $r unless $r->is_meta;
1909                         } else {
1910                                 $hash{'UNDEF'} = $r;
1911                         }
1912                 }
1913                 if( keys %hash == 1 && !exists $hash{'UNDEF'} ) {
1914                         my( $r ) = values %hash;
1915                         $r->is_common( 1 );
1916                         push( @common, $r );
1917                 }
1918         }
1919         return @common;
1920 }
1921
1922 =head2 text_from_paths
1923
1924 Calculate the text array for all witnesses from the path, for later consistency
1925 checking.  Only to be used if there is no non-graph-based way to know the
1926 original texts.
1927
1928 =cut
1929
1930 sub text_from_paths {
1931         my $self = shift;
1932     foreach my $wit ( $self->tradition->witnesses ) {
1933         my @readings = $self->reading_sequence( $self->start, $self->end, $wit->sigil );
1934         my @text;
1935         foreach my $r ( @readings ) {
1936                 next if $r->is_meta;
1937                 push( @text, $r->text );
1938         }
1939         $wit->text( \@text );
1940         if( $wit->is_layered ) {
1941                         my @ucrdgs = $self->reading_sequence( $self->start, $self->end,
1942                                                                                                   $wit->sigil.$self->ac_label );
1943                         my @uctext;
1944                         foreach my $r ( @ucrdgs ) {
1945                                 next if $r->is_meta;
1946                                 push( @uctext, $r->text );
1947                         }
1948                         $wit->layertext( \@uctext );
1949         }
1950     }
1951 }
1952
1953 =head1 UTILITY FUNCTIONS
1954
1955 =head2 common_predecessor( $reading_a, $reading_b )
1956
1957 Find the last reading that occurs in sequence before both the given readings.
1958 At the very least this should be $self->start.
1959
1960 =head2 common_successor( $reading_a, $reading_b )
1961
1962 Find the first reading that occurs in sequence after both the given readings.
1963 At the very least this should be $self->end.
1964
1965 =begin testing
1966
1967 use Text::Tradition;
1968
1969 my $cxfile = 't/data/Collatex-16.xml';
1970 my $t = Text::Tradition->new(
1971     'name'  => 'inline',
1972     'input' => 'CollateX',
1973     'file'  => $cxfile,
1974     );
1975 my $c = $t->collation;
1976
1977 is( $c->common_predecessor( 'n24', 'n23' )->id,
1978     'n20', "Found correct common predecessor" );
1979 is( $c->common_successor( 'n24', 'n23' )->id,
1980     '__END__', "Found correct common successor" );
1981
1982 is( $c->common_predecessor( 'n19', 'n17' )->id,
1983     'n16', "Found correct common predecessor for readings on same path" );
1984 is( $c->common_successor( 'n21', 'n10' )->id,
1985     '__END__', "Found correct common successor for readings on same path" );
1986
1987 =end testing
1988
1989 =cut
1990
1991 ## Return the closest reading that is a predecessor of both the given readings.
1992 sub common_predecessor {
1993         my $self = shift;
1994         my( $r1, $r2 ) = $self->_objectify_args( @_ );
1995         return $self->_common_in_path( $r1, $r2, 'predecessors' );
1996 }
1997
1998 sub common_successor {
1999         my $self = shift;
2000         my( $r1, $r2 ) = $self->_objectify_args( @_ );
2001         return $self->_common_in_path( $r1, $r2, 'successors' );
2002 }
2003
2004
2005 # TODO think about how to do this without ranks...
2006 sub _common_in_path {
2007         my( $self, $r1, $r2, $dir ) = @_;
2008         my $iter = $self->end->rank;
2009         my @candidates;
2010         my @last_r1 = ( $r1 );
2011         my @last_r2 = ( $r2 );
2012         # my %all_seen = ( $r1 => 'r1', $r2 => 'r2' );
2013         my %all_seen;
2014         # say STDERR "Finding common $dir for $r1, $r2";
2015         while( !@candidates ) {
2016                 last unless $iter--;  # Avoid looping infinitely
2017                 # Iterate separately down the graph from r1 and r2
2018                 my( @new_lc1, @new_lc2 );
2019                 foreach my $lc ( @last_r1 ) {
2020                         foreach my $p ( $lc->$dir ) {
2021                                 if( $all_seen{$p->id} && $all_seen{$p->id} ne 'r1' ) {
2022                                         # say STDERR "Path candidate $p from $lc";
2023                                         push( @candidates, $p );
2024                                 } elsif( !$all_seen{$p->id} ) {
2025                                         $all_seen{$p->id} = 'r1';
2026                                         push( @new_lc1, $p );
2027                                 }
2028                         }
2029                 }
2030                 foreach my $lc ( @last_r2 ) {
2031                         foreach my $p ( $lc->$dir ) {
2032                                 if( $all_seen{$p->id} && $all_seen{$p->id} ne 'r2' ) {
2033                                         # say STDERR "Path candidate $p from $lc";
2034                                         push( @candidates, $p );
2035                                 } elsif( !$all_seen{$p->id} ) {
2036                                         $all_seen{$p->id} = 'r2';
2037                                         push( @new_lc2, $p );
2038                                 }
2039                         }
2040                 }
2041                 @last_r1 = @new_lc1;
2042                 @last_r2 = @new_lc2;
2043         }
2044         my @answer = sort { $a->rank <=> $b->rank } @candidates;
2045         return $dir eq 'predecessors' ? pop( @answer ) : shift ( @answer );
2046 }
2047
2048 sub throw {
2049         Text::Tradition::Error->throw(
2050                 'ident' => 'Collation error',
2051                 'message' => $_[0],
2052                 );
2053 }
2054
2055 no Moose;
2056 __PACKAGE__->meta->make_immutable;
2057
2058 =head1 BUGS/TODO
2059
2060 =over
2061
2062 =item * Rework XML serialization in a more modular way
2063
2064 =back
2065
2066 =head1 LICENSE
2067
2068 This package is free software and is provided "as is" without express
2069 or implied warranty.  You can redistribute it and/or modify it under
2070 the same terms as Perl itself.
2071
2072 =head1 AUTHOR
2073
2074 Tara L Andrews E<lt>aurum@cpan.orgE<gt>