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