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