############################################################################
# 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