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