[Keith Vetter] : using the maze generating engine from [maze generator2], this little game displays 3D mazes. You can adjust the width, height and depth of the maze. You can also try solving the maze by moving around a man with the arrow keys. At any point, you can have the shortest route to the exit displayed. ---- [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 {ScrollBarCmd scroll [expr {-%D/abs(%D)}] page} bind .c [list MoveMan $::DIR(NORTH) 0] bind .c [list MoveMan $::DIR(NORTH) 1] bind .c [list MoveMan $::DIR(SOUTH) 0] bind .c [list MoveMan $::DIR(SOUTH) 1] bind .c [list MoveMan $::DIR(WEST) 0] bind .c [list MoveMan $::DIR(WEST) 1] bind .c [list MoveMan $::DIR(EAST) 0] bind .c [list MoveMan $::DIR(EAST) 1] bind .c [list MoveMan $::DIR(UP) 0] bind .c [list MoveMan $::DIR(UP) 1] bind .c [list MoveMan $::DIR(UP) 0] bind .c [list MoveMan $::DIR(UP) 1] bind .c [list MoveMan $::DIR(DOWN) 0] bind .c [list MoveMan $::DIR(DOWN) 1] bind .c [list MoveMan $::DIR(DOWN) 0] bind .c [list MoveMan $::DIR(DOWN) 1] bind .c [list NewMaze] bind .c [list ShowMark 1] bind .c [list ShowMark 1] #bind .c [list Move2Mouse %x %y] bind .c [list MouseDown %x %y] bind .c [list MouseMove %x %y] bind .c [list MouseUp] bind .c [list ShowMark 1] bind .c {expr {[MoveMan $::DIR(DOWN) 0] || [MoveMan $::DIR(UP) 0]}} bind .c [list MoveMan $::DIR(UP) 0] #bind .c [list Move2Mouse %x %y] bind Canvas [bind Text ] bind Canvas [bind Text ] bind .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 NewMaze ====== see also [Tcl/Tk games] <>Games