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.
2017-12-03 : An online demo of the above is available at [2]uniquename 2013aug01Here is a right-clipped image of the 'desktop' version --- along with a (partly-clipped) image of the help popup.
##+##########################################################################
#
# 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
