Beefy Boxes and Bandwidth Generously Provided by pair Networks
No such thing as a small change
 
PerlMonks  

Re: Lights out puzzle

by choroba (Abbot)
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 (Abbot) 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 chilling in the Monastery: (12)
As of 2014-10-31 13:06 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    For retirement, I am banking on:










    Results (217 votes), past polls