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

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> NewMaze

uniquename 2013aug17

This expenditure of coding energy deserves a couple of images to give a visual picture of what this code creates.

vetter_3D-Maze_wiki4188_mazeANDcontrols_screenshot_582x502.jpg

The following Help window helps explain how to use the controls on this Tk GUI.

vetter_3D-Maze_wiki4188_Help_screenshot_497x524.jpg