Commit | Line | Data |
e58153d6 |
1 | package Text::Tradition::Parser::GraphML; |
b49c4318 |
2 | |
3 | use strict; |
4 | use warnings; |
b49c4318 |
5 | use XML::LibXML; |
6 | use XML::LibXML::XPathContext; |
7 | |
2ceca8c3 |
8 | =head1 NAME |
b49c4318 |
9 | |
2ceca8c3 |
10 | Text::Tradition::Parser::GraphML |
11 | |
12 | =head1 DESCRIPTION |
13 | |
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/ |
17 | |
18 | =head1 METHODS |
19 | |
20 | =over |
21 | |
22 | =item B<parse> |
23 | |
24 | parse( $graph, $graphml_string ); |
25 | |
26 | Takes an initialized Text::Tradition::Graph object and a string |
27 | containing the GraphML; creates the appropriate nodes and edges on the |
28 | graph. |
29 | |
30 | =cut |
b49c4318 |
31 | |
4a8828f0 |
32 | use vars qw/ $xpc %nodedata /; |
33 | |
b49c4318 |
34 | sub parse { |
4a8828f0 |
35 | my( $tradition, $graphml_str ) = @_; |
b49c4318 |
36 | |
4a8828f0 |
37 | my $collation = $tradition->collation; |
b49c4318 |
38 | my $parser = XML::LibXML->new(); |
39 | my $doc = $parser->parse_string( $graphml_str ); |
8e1394aa |
40 | my $graphml = $doc->documentElement(); |
4a8828f0 |
41 | $xpc = XML::LibXML::XPathContext->new( $graphml ); |
b49c4318 |
42 | $xpc->registerNs( 'g', 'http://graphml.graphdrawing.org/xmlns' ); |
43 | |
44 | # First get the ID keys, for witnesses and for collation data |
b49c4318 |
45 | my %witnesses; |
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. |
49 | |
50 | if( $k->getAttribute( 'for' ) eq 'node' ) { |
4a8828f0 |
51 | # The node data keys we expect are: |
df6d9812 |
52 | # 'number|name' -> unique node identifier |
53 | # 'token|reading' -> reading for the node |
4a8828f0 |
54 | # 'identical' -> the node of which this node is |
55 | # a transposed version |
56 | # 'position' -> a calculated position for the node |
b49c4318 |
57 | $nodedata{ $k->getAttribute( 'attr.name' ) } = $k->getAttribute( 'id' ); |
58 | } else { |
59 | $witnesses{ $k->getAttribute( 'id' ) } = $k->getAttribute( 'attr.name' ); |
60 | } |
61 | } |
62 | |
4a8828f0 |
63 | my $has_explicit_positions = defined $nodedata{'position'}; |
64 | |
65 | # Add the witnesses that we have found |
66 | foreach my $wit ( values %witnesses ) { |
67 | $tradition->add_witness( 'sigil' => $wit ); |
68 | } |
69 | |
b49c4318 |
70 | my $graph_el = $xpc->find( '/g:graphml/g:graph' )->[0]; |
71 | |
72 | # Add the nodes to the graph. First delete the start node, because |
73 | # GraphML graphs will have their own start nodes. |
8e1394aa |
74 | $collation->del_reading( $collation->start() ); |
b49c4318 |
75 | # Map from XML IDs to node name/identity |
76 | my %node_name; |
77 | # Keep track of whatever extra info we're passed |
78 | my $extra_data = {}; |
79 | my @nodes = $xpc->findnodes( '//g:node' ); |
80 | foreach my $n ( @nodes ) { |
4a8828f0 |
81 | my $id = _lookup_node_data( $n, 'number' ); |
df6d9812 |
82 | $id = _lookup_node_data( $n, 'name' ) unless $id; |
e2902068 |
83 | my $token = _lookup_node_data( $n, 'token' ); |
df6d9812 |
84 | $token = _lookup_node_data( $n, 'reading' ) unless $token; |
8e1394aa |
85 | my $gnode = $collation->add_reading( $id ); |
b49c4318 |
86 | $node_name{ $n->getAttribute('id') } = $id; |
e2902068 |
87 | $gnode->text( $token ); |
b49c4318 |
88 | |
4a8828f0 |
89 | # Now get the rest of the data, i.e. not the ID or label |
b49c4318 |
90 | my $extra = {}; |
4a8828f0 |
91 | foreach my $k ( keys %nodedata ) { |
92 | next if $k =~ /^(number|token)$/; |
93 | $extra->{ $k } = _lookup_node_data( $n, $k ); |
b49c4318 |
94 | } |
95 | $extra_data->{ $id } = $extra; |
96 | } |
97 | |
98 | # Now add the edges. |
99 | my @edges = $xpc->findnodes( '//g:edge' ); |
100 | foreach my $e ( @edges ) { |
101 | my $from = $node_name{ $e->getAttribute('source') }; |
102 | my $to = $node_name{ $e->getAttribute('target') }; |
103 | # Label according to the witnesses present. |
104 | my @wit_ids = $xpc->findnodes( './g:data/attribute::key', $e ); |
105 | my @wit_names = map { $witnesses{ $_->getValue() } } @wit_ids; |
e2902068 |
106 | # One path per witness |
107 | foreach( @wit_names ) { |
108 | $collation->add_path( $from, $to, $_ ); |
109 | } |
110 | # Only a single path between two readings |
111 | # my $label = $collation->path_label( @wit_names ); |
112 | # $collation->add_path( $from, $to, $label ); |
b49c4318 |
113 | } |
114 | |
115 | ## Reverse the node_name hash so that we have two-way lookup. |
116 | my %node_id = reverse %node_name; |
a25d4374 |
117 | |
118 | ## Record the nodes that are marked as transposed. |
c557b209 |
119 | my $tr_xpath = '//g:node[g:data[@key="' . $nodedata{'identical'} . '"]]'; |
c2d16875 |
120 | my $transposition_nodes = $xpc->find( $tr_xpath ); |
121 | foreach my $tn ( @$transposition_nodes ) { |
122 | my $id_xpath = sprintf( './g:data[@key="%s"]/text()', |
c557b209 |
123 | $nodedata{'identical'} ); |
8e1394aa |
124 | $collation->reading( $node_id{ $tn->getAttribute( 'id' ) } )-> |
125 | set_identical( $collation->reading( |
126 | $node_name{ $xpc->findvalue( $id_xpath, $tn ) } ) ); |
a25d4374 |
127 | } |
a25d4374 |
128 | |
b49c4318 |
129 | # Find the beginning and end nodes of the graph. The beginning node |
130 | # has no incoming edges; the end node has no outgoing edges. |
131 | my( $begin_node, $end_node ); |
8e1394aa |
132 | foreach my $gnode ( $collation->readings() ) { |
4a8828f0 |
133 | # print STDERR "Checking node " . $gnode->name . "\n"; |
b49c4318 |
134 | my @outgoing = $gnode->outgoing(); |
135 | my @incoming = $gnode->incoming(); |
136 | |
137 | unless( scalar @incoming ) { |
138 | warn "Already have a beginning node" if $begin_node; |
4a8828f0 |
139 | $begin_node = $gnode; |
8e1394aa |
140 | $collation->start( $gnode ); |
b49c4318 |
141 | } |
142 | unless( scalar @outgoing ) { |
143 | warn "Already have an ending node" if $end_node; |
4a8828f0 |
144 | $end_node = $gnode; |
b49c4318 |
145 | } |
146 | } |
147 | |
3a1f2523 |
148 | my @common_nodes = $collation->walk_witness_paths( $end_node ); |
4a8828f0 |
149 | # Now we have added the witnesses and their paths, so have also |
150 | # implicitly marked the common nodes. Now we can calculate their |
151 | # explicit permissions. This is separate because it won't always |
152 | # be necessary with the GraphML parsing. |
4a8828f0 |
153 | if( $has_explicit_positions ) { |
154 | # Record the positions that came with each graph node. |
155 | # TODO we really need to translate these into our own style of |
156 | # position identifier. That's why we defer this until now. |
157 | foreach my $node_id ( keys %$extra_data ) { |
158 | my $pos = $extra_data->{$node_id}->{'position'}; |
159 | $collation->reading( $node_name{$node_id} )->position( $pos ); |
b49c4318 |
160 | } |
4a8828f0 |
161 | } else { |
162 | # Calculate a position for each graph node. |
3a1f2523 |
163 | $collation->calculate_positions( @common_nodes ); |
b49c4318 |
164 | } |
4a8828f0 |
165 | } |
b49c4318 |
166 | |
4a8828f0 |
167 | sub _lookup_node_data { |
168 | my( $xmlnode, $key ) = @_; |
df6d9812 |
169 | return undef unless exists $nodedata{$key}; |
4a8828f0 |
170 | my $lookup_xpath = './g:data[@key="%s"]/child::text()'; |
171 | my $data = $xpc->findvalue( sprintf( $lookup_xpath, $nodedata{$key} ), |
172 | $xmlnode ); |
173 | return $data; |
b49c4318 |
174 | } |
175 | |
2ceca8c3 |
176 | =back |
177 | |
178 | =head1 LICENSE |
179 | |
180 | This package is free software and is provided "as is" without express |
181 | or implied warranty. You can redistribute it and/or modify it under |
182 | the same terms as Perl itself. |
183 | |
184 | =head1 AUTHOR |
185 | |
186 | Tara L Andrews, aurum@cpan.org |
187 | |
188 | =cut |
189 | |
b49c4318 |
190 | 1; |