lib/Text/Tradition/Collation.pm

   1 package Text::Tradition::Collation;
   2
   3 use Graph::Easy;
   4 use IPC::Run qw( run binary );
   5 use Text::Tradition::Collation::Reading;
   6 use Moose;
   7
   8 has 'graph' => (
   9     is => 'ro',
  10     isa => 'Graph::Easy',
  11     handles => {
  12         add_reading => 'add_node',
  13         del_reading => 'del_node',
  14         add_path => 'add_edge',
  15         del_path => 'del_edge',
  16         reading => 'node',
  17         path => 'edge',
  18         readings => 'nodes',
  19         paths => 'edges',
  20     },
  21     default => sub { Graph::Easy->new( undirected => 0 ) },
  22     );
  23
  24
  25 has 'tradition' => (
  26     is => 'rw',
  27     isa => 'Text::Tradition',
  28     );
  29
  30 has 'svg' => (
  31     is => 'ro',
  32     isa => 'Str',
  33     writer => '_save_svg',
  34     predicate => 'has_svg',
  35     );
  36
  37 has 'graphviz' => (
  38     is => 'ro',
  39     isa => 'Str',
  40     writer => '_save_graphviz',
  41     predicate => 'has_graphviz',
  42     );
  43
  44 has 'graphml' => (
  45     is => 'ro',
  46     isa => 'XML::LibXML::Document',
  47     writer => '_save_graphml',
  48     predicate => 'has_graphml',
  49     );
  50
  51 # Keeps track of the lemmas within the collation.  At most one lemma
  52 # per position in the graph.
  53 has 'lemmata' => (
  54     is => 'ro',
  55     isa => 'HashRef[Maybe[Str]]',
  56     default => sub { {} },
  57     );
  58
  59 has 'wit_list_separator' => (
  60                              is => 'rw',
  61                              isa => 'Str',
  62                              default => ', ',
  63                              );
  64
  65 # The collation can be created two ways:
  66 # 1. Collate a set of witnesses (with CollateX I guess) and process
  67 #    the results as in 2.
  68 # 2. Read a pre-prepared collation in one of a variety of formats,
  69 #    and make the graph from that.
  70
  71 # The graph itself will (for now) be immutable, and the positions
  72 # within the graph will also be immutable.  We need to calculate those
  73 # positions upon graph construction.  The equivalences between graph
  74 # nodes will be mutable, entirely determined by the user (or possibly
  75 # by some semantic pre-processing provided by the user.)  So the
  76 # constructor should just make an empty equivalences object.  The
  77 # constructor will also need to make the witness objects, if we didn't
  78 # come through option 1.
  79
  80 sub BUILD {
  81     my( $self, $args ) = @_;
  82     $self->graph->use_class('node', 'Text::Tradition::Collation::Reading');
  83
  84     # Pass through any graph-specific options.
  85     my $shape = exists( $args->{'shape'} ) ? $args->{'shape'} : 'ellipse';
  86     $self->graph->set_attribute( 'node', 'shape', $shape );
  87 }
  88
  89 # Wrappers around some methods
  90
  91 sub merge_readings {
  92     my $self = shift;
  93     my $first_node = shift;
  94     my $second_node = shift;
  95     $first_node->merge_from( $second_node );
  96     unshift( @_, $first_node, $second_node );
  97     return $self->graph->merge_nodes( @_ );
  98 }
  99
 100 =head2 Output method(s)
 101
 102 =over
 103
 104 =item B<as_svg>
 105
 106 print $graph->as_svg( $recalculate );
 107
 108 Returns an SVG string that represents the graph.  Uses GraphViz to do
 109 this, because Graph::Easy doesn\'t cope well with long graphs. Unless
 110 $recalculate is passed (and is a true value), the method will return a
 111 cached copy of the SVG after the first call to the method.
 112
 113 =cut
 114
 115 sub as_svg {
 116     my( $self, $recalc ) = @_;
 117     return $self->svg if $self->has_svg;
 118
 119     $self->_save_graphviz( $self->graph->as_graphviz() )
 120         unless( $self->has_graphviz && !$recalc );
 121
 122     my @cmd = qw/dot -Tsvg/;
 123     my( $svg, $err );
 124     my $in = $self->graphviz;
 125     run( \@cmd, \$in, ">", binary(), \$svg );
 126     $self->{'svg'} = $svg;
 127     return $svg;
 128 }
 129
 130 =item B<as_graphml>
 131
 132 print $graph->as_graphml( $recalculate )
 133
 134 Returns a GraphML representation of the collation graph, with
 135 transposition information and position information. Unless
 136 $recalculate is passed (and is a true value), the method will return a
 137 cached copy of the SVG after the first call to the method.
 138
 139 =cut
 140
 141 sub as_graphml {
 142     my( $self, $recalc ) = @_;
 143     return $self->graphml if $self->has_graphml;
 144
 145     # Some namespaces
 146     my $graphml_ns = 'http://graphml.graphdrawing.org/xmlns';
 147     my $xsi_ns = 'http://www.w3.org/2001/XMLSchema-instance';
 148     my $graphml_schema = 'http://graphml.graphdrawing.org/xmlns ' .
 149         'http://graphml.graphdrawing.org/xmlns/1.0/graphml.xsd';
 150
 151     # Create the document and root node
 152     my $graphml = XML::LibXML->createDocument( "1.0", "UTF-8" );
 153     my $root = $graphml->createElementNS( $graphml_ns, 'graphml' );
 154     $graphml->setDocumentElement( $root );
 155     $root->setNamespace( $xsi_ns, 'xsi', 0 );
 156     $root->setAttributeNS( $xsi_ns, 'schemaLocation', $graphml_schema );
 157
 158     # Add the data keys for nodes
 159     my @node_data = ( 'name', 'token', 'identical', 'position' );
 160     foreach my $ndi ( 0 .. $#node_data ) {
 161         my $key = $root->addNewChild( $graphml_ns, 'key' );
 162         $key->setAttribute( 'attr.name', $node_data[$ndi] );
 163         $key->setAttribute( 'attr.type', 'string' );
 164         $key->setAttribute( 'for', 'node' );
 165         $key->setAttribute( 'id', 'd'.$ndi );
 166     }
 167
 168     # Add the data keys for edges
 169     my %wit_hash;
 170     my $wit_ctr = 0;
 171     foreach my $wit ( $self->getWitnessList ) {
 172         my $wit_key = 'w' . $wit_ctr++;
 173         $wit_hash{$wit} = $wit_key;
 174         my $key = $root->addNewChild( $graphml_ns, 'key' );
 175         $key->setAttribute( 'attr.name', $wit );
 176         $key->setAttribute( 'attr.type', 'string' );
 177         $key->setAttribute( 'for', 'edge' );
 178         $key->setAttribute( 'id', $wit_key );
 179     }
 180
 181     # Add the graph, its nodes, and its edges
 182     my $graph = $root->addNewChild( $graphml_ns, 'graph' );
 183     $graph->setAttribute( 'edgedefault', 'directed' );
 184     $graph->setAttribute( 'id', 'g0' ); # TODO make this meaningful
 185     $graph->setAttribute( 'parse.edgeids', 'canonical' );
 186     $graph->setAttribute( 'parse.edges', $self->edges() );
 187     $graph->setAttribute( 'parse.nodeids', 'canonical' );
 188     $graph->setAttribute( 'parse.nodes', $self->nodes() );
 189     $graph->setAttribute( 'parse.order', 'nodesfirst' );
 190
 191     my $node_ctr = 0;
 192     my %node_hash;
 193     foreach my $n ( $self->readings ) {
 194         my %this_node_data = ();
 195         foreach my $ndi ( 0 .. $#node_data ) {
 196             my $value;
 197             $this_node_data{'d'.$ndi} = $n->name if $node_data[$ndi] eq 'name';
 198             $this_node_data{'d'.$ndi} = $n->label
 199                 if $node_data[$ndi] eq 'token';
 200             $this_node_data{'d'.$ndi} = $n->primary->name if $n->has_primary;
 201             $this_node_data{'d'.$ndi} =
 202                 $self->{'positions'}->node_position( $n )
 203                 if $node_data[$ndi] eq 'position';
 204         }
 205         my $node_el = $graph->addNewChild( $graphml_ns, 'node' );
 206         my $node_xmlid = 'n' . $node_ctr++;
 207         $node_hash{ $n->name } = $node_xmlid;
 208         $node_el->setAttribute( 'id', $node_xmlid );
 209
 210         foreach my $dk ( keys %this_node_data ) {
 211             my $d_el = $node_el->addNewChild( $graphml_ns, 'data' );
 212             $d_el->setAttribute( 'key', $dk );
 213             $d_el->appendTextChild( $this_node_data{$dk} );
 214         }
 215     }
 216
 217     foreach my $e ( $self->edges() ) {
 218         my( $name, $from, $to ) = ( $e->name,
 219                                     $node_hash{ $e->from()->name() },
 220                                     $node_hash{ $e->to()->name() } );
 221         my $edge_el = $graph->addNewChild( $graphml_ns, 'edge' );
 222         $edge_el->setAttribute( 'source', $from );
 223         $edge_el->setAttribute( 'target', $to );
 224         $edge_el->setAttribute( 'id', $name );
 225         # TODO Got to add the witnesses
 226     }
 227
 228     # Return the thing
 229     $self->_save_graphml( $graphml );
 230     return $graphml;
 231 }
 232
 233 =back
 234
 235 =item B<start>
 236
 237 my $beginning = $collation->start();
 238
 239 Returns the beginning of the collation, a meta-reading with label '#START#'.
 240
 241 =cut
 242
 243 sub start {
 244     # Return the beginning reading of the graph.
 245     my $self = shift;
 246     my( $new_start ) = @_;
 247     if( $new_start ) {
 248         $self->del_reading( '#START#' );
 249         $self->graph->rename_node( $new_start, '#START#' );
 250     }
 251     return $self->reading('#START#');
 252 }
 253
 254 =item B<next_reading>
 255
 256 my $next_reading = $graph->next_reading( $reading, $witpath );
 257
 258 Returns the reading that follows the given reading along the given witness
 259 path.  TODO These are badly named.
 260
 261 =cut
 262
 263 sub next_reading {
 264     # Return the successor via the corresponding edge.
 265     my $self = shift;
 266     return $self->_find_linked_reading( 'next', @_ );
 267 }
 268
 269 =item B<prior_reading>
 270
 271 my $prior_reading = $graph->prior_reading( $reading, $witpath );
 272
 273 Returns the reading that precedes the given reading along the given witness
 274 path.  TODO These are badly named.
 275
 276 =cut
 277
 278 sub prior_reading {
 279     # Return the predecessor via the corresponding edge.
 280     my $self = shift;
 281     return $self->_find_linked_reading( 'prior', @_ );
 282 }
 283
 284 sub _find_linked_reading {
 285     my( $self, $direction, $node, $edge ) = @_;
 286     $edge = 'base text' unless $edge;
 287     my @linked_edges = $direction eq 'next'
 288         ? $node->outgoing() : $node->incoming();
 289     return undef unless scalar( @linked_edges );
 290
 291     # We have to find the linked edge that contains all of the
 292     # witnesses supplied in $edge.
 293     my @edge_wits = $self->witnesses_of_label( $edge );
 294     foreach my $le ( @linked_edges ) {
 295         my @le_wits = $self->witnesses_of_label( $le->name );
 296         if( _is_within( \@edge_wits, \@le_wits ) ) {
 297             # This is the right edge.
 298             return $direction eq 'next' ? $le->to() : $le->from();
 299         }
 300     }
 301     warn "Could not find $direction node from " . $node->label
 302         . " along edge $edge";
 303     return undef;
 304 }
 305
 306 # Some set logic.
 307 sub _is_within {
 308     my( $set1, $set2 ) = @_;
 309     my $ret = 1;
 310     foreach my $el ( @$set1 ) {
 311         $ret = 0 unless grep { /^\Q$el\E$/ } @$set2;
 312     }
 313     return $ret;
 314 }
 315
 316 # Walk the paths for each witness in the graph, and return the nodes
 317 # that the graph has in common.
 318
 319 sub walk_witness_paths {
 320     my( $self, $end ) = @_;
 321     # For each witness, walk the path through the graph.
 322     # Then we need to find the common nodes.
 323     # TODO This method is going to fall down if we have a very gappy
 324     # text in the collation.
 325     my $paths = {};
 326     my @common_readings;
 327     foreach my $wit ( @{$self->tradition->witnesses} ) {
 328         my $curr_reading = $self->start;
 329         my @wit_path = ( $curr_reading );
 330         my %seen_readings;
 331         # TODO Detect loops at some point
 332         while( $curr_reading->name ne $end->name ) {
 333             if( $seen_readings{$curr_reading->name} ) {
 334                 warn "Detected loop walking path for witness " . $wit->sigil
 335                     . " at reading " . $curr_reading->name;
 336                 last;
 337             }
 338             my $next_reading = $self->next_reading( $curr_reading,
 339                                                     $wit->sigil );
 340             push( @wit_path, $next_reading );
 341             $seen_readings{$curr_reading->name} = 1;
 342             $curr_reading = $next_reading;
 343         }
 344         $wit->path( \@wit_path );
 345         if( @common_readings ) {
 346             my @cn;
 347             foreach my $n ( @wit_path ) {
 348                 push( @cn, $n ) if grep { $_ eq $n } @common_readings;
 349             }
 350             @common_readings = ();
 351             push( @common_readings, @cn );
 352         } else {
 353             push( @common_readings, @wit_path );
 354         }
 355     }
 356
 357     # Mark all the nodes as either common or not.
 358     foreach my $cn ( @common_readings ) {
 359         print STDERR "Setting " . $cn->name . " as common node\n";
 360         $cn->make_common;
 361     }
 362     foreach my $n ( $self->readings() ) {
 363         $n->make_variant unless $n->is_common;
 364     }
 365     # Return an array of the common nodes in order.
 366     return @common_readings;
 367 }
 368
 369 sub common_readings {
 370     my $self = shift;
 371     my @common = grep { $_->is_common } $self->readings();
 372     return @common;
 373 }
 374
 375 # Calculate the relative positions of nodes in the graph, if they
 376 # were not given to us.
 377 sub calculate_positions {
 378     my( $self, @ordered_common ) = @_;
 379
 380     # We have to calculate the position identifiers for each word,
 381     # keyed on the common nodes.  This will be 'fun'.  The end result
 382     # is a hash per witness, whose key is the word node and whose
 383     # value is its position in the text.  Common nodes are always N,1
 384     # so have identical positions in each text.
 385     $DB::single = 1;
 386
 387     my $node_pos = {};
 388     foreach my $wit ( @{$self->tradition->witnesses} ) {
 389         # First we walk each path, making a matrix for each witness that
 390         # corresponds to its eventual position identifier.  Common nodes
 391         # always start a new row, and are thus always in the first column.
 392
 393         my $wit_matrix = [];
 394         my $cn = 0;  # We should hit the common readings in order.
 395         my $row = [];
 396         foreach my $wn ( @{$wit->path} ) {
 397             if( $wn eq $ordered_common[$cn] ) {
 398                 # Set up to look for the next common node, and
 399                 # start a new row of words.
 400                 $cn++;
 401                 push( @$wit_matrix, $row ) if scalar( @$row );
 402                 $row = [];
 403             }
 404             push( @$row, $wn );
 405         }
 406         push( @$wit_matrix, $row );  # Push the last row onto the matrix
 407
 408         # Now we have a matrix per witness, so that each row in the
 409         # matrix begins with a common node, and continues with all the
 410         # variant words that appear in the witness.  We turn this into
 411         # real positions in row,cell format.  But we need some
 412         # trickery in order to make sure that each node gets assigned
 413         # to only one position.
 414
 415         foreach my $li ( 1..scalar(@$wit_matrix) ) {
 416             foreach my $di ( 1..scalar(@{$wit_matrix->[$li-1]}) ) {
 417                 my $reading = $wit_matrix->[$li-1]->[$di-1];
 418                 my $position = "$li,$di";
 419                 # If we have seen this node before, we need to compare
 420                 # its position with what went before.
 421                 unless( $reading->has_position &&
 422                         _cmp_position( $position, $reading->position ) < 1 ) {
 423                     # The new position ID replaces the old one.
 424                     $reading->position( $position );
 425                 } # otherwise, the old position needs to stay.
 426             }
 427         }
 428     }
 429
 430     $self->init_lemmata();
 431 }
 432
 433 sub _cmp_position {
 434     my( $a, $b ) = @_;
 435     my @pos_a = split(/,/, $a );
 436     my @pos_b = split(/,/, $b );
 437
 438     my $big_cmp = $pos_a[0] <=> $pos_b[0];
 439     return $big_cmp if $big_cmp;
 440     # else
 441     return $pos_a[1] <=> $pos_b[1];
 442 }
 443
 444 sub all_positions {
 445     my $self = shift;
 446     my %positions = ();
 447     map { $positions{$_->position} = 1 } $self->readings;
 448     return keys( %positions );
 449 }
 450
 451 sub readings_at_position {
 452     my( $self, $pos ) = @_;
 453     my @answer = grep { $_->position eq $pos } $self->readings;
 454     return @answer;
 455 }
 456
 457 ## Lemmatizer functions
 458
 459 sub init_lemmata {
 460     my $self = shift;
 461
 462     foreach my $position ( $self->all_positions ) {
 463         $self->lemmata->{$position} = undef;
 464     }
 465
 466     foreach my $cr ( $self->common_readings ) {
 467         $self->lemmata->{$cr->position} = $cr->name;
 468     }
 469 }
 470
 471 =item B<lemma_readings>
 472
 473 my @state = $graph->lemma_readings( @readings_delemmatized );
 474
 475 Takes a list of readings that have just been delemmatized, and returns
 476 a set of tuples of the form ['reading', 'state'] that indicates what
 477 changes need to be made to the graph.
 478
 479 =over
 480
 481 =item *
 482
 483 A state of 1 means 'lemmatize this reading'
 484
 485 =item *
 486
 487 A state of 0 means 'delemmatize this reading'
 488
 489 =item *
 490
 491 A state of undef means 'an ellipsis belongs in the text here because
 492 no decision has been made / an earlier decision was backed out'
 493
 494 =back
 495
 496 =cut
 497
 498 sub lemma_readings {
 499     my( $self, @toggled_off_nodes ) = @_;
 500
 501     # First get the positions of those nodes which have been
 502     # toggled off.
 503     my $positions_off = {};
 504     map { $positions_off->{ $_->position } = $_->name } @toggled_off_nodes;
 505
 506
 507     # Now for each position, we have to see if a node is on, and we
 508     # have to see if a node has been turned off.
 509     my @answer;
 510     foreach my $pos ( $self->all_positions() ) {
 511         # Find the state of this position.  If there is an active node,
 512         # its name will be the state; otherwise the state will be 0
 513         # (nothing at this position) or undef (ellipsis at this position)
 514         my $active = $self->lemmata->{$pos};
 515
 516         # Is there a formerly active node that was toggled off?
 517         if( exists( $positions_off->{$pos} ) ) {
 518             my $off_node = $positions_off->{$pos};
 519             if( $active && $active ne $off_node) {
 520                 push( @answer, [ $off_node, 0 ], [ $active, 1 ] );
 521             } else {
 522                 push( @answer, [ $off_node, $active ] );
 523             }
 524
 525         # No formerly active node, so we just see if there is a currently
 526         # active one.
 527         } elsif( $active ) {
 528             # Push the active node, whatever it is.
 529             push( @answer, [ $active, 1 ] );
 530         } else {
 531             # Push the state that is there. Arbitrarily use the first node
 532             # at that position.
 533             my @pos_nodes = $self->readings_at_position( $pos );
 534             push( @answer, [ $pos_nodes[0], $self->lemmata->{$pos} ] );
 535         }
 536     }
 537
 538     return @answer;
 539 }
 540
 541
 542
 543 # Return the string that joins together a list of witnesses for
 544 # display on a single path.
 545 sub path_label {
 546     my $self = shift;
 547     return join( $self->wit_list_separator, @_ );
 548 }
 549
 550 sub witnesses_of_label {
 551     my $self = shift;
 552     my $regex = $self->wit_list_separator;
 553     return split( /^\Q$regex\E$/, @_ );
 554 }
 555
 556 no Moose;
 557 __PACKAGE__->meta->make_immutable;