[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 <brhartweg@bigfoot.com>\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
======


<<categories>> Games