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

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



[gold] added pix 


======
 ##+##########################################################################
 #
 # 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://web.archive.org/web/20040814193730/http%3A//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 Analysis of Lights Out'', Mathematics Magazine 74:4 (2001), 295-304. [http://dalila.sip.ucm.es/miembros/cpareja/lo/paper.ps]

[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 7x7, or 7x10, Tcl even crashes:
!!!!!!
Not enough memory to allocate list

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

----

[uniquename] 2013aug01

The image above is at 'external site' flickr.com. 
It is probably just a matter of time before that link goes dead. 
As insurance, here is a 'locally stored' image, stored on this wiki site.

[vetter_LightsOut_screenshot_649x526.jpg]
    


<<categories>> Games | Application | Tcl/Tk Games | Toys