SH: 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 four types of puzzle here, five 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 winnng is slightly different.
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 Glibert"
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 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
# 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]
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]
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]
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
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 {}
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] } {
for {set i 0} { $i < $its} {incr i} {
.c move Move $dx $dy
update
after 20
}
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
array unset M $b
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}
}
}
}
evaluate$::gameType
if {$WON} return;
}
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 {
global M B
catch {
set id $B($b)
.c delete $id
array unset B ${b}*
array unset M $b
} x
}
proc removeTarget n {
incr ::NT -1
.c delete $::TCnvId($n)
array unset ::TNumAt $::TPos($n)
foreach arr {TPos TCnvId TType} { array unset ::${arr} $n}
}
proc evaluate1 {} {if {$::TPos(0)==$::B(0,rc)} { set ::WON 1}}
proc evaluate2 {} {if {$::TPos(0)==$::B(0,rc) && $::TPos(1)==$::B(1,rc)} { set ::WON 1}}
proc evaluate3 {} {
set rc $::B(0,rc)
if {[catch {set ::TNumAt($rc)} x]} return
removeTarget $x
if {$::NT == 0} {set ::WON 1}
}
proc evaluate4 {} { ;# Remove red balls
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 }
}
}
}
canvas .c -width 500 -height 500
grid .c -columnspan 3
button .st -text restart -command { setupGame [.om index select]}
iwidgets::optionmenu .om -labeltext "Game:" -command { setupGame [.om index select]}
foreach g $games {.om insert end [lindex $g 0]}
.om index select
button .e -text End -command {destroy .}
label .l0 -text "Use arrow keys"
grid .l0 -sticky w -columnspan 3
label .l
grid .l -sticky w -columnspan 3
label .l2
grid .l2 -sticky w -columnspan 3
grid .st .om .e
bind . <KeyPress-Up> { tilt U}
bind . <KeyPress-Down> {tilt D}
bind . <KeyPress-Left> {tilt L}
bind . <KeyPress-Right> {tilt R}
setupGame 0