Beefy Boxes and Bandwidth Generously Provided by pair Networks
Problems? Is your data what you think it is?
 
PerlMonks  

Re: Lights out puzzle

by choroba (Canon)
on Nov 28, 2011 at 18:09 UTC ( #940423=note: print w/ replies, xml ) Need Help??


in reply to Lights out puzzle

Here's a quick Monday morning puzzle.
Quick?? I spent several hours on it, not being able to come with anything better then this:
#!/usr/bin/perl package Board; use warnings; use strict; use Scalar::Util 'refaddr'; use constant _CROSS => ([0, 0], [-1, 0], [1, 0], [0, -1], [0, 1]); my %click; sub new { my ($class, $value) = @_; my $board = []; @$board = map [($value) x 14], 1 .. 13; push @$board, [($value) x 7]; $click{refaddr($board)} = [map ([(0) x 14], 1 .. 13), [(0) x 7]]; bless $board, $class; return $board; } # new sub finished { my $board = shift; return not grep {grep $_, @$_} @$board; } # finished sub show { my $board = shift; for my $row (@$board) { return unless defined $row; print map $_ ? '*' : defined $_ ? '.' : '', @$row; print "\n"; } } # show sub _cross { my ($board, $x, $y) = @_; my @cross = grep { $_->[0] >= 0 and $_->[1] >= 0 and ref $board->[$_->[1]] and defined $board->[$_->[1]][$_->[0]] } map [$x + $_->[0], $y + $_->[1]], _CROSS; return @cross; } # _cross sub toggle { my ($board, $x, $y) = @_; my $old = $board->[$y][$x]; return unless defined $old; $board->[$y][$x] = $old eq 1 ? 0 : 1; } # toggle sub at { my ($board, $x, $y) = @_; return if $x < 0 or $y < 0 or not ref $board->[$y] or not defined $board->[$y][$x]; return $board->[$y][$x]; } # at sub around { my ($board, $x, $y) = @_; return map $board->at(@$_), $board->_cross($x, $y); } # around sub click { my ($board, $x, $y) = @_; return unless defined $board->[$y][$x]; $click{refaddr($board)}[$y][$x] = ! $click{refaddr($board)}[$y][$x +]; $board->toggle($_->[0], $_->[1]) for $board->_cross($x, $y); } # click sub row { my ($board, $y) = @_; return @{ $board->[$y] }; } # row sub clean { my $board = shift; for my $y (1 .. 13) { for my $x (0 .. 13) { $board->click($x, $y) if $board->at($x, $y-1); } } } # clean sub lastrow { my $board = shift; return map $board->at($_, 13 - ($_ > 6)), (0 .. 13); } # lastrow sub history { my $board = shift; return unless ref $click{refaddr($board)}; my @h = @{ $click{refaddr($board)} }; print map ($_ ? 1 : '0', @$_),"\n" for @h; } # history ########################################################## package main; use warnings; use strict; sub stringify { return join q[], map $_ ? 1 : 0, @_; } # stringify if (@ARGV) { my $b = Board->new(1); open my $IN, '<', $ARGV[0] or die $!; while (<$IN>) { chomp; for my $i (0 .. length()-1 ) { $b->click($i, $.-1) if substr $_, $i, 1; } $b->show; } } else { my %cache; for my $i (0 .. 13) { my $b = Board->new(0); $b->click($i, 0); $b->clean; my $k = stringify($b->lastrow); $cache{$k} = $i; } delete $cache{'0' x 14}; my $board = Board->new(1); while (1) { $board->clean; my $last = stringify($board->lastrow); if (exists $cache{$last}) { $board->click($cache{$last}, 0); } elsif (not $board->finished) { $board->click(int rand 13, int rand 2) for 1 .. 1 + int ra +nd 5; } else { last; } } $board->history; }
It's a bit randomized, but usually runs under 2 seconds on my machine. Run it with a filename as an argument to check the solution saved in the file.
Update: Removed forgotten debugging line.
Update2: Readmore changed to spoiler.


Comment on Re: Lights out puzzle
Download Code
Re^2: Lights out puzzle
by choroba (Canon) on Nov 30, 2011 at 10:06 UTC
    Here are some comments on how it works:
    The code clears all the lines except for the last one (clean) the simple way: if there is a light, click underneath. The last line (or, better to say, broken line, i.e. the last line plus the remaining half of the previous one) is then solved half-randomly. At the beginning, I cache how clicking on the top line influences the last line, but only for one click on the line (i.e. I only know what the last line will be after having one light lit). Therefore, I have to click randomly until I get a cached position that I can solve. This works well for size 14, but the time doubles for each +2 in size, so size 20 is already too slow. Caching more positions could be added easily (like clicking two times), but I am not sure how much time it would take to cache all possible combinations on the first line.
    Because the order of clicks is not important, I keep a separate map of the board with 0 for the even clicks and 1 for the odd ones. This separate board is the output of the program.
Re^2: Lights out puzzle
by ambrus (Abbot) on Dec 01, 2011 at 10:41 UTC

    I changed the definition of the show and toggle methods like this:

    sub show { my $board = shift; print "\e[H"; for my $row (@$board) { return unless defined $row; print map $_ ? '*' : defined $_ ? '.' : '', @$row; print "\e[K\n"; } print "\e[J"; use Time::HiRes "sleep"; sleep(6e-3); } # show sub toggle { my ($board, $x, $y) = @_; my $old = $board->[$y][$x]; return unless defined $old; $board->[$y][$x] = $old eq 1 ? 0 : 1; } # toggle
    and now I can see the lights being chased down to the bottom of the board. Looks nice.
      Yes, in fact, I did something similar for debugging :-)

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://940423]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others imbibing at the Monastery: (13)
As of 2015-07-06 23:15 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (85 votes), past polls