[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 "Name of 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 "Test stemma 1" {
     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
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" );
ok( $stemma->has_identifier, "Stemma identifier was found in dot" );
is( $stemma->identifier, 'Coislinianum lineage', "Correct stemma identifier was found in dot" );
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" );

# Create an undirected graph
my $undirdotfh;
open( $undirdotfh, 't/data/besoin_undirected.dot' ) or die "Could not open test dotfile";
binmode( $undirdotfh, ':utf8' );
my $udstemma = Text::Tradition::Stemma->new( dot => $undirdotfh );
is( ref( $udstemma ), 'Text::Tradition::Stemma', "Created stemma from undirected dotfile" );
is( scalar $udstemma->witnesses, 13, "Found correct number of extant witnesses" );
is( scalar $udstemma->hypotheticals, 12, "Found correct number of hypotheticals" );
ok( $udstemma->is_undirected, "Stemma was recorded as undirected" );
is( $udstemma->identifier, "RHM stemma", "Undirected graph retained its name" );

=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 identifier => (
	is => 'ro',
	isa => 'Str',
	writer => 'set_identifier',
	predicate => 'has_identifier',
	);
    
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'} );
    } 
}

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 $g->isa( 'Graph' );
		foreach my $v ( $g->vertices ) {
			unless( $g->has_vertex_attribute( $v, 'class' ) ) {
				$g->set_vertex_attribute( $v, 'class', 'extant' );
			}
		}
	}
};

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 $graph;
	my $reader_out;
	my $reader_err;
	{
		local(*STDOUT);
		open( STDOUT, ">", \$reader_out );
		local(*STDERR);
		open( STDERR, ">", \$reader_err );
		$graph = $reader->read_graph( $dotfh );
		close STDOUT;
		close 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" );
	}
	## HORRIBLE HACK but there is no API access to graph attributes!
	my $graph_id = exists $graph->[4]->{'name'} ? $graph->[4]->{'name'} : 'stemma';
	# Correct for implicit graph -> digraph quirk of reader
	if( $reader_err && $reader_err =~ /graph will be treated as digraph/ ) {
		my $udgraph = $graph->undirected_copy;
		foreach my $v ( $graph->vertices ) {
			$udgraph->set_vertex_attributes( $v, $graph->get_vertex_attributes( $v ) );
		}
		$graph = $udgraph;
	}
	$self->graph( $graph );
	$self->set_identifier( $graph_id );
}

sub is_undirected {
	my( $self ) = @_;
	return undef unless $self->has_graph;
	return $self->graph->is_undirected;
}

=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,
    	'bgcolor' => 'transparent',
    );
    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 $gname = $self->has_identifier ? '"' . $self->identifier . '"'
		: 'stemma';
	my @dotlines;
	push( @dotlines, "$gdecl $gname {" );
	## 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 ) {
    	my %vattr = ( 'id' => $n );  # Set the SVG element ID to the sigil itself
        if( $graph->has_vertex_attribute( $n, 'label' ) ) {
        	$vattr{'label'} = $graph->get_vertex_attribute( $n, 'label' );
        }
		push( @dotlines, _make_dotline( $n, %vattr ) );
    }
    # 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;
	if( $self->has_identifier ) {
		$opts->{'name'} = $self->identifier;
	}
	## 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 $gname = exists $opts->{'name'} ? '"' . $opts->{'name'} . '"'
		: 'stemma';
	my @dotlines;
	push( @dotlines, "$gdecl $gname {" );
	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();
    binmode $dotfile, ':utf8';
    print $dotfile $dot;
    close $dotfile;
    push( @cmd, $dotfile->filename );
    run( \@cmd, ">", binary(), \$svg );
    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;
	my $ident = $self->identifier; # will have to restore this at the end
	if( $self->is_undirected ) {
		$graph = $self->graph;
	} else {
		# Make an undirected version of this graph.
		$graph = $self->graph->undirected_copy();
	}
	# First, ensure that the requested root is actually a vertex in the graph.
	unless( $graph->has_vertex( $rootvertex ) ) {
		throw( "Cannot orient graph $graph on nonexistent vertex $rootvertex" );
	}
	
	# Now make a directed version of the graph.
	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->hypotheticals;
	map { $rooted->set_vertex_attribute( $_, 'class', 'extant' ) }
		$self->witnesses;
	$self->graph( $rooted );
	$self->set_identifier( $ident );
}


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
f96630e3	39	digraph "Name of Stemma" {
027d819c	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
f96630e3	68	digraph "Test stemma 1" {
027d819c	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
02b6340e	105	my $baddotfh;
	106	open( $baddotfh, 't/data/besoin_bad.dot' ) or die "Could not open test dotfile";
	107	try {
	108	my $stemma = Text::Tradition::Stemma->new( dot => $baddotfh );
	109	ok( 0, "Created broken stemma from dotfile with syntax error" );
	110	} catch( Text::Tradition::Error $e ) {
	111	like( $e->message, qr/^Error trying to parse/, "Syntax error in dot threw exception" );
64a36834	112	}
	113
	114	# Create a good graph
	115	my $dotfh;
	116	open( $dotfh, 't/data/florilegium.dot' ) or die "Could not open test dotfile";
	117	binmode( $dotfh, ':utf8' );
ace5fce5	118	my $stemma = Text::Tradition::Stemma->new( dot => $dotfh );
64a36834	119	is( ref( $stemma ), 'Text::Tradition::Stemma', "Created stemma from good dotfile" );
	120	is( scalar $stemma->witnesses, 13, "Found correct number of extant witnesses" );
	121	is( scalar $stemma->hypotheticals, 8, "Found correct number of extant hypotheticals" );
f96630e3	122	ok( $stemma->has_identifier, "Stemma identifier was found in dot" );
f96630e3	123	is( $stemma->identifier, 'Coislinianum lineage', "Correct stemma identifier was found in dot" );
64a36834	124	my $found_unicode_sigil;
	125	foreach my $h ( $stemma->hypotheticals ) {
	126	$found_unicode_sigil = 1 if $h eq "\x{3b1}";
	127	}
	128	ok( $found_unicode_sigil, "Found a correctly encoded Unicode sigil" );
	129
cb741417	130	# Create an undirected graph
	131	my $undirdotfh;
	132	open( $undirdotfh, 't/data/besoin_undirected.dot' ) or die "Could not open test dotfile";
	133	binmode( $undirdotfh, ':utf8' );
	134	my $udstemma = Text::Tradition::Stemma->new( dot => $undirdotfh );
	135	is( ref( $udstemma ), 'Text::Tradition::Stemma', "Created stemma from undirected dotfile" );
	136	is( scalar $udstemma->witnesses, 13, "Found correct number of extant witnesses" );
	137	is( scalar $udstemma->hypotheticals, 12, "Found correct number of hypotheticals" );
	138	ok( $udstemma->is_undirected, "Stemma was recorded as undirected" );
6665a327	139	is( $udstemma->identifier, "RHM stemma", "Undirected graph retained its name" );
ea45d2a6	140
64a36834	141	=end testing
64a36834	142
027d819c	143	=cut
027d819c	144
9463b0bf	145	has collation => (
	146	is => 'ro',
	147	isa => 'Text::Tradition::Collation',
ea45d2a6	148	clearer => 'clear_collation', # interim measure to remove refs in DB
8d9a1cd8	149	weak_ref => 1,
9463b0bf	150	);
9463b0bf	151
e05997e2	152	has graph => (
	153	is => 'rw',
	154	isa => 'Graph',
	155	predicate => 'has_graph',
	156	);
ea45d2a6	157
98f22390	158	has identifier => (
ea45d2a6	159	is => 'ro',
98f22390	160	isa => 'Str',
	161	writer => 'set_identifier',
	162	predicate => 'has_identifier',
ea45d2a6	163	);
98f22390	164
e05997e2	165	sub BUILD {
	166	my( $self, $args ) = @_;
	167	# If we have been handed a dotfile, initialize it into a graph.
	168	if( exists $args->{'dot'} ) {
027d819c	169	$self->_graph_from_dot( $args->{'dot'} );
98f22390	170	}
c0ccdb62	171	}
c0ccdb62	172
ea45d2a6	173	before 'graph' => sub {
	174	my $self = shift;
	175	if( @_ ) {
	176	# Make sure all unclassed graph nodes are marked extant.
	177	my $g = $_[0];
	178	throw( "Cannot set graph to a non-Graph object" )
cb741417	179	unless $g->isa( 'Graph' );
ea45d2a6	180	foreach my $v ( $g->vertices ) {
	181	unless( $g->has_vertex_attribute( $v, 'class' ) ) {
	182	$g->set_vertex_attribute( $v, 'class', 'extant' );
	183	}
	184	}
98f22390	185	}
	186	};
	187
027d819c	188	sub _graph_from_dot {
8d9a1cd8	189	my( $self, $dotfh ) = @_;
8d9a1cd8	190	my $reader = Graph::Reader::Dot->new();
64a36834	191	# Redirect STDOUT in order to trap any error messages - syntax errors
64a36834	192	# are evidently not fatal.
02b6340e	193	my $graph;
02b6340e	194	my $reader_out;
cb741417	195	my $reader_err;
02b6340e	196	{
	197	local(*STDOUT);
	198	open( STDOUT, ">", \$reader_out );
cb741417	199	local(*STDERR);
cb741417	200	open( STDERR, ">", \$reader_err );
02b6340e	201	$graph = $reader->read_graph( $dotfh );
02b6340e	202	close STDOUT;
cb741417	203	close STDERR;
02b6340e	204	}
64a36834	205	if( $reader_out && $reader_out =~ /error/s ) {
	206	throw( "Error trying to parse dot: $reader_out" );
	207	} elsif( !$graph ) {
	208	throw( "Failed to create graph from dot" );
	209	}
6665a327	210	## HORRIBLE HACK but there is no API access to graph attributes!
6665a327	211	my $graph_id = exists $graph->[4]->{'name'} ? $graph->[4]->{'name'} : 'stemma';
cb741417	212	# Correct for implicit graph -> digraph quirk of reader
	213	if( $reader_err && $reader_err =~ /graph will be treated as digraph/ ) {
	214	my $udgraph = $graph->undirected_copy;
	215	foreach my $v ( $graph->vertices ) {
	216	$udgraph->set_vertex_attributes( $v, $graph->get_vertex_attributes( $v ) );
	217	}
	218	$graph = $udgraph;
	219	}
64a36834	220	$self->graph( $graph );
6665a327	221	$self->set_identifier( $graph_id );
8d9a1cd8	222	}
8d9a1cd8	223
98f22390	224	sub is_undirected {
	225	my( $self ) = @_;
	226	return undef unless $self->has_graph;
	227	return $self->graph->is_undirected;
	228	}
	229
027d819c	230	=head1 METHODS
	231
	232	=head2 as_dot( \%options )
	233
	234	Returns a normal dot representation of the stemma layout, suitable for rendering
	235	with GraphViz. Options include:
	236
	237	=over
	238
	239	=item * graph - A hashref of global graph options.
	240
	241	=item * node - A hashref of global node options.
	242
	243	=item * edge - A hashref of global edge options.
	244
	245	=back
	246
	247	See the GraphViz documentation for the list of available options.
	248
	249	=cut
	250
8d9a1cd8	251	sub as_dot {
e367f5c0	252	my( $self, $opts ) = @_;
7a7c249c	253
335a62ef	254	## See if we are including any a.c. witnesses in this graph.
	255	my $graph = $self->graph;
	256	if( exists $opts->{'layerwits'} ) {
5c44c598	257	my $extant = {};
	258	map { $extant->{$_} = 1 } $self->witnesses;
	259	$graph = $self->situation_graph( $extant, $opts->{'layerwits'} );
335a62ef	260	}
335a62ef	261
7a7c249c	262	# Get default and specified options
e02340f3	263	my %graphopts = (
e02340f3	264	# 'ratio' => 1,
f05e891c	265	'bgcolor' => 'transparent',
e02340f3	266	);
7a7c249c	267	my %nodeopts = (
7a7c249c	268	'fontsize' => 11,
7a7c249c	269	'style' => 'filled',
7a7c249c	270	'fillcolor' => 'white',
e02340f3	271	'color' => 'white',
7a7c249c	272	'shape' => 'ellipse', # Shape for the extant nodes
	273	);
	274	my %edgeopts = (
e02340f3	275	'arrowhead' => 'none',
7a7c249c	276	);
	277	@graphopts{ keys %{$opts->{'graph'}} } = values %{$opts->{'graph'}}
	278	if $opts->{'graph'};
	279	@nodeopts{ keys %{$opts->{'node'}} } = values %{$opts->{'node'}}
	280	if $opts->{'node'};
	281	@edgeopts{ keys %{$opts->{'edge'}} } = values %{$opts->{'edge'}}
	282	if $opts->{'edge'};
335a62ef	283
ea45d2a6	284	my $gdecl = $graph->is_directed ? 'digraph' : 'graph';
f96630e3	285	my $gname = $self->has_identifier ? '"' . $self->identifier . '"'
f96630e3	286	: 'stemma';
7a7c249c	287	my @dotlines;
f96630e3	288	push( @dotlines, "$gdecl $gname {" );
7a7c249c	289	## Print out the global attributes
	290	push( @dotlines, _make_dotline( 'graph', %graphopts ) ) if keys %graphopts;
	291	push( @dotlines, _make_dotline( 'edge', %edgeopts ) ) if keys %edgeopts;
7a7c249c	292	push( @dotlines, _make_dotline( 'node', %nodeopts ) ) if keys %nodeopts;
	293
	294	# Add each of the nodes.
335a62ef	295	foreach my $n ( $graph->vertices ) {
c753ea40	296	my %vattr = ( 'id' => $n ); # Set the SVG element ID to the sigil itself
335a62ef	297	if( $graph->has_vertex_attribute( $n, 'label' ) ) {
c753ea40	298	$vattr{'label'} = $graph->get_vertex_attribute( $n, 'label' );
e79c23c7	299	}
c753ea40	300	push( @dotlines, _make_dotline( $n, %vattr ) );
e79c23c7	301	}
7a7c249c	302	# Add each of our edges.
335a62ef	303	foreach my $e ( $graph->edges ) {
986bbd1b	304	my( $from, $to ) = map { _dotquote( $_ ) } @$e;
ea45d2a6	305	my $connector = $graph->is_directed ? '->' : '--';
ea45d2a6	306	push( @dotlines, " $from $connector $to;" );
7a7c249c	307	}
7a7c249c	308	push( @dotlines, '}' );
e79c23c7	309
7a7c249c	310	return join( "\n", @dotlines );
	311	}
	312
0bded693	313	=head2 alter_graph( $dotstring )
	314
	315	Alters the graph of this stemma according to the definition specified
	316	in $dotstring.
	317
	318	=cut
	319
	320	sub alter_graph {
	321	my( $self, $dotstring ) = @_;
	322	my $dotfh;
	323	open $dotfh, '<', \$dotstring;
f90b2bde	324	binmode $dotfh, ':utf8';
0bded693	325	$self->_graph_from_dot( $dotfh );
	326	}
	327
335a62ef	328	=head2 editable( $opts )
027d819c	329
5c44c598	330	=head2 editable_graph( $graph, $opts )
5c44c598	331
88a6bac5	332	Returns a version of the graph rendered in our definition format. The
335a62ef	333	output separates statements with a newline; set $opts->{'linesep'} to the
	334	empty string or to a space if the result is to be sent via JSON.
	335
5c44c598	336	If a situational version of the stemma is required, the arguments for
5c44c598	337	situation_graph should be passed via $opts->{'extant'} and $opts->{'layerwits'}.
027d819c	338
027d819c	339	=cut
7a7c249c	340
7a7c249c	341	sub editable {
5c44c598	342	my( $self, $opts ) = @_;
335a62ef	343	my $graph = $self->graph;
f96630e3	344	if( $self->has_identifier ) {
	345	$opts->{'name'} = $self->identifier;
	346	}
5c44c598	347	## See if we need an editable version of a situational graph.
	348	if( exists $opts->{'layerwits'} \|\| exists $opts->{'extant'} ) {
	349	my $extant = delete $opts->{'extant'} \|\| {};
	350	my $layerwits = delete $opts->{'layerwits'} \|\| [];
	351	$graph = $self->situation_graph( $extant, $layerwits );
335a62ef	352	}
5c44c598	353	return editable_graph( $graph, $opts );
	354	}
	355
	356	sub editable_graph {
	357	my( $graph, $opts ) = @_;
335a62ef	358
	359	# Create the graph
	360	my $join = ( $opts && exists $opts->{'linesep'} ) ? $opts->{'linesep'} : "\n";
ea45d2a6	361	my $gdecl = $graph->is_undirected ? 'graph' : 'digraph';
f96630e3	362	my $gname = exists $opts->{'name'} ? '"' . $opts->{'name'} . '"'
f96630e3	363	: 'stemma';
7a7c249c	364	my @dotlines;
f96630e3	365	push( @dotlines, "$gdecl $gname {" );
7a7c249c	366	my @real; # A cheap sort
5c44c598	367	foreach my $n ( sort $graph->vertices ) {
5c44c598	368	my $c = $graph->get_vertex_attribute( $n, 'class' );
7a7c249c	369	$c = 'extant' unless $c;
	370	if( $c eq 'extant' ) {
	371	push( @real, $n );
	372	} else {
	373	push( @dotlines, _make_dotline( $n, 'class' => $c ) );
	374	}
e367f5c0	375	}
7a7c249c	376	# Now do the real ones
	377	foreach my $n ( @real ) {
	378	push( @dotlines, _make_dotline( $n, 'class' => 'extant' ) );
	379	}
5c44c598	380	foreach my $e ( sort _by_vertex $graph->edges ) {
986bbd1b	381	my( $from, $to ) = map { _dotquote( $_ ) } @$e;
ea45d2a6	382	my $conn = $graph->is_undirected ? '--' : '->';
ea45d2a6	383	push( @dotlines, " $from $conn $to;" );
7a7c249c	384	}
7a7c249c	385	push( @dotlines, '}' );
88a6bac5	386	return join( $join, @dotlines );
7a7c249c	387	}
	388
	389	sub _make_dotline {
	390	my( $obj, %attr ) = @_;
	391	my @pairs;
	392	foreach my $k ( keys %attr ) {
986bbd1b	393	my $v = _dotquote( $attr{$k} );
986bbd1b	394	push( @pairs, "$k=$v" );
7a7c249c	395	}
986bbd1b	396	return sprintf( " %s [ %s ];", _dotquote( $obj ), join( ', ', @pairs ) );
8d9a1cd8	397	}
8d9a1cd8	398
986bbd1b	399	sub _dotquote {
	400	my( $str ) = @_;
	401	return $str if $str =~ /^[A-Za-z0-9]+$/;
	402	$str =~ s/\"/\\\"/g;
	403	$str = '"' . $str . '"';
	404	return $str;
	405	}
	406
7a7c249c	407	sub _by_vertex {
	408	return $a->[0].$a->[1] cmp $b->[0].$b->[1];
	409	}
8d9a1cd8	410
5c44c598	411	=head2 situation_graph( $extant, $layered )
335a62ef	412
ea45d2a6	413	Returns a graph which is the original stemma graph with all witnesses not
	414	in the %$extant hash marked as hypothetical, and witness layers added to
	415	the graph according to the list in @$layered. A layered (a.c.) witness is
	416	added as a parent of its main version, and additionally shares all other
	417	parents and children with that version.
335a62ef	418
	419	=cut
	420
5c44c598	421	sub situation_graph {
ace5fce5	422	my( $self, $extant, $layerwits, $layerlabel ) = @_;
5c44c598	423
	424	my $graph = $self->graph->copy;
	425	foreach my $vertex ( $graph->vertices ) {
	426	# Set as extant any vertex that is extant in the stemma AND
	427	# exists in the $extant hash.
	428	my $class = 'hypothetical';
	429	$class = 'extant' if exists $extant->{$vertex} && $extant->{$vertex} &&
	430	$self->graph->get_vertex_attribute( $vertex, 'class' ) ne 'hypothetical';
	431	$graph->set_vertex_attribute( $vertex, 'class', $class );
	432	}
	433
335a62ef	434	# For each 'layered' witness in the layerwits array, add it to the graph
	435	# as an ancestor of the 'main' witness, and otherwise with the same parent/
	436	# child links as its main analogue.
	437	# TOOD Handle case where B is copied from A but corrected from C
ace5fce5	438	$layerlabel = ' (a.c.)' unless $layerlabel;
335a62ef	439	foreach my $lw ( @$layerwits ) {
	440	# Add the layered witness and set it with the same attributes as
	441	# its 'main' analogue
5c44c598	442	throw( "Cannot add a layer to a hypothetical witness $lw" )
5c44c598	443	unless $graph->get_vertex_attribute( $lw, 'class' ) eq 'extant';
ace5fce5	444	my $lwac = $lw . $layerlabel;
335a62ef	445	$graph->add_vertex( $lwac );
	446	$graph->set_vertex_attributes( $lwac,
	447	$graph->get_vertex_attributes( $lw ) );
	448
	449	# Set it as ancestor to the main witness
	450	$graph->add_edge( $lwac, $lw );
	451
	452	# Give it the same ancestors and descendants as the main witness has,
	453	# bearing in mind that those ancestors and descendants might also just
	454	# have had a layered witness defined.
	455	foreach my $v ( $graph->predecessors( $lw ) ) {
	456	next if $v eq $lwac; # Don't add a loop
	457	$graph->add_edge( $v, $lwac );
ace5fce5	458	$graph->add_edge( $v.$layerlabel, $lwac )
ace5fce5	459	if $graph->has_vertex( $v.$layerlabel );
335a62ef	460	}
	461	foreach my $v ( $graph->successors( $lw ) ) {
	462	next if $v eq $lwac; # but this shouldn't occur
	463	$graph->add_edge( $lwac, $v );
ace5fce5	464	$graph->add_edge( $lwac, $v.$layerlabel )
ace5fce5	465	if $graph->has_vertex( $v.$layerlabel );
335a62ef	466	}
	467	}
	468	return $graph;
	469	}
	470
027d819c	471	=head2 as_svg
	472
	473	Returns an SVG representation of the graph, calling as_dot first.
	474
	475	=cut
	476
8d9a1cd8	477	sub as_svg {
	478	my( $self, $opts ) = @_;
	479	my $dot = $self->as_dot( $opts );
ea45d2a6	480	my @cmd = ( '-Tsvg' );
ea45d2a6	481	unshift( @cmd, $self->is_undirected ? 'neato' : 'dot' );
3bf5d6f1	482	my $svg;
e79c23c7	483	my $dotfile = File::Temp->new();
e79c23c7	484	binmode $dotfile, ':utf8';
8d9a1cd8	485	print $dotfile $dot;
459c39b3	486	close $dotfile;
e79c23c7	487	push( @cmd, $dotfile->filename );
e79c23c7	488	run( \@cmd, ">", binary(), \$svg );
428bcf0b	489	return decode_utf8( $svg );
e79c23c7	490	}
e79c23c7	491
027d819c	492	=head2 witnesses
	493
	494	Returns a list of the extant witnesses represented in the stemma.
	495
	496	=cut
	497
08e0fb85	498	sub witnesses {
	499	my $self = shift;
	500	my @wits = grep { $self->graph->get_vertex_attribute( $_, 'class' ) eq 'extant' }
	501	$self->graph->vertices;
	502	return @wits;
	503	}
	504
06e7cbc7	505	=head2 hypotheticals
	506
	507	Returns a list of the hypothetical witnesses represented in the stemma.
	508
	509	=cut
	510
bebec0e9	511	sub hypotheticals {
	512	my $self = shift;
	513	my @wits = grep
	514	{ $self->graph->get_vertex_attribute( $_, 'class' ) eq 'hypothetical' }
	515	$self->graph->vertices;
	516	return @wits;
	517	}
	518
37bf09f4	519	=head2 root_graph( $root_vertex )
ea45d2a6	520
	521	If the stemma graph is undirected, make it directed with $root_vertex at the root.
	522	If it is directed, re-root it.
	523
	524	=cut
	525
	526	sub root_graph {
	527	my( $self, $rootvertex ) = @_;
	528	my $graph;
907f6671	529	my $ident = $self->identifier; # will have to restore this at the end
ea45d2a6	530	if( $self->is_undirected ) {
	531	$graph = $self->graph;
	532	} else {
	533	# Make an undirected version of this graph.
	534	$graph = $self->graph->undirected_copy();
	535	}
1cf6dd32	536	# First, ensure that the requested root is actually a vertex in the graph.
	537	unless( $graph->has_vertex( $rootvertex ) ) {
	538	throw( "Cannot orient graph $graph on nonexistent vertex $rootvertex" );
	539	}
	540
	541	# Now make a directed version of the graph.
ea45d2a6	542	my $rooted = Graph->new();
	543	$rooted->add_vertex( $rootvertex );
	544	my @next = ( $rootvertex );
	545	while( @next ) {
	546	my @children;
	547	foreach my $v ( @next ) {
	548	# Place its not-placed neighbors (ergo children) in the tree
	549	# and connect them
	550	foreach my $n ( grep { !$rooted->has_vertex( $_ ) }
	551	$graph->neighbors( $v ) ) {
	552	$rooted->add_vertex( $n );
	553	$rooted->add_edge( $v, $n );
	554	push( @children, $n );
	555	}
	556	}
	557	@next = @children;
	558	}
	559	# Set the vertex classes
	560	map { $rooted->set_vertex_attribute( $_, 'class', 'hypothetical' ) }
1cf6dd32	561	$self->hypotheticals;
	562	map { $rooted->set_vertex_attribute( $_, 'class', 'extant' ) }
	563	$self->witnesses;
	564	$self->graph( $rooted );
907f6671	565	$self->set_identifier( $ident );
ea45d2a6	566	}
	567
	568
63778331	569	sub throw {
	570	Text::Tradition::Error->throw(
	571	'ident' => 'Stemma error',
	572	'message' => $_[0],
	573	);
	574	}
	575
	576
9463b0bf	577	no Moose;
	578	__PACKAGE__->meta->make_immutable;
	579
	580	1;
027d819c	581
	582	=head1 LICENSE
	583
	584	This package is free software and is provided "as is" without express
	585	or implied warranty. You can redistribute it and/or modify it under
	586	the same terms as Perl itself.
	587
	588	=head1 AUTHOR
	589
	590	Tara L Andrews E<lt>aurum@cpan.orgE<gt>