Version 5 of 3D Maze

Updated 2002-09-27 17:54:13

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.


MPJ: (9/27/02) This new version seem to generate unsolveable mazes???


 ##+##########################################################################
 #
 # 3D Maze.tcl
 #
 # 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.
 #
 # 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

 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

    # 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,x 0 0,y -1 0,z 0    1,x  1 1,y 0 1,z 0   2,x 0 2,y 0 2,z -1
        3,x 0 3,y  1 3,z 0    4,x -1 4,y 0 4,z 0   5,x 0 5,y 0 5,z  1
    }
    array set MARK {X 0x4000 ? 0x8000 ANY 0xC000 VICTORY 0x400}
 }

 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) << 16}]}
 proc GETHINT {x y z}   {return [expr {($::maze($x,$y,$z) >> 16) - 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 DOMARK {x y z who} {ORMAZE $x $y $z $who}
 proc UNMARK {x y z who} {set ::maze($x,$y,$z) [expr {$::maze($x,$y,$z)&~$who}]}
 proc UNMARK {x y z who} {UNORMAZE $x $y $z $who}
 proc MOVETO {x y z d}  {list [incr x $::MOTION($d,x)] \
                             [incr y $::MOTION($d,y)] [incr z $::MOTION($d,z)]}
 ##+##########################################################################
 #
 # 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]]
 }
 ##+##########################################################################
 # 
 # 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)
            }
        }
    }
    eval UNORMAZE $::sz(end2) $::MARK(VICTORY)

    AnimateCmd 0
    GetSolution                                 ;# Make sure solution is correct
    ShowLevel 0
    set ::sz(cnt) 0

 }
 ##+##########################################################################
 #
 # 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
            }
        }
    }
    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]
    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
    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
    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
    pack .new .restart -side top -in .bottom.mid -expand 1 -fill x
    pack .solve .anim .helper -side top -in .bottom.right -fill x -padx 1m

    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>           NewMaze
    bind .c <Key-space>       [list ShowMark 1]
    bind .c <Key-Insert>      [list ShowMark 1]
    bind .c <Button-1>        [list MouseDown %x %y]
    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 Canvas <Button-2> [bind Text <Button-2>]
    bind Canvas <B2-Motion> [bind Text <B2-Motion>]
    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
    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} {
    set m $::maze($x,$y,$z)
    set w $::sz(lw)

    foreach {- - x0 y0 x1 y1 x2 y2 x3 y3} [CellXY $x $y] break

    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} [list $::sz(px) $::sz(py) $::sz(pz)] 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 $moves}
    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)]} {
            set txt "You did it\n\n"
            append txt "Total moves: $sz(cnt)\n"
            append txt "Best possible: $sz(best)"
            tk_messageBox -message $txt
            ORMAZE $sz(px) $sz(py) $sz(pz) $::MARK(VICTORY)
        }
    }
    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} [list $sz(px) $sz(py) $sz(pz)] 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} [list $sz(px) $sz(py) $sz(pz)] break
    if {$force && $sz(lvl) != $z} { ShowLevel $z }
    if {$sz(lvl) != $z} return

    .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 500 AnimateSolution [list [lrange $sol 1 end]]]
 }
 ##+##########################################################################
 # 
 # MouseDown
 # 
 # Handles mouse down events. Moves the man to where the mouse is if there is
 # a legal path.
 # 
 proc MouseDown {X Y} {
    global sz
    set px [expr {floor(([.c canvasx $X] - $sz(lm)) / $sz(box))}]
    set py [expr {floor(([.c canvasy $Y] - $sz(tm)) / $sz(box))}]
    if {$px < 0 || $py < 0 || $px > $sz(x) || $py >= $sz(y)} return

    set n [catch {CanReach "" -1 $sz(px) $sz(py) $sz(pz) $px $py $sz(pz)} path]
    if {$n} return

    foreach dir $path {
        MoveMan $dir 0
        update
        after 250
    }
 }
 ##+##########################################################################
 # 
 # CanReach
 # 
 # Does a depth first search trying to get from x0,y0,z0 to x1,y1,z1
 # 
 proc CanReach {path whence x0 y0 z0 x1 y1 z1} {
    if {$z0 != $z1} {return ""}
    if {$x0 == $x1 && $y0 == $y1} { return $path }

    set whence [OPPOSITE $whence]
    foreach d [list NORTH SOUTH EAST WEST] {
        set dir $::DIR($d)
        if {$dir == $whence} continue           ;# Don't backtrack
        if {! [CANMOVE $x0 $y0 $z0 $dir]} continue

        foreach {x y z} [MOVETO $x0 $y0 $z0 $dir] break
        set p2 [CanReach "$path$dir " $dir $x $y $z $x1 $y1 $z1]
        if {$p2 != ""} { return $p2 }
    }
    return ""
 }
 ##+##########################################################################
 # 
 # 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}]"
    }
    text .help.t -wrap word -width 70 -height 25 -pady 10
    button .help.quit -text Dismiss -command {catch {destroy .help}}
    pack .help.quit -side bottom
    pack .help.t -side top -fill both -expand 1

    .help.t tag config header -justify center -font bold -foreground red
    .help.t tag config header2  -justify center -font bold
    set margin [font measure [.help.t cget -font] " o "]
    set margin2 [font measure [.help.t cget -font] " o - "]
    .help.t tag config bullet -lmargin2 $margin -fon "[.help.t cget -font] bold"
    .help.t tag config n -lmargin1 $margin -lmargin2 $margin2

    .help.t insert end "3D Maze" header "\nby Keith Vetter\n\n" header2 
    .help.t insert end " o To View Maze\n" bullet
    .help.t insert end "- Use scroll bar or mouse wheel to change " n
    .help.t insert end "which level is displayed.\n" n
    .help.t insert end "- If the maze is larger than the display, pan with " n
    .help.t insert end "the middle button.\n\n" n
    .help.t insert end " o To Move the Man\n" bullet
    .help.t insert end "- Mouse: click where you want the man to go, " n
    .help.t insert end "right click to go up and down stairs.\n" n
    .help.t insert end "- Keyboard: use the arrow keys, page up and " n
    .help.t insert end "page down. Holding the shift key while pressing " n
    .help.t insert end "the key will move the " n
    .help.t insert end "man until it hits a wall.\n\n" n
    .help.t insert end " o To Set or Clear Marks\n" bullet
    .help.t insert end "- Mouse: click while holding the shift key.\n" n
    .help.t insert end "- Keyboard: press the space bar.\n\n" n
    .help.t insert end " o To See the Solution\n" bullet
    .help.t insert end "- Turning on 'Show Solution' or 'Animate Solution' " n
    .help.t insert end "will show you the solution from the current " n
    .help.t insert end "location.\n\n" n

    .help.t insert end " o Hints on Solving a Maze" bullet
    .help.t insert end "- Place X marks on stairs that lead to dead ends." n
    .help.t insert end "- Place check marks on the stairs you entered a " n
    .help.t insert end "new level on so you konw how to backtrack." n
    .help.t config -state disabled
 }
 ##+##########################################################################
 #
 # what
 #
 # Debugging routine which displays a cells data.
 #
 proc what {x y z} {
    global maze WALL DOOR MARK DIR

    set value $maze($x,$y,$z)
    foreach arr [list WALL DOOR MARK] {
        puts -nonewline "$arr: "
        foreach {name bit} [array get $arr] {
            if {$name == "ANY"} continue
            if {$value & $bit} {
                puts -nonewline [format %-6s [string tolower $name]]
            }
        }
        puts ""
    }
    puts "HINT: [string tolower $DIR([GETHINT $x $y $z])]"

 }

 Init
 DoDisplay
 NewMaze

see also Tcl/Tk games

Category Games