Summary edit
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 commutative.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.HJG 2014-05-08 : I added buttons to cycle thru some canned puzzles, changed the board to be drawn in alternate colors based on boardsize, and disabled the solver for big gameboards to prevent it from crashing (with an exception for the stored puzzles).The solver can find some solutions for 5x5 in reasonable time, but 4x5 and maybe 7x3 is the maximum that can be handled safely.Also, proc InitBoard currently just puts random values into each cell. For some boardsizes (e.g. 4x4), this results in many unsolvable games.Maybe an alternative approach would work better, e.g. starting with the empty board, then doing some random moves...uniquename 2013aug01 added pix
Code edit
##+##########################################################################
#
# LightsOut.tcl - description
# by Keith Vetter -- Sept 10, 2004
# http://mathworld.wolfram.com/LightsOutPuzzle.html
#
# Collection of puzzles, and solver-limiting
# 2014-05 by HaJo Gurt
#
package require Tk
array set S {title "Lights Out" version "v1.14 2014-05-08" w 500 h 500}
array set G {rows 3 cols 3 maxSolve 21 puz 70 autoSolve 0}
global T1 T2
proc DoDisplay {} {
wm title . "$::S(title) $::S(version)"
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 <Escape> {exit}
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 Puzzle { dir } {
#: Select puzzle
global G S
incr G(puz) $dir
if { $G(puz) < 0 } { set G(puz) 70 } ;# TODO
set puzz {}
# 1 2 3 # 1 2 3 4 # 1 2 3 4 5
# 4 5 6 # 5 6 7 8 # 6 7 8 9 10
# 7 8 9 # 9 10 11 12 # 11 12 13 14 15
# 10 11 12 # 13 14 15 16 # 16 17 18 19 20
# 13 14 15 # 17 18 19 20 # 21 22 23 24 25 # ...
# 16 17 18 # 64 65 66 67 68 69 70
##
## 1 { set puzz { 5 4 0 3 4 8 9 10 14 15 } ;# ct-hard : 136s / 10 moves }
##
switch $G(puz) {
1 { set puzz { 3 3 0 1 } ;# 5 moves
}
2 { set puzz { 3 3 0 2 } ;# 4 moves
}
3 { set puzz { 3 3 0 5 } ;# c 5 moves
}
4 { set puzz { 3 3 0 4 5 } ;# -. 5 moves
}
5 { set puzz { 3 3 0 4 6 } ;# .. 6 moves
}
6 { set puzz { 3 3 0 7 8 } ;# _. 5 moves
}
7 { set puzz { 3 3 0 7 9 } ;# ._. 4 moves
}
8 { set puzz { 3 3 0 7 6 } ;# 5 moves
}
9 { set puzz { 3 3 0 8 6 } ;# 4 moves
}
10 { set puzz { 3 3 0 4 6 8 } ;# -_- 6 moves
}
11 { set puzz { 3 3 0 4 5 6 } ;# --- 7 moves
}
12 { set puzz { 3 3 0 1 3 5 } ;# v 5 moves
}
13 { set puzz { 3 3 0 1 3 8 } ;# V 8 moves
}
14 { set puzz { 3 3 0 1 3 9 } ;# 3 moves
}
15 { set puzz { 3 3 -1 2 4 6 8 } ;# 9 moves
}
16 { set puzz { 4 3 0 10 } ;# 7 moves
}
17 { set puzz { 4 3 0 11 } ;# 7 moves
}
18 { set puzz { 4 3 0 7 } ;# 7 moves
}
19 { set puzz { 4 3 0 8 } ;# 4 moves
}
20 { set puzz { 4 3 0 10 12 } ;# ":" 6 moves
}
21 { set puzz { 4 3 0 11 12 } ;# "-" 6 moves
}
22 { set puzz { 4 3 0 9 11 } ;# "-" 6 moves
}
23 { set puzz { 4 3 0 9 12 } ;# 6 moves
}
24 { set puzz { 4 3 0 6 12 } ;# 6 moves
}
25 { set puzz { 4 3 0 3 12 } ;# 10 moves
}
26 { set puzz { 4 3 0 2 9 } ;# ",-" 6 moves
}
27 { set puzz { 4 3 0 2 11 } ;# ":" 10 moves
}
28 { set puzz { 4 3 0 2 8 } ;# : 5 moves
}
29 { set puzz { 4 3 0 2 8 11 } ;# "i" 8 moves
}
30 { set puzz { 4 3 0 4 6 8 10 12 } ;# "x" 6 moves
}
31 { set puzz { 4 3 0 2 4 6 8 10 12 } ;# "//" 7 moves
}
32 { set puzz { 4 3 0 5 10 11 12 } ;# 7 moves
}
33 { set puzz { 4 3 -1 1 3 5 11 } ;# "A" 3 moves
}
34 { set puzz { 4 3 0 3 6 10 11 12 } ;# _' 5 moves
}
35 { set puzz { 4 3 0 1 2 3 8 11 } ;# 6 moves
}
36 { set puzz { 4 3 0 1 2 3 5 8 11 } ;# "T" 8 moves
}
37 { set puzz { 4 4 -1 0 } ;# "@" 4 moves / 0 s
}
38 { set puzz { 4 4 0 1 4 13 16 } ;# "4Q" 6 moves / 1 s
}
39 { set puzz { 4 4 -1 1 4 13 16 } ;# "4+" 4 moves / 0 s
}
40 { set puzz { 4 4 0 6 7 9 12 14 15 } ;# "<>" 2 moves / 1 s
}
41 { set puzz { 4 4 -1 6 7 9 12 14 15 } ;# "<>" 4 moves / 1 s
}
42 { set puzz { 4 4 -1 6 7 10 11 } ;# "O" 4 moves / 0 s
}
43 { set puzz { 4 4 0 6 7 10 11 } ;# "o" 6 moves / 1 s
}
44 { set puzz { 4 4 0 4 7 10 13 } ;# "/" 4 moves / 0 s
}
45 { set puzz { 5 3 0 8 } ;# "." 4 moves
}
46 { set puzz { 5 3 0 2 8 14 } ;# ":" 5 moves / 1s
}
47 { set puzz { 5 3 0 5 11 } ;# ":" 5 moves / ???
}
48 { set puzz { 5 3 0 5 8 11 } ;# ":" 5 moves / 1s
}
49 { set puzz { 5 3 -1 2 8 14 } ;# ":" 5 moves / 1s
}
50 { set puzz { 5 3 0 2 14 } ;# ":" 7 moves / 1s
}
51 { set puzz { 5 3 0 2 5 8 11 14 7 9 } ;# "+" 6 moves / 1s
}
52 { set puzz { 5 3 -1 4 7 10 6 9 12 } ;# "I" 4 moves / 1s
}
53 { set puzz { 5 3 -1 2 4 5 6 10 11 12 14 } ;# ":-:" 6 moves / 1s
}
54 { set puzz { 5 3 0 4 5 6 10 11 12 } ;# "=" 7 moves / 1s
}
55 { set puzz { 5 3 -1 0 } ;# "@" 6 moves / 1s
}
56 { set puzz { 5 4 0 20 } ;# "." 8 moves / 32 s
}
57 { set puzz { 5 4 0 19 } ;# "." 8 moves / 30 s
}
58 { set puzz { 5 4 0 1 2 3 4 14 15 } ;# "^-" 10 moves / 144-172 s
}
59 { set puzz { 5 4 0 5 8 14 15 } ;# ":-" 8 moves / 65 s
}
60 { set puzz { 5 4 0 6 7 10 11 14 15 } ;# "o" 12 moves / 266-348 s
}
61 { set puzz { 5 4 -1 6 7 10 11 14 15 } ;# "O" 10 moves / 173 s
}
62 { set puzz { 6 3 0 1 2 3 4 6 7 8 9 } ;# ".Q" 8 moves / 14s
}
63 { set puzz { 6 3 0 5 10 12 16 18 } ;# "5." 9 moves / 24s
}
-64 { set puzz { 6 3 0 5 8 11 } ;# "D" 5 moves / 1s
}
64 { set puzz { 6 3 -1 5 8 11 } ;# "D" 11 moves / 72s
}
65 { set puzz { 6 3 -1 5 8 10 13 16 12 15 18} ;# "(-" 11 moves / 44s
}
66 { set puzz { 6 3 0 1 3 5 7 8 9 11 14 17} ;# ">+-" 10 moves / 43s
}
67 { set puzz { 6 3 -1 2 7 9 14 16 17 18 } ;# "X" 5 moves / 1s
}
68 { set puzz { 6 3 0 1 3 7 9 13 15 17 } ;# "7." 6 moves / 4s
}
69 { set puzz { 6 3 -1 2 4 6 } ;# "<" 12 moves / 66s-88s
}
70 { set puzz { 6 3 -1 0 } ;# "@" 10 moves / 45s
}
71 { set puzz { 5 5 0 1 2 4 5 6 10 16 20 21 22 24 25 } ;# "4C" 4 moves / 1s
}
default {
set puzz { 5 5 0 1 } ;# 5x5 too big for solver
set G(puz) 0
}
}
puts "Puzzle $::G(puz):"
FillPuzzle $puzz
if { $G(autoSolve) > 0 } {update; ::Solve::Hint 1}
}
proc FillPuzzle { p } {
#: Fill puzzle-data into array PUZZ, for use in InitBoard
global G PUZZ
set r [lindex $p 0]
set c [lindex $p 1]
set inv [lindex $p 2]
set G(rows) $r
set G(cols) $c
puts "$G(puz): $G(rows),$G(cols) $inv " ;##
if {$inv == 0} {
set X 1; set O 0
} else {
set X 0; set O 1
}
set i 0
for {set row 0} {$row < $G(rows)} {incr row} {
for {set col 0} {$col < $G(cols)} {incr col} {
incr i
set PUZZ(board,$row,$col) $O
if {[lsearch -start 2 $p $i] >= 2} { set PUZZ(board,$row,$col) $X }
## puts "$i - $row,$col: $PUZZ(board,$row,$col) " ;##
}
}
NewBoard puzzle
}
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 .puzzle+ -text "Next Puzzle" -bd 4 -command { Puzzle 1 }
button .puzzle- -text "Prev Puzzle" -bd 4 -command { Puzzle -1 }
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 -bg white
button .help -text Help -command Help
grid .new -in .ctrl -sticky ew -row 0
grid .restart -in .ctrl -sticky ew
grid rowconfigure .ctrl 2 -minsize 20
grid .puzzle+ -in .ctrl -sticky ew -row 3
grid .puzzle- -in .ctrl -sticky ew
grid rowconfigure .ctrl 5 -minsize 20
grid .solution -in .ctrl -sticky ew -row 6
grid .hint -in .ctrl -sticky ew
grid rowconfigure .ctrl 10 -minsize 50
grid .rows -in .ctrl -sticky ew -row 12
grid .cols -in .ctrl -sticky ew
grid rowconfigure .ctrl 15 -minsize 80
grid .moves -in .ctrl -sticky ew -row 15
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
set lite yellow
if { [expr {( $G(cols) + $G(rows) ) & 1}] } { set lite cyan }
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 $lite}
.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 PUZZ
set G(state) play
set G(msg) ""
set G(moves) 0
set G(tmoves) "Moves: 0"
set G(path) {}
array unset G board,*
puts "InitBoard $how" ;##
if {$how eq "puzzle"} {
array set G [array get PUZZ]
array set LAST [array get G board,*] ;# Remember for restart
return
}
if {$how eq "last"} {
array set G [array get LAST]
return
}
puts "InitBoard: $G(rows)x$G(cols) $how" ;##
set G(puz) 0
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)}] ;# TODO
## puts "$row,$col: $G(board,$row,$col) " ;##
}
}
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"
append msg "Collection of puzzles, alternating colors\n"
append msg "and solver-limiting by HaJo Gurt 2014-05-05\n\n"
tk_messageBox -message $msg -title "$::S(title) Help"
}
puts "$::S(title) $::S(version)"
InitBoard rand
DoDisplay
namespace eval ::Solve {
variable b
}
proc ::Solve::Hint {{all 0}} {
.c delete hint
if {[::IsWinner]} return
if { $::G(puz)==0 } { ;# not one of the stored puzzles -> check size
set bs [expr {$::G(cols) * $::G(rows) }]
if { $bs > $::G(maxSolve) } {
set msg "Gameboard is too big for automatic solving."
tk_messageBox -message $msg -title "$::S(title) - Solver disabled"
return
}
}
set path [::Solve::Solver]
set ::T2 [clock seconds]
set t [expr $::T2-$::T1]
puts "done: $::T1 $::T2 => $t s [llength $path] moves\a" ;##
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]
set ::T1 [clock seconds]
set td [clock format $::T1 -format "%Y-%m-%d %H:%M:%S" ]
puts "Solve: $max $::T1 = $td" ;##
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]
}
#.Comments edit
GS (040911) A few years ago, there was an interesting discussion on sci.math about this puzzle [1] 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. [2]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 (it may need 3-6 minutes), but 7x3 needs about 10 minutes.
6x4, 5x5 and up are too big and lead to crashes.Maybe disabling the Solve- and Hint-buttons on big boards would prevent such crashes (and frustration for players).
