From: Tara L Andrews <tla@mit.edu>
Date: Thu, 23 Aug 2012 18:56:38 +0000 (+0200)
Subject: allow dump and reload of Result objects via JSON
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a42a164c8f2546c74dd09c33c9bc54b624f80ae4;p=scpubgit%2Fstemmatology.git

allow dump and reload of Result objects via JSON
---

diff --git a/lib/Text/Tradition/Analysis/Result.pm b/lib/Text/Tradition/Analysis/Result.pm
index d38daa2..8bd41f2 100644
--- a/lib/Text/Tradition/Analysis/Result.pm
+++ b/lib/Text/Tradition/Analysis/Result.pm
@@ -1,6 +1,8 @@
 package Text::Tradition::Analysis::Result;
 
 use Moose;
+use Digest::MD5 qw/ md5_hex /;
+use Encode qw/ encode_utf8 /;
 use JSON qw/ to_json /;
 use Set::Scalar;
 use Text::Tradition::Error;
@@ -105,25 +107,9 @@ around BUILDARGS => sub {
 	# then alphabetically by first-sorted.
 	die "Must specify a set list to Analysis::Result->new()" 
 		unless ref( $args->{'setlist'} ) eq 'ARRAY'; 
-	my @sets;
-	foreach my $set ( @{$args->{'setlist'}} ) {
-		my $s = $set;
-		# Check uniqueness of the current set
-		if( ref( $set ) ne 'Set::Scalar' ) {
-			$s = Set::Scalar->new( @$set );
-			die "Duplicate element(s) in set passed to Analysis::Result->new()"
-				unless @$set == $s->elements;
-		}
-		# Check distinctness of the set from all other sets given so far
-		foreach my $ps ( @sets ) {
-			die "Two sets are not disjoint"
-				unless $s->is_disjoint( $ps );
-		}
-		# Save the set.
-		push( @sets, $s );
-	}
-	# Order the sets.
-	$args->{'setlist'} = [ sort { by_size_and_alpha( $a, $b ) } @sets ];
+	# Order the sets and make sure they are all distinct Set::Scalars.
+	$args->{'setlist'} = _check_set_args( $args->{'setlist'} );
+	$args->{'groupinglist'} = _check_set_args( $args->{'groupinglist'} );
 	
 	# If we have been passed a Text::Tradition::Stemma or a Graph, save only
 	# its string.
@@ -143,6 +129,28 @@ around BUILDARGS => sub {
 	return $class->$orig( $args );
 };
 
+sub _check_set_args {
+	my $setlist = shift;
+	my @sets;
+	foreach my $set ( @{$setlist} ) {
+		my $s = $set;
+		# Check uniqueness of the current set
+		if( ref( $set ) ne 'Set::Scalar' ) {
+			$s = Set::Scalar->new( @$set );
+			die "Duplicate element(s) in set or group passed to Analysis::Result->new()"
+				unless @$set == $s->elements;
+		}
+		# Check distinctness of the set from all other sets given so far
+		foreach my $ps ( @sets ) {
+			die "Two sets are not disjoint"
+				unless $s->is_disjoint( $ps );
+		}
+		# Save the set.
+		push( @sets, $s );
+	}
+	return [ sort { by_size_and_alpha( $a, $b ) } @sets ];
+}	
+
 sub BUILD {
 	my $self = shift;
 	
@@ -173,6 +181,11 @@ sub record_grouping {
 
 # A request string is the graph followed by the groups, which should form a unique
 # key for the result.
+sub object_key {
+	my $self = shift;
+	return md5_hex( encode_utf8( $self->request_string ) );
+}
+
 sub request_string {
 	my $self = shift;
 	return string_from_graph_problem( $self->graph, [ $self->sets ] );
@@ -244,6 +257,30 @@ sub minimum_grouping_for {
 	return $self->grouping( $midx );
 }
 
+sub TO_JSON {
+	my $self = shift;
+	# Graph and setlist
+	my $data = { 
+		graph => $self->graph, 
+		setlist => [],
+		groupinglist => [],
+		classlist => {}
+	};
+	$data->{is_genealogical} = 1 if $self->is_genealogical;
+	foreach my $set ( $self->sets ) {
+		push( @{$data->{setlist}}, [ $set->members ] );
+	}
+	# groupinglist
+	foreach my $group ( $self->groupings ) {
+		push( @{$data->{groupinglist}}, [ $group->members ] );
+	}
+	# classlist
+	foreach my $wit ( $self->assigned_wits ) {
+		$data->{classlist}->{$wit} = $self->class( $wit );
+	}
+	return $data;
+}
+
 sub throw {
 	Text::Tradition::Error->throw( 
 		'ident' => 'Analysis::Result error',
diff --git a/t/data/analysis.db b/t/data/analysis.db
index ce18ac5..f000bdc 100644
Binary files a/t/data/analysis.db and b/t/data/analysis.db differ