File Coverage

blib/lib/Set/Cluster.pm

Criterion	Covered	Total	%
statement	135	136	99.2
branch	19	24	79.1
condition	9	15	60.0
subroutine	20	20	100.0
pod	6	10	60.0
total	189	205	92.2

package Set::Cluster::Result;

use 5.004;

use strict;
use warnings;
use Storable qw(dclone);
use Carp;

sub copy {
	my $self = shift;
	croak "can't copy class $self" unless (ref $self);
	my $copy = Storable::dclone($self);
	return $copy;
}

sub new {
	my $class = shift;
	my $self = {};
	return bless $self, $class;
}


package Set::Cluster;

use strict;
use warnings;

use Carp;

our $VERSION = '0.02';

sub new {
	my $class = shift;
	my $self = { results => {}, node_name_lookup => {}, item_lookup => {}, item_type => "" };
	return bless $self, $class;
}

sub setup {
	my $self = shift;
	my %args = @_;
	$self->{nodes} = $args{nodes} || croak "No nodes specified";
	$args{items} || croak "No items specified";
	if (ref $args{items} eq "ARRAY") {
		$self->{item_type} = "ARRAY";
		foreach my $object (@{$args{items}}) {
			$self->{item_lookup}->{"$object"} = $object;
			$object->can("weight") or croak "Object $object does not have a weight method";
			$self->{items}->{"$object"} = $object->weight;
		}
	} elsif (ref $args{items} eq "HASH") {
		$self->{item_type} = "HASH";
		$self->{items} = $args{items};
	} else {
		croak "items is not correct type: ".ref $args{items};
	}
}

sub results { shift->{results}; }

sub calculate {
	my $self = shift;
	my $levels = shift || 0;

	$levels = scalar @{$self->{nodes}} - 1 if ($levels >= scalar @{$self->{nodes}});

	# Setup nodes and distribute first time
	my $result = Set::Cluster::Result->new;
	foreach my $n (@{$self->{nodes}}) {
		my $stringified = "$n";
		$self->{node_name_lookup}->{$stringified} = $n;
		$result->{$stringified} = [];
	}
	$self->distribute($result, [keys %{$self->{items}}]);

	$self->process("", $result, $levels);
}

sub process {
	my ($self, $scenario, $result, $levels) = @_;
	$self->{results}->{$scenario} = $result;
	if ($levels > 0) {
		foreach my $failed_node (keys %$result) {
			my $new_state = $result->copy;
			my $scenario = join(",", split(",",$scenario), $failed_node);
			my @items = @{$new_state->{$failed_node}};
			delete $new_state->{$failed_node};
			$self->distribute($new_state, [@items]);
			$self->process($scenario, $new_state, $levels-1);
		}
	}
}

# Logic - sort items by weight. From highest, add item to
# node with lowest total weight
sub distribute {
	my ($self, $state, $items) = @_;

	my @nodes = keys %$state;
	my @items = sort { $self->{items}->{$a} <=> $self->{items}->{$b} || $a cmp $b } @$items;

	while (my $i = pop @items) {
		my $node = $self->lowest($state);
		push @{$state->{$node}}, $i;
	}
	return $state;
}

# TODO: Should keep total with the node, to save recalculating each time
sub lowest {
	my $self = shift;
	my $state = shift;
	my %totals;
	foreach my $n (keys %$state) {
		$totals{$n} = 0;
		map { $totals{$n} += $self->{items}->{$_} } @{$state->{$n}};
	}
	my @a = sort { $totals{$a} <=> $totals{$b} || $a cmp $b } keys %totals;
	return shift @a;
}

sub items {
	my $self = shift;
	my %args = @_;
	$args{fail} = $args{fail} || "";
	my $scenario = "$args{fail}";
	my $node = "$args{node}" || croak "Must specify node";
	if ($self->{item_type} eq "HASH") {
		return @{$self->results->{$scenario}->{$node}};
	} else {
		return map {$_ = $self->{item_lookup}->{$_}} @{$self->results->{$scenario}->{$node}};
	}
}

sub takeover {
	my $self = shift;
	my %args = @_;
	my $node = "$args{node}" || croak "Must specify node";
	my @fail = split (",", "$args{fail}");
	pop @fail;
	my $fail = join(",", @fail);
	my $prior = $self->results->{$fail}->{$node};
	my $now = $self->results->{$args{fail}}->{$node};
	my %seen;
	map {$seen{$_}++} @$now;
	map {$seen{$_}--} @$prior;
	my @result = ();
	map { push @result, $_ if $seen{$_}==1 } keys %seen;
	if ($self->{item_type} eq "HASH") {
		return @result;
	} else {
		return map { $_ = $self->{item_lookup}->{$_}} @result;
	}
}

sub hash_by_item {
	my $self = shift;
	my %args = @_;
	my $fail = $args{fail} || "";
	my $hash = {};
	foreach my $node (keys %{$self->results->{$fail}}) {
		my $items = $self->results->{$fail}->{$node};
		foreach my $i (@{$items}) {
			$hash->{$i} = $self->{node_name_lookup}->{$node};
		}
	}
	return $hash;
}

1;
__END__