3D Maze
Description
Keith Vetter 2003-04-07: this whizzlet draws both the standard Hilbert Curve and a analogous one in 3-dimensions.
One clever aspect of this program is how it does hidden surface removal. The simple painters algorithm--drawing distant objects first so nearer objects paint over obscured surfaces (as used in Fractal Mountains)--doesn't work easily because the components of the curve can't be generated in a back-to-front ordering.
Instead, it uses tk's canvas stacking order. As each object gets generated it is tagged with its depth; then when everything is drawn, then canvas raise is used to place nearer objects before distant ones. This method won't work for complex objects but for the simple ones here it makes an effective hidden surface algorithm.
Changes
- PYK 2012-11-24: removed [update]
- APE 2022-04-11: replaced list assignation "[foreach] ... [break]" by [lassign]
Discussion
LV is there a relationship between this code and the sdarchive starkit that talks about the same thing?
In cases where wiki code is turned into starkits, perhaps the starkit's url could be added to the appropriate page, and, vice versa, the wikit page could be placed in the starkit's help information, so that someone with problems knows where to submit questions and comments?
Jeff Smith 2019-08-18 : Below is an online demo using CloudTk
Jeff Smith 2020-08-19 : This demo has been changed to run "3D Maze" in an Alpine Linux Docker Container. It is a 27.4MB image which is made up of Alpine Linux + tclkit + 3D-Maze.kit + + libx11 + libxft + fontconfig + ttf-linux-libertine. It is run under a user account in the Container. The Container is restrictive with permissions for "Other" removed for "execute" and "read" for certain directories.
Code
##+####################################################################
#
# 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(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} {set ::INFO $msg}
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} {lassign [split $::MOTION($d) , ] dx dy dz
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
trace add variable ::INFO write {
.c itemconfig INFO -text $::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
}
##+##########################################################################
#
# Restart
#
# Puts man back at the starting door
#
proc Restart {} {
lassign $::sz(start) ::sz(px) ::sz(py) ::sz(pz)
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 sz(walkcnt) [expr {$sz(x) * $sz(y) * $sz(z)}]
after idle WalkMaze
}
proc WalkMaze {} {
global sz
lassign [PopPos] px py pz
if {$px == -1} {
# We're done
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) {}
ShowMaze
set ::sz(best) [llength [GetSolution]]
return
}
set newDir [PickDir $px $py $pz] ;# Get a new direction
if {$newDir == -1} {
after idle WalkMaze ;# Can't move, try new position
return
}
set whence [OPPOSITE $newDir]
PushPos $px $py $pz
ORMAZE $px $py $pz [DOORDIR $newDir] ;# Add door in the new direction
# Cell we move into
lassign [MOVETO $px $py $pz $newDir] px py pz
# 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 sz(walkcnt) -1] % 100) == 0} { INFO "Thinking $sz(walkcnt)" }
after idle WalkMaze
}
##+##########################################################################
#
# 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]
lassign [list $x1 $y1 $z1] ::sz(px) ::sz(py) ::sz(pz)
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 ""}
lassign [MOVETO $px $py $pz $dir] px2 py2 pz2
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
}
##+##########################################################################
#
# 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)"
set test [.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
lassign [CellXY $x $y] - - x0 y0 x1 y1 x2 y2 x3 y3
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) {
lassign $pos px py pz
if {$pz == $lvl} {
lassign [CellXY $px $py] cx cy
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} {
lassign [CellXY $px $py] cx cy x0 y0 x1 y1 x2 y2 x3 y3
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
lassign [POS] px py pz
while {1} {
lappend xy [list $px $py $pz]
set dir [GETHINT $px $py $pz]
if {$dir == -1} break
lassign [MOVETO $px $py $pz $dir] px py pz
}
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
lassign $xy x y
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} {
lassign [CellXY $px $py] cx cy x0 y0 x1 y1 x2 y2 x3 y3
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
lassign [MOVETO $sz(px) $sz(py) $sz(pz) $dir] sz(px) sz(py) sz(pz)
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} { lassign [POS] x y z}
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
lassign [MakeBox $x $y] x0 y0 x2 y2
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}]
lassign {.75 .25 .125} a b c
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
lassign [POS] x y z
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}
lassign [CellXY $x $y] cx cy
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}
lassign [lindex $sol 0] ::sz(px) ::sz(py) ::sz(pz)
ShowMan 1
set ::sz(after) [after 250 AnimateSolution [list [lrange $sol 1 end]]]
}
proc Moving {dirs} {
global sz
while {[set dir [lindex $dirs[set dirs [lrange $dirs 1 end]] 0]] == -1} {}
if {$dir ne {}} {
MoveMan $dir 0
}
if {[llength $dirs]} {
after 250 Moving [list $dirs]
} else {
set sz(mousing) 0
}
}
##+##########################################################################
#
# 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
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
Moving $dirs
}
##+##########################################################################
#
# MouseDown MouseMove
#
# These routines handle dragging the man via the mouse
#
proc MouseDown {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)))}]
if {$px != $sz(px) || $py != $sz(py) || $sz(lvl) != $sz(pz)} {
set sz(mousing) 1
Move2Mouse $X $Y
return
}
.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
set $sz(mousing) 1
MoveMan $dir 0
set sz(mousing) 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
lassign [list $x1 $y1 $z1] sz(px) sz(py) sz(pz)
set s1 [GetSolution] ;# Get solution from there
lassign $pos0 sz(px) sz(py) sz(pz) ;# 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]}
lassign $args x y z
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
bind .c <Map> NewMazeuniquename 2013aug17
This expenditure of coding energy deserves a couple of images to give a visual picture of what this code creates.
The following Help window helps explain how to use the controls on this Tk GUI.
