Algorithm-CP-IZ

 view release on metacpan or  search on metacpan

lib/Algorithm/CP/IZ.pm  view on Meta::CPAN

package Algorithm::CP::IZ;

use 5.010000; # need Newx in XS
use strict;
use warnings;

use Carp;
use Scalar::Util qw(weaken blessed looks_like_number);

require Exporter;
use AutoLoader;

use Algorithm::CP::IZ::Int;
use Algorithm::CP::IZ::RefVarArray;
use Algorithm::CP::IZ::RefIntArray;
use Algorithm::CP::IZ::ParamValidator qw(validate);
use Algorithm::CP::IZ::ValueSelector;
use Algorithm::CP::IZ::CriteriaValueSelector;
use Algorithm::CP::IZ::NoGoodSet;
use Algorithm::CP::IZ::SearchNotify;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Algorithm::CP::IZ ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'value_selector' => [ qw(
    CS_VALUE_SELECTOR_MIN_TO_MAX
    CS_VALUE_SELECTOR_MAX_TO_MIN
    CS_VALUE_SELECTOR_LOWER_AND_UPPER
    CS_VALUE_SELECTOR_UPPER_AND_LOWER
    CS_VALUE_SELECTOR_MEDIAN_AND_REST
    CS_VALUE_SELECTION_EQ
    CS_VALUE_SELECTION_NEQ
    CS_VALUE_SELECTION_LE
    CS_VALUE_SELECTION_LT
    CS_VALUE_SELECTION_GE
    CS_VALUE_SELECTION_GT
) ]);

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'value_selector'} } );

our $VERSION = '0.07';

sub AUTOLOAD {
    # This AUTOLOAD is used to 'autoload' constants from the constant()
    # XS function.

    my $constname;
    our $AUTOLOAD;
    ($constname = $AUTOLOAD) =~ s/.*:://;
    croak "&Algorithm::CP::IZ::constant not defined" if $constname eq 'constant';
    my ($error, $val) = constant($constname);
    if ($error) { croak $error; }
    {
	no strict 'refs';
	# Fixed between 5.005_53 and 5.005_61
#XXX	if ($] >= 5.00561) {
#XXX	    *$AUTOLOAD = sub () { $val };
#XXX	}
#XXX	else {
	    *$AUTOLOAD = sub { $val };
#XXX	}
    }

lib/Algorithm/CP/IZ.pm  view on Meta::CPAN

sub accept_context {
    my $self = shift;

    my $cxt = $self->{_cxt};
    if (@$cxt == 0) {
	_report_error("accept_context: bottom of context stack");
    }

    Algorithm::CP::IZ::cs_acceptContext();

    # pop must be after cs_acceptContext to save cs_backtrack context.
    pop(@$cxt);
}

sub accept_context_until {
    my $self = shift;
    my $label = shift;

    validate([$label], ["I"],
	     "Usage: accept_context_until(int_label)");

    my $cxt = $self->{_cxt};
    if (@$cxt == 0) {
	_report_error("accept_context_until: invalid label");
    }

    while (@$cxt >= $label) {
	Algorithm::CP::IZ::cs_acceptContext();

	# pop must be after cs_acceptContext to save cs_backtrack context.
	pop(@$cxt);
    }
}

sub accept_all {
    my $self = shift;
    my $label = shift;

    Algorithm::CP::IZ::cs_acceptAll();

    # pop must be after cs_acceptContext to save cs_backtrack context.
    $self->{_cxt} = [];
}

my $Backtrack_id = 0;

sub backtrack {
    my $self = shift;
    my ($var, $index, $handler) = @_;

    validate([$var, $index, $handler], ["oV", "I", "C"],
	     "Usage: backtrack(variable, index, code_ref)");

    $var = _safe_var($var) if (defined($var));
    
    my $id = $Backtrack_id++;
    $self->{_backtracks}->{$id} = [$var, $index, $handler];

    my $backtracks = $self->{_backtracks};
    weaken($backtracks);

    $self->{_backtrack_code_ref} ||= sub {
	my $bid = shift;
	my $r = $backtracks->{$bid};
	my $bh = $r->[2];
	&$bh($r->[0], $r->[1]);

	delete $backtracks->{$bid};
    };

    my $vptr = defined($var) ? $$var : 0;

    Algorithm::CP::IZ::cs_backtrack($vptr, $id,
				    $self->{_backtrack_code_ref});
}

sub _create_int_from_min_max {
    my ($self, $min, $max) = @_;
    validate([$min, $max], ["I", "I"], "Usage: create_int(min, max), create_int(constant), create_int([domain])");
    return Algorithm::CP::IZ::cs_createCSint(int($min), int($max));
}

sub _create_int_from_domain {
    my ($self, $int_array) = @_;
    validate([$int_array], ["iA1"], "Usage: create_int(min, max), create_int(constant), create_int([domain])");

    my $parray = Algorithm::CP::IZ::alloc_int_array([map { int($_) } @$int_array]);
    my $ptr = Algorithm::CP::IZ::cs_createCSintFromDomain($parray, scalar @$int_array);
    Algorithm::CP::IZ::free_array($parray);

    return $ptr;
}

sub create_int {
    my $self = shift;
    my $p1 = shift;

    my $ptr;
    my $name;

    if (!ref $p1 && @_ == 0) {
	return $self->_const_var($p1);
    }
    elsif (ref $p1 && ref $p1 eq 'ARRAY') {
	$name = shift;
	$ptr = $self->_create_int_from_domain($p1);
	unless ($ptr) {
	    my $param_str = join(", ", @$p1);
	    _report_error("cannot create variable from [$param_str]");
	}
    }
    else {
	my $min = $p1;
	my $max = shift;
	$name = shift;

	$ptr = $self->_create_int_from_min_max($min, $max);
	unless ($ptr) {
	    my $param_str = join(", ", $min, $max);
	    _report_error("cannot create variable from ($param_str)");

lib/Algorithm/CP/IZ.pm  view on Meta::CPAN

	return &$handler($var_array->[$index], $index, $old_min, $var_array, $ext) ? 1 : 0;
    };

    $self->_push_object($h);

    return Algorithm::CP::IZ::cs_eventNewMin($$parray, scalar(@$var_array), $h);
}

sub event_new_max {
    my $self = shift;
    my ($var_array, $handler, $ext) = @_;

    validate([$var_array, $handler], ["vA0", "C"],
	     "Usage: event_new_max([variables], code_ref, ext)");

    my $parray = $self->_create_registered_var_array($var_array);

    my $h = sub {
	my ($index, $old_min) = @_;
	return &$handler($var_array->[$index], $index, $old_min, $var_array, $ext) ? 1 : 0;
    };

    $self->_push_object($h);

    return Algorithm::CP::IZ::cs_eventNewMax($$parray, scalar(@$var_array), $h);
}

sub event_neq {
    my $self = shift;
    my ($var_array, $handler, $ext) = @_;

    validate([$var_array, $handler], ["vA0", "C"],
	     "Usage: event_eq([variables], code_ref, ext)");

    my $parray = $self->_create_registered_var_array($var_array);

    my $h = sub {
	my ($index, $val) = @_;
	return &$handler($var_array->[$index], $index, $val, $var_array, $ext) ? 1 : 0;
    };

    $self->_push_object($h);

    return Algorithm::CP::IZ::cs_eventNeq($$parray, scalar(@$var_array), $h);
}

#####################################################
# Global constraints
#####################################################

sub _register_variable {
    my ($self, $var) = @_;

    my $vars = $self->{_vars};
    if (scalar @$vars == 0 || defined($vars->[scalar(@$vars)-1])) {
	push(@$vars, $var);
    }
    else {
	$vars->[scalar(@$vars)-1] = $var;
    }
    weaken($vars->[scalar(@$vars)-1]);
}

sub _argv_func {
    my $v = shift;
    my $N = shift;
    my $arg2_func = shift;
    my $argv_func = shift;

    if (@$v == 1) {
	return $v;
    }
    elsif (@$v == 2) {
	no strict "refs";
	return &$arg2_func(@$v);
    }
    elsif (@$v <= $N) {
	my $n = scalar @$v;
	no strict "refs";
	my $xs = "$argv_func$n";
	return &$xs(@$v);
    }

    my @ptrs;
    my @rest = @$v;
    for my $i (1..$N) {
	my $p = shift @rest;
	push(@ptrs, $p);
    }

    push(@rest, _argv_func(\@ptrs, $N, $arg2_func, $argv_func));

    return _argv_func(\@rest, $N, $arg2_func, $argv_func);
}

sub Add {
    my $self = shift;
    my @params = @_;

    my $usage_msg = 'usage: Add(v1, v2, ...)';
    if (@params < 1) {
	_report_error($usage_msg);
    }
    for my $v (@params) {
	validate([$v], ["V"], $usage_msg);
    }

    if (@params == 1) {
	return $params[0] if (ref $params[0]);
	return $self->_const_var(int($params[0]));
    }

    my @v = map { ref $_ ? $_ : $self->_const_var(int($_)) } @params;

    my $ptr = _argv_func([map { $$_} @v], 10,
			 "Algorithm::CP::IZ::cs_Add",
			 "Algorithm::CP::IZ::cs_VAdd");

    my $ret = Algorithm::CP::IZ::Int->new($ptr);
    $self->_register_variable($ret);