view release on metacpan or  search on metacpan

lib/Games/Sudoku/General.pm  view on Meta::CPAN

L<ACKNOWLEDGMENTS|/ACKNOWLEDGMENTS> section addresses why the former
URL is not an actual POD link.

The second value is the cell number, as defined by the topology
setting. For the 'sudoku' and 'latin' settings, the cells are
numbered from zero, row-by-row. If you did your own topology, the
first cell you defined is 0, the second is 1, and so on.

The third value is the value assigned to the cell. If returned in
list context, it is the number assigned to the cell's symbol. If
in scalar context, it is the symbol itself.

=for comment help syntax-highlighting editor "

=cut

sub steps {
    my ( $self ) = @_;
    return wantarray ? (@{$self->{backtrack_stack}}) :
	defined wantarray ?
	    $self->_format_constraint (@{$self->{backtrack_stack}}) :
	undef;
}

=head2 unload

 $string = $su->unload();

This method returns either the current puzzle or the current solution,
depending on whether the solution() method has been called since the
puzzle was loaded.

=cut

sub unload {
    my ( $self ) = @_;
    return $self->_unload ()
}

########################################################################

#	Private methods and subroutines.

#	$status_value = $su->_constrain ();

#	This method applies all possible constraints to the current
#	problem, placing them on the backtrack stack. The backtrack
#	algorithm needs to remove these when backtracking. The return
#	is false if we ran out of constraints, or true if we found
#	a constraint that could not be satisfied.

my %constraint_method = (
    '?' => '_constraint_backtrack',
);

sub _constrain {
    my ( $self ) = @_;
    my $stack = $self->{backtrack_stack} ||= [];	# May hit this
							# when initializing.
    my $used = $self->{constraints_used} ||= {};
    my $iterations;
    $iterations = $self->{iteration_limit}
	if $self->{iteration_limit} > 0;

    $self->{no_more_solutions} and
	return $self->_unload (undef, SUDOKU_NO_SOLUTION);

    @{$self->{backtrack_stack}} and do {
	$self->_constraint_remove and
	    return $self->_unload (undef, SUDOKU_NO_SOLUTION);
    };

    $self->{cells_unassigned} or do {
	$self->{no_more_solutions} = 1;
	return $self->_unload ('', SUDOKU_SUCCESS);
    };

    my $number_of_cells = @{$self->{cell}};

constraint_loop:
    {	# Begin outer constraint loop.

	foreach my $constraint (qw{F N B T ?}) {
	    confess <<eod if @{$self->{cell}} != $number_of_cells;
Programming error - Before trying $constraint constraint.
        We started with $number_of_cells cells, but now have @{[
	scalar @{$self->{cell}}]}.
eod
	    my $method = $constraint_method{$constraint} ||
		    "_constraint_$constraint";
	    my $rslt = $self->$method () or next;
	    @$rslt or next;
	    foreach my $constr (@$rslt) {
		if (ref $constr) {
		    push @$stack, $constr;
		    $used->{$constr->[0]}++
		} else {
		    my $rslt = $self->_constraint_remove or
			redo constraint_loop;
		    return $self->_unload ('', $rslt);
	        }
	    }
	    $self->{cells_unassigned} or
		return $self->_unload ('', SUDOKU_SUCCESS);
	    redo constraint_loop;
	}

    }	# end outer constraint loop.

    $self->set (status_value => SUDOKU_TOO_HARD);
    return;
}

#	Constraint executors:
#	These all return a reference to the constraints to be stacked,
#	provided progress was made. Otherwise they return 0. At the
#	point a contradiction is found, they push 'backtrack' on the
#	end of the list to be returned, and return immediately.

#	F constraint - only one value possible. Unlike the other
#	constraints, we keep iterating this one until we make no
#	progress.

lib/Games/Sudoku/General.pm  view on Meta::CPAN

			my @ccl;
			for (my $inx = 0; $inx < @$open; $inx++) {
			    next if $tuple_member[$inx] ||
				$open->[$inx]{possible}{$val};
			    $open->[$inx]{possible}{$val} = 1;
			    --$contributed->[$val];
			    push @ccl, $open->[$inx]{index};
			}
			push @$constraint, [\@ccl, $val] if @ccl;
		    }

#	If the number of discrete values is greater than the current
#	order, we may have a hidden tuple. The test for an "effective"
#	hidden tuple involves massaging @tcontr against @$contributed in
#	some way to find a tuple of values within the tuple of cells
#	which do not occur outside it.

		} elsif ($discrete > $order) {
		    my $within = 0;	# Number of values occuring only
					# within tuple.
		    for (my $val = 1; $val < @tcontr; $val++) {
			$within++ if $tcontr[$val] &&
			    $contributed->[$val] == $tcontr[$val];
		    }
		    next unless $within >= $order;
		    $constraint = ['T', 'hidden', $order];
		    map {$tuple_member[$_] = 1} @$tuple;
		    for (my $val = 1; $val < @tcontr; $val++) {
			next unless $tcontr[$val] &&
			    $contributed->[$val] > $tcontr[$val];
			my @ccl;
			for (my $inx = 0; $inx < @$open; $inx++) {
			    next unless $tuple_member[$inx]
				&& !$open->[$inx]{possible}{$val}
				;
			    $open->[$inx]{possible}{$val} = 1;
			    --$contributed->[$val];
			    --$tcontr[$val];
			    push @ccl, $open->[$inx]{index};
			}

			push @$constraint, [\@ccl, $val] if @ccl;
		    }
		}

		next unless $constraint;
		$self->{debug} and
		    print '#    ', $self->_format_constraint ($constraint);
		return [$constraint];
	    }	# Next tuple
	}	# Next set containing vacant cells
    }	# Next order

    return [];
}

# ? constraint - initiate backtracking.

sub _constraint_backtrack {
    my ( $self ) = @_;
##  --$iterations >= 0 or return $self->_unload ('', SUDOKU_TOO_HARD)
##	if defined $iterations;
    my @try;
    my $syms = @{$self->{symbol_list}};
    foreach my $cell (@{$self->{cell}}) {
	next if $cell->{content};
	next unless @{$cell->{membership}};
	my $possible = 0;
	for (my $val = 1; $val < $syms; $val++) {
	    $possible++ unless $cell->{possible}{$val};
	}
	$possible or return ['backtrack'];
	push @try, [$cell, $possible];
    }
    @try = map {$_->[0]} sort {
	$a->[1] <=> $b->[1] || $a->[0]{index} <=> $b->[0]{index}} @try;
    my $cell = $try[0];
    for (my $val = 1; $val < $syms; $val++) {
	next if $cell->{possible}{$val};
	$self->_try ($cell, $val) and confess <<eod;
Programming error - Value $val illegal in cell $cell->{index} for ? constraint, but
        \$self->{possible}{$val} = $self->{possible}{$val}
eod
	my $constraint = ['?' => [$cell->{index}, $val]];
	$self->{debug}
	    and print '#    ', $self->_format_constraint ($constraint);
	return [$constraint];
    }
    return [];
}

#	$status_value = $su->_constraint_remove ();

#	This method removes the topmost constraints from the backtrack
#	stack. It continues until the next item is a backtrack item or
#	the stack is empty. It returns true (SUDOKU_NO_SOLUTION,
#	actually) if the stack is emptied, or false (SUDOKU_SUCCESS,
#	actually) if it stops because it found a backtrack item.

#	The following arguments may be passed, for use in preparing
#	a generated problem:
#	    - minimum number of cells to leave occupied (no lower limit
#		if this is undefined);
#	    - maximum number of cells to leave occupied (no upper limit
#		if this is undefined);
#	    - a reference to a hash of constraints that it is legal to
#		remove. The hash value is the number of times it is
#		legal to remove that constraint, or undef if it can
#		be removed any number of times.

sub _constraint_remove {
    my ( $self, $min, $max, $removal_ok ) = @_;
    $min and $min = @{$self->{cell}} - $min;
    $max and $max = @{$self->{cell}} - $max;
    $self->{no_more_solutions} and return SUDOKU_NO_SOLUTION;
    my $stack = $self->{backtrack_stack} or return SUDOKU_NO_SOLUTION;
    my $used = $self->{constraints_used} ||= {};
    my $inx = @$stack;
    my $syms = @{$self->{symbol_list}};
    ($self->{debug} && $inx) and print <<eod;
# Debug - Backtracking
eod