AutoMaze - BBH based on suggestion by RS, using his graph code from Graph theory in Tcl. Those unfamiliar with Tcl/Tk will want to read, "When all you want is to run a Tk application".
This seems to require an 'edges' proc which isn't defined... RS Not here, but as alluded above, you need a few routines from Graph theory in Tcl: edges, nodes, isBridge, isContinuous. As comments between Tcl code are guarded there with "if 0 {...}", just grab the whole chunk from "proc nodes" to (inclusively) "isBridge", paste into your editor, go!
RS added doodler, see end of page
BBH created new multi-player game version at TkMaze
##################################################################
# Auto Maze
# CAUTION : don;t try too large a grid size as this is NOT efficient
# you end up doing a lot of list operations on some large lists
#
##################################################################
proc createGrid {w h} {
set g ""
for {set r 0; set r1 1} {$r < $h} {incr r ; incr r1 } {
for {set c 0 ; set c1 1} {$c < $w} {incr c ; incr c1 } {
if {$r1 < $h} { lappend g "R${r}C$c,R${r1}C$c" }
if {$c1 < $w} { lappend g "R${r}C$c,R${r}C$c1" }
}
}
return $g
}
proc random {n} { expr {int(rand() * $n)} }
proc lYank {_L i} {
upvar 1 $_L L
set item [lindex $L $i]
set L [lreplace $L $i $i]
return $item
}
proc lDelete {_L item} {
upvar 1 $_L L
set i [lsearch -exact $L $item]
set L [lreplace $L $i $i]
}
proc reduceGraph {g} {
set eList [edges $g]
set n [expr {$::H*$::W-1}] ;# bbh fixed, RS brought here
while {[llength $g]>$n } {
set edge [lYank eList [random [llength $eList]]]
if { ! [isBridge $edge $g] } {
lDelete g $edge
}
}
return $g
}
proc renderMaze {g cvs} {
$cvs delete all
foreach e $g {
if [regexp {R(\d+)C(\d+),R(\d+)C(\d+)} $e -> r1 c1 r2 c2] {
set y1 [expr {($r1 * 10.0) + 1.0}]
set y2 [expr {($r2 * 10.0) + 9.0}]
set x1 [expr {($c1 * 10.0) + 1.0}]
set x2 [expr {($c2 * 10.0) + 9.0}]
$cvs create rectangle $x1 $y1 $x2 $y2 -fill $::CLR -outline $::CLR
}
}
# make enter/exit points..
foreach {x y} [list [random $::W] 0 [random $::W] $::H] {
set x [expr {$x * 10.0}]
set y [expr {$y * 10.0}]
$cvs create rectangle \
[expr {$x + 1.0}] [expr {$y - 1.0}] \
[expr {$x + 9.0}] [expr {$y + 1.0}] \
-fill $::CLR -outline $::CLR
}
foreach x [list -1.0 [expr {($::W * 10) + 1.0}]] {
$cvs create rectangle $x 0.0 $x 0.0 -fill {} -outline {}
}
# second time looks better - so do it twice
scaleData $cvs
after idle scaleData $cvs
}
proc scaleData {cvs} {
set bbox [$cvs bbox all]
if {[llength $bbox] != 4} {
return
}
foreach {x1 y1 x2 y2} $bbox break
set dw [expr $x2 - $x1]
set dh [expr $y2 - $y1]
set cw [winfo width $cvs]
set ch [winfo height $cvs]
set sx [expr {double($cw)/double($dw)}]
set sy [expr {double($ch)/double($dh)}]
$cvs move all [expr -1 * $x1] [expr -1 * $y1]
$cvs scale all 0 0 $sx $sy
}
proc newMaze {} {
global H W
set g [createGrid $W $H]
set m [reduceGraph $g]
renderMaze $m .c
}
proc makeGUI {} {
wm title . "Maze"
set ::W 10
set ::H 10
set ::CLR grey75
. config -background $::CLR
label .lw -text Width: -background $::CLR
entry .ew -textvar W -width 5 -validate all -vcmd {string is integer %P}
label .lh -text Height: -background $::CLR
entry .eh -textvar H -width 5 -validate all -vcmd {string is integer %P}
button .b -text "New Maze" -command newMaze -background $::CLR
canvas .c -width 400 -height 400 -bd 0 -relief flat -background black -highlightthickness 0
grid x .lw .ew .lh .eh .b x -padx 5 -pady 5
grid .c -columnspan 99 -sticky news -padx 5 -pady 5
grid rowconfigure . 1 -weight 1
grid columnconfig . 0 -weight 1
grid columnconfig . 6 -weight 1
update
bind .c <Configure> {scaleData %W}
}
makeGUIOr, to make larger mazes in a reasonable amount of time - BBH
proc createGrid {w h} {
set g ""
for {set r 0; set r1 1} {$r < $h} {incr r ; incr r1 } {
for {set c 0 ; set c1 1} {$c < $w} {incr c ; incr c1 } {
if {$r1 < $h} { lappend g "R${r}C$c,R${r1}C$c" }
if {$c1 < $w} { lappend g "R${r}C$c,R${r}C$c1" }
}
}
return $g
}
proc random {n} { expr {int(rand() * $n)} }
proc lYank {_L i} {
upvar 1 $_L L
set item [lindex $L $i]
set L [lreplace $L $i $i]
return $item
}
proc lDelete {_L item} {
upvar 1 $_L L
set i [lsearch -exact $L $item]
set L [lreplace $L $i $i]
}
proc reduceGraph {g w h} {
set eList [edges $g]
set n [expr {$w*$h -1}]
while {[llength $g] > $n } {
set edge [lYank eList [random [llength $eList]]]
if { ! [isBridge $edge $g] } {
lDelete g $edge
}
}
return $g
}
proc renderMazeBlock {g cvs origX origY} {
foreach e $g {
if [regexp {R(\d+)C(\d+),R(\d+)C(\d+)} $e -> r1 c1 r2 c2] {
set x1 [expr {$origX + ($c1 * 10.0) + 1.0}]
set x2 [expr {$origX + ($c2 * 10.0) + 9.0}]
set y1 [expr {$origY + ($r1 * 10.0) + 1.0}]
set y2 [expr {$origY + ($r2 * 10.0) + 9.0}]
$cvs create rectangle $x1 $y1 $x2 $y2 -fill $::CLR -outline $::CLR
}
}
}
proc connectMazeBlocks {g cvs} {
foreach e $g {
if [regexp {R(\d+)C(\d+),R(\d+)C(\d+)} $e -> r1 c1 r2 c2] {
if {$r1 == $r2} {
set y1 [expr {($r1*100.0) + ([random 10] * 10.0) + 3.0}]
set y2 [expr $y1 + 8.0]
set x1 [expr {($c2*100.0) - 5.0}]
set x2 [expr {($c2*100.0) + 5.0}]
} else {
set x1 [expr {($c1*100.0) + ([random 10] * 10.0) + 3.0}]
set x2 [expr $x1 + 8.0]
set y1 [expr {($r2*100.0) - 5.0}]
set y2 [expr {($r2*100.0) + 5.0}]
}
$cvs create rectangle $x1 $y1 $x2 $y2 -fill $::CLR -outline $::CLR
}
}
# make enter/exit points..
foreach {X Y} [list [random $::W] 0 [random $::W] $::H] {
set x [expr {$X * 100.0 + [random 10] * 10.0}]
set y [expr {$Y * 100.0}]
$cvs create rectangle \
[expr {$x + 3.0}] [expr {$y - 5.0}] \
[expr {$x + 11.0}] [expr {$y + 5.0}] \
-fill $::CLR -outline $::CLR
}
}
proc newMaze {} {
global H W
.c delete all
.c config -width [expr $W*100 + 4] -height [expr $H*100+4] -cursor watch
set ::N [expr $W*$H]
set blocks {}
label .c.l -font {helvetica 144 bold italic} -textvar N -background black -foreground yellow
.c create window [expr $W*50] [expr $H*50] -anchor c -window .c.l
update
for {set r 0} {$r < $H} {incr r} {
for {set c 0} {$c < $W} {incr c} {
set oX [expr $c * 100 + 2]
set oY [expr $r * 100 + 2]
set g [createGrid 10 10]
lappend blocks [reduceGraph $g 10 10] $oX $oY
incr ::N -1
update
}
}
set g [createGrid $W $H]
set m [reduceGraph $g $W $H]
destroy .c.l
foreach {b x y} $blocks {
renderMazeBlock $b .c $x $y
}
connectMazeBlocks $m .c
.c config -cursor {}
}
proc makeGUI {} {
wm title . "Maze"
set ::W 5
set ::H 5
set ::CLR grey75
. config -background $::CLR
label .lw -text Width: -background $::CLR
tk_optionMenu .ew W 1 2 3 4 5 6 7 8 9 10
.ew config -background $::CLR
label .lh -text Height: -background $::CLR
tk_optionMenu .eh H 1 2 3 4 5 6 7 8 9 10
.eh config -background $::CLR
button .b -text "New Maze" -command newMaze -background $::CLR
canvas .c -width 504 -height 504 -bd 0 -relief flat -background black -highlightthickness 0
grid x .lw .ew .lh .eh .b x -padx 5 -pady 5
grid .c -columnspan 99 -sticky {} -padx 5 -pady 5
wm resizable . 0 0
}if 0 {RS could not resist to add doodling functionality (draw a line with left mouse button down), so you can better see your way through the maze... Just append this code at end and enjoy! }
proc doodle {w {color black}} {
#-- enable a canvas to accept mouse drawing
bind $w <1> [list doodle'start %W %x %y $color]
bind $w <B1-Motion> {doodle'move %W %x %y}
}
proc doodle'start {w x y color} {
set x0 [$w canvasx $x]
set y0 [$w canvasy $y]
set ::_id [$w create line $x0 $y0 $x0 $y0 \
-width 3 -fill $color]
}
proc doodle'move {w x y} {
set x0 [$w canvasx $x]
set y0 [$w canvasy $y]
eval $w coords $::_id [concat [$w coords $::_id] $x0 $y0]
}
doodle .c red ;# install the bindings