Keith 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.
##+##########################################################################
#
# LightsOut.tcl - description
# by Keith Vetter -- Sept 10, 2004
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]
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 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 -row 100 -sticky ew
}
proc DrawBoard {{redraw 0}} {
global S G
.c delete msg
if {$redraw} { ;# Redraw everything
.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 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 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
}
return $who
}
proc ReDraw {h} {
}
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
DoDisplayGS (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 ]