Commit | Line | Data |
6f4946fb |
1 | package Text::Tradition::Parser::CTE; |
2 | |
3 | use strict; |
4 | use warnings; |
a188b944 |
5 | use feature 'say'; |
c9158e60 |
6 | use Encode qw/ decode /; |
00311328 |
7 | use Text::Tradition::Error; |
4d85a60e |
8 | use Text::Tradition::Parser::Util qw/ collate_variants /; |
6f4946fb |
9 | use XML::LibXML; |
10 | use XML::LibXML::XPathContext; |
f60f9e0f |
11 | use TryCatch; |
6f4946fb |
12 | |
13 | =head1 NAME |
14 | |
15 | Text::Tradition::Parser::CTE |
16 | |
17 | =head1 DESCRIPTION |
18 | |
19 | Parser module for Text::Tradition, given a TEI file exported from |
20 | Classical Text Editor. |
21 | |
22 | =head1 METHODS |
23 | |
a445ce40 |
24 | =head2 parse |
6f4946fb |
25 | |
26 | my @apparatus = read( $xml_file ); |
27 | |
28 | Takes a Tradition object and a TEI file exported from Classical Text |
4d85a60e |
29 | Editor using double-endpoint-attachment critical apparatus encoding; |
30 | initializes the Tradition from the file. |
6f4946fb |
31 | |
32 | =cut |
33 | |
4d85a60e |
34 | my %sigil_for; # Save the XML IDs for witnesses. |
35 | my %apps; # Save the apparatus XML for a given ID. |
f6e19c7c |
36 | my %has_ac; # Keep track of witnesses that have corrections. |
6f4946fb |
37 | |
38 | sub parse { |
dfc37e38 |
39 | my( $tradition, $opts ) = @_; |
4d85a60e |
40 | my $c = $tradition->collation; # Some shorthand |
41 | |
e9442e1c |
42 | ## DEBUG/TEST |
43 | $opts->{interpret_transposition} = 1; |
44 | |
4d85a60e |
45 | # First, parse the XML. |
c9158e60 |
46 | my( $tei, $xpc ) = _remove_formatting( $opts ); |
47 | return unless $tei; # we have already warned. |
4d85a60e |
48 | |
49 | # CTE uses a DTD rather than any xmlns-based parsing. Thus we |
50 | # need no namespace handling. |
4d85a60e |
51 | # Get the witnesses and create the witness objects. |
52 | foreach my $wit_el ( $xpc->findnodes( '//sourceDesc/listWit/witness' ) ) { |
53 | # The witness xml:id is used internally, and is *not* the sigil name. |
54 | my $id= $wit_el->getAttribute( 'xml:id' ); |
92de40a6 |
55 | # If the witness element has an abbr element, that is the sigil. Otherwise |
56 | # the whole thing is the sigil. |
57 | my $sig = $xpc->findvalue( 'abbr', $wit_el ); |
58 | my $identifier = 'CTE witness'; |
59 | if( $sig ) { |
60 | # The sigil is what is in the <abbr/> tag; the identifier is anything |
61 | # that follows. |
62 | $identifier = _tidy_identifier( |
63 | $xpc->findvalue( 'child::text()', $wit_el ) ); |
64 | } else { |
65 | my @sig_parts = $xpc->findnodes( 'descendant::text()', $wit_el ); |
66 | $sig = _stringify_sigil( @sig_parts ); |
67 | } |
68 | say STDERR "Adding witness $sig ($identifier)"; |
69 | $tradition->add_witness( sigil => $sig, identifier => $identifier, |
70 | sourcetype => 'collation' ); |
b8f262e8 |
71 | $sigil_for{'#'.$id} = $sig; # Make life easy by keying on the ID ref syntax |
4d85a60e |
72 | } |
c9158e60 |
73 | |
4d85a60e |
74 | # Now go through the text and find the base tokens, apparatus tags, and |
75 | # anchors. Make a giant array of all of these things in sequence. |
76 | # TODO consider combining this with creation of graph below |
77 | my @base_text; |
78 | foreach my $pg_el ( $xpc->findnodes( '/TEI/text/body/p' ) ) { |
79 | foreach my $xn ( $pg_el->childNodes ) { |
82a45078 |
80 | push( @base_text, _get_base( $xn ) ); |
4d85a60e |
81 | } |
6f4946fb |
82 | } |
4d85a60e |
83 | # We now have to work through this array applying the alternate |
84 | # apparatus readings to the base text. Essentially we will put |
85 | # everything on the graph, from which we will delete the apps and |
86 | # anchors when we are done. |
f6e19c7c |
87 | |
9e0a9786 |
88 | # First, put the base tokens, apps, and anchors in the graph. Save the |
89 | # app siglorum separately as it has to be processed in order. |
90 | my @app_sig; |
876c951d |
91 | my @app_crit; |
4d85a60e |
92 | my $counter = 0; |
93 | my $last = $c->start; |
94 | foreach my $item ( @base_text ) { |
95 | my $r; |
96 | if( $item->{'type'} eq 'token' ) { |
12720144 |
97 | $r = $c->add_reading( { id => 'n'.$counter++, |
98 | text => $item->{'content'} } ); |
4d85a60e |
99 | } elsif ( $item->{'type'} eq 'anchor' ) { |
10e4b1ac |
100 | $r = $c->add_reading( { id => '__ANCHOR_' . $item->{'content'} . '__', |
12720144 |
101 | is_ph => 1 } ); |
4d85a60e |
102 | } elsif ( $item->{'type'} eq 'app' ) { |
10e4b1ac |
103 | my $tag = '__APP_' . $counter++ . '__'; |
12720144 |
104 | $r = $c->add_reading( { id => $tag, is_ph => 1 } ); |
f60f9e0f |
105 | my $app = $item->{'content'}; |
876c951d |
106 | $apps{$tag} = $app; |
f60f9e0f |
107 | # Apparatus should be differentiable by type attribute; apparently |
108 | # it is not. Peek at the content to categorize it. |
9e0a9786 |
109 | # Apparatus criticus is type a1; app siglorum is type a2 |
93a44639 |
110 | my @sigtags = $xpc->findnodes( 'descendant::*[name(witStart) or name(witEnd)]', $app ); |
f60f9e0f |
111 | if( @sigtags ) { |
876c951d |
112 | push( @app_sig, $tag ); |
9e0a9786 |
113 | } else { |
876c951d |
114 | push( @app_crit, $tag ); |
9e0a9786 |
115 | } |
4d85a60e |
116 | } |
f6e19c7c |
117 | $c->add_path( $last, $r, $c->baselabel ); |
4d85a60e |
118 | $last = $r; |
6f4946fb |
119 | } |
f6e19c7c |
120 | $c->add_path( $last, $c->end, $c->baselabel ); |
4d85a60e |
121 | |
122 | # Now we can parse the apparatus entries, and add the variant readings |
123 | # to the graph. |
876c951d |
124 | foreach my $app_id ( @app_crit ) { |
e9442e1c |
125 | _add_readings( $c, $app_id, $opts ); |
6f4946fb |
126 | } |
93a44639 |
127 | _add_lacunae( $c, @app_sig ); |
4d85a60e |
128 | |
f6e19c7c |
129 | # Finally, add explicit witness paths, remove the base paths, and remove |
130 | # the app/anchor tags. |
dead25ca |
131 | try { |
132 | _expand_all_paths( $c ); |
f60f9e0f |
133 | } catch( Text::Tradition::Error $e ) { |
134 | throw( $e->message ); |
135 | } catch { |
136 | throw( $@ ); |
dead25ca |
137 | } |
861c3e27 |
138 | |
139 | # Save the text for each witness so that we can ensure consistency |
140 | # later on |
a188b944 |
141 | unless( $opts->{'nocalc'} ) { |
dead25ca |
142 | try { |
143 | $tradition->collation->text_from_paths(); |
144 | $tradition->collation->calculate_ranks(); |
145 | $tradition->collation->flatten_ranks(); |
f60f9e0f |
146 | } catch( Text::Tradition::Error $e ) { |
147 | throw( $e->message ); |
148 | } catch { |
149 | throw( $@ ); |
dead25ca |
150 | } |
a188b944 |
151 | } |
6f4946fb |
152 | } |
153 | |
4d85a60e |
154 | sub _stringify_sigil { |
155 | my( @nodes ) = @_; |
156 | my @parts = grep { /\w/ } map { $_->data } @nodes; |
222d58f1 |
157 | my $whole = join( '', @parts ); |
158 | $whole =~ s/\W//g; |
159 | return $whole; |
4d85a60e |
160 | } |
6f4946fb |
161 | |
92de40a6 |
162 | sub _tidy_identifier { |
163 | my( $str ) = @_; |
164 | $str =~ s/^\W+//; |
165 | return $str; |
166 | } |
167 | |
c9158e60 |
168 | # Get rid of all the formatting elements that get in the way of tokenization. |
169 | sub _remove_formatting { |
170 | my( $opts ) = @_; |
171 | |
172 | # First, parse the original XML |
173 | my $parser = XML::LibXML->new(); |
174 | my $doc; |
175 | if( exists $opts->{'string'} ) { |
176 | $doc = $parser->parse_string( $opts->{'string'} ); |
177 | } elsif ( exists $opts->{'file'} ) { |
178 | $doc = $parser->parse_file( $opts->{'file'} ); |
dead25ca |
179 | } elsif ( exists $opts->{'xmlobj'} ) { |
180 | $doc = $opts->{'xmlobj'}; |
c9158e60 |
181 | } else { |
182 | warn "Could not find string or file option to parse"; |
183 | return; |
184 | } |
00311328 |
185 | |
c9158e60 |
186 | # Second, remove the formatting |
187 | my $xpc = XML::LibXML::XPathContext->new( $doc->documentElement ); |
188 | my @useless = $xpc->findnodes( '//hi' ); |
189 | foreach my $n ( @useless ) { |
190 | my $parent = $n->parentNode(); |
191 | my @children = $n->childNodes(); |
192 | my $first = shift @children; |
7c2ed85e |
193 | if( $first ) { |
194 | $parent->replaceChild( $first, $n ); |
195 | foreach my $c ( @children ) { |
196 | $parent->insertAfter( $c, $first ); |
197 | $first = $c; |
198 | } |
199 | } else { |
200 | $parent->removeChild( $n ); |
c9158e60 |
201 | } |
202 | } |
203 | |
204 | # Third, write out and reparse to merge the text nodes. |
00311328 |
205 | my $enc = $doc->encoding || 'UTF-8'; |
206 | my $result = decode( $enc, $doc->toString() ); |
c9158e60 |
207 | my $tei = $parser->parse_string( $result )->documentElement; |
00311328 |
208 | unless( $tei->nodeName =~ /^tei(corpus)?$/i ) { |
209 | throw( "Parsed document has non-TEI root element " . $tei->nodeName ); |
210 | } |
c9158e60 |
211 | $xpc = XML::LibXML::XPathContext->new( $tei ); |
212 | return( $tei, $xpc ); |
213 | } |
214 | |
215 | ## Helper function to help us navigate through nested XML, picking out |
216 | ## the words, the apparatus, and the anchors. |
4d85a60e |
217 | |
218 | sub _get_base { |
219 | my( $xn ) = @_; |
220 | my @readings; |
221 | if( $xn->nodeType == XML_TEXT_NODE ) { |
222 | # Base text, just split the words on whitespace and add them |
223 | # to our sequence. |
224 | my $str = $xn->data; |
225 | $str =~ s/^\s+//; |
c9158e60 |
226 | my @tokens = split( /\s+/, $str ); |
92de40a6 |
227 | push( @readings, map { { type => 'token', content => $_ } } @tokens ); |
4d85a60e |
228 | } elsif( $xn->nodeName eq 'app' ) { |
229 | # Apparatus, just save the entire XML node. |
92de40a6 |
230 | push( @readings, { type => 'app', content => $xn } ); |
4d85a60e |
231 | } elsif( $xn->nodeName eq 'anchor' ) { |
232 | # Anchor to mark the end of some apparatus; save its ID. |
82a45078 |
233 | if( $xn->hasAttribute('xml:id') ) { |
92de40a6 |
234 | push( @readings, { type => 'anchor', |
235 | content => $xn->getAttribute( 'xml:id' ) } ); |
82a45078 |
236 | } # if the anchor has no XML ID, it is not relevant to us. |
93a44639 |
237 | } elsif( $xn->nodeName !~ /^(note|seg|milestone|emph)$/ ) { # Any tag we don't know to disregard |
a188b944 |
238 | say STDERR "Unrecognized tag " . $xn->nodeName; |
6f4946fb |
239 | } |
4d85a60e |
240 | return @readings; |
6f4946fb |
241 | } |
242 | |
c9158e60 |
243 | sub _append_tokens { |
244 | my( $list, @tokens ) = @_; |
245 | if( @$list && $list->[-1]->{'content'} =~ /\#JOIN\#$/ ) { |
246 | # The list evidently ended mid-word; join the next token onto it. |
247 | my $t = shift @tokens; |
248 | if( ref $t && $t->{'type'} eq 'token' ) { |
249 | # Join the word |
250 | $t = $t->{'content'}; |
251 | } elsif( ref $t ) { |
252 | # An app or anchor intervened; end the word. |
253 | unshift( @tokens, $t ); |
254 | $t = ''; |
255 | } |
256 | $list->[-1]->{'content'} =~ s/\#JOIN\#$/$t/; |
257 | } |
258 | foreach my $t ( @tokens ) { |
259 | unless( ref( $t ) ) { |
260 | $t = { 'type' => 'token', 'content' => $t }; |
261 | } |
262 | push( @$list, $t ); |
263 | } |
264 | } |
265 | |
4d85a60e |
266 | sub _add_readings { |
e9442e1c |
267 | my( $c, $app_id, $opts ) = @_; |
4d85a60e |
268 | my $xn = $apps{$app_id}; |
9e0a9786 |
269 | my $anchor = _anchor_name( $xn->getAttribute( 'to' ) ); |
92de40a6 |
270 | |
93a44639 |
271 | # Get the lemma, which is all the readings between app and anchor, |
272 | # excluding other apps or anchors. |
273 | my @lemma = _return_lemma( $c, $app_id, $anchor ); |
274 | |
4d85a60e |
275 | # For each reading, send its text to 'interpret' along with the lemma, |
276 | # and then save the list of witnesses that these tokens belong to. |
3a5d151b |
277 | my %wit_rdgs; # Maps from witnesses to the variant text |
4d85a60e |
278 | my $ctr = 0; |
279 | my $tag = $app_id; |
10e4b1ac |
280 | $tag =~ s/^\__APP_(.*)\__$/$1/; |
c9158e60 |
281 | |
4d85a60e |
282 | foreach my $rdg ( $xn->getChildrenByTagName( 'rdg' ) ) { |
c9f61c70 |
283 | # Get the relevant witnesses. |
93a44639 |
284 | my @witlist = map { $sigil_for{$_} } |
285 | split( /\s+/, $rdg->getAttribute( 'wit' ) ); |
c9f61c70 |
286 | |
3a5d151b |
287 | # Does the reading have an ID? If so it probably has a witDetail |
a5978ac8 |
288 | # attached, and we need to read it. If an A.C. or P.C. reading is |
289 | # declared explicity, this is where it will be dealt with. |
3a5d151b |
290 | if( $rdg->hasAttribute( 'xml:id' ) ) { |
f6e19c7c |
291 | my $rid = $rdg->getAttribute( 'xml:id' ); |
292 | my $xpc = XML::LibXML::XPathContext->new( $xn ); |
293 | my @details = $xpc->findnodes( './witDetail[@target="'.$rid.'"]' ); |
294 | foreach my $d ( @details ) { |
c9f61c70 |
295 | @witlist = _parse_wit_detail( $d, @witlist ); |
f6e19c7c |
296 | } |
3a5d151b |
297 | } |
c9f61c70 |
298 | |
299 | # Now we have our list of relevant witnesses for the reading, annotated |
300 | # with AC or PC if applicable. Interpret the reading in light of the |
301 | # lemma, anything we already have for the witness, etc. |
302 | # If an A.C. or P.C. reading is implied rather than explicitly noted, |
303 | # this is where it will be dealt with. |
304 | |
305 | foreach my $wit ( @witlist ) { |
93a44639 |
306 | # The lemma for this witness is either the actual lemma, or the |
307 | # reading that we have already determined. |
308 | my $hascorr; |
c9f61c70 |
309 | if( $wit =~ /^(.*)_pc$/ ) { |
93a44639 |
310 | $wit = $1; |
311 | $hascorr = 1; |
c9f61c70 |
312 | } |
93a44639 |
313 | ## TODO think through ac/pc interaction from these specs |
314 | my $wit_lemma = $wit_rdgs{$wit} || \@lemma; |
315 | my @rdg_nodes; |
316 | ( $wit, @rdg_nodes )= _read_reading( $rdg, $wit_lemma, $wit, |
317 | $tag, $ctr, $anchor, $opts ); |
c9f61c70 |
318 | $wit_rdgs{$wit} = \@rdg_nodes; |
93a44639 |
319 | # If the PC flag is set, there is a corresponding AC that |
320 | # follows the lemma and has to be explicitly declared. |
321 | if( $flag->{'PC'} ) { |
322 | $wit_rdgs{$wit.'_ac'} = $wit_lemma; |
323 | } |
c9f61c70 |
324 | } |
f6e19c7c |
325 | } |
93a44639 |
326 | |
4d85a60e |
327 | # Now collate the variant readings, since it is not done for us. |
93a44639 |
328 | collate_variants( $c, \@lemma, values %wit_rdgs ); |
b8f262e8 |
329 | |
c9f61c70 |
330 | # Now add the witness paths for each reading. |
9e0a9786 |
331 | foreach my $wit_id ( keys %wit_rdgs ) { |
93a44639 |
332 | my $witstr = _get_sigil( $wit_id, $c->ac_label ); |
9e0a9786 |
333 | my $rdg_list = $wit_rdgs{$wit_id}; |
93a44639 |
334 | _add_wit_path( $c, $rdg_list, $app_id, $anchor, $witstr ); |
92de40a6 |
335 | } |
4d85a60e |
336 | } |
6f4946fb |
337 | |
4d85a60e |
338 | sub _anchor_name { |
339 | my $xmlid = shift; |
340 | $xmlid =~ s/^\#//; |
10e4b1ac |
341 | return sprintf( "__ANCHOR_%s__", $xmlid ); |
6f4946fb |
342 | } |
343 | |
4d85a60e |
344 | sub _return_lemma { |
93a44639 |
345 | my( $c, $app, $anchor ) = @_; |
10e4b1ac |
346 | my @nodes = grep { $_->id !~ /^__A(PP|NCHOR)/ } |
93a44639 |
347 | $c->reading_sequence( $c->reading( $app ), $c->reading( $anchor ), |
348 | $c->baselabel ); |
4d85a60e |
349 | return @nodes; |
350 | } |
6f4946fb |
351 | |
c9f61c70 |
352 | sub _parse_wit_detail { |
93a44639 |
353 | my $detail = shift; |
354 | my %wits; |
355 | map { $wits{$_} = $_ } @_; |
356 | my @changewits = map { $sigil_for{$_} } |
357 | split( /\s+/, $detail->getAttribute( 'wit' ) ); |
c9f61c70 |
358 | my $content = $detail->textContent; |
359 | if( $content =~ /^a\.?\s*c(orr)?\.$/ ) { |
93a44639 |
360 | # Replace the key in the $readings hash |
361 | map { $wits{$_} = $_.'_ac' } @changewits; |
c9f61c70 |
362 | } elsif( $content =~ /^p\.?\s*c(orr)?\.$/ || $content =~ /^s\.?\s*l\.$/ |
363 | || $content =~ /^in marg\.?$/ ) { |
93a44639 |
364 | # If no key for the wit a.c. exists, add one pointing to the lemma |
365 | map { $wits{$_} = $_.'_pc' } @changewits; |
c9f61c70 |
366 | } else { #...not sure what it is? |
367 | say STDERR "WARNING: Unrecognized sigil annotation $content"; |
368 | } |
93a44639 |
369 | my @newwits = sort values %wits; |
370 | return @newwits; |
c9f61c70 |
371 | } |
372 | |
373 | sub _read_reading { |
93a44639 |
374 | my( $rdg, $lemma, $witness, $tag, $ctr, $anchor, $opts ) = @_; |
c9f61c70 |
375 | |
376 | # Get the text of the lemma. |
377 | my $lemma_str = join( ' ', map { $_->text } grep { !$_->is_ph } @$lemma ); |
378 | |
379 | my @text; |
380 | foreach ( $rdg->childNodes ) { |
381 | push( @text, _get_base( $_ ) ); |
382 | } |
383 | my( $interpreted, $flag ) = ( '', undef ); |
384 | if( @text ) { |
385 | ( $interpreted, $flag ) = interpret( |
386 | join( ' ', map { $_->{'content'} } @text ), $lemma_str, $anchor, $opts ); |
387 | } |
388 | if( ( $interpreted eq $lemma_str || $interpreted eq '__LEMMA__' ) |
389 | && !keys %$flag ) { |
390 | # The reading is the lemma. Pass it back. |
93a44639 |
391 | return( $wit, @$lemma ); |
c9f61c70 |
392 | } |
393 | |
394 | my @rdg_nodes; |
395 | if( $interpreted eq '#LACUNA#' ) { |
93a44639 |
396 | push( @rdg_nodes, $c->add_reading( { id => 'r'.$tag.".".$ctr++, |
c9f61c70 |
397 | is_lacuna => 1 } ) ); |
398 | } elsif( $flag->{'TR'} ) { |
399 | # Our reading is transposed to after the given string. Look |
400 | # down the collation base text and try to find it. |
401 | # The @rdg_nodes should remain blank here, so that the correct |
402 | # omission goes into the graph. |
403 | my @transp_nodes; |
404 | foreach my $w ( split( /\s+/, $interpreted ) ) { |
93a44639 |
405 | my $r = $c->add_reading( { id => 'r'.$tag.".".$ctr++, |
c9f61c70 |
406 | text => $w } ); |
407 | push( @transp_nodes, $r ); |
408 | } |
93a44639 |
409 | if( $anchor && @lemma ) { |
410 | my $success = _attach_transposition( $c, $lemma, $anchor, |
411 | \@transp_nodes, $witlist, $flag->{'TR'} ); |
c9f61c70 |
412 | unless( $success ) { |
413 | # If we didn't manage to insert the displaced reading, |
414 | # then restore it here rather than silently deleting it. |
415 | push( @rdg_nodes, @transp_nodes ); |
416 | } |
417 | } |
418 | } else { |
419 | foreach my $w ( split( /\s+/, $interpreted ) ) { |
420 | if( $w eq '__LEMMA__' ) { |
93a44639 |
421 | push( @rdg_nodes, @lemma ); |
c9f61c70 |
422 | } else { |
93a44639 |
423 | my $r = $c->add_reading( { id => 'r'.$tag.".".$ctr++, |
c9f61c70 |
424 | text => $w } ); |
93a44639 |
425 | push( @rdg_nodes, $r ); |
c9f61c70 |
426 | } |
427 | } |
428 | } |
429 | |
93a44639 |
430 | # Note if the interpretation said that we're dealing with a correction. |
431 | if( $flag->{'AC'} ) { |
432 | $wit .= '_ac'; |
433 | } elsif( $flag->{'PC'} ) { |
434 | $wit .= '_pc'; |
435 | } |
436 | return( $wit, @rdg_nodes ); |
437 | } |
438 | |
439 | # Make a best-effort attempt to attach a transposition farther down the line. |
440 | # $lemmaseq contains the Reading objects of the lemma |
441 | # $anchor contains the point at which we should start scanning for a match |
442 | # $rdgseq contains the Reading objects of the transposed reading |
443 | # (should be identical to the lemma) |
444 | # $witlist contains the list of applicable witnesses |
445 | # $reftxt contains the text to match, after which the $rdgseq should go. |
446 | sub _attach_transposition { |
447 | my( $c, $lemmaseq, $anchor, $rdgseq, $witlist, $reftxt ) = @_; |
448 | my @refwords = split( /\s+/, $reftxt ); |
449 | my $checked = $c->reading( $anchor ); |
450 | my $found; |
451 | my $success; |
452 | while( $checked ne $c->end && !$found ) { |
453 | my $next = $c->next_reading( $checked, $c->baselabel ); |
454 | if( $next->text eq $refwords[0] ) { |
455 | # See if the entire sequence of words matches. |
456 | $found = $next; |
457 | foreach my $w ( 1..$#refwords ) { |
458 | $found = $c->next_reading( $next, $c->baselabel ); |
459 | unless( $found->text eq $refwords[$w] ) { |
460 | $found = undef; |
461 | last; |
462 | } |
463 | } |
464 | } |
465 | $checked = $next; |
466 | } |
467 | if( $found ) { |
468 | # The $found variable should now contain the reading after which we |
469 | # should stick the transposition. |
470 | my $fnext = $c->next_reading( $found, $c->baselabel ); |
471 | my $aclabel = $c->ac_label; |
472 | foreach my $wit_id ( @$witlist ) { |
473 | my $witstr = _get_sigil( $wit_id, $aclabel ); |
474 | _add_wit_path( $c, $rdgseq, $found->id, $fnext->id, $witstr ); |
475 | } |
476 | # ...and add the transposition relationship between lemma and rdgseq. |
477 | if( @$lemmaseq == @$rdgseq ) { |
478 | foreach my $i ( 0..$#{$lemmaseq} ) { |
479 | $c->add_relationship( $lemmaseq->[$i], $rdgseq->[$i], |
480 | { type => 'transposition', annotation => 'Detected by CTE' } ); |
481 | } |
482 | $success = 1; |
483 | } else { |
484 | throw( "Lemma at $found and transposed sequence different lengths?!" ); |
485 | } |
486 | } else { |
487 | say STDERR "WARNING: Unable to find $reftxt in base text for transposition"; |
488 | } |
489 | return $success; |
e9442e1c |
490 | } |
491 | |
a445ce40 |
492 | =head2 interpret( $reading, $lemma ) |
493 | |
494 | Given a string in $reading and a corresponding lemma in $lemma, interpret what |
495 | the actual reading should be. Used to deal with apparatus-ese shorthands for |
496 | marking transpositions, prefixed or suffixed words, and the like. |
497 | |
498 | =cut |
499 | |
6f4946fb |
500 | sub interpret { |
4d85a60e |
501 | # A utility function to change apparatus-ese into a full variant. |
e9442e1c |
502 | my( $reading, $lemma, $anchor, $opts ) = @_; |
4d85a60e |
503 | return $reading if $reading eq $lemma; |
504 | my $oldreading = $reading; |
505 | # $lemma =~ s/\s+[[:punct:]]+$//; |
e9442e1c |
506 | my $flag = {}; # To pass back extra info about the interpretation |
4d85a60e |
507 | my @words = split( /\s+/, $lemma ); |
f9ffe014 |
508 | # Discard any 'sic' notation - that rather goes without saying. |
a5978ac8 |
509 | $reading =~ s/([[:punct:]]+)?sic([[:punct:]]+)?//g; |
f9ffe014 |
510 | |
c9f61c70 |
511 | # Look to see if there is an implied add or praem masked by the XML. |
512 | # If so, undo it for purposes of reading identity. |
513 | $reading =~ s/^$lemma\b/__LEMMA__/; |
514 | $reading =~ s/\b$lemma$/__LEMMA__/; |
515 | |
f9ffe014 |
516 | # Now look for common jargon. |
517 | if( $reading =~ /^(.*) praem.$/ || $reading =~ /^praem\. (.*)$/ ) { |
c9f61c70 |
518 | $reading = "$1 __LEMMA__"; |
f9ffe014 |
519 | } elsif( $reading =~ /^(.*) add.$/ || $reading =~ /^add\. (.*)$/ ) { |
c9f61c70 |
520 | $reading = "__LEMMA__ $1"; |
b8f262e8 |
521 | } elsif( $reading =~ /locus [uv]acuus/ |
522 | || $reading eq 'def.' |
c9158e60 |
523 | || $reading eq 'illeg.' |
a5978ac8 |
524 | || $reading eq 'desunt' |
f6e19c7c |
525 | ) { |
b8f262e8 |
526 | $reading = '#LACUNA#'; |
527 | } elsif( $reading eq 'om.' ) { |
4d85a60e |
528 | $reading = ''; |
c9158e60 |
529 | } elsif( $reading =~ /^in[uv]\.$/ |
a5978ac8 |
530 | || $reading =~ /^tr(ans(p)?)?\.$/ ) { |
4d85a60e |
531 | # Hope it is two words. |
a188b944 |
532 | say STDERR "WARNING: want to invert a lemma that is not two words" |
4d85a60e |
533 | unless scalar( @words ) == 2; |
534 | $reading = join( ' ', reverse( @words ) ); |
12720144 |
535 | } elsif( $reading =~ /^iter(\.|at)$/ ) { |
4d85a60e |
536 | # Repeat the lemma |
c9f61c70 |
537 | $reading = "__LEMMA__ $lemma"; |
a5978ac8 |
538 | } elsif( $reading =~ /^(.*?)\s*\(?in marg\.\)?$/ ) { |
539 | $reading = $1; |
540 | if( $reading ) { |
541 | # The given text is a correction. |
542 | $flag->{'PC'} = 1; |
543 | } else { |
544 | # The lemma itself was the correction; the witness carried |
545 | # no reading pre-correction. |
546 | $flag->{'AC'} = 1; |
547 | } |
12720144 |
548 | } elsif( $reading =~ /^(.*) \.\.\. (.*)$/ ) { |
4d85a60e |
549 | # The first and last N words captured should replace the first and |
550 | # last N words of the lemma. |
551 | my @begin = split( /\s+/, $1 ); |
552 | my @end = split( /\s+/, $2 ); |
553 | if( scalar( @begin ) + scalar ( @end ) > scalar( @words ) ) { |
554 | # Something is wrong and we can't do the splice. |
dead25ca |
555 | throw( "$lemma is too short to accommodate $oldreading" ); |
4d85a60e |
556 | } else { |
557 | splice( @words, 0, scalar @begin, @begin ); |
558 | splice( @words, -(scalar @end), scalar @end, @end ); |
559 | $reading = join( ' ', @words ); |
560 | } |
e9442e1c |
561 | } elsif( $opts->{interpret_transposition} && |
a5978ac8 |
562 | ( $reading =~ /^post\s*(?<lem>.*?)\s+tr(ans(p)?)?\.$/ || |
563 | $reading =~ /^tr(ans(p)?)?\. post\s*(?<lem>.*)$/) ) { |
e9442e1c |
564 | # Try to deal with transposed readings |
565 | ## DEBUG |
566 | say STDERR "Will attempt transposition: $reading at $anchor"; |
c9f61c70 |
567 | # Copy the lemma into the reading string for insertion later |
568 | # in the text. |
e9442e1c |
569 | $reading = $lemma; |
a5978ac8 |
570 | $flag->{'TR'} = $+{lem}; |
12720144 |
571 | } |
572 | return( $reading, $flag ); |
4d85a60e |
573 | } |
574 | |
9e0a9786 |
575 | sub _add_lacunae { |
93a44639 |
576 | my( $c, @app_id ) = @_; |
9e0a9786 |
577 | # Go through the apparatus entries in order, noting where to start and stop our |
578 | # various witnesses. |
579 | my %lacunose; |
93a44639 |
580 | my $ctr = 0; |
581 | foreach my $tag ( @app_id ) { |
582 | my $app = $apps{$tag}; |
583 | # Find the anchor, if any. This marks the point where the text starts |
584 | # or ends. |
9e0a9786 |
585 | my $anchor = $app->getAttribute( 'to' ); |
586 | my $aname; |
93a44639 |
587 | if( $anchor ) { |
588 | $anchor =~ s/^\#//; |
589 | $aname = _anchor_name( $anchor ); |
590 | } |
9e0a9786 |
591 | |
592 | foreach my $rdg ( $app->getChildrenByTagName( 'rdg' ) ) { |
93a44639 |
593 | my @witlist = map { _get_sigil( $_, $c->ac_label ) } |
594 | split( /\s+/, $rdg->getAttribute( 'wit' ) ); |
9e0a9786 |
595 | my @start = $rdg->getChildrenByTagName( 'witStart' ); |
596 | my @end = $rdg->getChildrenByTagName( 'witEnd' ); |
597 | if( @start && @end ) { |
598 | throw( "App sig entry at $anchor has both witStart and witEnd!" ); |
599 | } |
93a44639 |
600 | if( @start && $anchor && |
601 | $c->prior_reading( $aname, $c->baselabel ) ne $c->start ) { |
602 | # We are picking back up after a hiatus. Find the last end and |
603 | # add a lacuna link between there and here. |
604 | foreach my $wit ( @witlist ) { |
605 | my $stoppoint = delete $lacunose{$wit}; |
6f91b6f6 |
606 | my $stopname = $stoppoint ? _anchor_name( $stoppoint ) : $c->start->id; |
93a44639 |
607 | say STDERR "Adding lacuna for $wit between $stopname and $anchor"; |
608 | my $lacuna = $c->add_reading( { id => "as_$anchor.".$ctr++, |
609 | is_lacuna => 1 } ); |
610 | _add_wit_path( $c, [ $lacuna ], $stopname, $aname, $wit ); |
611 | } |
612 | } elsif( @end && $anchor && |
613 | $c->next_reading( $aname, $c->baselabel ) ne $c->end ) { |
614 | # We are stopping. If we've already stopped for the given witness, |
615 | # flag an error; otherwise record the stopping point. |
616 | foreach my $wit ( @witlist ) { |
617 | if( $lacunose{$wit} ) { |
618 | throw( "Trying to end $wit at $anchor when already ended at " |
619 | . $lacunose{$wit} ); |
6f91b6f6 |
620 | } |
93a44639 |
621 | $lacunose{$wit} = $anchor; |
9e0a9786 |
622 | } |
623 | } |
624 | } |
625 | } |
626 | |
627 | # For whatever remains in the %lacunose hash, add a lacuna between that spot and |
628 | # $c->end for each of the witnesses. |
93a44639 |
629 | foreach my $wit ( keys %lacunose ) { |
630 | next unless $lacunose{$wit}; |
631 | my $aname = _anchor_name( $lacunose{$wit} ); |
632 | say STDERR "Adding lacuna for $wit from $aname to end"; |
633 | my $lacuna = $c->add_reading( { id => 'as_'.$lacunose{$wit}.'.'.$ctr++, |
9e0a9786 |
634 | is_lacuna => 1 } ); |
93a44639 |
635 | _add_wit_path( $c, [ $lacuna ], $aname, $c->end, $wit ); |
9e0a9786 |
636 | } |
637 | } |
638 | |
a445ce40 |
639 | sub _get_sigil { |
640 | my( $xml_id, $layerlabel ) = @_; |
f6e19c7c |
641 | if( $xml_id =~ /^(.*)_ac$/ ) { |
642 | my $real_id = $1; |
a445ce40 |
643 | return $sigil_for{$real_id} . $layerlabel; |
f6e19c7c |
644 | } else { |
645 | return $sigil_for{$xml_id}; |
646 | } |
647 | } |
648 | |
a445ce40 |
649 | sub _expand_all_paths { |
f6e19c7c |
650 | my( $c ) = @_; |
651 | |
652 | # Walk the collation and fish out the paths for each witness |
653 | foreach my $wit ( $c->tradition->witnesses ) { |
654 | my $sig = $wit->sigil; |
12720144 |
655 | my @path = grep { !$_->is_ph } |
f6e19c7c |
656 | $c->reading_sequence( $c->start, $c->end, $sig ); |
657 | $wit->path( \@path ); |
658 | if( $has_ac{$sig} ) { |
12720144 |
659 | my @ac_path = grep { !$_->is_ph } |
861c3e27 |
660 | $c->reading_sequence( $c->start, $c->end, $sig.$c->ac_label ); |
f6e19c7c |
661 | $wit->uncorrected_path( \@ac_path ); |
662 | } |
663 | } |
664 | |
665 | # Delete the anchors |
12720144 |
666 | foreach my $anchor ( grep { $_->is_ph } $c->readings ) { |
f6e19c7c |
667 | $c->del_reading( $anchor ); |
668 | } |
12720144 |
669 | # Delete the base edges |
670 | map { $c->del_path( $_, $c->baselabel ) } $c->paths; |
f6e19c7c |
671 | |
672 | # Make the path edges |
673 | $c->make_witness_paths(); |
7c2ed85e |
674 | |
675 | # Now remove any orphan nodes, and warn that we are doing so. |
95e89db0 |
676 | my %suspect_apps; |
82a45078 |
677 | while( $c->sequence->predecessorless_vertices > 1 ) { |
678 | foreach my $v ( $c->sequence->predecessorless_vertices ) { |
679 | my $r = $c->reading( $v ); |
680 | next if $r->is_start; |
876c951d |
681 | my $tag = $r->id; |
682 | $tag =~ s/^r(\d+)\.\d+/$1/; |
82a45078 |
683 | say STDERR "Deleting orphan reading $r / " . $r->text; |
95e89db0 |
684 | push( @{$suspect_apps{$tag}}, $r->id ) if $tag =~ /^\d+$/; |
82a45078 |
685 | $c->del_reading( $r ); |
686 | } |
7c2ed85e |
687 | } |
876c951d |
688 | if( $c->sequence->successorless_vertices > 1 ) { |
689 | my @bad = grep { $_ ne $c->end->id } $c->sequence->successorless_vertices; |
690 | foreach( @bad ) { |
95e89db0 |
691 | my $tag = $_; |
692 | next unless $tag =~ /^r/; |
693 | $tag =~ s/^r(\d+)\.\d+/$1/; |
694 | push( @{$suspect_apps{$tag}}, $_ ); |
876c951d |
695 | } |
95e89db0 |
696 | _dump_suspects( %suspect_apps ); |
876c951d |
697 | throw( "Remaining hanging readings: @bad" ); |
698 | } |
95e89db0 |
699 | _dump_suspects( %suspect_apps ) if keys %suspect_apps; |
4d85a60e |
700 | } |
701 | |
702 | sub _add_wit_path { |
f6e19c7c |
703 | my( $c, $rdg, $app, $anchor, $wit ) = @_; |
4d85a60e |
704 | my @nodes = @$rdg; |
f6e19c7c |
705 | push( @nodes, $c->reading( $anchor ) ); |
4d85a60e |
706 | |
f6e19c7c |
707 | my $cur = $c->reading( $app ); |
4d85a60e |
708 | foreach my $n ( @nodes ) { |
f6e19c7c |
709 | $c->add_path( $cur, $n, $wit ); |
4d85a60e |
710 | $cur = $n; |
6f4946fb |
711 | } |
6f4946fb |
712 | } |
713 | |
876c951d |
714 | sub _dump_suspects { |
95e89db0 |
715 | my %list = @_; |
876c951d |
716 | say STDERR "Suspect apparatus entries:"; |
95e89db0 |
717 | foreach my $suspect ( sort { $a <=> $b } keys %list ) { |
718 | my @badrdgs = @{$list{$suspect}}; |
719 | say STDERR print_apparatus( $suspect ); |
720 | say STDERR "\t(Linked to readings @badrdgs)"; |
876c951d |
721 | } |
722 | } |
723 | |
724 | sub print_apparatus { |
725 | my( $appid ) = @_; |
726 | my $tag = '__APP_' . $appid . '__'; |
727 | my $app = $apps{$tag}; |
728 | my $appstring = ''; |
729 | # Interpret the XML - get the lemma and readings and print them out. |
730 | my $xpc = XML::LibXML::XPathContext->new( $app ); |
731 | my $anchor = $app->getAttribute('to'); |
732 | if( $anchor ) { |
733 | # We have a lemma, so we construct it. |
734 | $anchor =~ s/^#//; |
95e89db0 |
735 | $appstring .= "(Anchor $anchor) "; |
876c951d |
736 | my $curr = $app; |
737 | while( $curr ) { |
738 | last if $curr->nodeType eq XML_ELEMENT_NODE |
739 | && $curr->hasAttribute( 'xml:id' ) |
740 | && $curr->getAttribute( 'xml:id' ) eq $anchor; |
741 | $appstring .= $curr->data if $curr->nodeType eq XML_TEXT_NODE; |
742 | $curr = $curr->nextSibling; |
743 | } |
744 | } |
95e89db0 |
745 | $appstring .= '] '; |
746 | my @readings; |
876c951d |
747 | foreach my $rdg_el ( $xpc->findnodes( 'child::rdg' ) ) { |
748 | my $rdgtext = ''; |
749 | my $startend = ''; |
750 | my %detail; |
751 | foreach my $child_el ( $rdg_el->childNodes ) { |
752 | if( $child_el->nodeType eq XML_TEXT_NODE ) { |
753 | $rdgtext .= $child_el->data; |
754 | } elsif( $child_el->nodeName =~ /^wit(Start|End)$/ ) { |
755 | my $startend = lc( $1 ); |
756 | } elsif( $child_el->nodeName eq 'witDetail' ) { |
757 | foreach my $wit ( map { _get_sigil( $_ ) } |
758 | split( /\s+/, $child_el->getAttribute('wit') ) ) { |
759 | $detail{$wit} = $child_el->textContent; |
760 | } |
761 | } |
762 | } |
95e89db0 |
763 | |
876c951d |
764 | my @witlist; |
765 | foreach my $witrep ( map { _get_sigil( $_ ) } |
766 | split( /\s+/, $rdg_el->getAttribute('wit') ) ) { |
767 | if( exists $detail{$witrep} ) { |
768 | $witrep .= '(' . $detail{$witrep} . ')' |
769 | } |
770 | if( $startend eq 'start' ) { |
771 | $witrep = '*' . $witrep; |
772 | } elsif( $startend eq 'end' ) { |
773 | $witrep .= '*'; |
774 | } |
775 | push( @witlist, $witrep ); |
776 | } |
95e89db0 |
777 | $rdgtext .= " @witlist"; |
778 | push( @readings, $rdgtext ); |
876c951d |
779 | } |
95e89db0 |
780 | $appstring .= join( ' ', @readings ); |
876c951d |
781 | return $appstring; |
782 | } |
783 | |
00311328 |
784 | sub throw { |
785 | Text::Tradition::Error->throw( |
786 | 'ident' => 'Parser::CTE error', |
93a44639 |
787 | 'message' => $_[0], |
00311328 |
788 | ); |
789 | } |
790 | |
6f4946fb |
791 | =head1 LICENSE |
792 | |
793 | This package is free software and is provided "as is" without express |
794 | or implied warranty. You can redistribute it and/or modify it under |
795 | the same terms as Perl itself. |
796 | |
797 | =head1 AUTHOR |
798 | |
799 | Tara L Andrews, aurum@cpan.org |
800 | |
801 | =cut |
802 | |
803 | 1; |
804 | |