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; |
11 | |
12 | =head1 NAME |
13 | |
14 | Text::Tradition::Parser::CTE |
15 | |
16 | =head1 DESCRIPTION |
17 | |
18 | Parser module for Text::Tradition, given a TEI file exported from |
19 | Classical Text Editor. |
20 | |
21 | =head1 METHODS |
22 | |
a445ce40 |
23 | =head2 parse |
6f4946fb |
24 | |
25 | my @apparatus = read( $xml_file ); |
26 | |
27 | Takes a Tradition object and a TEI file exported from Classical Text |
4d85a60e |
28 | Editor using double-endpoint-attachment critical apparatus encoding; |
29 | initializes the Tradition from the file. |
6f4946fb |
30 | |
31 | =cut |
32 | |
4d85a60e |
33 | my %sigil_for; # Save the XML IDs for witnesses. |
34 | my %apps; # Save the apparatus XML for a given ID. |
f6e19c7c |
35 | my %has_ac; # Keep track of witnesses that have corrections. |
6f4946fb |
36 | |
37 | sub parse { |
dfc37e38 |
38 | my( $tradition, $opts ) = @_; |
4d85a60e |
39 | my $c = $tradition->collation; # Some shorthand |
40 | |
41 | # First, parse the XML. |
c9158e60 |
42 | my( $tei, $xpc ) = _remove_formatting( $opts ); |
43 | return unless $tei; # we have already warned. |
4d85a60e |
44 | |
45 | # CTE uses a DTD rather than any xmlns-based parsing. Thus we |
46 | # need no namespace handling. |
4d85a60e |
47 | # Get the witnesses and create the witness objects. |
48 | foreach my $wit_el ( $xpc->findnodes( '//sourceDesc/listWit/witness' ) ) { |
49 | # The witness xml:id is used internally, and is *not* the sigil name. |
50 | my $id= $wit_el->getAttribute( 'xml:id' ); |
92de40a6 |
51 | # If the witness element has an abbr element, that is the sigil. Otherwise |
52 | # the whole thing is the sigil. |
53 | my $sig = $xpc->findvalue( 'abbr', $wit_el ); |
54 | my $identifier = 'CTE witness'; |
55 | if( $sig ) { |
56 | # The sigil is what is in the <abbr/> tag; the identifier is anything |
57 | # that follows. |
58 | $identifier = _tidy_identifier( |
59 | $xpc->findvalue( 'child::text()', $wit_el ) ); |
60 | } else { |
61 | my @sig_parts = $xpc->findnodes( 'descendant::text()', $wit_el ); |
62 | $sig = _stringify_sigil( @sig_parts ); |
63 | } |
64 | say STDERR "Adding witness $sig ($identifier)"; |
65 | $tradition->add_witness( sigil => $sig, identifier => $identifier, |
66 | sourcetype => 'collation' ); |
b8f262e8 |
67 | $sigil_for{'#'.$id} = $sig; # Make life easy by keying on the ID ref syntax |
4d85a60e |
68 | } |
c9158e60 |
69 | |
4d85a60e |
70 | # Now go through the text and find the base tokens, apparatus tags, and |
71 | # anchors. Make a giant array of all of these things in sequence. |
72 | # TODO consider combining this with creation of graph below |
73 | my @base_text; |
74 | foreach my $pg_el ( $xpc->findnodes( '/TEI/text/body/p' ) ) { |
75 | foreach my $xn ( $pg_el->childNodes ) { |
82a45078 |
76 | push( @base_text, _get_base( $xn ) ); |
4d85a60e |
77 | } |
6f4946fb |
78 | } |
4d85a60e |
79 | # We now have to work through this array applying the alternate |
80 | # apparatus readings to the base text. Essentially we will put |
81 | # everything on the graph, from which we will delete the apps and |
82 | # anchors when we are done. |
f6e19c7c |
83 | |
84 | # First, put the base tokens, apps, and anchors in the graph. |
4d85a60e |
85 | my $counter = 0; |
86 | my $last = $c->start; |
87 | foreach my $item ( @base_text ) { |
88 | my $r; |
89 | if( $item->{'type'} eq 'token' ) { |
12720144 |
90 | $r = $c->add_reading( { id => 'n'.$counter++, |
91 | text => $item->{'content'} } ); |
4d85a60e |
92 | } elsif ( $item->{'type'} eq 'anchor' ) { |
10e4b1ac |
93 | $r = $c->add_reading( { id => '__ANCHOR_' . $item->{'content'} . '__', |
12720144 |
94 | is_ph => 1 } ); |
4d85a60e |
95 | } elsif ( $item->{'type'} eq 'app' ) { |
10e4b1ac |
96 | my $tag = '__APP_' . $counter++ . '__'; |
12720144 |
97 | $r = $c->add_reading( { id => $tag, is_ph => 1 } ); |
4d85a60e |
98 | $apps{$tag} = $item->{'content'}; |
99 | } |
f6e19c7c |
100 | $c->add_path( $last, $r, $c->baselabel ); |
4d85a60e |
101 | $last = $r; |
6f4946fb |
102 | } |
f6e19c7c |
103 | $c->add_path( $last, $c->end, $c->baselabel ); |
4d85a60e |
104 | |
105 | # Now we can parse the apparatus entries, and add the variant readings |
106 | # to the graph. |
107 | |
108 | foreach my $app_id ( keys %apps ) { |
109 | _add_readings( $c, $app_id ); |
6f4946fb |
110 | } |
4d85a60e |
111 | |
f6e19c7c |
112 | # Finally, add explicit witness paths, remove the base paths, and remove |
113 | # the app/anchor tags. |
a445ce40 |
114 | _expand_all_paths( $c ); |
861c3e27 |
115 | |
116 | # Save the text for each witness so that we can ensure consistency |
117 | # later on |
a188b944 |
118 | unless( $opts->{'nocalc'} ) { |
119 | $tradition->collation->text_from_paths(); |
120 | $tradition->collation->calculate_ranks(); |
121 | $tradition->collation->flatten_ranks(); |
122 | } |
6f4946fb |
123 | } |
124 | |
4d85a60e |
125 | sub _stringify_sigil { |
126 | my( @nodes ) = @_; |
127 | my @parts = grep { /\w/ } map { $_->data } @nodes; |
222d58f1 |
128 | my $whole = join( '', @parts ); |
129 | $whole =~ s/\W//g; |
130 | return $whole; |
4d85a60e |
131 | } |
6f4946fb |
132 | |
92de40a6 |
133 | sub _tidy_identifier { |
134 | my( $str ) = @_; |
135 | $str =~ s/^\W+//; |
136 | return $str; |
137 | } |
138 | |
c9158e60 |
139 | # Get rid of all the formatting elements that get in the way of tokenization. |
140 | sub _remove_formatting { |
141 | my( $opts ) = @_; |
142 | |
143 | # First, parse the original XML |
144 | my $parser = XML::LibXML->new(); |
145 | my $doc; |
146 | if( exists $opts->{'string'} ) { |
147 | $doc = $parser->parse_string( $opts->{'string'} ); |
148 | } elsif ( exists $opts->{'file'} ) { |
149 | $doc = $parser->parse_file( $opts->{'file'} ); |
150 | } else { |
151 | warn "Could not find string or file option to parse"; |
152 | return; |
153 | } |
00311328 |
154 | |
c9158e60 |
155 | # Second, remove the formatting |
156 | my $xpc = XML::LibXML::XPathContext->new( $doc->documentElement ); |
157 | my @useless = $xpc->findnodes( '//hi' ); |
158 | foreach my $n ( @useless ) { |
159 | my $parent = $n->parentNode(); |
160 | my @children = $n->childNodes(); |
161 | my $first = shift @children; |
7c2ed85e |
162 | if( $first ) { |
163 | $parent->replaceChild( $first, $n ); |
164 | foreach my $c ( @children ) { |
165 | $parent->insertAfter( $c, $first ); |
166 | $first = $c; |
167 | } |
168 | } else { |
169 | $parent->removeChild( $n ); |
c9158e60 |
170 | } |
171 | } |
172 | |
173 | # Third, write out and reparse to merge the text nodes. |
00311328 |
174 | my $enc = $doc->encoding || 'UTF-8'; |
175 | my $result = decode( $enc, $doc->toString() ); |
c9158e60 |
176 | my $tei = $parser->parse_string( $result )->documentElement; |
00311328 |
177 | unless( $tei->nodeName =~ /^tei(corpus)?$/i ) { |
178 | throw( "Parsed document has non-TEI root element " . $tei->nodeName ); |
179 | } |
c9158e60 |
180 | $xpc = XML::LibXML::XPathContext->new( $tei ); |
181 | return( $tei, $xpc ); |
182 | } |
183 | |
184 | ## Helper function to help us navigate through nested XML, picking out |
185 | ## the words, the apparatus, and the anchors. |
4d85a60e |
186 | |
187 | sub _get_base { |
188 | my( $xn ) = @_; |
189 | my @readings; |
190 | if( $xn->nodeType == XML_TEXT_NODE ) { |
191 | # Base text, just split the words on whitespace and add them |
192 | # to our sequence. |
193 | my $str = $xn->data; |
194 | $str =~ s/^\s+//; |
c9158e60 |
195 | my @tokens = split( /\s+/, $str ); |
92de40a6 |
196 | push( @readings, map { { type => 'token', content => $_ } } @tokens ); |
4d85a60e |
197 | } elsif( $xn->nodeName eq 'app' ) { |
198 | # Apparatus, just save the entire XML node. |
92de40a6 |
199 | push( @readings, { type => 'app', content => $xn } ); |
4d85a60e |
200 | } elsif( $xn->nodeName eq 'anchor' ) { |
201 | # Anchor to mark the end of some apparatus; save its ID. |
82a45078 |
202 | if( $xn->hasAttribute('xml:id') ) { |
92de40a6 |
203 | push( @readings, { type => 'anchor', |
204 | content => $xn->getAttribute( 'xml:id' ) } ); |
82a45078 |
205 | } # if the anchor has no XML ID, it is not relevant to us. |
92de40a6 |
206 | } elsif( $xn->nodeName =~ /^wit(Start|End)$/ ){ |
207 | push( @readings, { type => 'token', content => '#' . uc( $1 ) . '#' } ); |
208 | } elsif( $xn->nodeName !~ /^(note|seg|milestone|emph)$/ ) { # Any tag we don't know to disregard |
a188b944 |
209 | say STDERR "Unrecognized tag " . $xn->nodeName; |
6f4946fb |
210 | } |
4d85a60e |
211 | return @readings; |
6f4946fb |
212 | } |
213 | |
c9158e60 |
214 | sub _append_tokens { |
215 | my( $list, @tokens ) = @_; |
216 | if( @$list && $list->[-1]->{'content'} =~ /\#JOIN\#$/ ) { |
217 | # The list evidently ended mid-word; join the next token onto it. |
218 | my $t = shift @tokens; |
219 | if( ref $t && $t->{'type'} eq 'token' ) { |
220 | # Join the word |
221 | $t = $t->{'content'}; |
222 | } elsif( ref $t ) { |
223 | # An app or anchor intervened; end the word. |
224 | unshift( @tokens, $t ); |
225 | $t = ''; |
226 | } |
227 | $list->[-1]->{'content'} =~ s/\#JOIN\#$/$t/; |
228 | } |
229 | foreach my $t ( @tokens ) { |
230 | unless( ref( $t ) ) { |
231 | $t = { 'type' => 'token', 'content' => $t }; |
232 | } |
233 | push( @$list, $t ); |
234 | } |
235 | } |
236 | |
4d85a60e |
237 | sub _add_readings { |
238 | my( $c, $app_id ) = @_; |
239 | my $xn = $apps{$app_id}; |
92de40a6 |
240 | # If the app is of type a1, it is an apparatus criticus. |
241 | # If it is of type a2, it is an apparatus codicum and might not |
242 | # have an anchor. |
243 | my $anchor; |
244 | if( $xn->hasAttribute('to') ) { |
245 | $anchor = _anchor_name( $xn->getAttribute( 'to' ) ); |
246 | } |
247 | |
4d85a60e |
248 | # Get the lemma, which is all the readings between app and anchor, |
249 | # excluding other apps or anchors. |
92de40a6 |
250 | my @lemma; |
251 | my $lemma_str = ''; |
252 | if( $anchor ) { |
253 | @lemma = _return_lemma( $c, $app_id, $anchor ); |
254 | $lemma_str = join( ' ', map { $_->text } grep { !$_->is_ph } @lemma ); |
255 | } |
256 | |
4d85a60e |
257 | # For each reading, send its text to 'interpret' along with the lemma, |
258 | # and then save the list of witnesses that these tokens belong to. |
3a5d151b |
259 | my %wit_rdgs; # Maps from witnesses to the variant text |
4d85a60e |
260 | my $ctr = 0; |
261 | my $tag = $app_id; |
10e4b1ac |
262 | $tag =~ s/^\__APP_(.*)\__$/$1/; |
c9158e60 |
263 | |
4d85a60e |
264 | foreach my $rdg ( $xn->getChildrenByTagName( 'rdg' ) ) { |
265 | my @text; |
4d85a60e |
266 | foreach ( $rdg->childNodes ) { |
267 | push( @text, _get_base( $_ ) ); |
268 | } |
12720144 |
269 | my( $interpreted, $flag ) = ( '', undef ); |
270 | if( @text ) { |
271 | ( $interpreted, $flag ) = interpret( |
272 | join( ' ', map { $_->{'content'} } @text ), $lemma_str ); |
273 | } |
b8f262e8 |
274 | next if( $interpreted eq $lemma_str ) && !$flag; # Reading is lemma. |
275 | |
4d85a60e |
276 | my @rdg_nodes; |
b8f262e8 |
277 | if( $interpreted eq '#LACUNA#' ) { |
10e4b1ac |
278 | push( @rdg_nodes, $c->add_reading( { id => 'r'.$tag.".".$ctr++, |
b8f262e8 |
279 | is_lacuna => 1 } ) ); |
280 | } else { |
92de40a6 |
281 | if ( $flag && $flag eq 'START' |
282 | && $c->prior_reading( $app_id, $c->baselabel ) ne $c->start ) { |
283 | # Add a lacuna for the witness start. |
284 | push( @rdg_nodes, $c->add_reading( { id => 'r'.$tag.".".$ctr++, |
285 | is_lacuna => 1 } ) ); |
286 | $flag = ''; |
287 | } |
b8f262e8 |
288 | foreach my $w ( split( /\s+/, $interpreted ) ) { |
10e4b1ac |
289 | my $r = $c->add_reading( { id => 'r'.$tag.".".$ctr++, |
b8f262e8 |
290 | text => $w } ); |
291 | push( @rdg_nodes, $r ); |
292 | } |
92de40a6 |
293 | if( $flag && $flag eq 'END' |
294 | && $c->next_reading( $app_id, $c->baselabel ) ne $c->end ) { |
295 | # Add a lacuna for the witness end. |
296 | push( @rdg_nodes, $c->add_reading( { id => 'r'.$tag.".".$ctr++, |
297 | is_lacuna => 1 } ) ); |
298 | $flag = ''; |
299 | } |
4d85a60e |
300 | } |
92de40a6 |
301 | |
f6e19c7c |
302 | # For each listed wit, save the reading. |
303 | foreach my $wit ( split( /\s+/, $rdg->getAttribute( 'wit' ) ) ) { |
12720144 |
304 | $wit .= $flag if $flag; |
f6e19c7c |
305 | $wit_rdgs{$wit} = \@rdg_nodes; |
306 | } |
12720144 |
307 | |
3a5d151b |
308 | # Does the reading have an ID? If so it probably has a witDetail |
f6e19c7c |
309 | # attached, and we need to read it. |
3a5d151b |
310 | if( $rdg->hasAttribute( 'xml:id' ) ) { |
12720144 |
311 | warn "Witdetail on meta reading" if $flag; # this could get complicated. |
f6e19c7c |
312 | my $rid = $rdg->getAttribute( 'xml:id' ); |
313 | my $xpc = XML::LibXML::XPathContext->new( $xn ); |
314 | my @details = $xpc->findnodes( './witDetail[@target="'.$rid.'"]' ); |
315 | foreach my $d ( @details ) { |
316 | _parse_wit_detail( $d, \%wit_rdgs, \@lemma ); |
317 | } |
3a5d151b |
318 | } |
f6e19c7c |
319 | } |
320 | |
4d85a60e |
321 | # Now collate the variant readings, since it is not done for us. |
12720144 |
322 | collate_variants( $c, \@lemma, values %wit_rdgs ); |
b8f262e8 |
323 | |
92de40a6 |
324 | # Now add the witness paths for each reading. If we don't have an anchor |
325 | # (e.g. with an initial witStart) there was no witness path to speak of. |
326 | if( $anchor ) { |
327 | my $aclabel = $c->ac_label; |
328 | foreach my $wit_id ( keys %wit_rdgs ) { |
329 | my $witstr = _get_sigil( $wit_id, $aclabel ); |
330 | my $rdg_list = $wit_rdgs{$wit_id}; |
331 | _add_wit_path( $c, $rdg_list, $app_id, $anchor, $witstr ); |
332 | } |
333 | } |
4d85a60e |
334 | } |
6f4946fb |
335 | |
4d85a60e |
336 | sub _anchor_name { |
337 | my $xmlid = shift; |
338 | $xmlid =~ s/^\#//; |
10e4b1ac |
339 | return sprintf( "__ANCHOR_%s__", $xmlid ); |
6f4946fb |
340 | } |
341 | |
4d85a60e |
342 | sub _return_lemma { |
343 | my( $c, $app, $anchor ) = @_; |
10e4b1ac |
344 | my @nodes = grep { $_->id !~ /^__A(PP|NCHOR)/ } |
12720144 |
345 | $c->reading_sequence( $c->reading( $app ), $c->reading( $anchor ), |
346 | $c->baselabel ); |
4d85a60e |
347 | return @nodes; |
348 | } |
6f4946fb |
349 | |
a445ce40 |
350 | =head2 interpret( $reading, $lemma ) |
351 | |
352 | Given a string in $reading and a corresponding lemma in $lemma, interpret what |
353 | the actual reading should be. Used to deal with apparatus-ese shorthands for |
354 | marking transpositions, prefixed or suffixed words, and the like. |
355 | |
356 | =cut |
357 | |
6f4946fb |
358 | sub interpret { |
4d85a60e |
359 | # A utility function to change apparatus-ese into a full variant. |
360 | my( $reading, $lemma ) = @_; |
361 | return $reading if $reading eq $lemma; |
362 | my $oldreading = $reading; |
363 | # $lemma =~ s/\s+[[:punct:]]+$//; |
12720144 |
364 | my $flag; # In case of p.c. indications |
4d85a60e |
365 | my @words = split( /\s+/, $lemma ); |
b2edc51f |
366 | $reading =~ s/[[:punct:]]?\bsic\b([[:punct:]]+)?//g; |
4d85a60e |
367 | if( $reading =~ /^(.*) praem.$/ ) { |
368 | $reading = "$1 $lemma"; |
369 | } elsif( $reading =~ /^(.*) add.$/ ) { |
370 | $reading = "$lemma $1"; |
b8f262e8 |
371 | } elsif( $reading =~ /add. alia manu/ |
372 | || $reading =~ /inscriptionem compegi e/ # TODO huh? |
373 | || $reading eq 'inc.' # TODO huh? |
374 | ) { |
12720144 |
375 | # Ignore it. |
376 | $reading = $lemma; |
b8f262e8 |
377 | } elsif( $reading =~ /locus [uv]acuus/ |
378 | || $reading eq 'def.' |
c9158e60 |
379 | || $reading eq 'illeg.' |
380 | || $reading eq 'onleesbar' |
f6e19c7c |
381 | ) { |
b8f262e8 |
382 | $reading = '#LACUNA#'; |
383 | } elsif( $reading eq 'om.' ) { |
4d85a60e |
384 | $reading = ''; |
c9158e60 |
385 | } elsif( $reading =~ /^in[uv]\.$/ |
386 | || $reading eq 'transp.' ) { |
4d85a60e |
387 | # Hope it is two words. |
a188b944 |
388 | say STDERR "WARNING: want to invert a lemma that is not two words" |
4d85a60e |
389 | unless scalar( @words ) == 2; |
390 | $reading = join( ' ', reverse( @words ) ); |
12720144 |
391 | } elsif( $reading =~ /^iter(\.|at)$/ ) { |
4d85a60e |
392 | # Repeat the lemma |
393 | $reading = "$lemma $lemma"; |
12720144 |
394 | } elsif( $reading eq 'in marg.' ) { |
395 | # There was nothing before a correction. |
396 | $reading = ''; |
397 | $flag = '_ac'; |
398 | } elsif( $reading =~ /^(.*) \.\.\. (.*)$/ ) { |
4d85a60e |
399 | # The first and last N words captured should replace the first and |
400 | # last N words of the lemma. |
401 | my @begin = split( /\s+/, $1 ); |
402 | my @end = split( /\s+/, $2 ); |
403 | if( scalar( @begin ) + scalar ( @end ) > scalar( @words ) ) { |
404 | # Something is wrong and we can't do the splice. |
a188b944 |
405 | say STDERR "ERROR: $lemma is too short to accommodate $oldreading"; |
4d85a60e |
406 | } else { |
407 | splice( @words, 0, scalar @begin, @begin ); |
408 | splice( @words, -(scalar @end), scalar @end, @end ); |
409 | $reading = join( ' ', @words ); |
410 | } |
92de40a6 |
411 | } elsif( $reading =~ /^\#START\#\s*(.*)$/ ) { |
412 | $reading = $1; |
413 | $flag = 'START'; |
414 | } elsif( $reading =~ /^(.*?)\s*\#END\#$/ ) { |
415 | $reading = $1; |
416 | $flag = 'END'; |
6f4946fb |
417 | } |
12720144 |
418 | if( $oldreading ne $reading || $flag || $oldreading =~ /\./ ) { |
419 | my $int = $reading; |
420 | $int .= " ($flag)" if $flag; |
b39e7cb5 |
421 | # say STDERR "Interpreted $oldreading as $int given $lemma"; |
12720144 |
422 | } |
423 | return( $reading, $flag ); |
4d85a60e |
424 | } |
425 | |
f6e19c7c |
426 | sub _parse_wit_detail { |
427 | my( $detail, $readings, $lemma ) = @_; |
428 | my $wit = $detail->getAttribute( 'wit' ); |
429 | my $content = $detail->textContent; |
4ed2b212 |
430 | if( $content =~ /a\.\s*c\b/ ) { |
f6e19c7c |
431 | # Replace the key in the $readings hash |
432 | my $rdg = delete $readings->{$wit}; |
433 | $readings->{$wit.'_ac'} = $rdg; |
434 | $has_ac{$sigil_for{$wit}} = 1; |
4ed2b212 |
435 | } elsif( $content =~ /p\.\s*c\b/ ) { |
f6e19c7c |
436 | # If no key for the wit a.c. exists, add one pointing to the lemma |
437 | unless( exists $readings->{$wit.'_ac'} ) { |
438 | $readings->{$wit.'_ac'} = $lemma; |
439 | } |
440 | $has_ac{$sigil_for{$wit}} = 1; |
441 | } # else don't bother just yet |
442 | } |
443 | |
a445ce40 |
444 | sub _get_sigil { |
445 | my( $xml_id, $layerlabel ) = @_; |
f6e19c7c |
446 | if( $xml_id =~ /^(.*)_ac$/ ) { |
447 | my $real_id = $1; |
a445ce40 |
448 | return $sigil_for{$real_id} . $layerlabel; |
f6e19c7c |
449 | } else { |
450 | return $sigil_for{$xml_id}; |
451 | } |
452 | } |
453 | |
a445ce40 |
454 | sub _expand_all_paths { |
f6e19c7c |
455 | my( $c ) = @_; |
456 | |
457 | # Walk the collation and fish out the paths for each witness |
458 | foreach my $wit ( $c->tradition->witnesses ) { |
459 | my $sig = $wit->sigil; |
12720144 |
460 | my @path = grep { !$_->is_ph } |
f6e19c7c |
461 | $c->reading_sequence( $c->start, $c->end, $sig ); |
462 | $wit->path( \@path ); |
463 | if( $has_ac{$sig} ) { |
12720144 |
464 | my @ac_path = grep { !$_->is_ph } |
861c3e27 |
465 | $c->reading_sequence( $c->start, $c->end, $sig.$c->ac_label ); |
f6e19c7c |
466 | $wit->uncorrected_path( \@ac_path ); |
467 | } |
468 | } |
469 | |
470 | # Delete the anchors |
12720144 |
471 | foreach my $anchor ( grep { $_->is_ph } $c->readings ) { |
f6e19c7c |
472 | $c->del_reading( $anchor ); |
473 | } |
12720144 |
474 | # Delete the base edges |
475 | map { $c->del_path( $_, $c->baselabel ) } $c->paths; |
f6e19c7c |
476 | |
477 | # Make the path edges |
478 | $c->make_witness_paths(); |
7c2ed85e |
479 | |
480 | # Now remove any orphan nodes, and warn that we are doing so. |
82a45078 |
481 | while( $c->sequence->predecessorless_vertices > 1 ) { |
482 | foreach my $v ( $c->sequence->predecessorless_vertices ) { |
483 | my $r = $c->reading( $v ); |
484 | next if $r->is_start; |
485 | say STDERR "Deleting orphan reading $r / " . $r->text; |
486 | $c->del_reading( $r ); |
487 | } |
7c2ed85e |
488 | } |
4d85a60e |
489 | } |
490 | |
491 | sub _add_wit_path { |
f6e19c7c |
492 | my( $c, $rdg, $app, $anchor, $wit ) = @_; |
4d85a60e |
493 | my @nodes = @$rdg; |
f6e19c7c |
494 | push( @nodes, $c->reading( $anchor ) ); |
4d85a60e |
495 | |
f6e19c7c |
496 | my $cur = $c->reading( $app ); |
4d85a60e |
497 | foreach my $n ( @nodes ) { |
f6e19c7c |
498 | $c->add_path( $cur, $n, $wit ); |
4d85a60e |
499 | $cur = $n; |
6f4946fb |
500 | } |
6f4946fb |
501 | } |
502 | |
00311328 |
503 | sub throw { |
504 | Text::Tradition::Error->throw( |
505 | 'ident' => 'Parser::CTE error', |
506 | 'message' => $_[0], |
507 | ); |
508 | } |
509 | |
6f4946fb |
510 | =head1 LICENSE |
511 | |
512 | This package is free software and is provided "as is" without express |
513 | or implied warranty. You can redistribute it and/or modify it under |
514 | the same terms as Perl itself. |
515 | |
516 | =head1 AUTHOR |
517 | |
518 | Tara L Andrews, aurum@cpan.org |
519 | |
520 | =cut |
521 | |
522 | 1; |
523 | |