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