base/lib/Text/Tradition/Collation.pm

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