uniquename 2013aug18This nice maze generator deserves to have an image to let all who stumble across this page know what the code below creates.
##+##########################################################################
#
# DoMaze.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.
#
# Revisions:
# KPV August 31, 1994 - initial revision
# KPV Sep 24, 2002 - ported to tk8+
#
package require Tk
set sz(x) 15 ;# Maze width
set sz(y) 15 ;# Maze height
set sz(z) 1 ;# Maze levels -- you can have 3-d mazes
##+##########################################################################
#
# Init
#
# Sets up some global variables.
#
proc Init {} {
global sz DIR WALL DOOR MOTION
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
# These directions also act as bit shift amounts
array set DIR {NORTH 0 EAST 1 UP 2 SOUTH 3 WEST 4 DOWN 5 }
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
}
}
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 BACKINFO {dir} {return [expr {($dir + 1) << 16}]}
proc BACKUNINFO {val} {return [expr {($val >> 16) - 1}]}
proc INFO {msg} {.c itemconfig INFO -text $msg ; update idletasks }
proc MOVETO {x y z dir} { list [incr x $::MOTION($dir,x)] \
[incr y $::MOTION($dir,y)] \
[incr z $::MOTION($dir,z)]
}
##+##########################################################################
#
# NewMaze
#
# Creates a new maze of a given size.
#
proc NewMaze {{x -1} {y -1} {z 1}} {
if {$x != -1} { set ::sz(x) $x ; set ::sz(y) $y ; set ::sz(z) $z }
set w [winfo width .c] ; set h [winfo height .c]
.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}]
FillMaze
ShowMaze
}
##+##########################################################################
#
# InitMaze
#
# Set up matrix and pick start and ending points
#
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
OrMaze $px $py $pz [BACKINFO $whence]
if {([incr cnt -1] % 100) == 0} { INFO "Thinking $cnt" }
}
INFO "drawing"
# Now open the outer wall up for our entrance and exit
set maze($sz(start)) [expr {$maze($sz(start)) & ~$::WALL(WEST)}]
set maze($sz(end)) [expr {$maze($sz(end)) & ~$::WALL(EAST)}]
}
##+##########################################################################
#
# PickEntrance
#
# Pick where the entrance and exit should be.
#
proc PickEntrance {} {
set y1 [expr {int(rand() * $::sz(y))}]
set y2 [expr {int(rand() * $::sz(y))}]
set ::sz(start) "0,$y1,0"
set ::sz(end) "[expr {$::sz(x) - 1}],$y2,[expr {$::sz(z) - 1}]"
return [list 0 $y1 0]
}
##+##########################################################################
#
# 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]
}
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 already done?
OrMaze $px $py $pz [WALLDIR $dir]
OrMaze $px2 $py2 $pz2 [WALLDIR [OPPOSITE $dir]]
return ""
}
return $dir
}
##+##########################################################################
#
# DoDisplay
#
# Initializes our (simple) display
#
proc DoDisplay {} {
pack [frame .bottom] -side bottom -fill x
canvas .c -relief raised -bd 2 -width $::sz(w) -height $::sz(h)
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
button .new -text "New Maze" -command NewMaze
button .solve -text "Show Solution" -command ShowSolution
pack .c -side top -fill both -expand 1
pack .x .y -side left -in .bottom
pack .new .solve -side left -in .bottom -expand 1
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 txt "Maze: $::sz(x)x$::sz(y)"
if {$::sz(z) > 1} {append txt "x$::sz(z) Level 0"}
.c create text $x 10 -text $txt -anchor n -font bold
ShowLevel 0
.solve config -text "Show Solution"
}
##+##########################################################################
#
# ShowLevel
#
# Draws this level of the maze (for mazes with sz(z) > 1)
#
proc ShowLevel {z} {
.c delete maze
for {set x 0} {$x < $::sz(x)} {incr x} {
for {set y 0} {$y < $::sz(y)} {incr y} {
ShowCell $x $y $z
}
}
}
##+##########################################################################
#
# ShowCell
#
# Shows walls for this cell
#
proc ShowCell {x y z} {
set m $::maze($x,$y,$z)
set w $::sz(lw)
foreach {cx cy 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)} {.c create text $x0 $y0 -text " u" \
-anchor nw -tag maze}
if {$m & $::DOOR(DOWN)} {.c create text $x1 $y1 -text "d " \
-anchor ne -tag maze}
}
##+##########################################################################
#
# ShowSolution
#
# Uses the BACKINFO in each cell to get the solution.
#
proc ShowSolution {} {
if {[.c find withtag s] != ""} { ;# Already showing solution???
.c delete s
.solve config -text "Show Solution"
return
}
foreach {px py pz} [split $::sz(end) ,] break
foreach {cx cy x0 y0 x1 y1 x2 y2 x3 y3} [CellXY $px $py] break
set xy [list $x1 $cy] ;# The exit door
while {1} {
foreach {x y} [CellXY $px $py] break
lappend xy $x $y
set back [BACKUNINFO $::maze($px,$py,$pz)]
if {$back == -1} break
foreach {px py pz} [MOVETO $px $py $pz $back] break
}
foreach {cx cy x0 y0 x1 y1 x2 y2 x3 y3} [CellXY $px $py] break
lappend xy $x0 $cy ;# Then entrance door
.c create line $xy -tag s -fill cyan -width 5 -arrow first
.solve config -text "Hide Solution"
}
##+##########################################################################
#
# CellXY
#
# Returns the coordinates of cell at (px,py) starting nw and going clockwise.
#
proc CellXY {px py} {
set x [expr {$::sz(lm) + $px * $::sz(box)}]
set y [expr {$::sz(tm) + $py * $::sz(box)}]
set cx [expr {$::sz(lm) + ($px+.5) * $::sz(box)}]
set cy [expr {$::sz(tm) + ($py+.5) * $::sz(box)}]
set xy [list $cx $cy $x $y]
set x [expr {$x + $::sz(box)}]
lappend xy $x $y
set y [expr {$y + $::sz(box)}]
lappend xy $x $y
set x [expr {$x - $::sz(box)}]
lappend xy $x $y
return $xy
}
##+##########################################################################
#
# OrMaze
#
# Helper function to logically OR value to maze(x,y,z)
#
proc OrMaze {x y z value} {
set ::maze($x,$y,$z) [expr {$::maze($x,$y,$z) | $value}]
}
##+##########################################################################
#
# 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 end]
set ::mstack [lrange $::mstack 0 end-1]
return $pos
}
Init
DoDisplay
NewMaze