lib/Text/Tradition/Collation.pm

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