File Coverage

blib/lib/Set/Equivalence.pm

Criterion	Covered	Total	%
statement	225	225	100.0
branch	60	76	78.9
condition	15	27	55.5
subroutine	72	72	100.0
pod	49	49	100.0
total	421	449	93.7

use 5.008;
use strict;
use warnings;

package Set::Equivalence;

BEGIN {
	$Set::Equivalence::AUTHORITY = 'cpan:TOBYINK';
	$Set::Equivalence::VERSION   = '0.003';
}

use Carp qw( croak );
use List::Util qw( first );
use List::MoreUtils qw( any );
use Scalar::Util qw( blessed refaddr );

# avoid unnecessarily importing constant.pm
sub true()  { !!1 };
sub false() { !!0 };

use overload
	'""'     => 'as_string',
	'+'      => 'union',
	'*'      => 'intersection',
	'%'      => 'symmetric_difference',
	'-'      => 'difference',
	'=='     => 'equal',
	'eq'     => 'equal',
	'!='     => 'not_equal',
	'ne'     => 'not_equal',
	'<'      => 'proper_subset',
	'>'      => 'proper_superset',
	'<='     => 'subset',
	'>='     => 'superset',
	'@{}'    => 'as_array',
	'bool'   =>  sub { 1 },
	fallback => 1;

sub new {
	my $class = shift;
	my %args  = @_;

	my $init = delete($args{members});
	my $self = bless {
		equivalence_relation => $class->_build_equivalence_relation(\%args),
		members              => [],
		mutable              => true,
		%args,
	} => $class;

	local $self->{mutable} = true;
	$self->insert(@$init) if $init;

	return $self;
}

sub equivalence_relation {
	shift->{equivalence_relation};
}

sub type_constraint {
	shift->{type_constraint};
}

sub should_coerce {
	my $self = shift;
	$self->{coerce} and $self->{type_constraint} and $self->{type_constraint}->has_coercion
}

sub is_mutable {
	!! shift->{mutable};
}

sub is_immutable {
	not shift->is_mutable;
}

sub make_immutable {
	my $self = shift;
	$self->{mutable} = false;
	return $self;
}

sub _default_equivalence_relation {
	no warnings 'uninitialized';
	my ($x, $y) = @_;

	# If 'eq' says they're not equal, then trust it.
	return false unless $x eq $y;

	# However, there are some situations where 'eq'
	# might provide a false positive.

	# Undef is not equal to ""
	return false unless !!defined($x) == !!defined($y);

	# A non-overloaded object can never be equal to a string!
	return false if !ref($x) && ref($y) && !overload::Overloaded($y);
	return false if !ref($y) && ref($x) && !overload::Overloaded($x);

	# OK then, they're equal!
	return true;
}

sub _build_equivalence_relation { \&_default_equivalence_relation };

sub insert {
	my $self = shift;
	croak "cannot call insert on immutable set"
		unless $self->is_mutable;

	my $eq = $self->equivalence_relation;
	my $tc = $self->type_constraint;
	my $sc = $self->should_coerce;

	my $count;
	ITEM: while (@_) {
		my $item = $sc ? $tc->coerce(shift @_) : (shift @_);
		$tc->check($item) || croak $tc->get_message($item) if $tc;
		next ITEM if any { $eq->($_, $item) } $self->members;
		push @{$self->{members}}, $item;
		$count++;
	}

	return $count;
}

sub _unshift {
	my $self = shift;
	croak "cannot call _unshift on immutable set"
		unless $self->is_mutable;

	my $eq = $self->equivalence_relation;
	my $tc = $self->type_constraint;
	my $sc = $self->should_coerce;

	my $count;
	ITEM: while (@_) {
		my $item = $sc ? $tc->coerce(pop @_) : (pop @_);
		$tc->check($item) || croak $tc->get_message($item) if $tc;
		next ITEM if any { $eq->($_, $item) } $self->members;
		unshift @{$self->{members}}, $item;
		$count++;
	}

	return $count;
}

sub contains {
	my $self = shift;

	my $eq = $self->equivalence_relation;

	return true unless @_;

	ITEM: while (@_) {
		my $item = shift @_;
		return false unless any { $eq->($_, $item) } $self->members;
	}

	return true;
}

sub member {
	my $self = shift;
	my $item = $_[0];
	my $eq = $self->equivalence_relation;
	for ($self->members) {
		return $_ if $eq->($_, $item)
	}
	return;
}

sub members {
	my $self = shift;
	@{$self->{members}};
}

sub size {
	my $self = shift;
	scalar @{$self->{members}};
}

sub remove {
	my $self = shift;
	croak "cannot call remove on immutable set"
		unless $self->is_mutable;

	my $eq = $self->equivalence_relation;

	return 0 unless @_;

	my ($count, @new_set) = 0;
	OLD_SET: for my $member ($self->members) {
		REMOVALS: for my $item (@_) {
			if ($eq->($member, $item)) {
				$count++;
				next OLD_SET;
			}
		}
		push @new_set, $member;
	}

	@{$self->{members}} = @new_set;
	return $count;
}

sub weaken {
	die "unimplemented";
}

sub is_weak {
	false;
}

sub strengthen {
	$_[0];
}

sub invert {
	my $self = shift;
	croak "cannot call invert on immutable set"
		unless $self->is_mutable;

	my ($hasnt, $has) = List::MoreUtils::part { $self->contains($_) } @_;

	if (@{$has||[]}) {
		$self->remove(@$has);
	}
	$self->insert(@$hasnt);
}

sub clear {
	my $self = shift;
	croak "cannot call clear on immutable set"
		unless $self->is_mutable;

	my $size = $self->size;
	@{$self->{members}} = ();
	return $size;
}

sub as_string {
	my $self = shift;
	"(" . join(" ", sort $self->members) . ")";
}

sub _args
{
	my $n = shift;
	my ($class, @eq, @tc);

	if (ref $_[0])
	{
		$class = ref($_[0]);
		@eq = (equivalence_relation => $_[0]->equivalence_relation);
		@tc = (type_constraint => $_[0]->type_constraint) if $_[0]->type_constraint;
	}
	else
	{
		$class = shift;
	}

	for (0 .. $n-1) {
		blessed($_[$_]) && $_[$_]->isa($class)
			or croak("expected $class; got $_[$_]");
	}

	return (
		sub {
			my @members = @_;
			$class->new(members => \@members, @eq, @tc);
		}, @_
	);
}

sub equal {
	my (undef, $this, $that) = _args 2, @_;
	return true if refaddr($this) == refaddr($that);
	$this->contains($that->members) and $that->contains($this->members);
}

sub not_equal {
	my (undef, $this, $that) = _args 2, @_;
	not $this->equal($that);
}

sub clone {
	my ($maker, $this) = _args 1, @_;
	return $maker->( $this->members );
}

sub intersection {
	my ($maker, $this, $that) = _args 2, @_;
	return $maker->(
		grep $that->contains($_), $this->members
	);
}

sub union {
	my ($maker, $this, $that) = _args 2, @_;
	return $maker->( $this->members, $that->members );
}

sub difference {
	my ($maker, $this, $that) = _args 2, @_;
	my $new = $maker->( $this->members );
	$new->remove($that->members);
	return $new;
}

sub symmetric_difference {
	my ($maker, $this, $that) = _args 2, @_;
	my $new = $maker->( $this->members );
	$new->invert($that->members);
	return $new;
}

sub subset {
	my (undef, $this, $that) = _args 2, @_;
	$that->contains($this->members);
}

sub proper_subset {
	my (undef, $this, $that) = _args 2, @_;
	$that->contains($this->members) and not $this->contains($that->members);
}

sub superset {
	my (undef, $this, $that) = _args 2, @_;
	$this->contains($that->members);
}

sub proper_superset {
	my (undef, $this, $that) = _args 2, @_;
	$this->contains($that->members) and not $that->contains($this->members);
}

sub is_null {
	my $self = shift;
	$self->size == 0;
}

sub compare {
	die "unimplemented";
}

sub is_disjoint {
	my (undef, $this, $that) = _args 2, @_;
	return $this->intersection($that)->is_null;
}

sub as_string_callback {
	die "unimplemented";
}

# Aliases
sub includes { shift->contains(@_) }
sub has      { shift->contains(@_) }
sub element  { shift->member(@_) }
sub elements { shift->members(@_) }
sub delete   { shift->remove(@_) }
sub is_empty { shift->is_null(@_) }

# Exports
BEGIN {
	require Exporter::Tiny;
	push our(@ISA), 'Exporter::Tiny';
	push our(@EXPORT_OK), 'set', 'typed_set';
};
sub set       {                 __PACKAGE__->new(members => \@_,                       ) };
sub typed_set { my $tc = shift; __PACKAGE__->new(members => \@_, type_constraint => $tc) };

# Extra fun
sub as_array {
	my $self = shift;
	my $array = $self->{_array} ||= do {
		require Set::Equivalence::_Tie;
		tie my @arr, 'Set::Equivalence::_Tie', $self;
		\@arr;
	};
	Scalar::Util::weaken($self->{_array}) unless Scalar::Util::isweak($self->{_array});
	return $array;
}

sub iterator {
	my $self = shift;
	my @elements = $self->members;
	return sub { shift @elements };
}

sub map {
	my ($maker, $this, $code) = _args 1, @_;
	shift unless blessed $_[0];
	return $maker->(map $code->($_), $this->members);
}

sub grep {
	my ($maker, $this, $code) = _args 1, @_;
	shift unless blessed $_[0];
	return $maker->(grep $code->($_), $this->members);
}

sub reduce {
	my (undef, $this, $code) = _args 1, @_;
	@_ = ($code, $this->members);
	goto \&List::Util::reduce;
}

sub part {
	my ($maker, $this, $code) = _args 1, @_;
	return map $maker->(@$_), &List::MoreUtils::part($code, $this->members);
}

sub pop {
	my $self = shift;
	croak "cannot call pop on immutable set"
		unless $self->is_mutable;
	return if $self->is_null;
	$self->remove( my $r = $self->{members}[-1] );
	return $r;
}

sub _shift {
	my $self = shift;
	croak "cannot call _shift on immutable set"
		unless $self->is_mutable;
	return if $self->is_null;
	$self->remove( my $r = $self->{members}[0] );
	return $r;
}

set -> is_null

__END__