LV Maybe the following app could become one of the demonstration applications in the tclapp (or is it tkapp) module at sf.net?
BBH Fine by me ;)
#########################################################################
##
## TkMaze - a fun little maze game
##
## Based on ideas from [Graph theory in Tcl] by [Richard Suchenwirth]
## and my inital cut at [maze generator] The few procs needed from there
## have been moved (and some tweaking done for this specific usage which
## may/may not apply to graphs in general) so this should work fine just
## by copying the whole thing and running as is
##
#########################################################################
## Change Log: (please add entry and update the TkMazeVersion)
##
## Date Name Notes
## --------- ------------- --------------------------------------------
## 19Nov2001 B. Hartweg Initial Release
##
#########################################################################
namespace eval tkmaze {
variable TkMazeVersion 0.1
variable Cache
variable Settings
variable Color
variable Maze
array set Settings {
Width 5
Height 3
OldShadow None
Shadow None
Visibility 5
Player,1 human
Player,2 human
Trail,1 yes
Trail,2 yes
Delay,1 100
Delay,2 100
AID,1 -1
AID,2 -1
Color,1 Blue
Color,2 Red
Keys,up,1 {<W> <w>}
Keys,down,1 {<Z> <z>}
Keys,left,1 {<A> <a>}
Keys,right,1 {<S> <s>}
Keys,up,2 {<Up> <KP_8>}
Keys,down,2 {<Down> <KP_2>}
Keys,left,2 {<Left> <KP_4>}
Keys,right,2 {<Right> <KP_6>}
InGame no
}
namespace eval drones {
variable rturn
variable lturn
variable uturn
array set rturn {
down left
left up
up right
right down
}
array set lturn {
down right
right up
up left
left down
}
array set uturn {
up down
down up
left right
right left
}
}
}
proc ::tkmaze::init {} {
getCache
mainGUI
}
proc ::tkmaze::mainGUI {} {
variable Settings
variable Color
wm title . "TkMaze"
menu .mbar -type menubar
. config -menu .mbar
set Color [. cget -background]
# File Menu
.mbar add cascade -label File -menu [set m [menu .mbar.f -tearoff 0]]
$m add command -label "New Game" \
-command [namespace code newGame]
$m add command -label "Pause" \
-command [namespace code pause]
$m add command -label "Quit" -command exit
# Options Menu
.mbar add cascade -label Options -menu [set m [menu .mbar.o -tearoff 0]]
$m add cascade -label Width -menu [menu $m.w -tearoff 0]
for {set w 1} {$w < [expr {[winfo screenwidth .]/100}]} {incr w} {
$m.w add radiobutton -label $w -value $w \
-variable [namespace which -variable Settings](Width)
}
$m add cascade -label Height -menu [menu $m.h -tearoff 0]
for {set h 1} {$h < [expr {[winfo screenheight .]/100}]} {incr h} {
$m.h add radiobutton -label $h -value $h \
-variable [namespace which -variable Settings](Height)
}
$m add cascade -label Shadow -menu [menu $m.s -tearoff 0]
foreach v {None Transient Permanent} {
$m.s add radiobutton -label $v -value $v \
-variable [namespace which -variable Settings](Shadow) \
-command [namespace code "changeShadow"]
}
$m.s add cascade -label Visibility -menu [menu $m.s.v -tearoff 0]
foreach d {5 10 15 20 25} {
$m.s.v add radiobutton -label $d -value $d \
-variable [namespace which -variable Settings](Visibility)
}
# Player Menus
foreach {n} {1 2} {
.mbar add cascade -label "Player $n" -menu [set m [menu .mbar.p$n -tearoff 0]]
$m add radiobutton -label Human -value human \
-variable [namespace which -variable Settings](Player,$n) \
-command [namespace code "setupPlayer $n"]
$m add separator
foreach cmd [info commands [namespace current]::drones::*] {
set name [namespace tail $cmd]
$m add radiobutton -label $name -value $name \
-variable [namespace which -variable Settings](Player,$n) \
-command [namespace code "setupPlayer $n"]
}
$m add cascade -label Delay -menu [menu $m.d -tearoff 0]
foreach {w v} {
None 1 "1/10 sec" 100 "1/4 sec" 250
"1/3 sec" 333 "1/2 sec" 500 "1 sec" 1000
} {
$m.d add radiobutton -label $w -value $v \
-variable [namespace which -variable Settings](Delay,$n)
}
$m add separator
$m add checkbutton -label "Show Trail" -onval yes -offval no \
-variable [namespace which -variable Settings](Trail,$n)
}
# Help Menu
.mbar add cascade -label Help -menu [set m [menu .mbar.h -tearoff 0]]
$m add command -label "About..." \
-command [namespace code about]
#playing board is all one canvas -no fancy layout needed!
pack [canvas .c -background black -highlightthickness 0] -padx 10 -pady 10
}
proc ::tkmaze::changeShadow {} {
variable Settings
switch -glob "$Settings(OldShadow)->$Settings(Shadow)" {
*->None{
catch {.c lower Shadow}
}
Transient->Transient -
Permanent->Permanent -
Permanent->Transient {
# nothing to do!
}
None->* -
Transient->Permanent {
catch {.c raise Shadow}
catch {modShadow lower $Settings(Current,1)}
catch {modShadow lower $Settings(Current,2)}
}
}
set Settings(OldShadow) $Settings(Shadow)
}
proc ::tkmaze::changeVis {} {
variable Settings
catch {
switch -exact $Settings(Shadow) {
None {
return
}
Permanent {
.c raise all
modShadow lower $Settings(Current,1)
modShadow lower $Settings(Current,2)
}
Transient {
modShadow lower $Settings(Current,1)
modShadow lower $Settings(Current,2)
}
}
}
}
proc ::tkmaze::modShadow {op n} {
variable Settings
scan $n "<%d:%d>" x y
set r $Settings(Visibility)
for {set dx -$r} {$dx <= $r} {incr dx} {
for {set dy -$r} {$dy <= $r} {incr dy} {
if { hypot($dx,$dy) < $r } {
set tag "S<[expr {$x+$dx}]:[expr {$y+$dy}]>"
catch {.c $op $tag}
}
}
}
}
proc ::tkmaze::getCache {{force no}} {
variable Cache
set fname $::env(HOME)/.tkmazerc
if {[string equal $force force]} {
set doit 1
} else {
set doit 1
if [file readable $fname] {
set fd [open $fname r]
set Cache [read $fd]
close $fd
if {![catch {llength $Cache}]} {
if {[llength $Cache] >= 25} {
set doit 0
}
}
}
}
puts "DOIT = $doit"
if { $doit } {
toplevel .msg
wm title .msg "Working..."
pack [label .msg.l -textvar MSG]
set i 0
set Cache {}
while {$i < 25} {
if {$i%10} {append ::MSG "."} {
set ::MSG "Generating Maze Data..."
}
update idletasks
puts "MAKE GRID ----------------" ; update
set tmp [makeGrid 10 10]
puts "MAKE MAZE+++++++++++++++++++++++++++++++++++++" ; update
lappend Cache [makeMaze $tmp 10 10]
puts "DONE\n"
incr i
}
set fd [open $fname w]
puts $fd $Cache
close $fd
catch {destroy .msg}
}
}
proc ::tkmaze::makeGrid {w h} {
set m {}
for {set x 0} {$x < $w} {incr x} {
set x1 [expr {$x+1}]
for {set y 0} {$y < $h} {incr y} {
set y1 [expr {$y+1}]
if {$x1<$w} { lappend m "<$x:$y>,<$x1:$y>" }
if {$y1<$h} { lappend m "<$x:$y>,<$x:$y1>" }
}
}
return $m
}
proc ::tkmaze::makeMaze {g w h} {
set eList [edges $g]
set n [expr {$w*$h -1}]
while {[llength $g] > $n } {
set edge [listRemove eList [random [llength $eList]]]
set nds [string map {, " "} $edge]
set t [string map [list $edge $nds] $g]
if {[isConnected $t]} {
listDelete g $edge
}
}
return $g
}
proc ::tkmaze::nodes {g} {
lsort -unique [string map {, " "} $g]
}
proc ::tkmaze::edges {g} {
set e {}
foreach elem $g {
if {[string match "*,*" $elem]} {
lappend e $elem
}
}
set e
}
proc ::tkmaze::isConnected {g} {
set i 0
foreach node [nodes $g] {
set set($node) [incr i]
set ccs($i) $node
}
foreach edge [edges $g] {
foreach {from to} [split $edge ,] break
set s1 $set($from)
set s2 $set($to)
if {$s1!=$s2} {
if {$s1>$s2} {swap s1 s2}
foreach node $ccs($s2) {
set set($node) $s1
lappend ccs($s1) $node
}
unset ccs($s2) ;#
}
}
expr {[array size ccs]==1}
}
proc ::tkmaze::getRandomBlock {sx sy} {
variable Cache
set m [lindex $Cache [random [llength $Cache]]]
set f {0 1 2 3 4 5 6 7 8 9}
set b {9 8 7 6 5 4 3 2 1 0}
foreach xf $f xb $b {
set x [expr {$sx+$xf}]
foreach yf $f yb $b {
set y [expr {$sy+$yf}]
set n "<$x:$y>"
lappend map(0) "<$xf:$yf>" $n
lappend map(1) "<$xf:$yb>" $n
lappend map(2) "<$xb:$yf>" $n
lappend map(3) "<$xb:$yb>" $n
lappend map(4) "<$yf:$xf>" $n
lappend map(5) "<$yb:$xf>" $n
lappend map(6) "<$yf:$xb>" $n
lappend map(7) "<$yb:$xb>" $n
}
}
string map $map([random 8]) $m
}
proc ::tkmaze::swap {_a _b} {
upvar 1 $_a a $_b b
foreach {b a} [list $a $b] break
}
proc ::tkmaze::random {n} { expr {int(rand() * $n)} }
proc ::tkmaze::listRemove {_L i} {
upvar 1 $_L L
set item [lindex $L $i]
set L [lreplace $L $i $i]
return $item
}
proc ::tkmaze::listDelete {_L item} {
upvar 1 $_L L
set i [lsearch -exact $L $item]
set L [lreplace $L $i $i]
}
proc ::tkmaze::renderMaze {} {
variable Settings
variable Maze
variable Color
foreach e $Maze {
scan $e "<%d:%d>,<%d:%d>" x1 y1 x2 y2
set x1 [expr {($x1 * 10.0) + 1.0}]
set x2 [expr {($x2 * 10.0) + 9.0}]
set y1 [expr {($y1 * 10.0) + 1.0}]
set y2 [expr {($y2 * 10.0) + 9.0}]
.c create rectangle $x1 $y1 $x2 $y2 -fill $Color -outline $Color -tag MAZE
}
foreach n [nodes $Maze] {
if {[string equal $n $Settings(Start,1)] ||
[string equal $n $Settings(Start,2)]} {
continue
}
scan $n "<%d:%d>" x y
set x1 [expr {$x*10}]
set x2 [expr {$x1+10}]
set y1 [expr {$y*10}]
set y2 [expr {$y1+10}]
if 1 {
set tags [list Shadow "S$n"]
} else {
set xs [expr {$x-$Settings(Visibility)}]
set xe [expr {$x+$Settings(Visibility)}]
set ys [expr {$y-$Settings(Visibility)}]
set ye [expr {$y+$Settings(Visibility)}]
set tags Shadow
for {set xx $xs} {$xx <= $xe} {incr xx} {
for {set yy $ys} {$yy <= $ye} {incr yy} {
if {hypot($x-$xx,$y-$yy) < $Settings(Visibility)} {
lappend tags "S<$xx:$yy>"
}
}
}
}
.c create rectangle $x1 $y1 $x2 $y2 -fill black -outline black -tag $tags
}
if {[string equal $Settings(Shadow) None]} {
.c lower Shadow
} else {
.c raise Shadow
}
}
proc ::tkmaze::generateMaze {} {
variable Settings
variable Maze
set Maze {}
# get chunks from cached data
for {set x 0} {$x < $Settings(Width)} {incr x} {
for {set y 0} {$y < $Settings(Height)} {incr y} {
set m [getRandomBlock [expr {$x*10}] [expr {$y*10}]]
set Maze [concat $Maze $m]
}
}
# connect the blocks
set g [makeGrid $Settings(Width) $Settings(Height)]
set m [makeMaze $g $Settings(Width) $Settings(Height)]
foreach e $m {
scan $e "<%d:%d>,<%d:%d>" x1 y1 x2 y2
if {$x1==$x2} {
set X1 [set X2 [expr {$x1*10 + [random 10]}]]
set Y2 [expr {$y2*10}]
set Y1 [expr {$Y2-1}]
} else {
set Y1 [set Y2 [expr {$y1*10 + [random 10]}]]
set X2 [expr {$x2*10}]
set X1 [expr {$X2-1}]
}
lappend Maze "<$X1:$Y1>,<$X2:$Y2>"
}
# normalize (so all edges are left->right or top->bottom
set m {}
foreach e $Maze {
scan $e "<%d:%d>,<%d:%d>" x1 y1 x2 y2
if {$x1>$x2||$y1>$y2} {
lappend m "<$x2:$y2>,<$x1:$y1>"
} else {
lappend m $e
}
}
set Maze $m
# add start/stop nodes
foreach {x p v} [list 0 1 n2 [expr {$Settings(Width)*10}] 2 n1] {
set y [random [expr {$Settings(Height)*10}]]
set n1 "<$x:$y>"
incr x -1
set n2 "<$x:$y>"
set Settings(Start,$p) [set $v]
lappend Maze "$n2,$n1"
}
set Settings(Goal,1) $Settings(Start,2)
set Settings(Goal,2) $Settings(Start,1)
# blur divisions
# draw it!
renderMaze
}
proc ::tkmaze::newGame {} {
variable Settings
after cancel $Settings(AID,1)
after cancel $Settings(AID,2)
.c delete all
.c config -cursor watch -width [expr {$Settings(Width)*100+10}] -height [expr {$Settings(Height)*100+10}]
. config -cursor watch
update
generateMaze
.c move all 5 5
set Settings(InGame) yes
foreach {p d} {1 right 2 left} {
set Settings(Current,$p) $Settings(Start,$p)
set Settings(LastDir,$p) ""
scan $Settings(Current,$p) "<%d:%d>" X Y
foreach {x y} [getPoint $X $Y $p] break
set Settings(Coords,$p) [list $x $y $x $y]
.c create line $Settings(Coords,$p) -width 2 -fill $Settings(Color,$p) -tag "PTrail$p"
.c create oval [getOval $x $y] -fill $Settings(Color,$p) -outline $Settings(Color,$p) -tag "PMark$p"
playerMove $p $d
after [random 100] [namespace code "setupPlayer $p"]
}
.c config -cursor {}
. config -cursor {}
}
proc ::tkmaze::setupPlayer {p} {
variable Settings
if { $Settings(InGame) } {
set man [string equal $Settings(Player,$p) human]
foreach dir {up down left right} {
foreach k $Settings(Keys,$dir,$p) {
if { $man } {
bind . $k [namespace code "playerMove $p $dir"]
} else {
bind . $k {}
}
}
}
if { ! $man } {
catch {autoPlay $p}
}
}
}
proc ::tkmaze::playerMove {p d} {
variable Settings
variable Maze
if { ! $Settings(InGame) } {
return 0
}
set n1 $Settings(Current,$p)
scan $n1 "<%d:%d>" x y
switch $d {
up {incr y -1}
down {incr y 1}
left {incr x -1}
right {incr x 1}
}
set n2 "<$x:$y>"
if {[lsearch -exact $Maze "$n1,$n2"] >=0 ||
[lsearch -exact $Maze "$n2,$n1"] >=0
} {
set Settings(Current,$p) $n2
set Settings(LastDir,$p) $d
foreach {x y} [getPoint $x $y $p] break
.c coords PMark$p [getOval $x $y]
lappend Settings(Coords,$p) $x $y
.c coords PTrail$p $Settings(Coords,$p)
if { $Settings(Trail,$p) } {
.c raise PTrail$p
} else {
.c lower PTrail$p
}
if {[string equal $Settings(Shadow) Permanent]} {
modShadow raise $n1
}
modShadow lower $n2
if {[string equal $Settings(Current,$p) $Settings(Goal,$p)]} {
set Settings(InGame) no
tk_messageBox -title "Game Over" -message \
"Player $p has WON!"
}
return 1
} else {
return 0
}
}
proc ::tkmaze::autoPlay {p} {
variable Settings
variable Maze
after cancel $Settings(AID,$p)
set cmd [namespace current]::drones::$Settings(Player,$p)
set n $Settings(Current,$p)
scan $n "<%d:%d>" x y
set valid {}
foreach {d dx dy} {up 0 -1 down 0 1 left -1 0 right 1 0} {
set nn "<[expr {$x + $dx}]:[expr {$y + $dy}]>"
if {[lsearch -exact $Maze "$n,$nn"] >=0 ||
[lsearch -exact $Maze "$nn,$n"] >=0
} {
lappend valid $d
}
}
set d $Settings(LastDir,$p)
catch {set d [$cmd $d $valid]}
playerMove $p $d
if {$Settings(InGame) && ![string equal $Settings(Player,$p) human]} {
set Settings(AID,$p) [after $Settings(Delay,$p) [namespace code "autoPlay $p"]]
}
}
proc ::tkmaze::pause {} {
variable Settings
if { $Settings(InGame) } {
after cancel $Settings(AID,1)
after cancel $Settings(AID,2)
set Settings(InGame) no
tk_messageBox -title Pause -message "Game Paused - Click Ok to continue" -parent .
set Settings(InGame) yes
setupPlayer 1
setupPlayer 2
}
}
proc ::tkmaze::getPoint {x y p} {
set off(1) 8
set off(2) 12
list [expr {$x*10 + $off($p)}] [expr {$y*10 + $off($p)}]
}
proc ::tkmaze::getOval {x y} {
set x1 [expr {$x - 3}]
set y1 [expr {$y - 3}]
set x2 [expr {$x + 3}]
set y2 [expr {$y + 3}]
list $x1 $y1 $x2 $y2
}
proc ::tkmaze::about {} {
variable TkMazeVersion
if {[winfo exists .about]} {
wm deiconify .about
} else {
set w [toplevel .about -class dialog]
wm withdraw $w
wm transient $w .
wm title $w "About TkMaze $TkMazeVersion"
button $w.b -text Dismiss -command [list wm withdraw $w]
text $w.text -height 14 -bd 1 -width 70
pack $w.b -fill x -side bottom
pack $w.text -fill both -side left -expand 1
$w.text tag config center -justify center
$w.text tag config title -justify center -font {Courier -18 bold}
$w.text insert 1.0 "About TkMaze $TkMazeVersion" title \
"\n\nCopyright (C) 2001 Bruce B Hartweg <[email protected]>\n\n" \
center {
Most settings can be changed on the fly (except width/height)
Goal is to get to the other side!
Player 1 (blue) uses W,A,S,Z keys (upper or lower)
Player 2 (red) uses arrow keys (or KeyPad 2,4,6,8)
Shadow option hides the maze except for "Visibility" blocks from player
in Transient mode exposed area remains exposed
in Permanent mode ONLY nearest blocks visible
} left
$w.text config -state disabled
wm deiconify $w
}
}
#########################################################################
## the drone sub-namespace is for robot players
## each proc here should take 2 args
## last - last direction moved
## valid - a list of valid direction to go from here
## and it should return a desired direction to move - for convience
## there variable rturn lturn and uturn are arrays that give the
## RELATIVE left/right/opposite turn of given direction
#########################################################################
proc ::tkmaze::drones::Lefty {last valid} {
variable rturn
variable lturn
variable uturn
set r $rturn($last)
set l $lturn($last)
set u $uturn($last)
foreach dir [list $l $last $r $u] {
if {[lsearch $valid $dir]>=0} {
return $dir
}
}
return $last
}
proc ::tkmaze::drones::Righty {last valid} {
variable rturn
variable lturn
variable uturn
set r $rturn($last)
set l $lturn($last)
set u $uturn($last)
foreach dir [list $r $last $l $u] {
if {[lsearch $valid $dir]>=0} {
return $dir
}
}
return $last
}
proc ::tkmaze::drones::Stupid {last valid} {
return [lindex $valid [::tkmaze::random [llength $valid]]]
}
#########################################################################
##
## START OF EXECUTION
##
#########################################################################
::tkmaze::init