**Summary**
[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 

[vetter_LightsOut_screenshot_649x526.jpg]

**Code**
----
======tcl
 ##+##########################################################################
 #
 # 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**

[GS] (040911) A few years ago, there was an interesting discussion on sci.math about this puzzle [http://web.archive.org/web/20050426225751/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 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 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. <<br>>
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).


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