Version 15 of Lights Out
Updated 2010-06-10 10:08:06 by lars_hKeith 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.
##+##########################################################################
#
# 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 Analyses 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.
Screenshots
gold added pix