Commit | Line | Data |
6f4946fb |
1 | package Text::Tradition::Parser::CTE; |
2 | |
3 | use strict; |
4 | use warnings; |
4d85a60e |
5 | use Text::Tradition::Parser::Util qw/ collate_variants /; |
6f4946fb |
6 | use XML::LibXML; |
7 | use XML::LibXML::XPathContext; |
8 | |
9 | =head1 NAME |
10 | |
11 | Text::Tradition::Parser::CTE |
12 | |
13 | =head1 DESCRIPTION |
14 | |
15 | Parser module for Text::Tradition, given a TEI file exported from |
16 | Classical Text Editor. |
17 | |
18 | =head1 METHODS |
19 | |
20 | =over |
21 | |
22 | =item B<parse> |
23 | |
24 | my @apparatus = read( $xml_file ); |
25 | |
26 | Takes a Tradition object and a TEI file exported from Classical Text |
4d85a60e |
27 | Editor using double-endpoint-attachment critical apparatus encoding; |
28 | initializes the Tradition from the file. |
6f4946fb |
29 | |
30 | =cut |
31 | |
4d85a60e |
32 | my %sigil_for; # Save the XML IDs for witnesses. |
33 | my %apps; # Save the apparatus XML for a given ID. |
6f4946fb |
34 | |
35 | sub parse { |
dfc37e38 |
36 | my( $tradition, $opts ) = @_; |
4d85a60e |
37 | my $c = $tradition->collation; # Some shorthand |
38 | |
39 | # First, parse the XML. |
40 | my $parser = XML::LibXML->new(); |
dfc37e38 |
41 | my $doc; |
42 | if( exists $opts->{'string'} ) { |
43 | $doc = $parser->parse_string( $opts->{'string'} ); |
44 | } elsif ( exists $opts->{'file'} ) { |
45 | $doc = $parser->parse_file( $opts->{'file'} ); |
46 | } else { |
47 | warn "Could not find string or file option to parse"; |
48 | return; |
49 | } |
4d85a60e |
50 | my $tei = $doc->documentElement(); |
51 | my $xpc = XML::LibXML::XPathContext->new( $tei ); |
52 | |
53 | # CTE uses a DTD rather than any xmlns-based parsing. Thus we |
54 | # need no namespace handling. |
55 | |
56 | # Get the witnesses and create the witness objects. |
57 | foreach my $wit_el ( $xpc->findnodes( '//sourceDesc/listWit/witness' ) ) { |
58 | # The witness xml:id is used internally, and is *not* the sigil name. |
59 | my $id= $wit_el->getAttribute( 'xml:id' ); |
60 | my @sig_parts = $xpc->findnodes( './abbr/descendant::text()', $wit_el ); |
61 | my $sig = _stringify_sigil( @sig_parts ); |
62 | $tradition->add_witness( sigil => $sig, source => $wit_el->toString() ); |
63 | $sigil_for{'#'.$id} = $sig; # Make life easy by keying on the ID ref syntax |
64 | } |
6f4946fb |
65 | |
4d85a60e |
66 | # Now go through the text and find the base tokens, apparatus tags, and |
67 | # anchors. Make a giant array of all of these things in sequence. |
68 | # TODO consider combining this with creation of graph below |
69 | my @base_text; |
70 | foreach my $pg_el ( $xpc->findnodes( '/TEI/text/body/p' ) ) { |
71 | foreach my $xn ( $pg_el->childNodes ) { |
72 | push( @base_text, _get_base( $xn ) ); |
73 | } |
6f4946fb |
74 | } |
4d85a60e |
75 | |
76 | # We now have to work through this array applying the alternate |
77 | # apparatus readings to the base text. Essentially we will put |
78 | # everything on the graph, from which we will delete the apps and |
79 | # anchors when we are done. |
80 | my $counter = 0; |
81 | my $last = $c->start; |
82 | foreach my $item ( @base_text ) { |
83 | my $r; |
84 | if( $item->{'type'} eq 'token' ) { |
85 | $r = $c->add_reading( 'n'.$counter++ ); |
86 | $r->text( $item->{'content'} ); |
87 | } elsif ( $item->{'type'} eq 'anchor' ) { |
88 | $r = $c->add_reading( '#ANCHOR_' . $item->{'content'} . '#' ); |
89 | } elsif ( $item->{'type'} eq 'app' ) { |
90 | my $tag = '#APP_' . $counter++ . '#'; |
91 | $r = $c->add_reading( $tag ); |
92 | $apps{$tag} = $item->{'content'}; |
93 | } |
94 | $c->add_path( $last, $r, 'BASE' ); |
95 | $last = $r; |
6f4946fb |
96 | } |
4d85a60e |
97 | $c->add_path( $last, $c->end, 'BASE' ); |
98 | |
99 | # Now we can parse the apparatus entries, and add the variant readings |
100 | # to the graph. |
101 | |
102 | foreach my $app_id ( keys %apps ) { |
103 | _add_readings( $c, $app_id ); |
6f4946fb |
104 | } |
4d85a60e |
105 | |
106 | # With the variant readings added, we now have to walk the graph for |
107 | # each witness and add an explicit path wherever there is not a divergence |
108 | # from BASE. Thus we will also construct $wit->path. |
109 | $DB::single = 1; |
110 | foreach my $wit ( $tradition->witnesses ) { |
111 | my $sig = $wit->sigil; |
112 | my @wit_path = $c->reading_sequence( $c->start, $c->end, $sig, 'BASE' ); |
113 | my $cur = $c->start; |
114 | foreach my $n ( @wit_path ) { |
115 | next if $cur eq $c->start; |
116 | my @paths = $cur->edges_to( $n ); |
117 | unless( grep { $_->name eq $sig } @paths ) { |
118 | $c->add_path( $cur, $n, $sig ); |
119 | } |
120 | } |
121 | $wit->path( \@wit_path ); |
122 | } |
123 | |
124 | # Collated readings are now on the graph, so now we get to remove |
125 | # all BASE edges and all app/anchor nodes. |
126 | foreach my $p ( $c->paths ) { |
127 | $c->del_path( $p ) if $p->name eq 'BASE'; |
128 | } |
129 | foreach my $n ( $c->readings ) { |
130 | if( $n->name =~ /^\#A(PP|NCHOR)/ ) { |
131 | # Pair up incoming / outgoing edges with the same label |
132 | my( %incoming, %outgoing ); |
133 | foreach my $e ( $n->incoming ) { |
134 | $incoming{$e->name} = $e->from; |
135 | $c->del_path( $e ); |
136 | } |
137 | foreach my $e ( $n->outgoing ) { |
138 | $outgoing{$e->name} = $e->to; |
139 | $c->del_path( $e ); |
140 | } |
141 | foreach my $w ( keys %incoming ) { |
142 | my $from = $incoming{$w}; |
143 | my $to = delete $outgoing{$w}; |
144 | warn "No outgoing edge on ".$n->name." for wit $w" unless $to; |
145 | $c->add_path( $from, $to, $w ); |
146 | } |
147 | foreach my $w ( keys %outgoing ) { |
148 | warn "Found no incoming edge on ".$n->name." for wit $w"; |
149 | } |
150 | $c->del_reading( $n ); |
151 | } |
6f4946fb |
152 | } |
153 | } |
154 | |
4d85a60e |
155 | sub _stringify_sigil { |
156 | my( @nodes ) = @_; |
157 | my @parts = grep { /\w/ } map { $_->data } @nodes; |
158 | return join( '', @parts ); |
159 | } |
6f4946fb |
160 | |
161 | ## Recursive little helper function to help us navigate through nested |
4d85a60e |
162 | ## XML, picking out the words, the apparatus, and the anchors. |
163 | |
164 | sub _get_base { |
165 | my( $xn ) = @_; |
166 | my @readings; |
167 | if( $xn->nodeType == XML_TEXT_NODE ) { |
168 | # Base text, just split the words on whitespace and add them |
169 | # to our sequence. |
170 | my $str = $xn->data; |
171 | $str =~ s/^\s+//; |
172 | foreach my $w ( split( /\s+/, $str ) ) { |
173 | push( @readings, { 'type' => 'token', 'content' => $w } ); |
174 | } |
175 | } elsif( $xn->nodeName eq 'hi' ) { |
176 | # Recurse as if the hi weren't there. |
177 | foreach( $xn->childNodes ) { |
178 | push( @readings, _get_base( $_ ) ); |
179 | } |
180 | } elsif( $xn->nodeName eq 'app' ) { |
181 | # Apparatus, just save the entire XML node. |
182 | push( @readings, { 'type' => 'app', 'content' => $xn } ); |
183 | } elsif( $xn->nodeName eq 'anchor' ) { |
184 | # Anchor to mark the end of some apparatus; save its ID. |
185 | push( @readings, { 'type' => 'anchor', |
186 | 'content' => $xn->getAttribute( 'xml:id' ) } ); |
187 | } elsif ( $xn->nodeName ne 'note' ) { # Any tag we don't know to disregard |
188 | print STDERR "Unrecognized tag " . $xn->nodeName . "\n"; |
6f4946fb |
189 | } |
4d85a60e |
190 | return @readings; |
6f4946fb |
191 | } |
192 | |
4d85a60e |
193 | sub _add_readings { |
194 | my( $c, $app_id ) = @_; |
195 | my $xn = $apps{$app_id}; |
196 | my $anchor = _anchor_name( $xn->getAttribute( 'to' ) ); |
197 | # Get the lemma, which is all the readings between app and anchor, |
198 | # excluding other apps or anchors. |
199 | my @lemma = _return_lemma( $c, $app_id, $anchor ); |
200 | my $lemma_str = join( ' ', grep { $_ !~ /^\#/ } map { $_->text } @lemma ); |
201 | |
202 | # For each reading, send its text to 'interpret' along with the lemma, |
203 | # and then save the list of witnesses that these tokens belong to. |
3a5d151b |
204 | my %wit_rdgs; # Maps from witnesses to the variant text |
205 | my %wit_details; # Maps from witnesses to the witness detail e.g. a.c. |
4d85a60e |
206 | my $ctr = 0; |
207 | my $tag = $app_id; |
208 | $tag =~ s/^\#APP_(.*)\#$/$1/; |
209 | foreach my $rdg ( $xn->getChildrenByTagName( 'rdg' ) ) { |
210 | my @text; |
211 | my $wits = $rdg->getAttribute( 'wit' ); |
212 | foreach ( $rdg->childNodes ) { |
213 | push( @text, _get_base( $_ ) ); |
214 | } |
215 | my $interpreted = @text |
216 | ? interpret( join( ' ', map { $_->{'content'} } @text ), $lemma_str ) |
217 | : ''; |
218 | my @rdg_nodes; |
219 | foreach my $w ( split( /\s+/, $interpreted ) ) { |
220 | my $r = $c->add_reading( $tag . "/" . $ctr++ ); |
221 | $r->text( $w ); |
222 | push( @rdg_nodes, $r ); |
223 | } |
224 | $wit_rdgs{$wits} = \@rdg_nodes; |
3a5d151b |
225 | # Does the reading have an ID? If so it probably has a witDetail |
226 | # attached, and that may be something we need to know. For now, |
227 | # save the reading ID. |
228 | if( $rdg->hasAttribute( 'xml:id' ) ) { |
229 | $wit_details{$wits} = $rdg->getAttribute( 'xml:id' ); |
230 | } |
6f4946fb |
231 | } |
3a5d151b |
232 | # Now go through the available witDetails and, er, do something |
233 | # foreach my $d ( $xn->getChildrenByTagName( 'witDetail' ) ) { |
234 | # my $referent = |
4d85a60e |
235 | |
236 | # Now collate the variant readings, since it is not done for us. |
237 | collate_variants( $c, \@lemma, values %wit_rdgs ); |
238 | |
239 | # Now add the witness paths for each reading. |
240 | foreach my $wit_str ( keys %wit_rdgs ) { |
241 | my @wits = get_sigla( $wit_str ); |
242 | my $rdg_list = $wit_rdgs{$wit_str}; |
243 | _add_wit_path( $c, $rdg_list, $app_id, $anchor, @wits ); |
6f4946fb |
244 | } |
4d85a60e |
245 | } |
6f4946fb |
246 | |
4d85a60e |
247 | sub _anchor_name { |
248 | my $xmlid = shift; |
249 | $xmlid =~ s/^\#//; |
250 | return sprintf( "#ANCHOR_%s#", $xmlid ); |
6f4946fb |
251 | } |
252 | |
4d85a60e |
253 | sub _return_lemma { |
254 | my( $c, $app, $anchor ) = @_; |
255 | my $app_node = $c->graph->node( $app ); |
256 | my $anchor_node = $c->graph->node( $anchor ); |
257 | my @nodes = grep { $_->name !~ /^\#A(PP|NCHOR)$/ } |
258 | $c->reading_sequence( $app_node, $anchor_node, 'BASE' ); |
259 | return @nodes; |
260 | } |
6f4946fb |
261 | |
262 | sub interpret { |
4d85a60e |
263 | # A utility function to change apparatus-ese into a full variant. |
264 | my( $reading, $lemma ) = @_; |
265 | return $reading if $reading eq $lemma; |
266 | my $oldreading = $reading; |
267 | # $lemma =~ s/\s+[[:punct:]]+$//; |
268 | # $reading =~ s/\s*\(?sic([\s\w.]+)?\)?$//; |
269 | my @words = split( /\s+/, $lemma ); |
270 | if( $reading =~ /^(.*) praem.$/ ) { |
271 | $reading = "$1 $lemma"; |
272 | } elsif( $reading =~ /^(.*) add.$/ ) { |
273 | $reading = "$lemma $1"; |
274 | } elsif( $reading eq 'om.' ) { |
275 | $reading = ''; |
276 | } elsif( $reading eq 'inv.' ) { |
277 | # Hope it is two words. |
278 | print STDERR "WARNING: want to invert a lemma that is not two words\n" |
279 | unless scalar( @words ) == 2; |
280 | $reading = join( ' ', reverse( @words ) ); |
281 | } elsif( $reading eq 'iter.' ) { |
282 | # Repeat the lemma |
283 | $reading = "$lemma $lemma"; |
284 | } elsif( $reading =~ /^(.*) \.\.\. (.*)$/ ) { |
285 | # The first and last N words captured should replace the first and |
286 | # last N words of the lemma. |
287 | my @begin = split( /\s+/, $1 ); |
288 | my @end = split( /\s+/, $2 ); |
289 | if( scalar( @begin ) + scalar ( @end ) > scalar( @words ) ) { |
290 | # Something is wrong and we can't do the splice. |
291 | print STDERR "ERROR: $lemma is too short to accommodate $oldreading\n"; |
292 | } else { |
293 | splice( @words, 0, scalar @begin, @begin ); |
294 | splice( @words, -(scalar @end), scalar @end, @end ); |
295 | $reading = join( ' ', @words ); |
296 | } |
6f4946fb |
297 | } |
4d85a60e |
298 | print STDERR "Interpreted $oldreading as $reading given $lemma\n"; |
299 | return $reading; |
300 | } |
301 | |
302 | sub get_sigla { |
303 | my $witstr = shift; |
304 | my @xml_ids = split( /\s+/, $witstr ); |
305 | my @sigs = map { $sigil_for{$_} } @xml_ids; |
306 | return @sigs; |
307 | } |
308 | |
309 | sub _add_wit_path { |
310 | my( $c, $rdg, $app, $anchor, @wits ) = @_; |
311 | my @nodes = @$rdg; |
312 | push( @nodes, $c->graph->node( $anchor ) ); |
313 | |
314 | my $cur = $c->graph->node( $app ); |
315 | foreach my $n ( @nodes ) { |
316 | foreach my $w ( @wits ) { |
317 | $c->add_path( $cur, $n, $w ); |
318 | } |
319 | $cur = $n; |
6f4946fb |
320 | } |
6f4946fb |
321 | } |
322 | |
323 | =back |
324 | |
325 | =head1 LICENSE |
326 | |
327 | This package is free software and is provided "as is" without express |
328 | or implied warranty. You can redistribute it and/or modify it under |
329 | the same terms as Perl itself. |
330 | |
331 | =head1 AUTHOR |
332 | |
333 | Tara L Andrews, aurum@cpan.org |
334 | |
335 | =cut |
336 | |
337 | 1; |
338 | |