GPS: This is very impressive! Thanks for sharing it.
KPV : Updated version that lets you use the mouse to move about. KPV : Updated again to make it more of an interesting game by optionally showing you only the cells you visited.UKo : Update to fix font for help widget with Tk 8.5
##+####################################################################
#
# 3D Maze
#
# Draws a maze with a guaranteed unique solution.
# by Keith Vetter
#
# The program works by picking a spot randomly in the maze, then
# random walking until it can't proceed on untravelled cells. It then
# backs up until it can branch onto a untravelled cells and proceeds
# on a new random walk. When all cells have been visited we're done
# except for selecting a spot on the east and west wall for the
# entrances.
#
# Actually, if you start your walk from the exit, and record the
# direction you entered a cell from, then you have the solution from
# anywhere in the maze to the exit. Furthermore, you can find the path
# from any A->B by getting the solution from both points, finding
# where they meet and joining the two paths to the junction point.
#
# Revisions:
# KPV August 31, 1994 - initial revision
# KPV Sep 24, 2002 - ported to tk8+
# KPV Sep 25, 2002 - exposed 3d capabilities, added the moving man,
# KPV Sep 26, 2002 - moving with the mouse
# KPV Oct 14, 2002 - added opaque maze
package require Tk
set sz(x) 10 ;# Maze width
set sz(y) 10 ;# Maze height
set sz(z) 3 ;# Maze levels
##+####################################################################
#
# Init
#
# Sets up some global variables.
#
proc Init {} {
global sz DIR WALL DOOR MOTION MARK
set sz(w) 550 ;# Canvas width
set sz(h) 550 ;# Canvas height
set sz(box) 30 ;# Cell box size
set sz(tm) 50 ;# Top margin
set sz(lm) 50 ;# Left margin
set sz(lw) 3 ;# Line width
set sz(animate) 0 ;# Animation active flag
set sz(moving) 0 ;# Automated moving flag
set sz(solution) {} ;# Working solution
set sz(mousing) 0
# These directions also act as bit shift amounts
array set DIR {NORTH 0 EAST 1 UP 2 SOUTH 3 WEST 4 DOWN 5 DONE -1}
foreach {a b} [array get DIR] {set DIR($b) $a}
array set WALL {
NORTH 0x01 EAST 0x02 UP 0x04 SOUTH 0x08 WEST 0x10 DOWN 0x20 ANY 0x3F
}
array set DOOR {
NORTH 0x0100 EAST 0x0200 UP 0x0400 SOUTH 0x0800 WEST 0x1000 DOWN 0x2000
ANY 0x3F00
}
array set MOTION {0 0,-1,0 1 1,0,0 2 0,0,-1 3 0,1,0 4 -1,0,0 5 0,0,1}
foreach {a b} [array get MOTION] {set MOTION($b) $a}
array set MARK {X 0x4000 ? 0x8000 ANY 0xC000 VICTORY 0x10000 \
VISIBLE 0x40 VISITED 0x80 V_ANY 0xC0}
}
proc WALLDIR {dir} {return [expr {$::WALL(NORTH) << $dir}] }
proc DOORDIR {dir} {return [expr {$::DOOR(NORTH) << $dir}] }
proc WALLDOORDIR {dir} {return [expr {($::WALL(NORTH) |$::DOOR(NORTH))<<$dir}]}
proc OPPOSITE {dir} {return [expr {($dir + 3) % 6}] }
proc ADDHINT {x y z dir} {ORMAZE $x $y $z [expr {($dir + 1) << 17}]}
proc GETHINT {x y z} {return [expr {($::maze($x,$y,$z) >> 17) - 1}]}
proc ORMAZE {x y z n} {set ::maze($x,$y,$z) [expr {$::maze($x,$y,$z) | $n}]}
proc UNORMAZE {x y z n} {set ::maze($x,$y,$z) [expr {$::maze($x,$y,$z) & ~$n}]}
proc INFO {msg} {.c itemconfig INFO -text $msg ; update idletasks }
proc CANMOVE {x y z d} {expr {$::maze($x,$y,$z) & [DOORDIR $d]}}
proc ISMARKED {x y z who} {expr {$::maze($x,$y,$z) & $who}}
proc ISVISIBLE {x y z} {expr {$::maze($x,$y,$z) & $::MARK(V_ANY)}}
proc MARKVISIBLE {x y z} {ORMAZE $x $y $z $::MARK(VISIBLE)}
proc MARKVISITED {x y z} {ORMAZE $x $y $z $::MARK(VISITED)}
proc DOMARK {x y z who} {ORMAZE $x $y $z $who}
proc UNMARK {x y z who} {UNORMAZE $x $y $z $who}
proc MOVETO {x y z d} {foreach {dx dy dz} [split $::MOTION($d) , ] break
list [incr x $dx] [incr y $dy] [incr z $dz]}
proc UNMOVE {x y z X Y Z} {
if {[catch {set ::MOTION([incr X -$x],[incr Y -$y],[incr Z -$z])} n]} {
return -1} {return $n}}
proc POS {} {list $::sz(px) $::sz(py) $::sz(pz)}
##+##########################################################################
#
# NewMaze
#
# Creates a new maze of a given size.
#
proc NewMaze {{redo 1}} {
set w [winfo width .c] ; set h [winfo height .c]
.c config -scrollregion [list 0 0 $w $h]
.c delete all
.c create text [expr $w/2] [expr $h/2] -anchor c -font bold -tag INFO
INFO "Thinking"
set w [expr {($w - 2.0*$::sz(lm)) / $::sz(x)}]
set h [expr {($h - 2.0*$::sz(tm)) / $::sz(y)}]
set x [expr {$w < $h ? $w : $h}]
set ::sz(box) [expr {$x > 100 ? 100 : $x < 5 ? 5 : $x}]
set ::sz(solve) 0
AnimateCmd 0
FillMaze
ShowMaze
set ::sz(best) [llength [GetSolution]]
set ::sz(moving) 0
}
##+##########################################################################
#
# Restart
#
# Puts man back at the starting door
#
proc Restart {} {
foreach {::sz(px) ::sz(py) ::sz(pz)} $::sz(start) break
for {set x 0} {$x < $::sz(x)} {incr x} { ;# Clear all marks
for {set y 0} {$y < $::sz(y)} {incr y} {
for {set z 0} {$z < $::sz(z)} {incr z} {
UNORMAZE $x $y $z $::MARK(ANY) ;# Remove all marks
UNORMAZE $x $y $z $::MARK(VISITED) ;# Haven't seen cell yet
}
}
}
eval UNORMAZE $::sz(end2) $::MARK(VICTORY)
AnimateCmd 0
GetSolution ;# Make sure solution is correct
ShowLevel 0
set ::sz(cnt) 0
}
proc DoOpaque {} {
for {set x 0} {$x < $::sz(x)} {incr x} { ;# Clear all marks
for {set y 0} {$y < $::sz(y)} {incr y} {
for {set z 0} {$z < $::sz(z)} {incr z} {
catch {
if {$::sz(opaque)} {
UNORMAZE $x $y $z $::MARK(VISIBLE)
} else {
ORMAZE $x $y $z $::MARK(VISIBLE)
}
}
}
}
}
ShowLevel $::sz(lvl)
}
##+##########################################################################
#
# InitMaze
#
# Set up emptry with only outer walls matrix
#
proc InitMaze {} {
global maze sz
catch {unset maze}
for {set x 0} {$x < $sz(x)} {incr x} { ;# Set all cells to 0
for {set y 0} {$y < $sz(y)} {incr y} {
for {set z 0} {$z < $sz(z)} {incr z} {
set maze($x,$y,$z) 0
if {! $sz(opaque)} { ORMAZE $x $y $z $::MARK(VISIBLE)}
}
}
}
for {set z 0} {$z < $sz(z)} {incr z} { ;# North, south walls
for {set x 0} {$x < $sz(x)} {incr x} {
ORMAZE $x 0 $z $::WALL(NORTH)
ORMAZE $x [expr {$sz(y) - 1}] $z $::WALL(SOUTH)
}
}
for {set z 0} {$z < $sz(z)} {incr z} { ;# East, west walls
for {set y 0} {$y < $sz(y)} {incr y} {
ORMAZE 0 $y $z $::WALL(WEST)
ORMAZE [expr {$sz(x) - 1}] $y $z $::WALL(EAST)
}
}
for {set x 0} {$x < $sz(x)} {incr x} { ;# Up, down walls
for {set y 0} {$y < $sz(y)} {incr y} {
ORMAZE $x $y 0 $::WALL(UP)
ORMAZE $x $y [expr {$sz(z) - 1}] $::WALL(DOWN)
}
}
}
##+##########################################################################
#
# FillMaze
#
# Does the actual maze creation by randomly walking around the maze.
#
proc FillMaze {} {
global sz maze
InitMaze
set ::mstack {}
eval PushPos [PickEntrance]
eval MARKVISITED [POS]
set cnt [expr {$sz(x) * $sz(y) * $sz(z)}]
while {1} {
foreach {px py pz} [PopPos] break
if {$px == -1} break ;# We're done
set newDir [PickDir $px $py $pz] ;# Get a new direction
if {$newDir == -1} continue ;# Can't move, try new position
set whence [OPPOSITE $newDir]
PushPos $px $py $pz
ORMAZE $px $py $pz [DOORDIR $newDir] ;# Add door in the new direction
# Cell we move into
foreach {px py pz} [MOVETO $px $py $pz $newDir] break
# It too has a door
PushPos $px $py $pz
ORMAZE $px $py $pz [DOORDIR $whence]
# Stuff solution info into high bits
ADDHINT $px $py $pz $whence
if {([incr cnt -1] % 100) == 0} { INFO "Thinking $cnt" }
}
INFO "drawing"
# Now open the outer wall up for our entrance and exit
eval UNORMAZE $sz(start) $::WALL(WEST)
eval UNORMAZE $sz(end) $::WALL(EAST)
eval ORMAZE $sz(end) $::DOOR(EAST)
set sz(solution) {}
}
##+##########################################################################
#
# PickEntrance
#
# Pick where the entrance and exit should be.
#
proc PickEntrance {} {
set x1 0 ;# Left wall
set y1 [expr {int(rand() * $::sz(y))}]
set z1 0
set x2 [expr {$::sz(x) - 1}] ;# Right wall
set y2 [expr {int(rand() * $::sz(y))}]
set z2 [expr {int(rand() * $::sz(z))}]
set z2 [expr {$::sz(z) - 1}]
set ::sz(lvl) $z1
set ::sz(start) [list $x1 $y1 $z1]
set ::sz(end) [list $x2 $y2 $z2]
set ::sz(end2) [list $::sz(x) $y2 $z2]
foreach {::sz(px) ::sz(py) ::sz(pz)} [list $x1 $y1 $z1] break
set ::maze($::sz(x),$y2,$z2) [DOORDIR $::DIR(WEST)] ;# MoveMan needs this
set ::sz(cnt) 0
return [list $x2 $y2 $z2]
}
##+##########################################################################
#
# PickDir
#
# Picks a random legal direction to move from (px,py,pz), -1 if no move.
#
proc PickDir {px py pz} {
set dirs {}
foreach dir {0 1 2 3 4 5} {
eval lappend dirs [OKDir? $px $py $pz $dir]
}
regsub -all {([0134] )} $dirs {\1\1\1\1} dirs ;# Make up/down less likely
set len [llength $dirs]
if {$len == 0} {return -1}
return [lindex $dirs [expr {int(rand() * $len)}]]
}
##+##########################################################################
#
# OKDir?
#
# Sees if it's legal to move in direction dir. If that cell is
# already visited then we put up a wall.
#
proc OKDir? {px py pz dir} {
if {$::maze($px,$py,$pz) & [WALLDOORDIR $dir]} {return ""}
foreach {px2 py2 pz2} [MOVETO $px $py $pz $dir] break
if {$::maze($px2,$py2,$pz2) & $::DOOR(ANY)} { ;# Destination visited???
ORMAZE $px $py $pz [WALLDIR $dir] ;# Yes, put up a wall
ORMAZE $px2 $py2 $pz2 [WALLDIR [OPPOSITE $dir]]
return ""
}
return $dir
}
##+##########################################################################
#
# DoDisplay
#
# Initializes our display
#
proc DoDisplay {} {
wm title . "3D Maze"
pack [frame .bottom] -side bottom -fill x
pack [frame .bottom.right] -side right -fill y
pack [frame .bottom.mid] -side right -fill y -expand 1
canvas .c -relief raised -bd 2 -wid $::sz(w) -height $::sz(h) -highlightth 0
scrollbar .sb -command ScrollBarCmd
scale .x -orient h -var sz(x) -fr 2 -to 100 -label "Maze Width" -relie ridge
scale .y -orient h -var sz(y) -fr 2 -to 100 -label "Maze Height" -reli ridge
scale .z -orient h -var sz(z) -fr 1 -to 5 -label "Maze Depth" -relie ridge
button .new -text "New Maze" -command NewMaze -width 11
button .restart -text "Restart" -command Restart
checkbutton .anim -text "Animate Solution" -command {AnimateCmd -1} \
-variable sz(animate) -relief raised -anchor w
checkbutton .solve -text "Show Solution" -command {ShowSolution -1} \
-variable sz(solve) -relief raised -anchor w
checkbutton .opaque -text "Opaque Maze" -command DoOpaque \
-variable sz(opaque) -relief raised -anchor w
button .helper -text Help -command Help
pack .sb -side right -fill y
pack .c -side left -fill both -expand 1
pack .x .y .z -side left -in .bottom -fill y
pack .new .restart .helper -side top -in .bottom.mid -expand 1 -fill x
pack .solve .anim .opaque -side top -in .bottom.right \
-fill both -padx 1m -exp 1
bind .c <MouseWheel> {ScrollBarCmd scroll [expr {-%D/abs(%D)}] page}
bind .c <Key-Up> [list MoveMan $::DIR(NORTH) 0]
bind .c <Shift-Key-Up> [list MoveMan $::DIR(NORTH) 1]
bind .c <Key-Down> [list MoveMan $::DIR(SOUTH) 0]
bind .c <Shift-Key-Down> [list MoveMan $::DIR(SOUTH) 1]
bind .c <Key-Left> [list MoveMan $::DIR(WEST) 0]
bind .c <Shift-Key-Left> [list MoveMan $::DIR(WEST) 1]
bind .c <Key-Right> [list MoveMan $::DIR(EAST) 0]
bind .c <Shift-Key-Right> [list MoveMan $::DIR(EAST) 1]
bind .c <Key-Prior> [list MoveMan $::DIR(UP) 0]
bind .c <Shift-Key-Prior> [list MoveMan $::DIR(UP) 1]
bind .c <Key-Home> [list MoveMan $::DIR(UP) 0]
bind .c <Shift-Key-Home> [list MoveMan $::DIR(UP) 1]
bind .c <Key-Next> [list MoveMan $::DIR(DOWN) 0]
bind .c <Shift-Key-Next> [list MoveMan $::DIR(DOWN) 1]
bind .c <Key-End> [list MoveMan $::DIR(DOWN) 0]
bind .c <Shift-Key-End> [list MoveMan $::DIR(DOWN) 1]
bind .c <Key-n> [list NewMaze]
bind .c <Key-space> [list ShowMark 1]
bind .c <Key-Insert> [list ShowMark 1]
#bind .c <Button-1> [list Move2Mouse %x %y]
bind .c <Button-1> [list MouseDown %x %y]
bind .c <B1-Motion> [list MouseMove %x %y]
bind .c <ButtonRelease-1> [list MouseUp]
bind .c <Shift-Button-1> [list ShowMark 1]
bind .c <Button-3> {expr {[MoveMan $::DIR(DOWN) 0] ||
[MoveMan $::DIR(UP) 0]}}
bind .c <Shift-Button-3> [list MoveMan $::DIR(UP) 0]
#bind .c <Double-Button-1> [list Move2Mouse %x %y]
bind Canvas <Button-2> [bind Text <Button-2>]
bind Canvas <B2-Motion> [bind Text <B2-Motion>]
bind .c <Alt-c> [list console show]
focus .c
update
}
##+##########################################################################
#
# ShowMaze
#
# Shows level 0 of the current maze
#
proc ShowMaze {} {
.c delete all
set x [expr {$::sz(lm) + ($::sz(x) * $::sz(box) / 2)}]
set ::sz(title) "Maze: $::sz(x)x$::sz(y)x$::sz(z)"
.c create text $x 10 -anchor n -font bold -tag title
ShowLevel $::sz(lvl)
}
##+##########################################################################
#
# ShowLevel
#
# Draws this level of the maze
#
proc ShowLevel {z} {
set ::sz(lvl) $z
.c itemconfig title -text "$::sz(title) Level [expr {$::sz(z) - $z}]"
set low [expr {1.0 * $::sz(lvl) / $::sz(z)}]
set high [expr {(1.0 + $::sz(lvl)) / $::sz(z)}]
.sb set $low $high
.c delete maze solve man mark box
for {set x 0} {$x < $::sz(x)} {incr x} {
for {set y 0} {$y < $::sz(y)} {incr y} {
ShowCell $x $y $::sz(lvl)
;#update
}
}
ShowSolution $z
ShowMan 0
}
##+##########################################################################
#
# ShowCell
#
# Shows walls for this cell
#
proc ShowCell {x y z} {
if {! [info exists ::maze($x,$y,$z)]} return
set m $::maze($x,$y,$z)
set w $::sz(lw)
if {! [ISVISIBLE $x $y $z]} return
foreach {- - x0 y0 x1 y1 x2 y2 x3 y3} [CellXY $x $y] break
set tag [list box,$x,$y,$z box]
.c delete box,$x,$y,$z
if {$m & $::MARK(VISITED) || (($m & $::MARK(V_ANY)) && $::sz(opaque))} {
.c create rect $x0 $y0 $x2 $y2 -tag $tag -fill lightyellow -outline {}
.c lower box
}
if {$m & $::WALL(NORTH)} {.c create line $x0 $y0 $x1 $y1 -wid $w -tag maze}
if {$m & $::WALL(EAST)} {.c create line $x1 $y1 $x2 $y2 -wid $w -tag maze}
if {$m & $::WALL(SOUTH)} {.c create line $x2 $y2 $x3 $y3 -wid $w -tag maze}
if {$m & $::WALL(WEST)} {.c create line $x3 $y3 $x0 $y0 -wid $w -tag maze}
if {$m & $::DOOR(UP)} {ShowStairs $x $y 1}
if {$m & $::DOOR(DOWN)} {ShowStairs $x $y 0}
if {$m & $::MARK(ANY)} {ShowMark 0 $x $y $z}
}
##+##########################################################################
#
# ShowSolution
#
# Uses the HINT data in each cell to get the solution and displays it
# for level lvl. LVL = -1 then we get a new solution and show for
# level sz(lvl)
#
proc ShowSolution {lvl} {
.c delete solve
if {! $::sz(solve)} return
if {$lvl == -1} {GetSolution ; set lvl $::sz(lvl)}
if {[llength $::sz(solution)] == 0} GetSolution
if {[llength $::sz(solution)] == 0} return
set xy {}
foreach pos $::sz(solution) {
foreach {px py pz} $pos break
if {$pz == $lvl} {
foreach {cx cy} [CellXY $px $py] break
lappend xy $cx $cy
} else {
if {[llength $xy] == 2} {
set xy [MakeBox $xy]
.c create oval $xy -tag solve -fill cyan -outline cyan
} elseif {[llength $xy] > 0} {
.c create line $xy -tag solve -fill cyan -width 5 -arrow last
}
set xy {}
}
}
if {$pz == $lvl} {
foreach {cx cy x0 y0 x1 y1 x2 y2 x3 y3} [CellXY $px $py] break
lappend xy $x1 $cy ;# Exit door
.c create line $xy -tag solve -fill cyan -width 5 -arrow last
}
.c raise man
.c raise mark
}
##+##########################################################################
#
# GetSolution
#
# Returns a list of cells that is the path to the exit.
#
proc GetSolution {} {
set ::sz(solution) {}
if {$::sz(px) == $::sz(x)} {return {}} ;# We're at the exit
foreach {px py pz} [POS] break
while {1} {
lappend xy [list $px $py $pz]
set dir [GETHINT $px $py $pz]
if {$dir == -1} break
foreach {px py pz} [MOVETO $px $py $pz $dir] break
}
set ::sz(solution) $xy
}
##+##########################################################################
#
# CellXY
#
# Returns the coordinates of cell at (px,py) starting nw and going clockwise.
#
proc CellXY {px py} {
set cx [expr {$::sz(lm) + ($px+.5) * $::sz(box)}]
set cy [expr {$::sz(tm) + ($py+.5) * $::sz(box)}]
set x0 [expr {$::sz(lm) + $px * $::sz(box)}]
set y0 [expr {$::sz(tm) + $py * $::sz(box)}]
set x2 [expr {$x0 + $::sz(box)}]
set y2 [expr {$y0 + $::sz(box)}]
return [list $cx $cy $x0 $y0 $x2 $y0 $x2 $y2 $x0 $y2]
}
##+##########################################################################
#
# MakeBox
#
# Returns top left, bottom right of 60% of the cells dimension.
#
proc MakeBox {xy {y -1}} {
if {$y != -1} { set xy [CellXY $xy $y] } ;# Convert maze to canvas units
foreach {x y} $xy break
set amt [expr {(.6 * $::sz(box)) / 2}]
return [list [expr {$x - $amt}] [expr {$y - $amt}] \
[expr {$x + $amt}] [expr {$y + $amt}]]
}
##+##########################################################################
#
# PushPos
#
# Pushes a position onto stack stack
#
proc PushPos {x y z} {
lappend ::mstack [list $x $y $z]
return ""
}
##+##########################################################################
#
# PopPos
#
# Pops top position off the stack. If we always take the top, then the
# maze will have one main corridor from the initial random walk. So we
# occassionally pick a position at random.
#
proc PopPos {} {
set len [llength $::mstack]
if {$len == 0} { return [list -1 -1 -1]}
set where end
if {rand() > .8} { set where [expr {int(rand() * $len)}] }
set pos [lindex $::mstack $where]
set ::mstack [lreplace $::mstack $where $where]
return $pos
}
##+##########################################################################
#
# ShowStairs
#
# Shows stairs going up or down. Pretty poor right now, just an arrow.
#
proc ShowStairs {px py updown} {
foreach {cx cy x0 y0 x1 y1 x2 y2 x3 y3} [CellXY $px $py] break
if {$updown} {
set x [expr {($cx + $x0) / 2}]
set y0 [expr {$y0 + 2}]
.c create line $x $y0 $x $y3 -tag {up maze} -arrow first -width 2 \
-fill magenta
} else {
set x [expr {($cx + $x1) / 2}]
set y3 [expr {$y3 - 2}]
.c create line $x $y0 $x $y3 -tag {down maze} -arrow last -width 2 \
-fill purple
}
}
##+##########################################################################
#
# ScrollBarCmd
#
# Called by scrollbar and mousewheel for changing levels.
#
proc ScrollBarCmd {verb amt args} {
set lvl $::sz(lvl)
if {$verb == "moveto"} {
set lvl [expr {round($amt * $::sz(z))}]
} elseif {$verb == "scroll"} {
if {($amt < 0 && $lvl > 0) || ($amt > 0 && $lvl+1 < $::sz(z))} {
incr lvl $amt
}
}
if {$::sz(lvl) != $lvl} {
ShowLevel $lvl
}
}
##+##########################################################################
#
# MoveMan
#
# Moves the man symbol in the given direction if possible.
#
proc MoveMan {dir all} {
global sz
set moves 0
if {$sz(animate)} {return 0}
while {1} {
if {! [CANMOVE $sz(px) $sz(py) $sz(pz) $dir]} break
foreach {sz(px) sz(py) sz(pz)} [MOVETO $sz(px) $sz(py) $sz(pz) $dir] \
break
incr moves
ShowMan 1
incr sz(cnt)
if {! $all} break
}
if {$sz(px) >= $sz(x)} { ;# Check for victory
if {! [ISMARKED $sz(px) $sz(py) $sz(pz) $::MARK(VICTORY)]} {
ORMAZE $sz(px) $sz(py) $sz(pz) $::MARK(VICTORY)
set txt "You did it\n\n"
append txt "Total moves: $sz(cnt)\n"
append txt "Best possible: $sz(best)"
tk_messageBox -message $txt
}
}
return $moves
}
##+##########################################################################
#
# ShowMark
#
# Shows the mark for a cell. If toggle, then rotates between various marks
#
proc ShowMark {toggle {x -1} {y -1} {z -1}} {
global sz
if {$x == -1} { foreach {x y z} [POS] break }
if {$toggle} {
if {[ISMARKED $x $y $z $::MARK(X)]} {
UNMARK $x $y $z $::MARK(X)
DOMARK $x $y $z $::MARK(?)
} elseif {[ISMARKED $x $y $z $::MARK(?)]} {
UNMARK $x $y $z $::MARK(?)
} else {
DOMARK $x $y $z $::MARK(X)
}
}
set tag "mark,$x,$y"
.c delete $tag
if {$x == $sz(x)} { UNMARK $x $y $z $::MARK(ANY) ; return } ;# Victory spot
foreach {x0 y0 x2 y2} [MakeBox $x $y] break
if {[ISMARKED $x $y $z $::MARK(X)]} {
.c create line $x0 $y0 $x2 $y2 -fill red -tag [list mark $tag] -width 3
.c create line $x2 $y0 $x0 $y2 -fill red -tag [list mark $tag] -width 3
} elseif {[ISMARKED $x $y $z $::MARK(?)]} {
set w [expr {$x2 - $x0}]
set h [expr {$y2 - $y0}]
foreach {a b c} {.75 .25 .125} break
lappend xy $x0 [expr {$y0 + $a * $h}] [expr {$x0 + $b * $w}] $y2
lappend xy $x2 [expr {$y0 + $c * $h}]
.c create line $xy -tag [list mark $tag] -fill red -width 3
}
.c raise man
}
##+##########################################################################
#
# ShowMan
#
# Displays the polygon for the man. If force, then we change levels if need be.
#
proc ShowMan {force} {
global sz
foreach {x y z} [POS] break
if {$force && $sz(lvl) != $z} { ShowLevel $z }
if {$sz(lvl) != $z} return
#if {! [ISVISIBLE $x $y $z]} {
# MARKVISITED $x $y $z
# ShowCell $x $y $z
#}
MARKVISITED $x $y $z
ShowCell $x $y $z
.c delete man
if {$sz(box) < 15} {
.c create rect [MakeBox $x $y] -tag man \
-fill dodgerblue -outline dodgerblue
return
}
set man {9 -66 -24 -67 -33 -54 -41 -43 -41 -34 -37 -29 -29 -29 -17 -50
-13 -51 -4 -52 0 -51 2 -50 -1 -45 -24 -5 -23 29 -28 30 -38 31
-46 31 -57 30 -63 31 -64 39 -63 44 -56 45 -49 46 -39 46 -25
47 -9 47 -5 38 -7 24 -4 17 3 20 12 24 17 28 19 38 17 63 23 68
28 68 34 66 35 65 37 60 38 46 37 25 37 19 9 0 8 -6 14 -14 21
-23 23 -24 26 -17 25 -24 25 -15 26 -13 63 -12 65 -14 65 -18
65 -21 60 -26 38 -27 36 -30 34 -51 33 -54 38 -55 45 -59 48
-65 48 -71 48 -75 44 -82 39 -85 33 -87 28 -87 20 -84 19 -83
16 -79 15 -74 13 -70 13 -65}
foreach {cx cy} [CellXY $x $y] break
set sc [expr {$sz(box) * .8 / 160.0}]
foreach {x y} $man {
lappend xy [expr {$cx + $x * $sc}] [expr {$cy + $y * $sc}]
}
.c create poly $xy -tag man -fill dodgerblue
}
##+##########################################################################
#
# AnimateCmd
#
# Turns on and off and start animation.
#
proc AnimateCmd {how} {
if {$how != -1} {set ::sz(animate) $how}
catch {after cancel $::sz(after)} ;# Stop any animation
if {$::sz(animate)} {
set xy [GetSolution]
AnimateSolution [lappend xy $::sz(end2)]
}
}
##+##########################################################################
#
# AnimateSolution
#
# Does the animation of the solution.
#
proc AnimateSolution {{sol -1}} {
if {[llength $sol] == 0} { AnimateCmd 0 ; return}
foreach {::sz(px) ::sz(py) ::sz(pz)} [lindex $sol 0] break
ShowMan 1
update
set ::sz(after) [after 250 AnimateSolution [list [lrange $sol 1 end]]]
}
##+##########################################################################
#
# Move2Mouse
#
# Moves the man to the mouse point. If we're on a stairs then we go up/down.
#
proc Move2Mouse {X Y} {
global sz
if {$sz(moving)} return
set px [expr {int(floor(([.c canvasx $X] - $sz(lm)) / $sz(box)))}]
set py [expr {int(floor(([.c canvasy $Y] - $sz(tm)) / $sz(box)))}]
if {$sz(lvl) != $sz(pz)} return
if {$px < 0 || $py < 0 || $px > $sz(x) || $py >= $sz(y)} return
if {$px == $sz(x) && [list $px $py $sz(pz)] != $sz(end2)} return
if {! [ISVISIBLE $px $py $sz(pz)]} return
# If we're on stairs then go up or down
#if {$px == $sz(px) && $py == $sz(py)} {
# expr {[MoveMan $::DIR(DOWN) 0] || [MoveMan $::DIR(UP) 0]}
# return
#}
set dirs [CanReach $px $py $sz(pz)]
if {[lsearch $dirs $::DIR(UP)] != -1 || \
[lsearch $dirs $::DIR(DOWN)] != -1} return
set sz(moving) 1
foreach dir $dirs {
if {$dir == -1} continue
MoveMan $dir 0
update
after 250
}
set sz(moving) 0
}
##+##########################################################################
#
# MouseDown MouseMove
#
# These routines handle dragging the man via the mouse
#
proc MouseDown {X Y} {
global sz
set sz(mousing) 0
set px [expr {int(floor(([.c canvasx $X] - $sz(lm)) / $sz(box)))}]
set py [expr {int(floor(([.c canvasy $Y] - $sz(tm)) / $sz(box)))}]
if {$px != $sz(px) || $py != $sz(py) || $sz(lvl) != $sz(pz)} {
Move2Mouse $X $Y
return
}
set sz(mousing) 1
.c itemconfig man -outline black
}
proc MouseUp {} {
.c itemconfig man -outline {}
}
proc MouseMove {X Y} {
global sz
if {! $sz(mousing)} return
set px [expr {int(floor(([.c canvasx $X] - $sz(lm)) / $sz(box)))}]
set py [expr {int(floor(([.c canvasy $Y] - $sz(tm)) / $sz(box)))}]
set pz $::sz(lvl)
set dir [eval UNMOVE [POS] $px $py $pz]
if {$dir == -1} return
MoveMan $dir 0
.c itemconfig man -outline black
}
##+##########################################################################
#
# CanReach
#
# Finds a path from current location to x1,y1,z1. Works by getting
# solution from each position, finding where they meet then joining
# the two paths to the junction point.
#
proc CanReach {x1 y1 z1} {
global sz
set pos0 [POS] ;# Remember where we are
foreach {sz(px) sz(py) sz(pz)} [list $x1 $y1 $z1] break
set s1 [GetSolution] ;# Get solution from there
foreach {sz(px) sz(py) sz(pz)} $pos0 break ;# Go back to where we were
set s0 [GetSolution] ;# Get solution from here
for {set i 0} {$i <= [llength $s0]} {incr i} {
if {[lindex $s0 "end-$i"] != [lindex $s1 "end-$i"]} break
}
# Convert list of positions into a list of directions
set path [lrange $s0 1 "end-$i"]
set path2 [ReverseList [lrange $s1 0 "end-[incr i -1]"]]
set dpath {}
foreach pos1 [concat $path $path2 [list [list $x1 $y1 $z1]]] {
lappend dpath [eval UNMOVE $pos0 $pos1]
set pos0 $pos1
}
return $dpath
}
##+##########################################################################
#
# ReverseList
#
# Reverses a list
#
proc ReverseList {l} {
set len [llength $l]
set xy {}
for {set i 0} {$i < $len} {incr i} {
lappend xy [lindex $l "end-$i"]
}
return $xy
}
##+##########################################################################
#
# Help
#
# Give very simple help.
#
proc Help {} {
catch {destroy .help}
toplevel .help
wm transient .help .
wm title .help "3D Maze Help"
if {[regexp {(\+[0-9]+)(\+[0-9]+)$} [wm geom .] => wx wy]} {
wm geom .help "+[expr {$wx+35}]+[expr {$wy+35}]"
}
set w .help.t
text $w -wrap word -width 70 -height 30 -pady 10
button .help.quit -text Dismiss -command {catch {destroy .help}}
pack .help.quit -side bottom
pack $w -side top -fill both -expand 1
font create Help {*}[font actual [$w cget -font]]
font create HelpBold {*}[font actual HelpBold] -weight bold
set margin [font measure Help " o "]
set margin2 [font measure Help " o - "]
$w tag config header -justify center -font bold -foreground red
$w tag config header2 -justify center -font bold
$w tag config bullet -lmargin2 $margin -font HelpBold
$w tag config n -lmargin1 $margin -lmargin2 $margin2
$w insert end "3D Maze" header "\nby Keith Vetter\n\n" header2
$w insert end " o To View Maze\n" bullet
$w insert end "- Use scroll bar or mouse wheel to change " n
$w insert end "which level is displayed.\n" n
$w insert end "- If the maze is larger than the display, pan with " n
$w insert end "the middle button.\n\n" n
$w insert end " o To Move the Man\n" bullet
$w insert end "- Mouse: click on the man and drag him or " n
$w insert end "just click where you want to go.\n" n
$w insert end "- Keyboard: use the arrow keys. Holding the shift key " n
$w insert end "while doing so will move the man as far as possible.\n\n" n
$w insert end " o To Move the Man Up or Down Levels\n" bullet
$w insert end "- Mouse: Right click (shift right-click forces up).\n" n
$w insert end "- Keyboard: press the page up or page down key.\n\n" n
$w insert end " o To Set or Clear Marks\n" bullet
$w insert end "- Mouse: click while holding the shift key.\n" n
$w insert end "- Keyboard: press the space bar.\n\n" n
$w insert end " o To See the Solution\n" bullet
$w insert end "- Turning on 'Show Solution' or 'Animate Solution' " n
$w insert end "will show you the solution from the current " n
$w insert end "location.\n\n" n
$w insert end " o Hints on Solving a Maze\n" bullet
$w insert end "- Place X marks on stairs that lead to dead ends.\n" n
$w insert end "- Place check marks on the stairs you entered a " n
$w insert end "new level on so you know how to backtrack." n
$w config -state disabled
font delete Help
font delete HelpBold
}
##+##########################################################################
#
# what
#
# Debugging routine which displays a cells data.
#
proc what {args} {
global maze WALL DOOR MARK DIR
if {[llength $args] == 0} {set args [POS]}
foreach {x y z} $args break
set value $maze($x,$y,$z)
puts "POS: $x $y $z => [format 0x%04X $value]"
foreach arr [list WALL DOOR MARK] {
puts -nonewline "$arr: "
foreach {name bit} [array get $arr] {
if {$name == "ANY"} continue
if {$name == "V_ANY"} continue
if {$value & $bit} {
puts -nonewline [format %-8s [string tolower $name]]
}
}
puts ""
}
puts "HINT: [string tolower $DIR([GETHINT $x $y $z])]"
}
Init
DoDisplay
NewMazesee also Tcl/Tk games