From: Tara L Andrews <tla\@mit.edu>
Date: Thu, 22 Dec 2011 13:31:37 +0000 (+0100)
Subject: change identity pools to use KiokuDB::Set
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1ca1163d2db79aab2458bd09721be9d8a16940c3;p=scpubgit%2Fstemmatology.git

change identity pools to use KiokuDB::Set
---

diff --git a/lib/Text/Tradition/Collation/Reading.pm b/lib/Text/Tradition/Collation/Reading.pm
index 9591206..be874ec 100644
--- a/lib/Text/Tradition/Collation/Reading.pm
+++ b/lib/Text/Tradition/Collation/Reading.pm
@@ -2,6 +2,8 @@ package Text::Tradition::Collation::Reading;
 
 use Moose;
 use MooseX::NonMoose;
+use KiokuDB::Set;
+use KiokuDB::Util qw/ weak_set /;
 
 extends 'Graph::Easy::Node';
 
@@ -20,21 +22,27 @@ has 'is_lacuna' => (
 # shared by the reading objects inside the pool.  When a reading is
 # added to the pool, all the same_as attributes should be updated.
 has 'same_as' => (
+	does => 'KiokuDB::Set',
     is => 'rw',
-    isa => 'ArrayRef[Text::Tradition::Collation::Reading]',
     );
+    
+has 'is_primary' => (
+	is => 'rw',
+	isa => 'Bool',
+	default => 1,
+	);
 
 # Deal with the non-arg option for Graph::Easy's constructor.
 around BUILDARGS => sub {
-    my $orig = shift;
-    my $class = shift;
-
-    my %args;
-    if( @_ == 1 && ref( $_[0] ) ne 'HASH' ) {
-	return $class->$orig( 'name' => $_[0] );
-    } else {
-	return $class->$orig( @_ );
-    }
+	my $orig = shift;
+	my $class = shift;
+
+	my %args;
+	if( @_ == 1 && ref( $_[0] ) ne 'HASH' ) {
+		return $class->$orig( 'name' => $_[0] );
+	} else {
+		return $class->$orig( @_ );
+	}
 };
 
 # A lacuna node is also a meta node.
@@ -47,8 +55,9 @@ before is_lacuna => sub {
 
 # Initialize the identity pool. 
 sub BUILD {
-    my( $self, $args ) = @_;
-    $self->same_as( [ $self ] );
+	my( $self, $args ) = @_;
+	my $pool = weak_set( $self );
+	$self->same_as( $pool );
 }
 
 sub text {
@@ -65,157 +74,160 @@ sub text {
 }
 
 sub witnessed_by {
-    my( $self, $sigil, $backup ) = @_;
-    my @wits = $self->witnesses;
-    return 1 if grep { $_ eq $sigil } @wits;
-    if( $backup ) {
-        return 1 if grep { $_ eq $backup } @wits;
-    }
-    return 0;
+	my( $self, $sigil, $backup ) = @_;
+	my @wits = $self->witnesses;
+	return 1 if grep { $_ eq $sigil } @wits;
+	if( $backup ) {
+		return 1 if grep { $_ eq $backup } @wits;
+	}
+	return 0;
 }
     
 sub witnesses {
-    my( $self ) = @_;
-    my @paths = grep { $_->get_attribute( 'class' ) eq 'path' } $self->outgoing;
-    push( @paths, grep { $_->get_attribute( 'class' ) eq 'path' } $self->incoming );
-    my %wits;
-    foreach my $p ( @paths ) {
-        if( $p->has_hidden_witnesses ) {
-            foreach ( @{$p->hidden_witnesses} ) {
-                $wits{$_} = 1;
-            }
-        } else {
-            $wits{$p->label} = 1;
-        }
-    }
-    return keys %wits;
+	my( $self ) = @_;
+	my @paths = grep { $_->get_attribute( 'class' ) eq 'path' } $self->outgoing;
+	push( @paths, grep { $_->get_attribute( 'class' ) eq 'path' } $self->incoming );
+	my %wits;
+	foreach my $p ( @paths ) {
+		if( $p->has_hidden_witnesses ) {
+			foreach ( @{$p->hidden_witnesses} ) {
+				$wits{$_} = 1;
+			}
+		} else {
+			$wits{$p->label} = 1;
+		}
+	}
+	return keys %wits;
 }
 
 sub merge_from {
-    my( $self, $merged_node ) = @_;
-    # Adopt the identity pool of the other node.
-    my @now_identical = grep { $_ ne $merged_node } @{$merged_node->same_as};
-    my $new_pool = _merge_array_pool( \@now_identical, $self->same_as )
-	if @now_identical;
-
-    # TODO Adopt the relationship attributes and segment memberships of the other node.
+	my( $self, $merged_node ) = @_;
+	if( $self eq $merged_node ) {
+		warn "Trying to merge a reading into itself";
+		return;
+	}
+	# Adopt the identity pool of the other node.
+	my @now_identical = grep { $_ ne $merged_node && $_ ne $self  }
+		$merged_node->same_as->members;
+	if( @now_identical ) {
+		_merge_array_pool( $self->same_as, @now_identical );
+	}
 }
 
 ## Dealing with transposed readings.  These methods are only really
 ## applicable if we have a linear collation graph.
 
 sub set_identical {
-    my( $self, $other_node ) = @_; 
-    my $enlarged_pool = _merge_array_pool( $self->same_as, 
-					   $other_node->same_as );
-
-    # ...and set this node to point to the enlarged pool.
-    $self->same_as( $enlarged_pool );
-}   
+	my( $self, $other_node ) = @_;
+	if( $self eq $other_node ) {
+		warn "Trying to set a reading identical to itself";
+		return;
+	}
+	# We are no longer primary; turn that off first.
+	my @new_members = grep { $_ ne $other_node } $self->same_as->members;
+	_merge_array_pool( $other_node->same_as, @new_members );
+}	
 
 sub identical_readings {
-    my $self = shift;
-    my @same = grep { $_ ne $self } @{$self->same_as};
-    return @same;
+	my $self = shift;
+	my @same = grep { $_ ne $self } $self->same_as->members;
+	return @same;
 }
 
+## Helper function - 
 sub _merge_array_pool {
-    my( $pool, $main_pool ) = @_;
-    my %poolhash;
-    foreach ( @$main_pool ) {
-	# Note which nodes are already in the main pool so that we
-	# don't re-add them.
-	$poolhash{$_->name} = 1;
-    }
-
-    foreach( @$pool ) {
-	# Add the remaining nodes to the main pool...
-	push( @$main_pool, $_ ) unless $poolhash{$_->name};
-    }
-    return $main_pool;
+	my( $pool, @new_members ) = @_;
+	$pool->insert( @new_members );
+	foreach my $n ( @new_members ) {
+		$n->is_primary( 0 );
+		$n->same_as( $pool );
+	}
 }
 
 sub has_primary {
-    my $self = shift;
-    my $pool = $self->same_as;
-    return $pool->[0]->name ne $self->name;
+	my $self = shift;
+	return !$self->is_primary;
 }
 
 sub primary {
-    my $self = shift;
-    return $self->same_as->[0];
+	my $self = shift;
+	my @p = grep { $_->is_primary } $self->same_as->members;
+	warn "Identity pool for " . $self->name . " has more than one primary"
+		if @p > 1;
+	warn "Identity pool for " . $self->name . " has no primary" unless @p;
+	return shift( @p );
 }
 
 # Looks from the outside like an accessor for a Boolean, but really 
 # sets the node's class.  Should apply to start, end, and lacunae.
 
 sub is_meta {
-	my $self = shift;
-	my $arg = shift;
-	if( defined $arg && $arg ) {
-		$self->set_attribute( 'class', 'meta' );
-	} elsif ( defined $arg ) {
-		$self->del_attribute( 'class' );
-	}
-	return $self->sub_class eq 'meta';	
+		my $self = shift;
+		my $arg = shift;
+		if( defined $arg && $arg ) {
+				$self->set_attribute( 'class', 'meta' );
+		} elsif ( defined $arg ) {
+				$self->del_attribute( 'class' );
+		}
+		return $self->sub_class eq 'meta';		
 }
 
 # Returns all readings that adjoin this one on any path.
 sub neighbor_readings {
-    my( $self, $direction ) = @_;
-    $direction = 'both' unless $direction;
-    my @paths = grep { $_->isa( 'Text::Tradition::Collation::Path' ) } $self->edges;
-    my %connected;
-    foreach my $p ( @paths ) {
-	if( $p->to eq $self ) {
-	    next if $direction eq 'forward';
-	    $connected{$p->from->name} = $p->from;
-	} else { # $p->from eq $self
-	    next if $direction =~ /^back/;
-	    $connected{$p->to->name} = $p->to;
+	my( $self, $direction ) = @_;
+	$direction = 'both' unless $direction;
+	my @paths = grep { $_->isa( 'Text::Tradition::Collation::Path' ) } $self->edges;
+	my %connected;
+	foreach my $p ( @paths ) {
+		if( $p->to eq $self ) {
+			next if $direction eq 'forward';
+			$connected{$p->from->name} = $p->from;
+		} else { # $p->from eq $self
+			next if $direction =~ /^back/;
+			$connected{$p->to->name} = $p->to;
+		}
 	}
-    }
-    return values( %connected );
+	return values( %connected );
 }
 
 # Returns all readings related to the one we've got.
 sub related_readings {
-    my( $self, $colocated, $queried ) = @_;
-    $queried = { $self->name => 1 } unless $queried;
-    my @related;
-    # Get the nodes directly related to this one
-    foreach my $e ( $self->edges ) {
-        next unless $e->isa( 'Text::Tradition::Collation::Relationship' );
-        next if $colocated && $e->type eq 'repetition';
-        my $n = $e->from eq $self ? $e->to : $e->from;
-        next if $queried->{$n->name};
-        push( @related, $n );
-    }
-    # Now query those nodes for their relations, recursively
-    map { $queried->{$_->name} = 1 } @related;
-    my @also_related;
-    foreach ( @related ) {
-        push( @also_related, $_->related_readings( $colocated, $queried ) );
-    }
-    push( @related, @also_related );
-    return @related;
+	my( $self, $colocated, $queried ) = @_;
+	$queried = { $self->name => 1 } unless $queried;
+	my @related;
+	# Get the nodes directly related to this one
+	foreach my $e ( $self->edges ) {
+		next unless $e->isa( 'Text::Tradition::Collation::Relationship' );
+		next if $colocated && $e->type eq 'repetition';
+		my $n = $e->from eq $self ? $e->to : $e->from;
+		next if $queried->{$n->name};
+		push( @related, $n );
+	}
+	# Now query those nodes for their relations, recursively
+	map { $queried->{$_->name} = 1 } @related;
+	my @also_related;
+	foreach ( @related ) {
+		push( @also_related, $_->related_readings( $colocated, $queried ) );
+	}
+	push( @related, @also_related );
+	return @related;
 }
 
 ## Keep track of which readings are unchanged across witnesses.
 sub is_common {
-    my( $self ) = shift;
-    return $self->get_attribute( 'class' ) eq 'common';
+	my( $self ) = shift;
+	return $self->get_attribute( 'class' ) eq 'common';
 }
 
 ## TODO Rationalize make_common, is_meta, etc.
 sub make_common {
-    my( $self ) = shift;
-    $self->set_attribute( 'class', 'common' );
+	my( $self ) = shift;
+	$self->set_attribute( 'class', 'common' );
 }
 
 sub make_variant {
-    my( $self ) = shift;
-    $self->set_attribute( 'class', 'variant' );
+	my( $self ) = shift;
+	$self->set_attribute( 'class', 'variant' );
 }
 
 no Moose;