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