Perl: the Markov chain saw PerlMonks

### Re (tilly) 2: 5x5 Puzzle

by tilly (Archbishop)
 on Jan 29, 2001 at 14:09 UTC Need Help??

in reply to Re (tilly) 1: 5x5 Puzzle

After some thought I realized that I could find several speedups. The first and biggest is what order the toggles are searched in. When you choose elements on one side, you can conclude diagonally. But I have to fill in the entire board before drawing interesting conclusions. Therefore by just reording what path you take you move the decision closer to the conclusion and speed things up.

The other thing that I changed is that I separated the decision about what paths to take from the toggling. As it stands for most of the board the decision is obvious from examining one board element what you have to do. But I was toggling twice whether or not I needed it. But by separating out that logic I make the logical structure simpler, and I believe it is slightly faster.

So here is a much speeded up version of the code:

```use strict;
use vars qw(\$min \$max @board @soln @toggles);
\$min = 1;
\$max = shift(@ARGV) || 5;
@board = map [map 0, \$min..\$max], \$min..\$max;

foreach my \$x (\$min..\$max) {
foreach my \$y (\$min..\$max) {
push @toggles, [
[\$x, \$y],
ret_valid_toggles(\$x, \$y),
ret_toggle_square(\$x, \$y)
];
}
}

# Sort them in an order where conclusions are discovered faster
@toggles = sort {
(\$a->[0][0] + \$a->[0][1]) <=> (\$b->[0][0] + \$b->[0][1]) or
\$a->[0][0] <=> \$b->[0][0]
} @toggles;

find_soln();

sub find_soln {
if (! @toggles) {
# Solved!
print join " ", "Solution:", map "\$_->[0][0]-\$_->[0][1]", @soln;
print "\n";
}
else {
my \$toggle = shift(@toggles);
foreach (\$toggle->[1]->()) {
if (\$_) {
\$toggle->[2]->();
push @soln, \$toggle;
find_soln();
pop @soln;
\$toggle->[2]->();
}
else {
find_soln();
}
}
unshift @toggles, \$toggle;
}
}

# Returns a function that toggles one square and its
# neighbours.
sub ret_toggle_square {
my (\$x, \$y) = @_;
my @to_swap= square_ref(\$x, \$y);
unless (\$x == \$min) {
push @to_swap, square_ref(\$x - 1, \$y);
}
unless (\$y == \$min) {
push @to_swap, square_ref(\$x, \$y - 1);
}
unless (\$x == \$max) {
push @to_swap, square_ref(\$x + 1, \$y);
}
unless (\$y == \$max) {
push @to_swap, square_ref(\$x, \$y + 1);
}
return sub { \$\$_ = not \$\$_ foreach @to_swap; };
}

# Returns a test functions that returns a list of valid
# toggle states to try
sub ret_valid_toggles {
my (\$x, \$y) = @_;
my @checks;
if (\$min < \$x) {
push @checks, square_ref(\$x-1, \$y);
}
if (\$max == \$x) {
if (\$min < \$y) {
push @checks, square_ref(\$x, \$y-1);
}
if (\$max == \$y) {
push @checks, square_ref(\$x, \$y);
}
}
if (not @checks) {
return sub {(0, 1)};
}
else {
my \$check = shift @checks;
if (not @checks) {
return sub {not \$\$check};
}
else {
return sub {
my \$val = \$\$check;
(grep {\$\$_ != \$val} @checks) ? () : not \$val;
};
}
}
}

# Given x, y returns a reference to that square on the board
sub square_ref {
my (\$x, \$y) = @_;
return \(\$board[\$x-1][\$y-1]);
}

UPDATE
Removed the ret_swap_square() function. Toggles go much faster if each swap is done directly rather than indirectly through a function call. (Removing 5 extra function calls per toggle matters...) Also dropped the unused Carp that snuck in through habit. (This is throw-away code...)

Replies are listed 'Best First'.
Re (tilly) 3 (rectangular): 5x5 Puzzle
by tilly (Archbishop) on Jan 29, 2001 at 23:13 UTC
Must...stop...tinkering...

Anyways the above was so darned close to working for rectangular boards that I just had to extend it to cover that. It defaults to 5x5. If you pass one argument it does nxn. 2 and it does nxm. Still just brute force.

```use strict;
use vars qw(\$min \$max_x \$max_y @board @soln @toggles);
\$min = 1;
\$max_x = shift(@ARGV) || 5;
\$max_y = shift(@ARGV) || \$max_x;
# The board starts empty and entries will autovivify. :-)

foreach my \$x (\$min..\$max_x) {
foreach my \$y (\$min..\$max_y) {
push @toggles, [
[\$x, \$y],
ret_valid_toggles(\$x, \$y),
ret_toggle_square(\$x, \$y)
];
}
}

# Sort them in an order where conclusions are discovered faster
@toggles = sort {
(\$a->[0][0] + \$a->[0][1]) <=> (\$b->[0][0] + \$b->[0][1]) or
\$a->[0][0] <=> \$b->[0][0]
} @toggles;

find_soln();

sub find_soln {
if (! @toggles) {
# Solved!
print join " ", "Solution:", map "\$_->[0][0]-\$_->[0][1]", @soln;
print "\n";
}
else {
my \$toggle = shift(@toggles);
foreach (\$toggle->[1]->()) {
if (\$_) {
\$toggle->[2]->();
push @soln, \$toggle;
find_soln();
pop @soln;
\$toggle->[2]->();
}
else {
find_soln();
}
}
unshift @toggles, \$toggle;
}
}

# Returns a function that toggles one square and its
# neighbours.
sub ret_toggle_square {
my (\$x, \$y) = @_;
my @to_swap= square_ref(\$x, \$y);
unless (\$x == \$min) {
push @to_swap, square_ref(\$x - 1, \$y);
}
unless (\$y == \$min) {
push @to_swap, square_ref(\$x, \$y - 1);
}
unless (\$x == \$max_x) {
push @to_swap, square_ref(\$x + 1, \$y);
}
unless (\$y == \$max_y) {
push @to_swap, square_ref(\$x, \$y + 1);
}
return sub { \$\$_ = not \$\$_ foreach @to_swap; };
}

# Returns a test functions that returns a list of valid
# toggle states to try
sub ret_valid_toggles {
my (\$x, \$y) = @_;
my @checks;
if (\$min < \$x) {
push @checks, square_ref(\$x-1, \$y);
}
if (\$max_x == \$x) {
if (\$min < \$y) {
push @checks, square_ref(\$x, \$y-1);
}
if (\$max_y == \$y) {
push @checks, square_ref(\$x, \$y);
}
}
if (not @checks) {
return sub {(0, 1)};
}
else {
my \$check = shift @checks;
if (not @checks) {
return sub {not \$\$check};
}
else {
return sub {
my \$val = \$\$check;
(grep {\$\$_ != \$val} @checks) ? () : not \$val;
};
}
}
}

# Given x, y returns a reference to that square on the board
sub square_ref {
my (\$x, \$y) = @_;
return \(\$board[\$x-1][\$y-1]);
}

Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: note [id://54968]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others having a coffee break in the Monastery: (2)
As of 2024-06-15 14:06 GMT
Sections?
Information?
Find Nodes?
Leftovers?
Voting Booth?

No recent polls found

Notices?
 • erzuuli ‥ 🛈The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.