[SMH]: This TCL program implements some tilt mazes that I copied from
java applets found on the internet.

[http://www.stevehowarth.com/images/tclWiki/TiltMaze.gif]


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.

---
[SMH] I've noticed something weird. This runs fine when I start it
with tclsh.exe. However when I run wish.exe, the key bindings don't
seem to take effect until after I press restart. Any Ideas?
----
[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.

----

[AK]: I know of a real-world tilt maze where you have to run a path from beginning to end, avoiding the holes nearby. The most challenging aspect of it is that in some places to stay on the path you have to move the ball towards a hole and then tilt into a perpendicular direction just before falling in, that, or tilting backwards to stop the balls motion just before the hole and then changing the direction. In other words, there is no wall stopping you from falling in these places, just you working against the balls momentum by hair trigger timed tilting.

[AK]: Another type I have seen is where you have to lodge several balls in several depressions. The challenge is to move a ball into a free depression without disloding the balls already in place.

[PYK] 2013-01:  The tilt feauture seems to be a bit broken, with balls changing direction only when they hit a wall, even if the board is tilted long before they reach a point where they could move in the direction of the tilt.

----
======
############################################################################
# TiltMaze.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   {
    OneBall      "Move red ball to target"
    R&B          "Move red to red and blue to blue at same time"
    ManyTargets  "Remove all the targets"
    RemoveReds   "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

set CX 40     ;# Width of cell
set CY 40     ;# Height of cell

set currGame     1

#  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  {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   OneBall     clickMazes one R 0 0 r 4 4
game   R&B         toshio     two B 5 3 R 5 4 b 5 2 r 5 1
game   ManyTargets clickMazes three R 3 2 b 0 0 b 0 4 b 2 2 b 4 0 b 4 4
game   OneBall     clickMazes four  R 2 2 r 3 3
game   RemoveReds  clickMazes  five B 2 4 B 3 0 R 3 4 R 4 0 g 2 2
game   OneBall     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 {} {
    clearGlobals
    global currGame games

    set ng [llength $games]

    .p configure -state [expr {($currGame > 1) ? "active" : "disabled"} ]
    .gl configure -text "$currGame of $ng"
    .n configure -state [expr {($currGame <= $ng) ? "active" : "disabled"} ]

    set g [lindex $::games [expr $currGame -1]]
    set ::gameType [lindex $g 0]  ;#  Type Credit Def...
    .l configure -text $::gameTypes($::gameType)
    catch {.l2 configure -text $::credits([lindex $g 1])} x
    setupBoard [lindex $g 2]
    foreach {t r c } [lreplace $g 0 2] {
        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 evaluate_OneBall {} {if {$::TPos(0)==$::B(0,rc)} { set ::WON 1}}

# Evaluate 2 Ball and matching target puzzle

proc evaluate_R&B {} {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 evaluate_ManyTargets {} {
    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 evaluate_RemoveReds {} {
    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}
        }
    }
}


grid  [canvas .c] -columnspan 5
grid  [label .l] -sticky w  -columnspan 5
grid  [label .l0 -text "Use arrow keys or l,r,u,d to tilt board"] -sticky w  -columnspan 5
grid  [label .l2] -sticky w  -columnspan 5
button .st -text restart -command setupGame

tk_optionMenu .om game [lindex $games 0 0]
foreach g [lreplace $games 0 0] {.om.menu add radiobutton -label [lindex $g 0] -variable game }

set l {}

button .p -text "<" -command {incr ::currGame -1; setupGame}  -state disabled
label .gl -text "1" 
button .n -text ">" -command {incr ::currGame; setupGame} 
button .e -text End -command {destroy .}
grid .st .p .gl .n .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> {setupGame}
bind . <KeyPress-r> {setupGame}
bind . <KeyPress-q> {destroy .}

setupGame
======

----

06Mar2005 [SMH] Removed IWidget dependancy.

<<categories>> Application | Games