[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 {console show} bind .c {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 [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 DoDisplay ---- [GS] (040911) A few years ago, there was an interesting discussion on sci.math about this puzzle [http://www.math.niu.edu/~rusin/papers/uses-math/games/other/lights] 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. [http://dalila.sip.ucm.es/miembros/cpareja/lo/paper.ps] ---- [Category Games] | [Category Application] | [Tcl/Tk Games]