error results from the CPAN

error

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	}
    }
    goto &$AUTOLOAD;
}

require XSLoader;
XSLoader::load('Algorithm::CP::IZ', $VERSION);

# Preloaded methods go here.

# Autoload methods go after =cut, and are processed by the autosplit program.

my $Instances = 0;

sub _report_error {
    my $msg = shift;
    croak __PACKAGE__ . ": ". $msg;
}

sub new {
    my $class = shift;

    if ($Instances > 0) {
	_report_error("another instance is working.");
    }

    Algorithm::CP::IZ::cs_init();
    $Instances++;

    bless {
	_vars => [],
	_cxt0 => [],
	_cxt => [],
	_const_vars => {},
	_backtracks => {},
	_ref_int_arrays => {},
	_ref_var_arrays => {},
    }, $class;
}

sub DESTROY {
    my $self = shift;
    my $vars = $self->{_vars};

    for my $v (@$vars) {
	# we must check existence of variable for global destruction.
	$v->_invalidate if (defined $v);
    }

    Algorithm::CP::IZ::cs_end();
    $Instances--;
}

sub save_context {
    my $self = shift;
    
    my $ret = Algorithm::CP::IZ::cs_saveContext();

    my $cxt = $self->{_cxt};
    push(@$cxt, []);

    $self->backtrack(undef, 0, sub { pop(@$cxt) });

    return $ret;
}

sub restore_context {
    my $self = shift;

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

    Algorithm::CP::IZ::cs_restoreContext();
}

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

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

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

    Algorithm::CP::IZ::cs_restoreContextUntil($label);
}

sub forget_save_context {
    my $self = shift;

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

    Algorithm::CP::IZ::cs_forgetSaveContext();
}

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

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

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

    Algorithm::CP::IZ::cs_forgetSaveContextUntil($label);
}

sub restore_all {
    my $self = shift;

    Algorithm::CP::IZ::cs_restoreAll();

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


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)");
	}
    }

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

    if (defined $name) {
	$ret->name($name);
    }

    $self->_register_variable($ret);

    return $ret;
}

sub _validate_search_params {
    my ($var_array, $params) = @_;
    return 1 unless (defined($params));
    return 0 unless (ref $params eq 'HASH');

    my %checker = (
	FindFreeVar => sub {
	    my $x = shift;
	    if (ref $x) {
		validate([$x], ["C"], "search: FindFreeVar must be a number or a coderef");
	    }
	    else {
		validate([$x], ["I"], "search: FindFreeVar must be a number or a coderef");
	    }
	},
	Criteria => sub {
	    my $x = shift;
	    validate([$x], ["C"], "search: Criteria must be a coderef");
	    return 1;
	},
	MaxFail => sub {
	    my $x = shift;
	    validate([$x], ["I"], "search: MaxFail must be an integer");
	},
	ValueSelectors => sub {
	    my $x = shift;
	    validate([$x], [
			 sub {
			     my $vs = shift;
			     return unless (ref $vs eq 'ARRAY'
					    && scalar @$vs == scalar @$var_array);
			     for my $obj (@$vs) {
				 return unless (blessed($obj)
						&& $obj->isa("Algorithm::CP::IZ::ValueSelector"));
			     }
			     1;
			 }], "search: ValueSelectos must be a arrayref of Algorithm::CP::IZ::ValueSelector instance for each variables");
	},
	MaxFailFunc => sub {
	    my $x = shift;
	    validate([$x], ["C"], "search: MaxFailFunc must be a coderef");
	},
	NoGoodSet => sub {
	    my $x = shift;
	    validate([$x], [
			 sub {
			     my $ngs = shift;
			     return blessed($ngs) && $ngs->isa("Algorithm::CP::IZ::NoGoodSet");
			 }], "search: NoGoodSet must be a instance of Algorithm::CP::IZ::NoGoodSet");
	},
	Notify => sub {
	    my $x = shift;
	    validate([$x], [
			 sub {
			     my $notify = shift;
			     return 1 if (ref $notify eq 'HASH');
			     return 1 if (blessed($notify));
			     return 0;
			 }], "search: Notify must be an hashref or object");
	},
    );

    my @keys = sort keys %$params;

    for my $k (@keys) {
	if (exists $checker{$k}) {
	    my $func = $checker{$k};
	    &$func($params->{$k});
	}
	else {
	    _report_error("search: Unknown Key $k in params");
	}
    }

    return 1;
}

sub search {
    my $self = shift;
    my $var_array = shift;
    my $params = shift;

    validate([$var_array, $params], ["vA0", sub {_validate_search_params($var_array, @_)}],
	     "Usage: search([variables], {key=>value,...}");

    my $array = [map { $$_ } @$var_array];
    my $max_fail = -1;
    my $find_free_var_id = 0;
    my $find_free_var_func = sub { die "search: Internal error"; };
    my $criteria_func;
    my $value_selectors;
    my $max_fail_func;
    my $ngs;
    my $notify;
    
    if ($params->{FindFreeVar}) {
	my $ffv = $params->{FindFreeVar};

	if (ref $ffv) {
	    $find_free_var_id = -1;
	    $find_free_var_func = sub {
		return &$ffv($var_array);
	    };
	}
	else {
	    $find_free_var_id = int($ffv);
	}
    }

    if ($params->{Criteria}) {
	$criteria_func = $params->{Criteria};
    }

    if ($params->{MaxFail}) {
	$max_fail = int($params->{MaxFail});
    }

    if ($params->{ValueSelectors}) {
	$value_selectors = $params->{ValueSelectors};
    }

    if ($params->{MaxFailFunc}) {
	$max_fail_func = $params->{MaxFailFunc};
    }

    if ($params->{NoGoodSet}) {
	$ngs = $params->{NoGoodSet};
    }

    if ($params->{Notify}) {
	$notify = $params->{Notify};
	unless (ref $notify eq 'Algorithm::CP::IZ::SearchNotify') {
	    $notify = Algorithm::CP::IZ::SearchNotify->new($notify);
	}

	$notify->set_var_array($var_array);
    }

    my $is_search35 = $value_selectors || $max_fail_func || $ngs || $notify;

    if ($is_search35) {
	unless ($value_selectors) {
	    if ($criteria_func) {
		$Algorithm::CP::IZ::CriteriaValueSelector::CriteriaFunction = $criteria_func;
		
		$value_selectors = [
		    map {
			$self->create_value_selector_simple("Algorithm::CP::IZ::CriteriaValueSelector")
		    } (0..scalar(@$var_array)-1)];

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

		$max_fail,
		defined($notify) ? $notify->{_ptr} : 0);
	}
    }
    else {
	if ($criteria_func) {
	    return Algorithm::CP::IZ::cs_searchCriteria($array,
							$find_free_var_id,
							$find_free_var_func,
							$criteria_func,
							$max_fail);
	}
	else {
	    return Algorithm::CP::IZ::cs_search($array,
						$find_free_var_id,
						$find_free_var_func,
						$max_fail);
	}
    }
	
    if ($criteria_func) {
	return Algorithm::CP::IZ::cs_searchCriteria($array,
						    $find_free_var_id,
						    $find_free_var_func,
						    $criteria_func,
						    $max_fail);
    }
    else {
 	return Algorithm::CP::IZ::cs_search($array,
					    $find_free_var_id,
					    $find_free_var_func,
					    $max_fail);
   }
}

sub _validate_find_all_params {
    my $params = shift;
    return 1 unless (defined($params));
    return 0 unless (ref $params eq 'HASH');

    my %checker = (
	FindFreeVar => sub {
	    my $x = shift;
	    if (ref $x) {
		validate([$x], ["C"], "find_all: FindFreeVar must be a number or coderef");
	    }
	    else {
		validate([$x], ["I"], "search: FindFreeVar must be a number or coderef");
	    }
	},
    );

    my @keys = sort keys %$params;

    for my $k (@keys) {
	if (exists $checker{$k}) {
	    my $func = $checker{$k};
	    &$func($params->{$k});
	}
	else {
	    _report_error("find_all: Unknown Key $k in params");
	}
    }

    return 1;
}

sub find_all {
    my $self = shift;
    my $var_array = shift;
    my $found_func = shift;
    my $params = shift;

    validate([$var_array, $found_func, $params],
	     ["vA0", "C", \&_validate_find_all_params],
	     "find_all: usage: find_all([vars], &callback_func, {params})");

    my $array = [map { $$_ } @$var_array];

    my $find_free_var_id = 0;
    my $find_free_var_func = sub { die "find_all: Internal error"; };

    if ($params->{FindFreeVar}) {
	my $ffv = $params->{FindFreeVar};

	if (ref $ffv) {
	    $find_free_var_id = -1;
	    $find_free_var_func = sub {
		return &$ffv($var_array);
	    };
	}
	else {
	    $find_free_var_id = int($ffv);
	}
    }

    my $call_back = sub {
	&$found_func($var_array);
    };

    return Algorithm::CP::IZ::cs_findAll($array,
					 $find_free_var_id,
					 $find_free_var_func,
					 $call_back);
}

sub _push_object {
    my $self = shift;
    my $obj = shift;

    my $cxt = $self->{_cxt};
    my $cur_cxt = $self->{_cxt0};

    if (scalar @$cxt > 0) {
	$cur_cxt = $cxt->[(scalar @$cxt) - 1];
    }

    push(@$cur_cxt, $obj);
}

sub _create_registered_var_array {
    my $self = shift;
    my $var_array = shift;;

    my $key = join(",", map { sprintf("%x", $$_) } @$var_array);
    my $r = $self->{_ref_var_arrays}->{$key};
    return $r if ($r);

    my $parray = Algorithm::CP::IZ::RefVarArray->new($var_array);
    $self->{_ref_var_arrays}->{$key} = $parray;

    return $parray;
}

sub _create_registered_int_array {
    my $self = shift;
    my $int_array = shift;;

    my $key = join(",", map { sprintf("%x", $_) } @$int_array);
    my $r = $self->{_ref_int_arrays}->{$key};
    return $r if ($r);

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

    $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);

    return $ret;
}

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

    my $usage_msg = 'usage: Mul(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_Mul",
			 "Algorithm::CP::IZ::cs_VMul");

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

    $self->_register_variable($ret);

    return $ret;
}

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

    my $usage_msg = 'usage: Sub(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_Sub",
			 "Algorithm::CP::IZ::cs_VSub");

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

    $self->_register_variable($ret);

    return $ret;

    $self->_register_variable($ret);

    return $ret;
}

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

    my $usage_msg = 'usage: Div(v1, v2)';
    if (@params != 2) {
	_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 = Algorithm::CP::IZ::cs_Div(map { $$_ } @v);

    # cannot divide number
    return undef if ($ptr == 0);

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

    $self->_register_variable($ret);

    return $ret;
}

sub ScalProd {
    my $self = shift;
    my $vars = shift;
    my $coeffs = shift;

    validate([$vars, $coeffs, 1], ["vA0", "iA0",
				   sub {
				       @$coeffs == @$vars
				   }],
	     "Usage: ScalProd([variables], [coeffs])");

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

    my $p1 = $self->_create_registered_var_array($vars);
    my $p2 = $self->_create_registered_int_array($coeffs);
    my $n = @$coeffs;

    my $ptr = Algorithm::CP::IZ::cs_ScalProd($$p1, $$p2, $n);
    my $ret = Algorithm::CP::IZ::Int->new($ptr);

    $self->_register_variable($ret);

    return $ret;
}

sub AllNeq {
    my $self = shift;
    my $var_array = shift;;

    validate([$var_array], ["vA0"], "Usage: AllNeq([variables])");

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

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

sub Sigma {

( run in 1.755 second using v1.01-cache-2.11-cpan-5b529ec07f3 )