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( keys %{$self->sequence->get_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( $use_refs, $include_witnesses )
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 If $use_refs is set to 1, the reading object is returned in the table
1258 instead of READINGTEXT; if not, the text of the reading is returned.
1259
1260 If $include_witnesses is set to a hashref, only the witnesses whose sigil
1261 keys have a true hash value will be included.
1262
1263 =cut
1264
1265 sub alignment_table {
1266     my( $self ) = @_;
1267     $self->calculate_ranks() unless $self->_graphcalc_done;
1268     return $self->cached_table if $self->has_cached_table;
1269
1270     # Make sure we can do this
1271         throw( "Need a linear graph in order to make an alignment table" )
1272                 unless $self->linear;
1273         $self->calculate_ranks unless $self->end->has_rank;
1274
1275     my $table = { 'alignment' => [], 'length' => $self->end->rank - 1 };
1276     my @all_pos = ( 1 .. $self->end->rank - 1 );
1277     foreach my $wit ( sort { $a->sigil cmp $b->sigil } $self->tradition->witnesses ) {
1278         # say STDERR "Making witness row(s) for " . $wit->sigil;
1279         my @wit_path = $self->reading_sequence( $self->start, $self->end, $wit->sigil );
1280         my @row = _make_witness_row( \@wit_path, \@all_pos );
1281         my $witobj = { 'witness' => $wit->sigil, 'tokens' => \@row };
1282         $witobj->{'identifier'} = $wit->identifier if $wit->identifier;
1283         push( @{$table->{'alignment'}}, $witobj );
1284         if( $wit->is_layered ) {
1285                 my @wit_ac_path = $self->reading_sequence( $self->start, $self->end,
1286                         $wit->sigil.$self->ac_label );
1287             my @ac_row = _make_witness_row( \@wit_ac_path, \@all_pos );
1288             my $witacobj = { 'witness' => $wit->sigil.$self->ac_label,
1289                 'tokens' => \@ac_row };
1290             $witacobj->{'identifier'} = $wit->identifier if $wit->identifier;
1291                         push( @{$table->{'alignment'}}, $witacobj );
1292         }
1293     }
1294     $self->cached_table( $table );
1295     return $table;
1296 }
1297
1298 sub _make_witness_row {
1299     my( $path, $positions ) = @_;
1300     my %char_hash;
1301     map { $char_hash{$_} = undef } @$positions;
1302     my $debug = 0;
1303     foreach my $rdg ( @$path ) {
1304         say STDERR "rank " . $rdg->rank if $debug;
1305         # say STDERR "No rank for " . $rdg->id unless defined $rdg->rank;
1306         $char_hash{$rdg->rank} = { 't' => $rdg };
1307     }
1308     my @row = map { $char_hash{$_} } @$positions;
1309     # Fill in lacuna markers for undef spots in the row
1310     my $last_el = shift @row;
1311     my @filled_row = ( $last_el );
1312     foreach my $el ( @row ) {
1313         # If we are using node reference, make the lacuna node appear many times
1314         # in the table.  If not, use the lacuna tag.
1315         if( $last_el && $last_el->{'t'}->is_lacuna && !defined $el ) {
1316             $el = $last_el;
1317         }
1318         push( @filled_row, $el );
1319         $last_el = $el;
1320     }
1321     return @filled_row;
1322 }
1323
1324 =head1 NAVIGATION METHODS
1325
1326 =head2 reading_sequence( $first, $last, $sigil, $backup )
1327
1328 Returns the ordered list of readings, starting with $first and ending
1329 with $last, for the witness given in $sigil. If a $backup sigil is
1330 specified (e.g. when walking a layered witness), it will be used wherever
1331 no $sigil path exists.  If there is a base text reading, that will be
1332 used wherever no path exists for $sigil or $backup.
1333
1334 =cut
1335
1336 # TODO Think about returning some lazy-eval iterator.
1337 # TODO Get rid of backup; we should know from what witness is whether we need it.
1338
1339 sub reading_sequence {
1340     my( $self, $start, $end, $witness ) = @_;
1341
1342     $witness = $self->baselabel unless $witness;
1343     my @readings = ( $start );
1344     my %seen;
1345     my $n = $start;
1346     while( $n && $n->id ne $end->id ) {
1347         if( exists( $seen{$n->id} ) ) {
1348             throw( "Detected loop for $witness at " . $n->id );
1349         }
1350         $seen{$n->id} = 1;
1351
1352         my $next = $self->next_reading( $n, $witness );
1353         unless( $next ) {
1354             throw( "Did not find any path for $witness from reading " . $n->id );
1355         }
1356         push( @readings, $next );
1357         $n = $next;
1358     }
1359     # Check that the last reading is our end reading.
1360     my $last = $readings[$#readings];
1361     throw( "Last reading found from " . $start->text .
1362         " for witness $witness is not the end!" ) # TODO do we get this far?
1363         unless $last->id eq $end->id;
1364
1365     return @readings;
1366 }
1367
1368 =head2 next_reading( $reading, $sigil );
1369
1370 Returns the reading that follows the given reading along the given witness
1371 path.
1372
1373 =cut
1374
1375 sub next_reading {
1376     # Return the successor via the corresponding path.
1377     my $self = shift;
1378     my $answer = $self->_find_linked_reading( 'next', @_ );
1379         return undef unless $answer;
1380     return $self->reading( $answer );
1381 }
1382
1383 =head2 prior_reading( $reading, $sigil )
1384
1385 Returns the reading that precedes the given reading along the given witness
1386 path.
1387
1388 =cut
1389
1390 sub prior_reading {
1391     # Return the predecessor via the corresponding path.
1392     my $self = shift;
1393     my $answer = $self->_find_linked_reading( 'prior', @_ );
1394     return $self->reading( $answer );
1395 }
1396
1397 sub _find_linked_reading {
1398     my( $self, $direction, $node, $path ) = @_;
1399
1400     # Get a backup if we are dealing with a layered witness
1401     my $alt_path;
1402     my $aclabel = $self->ac_label;
1403     if( $path && $path =~ /^(.*)\Q$aclabel\E$/ ) {
1404         $alt_path = $1;
1405     }
1406
1407     my @linked_paths = $direction eq 'next'
1408         ? $self->sequence->edges_from( $node )
1409         : $self->sequence->edges_to( $node );
1410     return undef unless scalar( @linked_paths );
1411
1412     # We have to find the linked path that contains all of the
1413     # witnesses supplied in $path.
1414     my( @path_wits, @alt_path_wits );
1415     @path_wits = sort( $self->_witnesses_of_label( $path ) ) if $path;
1416     @alt_path_wits = sort( $self->_witnesses_of_label( $alt_path ) ) if $alt_path;
1417     my $base_le;
1418     my $alt_le;
1419     foreach my $le ( @linked_paths ) {
1420         if( $self->sequence->has_edge_attribute( @$le, $self->baselabel ) ) {
1421             $base_le = $le;
1422         }
1423                 my @le_wits = sort $self->path_witnesses( $le );
1424                 if( _is_within( \@path_wits, \@le_wits ) ) {
1425                         # This is the right path.
1426                         return $direction eq 'next' ? $le->[1] : $le->[0];
1427                 } elsif( _is_within( \@alt_path_wits, \@le_wits ) ) {
1428                         $alt_le = $le;
1429                 }
1430     }
1431     # Got this far? Return the alternate path if it exists.
1432     return $direction eq 'next' ? $alt_le->[1] : $alt_le->[0]
1433         if $alt_le;
1434
1435     # Got this far? Return the base path if it exists.
1436     return $direction eq 'next' ? $base_le->[1] : $base_le->[0]
1437         if $base_le;
1438
1439     # Got this far? We have no appropriate path.
1440     warn "Could not find $direction node from " . $node->id
1441         . " along path $path";
1442     return undef;
1443 }
1444
1445 # Some set logic.
1446 sub _is_within {
1447     my( $set1, $set2 ) = @_;
1448     my $ret = @$set1; # will be 0, i.e. false, if set1 is empty
1449     foreach my $el ( @$set1 ) {
1450         $ret = 0 unless grep { /^\Q$el\E$/ } @$set2;
1451     }
1452     return $ret;
1453 }
1454
1455 # Return the string that joins together a list of witnesses for
1456 # display on a single path.
1457 sub _witnesses_of_label {
1458     my( $self, $label ) = @_;
1459     my $regex = $self->wit_list_separator;
1460     my @answer = split( /\Q$regex\E/, $label );
1461     return @answer;
1462 }
1463
1464 =head2 common_readings
1465
1466 Returns the list of common readings in the graph (i.e. those readings that are
1467 shared by all non-lacunose witnesses.)
1468
1469 =cut
1470
1471 sub common_readings {
1472         my $self = shift;
1473         my @common = grep { $_->is_common } $self->readings;
1474         return @common;
1475 }
1476
1477 =head2 path_text( $sigil, [, $start, $end ] )
1478
1479 Returns the text of a witness (plus its backup, if we are using a layer)
1480 as stored in the collation.  The text is returned as a string, where the
1481 individual readings are joined with spaces and the meta-readings (e.g.
1482 lacunae) are omitted.  Optional specification of $start and $end allows
1483 the generation of a subset of the witness text.
1484
1485 =cut
1486
1487 sub path_text {
1488         my( $self, $wit, $start, $end ) = @_;
1489         $start = $self->start unless $start;
1490         $end = $self->end unless $end;
1491         my @path = grep { !$_->is_meta } $self->reading_sequence( $start, $end, $wit );
1492         my $pathtext = '';
1493         my $last;
1494         foreach my $r ( @path ) {
1495                 unless ( $r->join_prior || !$last || $last->join_next ) {
1496                         $pathtext .= ' ';
1497                 }
1498                 $pathtext .= $r->text;
1499                 $last = $r;
1500         }
1501         return $pathtext;
1502 }
1503
1504 =head1 INITIALIZATION METHODS
1505
1506 These are mostly for use by parsers.
1507
1508 =head2 make_witness_path( $witness )
1509
1510 Link the array of readings contained in $witness->path (and in
1511 $witness->uncorrected_path if it exists) into collation paths.
1512 Clear out the arrays when finished.
1513
1514 =head2 make_witness_paths
1515
1516 Call make_witness_path for all witnesses in the tradition.
1517
1518 =cut
1519
1520 # For use when a collation is constructed from a base text and an apparatus.
1521 # We have the sequences of readings and just need to add path edges.
1522 # When we are done, clear out the witness path attributes, as they are no
1523 # longer needed.
1524 # TODO Find a way to replace the witness path attributes with encapsulated functions?
1525
1526 sub make_witness_paths {
1527     my( $self ) = @_;
1528     foreach my $wit ( $self->tradition->witnesses ) {
1529         # say STDERR "Making path for " . $wit->sigil;
1530         $self->make_witness_path( $wit );
1531     }
1532 }
1533
1534 sub make_witness_path {
1535     my( $self, $wit ) = @_;
1536     my @chain = @{$wit->path};
1537     my $sig = $wit->sigil;
1538     # Add start and end if necessary
1539     unshift( @chain, $self->start ) unless $chain[0] eq $self->start;
1540     push( @chain, $self->end ) unless $chain[-1] eq $self->end;
1541     foreach my $idx ( 0 .. $#chain-1 ) {
1542         $self->add_path( $chain[$idx], $chain[$idx+1], $sig );
1543     }
1544     if( $wit->is_layered ) {
1545         @chain = @{$wit->uncorrected_path};
1546                 unshift( @chain, $self->start ) unless $chain[0] eq $self->start;
1547                 push( @chain, $self->end ) unless $chain[-1] eq $self->end;
1548         foreach my $idx( 0 .. $#chain-1 ) {
1549             my $source = $chain[$idx];
1550             my $target = $chain[$idx+1];
1551             $self->add_path( $source, $target, $sig.$self->ac_label )
1552                 unless $self->has_path( $source, $target, $sig );
1553         }
1554     }
1555     $wit->clear_path;
1556     $wit->clear_uncorrected_path;
1557 }
1558
1559 =head2 calculate_ranks
1560
1561 Calculate the reading ranks (that is, their aligned positions relative
1562 to each other) for the graph.  This can only be called on linear collations.
1563
1564 =begin testing
1565
1566 use Text::Tradition;
1567
1568 my $cxfile = 't/data/Collatex-16.xml';
1569 my $t = Text::Tradition->new(
1570     'name'  => 'inline',
1571     'input' => 'CollateX',
1572     'file'  => $cxfile,
1573     );
1574 my $c = $t->collation;
1575
1576 # Make an svg
1577 my $table = $c->alignment_table;
1578 ok( $c->has_cached_table, "Alignment table was cached" );
1579 is( $c->alignment_table, $table, "Cached table returned upon second call" );
1580 $c->calculate_ranks;
1581 is( $c->alignment_table, $table, "Cached table retained with no rank change" );
1582 $c->add_relationship( 'n24', 'n23', { 'type' => 'spelling' } );
1583 isnt( $c->alignment_table, $table, "Alignment table changed after relationship add" );
1584
1585 =end testing
1586
1587 =cut
1588
1589 sub calculate_ranks {
1590     my $self = shift;
1591     # Save the existing ranks, in case we need to invalidate the cached SVG.
1592     my %existing_ranks;
1593     map { $existing_ranks{$_} = $_->rank } $self->readings;
1594
1595     # Do the rankings based on the relationship equivalence graph, starting
1596     # with the start node.
1597     my ( $node_ranks, $rank_nodes ) = $self->relations->equivalence_ranks();
1598
1599     # Transfer our rankings from the topological graph to the real one.
1600     foreach my $r ( $self->readings ) {
1601         if( defined $node_ranks->{$self->equivalence( $r->id )} ) {
1602             $r->rank( $node_ranks->{$self->equivalence( $r->id )} );
1603         } else {
1604                 # Die. Find the last rank we calculated.
1605                 my @all_defined = sort { ( $node_ranks->{$self->equivalence( $a->id )}||-1 )
1606                                  <=> ( $node_ranks->{$self->equivalence( $b->id )}||-1 ) }
1607                         $self->readings;
1608                 my $last = pop @all_defined;
1609             throw( "Ranks not calculated after $last - do you have a cycle in the graph?" );
1610         }
1611     }
1612     # Do we need to invalidate the cached data?
1613     if( $self->has_cached_table ) {
1614         foreach my $r ( $self->readings ) {
1615                 next if defined( $existing_ranks{$r} )
1616                         && $existing_ranks{$r} == $r->rank;
1617                 # Something has changed, so clear the cache
1618                 $self->_clear_cache;
1619                         # ...and recalculate the common readings.
1620                         $self->calculate_common_readings();
1621                 last;
1622         }
1623     }
1624         # The graph calculation information is now up to date.
1625         $self->_graphcalc_done(1);
1626 }
1627
1628 sub _clear_cache {
1629         my $self = shift;
1630         $self->wipe_table if $self->has_cached_table;
1631 }
1632
1633
1634 =head2 flatten_ranks
1635
1636 A convenience method for parsing collation data.  Searches the graph for readings
1637 with the same text at the same rank, and merges any that are found.
1638
1639 =cut
1640
1641 sub flatten_ranks {
1642     my $self = shift;
1643     my %unique_rank_rdg;
1644     my $changed;
1645     foreach my $rdg ( $self->readings ) {
1646         next unless $rdg->has_rank;
1647         my $key = $rdg->rank . "||" . $rdg->text;
1648         if( exists $unique_rank_rdg{$key} ) {
1649                 # Make sure they don't have different grammatical forms
1650                         my $ur = $unique_rank_rdg{$key};
1651                 if( $rdg->is_identical( $ur ) ) {
1652                                 # Combine!
1653                                 #say STDERR "Combining readings at same rank: $key";
1654                                 $changed = 1;
1655                                 $self->merge_readings( $unique_rank_rdg{$key}, $rdg );
1656                                 # TODO see if this now makes a common point.
1657                         }
1658         } else {
1659             $unique_rank_rdg{$key} = $rdg;
1660         }
1661     }
1662     # If we merged readings, the ranks are still fine but the alignment
1663     # table is wrong. Wipe it.
1664     $self->wipe_table() if $changed;
1665 }
1666
1667
1668 =head2 calculate_common_readings
1669
1670 Goes through the graph identifying the readings that appear in every witness
1671 (apart from those with lacunae at that spot.) Marks them as common and returns
1672 the list.
1673
1674 =begin testing
1675
1676 use Text::Tradition;
1677
1678 my $cxfile = 't/data/Collatex-16.xml';
1679 my $t = Text::Tradition->new(
1680     'name'  => 'inline',
1681     'input' => 'CollateX',
1682     'file'  => $cxfile,
1683     );
1684 my $c = $t->collation;
1685
1686 my @common = $c->calculate_common_readings();
1687 is( scalar @common, 8, "Found correct number of common readings" );
1688 my @marked = sort $c->common_readings();
1689 is( scalar @common, 8, "All common readings got marked as such" );
1690 my @expected = qw/ n1 n11 n16 n19 n20 n5 n6 n7 /;
1691 is_deeply( \@marked, \@expected, "Found correct list of common readings" );
1692
1693 =end testing
1694
1695 =cut
1696
1697 sub calculate_common_readings {
1698         my $self = shift;
1699         my @common;
1700         map { $_->is_common( 0 ) } $self->readings;
1701         # Implicitly calls calculate_ranks
1702         my $table = $self->alignment_table;
1703         foreach my $idx ( 0 .. $table->{'length'} - 1 ) {
1704                 my @row = map { $_->{'tokens'}->[$idx]
1705                                                         ? $_->{'tokens'}->[$idx]->{'t'} : '' }
1706                                         @{$table->{'alignment'}};
1707                 my %hash;
1708                 foreach my $r ( @row ) {
1709                         if( $r ) {
1710                                 $hash{$r->id} = $r unless $r->is_meta;
1711                         } else {
1712                                 $hash{'UNDEF'} = $r;
1713                         }
1714                 }
1715                 if( keys %hash == 1 && !exists $hash{'UNDEF'} ) {
1716                         my( $r ) = values %hash;
1717                         $r->is_common( 1 );
1718                         push( @common, $r );
1719                 }
1720         }
1721         return @common;
1722 }
1723
1724 =head2 text_from_paths
1725
1726 Calculate the text array for all witnesses from the path, for later consistency
1727 checking.  Only to be used if there is no non-graph-based way to know the
1728 original texts.
1729
1730 =cut
1731
1732 sub text_from_paths {
1733         my $self = shift;
1734     foreach my $wit ( $self->tradition->witnesses ) {
1735         my @readings = $self->reading_sequence( $self->start, $self->end, $wit->sigil );
1736         my @text;
1737         foreach my $r ( @readings ) {
1738                 next if $r->is_meta;
1739                 push( @text, $r->text );
1740         }
1741         $wit->text( \@text );
1742         if( $wit->is_layered ) {
1743                         my @ucrdgs = $self->reading_sequence( $self->start, $self->end,
1744                                                                                                   $wit->sigil.$self->ac_label );
1745                         my @uctext;
1746                         foreach my $r ( @ucrdgs ) {
1747                                 next if $r->is_meta;
1748                                 push( @uctext, $r->text );
1749                         }
1750                         $wit->layertext( \@uctext );
1751         }
1752     }
1753 }
1754
1755 =head1 UTILITY FUNCTIONS
1756
1757 =head2 common_predecessor( $reading_a, $reading_b )
1758
1759 Find the last reading that occurs in sequence before both the given readings.
1760 At the very least this should be $self->start.
1761
1762 =head2 common_successor( $reading_a, $reading_b )
1763
1764 Find the first reading that occurs in sequence after both the given readings.
1765 At the very least this should be $self->end.
1766
1767 =begin testing
1768
1769 use Text::Tradition;
1770
1771 my $cxfile = 't/data/Collatex-16.xml';
1772 my $t = Text::Tradition->new(
1773     'name'  => 'inline',
1774     'input' => 'CollateX',
1775     'file'  => $cxfile,
1776     );
1777 my $c = $t->collation;
1778
1779 is( $c->common_predecessor( 'n24', 'n23' )->id,
1780     'n20', "Found correct common predecessor" );
1781 is( $c->common_successor( 'n24', 'n23' )->id,
1782     '__END__', "Found correct common successor" );
1783
1784 is( $c->common_predecessor( 'n19', 'n17' )->id,
1785     'n16', "Found correct common predecessor for readings on same path" );
1786 is( $c->common_successor( 'n21', 'n10' )->id,
1787     '__END__', "Found correct common successor for readings on same path" );
1788
1789 =end testing
1790
1791 =cut
1792
1793 ## Return the closest reading that is a predecessor of both the given readings.
1794 sub common_predecessor {
1795         my $self = shift;
1796         my( $r1, $r2 ) = $self->_objectify_args( @_ );
1797         return $self->_common_in_path( $r1, $r2, 'predecessors' );
1798 }
1799
1800 sub common_successor {
1801         my $self = shift;
1802         my( $r1, $r2 ) = $self->_objectify_args( @_ );
1803         return $self->_common_in_path( $r1, $r2, 'successors' );
1804 }
1805
1806
1807 # TODO think about how to do this without ranks...
1808 sub _common_in_path {
1809         my( $self, $r1, $r2, $dir ) = @_;
1810         my $iter = $self->end->rank;
1811         my @candidates;
1812         my @last_r1 = ( $r1 );
1813         my @last_r2 = ( $r2 );
1814         # my %all_seen = ( $r1 => 'r1', $r2 => 'r2' );
1815         my %all_seen;
1816         # say STDERR "Finding common $dir for $r1, $r2";
1817         while( !@candidates ) {
1818                 last unless $iter--;  # Avoid looping infinitely
1819                 # Iterate separately down the graph from r1 and r2
1820                 my( @new_lc1, @new_lc2 );
1821                 foreach my $lc ( @last_r1 ) {
1822                         foreach my $p ( $lc->$dir ) {
1823                                 if( $all_seen{$p->id} && $all_seen{$p->id} ne 'r1' ) {
1824                                         # say STDERR "Path candidate $p from $lc";
1825                                         push( @candidates, $p );
1826                                 } elsif( !$all_seen{$p->id} ) {
1827                                         $all_seen{$p->id} = 'r1';
1828                                         push( @new_lc1, $p );
1829                                 }
1830                         }
1831                 }
1832                 foreach my $lc ( @last_r2 ) {
1833                         foreach my $p ( $lc->$dir ) {
1834                                 if( $all_seen{$p->id} && $all_seen{$p->id} ne 'r2' ) {
1835                                         # say STDERR "Path candidate $p from $lc";
1836                                         push( @candidates, $p );
1837                                 } elsif( !$all_seen{$p->id} ) {
1838                                         $all_seen{$p->id} = 'r2';
1839                                         push( @new_lc2, $p );
1840                                 }
1841                         }
1842                 }
1843                 @last_r1 = @new_lc1;
1844                 @last_r2 = @new_lc2;
1845         }
1846         my @answer = sort { $a->rank <=> $b->rank } @candidates;
1847         return $dir eq 'predecessors' ? pop( @answer ) : shift ( @answer );
1848 }
1849
1850 sub throw {
1851         Text::Tradition::Error->throw(
1852                 'ident' => 'Collation error',
1853                 'message' => $_[0],
1854                 );
1855 }
1856
1857 no Moose;
1858 __PACKAGE__->meta->make_immutable;
1859
1860 =head1 BUGS/TODO
1861
1862 =over
1863
1864 =item * Rework XML serialization in a more modular way
1865
1866 =back
1867
1868 =head1 LICENSE
1869
1870 This package is free software and is provided "as is" without express
1871 or implied warranty.  You can redistribute it and/or modify it under
1872 the same terms as Perl itself.
1873
1874 =head1 AUTHOR
1875
1876 Tara L Andrews E<lt>aurum@cpan.orgE<gt>