base/lib/Text/Tradition/Collation.pm

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