lib/Text/Tradition/Collation.pm

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