# GemGame -- based on a game by Derek Ramey 
# by Keith Vetter -- May 2003
# CE port by R.Suchenwirth
# see http://javaboutique.internet.com/GemGame/ # 
package require Tk
 wm geometry . +0+0
 bind . <Up> {
    exec wish $argv0 &;exit
 }
array set S {title "Gem Game" cols 12 rows 12 cell 36} 
set S(w) [expr {$S(cell) * $S(cols) + 10}] 
set S(h) [expr {$S(cell) * $S(rows) + 10}] 
proc DoDisplay {} {
    CompressImages
    frame .f
    canvas .c -relief ridge -bg black -height $::S(h) -width $::S(w) \
        -highlightthickness 0 -relief raised
    label .f.score -text Score:
    label .f.vscore -textvariable S(score)  -width 6
    label .f.vscore2 -textvariable S(score2) -width 7
    button .f.new -text New -command NewGame
    button .f.hint -text Hint -command Hint
    button .f.about -text ? -command About
    button .f.x -text x -command exit
    eval pack [winfo child .f] -side left
    pack .f -side top -fill x
    pack .c -side top -fill both -expand 1
 }
 proc CompressImages {} {
    image create photo ::img::img(0)
    image create photo ::img::img(0,2)
            ;# Blank image
    foreach id {1 2 3 4 5 6 7} {
        foreach a {2 3 4} {
            # We need narrower images
            image create photo ::img::img($id,$a)
            if {$a == 4} continue
            image create photo t
            t copy ::img::img($id) -zo 4
            set f [expr {$a*4}]
            ::img::img($id,$a) copy t -subsample $f
            image delete t
        }
    }
 }
 proc NewGame {} {
    array set ::S {score 0 score2 "" busy 0 click {}}
    .f.hint config -state normal
    .c delete all
    for {set row -2} {$row < $::S(rows)+2} {incr row} {
 ;# Initialize the board
        for {set col -2} {$col < $::S(cols)+2} {incr col} {
            set ::B($row,$col) -1
            if {$row < 0 || $row >= $::S(rows)} continue
            if {$col < 0 || $col >= $::S(cols)} continue
            set ::B($row,$col) [expr {1 + int(rand() * 7)}]
            .c create image [GetXY $row $col] -tag "c$row,$col"
            .c bind "c$row,$col" <Button-1> [list DoClick $row $col]
        }
    }
    # Change all cells on initial board that would explode
    while {1} {
        set cells [FindExploders]
        if {$cells == {}} break
        foreach cell $cells {
            set ::B($cell) [expr {1 + int(rand() * 7)}]
        }
    }
    DrawBoard
 }
 proc DrawBoard {} {
    for {set row 0} {$row < $::S(rows)} {incr row} {
        for {set col 0} {$col < $::S(cols)} {incr col} {
            .c itemconfig "c$row,$col" -image ::img::img($::B($row,$col),2)
        }
    }
 }
 proc GetXY {r c} {
    global S
    set x [expr {$c * $S(cell)/2 + $S(cell)/2}]
    set y [expr {$r * $S(cell)/2 + $S(cell)/2}]
    list $x $y
 }
 proc DoClick {row col} {
                  # Handles mouse clicks
    global S
    if {$S(busy)} return
    set S(busy) 1
    .c delete box
    if {$S(click) == {}} {
        # 1st click, draw the box
        set xy [.c bbox "c$row,$col"]
        .c create rect $xy -tag box -outline white -width 2
        set S(click) [list $row $col]
        set S(busy) 0
        return
    }
    foreach {row1 col1} $S(click) break
         ;# 2nd click, swap and explode
    set S(click) {}
    set dx [expr {abs($col - $col1)}]
    set dy [expr {abs($row - $row1)}]
    if {$dx <= 1 && $dy <= 1 && $dx != $dy} {
        ;# Valid neighbors
        SwapCells $row $col $row1 $col1
        set n [Explode]
        if {! $n} {
             ;# Did something explode???
              ;# Nope, undo the move
            SwapCells $row1 $col1 $row $col
        }
        if {! [Hint 1]}  GameOver
    }
    set S(busy) 0 
}
 proc SlideCells {cells} {  
    # Slides some cells down
    foreach {r c} $cells {
        .c itemconfig c$r,$c -image {}
        if {[info exists ::B($r,$c)] && $::B($r,$c) != -1} {
            set M($r,$c) $::B($r,$c)
        } else {
            set M($r,$c) [expr {1 + int(rand() * 7)}]
        }
        .c create image [GetXY $r $c] -image ::img::img($M($r,$c),2) -tag slider
    }
    set numSteps 8
    set dy [expr {double($::S(cell)) / $numSteps}]
    for {set step 0} {$step < $numSteps} {incr step} {
        .c move slider 0 $dy
        update
        after 10
    }
    foreach {r c} $cells {
                      ;# Update board data
        set ::B([expr {$r+1}],$c) $M($r,$c)
    }
    DrawBoard
    .c delete slider 
}
 proc SwapCells {r1 c1 r2 c2} {
    global B
    .c itemconfig c$r1,$c1 -image {}
    .c itemconfig c$r2,$c2 -image {}
    foreach {x1 y1} [GetXY $r1 $c1] break
    foreach {x2 y2} [GetXY $r2 $c2] break
    .c create image $x1 $y1 -image ::img::img($B($r1,$c1),2) -tag {slide1 slide}
    .c create image $x2 $y2 -image ::img::img($B($r2,$c2),2) -tag {slide2 slide}
    set numSteps 8
    set dx [expr {$x2 - $x1}]
    set dy [expr {$y2 - $y1}]
    set dx1 [expr {double($dx) / $numSteps}]
    set dy1 [expr {double($dy) / $numSteps}]
    set dx2 [expr {-1 * $dx1}]
    set dy2 [expr {-1 * $dy1}]
    for {set step 0} {$step < $numSteps} {incr step} {
        .c move slide1 $dx1 $dy1
        .c move slide2 $dx2 $dy2
        update
        after 10
    }
    .c delete slide
    foreach [list B($r1,$c1) B($r2,$c2)] [list $B($r2,$c2) $B($r1,$c1)] break
    DrawBoard
 }
 proc Explode {} {
    set cnt 0
    while {1} {
        set cells [FindExploders]
               ;# Find who should explode
        if {$cells == {}} break
                 ;# Nobody, we're done
        incr cnt [llength $cells]
        catch { snd_ok play }
        ExplodeCells $cells
                     ;# Do the explosion affect
        CollapseCells
                           ;# Move cells down
    }
    incr ::S(score) [expr {$cnt*$cnt}]
    set ::S(score2) ""
                          ;# Show special scores
    if {$cnt > 3} {
       set ::S(score2) ([expr {$cnt*$cnt}])
    }
    return [expr {$cnt > 0 ? 1 : 0}]
 }
 proc CollapseCells {} {
    while {1} {
                             ;# Stop nothing slides down
        set sliders {}
        for {set col 0} {$col < $::S(cols)} {incr col} {
            set collapse 0
            for {set row [expr {$::S(rows)-1}]} {$row >= 0} {incr row -1} {
                if {$collapse || $::B($row,$col) == 0} {
                    lappend sliders [expr {$row-1}] $col
                    set collapse 1
                }
            }
        }
        if {$sliders == {}} break
        SlideCells $sliders
    }
 }
 proc ExplodeCells {cells} {
    foreach stage {2 3 4} {
        foreach who $cells {
            .c itemconfig c$who -image ::img::img($::B($who),$stage)
            if {$stage == 4} {set ::B($who) 0}
        }
        update
        after 100
   }
 }
 proc FindExploders {} {
                         ;# Find all triplets and up
    global S B
    array set explode {}
    for {set row 0} {$row < $S(rows)} {incr row} {
        for {set col 0} {$col < $S(cols)} {incr col} {
            set me $B($row,$col)
            if {$me == 0} continue
            foreach {dr dc} {-1 0 1 0 0 -1 0 1} {
               set who [list $row $col]
                for {set len 1} {1} {incr len} {
                    set r [expr {$row + $len * $dr}]
                    set c [expr {$col + $len * $dc}]
                    if {$B($r,$c) != $me} break
                    lappend who $r $c
                }
                if {$len < 3} continue
                foreach {r c} $who {
                    set explode($r,$c) [list $r $c]
                }
            }
        }
    }
    return [array names explode]
 }
 proc Hint {{how 0}} {
    global S B
    if {$how == 0} {
        incr S(score) -50
        set S(score2) (-50)
    }
    set h { 0 1 -1 2  0 2       0 1  1  2  0  2       0 2 -1  1 0  1            0 2  1 1  0 1       0 1 -1 -1  0 -1       0 1  1 -1 0 -1            1 0  2 1  2 0       1 0  2 -1  2  0       2 0  1 -1  1 0            2 0  1 1  1 0       1 0 -1 -1 -1  0       1 0 -1  1 -1 0            0 1  0 3  0 2       0 1  0 -2  0 -1       1 0  3 0   2 0            1 0 -2 0 -1 0    }
    .c delete box
    set S(click) {}
    set hints {}
    for {set row 0} {$row < $::S(rows)} {incr row} { ;# Test each cell
        for {set col 0} {$col < $::S(cols)} {incr col} {
            set me $B($row,$col)
            foreach {dr1 dc1 dr2 dc2 dr3 dc3} $h {
                 ;# Check certain neighbors
                set r [expr {$row+$dr1}]
                set c [expr {$col+$dc1}]
                if {$B($r,$c) != $me} continue
                set r [expr {$row+$dr2}]
                set c [expr {$col+$dc2}]
                if {$B($r,$c) != $me} continue
                if {$how == 1} {return 1}
                lappend hints [list $r $c [expr {$row+$dr3}] [expr {$col+$dc3}]]
            }
        }
    }
    if {$how == 2} {return $hints}
    if {$hints == {}} {return 0}
    set n [expr {int(rand() * [llength $hints])}]
    set hint [lindex $hints $n]
    .c dtag hint
    foreach {r c} $hint {
       .c addtag hint withtag c$r,$c
     }
    .c create rect [.c bbox hint] -tag box -outline white -width 3
    .c dtag hint
 }
 proc About {} {
    set msg "$::S(title)\nby Keith Vetter, June 2003
Based on a program by Derek Ramey
Win/CE port by R.Suchenwirth

Click on adjacent gems to swap them. If you get three or more gems in a 
row or column, they will explode, and those above will drop down and new gems will fill in the top."
    tk_messageBox -message $msg
 }
 proc GameOver {} {
    .c create rect 0 0 [winfo width .c] [winfo height .c] \
        -fill white -stipple gray25
    .c create text [GetXY 1 5] -text "Game Over" -font {Helvetica 20 bold} \
        -fill white -tag over
    .f.hint config -state disabled
 } 
 image create photo ::img::img(1) -data {R0lGODdhHgAeALMAAAAAAAAAyAAAKAAA6EhI2FBQ/xAQSBgQSDAw/////////////////////////////ywAAAAAHgAeAAAE/xDISau9OOvN+4RBhBDCCCEIQggshRAiAgRyyhCCCWGMEWAQhJRSCBEh    BAjkBMLAI+cxUkAjpxBCQCBnCOHAImchIEAkpxSEQCBlGOHAIqc0EMk5DSEQSBlGOAQWOYuBSM5pSIFAyjDCgUXOQg5Eck5TCgRShhEOLHIWciCScxpSIJAyjHBgkVMeiOSchhQIpAwjHFjklAYiOach    BAIpwwgHFjkLORDJOQ0hEEgZQjiwyEkIgEhOGQQhEEhpjDnHnHOMgUIaKaUUEMhJCDEBIjmDgEHOKSQEUpJCDERyShHgkHMEEQIEUpJCDERyShHgkHMEEwIEUpJCBERyShHgkIJzBBECBFKSQgxEckoR    4JBzBBECBFKSQgxEckoT4JBzBBECBFKSQgxEckoR4JBzBBMCBFISQkSASM4gYJBzCgmBnMYIIYwRxggohDFCGCOEEBDICUIIYowxQoBBEEJKIUSMQSCQE5wAQhhjhAADKISUQgg55EAgpzwQyEmrvTjr    zW8EADs=}
 image create photo ::img::img(2) -data {R0lGODdhHgAeAJEAAAAAABDgAGj/WP///ywAAAAAHgAeAAACzISPqcvtDyMi8YHkA8Un+EjxgeQDxSf4R/EDSD5Q/CD4QPEDSL4BxQ+CT/EDSL4BxQ+Cj6nLQPGB5BtQ/CD4QPGB5BtQ/CD4RvGB5APF    D4J/FB9IPlD8IPhIsYHkA8Un+GgREQTKB4pN8PEoNpBsoNgEHzEigiCJAMUm+JgQEQRJBCKCQviY    FhEESQQigkL4mBcRBEkgIgg+JkYEQRKICIKPmRFAMiIIPqZCAEmIIPiYahEEIYLgY+oFkBCCj6kqu7sAEeFj6nL7wxhJAQA7}
 image create photo ::img::img(3) -data {R0lGODdhHgAeAJEAAAAAAP//QOjwAODgACwAAAAAHgAeAAACxISPqctLgQg+pmYEQSL4mHoRFEiE4GMqRFACERGCj5kUG0g2wcc8ig8kn+BjAsUPIPlC8BEpvgHJN4KPRvEPSP4RfKT4CCQfCb5RfAwg+SgEn+KjAclHAwCg+HhA8vEIPqZuknw8oPl4AAAkHw1oPhrBJ/koQPNxCL6RfASajwQfSf4BzT+Cj0byDWi+EXxEki9A84fgYwLJB5pP8DGPZAPNJviYKSIkbGYIPqaCCAmbIfiYeiKEjeBjagrQCB9Tl9ufkQIAOw==}
 image create photo ::img::img(4) -data {R0lGODdhHgAeAJEAAAAAANAAAP8AAP84OCwAAAAAHgAeAAAC/4SPqcvtD0h8zAAh+CgCFB8TRAi+iQhQfEQQEYIPJBsoPh6ICInwSTZQfDQg2QQ7TESEwPgYICIEyCwijCRQfAQRAJIBABQbQODuCKZsAACKHwQfjeQLAADFN6D5BiTfAAAovgHNNyD5BgBA8Q1ovgHJNwAAim9A8w1IvgEAUHwDmm9A8g0AgOIb0HwDkm8AABTfgOYbkHwDAKD4BjTfgOQbAADFD4KPRvIFAIBiAwiQfAMBQCEYEWEiBMpHmAEgSAAAAQRJBEg+As0m+ECy4e4OaD7BJtlwdwc0n2CLiADJR4SZoRE+iAiQfESYGYJ/AiQfU2CG4J8AyccUGIKPqQK7BQA7}
 image create photo ::img::img(5) -data {R0lGODlhHgAeALMAAAAAAFyI/5zO/xtX/3qn/zx1/16T/zF5/2+V/wAwzT9w/6b5/wAduAA75SBg/424/yH5BAEAAAAALAAAAAAeAB4AAwT/EMhJq704601ZcyBYOAzDWYNYHGx7NKfUDEqxujjJJU5d    BECD0HAgtkwZnmIJDAwJUILwiGHQFIFfAGFAEB4PgeAhZTkwg6sW4SWIF/CFoPyyfJbYLfsriMfnRkgTDXhMbF5vfnAPgR2FQAh6YYpxZEaOhVh7bn2UgAdnEwyPkGxglHCfB5h4pV5hnX+MRAWsTKVQ    sLJQl6KZeYe5YmJgUrS2t3qvX8zGZhVXpMptUVwGAXUUhL+uwdZABwWCEqPcwIfo4AMX5ZkBCpGQW00jVdGPeU1ANgowGff4gGCp0Y8DwF94HCSIkQBhIQcDxnHwALBHA38xKpTYWCKjx48gAytEAAA7}
 image create photo ::img::img(6) -data {R0lGODdhHgAeAJEAAAAAAIDw/xjo/1jo/ywAAAAAHgAeAAACv4SPqcvtD6OcjMTHI/iYIEDxMWAIPqKIAMU/mBmCj0ayCf7RbIKPJBto/gEOwTeSDTQfB5Lgk2yg+XiQAARQNtB8TEgAAiQCNB/T4IAA    BAjQfEyEARoAEUDzMRUMCEgAzcdUMCAgIEDzMRECaACAiADNxzSIoAAAJBtoPiZQbAAAkg00Hw8oNsEn2UDzcYBiE3wj2UDzDyg2wUeSTfCPYhN8NBEBkn8QEQQfUYDko0AQfEwg+XgEH1OX2x9GORspADs=}
 image create photo ::img::img(7) -data {R0lGODlhHgAeALMAAAAAANtNyeId0/8A/wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAAAAAAALAAAAAAeAB4AAwSWEMhJq703AMG7/8KGAUG5gegZWmWroty7Tm0tf/dc72MeSzvTYEgs5iYhXnFJlJEkMRdzOlCRNFYNlSpyvQDb7dX0DXNtZTNzjPWA1Us2tPOGN9FuuxFP19+9eX5VfDGCg4B9gnJZdXBdZFFCjnSQbFpmTliWklwpQEFkGDA6QZs2njQ2oDw4LCarpXQYGrCgIj24uQARADs=}
 DoDisplay
 NewGame