[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. 

[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 
[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]
----





======
----
***Screenshots***




        [http://farm5.static.flickr.com/4063/4685112957_bba73da26a_m.jpg]
        


[http://farm5.static.flickr.com/4063/4685112957_bba73da26a.jpg]

[http://farm5.static.flickr.com/4063/4685112957_bba73da26a_s.jpg]


<alt=TCL_WIKI_lightsoutboasrdgametestpixversion2.png>
[gold] added pix 

    
----
**References**






----

[Category Games] | [Category Application] | [Tcl/Tk Games]