lib/Text/Tradition/Collation.pm

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