[scpubgit/stemmatology.git] / lib / Text / Tradition / Parser / CTE.pm

package Text::Tradition::Parser::CTE;

use strict;
use warnings;
use Text::Tradition::Parser::Util qw/ collate_variants /;
use XML::LibXML;
use XML::LibXML::XPathContext;

=head1 NAME

Text::Tradition::Parser::CTE

=head1 DESCRIPTION

Parser module for Text::Tradition, given a TEI file exported from
Classical Text Editor.

=head1 METHODS

=over

=item B<parse>

my @apparatus = read( $xml_file );

Takes a Tradition object and a TEI file exported from Classical Text
Editor using double-endpoint-attachment critical apparatus encoding; 
initializes the Tradition from the file.

=cut

my %sigil_for;  # Save the XML IDs for witnesses.
my %apps;       # Save the apparatus XML for a given ID.    
my %has_ac;     # Keep track of witnesses that have corrections.
my %group_sigla = (   ## HACK HACK HACK
	'#M38' => [ qw( #M23 #M24 #M25 #M27 #M30 #M26 #M31 #M32 #M33 ) ], # l -> L*
	);

sub parse {
	my( $tradition, $opts ) = @_;
	my $c = $tradition->collation;	# Some shorthand
	
	# First, parse the XML.
	my $parser = XML::LibXML->new();
    my $doc;
    if( exists $opts->{'string'} ) {
        $doc = $parser->parse_string( $opts->{'string'} );
    } elsif ( exists $opts->{'file'} ) {
        $doc = $parser->parse_file( $opts->{'file'} );
    } else {
        warn "Could not find string or file option to parse";
        return;
    }
	my $tei = $doc->documentElement();
	my $xpc = XML::LibXML::XPathContext->new( $tei );

	# CTE uses a DTD rather than any xmlns-based parsing.  Thus we
	# need no namespace handling.

	# Get the witnesses and create the witness objects.
	foreach my $wit_el ( $xpc->findnodes( '//sourceDesc/listWit/witness' ) ) {
		# The witness xml:id is used internally, and is *not* the sigil name.
		my $id= $wit_el->getAttribute( 'xml:id' );
		my @sig_parts = $xpc->findnodes( './abbr/descendant::text()', $wit_el );
		my $sig = _stringify_sigil( @sig_parts );
		unless( exists $group_sigla{'#'.$id} ) {  ## More HACKY
			$tradition->add_witness( sigil => $sig, source => $wit_el->toString() );
			$sigil_for{'#'.$id} = $sig;  # Make life easy by keying on the ID ref syntax
		}
	}

	# Now go through the text and find the base tokens, apparatus tags, and
	# anchors.  Make a giant array of all of these things in sequence.
	# TODO consider combining this with creation of graph below
	my @base_text;
	foreach my $pg_el ( $xpc->findnodes( '/TEI/text/body/p' ) ) {
		foreach my $xn ( $pg_el->childNodes ) {
			push( @base_text, _get_base( $xn ) );
		}
	}
	
	# We now have to work through this array applying the alternate 
	# apparatus readings to the base text.  Essentially we will put 
	# everything on the graph, from which we will delete the apps and
	# anchors when we are done.
	
	# First, put the base tokens, apps, and anchors in the graph.
	my $counter = 0;
	my $last = $c->start;
	foreach my $item ( @base_text ) {
	    my $r;
        if( $item->{'type'} eq 'token' ) {
            $r = $c->add_reading( { id => 'n'.$counter++, 
            						text => $item->{'content'} } );
        } elsif ( $item->{'type'} eq 'anchor' ) {
            $r = $c->add_reading( { id => '#ANCHOR_' . $item->{'content'} . '#', 
            						is_ph => 1 } );
        } elsif ( $item->{'type'} eq 'app' ) {
            my $tag = '#APP_' . $counter++ . '#';
            $r = $c->add_reading( { id => $tag, is_ph => 1 } );
            $apps{$tag} = $item->{'content'};
        }
        $c->add_path( $last, $r, $c->baselabel );
        $last = $r;
    }
    $c->add_path( $last, $c->end, $c->baselabel );
    
    # Now we can parse the apparatus entries, and add the variant readings 
    # to the graph.
    
    foreach my $app_id ( keys %apps ) {
        _add_readings( $c, $app_id );
    }
    
    # Finally, add explicit witness paths, remove the base paths, and remove
    # the app/anchor tags.
    expand_all_paths( $c );
}

sub _stringify_sigil {
    my( @nodes ) = @_;
    my @parts = grep { /\w/ } map { $_->data } @nodes;
    return join( '', @parts );
}

## Recursive little helper function to help us navigate through nested
## XML, picking out the words, the apparatus, and the anchors.

sub _get_base {
	my( $xn ) = @_;
	my @readings;
	if( $xn->nodeType == XML_TEXT_NODE ) {
	    # Base text, just split the words on whitespace and add them 
	    # to our sequence.
	    # TODO consider that XML markup might appear mid-token.
		my $str = $xn->data;
		$str =~ s/^\s+//;
		foreach my $w ( split( /\s+/, $str ) ) {
		    # HACK to cope with mismatched doublequotes
		    $w =~ s/\"//g;
			push( @readings, { 'type' => 'token', 'content' => $w } );
		}
	} elsif( $xn->nodeName eq 'hi' ) {
		# Recurse as if the hi weren't there.
		foreach( $xn->childNodes ) {
			push( @readings, _get_base( $_ ) );
		}
	} elsif( $xn->nodeName eq 'app' ) {
		# Apparatus, just save the entire XML node.
		push( @readings, { 'type' => 'app', 'content' => $xn } );
	} elsif( $xn->nodeName eq 'anchor' ) {
		# Anchor to mark the end of some apparatus; save its ID.
		push( @readings, { 'type' => 'anchor', 
		    'content' => $xn->getAttribute( 'xml:id' ) } );
	} elsif ( $xn->nodeName ne 'note' ) {  # Any tag we don't know to disregard
	    print STDERR "Unrecognized tag " . $xn->nodeName . "\n";
	}
	return @readings;
}

sub _add_readings {
    my( $c, $app_id ) = @_;
    my $xn = $apps{$app_id};
    my $anchor = _anchor_name( $xn->getAttribute( 'to' ) );
    # Get the lemma, which is all the readings between app and anchor,
    # excluding other apps or anchors.
    my @lemma = _return_lemma( $c, $app_id, $anchor );
    my $lemma_str = join( ' ', grep { $_ !~ /^\#/ } map { $_->text } @lemma );
    
    # For each reading, send its text to 'interpret' along with the lemma,
    # and then save the list of witnesses that these tokens belong to.
    my %wit_rdgs;  # Maps from witnesses to the variant text
    my $ctr = 0;
    my $tag = $app_id;
    $tag =~ s/^\#APP_(.*)\#$/$1/;
    foreach my $rdg ( $xn->getChildrenByTagName( 'rdg' ) ) {
        my @text;
        foreach ( $rdg->childNodes ) {
            push( @text, _get_base( $_ ) );
        }
        my( $interpreted, $flag ) = ( '', undef );
        if( @text ) {
        	( $interpreted, $flag ) = interpret( 
        		join( ' ', map { $_->{'content'} } @text ), $lemma_str );
        }
        my @rdg_nodes;
        foreach my $w ( split( /\s+/, $interpreted ) ) {
            my $r = $c->add_reading( { id => $tag . "/" . $ctr++,
            						   text => $w } );
            push( @rdg_nodes, $r );
        }
        
        # For each listed wit, save the reading.
        foreach my $wit ( split( /\s+/, $rdg->getAttribute( 'wit' ) ) ) {
			$wit .= $flag if $flag;
            $wit_rdgs{$wit} = \@rdg_nodes;
        }
        		
        # Does the reading have an ID? If so it probably has a witDetail
        # attached, and we need to read it.
        if( $rdg->hasAttribute( 'xml:id' ) ) {
        	warn "Witdetail on meta reading" if $flag; # this could get complicated.
            my $rid = $rdg->getAttribute( 'xml:id' );
            my $xpc = XML::LibXML::XPathContext->new( $xn );
            my @details = $xpc->findnodes( './witDetail[@target="'.$rid.'"]' );
            foreach my $d ( @details ) {
                _parse_wit_detail( $d, \%wit_rdgs, \@lemma );
            }
        }
    }       
        
    # Now collate the variant readings, since it is not done for us.
    collate_variants( $c, \@lemma, values %wit_rdgs );
    
    # HACKY HACKY Expand "group" sigla.
    # Does not work for nested groups; also does not work with a modifier
    # on the group sigil.
    foreach my $wit_id ( keys %group_sigla ) {
    	if ( exists $wit_rdgs{$wit_id} ) {
    		my $rdg = $wit_rdgs{$wit_id};
    		foreach my $w ( @{$group_sigla{$wit_id}} ) {
    			if( exists $wit_rdgs{$w} ) {
    				$DB::single = 1;
					warn "Had reading for individual member $w of group $wit_id at $xn";
    			}
    			$wit_rdgs{$w} = $rdg;
    		}
    		delete $wit_rdgs{$wit_id};
    	}
    }
    
    # Now add the witness paths for each reading.
    foreach my $wit_id ( keys %wit_rdgs ) {
        my $witstr = get_sigil( $wit_id, $c );
        my $rdg_list = $wit_rdgs{$wit_id};
        _add_wit_path( $c, $rdg_list, $app_id, $anchor, $witstr );
    }
}

sub _anchor_name {
    my $xmlid = shift;
    $xmlid =~ s/^\#//;
    return sprintf( "#ANCHOR_%s#", $xmlid );
}

sub _return_lemma {
    my( $c, $app, $anchor ) = @_;
    my @nodes = grep { $_->id !~ /^\#A(PP|NCHOR)/ } 
        $c->reading_sequence( $c->reading( $app ), $c->reading( $anchor ),
        	$c->baselabel );
    return @nodes;
}

sub interpret {
	# A utility function to change apparatus-ese into a full variant.
	my( $reading, $lemma ) = @_;
	return $reading if $reading eq $lemma;
	my $oldreading = $reading;
	# $lemma =~ s/\s+[[:punct:]]+$//;
	# $reading =~ s/\s*\(?sic([\s\w.]+)?\)?$//;
	my $flag;  # In case of p.c. indications
	my @words = split( /\s+/, $lemma );
	if( $reading =~ /^(.*) praem.$/ ) {
		$reading = "$1 $lemma";
	} elsif( $reading =~ /^(.*) add.$/ ) {
		$reading = "$lemma $1";
	} elsif( $reading =~ /add. alia manu/ ) {
		# Ignore it.
		$reading = $lemma;
	} elsif( $reading eq 'om.' 
	    || $reading =~ /locus [uv]acuus/
	    || $reading =~ /inscriptionem compegi e/ # TODO huh?
	    || $reading eq 'def.' # TODO huh?
	    ) {
		$reading = '';
	} elsif( $reading =~ /^in[uv]\.$/ ) {
		# Hope it is two words.
		print STDERR "WARNING: want to invert a lemma that is not two words\n" 
			unless scalar( @words ) == 2;
		$reading = join( ' ', reverse( @words ) );
	} elsif( $reading =~ /^iter(\.|at)$/ ) {
		# Repeat the lemma
		$reading = "$lemma $lemma";
	} elsif( $reading eq 'in marg.' ) {
		# There was nothing before a correction.
		$reading = '';
		$flag = '_ac';
	} elsif( $reading =~ /^(.*) \.\.\. (.*)$/ ) {
		# The first and last N words captured should replace the first and
		# last N words of the lemma.
		my @begin = split( /\s+/, $1 );
		my @end = split( /\s+/, $2 );
		if( scalar( @begin ) + scalar ( @end ) > scalar( @words ) ) {
			# Something is wrong and we can't do the splice.
			print STDERR "ERROR: $lemma is too short to accommodate $oldreading\n";
		} else {
			splice( @words, 0, scalar @begin, @begin );
			splice( @words, -(scalar @end), scalar @end, @end );
			$reading = join( ' ', @words );
		}
	}
	if( $oldreading ne $reading || $flag || $oldreading =~ /\./ ) {
		my $int = $reading;
		$int .= " ($flag)" if $flag;
		print STDERR "Interpreted $oldreading as $int given $lemma\n";
	}
	return( $reading, $flag );
}

sub _parse_wit_detail {
    my( $detail, $readings, $lemma ) = @_;
    my $wit = $detail->getAttribute( 'wit' );
    my $content = $detail->textContent;
    if( $content =~ /a\.\s*c\./ ) {
        # Replace the key in the $readings hash
        my $rdg = delete $readings->{$wit};
        $readings->{$wit.'_ac'} = $rdg;
        $has_ac{$sigil_for{$wit}} = 1;
    } elsif( $content =~ /p\.\s*c\./ ) {
        # If no key for the wit a.c. exists, add one pointing to the lemma
        unless( exists $readings->{$wit.'_ac'} ) {
            $readings->{$wit.'_ac'} = $lemma;
        }
        $has_ac{$sigil_for{$wit}} = 1;
    } # else don't bother just yet
}

sub get_sigil {
    my( $xml_id, $c ) = @_;
    if( $xml_id =~ /^(.*)_ac$/ ) {
        my $real_id = $1;
        return $sigil_for{$real_id} . $c->ac_label;
    } else {
        return $sigil_for{$xml_id};
    }
}

sub expand_all_paths { 
    my( $c ) = @_;
    
    # Walk the collation and fish out the paths for each witness
    foreach my $wit ( $c->tradition->witnesses ) {
        my $sig = $wit->sigil;
        my @path = grep { !$_->is_ph } 
            $c->reading_sequence( $c->start, $c->end, $sig );
        $wit->path( \@path );
        if( $has_ac{$sig} ) {
            my @ac_path = grep { !$_->is_ph } 
                $c->reading_sequence( $c->start, $c->end, $sig.$c->ac_label, $sig );
            $wit->uncorrected_path( \@ac_path );
        }
    }   
    
    # Delete the anchors
    foreach my $anchor ( grep { $_->is_ph } $c->readings ) {
        $c->del_reading( $anchor );
    }
    # Delete the base edges
    map { $c->del_path( $_, $c->baselabel ) } $c->paths;
    
    # Make the path edges
    $c->make_witness_paths();
}

sub _add_wit_path {
    my( $c, $rdg, $app, $anchor, $wit ) = @_;
    my @nodes = @$rdg;
    push( @nodes, $c->reading( $anchor ) );
    
    my $cur = $c->reading( $app );
    foreach my $n ( @nodes ) {
        $c->add_path( $cur, $n, $wit );
        $cur = $n;
    }
}

=back

=head1 LICENSE

This package is free software and is provided "as is" without express
or implied warranty.  You can redistribute it and/or modify it under
the same terms as Perl itself.

=head1 AUTHOR

Tara L Andrews, aurum@cpan.org

=cut

1;
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;
4d85a60e	28	initializes the Tradition from the file.
6f4946fb	29
	30	=cut
	31
4d85a60e	32	my %sigil_for; # Save the XML IDs for witnesses.
4d85a60e	33	my %apps; # Save the apparatus XML for a given ID.
f6e19c7c	34	my %has_ac; # Keep track of witnesses that have corrections.
12720144	35	my %group_sigla = ( ## HACK HACK HACK
	36	'#M38' => [ qw( #M23 #M24 #M25 #M27 #M30 #M26 #M31 #M32 #M33 ) ], # l -> L*
	37	);
6f4946fb	38
6f4946fb	39	sub parse {
dfc37e38	40	my( $tradition, $opts ) = @_;
4d85a60e	41	my $c = $tradition->collation; # Some shorthand
	42
	43	# First, parse the XML.
	44	my $parser = XML::LibXML->new();
dfc37e38	45	my $doc;
	46	if( exists $opts->{'string'} ) {
	47	$doc = $parser->parse_string( $opts->{'string'} );
	48	} elsif ( exists $opts->{'file'} ) {
	49	$doc = $parser->parse_file( $opts->{'file'} );
	50	} else {
	51	warn "Could not find string or file option to parse";
	52	return;
	53	}
4d85a60e	54	my $tei = $doc->documentElement();
	55	my $xpc = XML::LibXML::XPathContext->new( $tei );
	56
	57	# CTE uses a DTD rather than any xmlns-based parsing. Thus we
	58	# need no namespace handling.
	59
	60	# Get the witnesses and create the witness objects.
	61	foreach my $wit_el ( $xpc->findnodes( '//sourceDesc/listWit/witness' ) ) {
	62	# The witness xml:id is used internally, and is not the sigil name.
	63	my $id= $wit_el->getAttribute( 'xml:id' );
	64	my @sig_parts = $xpc->findnodes( './abbr/descendant::text()', $wit_el );
	65	my $sig = _stringify_sigil( @sig_parts );
12720144	66	unless( exists $group_sigla{'#'.$id} ) { ## More HACKY
	67	$tradition->add_witness( sigil => $sig, source => $wit_el->toString() );
	68	$sigil_for{'#'.$id} = $sig; # Make life easy by keying on the ID ref syntax
	69	}
4d85a60e	70	}
6f4946fb	71
4d85a60e	72	# Now go through the text and find the base tokens, apparatus tags, and
	73	# anchors. Make a giant array of all of these things in sequence.
	74	# TODO consider combining this with creation of graph below
	75	my @base_text;
	76	foreach my $pg_el ( $xpc->findnodes( '/TEI/text/body/p' ) ) {
	77	foreach my $xn ( $pg_el->childNodes ) {
	78	push( @base_text, _get_base( $xn ) );
	79	}
6f4946fb	80	}
4d85a60e	81
	82	# We now have to work through this array applying the alternate
	83	# apparatus readings to the base text. Essentially we will put
	84	# everything on the graph, from which we will delete the apps and
	85	# anchors when we are done.
f6e19c7c	86
f6e19c7c	87	# First, put the base tokens, apps, and anchors in the graph.
4d85a60e	88	my $counter = 0;
	89	my $last = $c->start;
	90	foreach my $item ( @base_text ) {
	91	my $r;
	92	if( $item->{'type'} eq 'token' ) {
12720144	93	$r = $c->add_reading( { id => 'n'.$counter++,
12720144	94	text => $item->{'content'} } );
4d85a60e	95	} elsif ( $item->{'type'} eq 'anchor' ) {
12720144	96	$r = $c->add_reading( { id => '#ANCHOR_' . $item->{'content'} . '#',
12720144	97	is_ph => 1 } );
4d85a60e	98	} elsif ( $item->{'type'} eq 'app' ) {
4d85a60e	99	my $tag = '#APP_' . $counter++ . '#';
12720144	100	$r = $c->add_reading( { id => $tag, is_ph => 1 } );
4d85a60e	101	$apps{$tag} = $item->{'content'};
4d85a60e	102	}
f6e19c7c	103	$c->add_path( $last, $r, $c->baselabel );
4d85a60e	104	$last = $r;
6f4946fb	105	}
f6e19c7c	106	$c->add_path( $last, $c->end, $c->baselabel );
4d85a60e	107
	108	# Now we can parse the apparatus entries, and add the variant readings
	109	# to the graph.
	110
	111	foreach my $app_id ( keys %apps ) {
	112	_add_readings( $c, $app_id );
6f4946fb	113	}
4d85a60e	114
f6e19c7c	115	# Finally, add explicit witness paths, remove the base paths, and remove
	116	# the app/anchor tags.
	117	expand_all_paths( $c );
6f4946fb	118	}
6f4946fb	119
4d85a60e	120	sub _stringify_sigil {
	121	my( @nodes ) = @_;
	122	my @parts = grep { /\w/ } map { $_->data } @nodes;
	123	return join( '', @parts );
	124	}
6f4946fb	125
6f4946fb	126	## Recursive little helper function to help us navigate through nested
4d85a60e	127	## XML, picking out the words, the apparatus, and the anchors.
	128
	129	sub _get_base {
	130	my( $xn ) = @_;
	131	my @readings;
	132	if( $xn->nodeType == XML_TEXT_NODE ) {
	133	# Base text, just split the words on whitespace and add them
	134	# to our sequence.
f6e19c7c	135	# TODO consider that XML markup might appear mid-token.
4d85a60e	136	my $str = $xn->data;
	137	$str =~ s/^\s+//;
	138	foreach my $w ( split( /\s+/, $str ) ) {
f6e19c7c	139	# HACK to cope with mismatched doublequotes
f6e19c7c	140	$w =~ s/\"//g;
4d85a60e	141	push( @readings, { 'type' => 'token', 'content' => $w } );
	142	}
	143	} elsif( $xn->nodeName eq 'hi' ) {
	144	# Recurse as if the hi weren't there.
	145	foreach( $xn->childNodes ) {
	146	push( @readings, _get_base( $_ ) );
	147	}
	148	} elsif( $xn->nodeName eq 'app' ) {
	149	# Apparatus, just save the entire XML node.
	150	push( @readings, { 'type' => 'app', 'content' => $xn } );
	151	} elsif( $xn->nodeName eq 'anchor' ) {
	152	# Anchor to mark the end of some apparatus; save its ID.
	153	push( @readings, { 'type' => 'anchor',
	154	'content' => $xn->getAttribute( 'xml:id' ) } );
	155	} elsif ( $xn->nodeName ne 'note' ) { # Any tag we don't know to disregard
	156	print STDERR "Unrecognized tag " . $xn->nodeName . "\n";
6f4946fb	157	}
4d85a60e	158	return @readings;
6f4946fb	159	}
6f4946fb	160
4d85a60e	161	sub _add_readings {
	162	my( $c, $app_id ) = @_;
	163	my $xn = $apps{$app_id};
	164	my $anchor = _anchor_name( $xn->getAttribute( 'to' ) );
	165	# Get the lemma, which is all the readings between app and anchor,
	166	# excluding other apps or anchors.
	167	my @lemma = _return_lemma( $c, $app_id, $anchor );
	168	my $lemma_str = join( ' ', grep { $_ !~ /^\#/ } map { $_->text } @lemma );
	169
	170	# For each reading, send its text to 'interpret' along with the lemma,
	171	# and then save the list of witnesses that these tokens belong to.
3a5d151b	172	my %wit_rdgs; # Maps from witnesses to the variant text
4d85a60e	173	my $ctr = 0;
	174	my $tag = $app_id;
	175	$tag =~ s/^\#APP_(.*)\#$/$1/;
	176	foreach my $rdg ( $xn->getChildrenByTagName( 'rdg' ) ) {
	177	my @text;
4d85a60e	178	foreach ( $rdg->childNodes ) {
	179	push( @text, _get_base( $_ ) );
	180	}
12720144	181	my( $interpreted, $flag ) = ( '', undef );
	182	if( @text ) {
	183	( $interpreted, $flag ) = interpret(
	184	join( ' ', map { $_->{'content'} } @text ), $lemma_str );
	185	}
4d85a60e	186	my @rdg_nodes;
4d85a60e	187	foreach my $w ( split( /\s+/, $interpreted ) ) {
12720144	188	my $r = $c->add_reading( { id => $tag . "/" . $ctr++,
12720144	189	text => $w } );
4d85a60e	190	push( @rdg_nodes, $r );
4d85a60e	191	}
f6e19c7c	192
	193	# For each listed wit, save the reading.
	194	foreach my $wit ( split( /\s+/, $rdg->getAttribute( 'wit' ) ) ) {
12720144	195	$wit .= $flag if $flag;
f6e19c7c	196	$wit_rdgs{$wit} = \@rdg_nodes;
f6e19c7c	197	}
12720144	198
3a5d151b	199	# Does the reading have an ID? If so it probably has a witDetail
f6e19c7c	200	# attached, and we need to read it.
3a5d151b	201	if( $rdg->hasAttribute( 'xml:id' ) ) {
12720144	202	warn "Witdetail on meta reading" if $flag; # this could get complicated.
f6e19c7c	203	my $rid = $rdg->getAttribute( 'xml:id' );
	204	my $xpc = XML::LibXML::XPathContext->new( $xn );
	205	my @details = $xpc->findnodes( './witDetail[@target="'.$rid.'"]' );
	206	foreach my $d ( @details ) {
	207	_parse_wit_detail( $d, \%wit_rdgs, \@lemma );
	208	}
3a5d151b	209	}
f6e19c7c	210	}
f6e19c7c	211
4d85a60e	212	# Now collate the variant readings, since it is not done for us.
12720144	213	collate_variants( $c, \@lemma, values %wit_rdgs );
	214
	215	# HACKY HACKY Expand "group" sigla.
	216	# Does not work for nested groups; also does not work with a modifier
	217	# on the group sigil.
	218	foreach my $wit_id ( keys %group_sigla ) {
	219	if ( exists $wit_rdgs{$wit_id} ) {
	220	my $rdg = $wit_rdgs{$wit_id};
	221	foreach my $w ( @{$group_sigla{$wit_id}} ) {
	222	if( exists $wit_rdgs{$w} ) {
	223	$DB::single = 1;
	224	warn "Had reading for individual member $w of group $wit_id at $xn";
	225	}
	226	$wit_rdgs{$w} = $rdg;
	227	}
	228	delete $wit_rdgs{$wit_id};
	229	}
	230	}
4d85a60e	231
4d85a60e	232	# Now add the witness paths for each reading.
f6e19c7c	233	foreach my $wit_id ( keys %wit_rdgs ) {
	234	my $witstr = get_sigil( $wit_id, $c );
	235	my $rdg_list = $wit_rdgs{$wit_id};
	236	_add_wit_path( $c, $rdg_list, $app_id, $anchor, $witstr );
6f4946fb	237	}
4d85a60e	238	}
6f4946fb	239
4d85a60e	240	sub _anchor_name {
	241	my $xmlid = shift;
	242	$xmlid =~ s/^\#//;
	243	return sprintf( "#ANCHOR_%s#", $xmlid );
6f4946fb	244	}
6f4946fb	245
4d85a60e	246	sub _return_lemma {
4d85a60e	247	my( $c, $app, $anchor ) = @_;
12720144	248	my @nodes = grep { $_->id !~ /^\#A(PP\|NCHOR)/ }
	249	$c->reading_sequence( $c->reading( $app ), $c->reading( $anchor ),
	250	$c->baselabel );
4d85a60e	251	return @nodes;
4d85a60e	252	}
6f4946fb	253
6f4946fb	254	sub interpret {
4d85a60e	255	# A utility function to change apparatus-ese into a full variant.
	256	my( $reading, $lemma ) = @_;
	257	return $reading if $reading eq $lemma;
	258	my $oldreading = $reading;
	259	# $lemma =~ s/\s+[[:punct:]]+$//;
	260	# $reading =~ s/\s*\(?sic([\s\w.]+)?\)?$//;
12720144	261	my $flag; # In case of p.c. indications
4d85a60e	262	my @words = split( /\s+/, $lemma );
	263	if( $reading =~ /^(.*) praem.$/ ) {
	264	$reading = "$1 $lemma";
	265	} elsif( $reading =~ /^(.*) add.$/ ) {
	266	$reading = "$lemma $1";
12720144	267	} elsif( $reading =~ /add. alia manu/ ) {
	268	# Ignore it.
	269	$reading = $lemma;
f6e19c7c	270	} elsif( $reading eq 'om.'
	271	\|\| $reading =~ /locus [uv]acuus/
	272	\|\| $reading =~ /inscriptionem compegi e/ # TODO huh?
	273	\|\| $reading eq 'def.' # TODO huh?
	274	) {
4d85a60e	275	$reading = '';
12720144	276	} elsif( $reading =~ /^in[uv]\.$/ ) {
4d85a60e	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 ) );
12720144	281	} elsif( $reading =~ /^iter(\.\|at)$/ ) {
4d85a60e	282	# Repeat the lemma
4d85a60e	283	$reading = "$lemma $lemma";
12720144	284	} elsif( $reading eq 'in marg.' ) {
	285	# There was nothing before a correction.
	286	$reading = '';
	287	$flag = '_ac';
	288	} elsif( $reading =~ /^(.) \.\.\. (.)$/ ) {
4d85a60e	289	# The first and last N words captured should replace the first and
	290	# last N words of the lemma.
	291	my @begin = split( /\s+/, $1 );
	292	my @end = split( /\s+/, $2 );
	293	if( scalar( @begin ) + scalar ( @end ) > scalar( @words ) ) {
	294	# Something is wrong and we can't do the splice.
	295	print STDERR "ERROR: $lemma is too short to accommodate $oldreading\n";
	296	} else {
	297	splice( @words, 0, scalar @begin, @begin );
	298	splice( @words, -(scalar @end), scalar @end, @end );
	299	$reading = join( ' ', @words );
	300	}
6f4946fb	301	}
12720144	302	if( $oldreading ne $reading \|\| $flag \|\| $oldreading =~ /\./ ) {
	303	my $int = $reading;
	304	$int .= " ($flag)" if $flag;
	305	print STDERR "Interpreted $oldreading as $int given $lemma\n";
	306	}
	307	return( $reading, $flag );
4d85a60e	308	}
4d85a60e	309
f6e19c7c	310	sub _parse_wit_detail {
	311	my( $detail, $readings, $lemma ) = @_;
	312	my $wit = $detail->getAttribute( 'wit' );
	313	my $content = $detail->textContent;
	314	if( $content =~ /a\.\s*c\./ ) {
	315	# Replace the key in the $readings hash
	316	my $rdg = delete $readings->{$wit};
	317	$readings->{$wit.'_ac'} = $rdg;
	318	$has_ac{$sigil_for{$wit}} = 1;
	319	} elsif( $content =~ /p\.\s*c\./ ) {
	320	# If no key for the wit a.c. exists, add one pointing to the lemma
	321	unless( exists $readings->{$wit.'_ac'} ) {
	322	$readings->{$wit.'_ac'} = $lemma;
	323	}
	324	$has_ac{$sigil_for{$wit}} = 1;
	325	} # else don't bother just yet
	326	}
	327
	328	sub get_sigil {
	329	my( $xml_id, $c ) = @_;
	330	if( $xml_id =~ /^(.*)_ac$/ ) {
	331	my $real_id = $1;
	332	return $sigil_for{$real_id} . $c->ac_label;
	333	} else {
	334	return $sigil_for{$xml_id};
	335	}
	336	}
	337
	338	sub expand_all_paths {
	339	my( $c ) = @_;
	340
	341	# Walk the collation and fish out the paths for each witness
	342	foreach my $wit ( $c->tradition->witnesses ) {
	343	my $sig = $wit->sigil;
12720144	344	my @path = grep { !$_->is_ph }
f6e19c7c	345	$c->reading_sequence( $c->start, $c->end, $sig );
	346	$wit->path( \@path );
	347	if( $has_ac{$sig} ) {
12720144	348	my @ac_path = grep { !$_->is_ph }
f6e19c7c	349	$c->reading_sequence( $c->start, $c->end, $sig.$c->ac_label, $sig );
	350	$wit->uncorrected_path( \@ac_path );
	351	}
	352	}
	353
	354	# Delete the anchors
12720144	355	foreach my $anchor ( grep { $_->is_ph } $c->readings ) {
f6e19c7c	356	$c->del_reading( $anchor );
f6e19c7c	357	}
12720144	358	# Delete the base edges
12720144	359	map { $c->del_path( $_, $c->baselabel ) } $c->paths;
f6e19c7c	360
	361	# Make the path edges
	362	$c->make_witness_paths();
4d85a60e	363	}
	364
	365	sub _add_wit_path {
f6e19c7c	366	my( $c, $rdg, $app, $anchor, $wit ) = @_;
4d85a60e	367	my @nodes = @$rdg;
f6e19c7c	368	push( @nodes, $c->reading( $anchor ) );
4d85a60e	369
f6e19c7c	370	my $cur = $c->reading( $app );
4d85a60e	371	foreach my $n ( @nodes ) {
f6e19c7c	372	$c->add_path( $cur, $n, $wit );
4d85a60e	373	$cur = $n;
6f4946fb	374	}
6f4946fb	375	}
	376
	377	=back
	378
	379	=head1 LICENSE
	380
	381	This package is free software and is provided "as is" without express
	382	or implied warranty. You can redistribute it and/or modify it under
	383	the same terms as Perl itself.
	384
	385	=head1 AUTHOR
	386
	387	Tara L Andrews, aurum@cpan.org
	388
	389	=cut
	390
	391	1;
	392