Version 23 of Lights Out
Updated 2014-05-06 10:09:14 by HJGKeith Vetter 2004-09-10 : This is a one-person puzzle in which you try to turn off all the lights. The board consists of a lattice of lights which can be turned on and off. Clicking on any light toggles the on/off state of that light and its four vertically and horizontally adjacent neighbors.
Determining if a given random arrangement of on/off lights can be all turned off is known as the All-Ones Problem.
One interesting quirk is that it doesn't matter the order of toggling lights needed to reach the solution--the solution is communative.
KPV 2004-09-11 : Added a "Hint" button which first does a search find the solution then displays one of the lights which needs to be toggled. The solver does a BFS and can be time consuming for large size boards.
gold added pix
##+##########################################################################
#
# LightsOut.tcl - description
# by Keith Vetter -- Sept 10, 2004
# http://mathworld.wolfram.com/LightsOutPuzzle.html
#
package require Tk
array set S {title "Lights Out" w 500 h 500}
array set G {rows 3 cols 3}
proc DoDisplay {} {
wm title . $::S(title)
frame .ctrl -relief ridge -bd 2 -padx 5 -pady 5
canvas .c -relief raised -height $::S(h) -width $::S(w) -bd 2 \
-highlightthickness 0 -relief raised
pack .ctrl -side right -fill both -ipady 5
pack .c -side top -fill both -expand 1
bind all <Key-F2> {console show}
bind .c <Configure> {ReCenter %W %h %w}
DoCtrlFrame
}
proc ReCenter {W h w} { ;# Called by configure event
set h2 [expr {$h / 2}]
set w2 [expr {$w / 2}]
$W config -scrollregion [list -$w2 -$h2 $w2 $h2]
DrawBoard 1
}
proc DoCtrlFrame {} {
button .restart -text "Restart Game" -command [list NewBoard last] -bd 4
.restart configure -font "[font actual [.restart cget -font]] -weight bold"
option add *font [.restart cget -font]
button .new -text "New Game" -bd 4 -command [list NewBoard rand]
button .hint -text Hint -bd 4 -command ::Solve::Hint
button .solution -text Solution -bd 4 -command {::Solve::Hint 1}
scale .rows -from 1 -to 10 -label Rows -orient h -relief ridge \
-variable G(rows) -command [list NewBoard rand]
scale .cols -from 1 -to 10 -label Columns -orient h -relief ridge \
-variable G(cols) -command [list NewBoard rand]
label .moves -textvariable G(tmoves) -relief sunken
button .help -text Help -command Help
grid .restart -in .ctrl -row 0 -sticky ew
grid .new -in .ctrl -sticky ew
grid rowconfigure .ctrl 5 -minsize 20
grid .hint -in .ctrl -sticky ew -row 6
grid .solution -in .ctrl -sticky ew
grid rowconfigure .ctrl 10 -minsize 50
grid .rows -in .ctrl -sticky ew -row 11
grid .cols -in .ctrl -sticky ew
grid rowconfigure .ctrl 20 -minsize 80
grid .moves -in .ctrl -sticky ew -rows 21
grid rowconfigure .ctrl 50 -weight 1
grid .help -in .ctrl -sticky ew -row 100
}
proc DrawBoard {{redraw 0}} {
global S G NEIGHBORS
.c delete msg hint
if {$redraw} { ;# Redraw everything
unset -nocomplain NEIGHBORS ;# Memoize array
.c delete all
set S(w) [winfo width .c]
set S(h) [winfo height .c]
set S(dx) [expr {double($S(w) - 10) / $G(cols)}]
set S(dy) [expr {double($S(h) - 10) / $G(rows)}]
if {$S(dx) < $S(dy)} {set S(dy) $S(dx)} else {set S(dx) $S(dy)}
set S(x0) [expr {- $S(dx) * $G(cols) / 2}]
set S(y0) [expr {- $S(dy) * $G(rows) / 2}]
for {set row 0} {$row < $G(rows)} {incr row} {
for {set col 0} {$col < $G(cols)} {incr col} {
set xy [GetBox $row $col]
.c create rect $xy -tag [list c c$row,$col]
.c bind c$row,$col <Button-1> [list DoClick $row $col]
}
}
set xy0 [GetBox 0 0]
set xy1 [GetBox $G(rows) $G(cols)]
set xy [concat [lrange $xy0 0 1] [lrange $xy1 0 1]]
.c create rect $xy -width 3
}
# Draw the light lattice
for {set row 0} {$row < $G(rows)} {incr row} {
for {set col 0} {$col < $G(cols)} {incr col} {
set fill [.c cget -bg]
if {$G(board,$row,$col) > 0} {set fill yellow}
.c itemconfig c$row,$col -fill $fill
}
}
if {$G(msg) ne ""} {
.c create text 0 0 -tag msg -text $G(msg) -font {Times 36 bold}
}
}
proc ShowHint {row col} {
set xy [GetOval $row $col]
.c create oval $xy -tag [list hint h$row,$col] -fill red
.c bind h$row,$col <Button-1> [list DoClick $row $col]
}
proc GetBox {row col} {
global S
set x0 [expr {$S(x0) + $col * $S(dx)}]
set y0 [expr {$S(y0) + $row * $S(dy)}]
set x1 [expr {$x0 + $S(dx)}]
set y1 [expr {$y0 + $S(dy)}]
return [list $x0 $y0 $x1 $y1]
}
proc GetOval {row col} {
global S
set x0 [expr {$S(x0) + ($col + .33) * $S(dx)}]
set y0 [expr {$S(y0) + ($row + .33) * $S(dy)}]
set x1 [expr {$S(x0) + ($col + .66) * $S(dx)}]
set y1 [expr {$S(y0) + ($row + .66) * $S(dy)}]
return [list $x0 $y0 $x1 $y1]
}
proc Neighbors {row col} {
global NEIGHBORS ;# Memoize
if {[info exists NEIGHBORS($row,$col)]} { return $NEIGHBORS($row,$col) }
set who {}
foreach {dr dc} {-1 0 0 0 1 0 0 -1 0 1} {
set r [expr {$row + $dr}]
set c [expr {$col + $dc}]
if {$r < 0 || $c < 0 || $r >= $::G(rows) || $c >= $::G(cols)} continue
lappend who $r $c
}
set NEIGHBORS($row,$col) $who
return $who
}
proc NewBoard {{how rand} args} {
InitBoard $how
DrawBoard 1
}
proc InitBoard {how} {
global G LAST
set G(state) play
set G(msg) ""
set G(moves) 0
set G(tmoves) "Moves: 0"
set G(path) {}
array unset G board,*
if {$how eq "last"} {
array set G [array get LAST]
return
}
while {1} { ;# Fill in the board
for {set row 0} {$row < $G(rows)} {incr row} {
for {set col 0} {$col < $G(cols)} {incr col} {
set G(board,$row,$col) [expr {int(rand() * 2)}]
}
}
if {! [IsWinner]} break ;# Must have 1 light on
}
array set LAST [array get G board,*] ;# Remember for restart
}
proc DoClick {row col} {
if {$::G(state) ne "play"} return
foreach {r c} [Neighbors $row $col] {
set ::G(board,$r,$c) [expr {1 - $::G(board,$r,$c)}]
}
set ::G(tmoves) "Moves: [incr ::G(moves)]"
lappend ::G(path) $row $col
if {[IsWinner]} {
set ::G(msg) "You Won!"
set ::G(state) won
}
DrawBoard
}
proc IsWinner {} {
foreach arr [array names ::G board,*] {
if {$::G($arr) == 1} {return 0}
}
return 1
}
proc Help {} {
set msg "$::S(title)\nby Keith Vetter, September 2004\n\n"
append msg "This is one-person puzzle in which you try to turn off\n"
append msg "all the lights. The board consists of a lattice of lights\n"
append msg "which can be turned on and off. Clicking on any light\n"
append msg "toggles the on/off state of this and its four vertically\n"
append msg "and horizontally adjacent neighbors.\n\n"
append msg "Determining if a given random arrangement of on/off\n"
append msg "lights can be all turned off is known as the\n"
append msg "\"All-Ones Problem\"\n\n"
tk_messageBox -message $msg -title "$::S(title) Help"
}
InitBoard rand
DoDisplay
namespace eval ::Solve {
variable b
}
proc ::Solve::Hint {{all 0}} {
.c delete hint
if {[::IsWinner]} return
set path [::Solve::Solver]
if {$path == {}} { ;# No solution
set msg "Can't be solved"
.c create text 0 0 -tag msg -text $msg -font {Times 36 bold}
return
}
if {! $all} { ;# Just one hint
set path [lindex $path [expr {int(rand() * [llength $path])}]]
}
foreach step $path {
scan $step "%d,%d" row col
ShowHint $row $col
}
}
proc ::Solve::Solve {} {
global path
set path [::Solve::Solver]
puts "[llength $path] => $path"
}
proc ::Solve::Solver {} {
variable b
global G
array unset b
set moves {}
for {set row 0} {$row < $G(rows)} {incr row} {
for {set col 0} {$col < $G(cols)} {incr col} {
lappend moves "$row,$col"
set b($row,$col) $G(board,$row,$col)
}
}
set max [llength $moves]
array set save [array get b]
for {set n 1} {$n <= $max} {incr n} {
set all [::Solve::Combinations $moves $n]
foreach path $all {
array set b [array get save]
foreach step $path {
scan $step "%d,%d" row col
::Solve::DoMove $row $col
}
if {[::Solve::IsWinner]} {
return $path
}
}
}
return {}
}
proc ::Solve::IsWinner {} {
variable b
foreach arr [array names b] {
if {$b($arr) != 0} {return 0}
}
return 1
}
proc ::Solve::DoMove {row col} {
variable b
set nb [Neighbors $row $col]
foreach {row col} $nb {
set b($row,$col) [expr {1 - $b($row,$col)}]
}
}
proc ::Solve::Combinations {myList size {prefix {}}} {
;# End recursion when size is 0 or equals our list size
if {$size == 0} {return [list $prefix]}
if {$size == [llength $myList]} {return [list [concat $prefix $myList]]}
set first [lindex $myList 0]
set rest [lrange $myList 1 end]
;# Combine solutions w/ first element and solutions w/o first element
set ans1 [::Solve::Combinations $rest [expr {$size-1}] \
[concat $prefix $first]]
set ans2 [::Solve::Combinations $rest $size $prefix]
return [concat $ans1 $ans2]
}GS (040911) A few years ago, there was an interesting discussion on sci.math about this puzzle [L1 ] and also a published article: Óscar Martín-Sánchez and Cristóbal Pareja-Flores, Two Reflected Analysis of Lights Out, Mathematics Magazine 74:4 (2001), 295-304. [L2 ]
Lars H: A rather elementary observation is that the problem can be stated as a linear equation system (one variable for each light) over GF(2), which means it can definitely be solved in polynomial time. The trivial complexity for an n-by-n grid is however O(n^6), so one might be interested in a faster solution.
HJG 2014-05-05 For big boards, like 5x5, 6x6, 7x7, or 7x10, Tcl even crashes:
5x5: alloc: could not allocate 800 new objects 6x6: alloc: could not allocate 800 new objects 7x7: Not enough memory to allocate list 7x10: unable to alloc 256 bytes This application has requested the Runtime to terminate it in an unusual way.
It looks like it consumed all the memory, and finally crashed (after about half an hour)...
Boards of size 5x4 can still be solved quickly, but 7x3, 6x4 and 5x5 are too big.
Maybe disabling the Solve- and Hint-buttons on big boards would prevent such crashes (and frustration for players).
uniquename 2013aug01
The image above is at 'external site' flickr.com. It is probably just a matter of time before that link goes dead. As insurance, here is a 'locally stored' image, stored on this wiki site.
