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