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

package Text::Tradition::Parser::Self;

use strict;
use warnings;
use Text::Tradition::Parser::GraphML qw/ graphml_parse /;
use TryCatch;

=head1 NAME

Text::Tradition::Parser::GraphML

=head1 SYNOPSIS

  use Text::Tradition;
  
  my $t_from_file = Text::Tradition->new( 
    'name' => 'my text',
    'input' => 'Self',
    'file' => '/path/to/tradition.xml'
    );
    
  my $t_from_string = Text::Tradition->new( 
    'name' => 'my text',
    'input' => 'Self',
    'string' => $tradition_xml,
    );

=head1 DESCRIPTION

Parser module for Text::Tradition to read in its own GraphML output format.
GraphML is a relatively simple graph description language; a 'graph' element
can have 'node' and 'edge' elements, and each of these can have simple 'data'
elements for attributes to be saved.

The graph itself has attributes as in the Collation object:

=over

=item * linear 

=item * ac_label

=item * baselabel

=item * wit_list_separator

=back

The node objects have the following attributes:

=over

=item * name

=item * reading

=item * identical

=item * rank

=item * class

=back

The edge objects have the following attributes:

=over

=item * class

=item * witness (for 'path' class edges)

=item * extra   (for 'path' class edges)

=item * relationship    (for 'relationship' class edges)

=item * equal_rank      (for 'relationship' class edges)

=item * non_correctable (for 'relationship' class edges)

=item * non_independent (for 'relationship' class edges)

=back

=head1 METHODS

=head2 B<parse>

parse( $graph, $opts );

Takes an initialized Text::Tradition object and a set of options; creates
the appropriate nodes and edges on the graph.  The options hash should
include either a 'file' argument or a 'string' argument, depending on the
source of the XML to be parsed.

=begin testing

use Text::Tradition;
binmode STDOUT, ":utf8";
binmode STDERR, ":utf8";
eval { no warnings; binmode $DB::OUT, ":utf8"; };

my $tradition = 't/data/florilegium_graphml.xml';
my $t = Text::Tradition->new( 
    'name'  => 'inline', 
    'input' => 'Self',
    'file'  => $tradition,
    );

is( ref( $t ), 'Text::Tradition', "Parsed GraphML version 2" );
if( $t ) {
    is( scalar $t->collation->readings, 319, "Collation has all readings" );
    is( scalar $t->collation->paths, 376, "Collation has all paths" );
    is( scalar $t->witnesses, 13, "Collation has all witnesses" );
}

# TODO add a relationship, add a stemma, write graphml, reparse it, check that 
# the new data is there
$t->language('Greek');
$t->add_stemma( 'dotfile' => 't/data/florilegium.dot' );
$t->collation->add_relationship( 'w12', 'w13', 
	{ 'type' => 'grammatical', 'scope' => 'global', 
	  'annotation' => 'This is some note' } );
ok( $t->collation->get_relationship( 'w12', 'w13' ), "Relationship set" );
my $graphml_str = $t->collation->as_graphml;

my $newt = Text::Tradition->new( 'input' => 'Self', 'string' => $graphml_str );
is( ref( $newt ), 'Text::Tradition', "Parsed current GraphML version" );
if( $newt ) {
    is( scalar $newt->collation->readings, 319, "Collation has all readings" );
    is( scalar $newt->collation->paths, 376, "Collation has all paths" );
    is( scalar $newt->witnesses, 13, "Collation has all witnesses" );
    is( scalar $newt->collation->relationships, 1, "Collation has added relationship" );
    is( $newt->language, 'Greek', "Tradition has correct language setting" );
    my $rel = $newt->collation->get_relationship( 'w12', 'w13' );
    ok( $rel, "Found set relationship" );
    is( $rel->annotation, 'This is some note', "Relationship has its properties" );
    is( scalar $newt->stemmata, 1, "Tradition has its stemma" );
    is( $newt->stemma(0)->witnesses, $t->stemma(0)->witnesses, "Stemma has correct length witness list" );
}


=end testing

=cut

sub parse {
    my( $tradition, $opts ) = @_;
    
    # Collation data is in the first graph; relationship-specific stuff 
    # is in the second.
    my( $graph_data, $rel_data ) = graphml_parse( $opts );
    
    my $collation = $tradition->collation;
    my %witnesses;
    
    # print STDERR "Setting graph globals\n";
    $tradition->name( $graph_data->{'name'} );
    my $use_version;
    my $tmeta = $tradition->meta;
    my $cmeta = $collation->meta;
    foreach my $gkey ( keys %{$graph_data->{'global'}} ) {
		my $val = $graph_data->{'global'}->{$gkey};
		if( $gkey eq 'version' ) {
			$use_version = $val;
		} elsif( $gkey eq 'stemmata' ) { # Special case, yuck
			foreach my $dotstr ( split( /\n/, $val ) ) {
				$tradition->add_stemma( 'dot' => $dotstr );
			}
		} elsif( $tmeta->has_attribute( $gkey ) ) {
			$tradition->$gkey( $val );
		} else {
			$collation->$gkey( $val );
		}
	}
		
    # Add the nodes to the graph.
    # Note any reading IDs that were changed in order to comply with XML 
    # name restrictions; we have to hardcode start & end.
    my %namechange = ( '#START#' => '__START__', '#END#' => '__END__' );

    # print STDERR "Adding collation readings\n";
    foreach my $n ( @{$graph_data->{'nodes'}} ) {    	
    	# If it is the start or end node, we already have one, so
    	# grab the rank and go.
    	next if( defined $n->{'is_start'} );
    	if( defined $n->{'is_end'} ) {
    		$collation->end->rank( $n->{'rank'} );
    		next;
    	}
		my $gnode = $collation->add_reading( $n );
		if( $gnode->id ne $n->{'id'} ) {
			$namechange{$n->{'id'}} = $gnode->id;
		}
    }
        
    # Now add the edges.
    # print STDERR "Adding collation path edges\n";
    foreach my $e ( @{$graph_data->{'edges'}} ) {
    	my $sourceid = exists $namechange{$e->{'source'}->{'id'}}
    		? $namechange{$e->{'source'}->{'id'}} : $e->{'source'}->{'id'};
    	my $targetid = exists $namechange{$e->{'target'}->{'id'}}
    		? $namechange{$e->{'target'}->{'id'}} : $e->{'target'}->{'id'};
        my $from = $collation->reading( $sourceid );
        my $to = $collation->reading( $targetid );

		warn "No witness label on path edge!" unless $e->{'witness'};
		my $label = $e->{'witness'} . ( $e->{'extra'} ? $collation->ac_label : '' );
		$collation->add_path( $from, $to, $label );
		
		# Add the witness if we don't have it already.
		unless( $witnesses{$e->{'witness'}} ) {
			$tradition->add_witness( 
				sigil => $e->{'witness'}, 'sourcetype' => 'collation' );
			$witnesses{$e->{'witness'}} = 1;
		}
		$tradition->witness( $e->{'witness'} )->is_layered( 1 ) if $e->{'extra'};
    }
    
    ## Done with the main graph, now look at the relationships.
	# Nodes are added via the call to add_reading above.  We only need
	# add the relationships themselves.
	# TODO check that scoping does trt
	$rel_data->{'edges'} ||= []; # so that the next line doesn't break on no rels
	foreach my $e ( sort { _layersort_rel( $a, $b ) } @{$rel_data->{'edges'}} ) {
    	my $sourceid = exists $namechange{$e->{'source'}->{'id'}}
    		? $namechange{$e->{'source'}->{'id'}} : $e->{'source'}->{'id'};
    	my $targetid = exists $namechange{$e->{'target'}->{'id'}}
    		? $namechange{$e->{'target'}->{'id'}} : $e->{'target'}->{'id'};
        my $from = $collation->reading( $sourceid );
        my $to = $collation->reading( $targetid );
		delete $e->{'source'};
		delete $e->{'target'};
		# The remaining keys are relationship attributes.
		# Backward compatibility...
		if( $use_version eq '2.0' || $use_version eq '3.0' ) {
			delete $e->{'class'};
			$e->{'type'} = delete $e->{'relationship'} if exists $e->{'relationship'};
		}
		# Add the specified relationship unless we already have done.
		my $rel_exists;
		if( $e->{'scope'} ne 'local' ) {
			my $relobj = $collation->get_relationship( $from, $to );
			if( $relobj && $relobj->scope eq $e->{'scope'}
				&& $relobj->type eq $e->{'type'} ) {
				$rel_exists = 1;
			}
		}
		try {
			$collation->add_relationship( $from, $to, $e ) unless $rel_exists;
		} catch( Text::Tradition::Error $e ) {
			warn "DROPPING $from -> $to: " . $e->message;
		}
	}
	
    # Save the text for each witness so that we can ensure consistency
    # later on
	$collation->text_from_paths();	
}

## Return the relationship that comes first in priority.
my %LAYERS = (
	'collated' => 1,
	'orthographic' => 2,
	'spelling' => 3,
	);

sub _layersort_rel {
	my( $a, $b ) = @_;
	my $key = exists $a->{'type'} ? 'type' : 'relationship';
	my $at = $LAYERS{$a->{$key}} || 99;
	my $bt = $LAYERS{$b->{$key}} || 99;
	return $at <=> $bt;
}

1;

=head1 BUGS / TODO

=over

=item * Make this into a stream parser with GraphML

=item * Simply field -> attribute correspondence for nodes and edges

=item * Share key name constants with Collation.pm

=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 E<lt>aurum@cpan.orgE<gt>
Commit	Line	Data
32014ec9	1	package Text::Tradition::Parser::Self;
	2
	3	use strict;
	4	use warnings;
1f7aa795	5	use Text::Tradition::Parser::GraphML qw/ graphml_parse /;
00c5bf0b	6	use TryCatch;
32014ec9	7
	8	=head1 NAME
	9
	10	Text::Tradition::Parser::GraphML
	11
e867486f	12	=head1 SYNOPSIS
	13
	14	use Text::Tradition;
	15
	16	my $t_from_file = Text::Tradition->new(
	17	'name' => 'my text',
	18	'input' => 'Self',
	19	'file' => '/path/to/tradition.xml'
	20	);
	21
	22	my $t_from_string = Text::Tradition->new(
	23	'name' => 'my text',
	24	'input' => 'Self',
	25	'string' => $tradition_xml,
	26	);
	27
32014ec9	28	=head1 DESCRIPTION
	29
	30	Parser module for Text::Tradition to read in its own GraphML output format.
e867486f	31	GraphML is a relatively simple graph description language; a 'graph' element
	32	can have 'node' and 'edge' elements, and each of these can have simple 'data'
	33	elements for attributes to be saved.
32014ec9	34
e867486f	35	The graph itself has attributes as in the Collation object:
	36
	37	=over
	38
	39	=item * linear
	40
	41	=item * ac_label
	42
	43	=item * baselabel
	44
	45	=item * wit_list_separator
	46
	47	=back
	48
	49	The node objects have the following attributes:
32014ec9	50
	51	=over
	52
e867486f	53	=item * name
	54
	55	=item * reading
	56
	57	=item * identical
	58
	59	=item * rank
	60
	61	=item * class
	62
	63	=back
	64
	65	The edge objects have the following attributes:
	66
	67	=over
	68
	69	=item * class
	70
	71	=item * witness (for 'path' class edges)
	72
	73	=item * extra (for 'path' class edges)
	74
	75	=item * relationship (for 'relationship' class edges)
	76
	77	=item * equal_rank (for 'relationship' class edges)
32014ec9	78
e867486f	79	=item * non_correctable (for 'relationship' class edges)
32014ec9	80
e867486f	81	=item * non_independent (for 'relationship' class edges)
	82
	83	=back
	84
	85	=head1 METHODS
	86
	87	=head2 B<parse>
	88
	89	parse( $graph, $opts );
	90
	91	Takes an initialized Text::Tradition object and a set of options; creates
	92	the appropriate nodes and edges on the graph. The options hash should
	93	include either a 'file' argument or a 'string' argument, depending on the
	94	source of the XML to be parsed.
	95
	96	=begin testing
	97
	98	use Text::Tradition;
	99	binmode STDOUT, ":utf8";
	100	binmode STDERR, ":utf8";
	101	eval { no warnings; binmode $DB::OUT, ":utf8"; };
	102
	103	my $tradition = 't/data/florilegium_graphml.xml';
	104	my $t = Text::Tradition->new(
	105	'name' => 'inline',
	106	'input' => 'Self',
	107	'file' => $tradition,
	108	);
	109
bbd064a9	110	is( ref( $t ), 'Text::Tradition', "Parsed GraphML version 2" );
e867486f	111	if( $t ) {
e867486f	112	is( scalar $t->collation->readings, 319, "Collation has all readings" );
255875b8	113	is( scalar $t->collation->paths, 376, "Collation has all paths" );
e867486f	114	is( scalar $t->witnesses, 13, "Collation has all witnesses" );
	115	}
	116
2a812726	117	# TODO add a relationship, add a stemma, write graphml, reparse it, check that
2a812726	118	# the new data is there
bbd064a9	119	$t->language('Greek');
2a812726	120	$t->add_stemma( 'dotfile' => 't/data/florilegium.dot' );
bbd064a9	121	$t->collation->add_relationship( 'w12', 'w13',
	122	{ 'type' => 'grammatical', 'scope' => 'global',
	123	'annotation' => 'This is some note' } );
	124	ok( $t->collation->get_relationship( 'w12', 'w13' ), "Relationship set" );
	125	my $graphml_str = $t->collation->as_graphml;
	126
	127	my $newt = Text::Tradition->new( 'input' => 'Self', 'string' => $graphml_str );
	128	is( ref( $newt ), 'Text::Tradition', "Parsed current GraphML version" );
	129	if( $newt ) {
	130	is( scalar $newt->collation->readings, 319, "Collation has all readings" );
	131	is( scalar $newt->collation->paths, 376, "Collation has all paths" );
	132	is( scalar $newt->witnesses, 13, "Collation has all witnesses" );
	133	is( scalar $newt->collation->relationships, 1, "Collation has added relationship" );
	134	is( $newt->language, 'Greek', "Tradition has correct language setting" );
	135	my $rel = $newt->collation->get_relationship( 'w12', 'w13' );
	136	ok( $rel, "Found set relationship" );
	137	is( $rel->annotation, 'This is some note', "Relationship has its properties" );
2a812726	138	is( scalar $newt->stemmata, 1, "Tradition has its stemma" );
2a812726	139	is( $newt->stemma(0)->witnesses, $t->stemma(0)->witnesses, "Stemma has correct length witness list" );
bbd064a9	140	}
	141
	142
e867486f	143	=end testing
32014ec9	144
	145	=cut
	146
32014ec9	147	sub parse {
dfc37e38	148	my( $tradition, $opts ) = @_;
2626f709	149
	150	# Collation data is in the first graph; relationship-specific stuff
	151	# is in the second.
	152	my( $graph_data, $rel_data ) = graphml_parse( $opts );
94c00c71	153
32014ec9	154	my $collation = $tradition->collation;
32014ec9	155	my %witnesses;
e309421a	156
0068967c	157	# print STDERR "Setting graph globals\n";
e3196b2a	158	$tradition->name( $graph_data->{'name'} );
2626f709	159	my $use_version;
bbd064a9	160	my $tmeta = $tradition->meta;
bbd064a9	161	my $cmeta = $collation->meta;
255875b8	162	foreach my $gkey ( keys %{$graph_data->{'global'}} ) {
	163	my $val = $graph_data->{'global'}->{$gkey};
	164	if( $gkey eq 'version' ) {
	165	$use_version = $val;
2a812726	166	} elsif( $gkey eq 'stemmata' ) { # Special case, yuck
	167	foreach my $dotstr ( split( /\n/, $val ) ) {
	168	$tradition->add_stemma( 'dot' => $dotstr );
	169	}
bbd064a9	170	} elsif( $tmeta->has_attribute( $gkey ) ) {
bbd064a9	171	$tradition->$gkey( $val );
255875b8	172	} else {
	173	$collation->$gkey( $val );
	174	}
	175	}
e309421a	176
10e4b1ac	177	# Add the nodes to the graph.
	178	# Note any reading IDs that were changed in order to comply with XML
	179	# name restrictions; we have to hardcode start & end.
	180	my %namechange = ( '#START#' => '__START__', '#END#' => '__END__' );
32014ec9	181
bbd064a9	182	# print STDERR "Adding collation readings\n";
2626f709	183	foreach my $n ( @{$graph_data->{'nodes'}} ) {
0174d6a9	184	# If it is the start or end node, we already have one, so
0174d6a9	185	# grab the rank and go.
bbd064a9	186	next if( defined $n->{'is_start'} );
	187	if( defined $n->{'is_end'} ) {
	188	$collation->end->rank( $n->{'rank'} );
0174d6a9	189	next;
0174d6a9	190	}
bbd064a9	191	my $gnode = $collation->add_reading( $n );
10e4b1ac	192	if( $gnode->id ne $n->{'id'} ) {
	193	$namechange{$n->{'id'}} = $gnode->id;
	194	}
32014ec9	195	}
910a0a6d	196
32014ec9	197	# Now add the edges.
bbd064a9	198	# print STDERR "Adding collation path edges\n";
32014ec9	199	foreach my $e ( @{$graph_data->{'edges'}} ) {
10e4b1ac	200	my $sourceid = exists $namechange{$e->{'source'}->{'id'}}
	201	? $namechange{$e->{'source'}->{'id'}} : $e->{'source'}->{'id'};
	202	my $targetid = exists $namechange{$e->{'target'}->{'id'}}
	203	? $namechange{$e->{'target'}->{'id'}} : $e->{'target'}->{'id'};
	204	my $from = $collation->reading( $sourceid );
	205	my $to = $collation->reading( $targetid );
bbd064a9	206
	207	warn "No witness label on path edge!" unless $e->{'witness'};
	208	my $label = $e->{'witness'} . ( $e->{'extra'} ? $collation->ac_label : '' );
	209	$collation->add_path( $from, $to, $label );
	210
2626f709	211	# Add the witness if we don't have it already.
bbd064a9	212	unless( $witnesses{$e->{'witness'}} ) {
82fa4d57	213	$tradition->add_witness(
82fa4d57	214	sigil => $e->{'witness'}, 'sourcetype' => 'collation' );
bbd064a9	215	$witnesses{$e->{'witness'}} = 1;
255875b8	216	}
bbd064a9	217	$tradition->witness( $e->{'witness'} )->is_layered( 1 ) if $e->{'extra'};
32014ec9	218	}
2626f709	219
	220	## Done with the main graph, now look at the relationships.
	221	# Nodes are added via the call to add_reading above. We only need
	222	# add the relationships themselves.
	223	# TODO check that scoping does trt
bf6e338d	224	$rel_data->{'edges'} \|\|= []; # so that the next line doesn't break on no rels
bf6e338d	225	foreach my $e ( sort { _layersort_rel( $a, $b ) } @{$rel_data->{'edges'}} ) {
10e4b1ac	226	my $sourceid = exists $namechange{$e->{'source'}->{'id'}}
	227	? $namechange{$e->{'source'}->{'id'}} : $e->{'source'}->{'id'};
	228	my $targetid = exists $namechange{$e->{'target'}->{'id'}}
	229	? $namechange{$e->{'target'}->{'id'}} : $e->{'target'}->{'id'};
	230	my $from = $collation->reading( $sourceid );
	231	my $to = $collation->reading( $targetid );
bbd064a9	232	delete $e->{'source'};
	233	delete $e->{'target'};
	234	# The remaining keys are relationship attributes.
	235	# Backward compatibility...
	236	if( $use_version eq '2.0' \|\| $use_version eq '3.0' ) {
	237	delete $e->{'class'};
	238	$e->{'type'} = delete $e->{'relationship'} if exists $e->{'relationship'};
	239	}
	240	# Add the specified relationship unless we already have done.
fdfa59a7	241	my $rel_exists;
bbd064a9	242	if( $e->{'scope'} ne 'local' ) {
	243	my $relobj = $collation->get_relationship( $from, $to );
	244	if( $relobj && $relobj->scope eq $e->{'scope'}
	245	&& $relobj->type eq $e->{'type'} ) {
fdfa59a7	246	$rel_exists = 1;
	247	}
	248	}
00c5bf0b	249	try {
	250	$collation->add_relationship( $from, $to, $e ) unless $rel_exists;
	251	} catch( Text::Tradition::Error $e ) {
	252	warn "DROPPING $from -> $to: " . $e->message;
	253	}
2626f709	254	}
861c3e27	255
	256	# Save the text for each witness so that we can ensure consistency
	257	# later on
bbd064a9	258	$collation->text_from_paths();
32014ec9	259	}
32014ec9	260
bf6e338d	261	## Return the relationship that comes first in priority.
	262	my %LAYERS = (
	263	'collated' => 1,
	264	'orthographic' => 2,
	265	'spelling' => 3,
	266	);
	267
	268	sub _layersort_rel {
	269	my( $a, $b ) = @_;
	270	my $key = exists $a->{'type'} ? 'type' : 'relationship';
	271	my $at = $LAYERS{$a->{$key}} \|\| 99;
	272	my $bt = $LAYERS{$b->{$key}} \|\| 99;
	273	return $at <=> $bt;
	274	}
	275
e867486f	276	1;
	277
	278	=head1 BUGS / TODO
	279
	280	=over
	281
	282	=item * Make this into a stream parser with GraphML
	283
	284	=item * Simply field -> attribute correspondence for nodes and edges
	285
	286	=item * Share key name constants with Collation.pm
	287
32014ec9	288	=back
	289
	290	=head1 LICENSE
	291
	292	This package is free software and is provided "as is" without express
	293	or implied warranty. You can redistribute it and/or modify it under
	294	the same terms as Perl itself.
	295
	296	=head1 AUTHOR
	297
e867486f	298	Tara L Andrews E<lt>aurum@cpan.orgE<gt>