Updated 2013-08-17 02:49:49 by uniquename

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.

Fun project for several reasons: 1) implemented a minimum spanning tree algorithm (Prim's) 2) implemented a depth-first search and 3) did a poor man's anti-aliasing to get nicer looking lines.

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

KPV There's already a built it cheat command. Just hold the control key down and click on a node. That will cause that node to orient itself correctly.

GS 2010-10-23 : A slightly modified version [1] for touchscreen Windows Mobile device with eTcl. Lights bulbs are larger and expert mod has been disabled because it is too larger to fit in smartphone screen resolution.

uniquename 2013aug01

Here is a right-clipped image of the 'desktop' version --- along with a (partly-clipped) image of the help popup.

This is the initial setting of the GUI. The little rods rotate to 'hexagonal-angles' --- and lights come on as more segments are attached, to complete the circuit to the central light.
 ##+##########################################################################
 #
 # 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