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

  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