1 package Text::Tradition::Parser::GraphML;
6 use XML::LibXML::XPathContext;
10 Text::Tradition::Parser::GraphML
14 Parser module for Text::Tradition, given a GraphML file that describes
15 a collation graph. For further information on the GraphML format for
16 text collation, see http://gregor.middell.net/collatex/
24 parse( $graph, $graphml_string );
26 Takes an initialized Text::Tradition::Graph object and a string
27 containing the GraphML; creates the appropriate nodes and edges on the
32 use vars qw/ $xpc %nodedata /;
35 my( $tradition, $graphml_str ) = @_;
37 my $collation = $tradition->collation;
38 my $parser = XML::LibXML->new();
39 my $doc = $parser->parse_string( $graphml_str );
40 my $graphml = $doc->documentElement();
41 $xpc = XML::LibXML::XPathContext->new( $graphml );
42 $xpc->registerNs( 'g', 'http://graphml.graphdrawing.org/xmlns' );
44 # First get the ID keys, for witnesses and for collation data
46 foreach my $k ( $xpc->findnodes( '//g:key' ) ) {
47 # Each key has a 'for' attribute; the edge keys are witnesses, and
48 # the node keys contain an ID and string for each node.
50 if( $k->getAttribute( 'for' ) eq 'node' ) {
51 # The node data keys we expect are:
52 # 'number' -> unique node identifier
53 # 'token' -> reading for the node
54 # 'identical' -> the node of which this node is
55 # a transposed version
56 # 'position' -> a calculated position for the node
57 $nodedata{ $k->getAttribute( 'attr.name' ) } = $k->getAttribute( 'id' );
59 $witnesses{ $k->getAttribute( 'id' ) } = $k->getAttribute( 'attr.name' );
63 my $has_explicit_positions = defined $nodedata{'position'};
65 # Add the witnesses that we have found
66 foreach my $wit ( values %witnesses ) {
67 $tradition->add_witness( 'sigil' => $wit );
70 my $graph_el = $xpc->find( '/g:graphml/g:graph' )->[0];
72 # Add the nodes to the graph. First delete the start node, because
73 # GraphML graphs will have their own start nodes.
74 $collation->del_reading( $collation->start() );
75 # Map from XML IDs to node name/identity
77 # Keep track of whatever extra info we're passed
79 my @nodes = $xpc->findnodes( '//g:node' );
80 foreach my $n ( @nodes ) {
81 my $id = _lookup_node_data( $n, 'number' );
82 my $token = _lookup_node_data( $n, 'token' );
83 my $gnode = $collation->add_reading( $id );
84 $node_name{ $n->getAttribute('id') } = $id;
85 $gnode->text( $token );
87 # Now get the rest of the data, i.e. not the ID or label
89 foreach my $k ( keys %nodedata ) {
90 next if $k =~ /^(number|token)$/;
91 $extra->{ $k } = _lookup_node_data( $n, $k );
93 $extra_data->{ $id } = $extra;
97 my @edges = $xpc->findnodes( '//g:edge' );
98 foreach my $e ( @edges ) {
99 my $from = $node_name{ $e->getAttribute('source') };
100 my $to = $node_name{ $e->getAttribute('target') };
101 # Label according to the witnesses present.
102 my @wit_ids = $xpc->findnodes( './g:data/attribute::key', $e );
103 my @wit_names = map { $witnesses{ $_->getValue() } } @wit_ids;
104 # One path per witness
105 foreach( @wit_names ) {
106 $collation->add_path( $from, $to, $_ );
108 # Only a single path between two readings
109 # my $label = $collation->path_label( @wit_names );
110 # $collation->add_path( $from, $to, $label );
113 ## Reverse the node_name hash so that we have two-way lookup.
114 my %node_id = reverse %node_name;
116 ## Record the nodes that are marked as transposed.
117 my $tr_xpath = '//g:node[g:data[@key="' . $nodedata{'identical'} . '"]]';
118 my $transposition_nodes = $xpc->find( $tr_xpath );
119 foreach my $tn ( @$transposition_nodes ) {
120 my $id_xpath = sprintf( './g:data[@key="%s"]/text()',
121 $nodedata{'identical'} );
122 $collation->reading( $node_id{ $tn->getAttribute( 'id' ) } )->
123 set_identical( $collation->reading(
124 $node_name{ $xpc->findvalue( $id_xpath, $tn ) } ) );
127 # Find the beginning and end nodes of the graph. The beginning node
128 # has no incoming edges; the end node has no outgoing edges.
129 my( $begin_node, $end_node );
130 foreach my $gnode ( $collation->readings() ) {
131 # print STDERR "Checking node " . $gnode->name . "\n";
132 my @outgoing = $gnode->outgoing();
133 my @incoming = $gnode->incoming();
135 unless( scalar @incoming ) {
136 warn "Already have a beginning node" if $begin_node;
137 $begin_node = $gnode;
138 $collation->start( $gnode );
140 unless( scalar @outgoing ) {
141 warn "Already have an ending node" if $end_node;
146 my @common_nodes = $collation->walk_witness_paths( $end_node );
147 # Now we have added the witnesses and their paths, so have also
148 # implicitly marked the common nodes. Now we can calculate their
149 # explicit permissions. This is separate because it won't always
150 # be necessary with the GraphML parsing.
151 if( $has_explicit_positions ) {
152 # Record the positions that came with each graph node.
153 # TODO we really need to translate these into our own style of
154 # position identifier. That's why we defer this until now.
155 foreach my $node_id ( keys %$extra_data ) {
156 my $pos = $extra_data->{$node_id}->{'position'};
157 $collation->reading( $node_name{$node_id} )->position( $pos );
160 # Calculate a position for each graph node.
161 $collation->calculate_positions( @common_nodes );
165 sub _lookup_node_data {
166 my( $xmlnode, $key ) = @_;
167 my $lookup_xpath = './g:data[@key="%s"]/child::text()';
168 my $data = $xpc->findvalue( sprintf( $lookup_xpath, $nodedata{$key} ),
177 This package is free software and is provided "as is" without express
178 or implied warranty. You can redistribute it and/or modify it under
179 the same terms as Perl itself.
183 Tara L Andrews, aurum@cpan.org