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

package Text::Tradition::Stemma;

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 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 * dot - A filehandle open to a DOT representation of the stemma graph.

=item * graph - If no DOT specification is given, you can pass a Graph object
instead.  The vertices of the graph should have an attribute 'class' set to
either of the values 'extant' or 'hypothetical'.

=item * is_undirected - If the graph specification (or graph object) is for an
undirected graph (e.g. a phylogenetic tree), this should be set.

=back

=begin testing

use TryCatch;

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

# Try to create a bad graph
TODO: {
	local $TODO = "cannot use stdout redirection trick with FastCGI";
	my $baddotfh;
	open( $baddotfh, 't/data/besoin_bad.dot' ) or die "Could not open test dotfile";
	try {
		my $stemma = Text::Tradition::Stemma->new( 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( 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" );

# TODO Create stemma from graph, create stemma from undirected graph,
# create stemma from incompletely-specified graph

=end testing

=cut

has collation => (
    is => 'ro',
    isa => 'Text::Tradition::Collation',
    clearer => 'clear_collation', # interim measure to remove refs in DB
    weak_ref => 1,
    );  

has graph => (
    is => 'rw',
    isa => 'Graph',
    predicate => 'has_graph',
    );
    
has is_undirected => (
	is => 'ro',
	isa => 'Bool',
	default => undef,
	writer => 'set_undirected',
	);
        	
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'} );
    } else {
	}
}

before 'graph' => sub {
	my $self = shift;
	if( @_ ) {
		# Make sure all unclassed graph nodes are marked extant.
		my $g = $_[0];
		throw( "Cannot set graph to a non-Graph object" ) 
			unless ref( $g ) eq 'Graph';
		foreach my $v ( $g->vertices ) {
			unless( $g->has_vertex_attribute( $v, 'class' ) ) {
				$g->set_vertex_attribute( $v, 'class', 'extant' );
			}
		}
		$self->set_undirected( $g->is_undirected );
	}
};

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.
	# TODO This breaks under FastCGI/Apache; reconsider.
 	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 );
}

=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 $gdecl = $graph->is_directed ? 'digraph' : 'graph';
	my @dotlines;
	push( @dotlines, "$gdecl 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;
    	my $connector = $graph->is_directed ? '->' : '--';
    	push( @dotlines, "  $from $connector $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;
	binmode $dotfh, ':utf8';
	$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 $gdecl = $graph->is_undirected ? 'graph' : 'digraph';
	my @dotlines;
	push( @dotlines, "$gdecl 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;
		my $conn = $graph->is_undirected ? '--' : '->';
		push( @dotlines, "  $from $conn $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 graph 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, $layerlabel ) = @_;
	
	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
	$layerlabel = ' (a.c.)' unless $layerlabel;
	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 . $layerlabel;
		$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.$layerlabel, $lwac )
				if $graph->has_vertex( $v.$layerlabel );
		}
		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.$layerlabel )
				if $graph->has_vertex( $v.$layerlabel );
		}
	}
	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 = ( '-Tsvg' );
    unshift( @cmd, $self->is_undirected ? 'neato' : 'dot' );
    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.
    	# TODO Also scale the viewbox
		my $width = $svgdoc->documentElement->getAttribute('width');
		my $height = $svgdoc->documentElement->getAttribute('height');
		$width =~ s/\D+//g;
		$height =~ s/\D+//g;
		my( $remove, $keep, $val, $viewbox );
		if( $width > $height ) {
			$remove = 'height';
			$keep = 'width';
			$val = $ew . 'px';
			my $vbheight = $width / $ew * $height;
			$viewbox = "0.00 0.00 $width.00" . sprintf( "%.2f", $vbheight );
		} else {
			$remove = 'width';
			$keep = 'height';
			$val = $eh . 'px';
			my $vbwidth = $height / $eh * $width;
			$viewbox = "0.00 0.00 " . sprintf( "%.2f", $vbwidth ) . " $height.00";
		}
		$svgdoc->documentElement->removeAttribute( $remove );
		$svgdoc->documentElement->setAttribute( $keep, $val );
		$svgdoc->documentElement->removeAttribute( 'viewBox' );
		$svgdoc->documentElement->setAttribute( 'viewBox', $viewbox );
		$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;
}

=head2 root_graph( $root_vertex ) {

If the stemma graph is undirected, make it directed with $root_vertex at the root.
If it is directed, re-root it.

=cut

sub root_graph {
	my( $self, $rootvertex ) = @_;
	my $graph;
	if( $self->is_undirected ) {
		$graph = $self->graph;
	} else {
		# Make an undirected version of this graph.
		$graph = $self->graph->undirected_copy();
	}
	my $rooted = Graph->new();
	$rooted->add_vertex( $rootvertex );
	my @next = ( $rootvertex );
	while( @next ) {
		my @children;
		foreach my $v ( @next ) {
			# Place its not-placed neighbors (ergo children) in the tree
			# and connect them
			foreach my $n ( grep { !$rooted->has_vertex( $_ ) } 
				$graph->neighbors( $v ) ) {
				$rooted->add_vertex( $n );
				$rooted->add_edge( $v, $n );
				push( @children, $n );
			}
		}
		@next = @children;
	}
	# Set the vertex classes
	map { $rooted->set_vertex_attribute( $_, 'class', 'hypothetical' ) }
		$self->graph->hypotheticals;
	map { $rooted->set_vertex_class( $_, 'class', 'extant' ) }
		$self->graph->witnesses;
	return $rooted;
}


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