[scpubgit/stemmatology.git] / lib / Text / Tradition / Stemma.pm

package Text::Tradition::Stemma;

use Bio::Phylo::IO;
use Encode qw( decode_utf8 );
use File::Temp;
use Graph;
use Graph::Reader::Dot;
use IPC::Run qw/ run binary /;
use Text::Tradition::Error;
use Text::Tradition::StemmaUtil qw/ character_input phylip_pars parse_newick /;
use Moose;

=head1 NAME

Text::Tradition::Stemma - a representation of a I<stemma codicum> for a Text::Tradition

=head1 SYNOPSIS

  use Text::Tradition;
  my $t = Text::Tradition->new( 
    'name' => 'this is a text',
    'input' => 'TEI',
    'file' => '/path/to/tei_parallel_seg_file.xml' );

  my $s = $tradition->add_stemma( dotfile => '/path/to/stemma.dot' );
    
=head1 DESCRIPTION

Text::Tradition is a library for representation and analysis of collated
texts, particularly medieval ones.  The Stemma is a representation of the
copying relationships between the witnesses in a Tradition, modelled with
a connected rooted directed acyclic graph (CRDAG).

=head1 DOT SYNTAX

The easiest way to define a stemma is to use a special form of the 'dot' 
syntax of GraphViz.  

Each stemma opens with the line

 digraph Stemma {
 
and continues with a list of all manuscript witnesses in the stemma, whether
extant witnesses or missing archetypes or hyparchetypes.  Each of these is
listed by its sigil on its own line, e.g.:

  alpha [ class=hypothetical ]
  1 [ class=hypothetical,label=* ]
  Ms4 [ class=extant ]
  
Extant witnesses are listed with class=extant; missing or postulated witnesses
are listed with class=hypothetical.  Anonymous hyparchetypes must be given a 
unique name or number, but can be represented as anonymous with the addition 
of 'label=*' to their lines.  Greek letters or other special characters may be
used as names, but they must always be wrapped in double quotes.

Links between manuscripts are then listed with arrow notation, as below. These 
lines show the direction of copying, one step at a time, for the entire stemma.

  alpha -> 1
  1 -> Ms4
  
The final line in the definition should be the closing brace:

 }
  
Thus for a set of extant manuscripts A, B, and C, where A and B were copied 
from the archetype O and C was copied from B, the definition would be:

 digraph Stemma {
     O [ class=hypothetical]
     A [ class=extant ]
     B [ class=extant ]
     C [ class=extant ]
     O -> A
     O -> B
     B -> C
 }

=head1 CONSTRUCTOR

=head2 new

The constructor.  This should generally be called from Text::Tradition, but
if called directly it takes the following options:

=over

=item * collation - The collation with which the stemma is associated.

=item * dot - A filehandle open to a DOT representation of the stemma graph.

=back

=begin testing

use Text::Tradition::Collation;
use TryCatch;

use_ok( 'Text::Tradition::Stemma' );

# Placeholder collation to use in tests
my $c = Text::Tradition::Collation->new();

# Try to create a bad graph
my $baddotfh;
open( $baddotfh, 't/data/besoin_bad.dot' ) or die "Could not open test dotfile";
try {
	my $stemma = Text::Tradition::Stemma->new( collation => $c, dot => $baddotfh );
	ok( 0, "Created broken stemma from dotfile with syntax error" );
} catch( Text::Tradition::Error $e ) {
	like( $e->message, qr/^Error trying to parse/, "Syntax error in dot threw exception" );
}

# Create a good graph
my $dotfh;
open( $dotfh, 't/data/florilegium.dot' ) or die "Could not open test dotfile";
binmode( $dotfh, ':utf8' );
my $stemma = Text::Tradition::Stemma->new( collation => $c, dot => $dotfh );
is( ref( $stemma ), 'Text::Tradition::Stemma', "Created stemma from good dotfile" );
is( scalar $stemma->witnesses, 13, "Found correct number of extant witnesses" );
is( scalar $stemma->hypotheticals, 8, "Found correct number of extant hypotheticals" );
my $found_unicode_sigil;
foreach my $h ( $stemma->hypotheticals ) {
	$found_unicode_sigil = 1 if $h eq "\x{3b1}";
}
ok( $found_unicode_sigil, "Found a correctly encoded Unicode sigil" );

=end testing

=cut

has collation => (
    is => 'ro',
    isa => 'Text::Tradition::Collation',
    required => 1,
    weak_ref => 1,
    );  

has graph => (
    is => 'rw',
    isa => 'Graph',
    predicate => 'has_graph',
    );
        	
sub BUILD {
    my( $self, $args ) = @_;
    # If we have been handed a dotfile, initialize it into a graph.
    if( exists $args->{'dot'} ) {
        $self->_graph_from_dot( $args->{'dot'} );
    }
}

sub _graph_from_dot {
	my( $self, $dotfh ) = @_;
 	my $reader = Graph::Reader::Dot->new();
 	# Redirect STDOUT in order to trap any error messages - syntax errors
 	# are evidently not fatal.
 	my $reader_out;
 	my $saved_stderr;
 	open $saved_stderr, ">&STDOUT";
 	close STDOUT;
 	open STDOUT, ">", \$reader_out;
	my $graph = $reader->read_graph( $dotfh );
	close STDOUT;
	open STDOUT, ">", \$saved_stderr;
	if( $reader_out && $reader_out =~ /error/s ) {
		throw( "Error trying to parse dot: $reader_out" );
	} elsif( !$graph ) {
		throw( "Failed to create graph from dot" );
	}
	$self->graph( $graph );
	# Go through the nodes and set any non-hypothetical node to extant.
	foreach my $v ( $self->graph->vertices ) {
		$self->graph->set_vertex_attribute( $v, 'class', 'extant' )
			unless $self->graph->has_vertex_attribute( $v, 'class' );
	}
}

=head1 METHODS

=head2 as_dot( \%options )

Returns a normal dot representation of the stemma layout, suitable for rendering
with GraphViz.  Options include:

=over

=item * graph - A hashref of global graph options.

=item * node - A hashref of global node options.

=item * edge - A hashref of global edge options.

=back

See the GraphViz documentation for the list of available options.

=cut

sub as_dot {
    my( $self, $opts ) = @_;
    
	## See if we are including any a.c. witnesses in this graph.
	my $graph = $self->graph;
	if( exists $opts->{'layerwits'} ) {
		my $extant = {};
		map { $extant->{$_} = 1 } $self->witnesses;
		$graph = $self->situation_graph( $extant, $opts->{'layerwits'} );
	}

    # Get default and specified options
    my %graphopts = (
    	# 'ratio' => 1,
    );
    my %nodeopts = (
		'fontsize' => 11,
		'style' => 'filled',
		'fillcolor' => 'white',
		'color' => 'white',
		'shape' => 'ellipse',	# Shape for the extant nodes
	);
	my %edgeopts = (
		'arrowhead' => 'none',
	);
	@graphopts{ keys %{$opts->{'graph'}} } = values %{$opts->{'graph'}} 
		if $opts->{'graph'};
	@nodeopts{ keys %{$opts->{'node'}} } = values %{$opts->{'node'}} 
		if $opts->{'node'};
	@edgeopts{ keys %{$opts->{'edge'}} } = values %{$opts->{'edge'}} 
		if $opts->{'edge'};
		
	my @dotlines;
	push( @dotlines, 'digraph stemma {' );
	## Print out the global attributes
	push( @dotlines, _make_dotline( 'graph', %graphopts ) ) if keys %graphopts;
	push( @dotlines, _make_dotline( 'edge', %edgeopts ) ) if keys %edgeopts;
	push( @dotlines, _make_dotline( 'node', %nodeopts ) ) if keys %nodeopts;

	# Add each of the nodes.
    foreach my $n ( $graph->vertices ) {
        if( $graph->has_vertex_attribute( $n, 'label' ) ) {
        	my $ltext = $graph->get_vertex_attribute( $n, 'label' );
        	push( @dotlines, _make_dotline( $n, 'label' => $ltext ) );
        } else {
        	# Use the default display settings.
        	$n = _dotquote( $n );
            push( @dotlines, "  $n;" );
        }
    }
    # Add each of our edges.
    foreach my $e ( $graph->edges ) {
    	my( $from, $to ) = map { _dotquote( $_ ) } @$e;
    	push( @dotlines, "  $from -> $to;" );
    }
    push( @dotlines, '}' );
    
    return join( "\n", @dotlines );
}

=head2 alter_graph( $dotstring )

Alters the graph of this stemma according to the definition specified
in $dotstring.

=cut

sub alter_graph {
	my( $self, $dotstring ) = @_;
	my $dotfh;
	open $dotfh, '<', \$dotstring;
	$self->_graph_from_dot( $dotfh );
}

=head2 editable( $opts )

=head2 editable_graph( $graph, $opts )

Returns a version of the graph rendered in our definition format.  The
output separates statements with a newline; set $opts->{'linesep'} to the 
empty string or to a space if the result is to be sent via JSON.

If a situational version of the stemma is required, the arguments for 
situation_graph should be passed via $opts->{'extant'} and $opts->{'layerwits'}.

=cut

sub editable {
	my( $self, $opts ) = @_;	
	my $graph = $self->graph;
	## See if we need an editable version of a situational graph.
	if( exists $opts->{'layerwits'} || exists $opts->{'extant'} ) {
		my $extant = delete $opts->{'extant'} || {};
		my $layerwits = delete $opts->{'layerwits'} || [];
		$graph = $self->situation_graph( $extant, $layerwits );
	}
	return editable_graph( $graph, $opts );
}

sub editable_graph {
	my( $graph, $opts ) = @_;

	# Create the graph
	my $join = ( $opts && exists $opts->{'linesep'} ) ? $opts->{'linesep'} : "\n";
	my @dotlines;
	push( @dotlines, 'digraph stemma {' );
	my @real; # A cheap sort
    foreach my $n ( sort $graph->vertices ) {
    	my $c = $graph->get_vertex_attribute( $n, 'class' );
    	$c = 'extant' unless $c;
    	if( $c eq 'extant' ) {
    		push( @real, $n );
    	} else {
			push( @dotlines, _make_dotline( $n, 'class' => $c ) );
		}
    }
	# Now do the real ones
	foreach my $n ( @real ) {
		push( @dotlines, _make_dotline( $n, 'class' => 'extant' ) );
	}
	foreach my $e ( sort _by_vertex $graph->edges ) {
		my( $from, $to ) = map { _dotquote( $_ ) } @$e;
		push( @dotlines, "  $from -> $to;" );
	}
    push( @dotlines, '}' );
    return join( $join, @dotlines );
}

sub _make_dotline {
	my( $obj, %attr ) = @_;
	my @pairs;
	foreach my $k ( keys %attr ) {
		my $v = _dotquote( $attr{$k} );
		push( @pairs, "$k=$v" );
	}
	return sprintf( "  %s [ %s ];", _dotquote( $obj ), join( ', ', @pairs ) );
}
	
sub _dotquote {
	my( $str ) = @_;
	return $str if $str =~ /^[A-Za-z0-9]+$/;
	$str =~ s/\"/\\\"/g;
	$str = '"' . $str . '"';
	return $str;
}

sub _by_vertex {
	return $a->[0].$a->[1] cmp $b->[0].$b->[1];
}

=head2 situation_graph( $extant, $layered )

Returns a graph which is the original stemma with all witnesses not in the
%$extant hash marked as hypothetical, and witness layers added to the graph
according to the list in @$layered.  A layered (a.c.) witness is added as a
parent of its main version, and additionally shares all other parents and
children with that version.

=cut

sub situation_graph {
	my( $self, $extant, $layerwits ) = @_;
	
	my $graph = $self->graph->copy;
	foreach my $vertex ( $graph->vertices ) {
		# Set as extant any vertex that is extant in the stemma AND 
		# exists in the $extant hash.
		my $class = 'hypothetical';
		$class = 'extant' if exists $extant->{$vertex} && $extant->{$vertex} &&
			$self->graph->get_vertex_attribute( $vertex, 'class' ) ne 'hypothetical';
		$graph->set_vertex_attribute( $vertex, 'class', $class );
	}
	
	# For each 'layered' witness in the layerwits array, add it to the graph
	# as an ancestor of the 'main' witness, and otherwise with the same parent/
	# child links as its main analogue.
	# TOOD Handle case where B is copied from A but corrected from C
	my $aclabel = $self->collation->ac_label;
	foreach my $lw ( @$layerwits ) {
		# Add the layered witness and set it with the same attributes as
		# its 'main' analogue
		throw( "Cannot add a layer to a hypothetical witness $lw" )
			unless $graph->get_vertex_attribute( $lw, 'class' ) eq 'extant';
		my $lwac = $lw . $aclabel;
		$graph->add_vertex( $lwac );
		$graph->set_vertex_attributes( $lwac,
			$graph->get_vertex_attributes( $lw ) );
			
		# Set it as ancestor to the main witness
		$graph->add_edge( $lwac, $lw );
		
		# Give it the same ancestors and descendants as the main witness has,
		# bearing in mind that those ancestors and descendants might also just
		# have had a layered witness defined.
		foreach my $v ( $graph->predecessors( $lw ) ) {
			next if $v eq $lwac; # Don't add a loop
			$graph->add_edge( $v, $lwac );
			$graph->add_edge( $v.$aclabel, $lwac )
				if $graph->has_vertex( $v.$aclabel );
		}
		foreach my $v ( $graph->successors( $lw ) ) {
			next if $v eq $lwac; # but this shouldn't occur
			$graph->add_edge( $lwac, $v );
			$graph->add_edge( $lwac, $v.$aclabel )
				if $graph->has_vertex( $v.$aclabel );
		}
	}
	return $graph;
}

=head2 as_svg

Returns an SVG representation of the graph, calling as_dot first.

=cut

sub as_svg {
    my( $self, $opts ) = @_;
    my $dot = $self->as_dot( $opts );
    my @cmd = qw/dot -Tsvg/;
    my $svg;
    my $dotfile = File::Temp->new();
    ## TODO REMOVE
    # $dotfile->unlink_on_destroy(0);
    binmode $dotfile, ':utf8';
    print $dotfile $dot;
    close $dotfile;
    push( @cmd, $dotfile->filename );
    run( \@cmd, ">", binary(), \$svg );
    # HACK: Parse the SVG and change the dimensions.
    # Get rid of width and height attributes to allow scaling.
    if( $opts->{'size'} ) {
    	require XML::LibXML;
		my $parser = XML::LibXML->new( load_ext_dtd => 0 );
		my $svgdoc;
		eval {
			$svgdoc = $parser->parse_string( decode_utf8( $svg ) );
		};
		throw( "Could not reparse SVG: $@" ) if $@;
    	my( $ew, $eh ) = @{$opts->{'size'}};
    	# If the graph is wider than it is tall, set width to ew and remove height.
    	# Otherwise set height to eh and remove width.
		my $width = $svgdoc->documentElement->getAttribute('width');
		my $height = $svgdoc->documentElement->getAttribute('height');
		$width =~ s/\D+//g;
		$height =~ s/\D+//g;
		my( $remove, $keep, $val );
		if( $width > $height ) {
			$remove = 'height';
			$keep = 'width';
			$val = $ew . 'px';
		} else {
			$remove = 'width';
			$keep = 'height';
			$val = $eh . 'px';
		}
		$svgdoc->documentElement->removeAttribute( $remove );
		$svgdoc->documentElement->setAttribute( $keep, $val );
		$svg = $svgdoc->toString();
	}
    # Return the result
    return decode_utf8( $svg );
}

=head2 witnesses

Returns a list of the extant witnesses represented in the stemma.

=cut

sub witnesses {
    my $self = shift;
    my @wits = grep { $self->graph->get_vertex_attribute( $_, 'class' ) eq 'extant' }
        $self->graph->vertices;
    return @wits;
}

=head2 hypotheticals

Returns a list of the hypothetical witnesses represented in the stemma.

=cut

sub hypotheticals {
    my $self = shift;
    my @wits = grep 
    	{ $self->graph->get_vertex_attribute( $_, 'class' ) eq 'hypothetical' }
        $self->graph->vertices;
    return @wits;
}

sub throw {
	Text::Tradition::Error->throw( 
		'ident' => 'Stemma error',
		'message' => $_[0],
		);
}


no Moose;
__PACKAGE__->meta->make_immutable;
    
1;

=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
9463b0bf	1	package Text::Tradition::Stemma;
9463b0bf	2
40f19742	3	use Bio::Phylo::IO;
e79c23c7	4	use Encode qw( decode_utf8 );
9463b0bf	5	use File::Temp;
e05997e2	6	use Graph;
e05997e2	7	use Graph::Reader::Dot;
e79c23c7	8	use IPC::Run qw/ run binary /;
63778331	9	use Text::Tradition::Error;
b02332ca	10	use Text::Tradition::StemmaUtil qw/ character_input phylip_pars parse_newick /;
40f19742	11	use Moose;
9463b0bf	12
027d819c	13	=head1 NAME
	14
	15	Text::Tradition::Stemma - a representation of a I<stemma codicum> for a Text::Tradition
	16
	17	=head1 SYNOPSIS
	18
	19	use Text::Tradition;
	20	my $t = Text::Tradition->new(
	21	'name' => 'this is a text',
	22	'input' => 'TEI',
	23	'file' => '/path/to/tei_parallel_seg_file.xml' );
	24
	25	my $s = $tradition->add_stemma( dotfile => '/path/to/stemma.dot' );
	26
	27	=head1 DESCRIPTION
	28
	29	Text::Tradition is a library for representation and analysis of collated
335a62ef	30	texts, particularly medieval ones. The Stemma is a representation of the
	31	copying relationships between the witnesses in a Tradition, modelled with
	32	a connected rooted directed acyclic graph (CRDAG).
027d819c	33
	34	=head1 DOT SYNTAX
	35
335a62ef	36	The easiest way to define a stemma is to use a special form of the 'dot'
335a62ef	37	syntax of GraphViz.
027d819c	38
	39	Each stemma opens with the line
	40
	41	digraph Stemma {
	42
	43	and continues with a list of all manuscript witnesses in the stemma, whether
	44	extant witnesses or missing archetypes or hyparchetypes. Each of these is
	45	listed by its sigil on its own line, e.g.:
	46
	47	alpha [ class=hypothetical ]
	48	1 [ class=hypothetical,label=* ]
	49	Ms4 [ class=extant ]
	50
	51	Extant witnesses are listed with class=extant; missing or postulated witnesses
	52	are listed with class=hypothetical. Anonymous hyparchetypes must be given a
	53	unique name or number, but can be represented as anonymous with the addition
	54	of 'label=*' to their lines. Greek letters or other special characters may be
	55	used as names, but they must always be wrapped in double quotes.
	56
	57	Links between manuscripts are then listed with arrow notation, as below. These
	58	lines show the direction of copying, one step at a time, for the entire stemma.
	59
	60	alpha -> 1
	61	1 -> Ms4
	62
	63	The final line in the definition should be the closing brace:
	64
	65	}
	66
	67	Thus for a set of extant manuscripts A, B, and C, where A and B were copied
	68	from the archetype O and C was copied from B, the definition would be:
	69
	70	digraph Stemma {
	71	O [ class=hypothetical]
	72	A [ class=extant ]
	73	B [ class=extant ]
	74	C [ class=extant ]
	75	O -> A
	76	O -> B
	77	B -> C
	78	}
	79
	80	=head1 CONSTRUCTOR
	81
	82	=head2 new
	83
	84	The constructor. This should generally be called from Text::Tradition, but
	85	if called directly it takes the following options:
	86
	87	=over
	88
	89	=item * collation - The collation with which the stemma is associated.
	90
	91	=item * dot - A filehandle open to a DOT representation of the stemma graph.
	92
	93	=back
	94
64a36834	95	=begin testing
	96
	97	use Text::Tradition::Collation;
	98	use TryCatch;
	99
	100	use_ok( 'Text::Tradition::Stemma' );
	101
	102	# Placeholder collation to use in tests
	103	my $c = Text::Tradition::Collation->new();
	104
	105	# Try to create a bad graph
	106	my $baddotfh;
	107	open( $baddotfh, 't/data/besoin_bad.dot' ) or die "Could not open test dotfile";
	108	try {
	109	my $stemma = Text::Tradition::Stemma->new( collation => $c, dot => $baddotfh );
	110	ok( 0, "Created broken stemma from dotfile with syntax error" );
	111	} catch( Text::Tradition::Error $e ) {
	112	like( $e->message, qr/^Error trying to parse/, "Syntax error in dot threw exception" );
	113	}
	114
	115	# Create a good graph
	116	my $dotfh;
	117	open( $dotfh, 't/data/florilegium.dot' ) or die "Could not open test dotfile";
	118	binmode( $dotfh, ':utf8' );
	119	my $stemma = Text::Tradition::Stemma->new( collation => $c, dot => $dotfh );
	120	is( ref( $stemma ), 'Text::Tradition::Stemma', "Created stemma from good dotfile" );
	121	is( scalar $stemma->witnesses, 13, "Found correct number of extant witnesses" );
	122	is( scalar $stemma->hypotheticals, 8, "Found correct number of extant hypotheticals" );
	123	my $found_unicode_sigil;
	124	foreach my $h ( $stemma->hypotheticals ) {
	125	$found_unicode_sigil = 1 if $h eq "\x{3b1}";
	126	}
	127	ok( $found_unicode_sigil, "Found a correctly encoded Unicode sigil" );
	128
	129	=end testing
	130
027d819c	131	=cut
027d819c	132
9463b0bf	133	has collation => (
	134	is => 'ro',
	135	isa => 'Text::Tradition::Collation',
	136	required => 1,
8d9a1cd8	137	weak_ref => 1,
9463b0bf	138	);
9463b0bf	139
e05997e2	140	has graph => (
	141	is => 'rw',
	142	isa => 'Graph',
	143	predicate => 'has_graph',
	144	);
c57be097	145
e05997e2	146	sub BUILD {
	147	my( $self, $args ) = @_;
	148	# If we have been handed a dotfile, initialize it into a graph.
	149	if( exists $args->{'dot'} ) {
027d819c	150	$self->_graph_from_dot( $args->{'dot'} );
e05997e2	151	}
c0ccdb62	152	}
c0ccdb62	153
027d819c	154	sub _graph_from_dot {
8d9a1cd8	155	my( $self, $dotfh ) = @_;
8d9a1cd8	156	my $reader = Graph::Reader::Dot->new();
64a36834	157	# Redirect STDOUT in order to trap any error messages - syntax errors
	158	# are evidently not fatal.
	159	my $reader_out;
	160	my $saved_stderr;
	161	open $saved_stderr, ">&STDOUT";
	162	close STDOUT;
	163	open STDOUT, ">", \$reader_out;
8d9a1cd8	164	my $graph = $reader->read_graph( $dotfh );
64a36834	165	close STDOUT;
	166	open STDOUT, ">", \$saved_stderr;
	167	if( $reader_out && $reader_out =~ /error/s ) {
	168	throw( "Error trying to parse dot: $reader_out" );
	169	} elsif( !$graph ) {
	170	throw( "Failed to create graph from dot" );
	171	}
	172	$self->graph( $graph );
	173	# Go through the nodes and set any non-hypothetical node to extant.
	174	foreach my $v ( $self->graph->vertices ) {
	175	$self->graph->set_vertex_attribute( $v, 'class', 'extant' )
	176	unless $self->graph->has_vertex_attribute( $v, 'class' );
7a7c249c	177	}
8d9a1cd8	178	}
8d9a1cd8	179
027d819c	180	=head1 METHODS
	181
	182	=head2 as_dot( \%options )
	183
	184	Returns a normal dot representation of the stemma layout, suitable for rendering
	185	with GraphViz. Options include:
	186
	187	=over
	188
	189	=item * graph - A hashref of global graph options.
	190
	191	=item * node - A hashref of global node options.
	192
	193	=item * edge - A hashref of global edge options.
	194
	195	=back
	196
	197	See the GraphViz documentation for the list of available options.
	198
	199	=cut
	200
8d9a1cd8	201	sub as_dot {
e367f5c0	202	my( $self, $opts ) = @_;
7a7c249c	203
335a62ef	204	## See if we are including any a.c. witnesses in this graph.
	205	my $graph = $self->graph;
	206	if( exists $opts->{'layerwits'} ) {
5c44c598	207	my $extant = {};
	208	map { $extant->{$_} = 1 } $self->witnesses;
	209	$graph = $self->situation_graph( $extant, $opts->{'layerwits'} );
335a62ef	210	}
335a62ef	211
7a7c249c	212	# Get default and specified options
e02340f3	213	my %graphopts = (
	214	# 'ratio' => 1,
	215	);
7a7c249c	216	my %nodeopts = (
7a7c249c	217	'fontsize' => 11,
7a7c249c	218	'style' => 'filled',
7a7c249c	219	'fillcolor' => 'white',
e02340f3	220	'color' => 'white',
7a7c249c	221	'shape' => 'ellipse', # Shape for the extant nodes
	222	);
	223	my %edgeopts = (
e02340f3	224	'arrowhead' => 'none',
7a7c249c	225	);
	226	@graphopts{ keys %{$opts->{'graph'}} } = values %{$opts->{'graph'}}
	227	if $opts->{'graph'};
	228	@nodeopts{ keys %{$opts->{'node'}} } = values %{$opts->{'node'}}
	229	if $opts->{'node'};
	230	@edgeopts{ keys %{$opts->{'edge'}} } = values %{$opts->{'edge'}}
	231	if $opts->{'edge'};
335a62ef	232
7a7c249c	233	my @dotlines;
	234	push( @dotlines, 'digraph stemma {' );
	235	## Print out the global attributes
	236	push( @dotlines, _make_dotline( 'graph', %graphopts ) ) if keys %graphopts;
	237	push( @dotlines, _make_dotline( 'edge', %edgeopts ) ) if keys %edgeopts;
7a7c249c	238	push( @dotlines, _make_dotline( 'node', %nodeopts ) ) if keys %nodeopts;
	239
	240	# Add each of the nodes.
335a62ef	241	foreach my $n ( $graph->vertices ) {
	242	if( $graph->has_vertex_attribute( $n, 'label' ) ) {
	243	my $ltext = $graph->get_vertex_attribute( $n, 'label' );
e02340f3	244	push( @dotlines, _make_dotline( $n, 'label' => $ltext ) );
e79c23c7	245	} else {
7a7c249c	246	# Use the default display settings.
986bbd1b	247	$n = _dotquote( $n );
7a7c249c	248	push( @dotlines, " $n;" );
e79c23c7	249	}
e79c23c7	250	}
7a7c249c	251	# Add each of our edges.
335a62ef	252	foreach my $e ( $graph->edges ) {
986bbd1b	253	my( $from, $to ) = map { _dotquote( $_ ) } @$e;
7a7c249c	254	push( @dotlines, " $from -> $to;" );
	255	}
	256	push( @dotlines, '}' );
e79c23c7	257
7a7c249c	258	return join( "\n", @dotlines );
	259	}
	260
0bded693	261	=head2 alter_graph( $dotstring )
	262
	263	Alters the graph of this stemma according to the definition specified
	264	in $dotstring.
	265
	266	=cut
	267
	268	sub alter_graph {
	269	my( $self, $dotstring ) = @_;
	270	my $dotfh;
	271	open $dotfh, '<', \$dotstring;
	272	$self->_graph_from_dot( $dotfh );
	273	}
	274
335a62ef	275	=head2 editable( $opts )
027d819c	276
5c44c598	277	=head2 editable_graph( $graph, $opts )
5c44c598	278
88a6bac5	279	Returns a version of the graph rendered in our definition format. The
335a62ef	280	output separates statements with a newline; set $opts->{'linesep'} to the
	281	empty string or to a space if the result is to be sent via JSON.
	282
5c44c598	283	If a situational version of the stemma is required, the arguments for
5c44c598	284	situation_graph should be passed via $opts->{'extant'} and $opts->{'layerwits'}.
027d819c	285
027d819c	286	=cut
7a7c249c	287
7a7c249c	288	sub editable {
5c44c598	289	my( $self, $opts ) = @_;
335a62ef	290	my $graph = $self->graph;
5c44c598	291	## See if we need an editable version of a situational graph.
	292	if( exists $opts->{'layerwits'} \|\| exists $opts->{'extant'} ) {
	293	my $extant = delete $opts->{'extant'} \|\| {};
	294	my $layerwits = delete $opts->{'layerwits'} \|\| [];
	295	$graph = $self->situation_graph( $extant, $layerwits );
335a62ef	296	}
5c44c598	297	return editable_graph( $graph, $opts );
	298	}
	299
	300	sub editable_graph {
	301	my( $graph, $opts ) = @_;
335a62ef	302
	303	# Create the graph
	304	my $join = ( $opts && exists $opts->{'linesep'} ) ? $opts->{'linesep'} : "\n";
7a7c249c	305	my @dotlines;
	306	push( @dotlines, 'digraph stemma {' );
	307	my @real; # A cheap sort
5c44c598	308	foreach my $n ( sort $graph->vertices ) {
5c44c598	309	my $c = $graph->get_vertex_attribute( $n, 'class' );
7a7c249c	310	$c = 'extant' unless $c;
	311	if( $c eq 'extant' ) {
	312	push( @real, $n );
	313	} else {
	314	push( @dotlines, _make_dotline( $n, 'class' => $c ) );
	315	}
e367f5c0	316	}
7a7c249c	317	# Now do the real ones
	318	foreach my $n ( @real ) {
	319	push( @dotlines, _make_dotline( $n, 'class' => 'extant' ) );
	320	}
5c44c598	321	foreach my $e ( sort _by_vertex $graph->edges ) {
986bbd1b	322	my( $from, $to ) = map { _dotquote( $_ ) } @$e;
7a7c249c	323	push( @dotlines, " $from -> $to;" );
	324	}
	325	push( @dotlines, '}' );
88a6bac5	326	return join( $join, @dotlines );
7a7c249c	327	}
	328
	329	sub _make_dotline {
	330	my( $obj, %attr ) = @_;
	331	my @pairs;
	332	foreach my $k ( keys %attr ) {
986bbd1b	333	my $v = _dotquote( $attr{$k} );
986bbd1b	334	push( @pairs, "$k=$v" );
7a7c249c	335	}
986bbd1b	336	return sprintf( " %s [ %s ];", _dotquote( $obj ), join( ', ', @pairs ) );
8d9a1cd8	337	}
8d9a1cd8	338
986bbd1b	339	sub _dotquote {
	340	my( $str ) = @_;
	341	return $str if $str =~ /^[A-Za-z0-9]+$/;
	342	$str =~ s/\"/\\\"/g;
	343	$str = '"' . $str . '"';
	344	return $str;
	345	}
	346
7a7c249c	347	sub _by_vertex {
	348	return $a->[0].$a->[1] cmp $b->[0].$b->[1];
	349	}
8d9a1cd8	350
5c44c598	351	=head2 situation_graph( $extant, $layered )
335a62ef	352
5c44c598	353	Returns a graph which is the original stemma with all witnesses not in the
	354	%$extant hash marked as hypothetical, and witness layers added to the graph
	355	according to the list in @$layered. A layered (a.c.) witness is added as a
	356	parent of its main version, and additionally shares all other parents and
	357	children with that version.
335a62ef	358
	359	=cut
	360
5c44c598	361	sub situation_graph {
	362	my( $self, $extant, $layerwits ) = @_;
	363
	364	my $graph = $self->graph->copy;
	365	foreach my $vertex ( $graph->vertices ) {
	366	# Set as extant any vertex that is extant in the stemma AND
	367	# exists in the $extant hash.
	368	my $class = 'hypothetical';
	369	$class = 'extant' if exists $extant->{$vertex} && $extant->{$vertex} &&
	370	$self->graph->get_vertex_attribute( $vertex, 'class' ) ne 'hypothetical';
	371	$graph->set_vertex_attribute( $vertex, 'class', $class );
	372	}
	373
335a62ef	374	# For each 'layered' witness in the layerwits array, add it to the graph
	375	# as an ancestor of the 'main' witness, and otherwise with the same parent/
	376	# child links as its main analogue.
	377	# TOOD Handle case where B is copied from A but corrected from C
5c44c598	378	my $aclabel = $self->collation->ac_label;
335a62ef	379	foreach my $lw ( @$layerwits ) {
	380	# Add the layered witness and set it with the same attributes as
	381	# its 'main' analogue
5c44c598	382	throw( "Cannot add a layer to a hypothetical witness $lw" )
	383	unless $graph->get_vertex_attribute( $lw, 'class' ) eq 'extant';
	384	my $lwac = $lw . $aclabel;
335a62ef	385	$graph->add_vertex( $lwac );
	386	$graph->set_vertex_attributes( $lwac,
	387	$graph->get_vertex_attributes( $lw ) );
	388
	389	# Set it as ancestor to the main witness
	390	$graph->add_edge( $lwac, $lw );
	391
	392	# Give it the same ancestors and descendants as the main witness has,
	393	# bearing in mind that those ancestors and descendants might also just
	394	# have had a layered witness defined.
	395	foreach my $v ( $graph->predecessors( $lw ) ) {
	396	next if $v eq $lwac; # Don't add a loop
	397	$graph->add_edge( $v, $lwac );
5c44c598	398	$graph->add_edge( $v.$aclabel, $lwac )
5c44c598	399	if $graph->has_vertex( $v.$aclabel );
335a62ef	400	}
	401	foreach my $v ( $graph->successors( $lw ) ) {
	402	next if $v eq $lwac; # but this shouldn't occur
	403	$graph->add_edge( $lwac, $v );
5c44c598	404	$graph->add_edge( $lwac, $v.$aclabel )
5c44c598	405	if $graph->has_vertex( $v.$aclabel );
335a62ef	406	}
	407	}
	408	return $graph;
	409	}
	410
027d819c	411	=head2 as_svg
	412
	413	Returns an SVG representation of the graph, calling as_dot first.
	414
	415	=cut
	416
8d9a1cd8	417	sub as_svg {
	418	my( $self, $opts ) = @_;
	419	my $dot = $self->as_dot( $opts );
e79c23c7	420	my @cmd = qw/dot -Tsvg/;
3bf5d6f1	421	my $svg;
e79c23c7	422	my $dotfile = File::Temp->new();
	423	## TODO REMOVE
	424	# $dotfile->unlink_on_destroy(0);
	425	binmode $dotfile, ':utf8';
8d9a1cd8	426	print $dotfile $dot;
459c39b3	427	close $dotfile;
e79c23c7	428	push( @cmd, $dotfile->filename );
e79c23c7	429	run( \@cmd, ">", binary(), \$svg );
3bf5d6f1	430	# HACK: Parse the SVG and change the dimensions.
5a7e26a9	431	# Get rid of width and height attributes to allow scaling.
c57be097	432	if( $opts->{'size'} ) {
428bcf0b	433	require XML::LibXML;
459c39b3	434	my $parser = XML::LibXML->new( load_ext_dtd => 0 );
	435	my $svgdoc;
	436	eval {
	437	$svgdoc = $parser->parse_string( decode_utf8( $svg ) );
	438	};
	439	throw( "Could not reparse SVG: $@" ) if $@;
c57be097	440	my( $ew, $eh ) = @{$opts->{'size'}};
	441	# If the graph is wider than it is tall, set width to ew and remove height.
	442	# Otherwise set height to eh and remove width.
	443	my $width = $svgdoc->documentElement->getAttribute('width');
	444	my $height = $svgdoc->documentElement->getAttribute('height');
	445	$width =~ s/\D+//g;
	446	$height =~ s/\D+//g;
	447	my( $remove, $keep, $val );
	448	if( $width > $height ) {
	449	$remove = 'height';
	450	$keep = 'width';
	451	$val = $ew . 'px';
	452	} else {
	453	$remove = 'width';
	454	$keep = 'height';
	455	$val = $eh . 'px';
	456	}
	457	$svgdoc->documentElement->removeAttribute( $remove );
	458	$svgdoc->documentElement->setAttribute( $keep, $val );
428bcf0b	459	$svg = $svgdoc->toString();
c57be097	460	}
3bf5d6f1	461	# Return the result
428bcf0b	462	return decode_utf8( $svg );
e79c23c7	463	}
e79c23c7	464
027d819c	465	=head2 witnesses
	466
	467	Returns a list of the extant witnesses represented in the stemma.
	468
	469	=cut
	470
08e0fb85	471	sub witnesses {
	472	my $self = shift;
	473	my @wits = grep { $self->graph->get_vertex_attribute( $_, 'class' ) eq 'extant' }
	474	$self->graph->vertices;
	475	return @wits;
	476	}
	477
06e7cbc7	478	=head2 hypotheticals
	479
	480	Returns a list of the hypothetical witnesses represented in the stemma.
	481
	482	=cut
	483
bebec0e9	484	sub hypotheticals {
	485	my $self = shift;
	486	my @wits = grep
	487	{ $self->graph->get_vertex_attribute( $_, 'class' ) eq 'hypothetical' }
	488	$self->graph->vertices;
	489	return @wits;
	490	}
	491
63778331	492	sub throw {
	493	Text::Tradition::Error->throw(
	494	'ident' => 'Stemma error',
	495	'message' => $_[0],
	496	);
	497	}
	498
	499
9463b0bf	500	no Moose;
	501	__PACKAGE__->meta->make_immutable;
	502
	503	1;
027d819c	504
	505	=head1 LICENSE
	506
	507	This package is free software and is provided "as is" without express
	508	or implied warranty. You can redistribute it and/or modify it under
	509	the same terms as Perl itself.
	510
	511	=head1 AUTHOR
	512
	513	Tara L Andrews E<lt>aurum@cpan.orgE<gt>