[Keith Vetter] 2006-02-09 : Here's a fun litle game where you have to rotate nodes 
to connect up wires to light up every node. I wrote a somewhat similar game
earlier called [Lights Out].

----

 ##+##########################################################################
 #
 # lightsOn.tcl -- based on http://pyva.net/eng/pc/lights.html
 # by Keith Vetter
 #
 package require Tk
 
 set G(n) 7
 array set S {title "Lights On" w 600 h 600 vdist 50 hdist 28}
 array set DRC {0 {0 2} 1 {-1 1} 2 {-1 -1} 3 {0 -2} 4 {1 -1} 5 {1 1}}
 array set COLORS {ray1 \#4C526C ray2 \#8C96B4}
 
 proc DoDisplay {} {
    global S
 
    wm title . $S(title)
    canvas .c -bg black -width $S(w) -height $S(h) -highlightthickness 0
    label .t -textvariable ::G(tmsg) -font {Times 18 bold} \
        -fg cyan -bg black -anchor w -padx 10
    pack .t -side top -fill x
    pack .c -side top -fill both -expand 1
    bind all <F2> NewGame
    bind all <F3> {console show}
    DoMenus
 
    bind .c <Configure> {ReCenter %W %h %w}     ;# Force 0,0 to be in center
    update
 }
 proc DoMenus {} {
    menu .m -tearoff 0
    . configure -menu .m                         ;# Attach menu to main window
 
    .m add cascade -menu .m.game -label "Game" -underline 0
    .m add cascade -menu .m.help -label "Help" -underline 0
 
    menu .m.game -tearoff 0
    .m.game add command -label "New Game" -under 0 -command NewGame -acc "F2"
    .m.game add separator
    .m.game add radiobutton -label "Easy"   -under 0 -variable ::G(n) -value 5  -command NewGame
    .m.game add radiobutton -label "Normal" -under 0 -variable ::G(n) -value 7  -command NewGame
    .m.game add radiobutton -label "Hard"   -under 0 -variable ::G(n) -value 9  -command NewGame
    .m.game add radiobutton -label "Expert" -under 0 -variable ::G(n) -value 11 -command NewGame
    .m.game add separator
    .m.game add command -label "Exit" -under 1 -command exit
 
    menu .m.help -tearoff 0
    .m.help add command -label "About" -under 0 -command About
 }
 proc DrawBoard {} {
    global B
 
    .c delete all
    for {set row $::G(-n2)} {$row < $::G(n2)} {incr row} {
        set cmax [expr {$::G(n)-1-abs($row)}]
        for {set col -$cmax} {$col <= $cmax} {incr col 2} {
            DrawCellRays $row $col
            .c create image [Cell2XY $row $col] -image ::img::ball \
                -tag b$row,$col
            .c bind b$row,$col <1> [list Click $row $col 1]
            .c bind r$row,$col <1> [list Click $row $col 1]
            .c bind b$row,$col <3> [list Click $row $col -1]
            .c bind r$row,$col <3> [list Click $row $col -1]
            .c bind b$row,$col <Control-1> [list Cheat $row $col]
            .c bind r$row,$col <Control-1> [list Cheat $row $col]
        }
    }
    LightUp
 }
 proc DrawRay {row col dir} {
    foreach {r1 c1} [MoveDir $row $col $dir] break
 
    foreach {x0 y0} [Cell2XY $row $col] break
    foreach {x1 y1} [Cell2XY $r1 $c1] break
 
    set x2 [expr {$x0 + ($x1-$x0)/2}]           ;# Halfway point
    set y2 [expr {$y0 + ($y1-$y0)/2}]
    set tag r$row,$col
    .c create line $x0 $y0 $x2 $y2 -tag [list r1 $tag] -width 4 -fil $::COLORS(ray1)
    .c create line $x0 $y0 $x2 $y2 -tag [list r2 $tag] -width 2 -fil $::COLORS(ray2)
    .c lower r$row,$col
 }
 proc DrawCellRays {row col} {
    .c delete r$row,$col
    foreach dir $::B(r,$row,$col) {
        DrawRay $row $col $dir
    }
 }
 proc Cell2XY {row col} {
    set x [expr {$col * $::S(hdist)}]
    set y [expr {-$row * $::S(vdist)}]
    return [list $x $y]
 }
 ##+##########################################################################
 #
 # Recenter -- keeps 0,0 at the center of the canvas during resizing
 #
 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]
 }
 
 proc Timer {{restart 0}} {
    global G
 
    foreach aid [after info] { after cancel $aid }
    if {$restart} {
        set G(start) [clock seconds]
    }
    if {$G(state) ne "play"} return
    set tlen [expr {[clock seconds] - $G(start)}]
    set G(tmsg) [clock format $tlen -format "%M:%S"]
    after 1000 Timer
 }
 proc NewGame {} {
    MakeBoard
    DrawBoard
    set ::G(state) play
    Timer 1
 }
 ##+##########################################################################
 #
 # MakeBoard -- figures out all the nodes and all edges, then deletes
 # edges leaving a minimum spanning tree and finally randomly rotates
 # all nodes.
 #
 proc MakeBoard {} {
    global B G EDGES
 
    unset -nocomplain B
    set EDGES {}
 
    set G(n2) [expr {($G(n)+1)/2}]              ;# Handy constants
    set G(-n2) [expr {1-$G(n2)}]
 
    for {set row $::G(-n2)} {$row < $::G(n2)} {incr row} {
        set cmax [expr {$::G(n)-1-abs($row)}]
        for {set col -$cmax} {$col <= $cmax} {incr col 2} {
            set B(c,$row,$col) 1
        }
    }
 
    # Compute all legal edges
    for {set row $::G(-n2)} {$row < $::G(n2)} {incr row} {
        set cmax [expr {$::G(n)-1-abs($row)}]
        for {set col -$cmax} {$col <= $cmax} {incr col 2} {
            set B(r,$row,$col) [FindNeighbors $row $col]
            foreach dir {0 1 2} {
                if {[lsearch $B(r,$row,$col) $dir] > -1} {
                    lappend EDGES [list $row $col $dir]
                }
            }
        }
    }
    set G(cnt) [llength [array names B c*]]
 
    # Now convert full graph into minimum spanning tree
    set mst [MST]
    foreach e $EDGES {
        if {[lsearch $mst $e] == -1} {          ;# Is edge not in MST???
            eval RemoveEdge $e                  ;# ...then remove it
        }
    }
 
    # Now rotate randomly every node
    for {set row $::G(-n2)} {$row < $::G(n2)} {incr row} {
        set cmax [expr {$::G(n)-1-abs($row)}]
        for {set col -$cmax} {$col <= $cmax} {incr col 2} {
            set B(rr,$row,$col) $B(r,$row,$col)
            RotateCell $row $col [expr {int(rand()*6)}]
        }
    }
 }
 ##+##########################################################################
 #
 # FindNeighbors -- returns list of all legal directions from this node
 #
 proc FindNeighbors {row col} {
    global B
 
    set dirs {}
    foreach dir {0 1 2 3 4 5} {
        foreach {r c} [MoveDir $row $col $dir] break
        if {[info exists B(c,$r,$c)]} { lappend dirs $dir }
    }
    return $dirs
 }
 proc MoveDir {row col dir} {
    foreach {dr dc} $::DRC($dir) break
    set r1 [expr {$row + $dr}]
    set c1 [expr {$col + $dc}]
    return [list $r1 $c1]
 }
 ##+##########################################################################
 #
 # Click -- handles clicking on a node
 #
 proc Click {row col rdir} {
    RotateCell $row $col $rdir
    DrawCellRays $row $col
    LightUp
 }
 proc Cheat {row col} {
    set ::B(r,$row,$col) $::B(rr,$row,$col)
    DrawCellRays $row $col
    LightUp
 }
 
 proc RotateCell {row col rdir} {
    global B
    set dirs {}
    foreach dir $B(r,$row,$col) {
        lappend dirs [expr {($dir + $rdir) % 6}]
    }
    set B(r,$row,$col) $dirs
 }
 ##+##########################################################################
 #
 # LightUp -- does a depth-first-search to find all connected components
 #
 proc LightUp {} {
    global DFS
 
    DFS
    set solved 1
    for {set row $::G(-n2)} {$row < $::G(n2)} {incr row} {
        set cmax [expr {$::G(n)-1-abs($row)}]
        for {set col -$cmax} {$col <= $cmax} {incr col 2} {
            set img "::img::ball2"
            if {! $DFS($row,$col)} {
                set solved 0
                set img "::img::ball"
            }
            .c itemconfig b$row,$col -image $img
        }
    }
 
    if {$solved} Victory
 }
 
 proc Victory {} {
    global G
 
    if {$G(state) ne "play"} return
    set G(state) solved
    Flash
 }
 proc Flash {{cnt 3} {delay 200}} {
    for {set i 0} {$i < $cnt} {incr i} {
        .c config -bg red
        .t config -bg red
        update
        after $delay
        .c config -bg black
        .t config -bg black
        update
        after $delay
    }
 }
 ##+##########################################################################
 #
 # RemoveEdge -- removes an edge for a given node and the reverse node
 #
 proc RemoveEdge {row col dir} {
    global B
 
    foreach {r c} [MoveDir $row $col $dir] break
    set opp [expr {($dir + 3) % 6}]
 
    set n [lsearch $B(r,$row,$col) $dir]
    set B(r,$row,$col) [lreplace $B(r,$row,$col) $n $n]
 
    set n [lsearch $B(r,$r,$c) $opp]
    set B(r,$r,$c) [lreplace $B(r,$r,$c) $n $n]
 }
 ##+##########################################################################
 #
 # DFS -- does a depth-first-search from the origin. This can blow out
 # the recursion limit for big board sizes.
 #
 proc DFS {} {
    global DFS
 
    unset -nocomplain DFS
    set DFS(cnt) 0
    for {set row $::G(-n2)} {$row < $::G(n2)} {incr row} {
        set cmax [expr {$::G(n)-1-abs($row)}]
        for {set col -$cmax} {$col <= $cmax} {incr col 2} {
            set DFS($row,$col) 0
        }
    }
 
    _DFS 0 0
 }
 ##+##########################################################################
 #
 # _DFS -- recursive caller for DFS
 #
 proc _DFS {row col} {
    global B DFS
 
    set DFS($row,$col) 1
    incr DFS(cnt)
    foreach dir $B(r,$row,$col) {
        if {! [IsPath $row $col $dir]} continue
        foreach {r c} [MoveDir $row $col $dir] break
        if {$DFS($r,$c) != 0} continue
        _DFS $r $c
    }
 }
 ##+##########################################################################
 #
 # IsPath -- return true if there is a path from row,col in direction dir
 #     assumes path exists out of row,col so it checks for off the board
 #     and is there a matching opposite path from destination
 #
 proc IsPath {row col dir} {
    global B
 
    foreach {r c} [MoveDir $row $col $dir] break
    if {! [info exists B(c,$r,$c)]} { return 0 };# Destination off the board
    set opp [expr {($dir + 3) % 6}]
    set n [lsearch $B(r,$r,$c) $opp]
    return [expr {$n > -1 ? 1 : 0}]
 }
 
 proc Shuffle {l} {
    set len [llength $l]
    set len2 $len
    for {set i 0} {$i < $len-1} {incr i} {
        set n [expr {int($i + $len2 * rand())}]
        incr len2 -1
 
        # Swap elements at i & n
        set temp [lindex $l $i]
        lset l $i [lindex $l $n]
        lset l $n $temp
    }
    return $l
 }
 proc About {} {
    set txt "$::S(title)\nby Keith Vetter, February 2006\n\n"
    append txt "Turn on all the lights!\n\n"
    append txt "Left click: rotate clockwise\n"
    append txt "Right click: rotate counter-clockwise\n"
    tk_messageBox -message $txt -title About
 }
 ##+##########################################################################
 #
 # MST -- computes a random minimum spanning tree using Prim's algorithm
 #
 proc MST {} {
    global B EDGES
 
    set mst {}
 
    # Mark all nodes as unvisited
    for {set row $::G(-n2)} {$row < $::G(n2)} {incr row} {
        set cmax [expr {$::G(n)-1-abs($row)}]
        for {set col -$cmax} {$col <= $cmax} {incr col 2} {
            set visited($row,$col) 0
        }
    }
 
    set edges [Shuffle $EDGES]
 
    foreach {r c} [lindex $edges 0] break       ;# Start with random node
    set visited($r,$c) 1
    while {[llength $mst] < $::G(cnt)-1} {
        # Find edge out of visited nodes (inefficient but who cares)
        for {set i 0} {$i < [llength $edges]} {incr i} {
            foreach {r0 c0 dir} [lindex $edges $i] break ;# Start point
            foreach {r1 c1} [MoveDir $r0 $c0 $dir] break ;# End point
            if {$visited($r0,$c0) != $visited($r1,$c1)} break
        }
        set edges [lreplace $edges $i $i]       ;# Remove from edge list
        lappend mst [list $r0 $c0 $dir]         ;# Add to our mst
        set visited($r0,$c0) 1                  ;# Mark nodes as visited
        set visited($r1,$c1) 1
    }
 
    return $mst
 }
 
 ################################################################
 
 image create photo ::img::ball -data {
    R0lGODlhCgAKALMAACQmJHd3d6SmpAQC/ExKTJGRkcTCxFxeXDk3Oby6vISGhJyenNDQ0GZnZlRW
    VKyurCH5BAEAAAMALAAAAAAKAAoAAwQ5cIyWGHtOjmJNekszHN4jLIUSIAWYBkHTEEUBN0d+ODHu
    /I4dIQgMHggAo3EHGCB+uR9CAxg6kJIIADs=}
 image create photo ::img::ball2 -data {
    R0lGODlhCgAKALMAAGRXBJSKBN7MBOzYXLyyBOjkBMq/BN3XBAQC/Pz2fJR6BJSWBPPwBL6aBGRm
    BN23BCH5BAEAAAgALAAAAAAKAAoAAwQzECFnzjFAomWtEMFkFQxTCBghkKX5NMaQzPTwPDI9283D
    loUX4MYKPjKKm/Kh0AB6QkkEADs=}
 
 DoDisplay
 NewGame
 return
----

[ABU] Really nice. Just for the blockheads like me, could you provide a "solve" command with a slow animation ?

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