Version 11 of Tilt Mazes
Updated 2003-11-30 17:00:39
SMH: This TCL program implements some tilt mazes that I copied from java applets found on the internet.
The idea is based on puzzles in which a ball rolls around in a tray. When the maze is tilted in one direction using an arrow key, the ball rolls until it hits something. At the moment there are four types of puzzle, six puzzles in all.
KPV This is similar to the game Eliminator--the same concept of tilting the board to move the pieces but what constitutes winning is slightly different.
############################################################################
# tilt.tcl - tilt maze variations.
# by Steve Howarth -- Nov 2003
#
# Derived from Java applet found at http://www.clickmazes.com and
# http://www.logicmazes.com featuring mazes by Andrea Gilbert
#
# The toshio-t web site also contains a java applet with several mazes.
############################################################################
array set gameTypes {
1 "Move red ball to target"
2 "Move red to red and blue to blue"
3 "Remove all the targets"
4 "Remove all the red balls"
}
array set credits {
clickMazes "www.clickmazes.com. Maze: Andrea Gilbert"
toshio "http://www.tcp-ip.or.jp/~toshio-t/ (japanese)"
}
package require Tk
package require Iwidgets 4.0
set CX 40 ;# Width of cell
set CY 40 ;# Height of cell
# Q, Busy Input Queue and busy flag. Allows typeahead of moves
# WON Game has been won
# NT/NB Number of targets/Balls
# NRows/NCols Board Size
# B(n) Canvas Id of Ball N
# B(n,x) Info about Ball n x=(r, c, rc)"
# M(n) Balls currently being moved.
# BLK(U,rc) A ball at r,c can not move Up. Also D/L/R"
# TPos(n) r,c of target number n
# TNumAt(r,c) Target number of target at r,c"
# TCnvID(n) Canvas Id of target n"
# TType(n) Target Type of target n"
# gameType Type Of Game
proc clearGlobals {} {
set ::Q {} ;# Input Queue
foreach v {WON NT NB NRows NCols busy} {set ::$v 0}
foreach arr {B M BLK TPos TNumAt TCnvId TType} {
array unset ::$arr
array set ::$arr {}
}
}
# Board layouts:
# width, height
# V positions of vertical lines on current row
# H positions of horizontal lines on current row
# current row increments on next V or H->H
set boards(one) {5 5 V 2 H 1 H 4 V 0 H 2 H 1 4 V 2 }
set boards(two) {6 6 V 2 H 0 V 4 H 1 V 3 V 1 H 4 V 0 H 5 V 2}
set boards(three) {5 5 V 1 H 0 3 V 3 V 0 1 H 2 H 4 V 0 2}
set boards(four) {6 6 V 0 4 H 2 H 4 V 0 1 2 H 2 3 5 V 2 3 H 0 H 5 V 1 2}
set boards(five) {5 5 V 0 1 H 2 V V V 0 H 4}
set boards(six) {9 9 V 2 6 H 0 5 8 V 1 7 H 1 4 V 5 6 V 1 4 H 0 3 5 8
V 6 H 3 5 V 3 4 H 1 6 8 V 0 H 2 4 V 4 H 0 3 7 V 3 7}
set games {}
# Game Defs {Title GameType CreditKey BoardName {R r c} ...
# R,G,B Red Green Blue Ball at r,c
# r,g,b Reg Green Blue Target Rect at r,c
proc game args {lappend ::games $args}
game "one" 1 clickMazes one R 0 0 r 4 4
game "two" 2 toshio two B 5 3 R 5 4 b 5 2 r 5 1
game "three" 3 clickMazes three R 3 2 b 0 0 b 0 4 b 2 2 b 4 0 b 4 4
game "four" 1 clickMazes four R 2 2 r 3 3
game "Five" 4 clickMazes five B 2 4 B 3 0 R 3 4 R 4 0 g 2 2
game "Six" 1 clickmazes six R 3 5 b 5 3
# convert cell to canvas coords using cell size (CX,CY)
proc X {x {dx 0}} { expr $x * $::CX + $dx * $::CX + 5}
proc Y {y {dy 0}} { expr $y * $::CY + $dy * $::CY + 5}
proc setupBoard name {
global BLK nRows nCols
set l $::boards($name)
set m [llength $l]
set nRows [lindex $l 0]
set nCols [lindex $l 1]
.c addtag X all
.c delete X
.c configure -width [expr $nCols * $::CX + 10] -height [expr $nRows * $::CY + 10]
set stt I
set r -1
for {set i 2} {$i < $m} {incr i} {
set c [lindex $l $i]
switch -glob $stt$c {
*V {incr r; set stt V}
HH {incr r}
VH {set stt H}
V[0-9] {
.c create line [X $c 1] [Y $r] [X $c 1] [Y $r 1] -width 3
set BLK(R,$r,$c) 1
set BLK(L,$r,[incr c]) 1
}
H[0-9] {
.c create line [X $c] [Y $r 1] [X $c 1] [Y $r 1] -width 3
set BLK(D,$r,$c) 1
set BLK(U,[expr $r + 1],$c) 1
}
}
}
.c create line [X 0] [Y 0] [X $nRows] [Y 0] \
[X $nRows] [Y $nRows] [X 0] [Y $nRows] [X 0] [Y 0] -width 3
set nc [expr $nCols - 1]
set nr [expr $nRows - 1]
for {set i 0} {$i < $nRows} {incr i} { set BLK(L,$i,0) 1; set BLK(R,$i,$nc) 1}
for {set i 0} {$i < $nCols} {incr i} { set BLK(U,0,$i) 1; set BLK(D,$nr,$i) 1}
}
proc newBall {t r c col {sz .8}} {
global B NB
set s1 [expr 0.5 - $sz/2 ]
set s2 [expr 1 - $s1]
set id [.c create oval [X $c $s1] [ Y $r $s1] [X $c $s2] [Y $r $s2] -fill $col]
foreach {n v} [list r $r c $c t $t rc $r,$c $t 1] {set B($NB,$n) $v }
set B($NB) $id
incr NB
}
proc newTarget {t r c col {sz .2}} {
global NT; # Number of targets
set s1 [expr 0.5 - $sz/2 ]
set s2 [expr 1 - $s1]
set id [.c create rectangle [X $c $s1] [ Y $r $s1] [X $c $s2] [Y $r $s2] -fill $col]
set ::TNumAt($r,$c) $NT
set ::TPos($NT) $r,$c
set ::TType($NT) $t
set ::TCnvId($NT) $id
incr NT
}
proc setupGame n {
clearGlobals
set g [lindex $::games $n]
set ::gameType [lindex $g 1]
.l configure -text $::gameTypes($::gameType)
catch {.l2 configure -text $::credits([lindex $g 2])} x
setupBoard [lindex $g 3]
foreach {t r c } [lreplace $g 0 3] {
switch $t {
R {newBall $t $r $c red}
G {newBall $t $r $c green}
B {newBall $t $r $c blue}
r {newTarget $t $r $c red}
g {newTarget $t $r $c green}
b {newTarget $t $r $c blue}
}
}
}
proc tilt {dir {q 1}} {
global M WON B CX CY BLK Q busy
if {$WON} return
# If user presses key before ball stops moving, Add to queue
if {$q} {
if {$::busy } {append Q $dir; return}
}
set busy 1
# Sort balls. When one ball stops, it may block the next.
# There must be a easier way to do this (hint!).
set L {}
foreach {b id} [array get B \[0-9\]] {lappend L [list $b $id $B($b,r) $B($b,c)]}
switch $dir {
U { set L [lsort -index 2 $L] }
D { set L [lsort -index 2 -decreasing $L]}
L { set L [lsort -index 3 $L]}
R { set L [lsort -index 3 -decreasing $L]}
}
set L2 {} ;# to contain ballNum1, canvasId, startRow, startCol, ballNum2,..
foreach x $L {lappend L2 [lindex $x 0] [lindex $x 1] [lindex $x 2] [lindex $x 3]}
array set TBLK [array get BLK]
foreach v {dr dc dr1 dc1} {set $v 0}
foreach {b id r c} $L2 {
switch $dir {
U { set dr -1; set dr1 1 } D { set dr 1; set dr1 -1}
L { set dc -1; set dc1 1} R { set dc 1; set dc1 -1}
}
if {[catch { set TBLK($dir,$r,$c)} xx]} {
set M($b) $id
.c itemconfigure $id -tag Move
} else {
set TBLK($dir,[expr $r + $dr1],[expr $c + $dc1]) 1
}
}
set its 5
set dx [expr $::CX * $dc / $its]
set dy [expr $::CY * $dr / $its]
while { [array size M] } {
# Move all balls to next square in $its steps.
for {set i 0} { $i < $its} {incr i} {
.c move Move $dx $dy
update
after 20
}
# Update ball positions. Check if resting against lines or other balls.
foreach {b id - -} $L2 {
if { [catch {set M($b)} x]} continue
set r [incr B($b,r) $dr]
set c [incr B($b,c) $dc]
set B($b,rc) $B($b,r),$B($b,c)
if {! [catch { set TBLK($dir,$r,$c)} x ]} {
.c dtag $id Move ;# Don't move ball any more
array unset M $b
# Ball now blocks others. Set temp horiz/vertical line in array.
switch $dir {
U {set TBLK(U,[incr r],$c) 1}
D {set TBLK(D,[incr r -1],$c) 1}
L {set TBLK(L,$r,[incr c]) 1}
R {set TBLK(R,$r,[incr c -1]) 1}
}
}
}
# Evalulate position
evaluate$::gameType
if {$WON} return;
}
# send typeahead move. When no more clear busy flag.
if {$Q ne ""} {
set cmd "tilt [string range $::Q 0 0] 0"
set Q [string range $Q 1 end]
after 0 $cmd
} else {
set busy 0
}
}
proc removeBall b {
set id $::B($b)
.c delete $id
array unset ::B ${b}*
array unset ::M $b
incr ::NB -1
}
proc removeTarget n {
incr ::NT -1
.c delete $::TCnvId($n)
array unset ::TNumAt $::TPos($n)
foreach arr {TPos TCnvId TType} { array unset ::${arr} $n}
}
# Evaluate 1 Ball and 1 target puzzle
proc evaluate1 {} {if {$::TPos(0)==$::B(0,rc)} { set ::WON 1}}
# Evaluate 2 Ball and matching target puzzle
proc evaluate2 {} {if {$::TPos(0)==$::B(0,rc) && $::TPos(1)==$::B(1,rc)} { set ::WON 1}}
# 1 Ball collect all targets. Check if ball is over a target.
proc evaluate3 {} {
set rc $::B(0,rc)
if {[catch {set ::TNumAt($rc)} x]} return
removeTarget $x
if {$::NT == 0} {set ::WON 1}
}
# Make red balls disappear puzzle. If ball at target, disappear it + count reds
proc evaluate4 {} {
global B
foreach {b id} [array get B \[0-9\]] {
set rc $B($b,rc)
if {![catch {set ::TNumAt($rc)} x ]} {
removeBall $b
set reds [array names B \[0-9\],R]
if {[llength $reds] == 0 } {set ::WON 1}
}
}
}
proc restart {} {setupGame [.om index select]}
grid [canvas .c] -columnspan 3
grid [label .l] -sticky w -columnspan 3
grid [label .l0 -text "Use arrow keys or l,r,u,d to tilt board"] -sticky w -columnspan 3
grid [label .l2] -sticky w -columnspan 3
button .st -text restart -command restart
iwidgets::optionmenu .om -labeltext "Game:" -command restart
foreach g $games {.om insert end [lindex $g 0]}
button .e -text End -command {destroy .}
grid .st .om .e
foreach {key dir} {Up U Down D Left L Right R u U d D l L r R} {
bind . <KeyPress-$key> "tilt $dir"
}
bind . <KeyPress-s> restart
bind . <KeyPress-q> {destroy .}
setupGame 0