AutoMaze - BBH based on suggestion by Richard Suchenwirth, using his graph code from Graph theory in Tcl
This seems to require an 'edges' proc which isn't defined...
RS added doodler, see end of page
##################################################################
# 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