Re: Lights out puzzle

[choroba]

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.

[choroba]

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.

[ambrus]

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.

[choroba]

Yes, in fact, I did something similar for debugging :-)