Version 79 of Gem Game

Updated 2019-01-07 01:24:31 by Jorge

Keith Vetter 2003-06-04 : here's an addictive little puzzle game copied from an applet at [L1 ].

The object of the game is to swap neighboring gems to create rows or columns of three or more similar gems. When you do so, those gems explode and all the gems above slide down and new gems fill in the top. The more gems you explode in a turn the more points you get.

KPV 2003-06-24 : since writing this program I've come across several other (non-tcl) versions that go by such names as Santa Balls [L2 ], Santa Balls 2 which uses a hexagonal board [L3 ], Flip the Mix which uses M&M pieces [L4 ] and Carnival Jackpot which is also played on a hexagonal board [L5 ].


uniquename 2013aug01

Here is a non-miniaturized image of the game --- with the control buttons along the left side, instead of along the top.

vetter_GemGame_screenshot_432x337.jpg


TV Looks nice, when does the game end?

KPV When you can't move anymore. It may take a while--my max score is around 9000.

DKF 35301 :^p KPV yes, but I had a turn score 1024 points :)

KPV 170,725 in 9,805 turns. But I used a computer to do the playing. It uses the simple algorithm of selecting out of all possible moves the one nearest the top out. See below for more details.

phk just for the records, I made 26'034 by myself and 213'024 using the robot.

MS's son Guido is proud to have reached 28'274 points.

TV Wonderfull, now we're shuffing 'round gems with our computer powers..

DHB AWSOME!!! Very Nicely DONE!!!


MC Added catch around snd_ok and snd_bad. (I have Snack installed but don't have permissions to write to /dev/dsp & /dev/mixer.)


4/Jun/2003 - Joe Mistachkin -- With this minor change, you can move any piece by giving up 10% of your current score.

       if {0} { # Keep reapable
       if {! $n} {                             ;# Did something explode???
           # Joe's custom part...
           if {$::S(score) < 10} {
             snd_bad play                        ;# Nope, undo the move
             SwapCells $row1 $col1 $row $col
           } else {
             # decrease score by 10%...
             set ::S(score) [expr {int($::S(score) - ($::S(score) / 10))}]
           }
       }
       }

KPV 2003-06-05 - I like your idea but I changed the way you invoke it because I wanted to avoid having it happen if you accidentally click on the wrong cell. I've updated the code so that now if you click on any two adjacent pieces 3 times in a row, they will be swapped with a 10% penalty.


MPJ 2003-06-05 - I thought this game would look nice on the PocketPC. So with a couple lines of change I was able to get a 8x8 board with all the buttons. If you want the file then get it here [L6 ] (updated picture and code 06-12). It will also plays well on the desktop. - RS: About at the same time I also did the same :-) The above version does not look well in Keuchel's port, because images are distorted on rendering. By reducing their scale, I can offer as alternative a 12x12 PocketPC version at [L7 ], where gems are smaller but well-looking.

MPJ: http://mywebpages.comcast.net/jakeforce/iGem.jpg RS: http://wiki.tcl.tk/_repo/wiki_images/iGems.jpg


KPV I wrote a little robot procedure to have the computer play by itself. I tried three different strategies for selecting which move to make. The best strategy was to select the move closest to the top. This routinely scores around 30,000 and the highest I've gotten was 170,725. The worst strategy was to select the move closest to the bottom; this averages a score of about 5,000. Selecting a move at random averages a score of about 15,000. The average score per turn, however, was about 17, 36, and 30 respectively.

I've updated the code below to include the Robot routine. You can only invoke it by pressing <F2> to bring up the console and typing the command in by hand.


escargo 7 Jun 2003 - I thought it might be interesting to have some game statistics displayed at the end of the game:

  • Total time
  • Total turns
  • Turns/minute
  • Total score
  • Average score per turn

These might be displayed optionally (pressing a "statistics" button) or at the end of every game.

KPV Your wish is my command! I've update the code below to have a "statistics" button.

escargo 8 Jun 2003 - Thanks for making the changes. I used my wish-reaper to download the new code. I certainly burned through 45 minutes playing this game really easily. I'm going to have to ration myself.

MPJ I added the statistics page (S button) and robot mode (R button) to the PocketPC version above.

escargo 12 Jun 2003 - Is there any practical way to have shorter games? Some games go over an hour. Solitaire is nice because the games are short.

KPV -- the easiest way is to change the board dimensions--the number of rows, columns and jewels. I just updated the code to allow you to change the dimensions via the console (see below). You can then use the Robot to see how long a typical game lasts. You might want to try 9x9x7 or 10x10x8.

Alternatively, I'm thinking of adding a timer to the game like the original applet has.

escargo - I would be in favor of that.

KPV -- done, see below.


KPV 2003-06-12: added several features: 1) pressing the z toggles zoom mode where the board is twice as large; 2) pressing r or R will run the robot either 10 moves or until the end of the game respectively, pressing the key again will stop the robot; 3) added another jewel (but it's not used by default); 4) board dimensions are configurable (via console no GUI yet)--just set either S(rows), S(cols) or S(jewels) and then press New Game.

DGP ...but you removed the [package require Tk 8.4] requirement. Don't do that.

KPV sorry, actually I just now went and removed the 8.4 dependencies-- replaced -padx and -pady on a frame with ones on the pack and grid commands. The code should now run fine on 8.3 (and probably earlier but I can't test it).

DGP OK, [package require Tk 8.3] then.


KPV 2003-06-13: Added 5 levels of difficulty to the game. Level 1 is the current version. Levels 2-5 are all timed games--when a timer ticks down to zero the game is over--but each time you complete a move you get a small time bonus. The higher the level the less initial time you have and the smaller the time bonus.


escargo 23 Jun 2003 - After playing with the new version, there are two features that I would like to see added.

  1. Mute. Sometimes I have other applications generating sounds (e.g., music) and the sound effects are unnecessary and undesirable.
  2. Pause. Sometimes the phone rings, and I don't want my timed games to time out on me, just because I'm busy. (If the game could detect that it's not on top and pause itself in those cases, that would be wonderful.)

KPV 2003-06-24 : I'd been thinking about adding these two features and you convinced me to do so. Mute is activated via a checkbutton on the display; Pause is activated by pressing p. I tried to find a binding that would trigger when the window becomes inactive but couldn't find one that worked on my Win2k box--the page Windowing system events has some explanations why.

escargo - Did you forget to bump the version number? I already had a version 1.4, and the "About" button lists the new version as 1.4. KPV oops

MG May 31st 2005 - You can add automatic pausing, still, using the <FocusOut> binding. Just bind <FocusOut> to

  bind . <FocusOut> "CheckPause %W"

and then add a CheckPause proc:

 proc CheckPause {w} {

  if { [focus -displayof .] == "" && $w == "." && $::S(pause) =="0" } {
       Pause
     }
 }

it should work. (The [focus] check makes sure the window isn't active, the check of $w makes sure the binding only fires for '.', otherwise it runs for the canvas, too, and the last one makes sure the game isn't paused already, otherwise it auto-unpauses:)


Laurent Duperval 2003-06-27: One minor change that would be nice: stop the timer when the game is paused.

escargo - The timer pauses for me on version 1.5. (It even backs up a little, which I think is only fair.)


escargo 7 Oct 2003 - I think there might be a bug in the pause code. If I pause the game for a long time, the amount of time available to complete a level gets incremented by some amount of time (perhaps the length of time the pause was in effect). Short pauses don't seem to matter much, but I get stuck away from the game for several minutes, and then come back, my remaining time is far beyond what I ought to have available. I can watch the counter increment from where it was left to a new, unreasonable level.


MG Aug 31 2004 - Another great little program. Nicely done, Keith. :)


HJG 2005-05-27 - Really nice game :-) I just had to tinker a bit with it, adding a menu for that extra jewel ... and now all options in one popup-menu, you can also select the number of cols and rows.


MG June 2nd 2005 - Added the number of legal moves at the moment into the Stats menu (and bumped the version number to 1.5.7). Haven't added the auto-pause from above into the code, since that's a bigger change to how it plays and I don't want to take that liberty with Keith's code.


 ##+###############################################################
 #
 # GemGame -- based on a game by Derek Ramey and others
 # by Keith Vetter -- May 2003
 #
 # Also known as Elf balls, Santa Balls and Santa Balls 2
 # http://www.afunzone.com/Kewel/santaballs.htm
 # Flip the Mix w/ M&M's: http://www.afunzone.com/mm.htm
 # Carnival Jackpot (hex): http://www.afunzone.com/Kewel/CarnJackpot.htm
 #
 # See http://javaboutique.internet.com/GemGame/
 #
 # 2003/06/12: zoom, robot on key, 8th jewel, resizable via console
 # 2003/06/13: timer levels
 # 2003/06/24: mute and pause
 # 2005-05-25: pause-button; Keys: "S": ShowStats, "H": Hint; Console-Message
 # 2005-05-26: Select number of jewels, re-arranged jewel-colors and buttons
 # 2005-05-28: System-Menu to set cols, rows, jewels
 # 2005-05-31: Options-Menu: set cols, rows, jewels, level, mute, stats
 # 2005-06-01: Center pause + gameover-messages on all playfield-sizes
 #
 # Bugs:
 # * Timer increments while paused
 # * Resize+Robot: while paused & after game-over
 # Todo:
 # * Support for Keyboard (Cursor-Keys)
 # * Highscore
 # * Profile: Save/Load Options
 # * Robot/Sortkey: calc. number of exploding gems for move --> optimize play
 # * Random seed --> Robot-Benchmark
 # * detect "triple play" in either direction
 # * "Last chance" - prompt for "triple play" before gameover

 package require Tk 8.3

 array set S {title "Gem Game" version 1.5.7 cols 10 rows 10 cell 30 jewels 7}
 set S(w) [expr {$S(cell) * $S(cols) + 10}]
 set S(h) [expr {$S(cell) * $S(rows) + 10}]
 set S(delay) 10
 set S(mute) 0
 set S(lvl) 2
 #set S(strlvl) "Level 2"
 #set S(strjew) "7 Jewels"
 # old - 2: Blue,Green 3:Yellow 4:Red 5:White 6:Cyan 7:Magenta 8:Grey
 # new -       ...     3:Red 4:White 5:Yellow ...
 array set S {lvl,1 0 lvl,2 180 lvl,3 90 lvl,4 60 lvl,5 30}

 proc DoDisplay {} {
    wm title . $::S(title)
    CompressImages

    option add *Label.background black
    frame .ctrl -relief ridge -bd 2 -bg black
    canvas .c   -relief ridge       -bg black -height $::S(h) -width $::S(w) \
        -highlightthickness 0 -bd 2 -relief raised

    label .score -text Score: -fg white
    .score configure  -font "[font actual [.score cget -font]] -weight bold"
    option add *font [.score cget -font]

    label .vscore  -textvariable S(score)  -fg yellow
    label .vscore2 -textvariable S(score2) -fg yellow
    label .ltimer  -text Time: -fg white
    label .timer   -textvariable S(timer)  -fg yellow

    button .new -text "New Game" -underline 0 -command NewGame 
 #  tk_optionMenu .optlvl S(strlvl) "Level 1" "Level 2" "Level 3" "Level 4" "Level 5"
 #  .optlvl config -highlightthickness 0
 #  trace variable ::S(strlvl) w Tracer
    button .opt -text "Options"  -command {OptMenu .}

 #  tk_optionMenu .optjew S(strjew) "3 Jewels" "4 Jewels" "5 Jewels" "6 Jewels" "7 Jewels" "8 Jewels"
 #  .optjew config -highlightthickness 0
 #  trace variable ::S(strjew) w Tracer

    button      .hint  -text "Hint"       -underline 0 -command Hint
    bind .c <Button-3> {Hint 2}
    bind .c <h>         Hint
    bind .c <H>         Hint
 #  button      .bstat -text "Statistics" -underline 0 -command ShowStats
    button      .pause -text "Pause"      -underline 0 -command Pause
    button      .about -text "About"      -command About
 #  checkbutton .mute  -text "Mute"       -variable S(mute)
    bind .c <M>         Mute
    bind .c <m>         Mute

    pack .ctrl -side left -fill y    -ipady 5 -ipadx 5
    pack .c    -side top  -fill both -expand 1

    grid .score   -in .ctrl -sticky ew -row 1
    grid .vscore  -in .ctrl -sticky ew
    grid .vscore2 -in .ctrl -sticky ew
    grid .ltimer  -in .ctrl -sticky ew
    grid .timer   -in .ctrl -sticky ew

    grid rowconfigure .ctrl 20 -minsize 10
    grid .opt     -in .ctrl -sticky ew -row 25 -pady 1
    grid .new     -in .ctrl -sticky ew         -pady 1
 ## grid .optlvl  -in .ctrl -sticky ew -pady 1
 #  grid .optjew  -in .ctrl -sticky ew -pady 1

 ## grid .mute    -in .ctrl -sticky ew -pady 1
 ## grid .bstat   -in .ctrl -sticky ew -pady 1

    grid rowconfigure .ctrl 40 -weight 1
    grid .pause   -in .ctrl -sticky ew -row 45 -pady 1
    grid .hint    -in .ctrl -sticky ew         -pady 1

    grid rowconfigure .ctrl 60 -weight 4
    grid .about   -in .ctrl -row 100 -sticky ew -pady 5

    bind all <F2> {console show; puts "GemGame-Console:"; \
         puts -nonewline "set S(jewels) "; puts $S(jewels); \
         puts -nonewline "set S(rows) ";   puts $S(rows); \
         puts -nonewline "set S(cols) ";   puts $S(cols) }
    bind .c <R> Robot
    bind .c <r> {Robot 10}
    bind .c <x> {Robot  1} ;#debug
    bind .c <z> Resize
    bind .c <n> NewGame
    bind .c <N> NewGame
    bind .c <p> Pause
    bind .c <P> Pause
    bind .c <s> ShowStats
    bind .c <S> ShowStats
    focus .c
 }

 proc OptMenu w {
    destroy .m
    menu .m        -tearoff 0
    menu .m.cols   -tearoff 0
    menu .m.rows   -tearoff 0
    menu .m.jewels -tearoff 0
    menu .m.level  -tearoff 0
    for {set i 6} {$i <= 16} {incr i} {
      .m.cols   add radiobutton -label $i -value $i -variable S(cols)   -command {NewGame}
      .m.rows   add radiobutton -label $i -value $i -variable S(rows)   -command {NewGame}
    }
    for {set i 3} {$i <= 8} {incr i} {
      .m.jewels add radiobutton -label $i -value $i -variable S(jewels) -command {NewGame}
    }
    for {set i 1} {$i <= 5} {incr i} {
      .m.level  add radiobutton -label $i -value $i -variable S(lvl)    -command {NewGame}
    }
   .m add cascade     -label "Cols"       -menu .m.cols
   .m add cascade     -label "Rows"       -menu .m.rows
   .m add cascade     -label "Jewels"     -menu .m.jewels
   .m add cascade     -label "Level"      -menu .m.level
   .m add separator
   .m add checkbutton -label "Mute"       -underline 0 -variable S(mute)
   .m add command     -label "Statistics" -underline 0 -command ShowStats
    tk_popup .m [winfo pointerx $w] [winfo pointery $w]  ;# pos. of cursor
  # tk_popup .m [winfo rootx $w] [winfo rooty $w]        ;# upper left corner
 }

 proc CompressImages {} {
    image create photo ::img::img(0)            ;# Blank image
    foreach id {1 2 3 4 5 6 7 8} {
        foreach a {2 3 4} {                     ;# We need narrower images
            image create photo ::img::img($id,$a)
            if {$a == 4} continue
            ::img::img($id,$a) copy ::img::img($id) -subsample $a $a
        }
    }
 }
 #proc Tracer {var1 var2 op} {
 #   if {$var2 == "strlvl"} {
 #       scan $::S(strlvl) "Level %d" lvl
 #       if {$lvl != $::S(lvl)} NewGame
 #       return
 #   }
 #   if {$var2 == "strjew"} {
 #       scan $::S(strjew) "%d Jewels" jew
 #       if {$jew != $::S(jewels)} NewGame
 #       return
 #   }
 #}
 proc NewGame {} {
    Timer off
  # scan $::S(strlvl) "Level %d"  ::S(lvl)
  # scan $::S(strjew) "%d Jewels" ::S(jewels)
    array set ::S {
        score 0 score2 "" busy 0 click {} click1 {} click2 {} pause 0
        cnt 0 time 00:00 sturn 0 tmin 0 best 0 robot 0 tbonus 0 tpause 0
    }
    set ::S(timer) $::S(lvl,$::S(lvl))

    if {$::S(lvl) > 1} {
        .hint   config -state disabled
        .ltimer config -fg white
        .timer  config -fg yellow
    } else {
        .hint   config -state normal
        .ltimer config -fg black
        .timer  config -fg black
    }
    .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() * $::S(jewels))}]
            .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() * $::S(jewels))}]
        }
    }
    DrawBoard 1
 }
 proc DrawBoard {{resize 0}} {
    global S

    if {$resize} {
        set S(w) [expr {$S(cell) * $S(cols) + 10}]
        set S(h) [expr {$S(cell) * $S(rows) + 10}]
        .c config -height $S(h) -width $S(w)
    }

    .c delete box
    for {set row 0} {$row < $::S(rows)} {incr row} {
        for {set col 0} {$col < $::S(cols)} {incr col} {
            if {$resize} {
                .c coords "c$row,$col" [GetXY $row $col]
            }
            .c itemconfig "c$row,$col" -image ::img::img($::B($row,$col))
        }
    }
    set ::S(legal) [llength [FindLegalMoves 0]]
 }
 proc GetXY {r c} {
    global S
    set x [expr {5 + $c * $S(cell) + $S(cell)/2}]
    set y [expr {5 + $r * $S(cell) + $S(cell)/2}]
    return [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
        if {$::S(timer) <= 0 && $::S(lvl) > 1} {
            GameOver "Out of time"
        }
        return
    }

    foreach {row1 col1} $S(click) break         ;# 2nd click, swap and explode
    set click [list [concat $S(click) $row $col]]
    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} {                               ;# Something exploded
            set click {}                        ;# Clear for triple play
            incr S(cnt)
            incr S(tbonus) [expr {6 - $S(lvl)}] ;# Add to time bonus
        } else {                                ;# Nothing exploded
            # Check for triple click
            if {$click == $S(click1) && $click == $S(click2)} {
                # decrease score by 10%...
                set ten [expr {round($S(score) / -10.0)}]
                if {$ten > -100} { set ten -100}
                incr S(score) $ten
                set S(score2) "($ten)"
                set click {}
                if {! $S(mute)} {catch { snd_bad play; snd_ok play }}
                incr S(cnt)
            } else {
                if {! $S(mute)} {catch { snd_bad play }} ;# Nope, undo the move
                SwapCells $row1 $col1 $row $col
            }
        }
        set S(click2) $S(click1)
        set S(click1) $click
        if {! [Hint 1]} {                       ;# Is the game over???
            GameOver
        }
    }
    set S(legal) [llength [FindLegalMoves 0]]
    set S(busy) 0
    catch {
        set ::S(sturn) [format "%.1f" [expr {$::S(score) / double($::S(cnt))}]]
    }
    if {$::S(cnt) == 1} {Timer start}
    if {$::S(timer) <= 0 && $::S(lvl) > 1} {
        GameOver "Out of time"
    }

 }
 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() * $::S(jewels))}]
        }
        .c create image [GetXY $r $c] -image ::img::img($M($r,$c)) -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 $::S(delay)
    }
    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)) -tag {slide1 slide}
    .c create image $x2 $y2 -image ::img::img($B($r2,$c2)) -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 $::S(delay)
    }
    .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]
        if {! $::S(mute)} {catch { snd_ok play }}
        ExplodeCells $cells                     ;# Do the explosion affect
        CollapseCells                           ;# Move cells down
    }

    set n [expr {$cnt * $cnt}]
    incr ::S(score) $n
    set ::S(score2) ""                          ;# Show special scores
    if {$cnt > 3} {set ::S(score2) "([expr {$cnt*$cnt}])"}
    if {$n > $::S(best)}  {set ::S(best) $n }
    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 [expr {10 * $::S(delay)}]
    }
 }
 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]
 }
 # 0 => 1 hint, 1 => is game over, 2 => all hints
 proc Hint {{how 0}} {
    if {$how == 0} {
        if {$::S(pause) != 0} return
        incr ::S(score)   -50
        set  ::S(score2) (-50)
        if {$::S(cnt) > 0} {
            set ::S(sturn) [format "%.1f" [expr {$::S(score)/double($::S(cnt))}]]
        }
    }
    .c delete box
    set S(click) {}

    set hints [FindLegalMoves $how]
    set len [llength $hints]
    if {$how == 1} {return [expr {$len > 0 ? 1 : 0}]}
    if {$how == 0} {                            ;# Highlight only 1 hint
        set hints [list [lindex $hints [expr {int(rand() * $len)}]]]
    }

    foreach hint $hints {                       ;# Highlight every hint
        foreach {r c} $hint { .c addtag hint withtag c$r,$c }
        .c create rect [.c bbox hint] -outline white -width 3 -tag box
        .c dtag hint
    }
    return $hints
 }
 proc FindLegalMoves {how} {
    global S B

    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}

    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
                lappend hints [list $r $c [expr {$row+$dr3}] [expr {$col+$dc3}]]
                if {$how == 1} { return $hints }
            }
        }
    }
    return $hints
 }
 proc About {} {
    set msg "$::S(title) v$::S(version)\nby Keith Vetter, June 2003\n"
    append msg "Based on a program by Derek Ramey\n\n"
    append msg "Click on adjacent gems to swap them. If you get three or\n"
    append msg "more gems in a row or column, they will explode and those\n"
    append msg "above will drop down and new gems will fill in the top.\n"
    append msg "The game ends when you have no more moves.\n\n"

    append msg "The score for a move is the square of the number of cells\n"
    append msg "exploded. Asking for a hint costs 50 points.\n"
    append msg "If you are insistent and repeat an illegal move three times,\n"
    append msg "it will do it, but cost you 10% of your score.\n\n"

    append msg "Keyboard-shortcuts:\n"
    append msg "N: New Game\n"
    append msg "P: Pause\n"
    append msg "H: Hint\n"
    append msg "M: Mute: Sound on/off\n"
    append msg "S: Statistics on/off\n"
    append msg "z: Resize \n"

    tk_messageBox -message $msg -title "About"
 }
 proc GameOver {{txt "Game Over"}} {
    .c create rect 0 0 [winfo width .c] [winfo height .c] \
        -fill white -stipple gray25
    set x [expr {[winfo width  .c] / 2}]
    set y [expr {[winfo height .c] / 2}]
  # .c create text [GetXY 4 5] -text $txt -font {Helvetica 28 bold} 
    .c create text $x $y -text $txt -font {Helvetica 28 bold} \
        -fill white -tag over
    .c delete box
    .hint  config -state disabled
    .pause config -state disabled
    Timer off
    ShowStats 1
 }
 proc DoSounds {} {
    proc snd_ok  {play} {}                      ;# Stub
    proc snd_bad {play} {}                      ;# Stub
    if {[catch {package require base64}]} return
    if {[catch {package require snack}]}  return

    set s(ok) {UklGRkACAABXQVZFZm10IBAAAAABAAEAESsAABErAAABAAgAZGF0YRwCAACAgId0Z
        HZbU5aMj7/MsIZ6UX6nWIiITWiIRUGUlZesvrGCiKiKTl96Fit3YF5emrGHqcqhlJuAdWxgW
        01EbWSHubW1uJ2MkqGPYFVSamtvgHmEh5ybraWLkHp5Xm5oWGRvb3WSlYqMi4+JhY6Ac25xd
        Xp5jYR/hoODdIN8e356goCHgoqGgIV/g35/d3N2eHZ6gIOIgouHioaNioGAfHpycHp2dH2Hi
        ouNiYiKhIF9enZzd3l+dX2BgYKIjoaJhIJ/fX6AfHl8fICAgICEgISFhYF/gH+AfIJ/gH6Af
        X6AfICAfYB+gn2DfoGAgIOAgYB8e3x9gIKChYCDgIN/g32Afn+BgIF+gH+BgIOAgX2CfYGAg
        IB/gH9/fIB/gICBgH+Df4KAgIB9gHuBfYKAgoCAhICDgIN+gH+Af4CAgIGAg4CFgIOAgICAg
        H9/f32AfoF/gn+BgICAf4B/gICAgICAgIKAgYCAgH+AfYB8f4CAgoGBgIKBgHt0cnqEi4yIh
        oKHioOBeoF+gHRvbW10eYSHhoyMmI+PhIF5dm9tbW92fICJjpKRkY6JhHx5b2xlbnWAhYeOj
        pSQkIiAe3R1cnNzdnx/gomLj4yJhICAfHp3d3d6fYKDhoKGgIeAhX1/eXt9foCAg4GCg4CDf
        YF6gHmAfYCBgIR/h4CEf4B9fn98gHuEfYV/g4CAgn6Fe4R6gn1/gHuDe4V+g4CAgn8=}
    set s(bad) {UklGRrEHAABXQVZFZm10IBAAAAABAAEAESsAABErAAABAAgAZGF0YY0HAAB/f39/
        gICAgICAgICAf39/fn9/f4CAgICAf3+AgICBgYGBf359fX5/gIGChISEgX14dXZ6f4OFiIuM
        iYB2bm52foSHio+Sk4x+bWBXY3mHjY2NlZqSg3NtcXp6eHd5goqLiY6Nf2tqeIKLnLGrhmJC
        OWF8h4+xvJJ3WTJTeX6Eja+/mH1qUE5lfoKIlsK6h3tbL2l/go28xIR9Qz15gIq9w31+Qjp2
        f4a0y4yBbkM9b3mDls6zgnY3Q3d5goWSp8yxjoF4VRlVc3iHvdGGhVYlWnt6o9irf4NAKmh2
        fpnYuYOLRytleX2w2KKGg0cpYnZ9sdaiiXc7Qmx0jsbAknUvT32Dw7uhhXo+NGF1g7LPpoqE
        Wj9GYXV+jK3gq4+FVihab3uJv9OWjXdEMmJxjqGsr4xqXm96iH1zflphcoqyv4xvaVNpiZSA
        f4qCgIiloJh+TFRja259nbiphnxnbGJfdpKXmaKPbl1fX26JnKOYe3BiaXqMinyHgn18fYeA
        e29xiot2fYiIi4h7dn+Fl6eMamNmcYGFg5Gbjn56cHVzdYWXnpB+bmhgdIibqqWHbFpUYnGH
        m6igjXlrX1hohJWkjnd2e397en1/b2NufYKSoqqUe2hbVVtte5KjpKKhgmFaZ3B3f5GclYp/
        gnxyamdwgIyapaGOgXFdaHeBhYN9h5eMjImBfm1pfIJ/g46WiXx1cm92gYeKkZeNf3h7fGhb
        aHmAkamqnIt1X09Vb3+PoqSQhXFcYXGAhI+moYp2alZRbIKLm62tmHtkTk9hc4KVpKmehHBl
        Xmh4hI6TlpOMdmpnaHOBi5OUjoRwcG5tfIWLj5GPgXl8fXyChICDeWptd3qCiYyLjI2BfYJ9
        d3d3fIB/h4h+enh+g4OHhoKAeXV5gIOCgoOAfHd7gYeNj4+LgXNsam12foOMjYqLhoB+eXqD
        hYeMhHVtam55h4yNjYd/fH18fH6AgYGCgoWJhnxxbnR8g4uQjIN7eXt5e36AgYGEh4N8eXp+
        goSEg358e3l7gIGEh4WDgHl3eHqAhYeIhoJ7dnV3fYKEhoWDgHt8gYSGhX95dXV3fYSJiYWD
        fXl6e31+gYSEg4SCfXp4d3Z5gYmNjIh+c3F0e4OHiYuKhX56eHh5fYGDg4F/fn1/hYaDgX16
        eHl9gIOFh4mGgHx6d3Z6gYaJiIWCfXl4eXyBhIOBfn+Cg4SFg396dHJ0eoOLjouFgH57e36A
        gH58enp7fYCFioiFgX17ent9fH+Cg4F/fn+Af3+AgYODg4OBfnt4d3l8foGFiYmGg4F/e3h2
        d3uAhIaHhYJ+e3t+gIGChIOAfXp5eXt+gIOFhoOCg4F+fX19fXx8fX6AgYKDgX9/goOCgH58
        e3l5fICDhYaFg4B9fn9+fXx8fH6AgoSFhYKAfnp6e35/gYKDgoB/f3+AgIGCgICAgIGBfnp4
        eHyAhouNi4V8c29xeYGIjY2Gfnh1eHyBg4ODg4F+fX5+fXt7fYCEiImGgXx2dHd9g4eIh4WB
        fXp5e36ChoaDf3p4eXx+gYWGhYKAfXp7fH6Ag4SDf318fH1+gYSEgoB9fH1/goODgYB9e3t8
        gISIiIaAenZ2eX2Ch4qIhYB6d3h6foGFh4aDgH17ent9f4GCg4OCgX9+fX19fXx9gIKEhYSB
        fnt6enx/g4SDgYB/fn59fX1+gIGBgoOCf3x7fH1/gYODgH9/f39/gYGAf318e31/goOEhIJ/
        fHp6fYCDhYWDf3x6e32Ag4WFhIF+fHt8fX+AgYOEhIF/fHp6fYGEhYWDf3t6e32Ag4aGg397
        enp7foCCg4OCgH9+fn5+f4CBgYGAf359fX5+foGDhIWFgn57eHh6foKFhoSAfHp6fICEh4eD
        fnp4eHt/goSFhIF+fHx9gIKDgoF/fXx8fn+BgoKCgYCAf359foCAgYB/fn9/f4CBgYB+fn+A
        gYKCgX99fX1+gIGCgoGAfn18fX5/gYOEg4F+fHt7fX+Cg4OCgH58fHx+gIOEhIOBfnx7e31/
        gYOEhIKAfXx8fn+AgYGAf35+f3+BgoKBgH99fX5/gIGBgYB/fn1+f4GDg4OAfnx8fH6AgoOD
        gX59fX5/gYGBgIB/f3+AgYGBgH9+fn5/f4CAgICAgH9+fX5+gIGCgoF/fn19fX+AgoKCgYB/
        fn19foCBgoKAf359fn5/gIGBgIB/f39+fn5+f4CBgoKBgH9+fX1+gIGBgYGAgH9/fn9/f39/
        f3+AgICAgICAgIB/f39/f4CAgICAgICAgYCAf35+f39/gIGAgH9+fn5/gIGCgoB/fn1+fn+A
        gYGAf39/f3+AgICAgIB/f39/f3+AgICAgICAgH9/fn5/f4CAgIB/f39/gICAgIB/f35+fn9/
        gIGBgIB/f39/f39/f39/f39/f4CBgYGBgH9+fX1+gIGCgoGAfn5+fn+AgYGAf35+fn5/gIGB
        gYB/f35+f3+AgICAf39/f3+AgICAgH9/f39/gICAf39/f3+AgICAgICAf39/f3+AgICAgICA
        f39/f39/gICAgIB/f4CAgH9/f39/f3+AgICAgICAf39/f4CAgICA}
    foreach snd {ok bad} {
        regsub -all {\s} $s($snd) {} sdata            ;# Bug in base64 package
        sound snd_$snd
        snd_$snd data [::base64::decode $sdata]
    }
 }
 image create photo ::img::img(1) -data {
    R0lGODdhHgAeALMAAAAAAAAAyAAAKAAA6EhI2FBQ/xAQSBgQSDAw////////////////////////
    /////ywAAAAAHgAeAAAE/xDISau9OOvN+4RBhBDCCCEIQggshRAiAgRyyhCCCWGMEWAQhJRSCBEh
    BAjkBMLAI+cxUkAjpxBCQCBnCOHAImchIEAkpxSEQCBlGOHAIqc0EMk5DSEQSBlGOAQWOYuBSM5p
    SIFAyjDCgUXOQg5Eck5TCgRShhEOLHIWciCScxpSIJAyjHBgkVMeiOSchhQIpAwjHFjklAYiOach
    BAIpwwgHFjkLORDJOQ0hEEgZQjiwyEkIgEhOGQQhEEhpjDnHnHOMgUIaKaUUEMhJCDEBIjmDgEHO
    KSQEUpJCDERyShHgkHMEEQIEUpJCDERyShHgkHMEEwIEUpJCBERyShHgkIJzBBECBFKSQgxEckoR
    4JBzBBECBFKSQgxEckoT4JBzBBECBFKSQgxEckoR4JBzBBMCBFISQkSASM4gYJBzCgmBnMYIIYwR
    xggohDFCGCOEEBDICUIIYowxQoBBEEJKIUSMQSCQE5wAQhhjhAADKISUQgg55EAgpzwQyEmrvTjr
    zW8EADs=}
 image create photo ::img::img(2) -data {
    R0lGODdhHgAeAJEAAAAAABDgAGj/WP///ywAAAAAHgAeAAACzISPqcvtDyMi8YHkA8Un+EjxgeQD
    xSf4R/EDSD5Q/CD4QPEDSL4BxQ+CT/EDSL4BxQ+Cj6nLQPGB5BtQ/CD4QPGB5BtQ/CD4RvGB5APF
    D4J/FB9IPlD8IPhIsYHkA8Un+GgREQTKB4pN8PEoNpBsoNgEHzEigiCJAMUm+JgQEQRJBCKCQviY
    FhEESQQigkL4mBcRBEkgIgg+JkYEQRKICIKPmRFAMiIIPqZCAEmIIPiYahEEIYLgY+oFkBCCj6kq
    u7sAEeFj6nL7wxhJAQA7}
    image create photo ::img::img(5) -data {
    R0lGODdhHgAeAJEAAAAAAP//QOjwAODgACwAAAAAHgAeAAACxISPqctLgQg+pmYEQSL4mHoRFEiE
    4GMqRFACERGCj5kUG0g2wcc8ig8kn+BjAsUPIPlC8BEpvgHJN4KPRvEPSP4RfKT4CCQfCb5RfAwg
    +SgEn+KjAclHAwCg+HhA8vEIPqZuknw8oPl4AAAkHw1oPhrBJ/koQPNxCL6RfASajwQfSf4BzT+C
    j0byDWi+EXxEki9A84fgYwLJB5pP8DGPZAPNJviYKSIkbGYIPqaCCAmbIfiYeiKEjeBjagrQCB9T
    l9ufkQIAOw==}
 image create photo ::img::img(3) -data {
    R0lGODdhHgAeAJEAAAAAANAAAP8AAP84OCwAAAAAHgAeAAAC/4SPqcvtD0h8zAAh+CgCFB8TRAi+
    iQhQfEQQEYIPJBsoPh6ICInwSTZQfDQg2QQ7TESEwPgYICIEyCwijCRQfAQRAJIBABQbQODuCKZs
    AACKHwQfjeQLAADFN6D5BiTfAAAovgHNNyD5BgBA8Q1ovgHJNwAAim9A8w1IvgEAUHwDmm9A8g0A
    gOIb0HwDkm8AABTfgOYbkHwDAKD4BjTfgOQbAADFD4KPRvIFAIBiAwiQfAMBQCEYEWEiBMpHmAEg
    SAAAAQRJBEg+As0m+ECy4e4OaD7BJtlwdwc0n2CLiADJR4SZoRE+iAiQfESYGYJ/AiQfU2CG4J8A
    yccUGIKPqQK7BQA7}
 image create photo ::img::img(4) -data {
    R0lGODlhHgAeALMAAAAAAFyI/5zO/xtX/3qn/zx1/16T/zF5/2+V/wAwzT9w/6b5/wAduAA75SBg
    /424/yH5BAEAAAAALAAAAAAeAB4AAwT/EMhJq704601ZcyBYOAzDWYNYHGx7NKfUDEqxujjJJU5d
    BECD0HAgtkwZnmIJDAwJUILwiGHQFIFfAGFAEB4PgeAhZTkwg6sW4SWIF/CFoPyyfJbYLfsriMfn
    RkgTDXhMbF5vfnAPgR2FQAh6YYpxZEaOhVh7bn2UgAdnEwyPkGxglHCfB5h4pV5hnX+MRAWsTKVQ
    sLJQl6KZeYe5YmJgUrS2t3qvX8zGZhVXpMptUVwGAXUUhL+uwdZABwWCEqPcwIfo4AMX5ZkBCpGQ
    W00jVdGPeU1ANgowGff4gGCp0Y8DwF94HCSIkQBhIQcDxnHwALBHA38xKpTYWCKjx48gAytEAAA7}
 image create photo ::img::img(6) -data {
    R0lGODdhHgAeAJEAAAAAAIDw/xjo/1jo/ywAAAAAHgAeAAACv4SPqcvtD6OcjMTHI/iYIEDxMWAI
    PqKIAMU/mBmCj0ayCf7RbIKPJBto/gEOwTeSDTQfB5Lgk2yg+XiQAARQNtB8TEgAAiQCNB/T4IAA
    BAjQfEyEARoAEUDzMRUMCEgAzcdUMCAgIEDzMRECaACAiADNxzSIoAAAJBtoPiZQbAAAkg00Hw8o
    NsEn2UDzcYBiE3wj2UDzDyg2wUeSTfCPYhN8NBEBkn8QEQQfUYDko0AQfEwg+XgEH1OX2x9GORsp
    ADs=}
 image create photo ::img::img(7) -data {
    R0lGODlhHgAeALMAAAAAANtNyeId0/8A/wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    AAAAACH5BAAAAAAALAAAAAAeAB4AAwSWEMhJq703AMG7/8KGAUG5gegZWmWroty7Tm0tf/dc72Me
    SzvTYEgs5iYhXnFJlJEkMRdzOlCRNFYNlSpyvQDb7dX0DXNtZTNzjPWA1Us2tPOGN9FuuxFP19+9
    eX5VfDGCg4B9gnJZdXBdZFFCjnSQbFpmTliWklwpQEFkGDA6QZs2njQ2oDw4LCarpXQYGrCgIj24
    uQARADs=}
 image create photo ::img::img(8) -data {
    R0lGODlhHgAeALMAAAQCBATO/GSazDRmnJzO/KyqrDRmzHcAAMjAyNGz71/tEwB3AHg6AQEAABMA
    AAAAACH5BAEAAAAALAAAAAAeAB4AAwR5EMhJq704640L/1NBeOAmnmV2jmNqrbAbsl7s2gD+2YGk
    a7xAL0fjBIXDX+WITBYvzKYTtXxKr74npSDgkq5I36Aw7nS7ErCYTDJ708112XT+CuVt+huQHM9B
    Xmh4MoE1fnkphYcyW10GbIxLXX+RIZSVIZiam5wbEQA7}

 proc Robot {{cnt -1}} {
    global S

    if {$S(robot)} {                            ;# Already going
        set S(robot) 0
        return
    }
    set S(robot) 1
    .pause config -state disabled

    if {$cnt == -1} {
        foreach {delay S(delay)} [list $S(delay) 0] break
        foreach snd {ok bad} {                  ;# Disable sound
            rename snd_$snd org.snd_$snd
            proc snd_$snd {play} {}
        }
    }

    for {} {$cnt != 0} {incr cnt -1} {
        if {! $S(robot)} break
        set moves [FindLegalMoves 2]
        if {$moves == {}} break

        # Massage data by adding a sorting key
        set all {}
        foreach m $moves {
            foreach {r1 c1 r2 c2} $m break

            # Top most
            set mm [concat [expr {$r1 < $r2 ? $r1 : $r2}] $m]
            # Random
            #set mm [concat [expr {rand() * 10000}] $m]
            # Bottom most
            #set mm [concat [expr {$r1 > $r2 ? -$r1 : -$r2}] $m]
            lappend all $mm
        }
        set all [lsort -index 0 -integer $all]
        set move [lindex $all 0]

        foreach {. r1 c1 r2 c2} $move break
        DoClick $r1 $c1
        DoClick $r2 $c2
    }
    set S(robot) 0
    if {$cnt < 0} {
        set S(delay) $delay
        foreach snd {ok bad} {   ;# Re-Enable sound
            rename snd_$snd {}
            rename org.snd_$snd snd_$snd
        }
    }
    .pause config -state normal
 }

 proc Timer {{how go}} {
    global S
    foreach a [after info] { after cancel $a }

    if {$how == "off"} return
    if {$how == "start"} { set S(tstart) [clock seconds] }

    set sec [expr {[clock seconds] - $S(tstart)}]
    set pause 0
    if {$S(pause) != 0} {
        set pause [expr {[clock seconds] - $S(pause)}]
    }
    set sec [expr {$sec - $pause - $S(tpause)}]

    if {$sec < 3600} {
        set S(time) [clock format $sec -gmt 1 -format %M:%S]
    } else {
        set S(time) [clock format $sec -gmt 1 -format %H:%M:%S]
    }
    if {$sec > 0} {
        set S(tmin) [format "%.1f" [expr {60.0 * $S(cnt) / $sec}]]
    }
    set S(timer) [expr {$S(lvl,$S(lvl))-$sec+$S(tbonus)+$S(tpause)}]
    if {$S(timer) < 0} {set S(timer) 0}

    if {! $S(busy) && $S(timer) <= 0 && $S(lvl) > 1} {
        GameOver "Out of time"
        return
    }
    after 1000 Timer
 }

 proc Mute {} {
    global S
    if {$S(mute) == 0} {
      set S(mute) 1
    } else {
      set S(mute) 0
    } 
 }
 proc Pause {} {
    global S

    if {$S(pause) == 0} {                       ;# Pause on
        if {$S(cnt) == 0} return                ;# Not started yet
        set S(pause) [clock seconds]
        .c create rect 0 0 [winfo width .c] [winfo height .c] \
            -fill black -tag pause
        set x [expr {[winfo width  .c] / 2}]
        set y [expr {[winfo height .c] / 2}]
      # .c create text [GetXY 4 5]         -font {Helvetica 28 bold} 
        .c create text $x [expr {$y - 15}] -font {Helvetica 28 bold} \
            -fill white -tag pause -text "PAUSED" -justify center
      # .c create text [GetXY 6 5]         -font {Helvetica 12 bold} 
        .c create text $x [expr {$y + 15}] -font {Helvetica 12 bold} \
            -fill white -tag pause -text "Press p to continue" -justify center
        .c delete box
    } else {                                    ;# Pause off
        incr S(tpause) [expr {[clock seconds] - $S(pause)}]
        set S(pause) 0
        .c delete pause
    }
 }
 proc ShowStats {{on 0}} {
    set w .stats

    if {[winfo exists $w]} {
        if {! $on} {destroy $w}
        return
    }
    toplevel $w -bg black
    wm title $w "$::S(title)"
    wm geom $w "+[expr {[winfo x .] + [winfo width .] + 10}]+[winfo y .]"

    label $w.title  -text "$::S(title) Statistics" -fg white -relief ridge
    label $w.lscore -text Score:                   -fg white
    label $w.vscore -textvariable S(score)         -fg yellow
    label $w.lturn  -text "Turns:"                 -fg white
    label $w.vturn  -textvariable S(cnt)           -fg yellow
    label $w.lsturn -text "Score/turn:"            -fg white
    label $w.vsturn -textvariable S(sturn)         -fg yellow
    label $w.lbest  -text "Best:"                  -fg white
    label $w.vbest  -textvariable S(best)          -fg yellow
    label $w.ltime  -text "Time:"                  -fg white
    label $w.vtime  -textvariable S(time)          -fg yellow
    label $w.ltmin  -text "Turns/minute:"          -fg white
    label $w.vtmin  -textvariable S(tmin)          -fg yellow
    label $w.lgood  -text "Legal Moves:"           -fg white
    label $w.vgood  -textvariable S(legal)         -fg yellow

    grid $w.title -
    grid $w.lscore $w.vscore
    grid $w.lturn  $w.vturn
    grid $w.lsturn $w.vsturn
    grid $w.lbest  $w.vbest
    grid $w.ltime  $w.vtime
    grid $w.ltmin  $w.vtmin
    grid $w.lgood  $w.vgood
 }
 proc Resize {} {
    if {[lsearch [image names] ::img::img(1).org] == -1} {
        foreach id {1 2 3 4 5 6 7 8} {
            image create photo ::img::img($id).org
            ::img::img($id).org copy ::img::img($id)
        }
    }
    set zoom [expr {$::S(cell) == 30 ? 2 : 1}]
    foreach id {1 2 3 4 5 6 7 8} {
        image delete ::img::img($id)            ;# For easier resizing
        image create photo ::img::img($id)
        ::img::img($id) copy ::img::img($id).org -zoom $zoom
    }
    CompressImages
    set ::S(cell) [image width ::img::img(1)]
    DrawBoard 1
 }

 DoDisplay
 DoSounds
 NewGame

  • ccbbaa - 20170825-1 ; initial commit to wiki
  • ccbbaa + 20170825-2 ; updated, fixed 2 small bugs which prevented operation when not in wifi/etc range
  • ccbbaa + 20170827 ; updated, fixed several small bugs, better androwish operation, HELP WANTED
    See in file header comments at SUGGESTED TESTING METHOD (HELP WANTED)

I made a new version of TkGems called TkGems2.tcl which is ported to androwish. And alpha tested by a few people (at least others read the source). New features:

  • The same program runs on PC under wish and on Android under androwish, minimal differences.
    Best viewed in kdiff3 etc compared with TkGems.tcl from above to see the differences.
  • Saves a high score file on both pc and androwish
  • Handles device's app closing / Back button and Menu keys on androwish
  • Modified snack code to make sounds when load is high (snack threads are preempted apparently).
  • Debug console using tkconclient on telnet port default 22222
  • The current version is ALPHA for testing only, with special instrumentation to hunt library
    and device bugs. Does not endanger your device or data in any (known) way.
#!/bin/sh
# the next line restarts using wish \
exec wish "$0" "$@"
#################################################################
 #
 # GemGame -- based on a game by Derek Ramey and others
 # by Keith Vetter -- May 2003
 #
 # mods for androwish
 # v0.2 - plp / abc 2017
 # note: save this file as TkGems2.tcl
 #
 # Also known as Elf balls, Santa Balls and Santa Balls 2
 # http://www.afunzone.com/Kewel/santaballs.htm
 # Flip the Mix w/ M&M's: http://www.afunzone.com/mm.htm
 # Carnival Jackpot (hex): http://www.afunzone.com/Kewel/CarnJackpot.htm
 #
 # See http://javaboutique.internet.com/GemGame/
 #
 # 2003/06/12: zoom, robot on key, 8th jewel, resizable via console
 # 2003/06/13: timer levels
 # 2003/06/24: mute and pause
 # 2005-05-25: pause-button; Keys: "S": ShowStats, "H": Hint; Console-Message
 # 2005-05-26: Select number of jewels, re-arranged jewel-colors and buttons
 # 2005-05-28: System-Menu to set cols, rows, jewels
 # 2005-05-31: Options-Menu: set cols, rows, jewels, level, mute, stats
 # 2005-06-01: Center pause + gameover-messages on all playfield-sizes
 #
 # Bugs:
 # * Timer increments while paused
 # * Resize+Robot: while paused & after game-over
 # Todo:
 # * Support for Keyboard (Cursor-Keys)
 # * Highscore
 # * Profile: Save/Load Options
 # * Robot/Sortkey: calc. number of exploding gems for move --> optimize play
 # * Random seed --> Robot-Benchmark
 # * detect "triple play" in either direction
 # * "Last chance" - prompt for "triple play" before gameover
 #
 # * v2 _abc_ new bugs and features: androwish: 22-08-2017
 # - the game works on both android and normal pc devices without changes
 # - a telnet debug console is opened at port 22222, where tcl commands can be
 #   issued.
 # - in androwish mode, all panels are toplevels. These are the main game, the
 #   About and the Statistics panels. Fonts are scaled using a hack for small
 #   devices with small screens, other UI tweaks to make the game fit.
 # - Sounds were modified because snack threads may be preempted in the bg when
 #   display updates occur. The sound is delayed using after idle.
 # - A high score file is saved in $env(HOME)/.TkGems2.cfg
 # - Android lifecycle signals are implemented, also some but not all usual menu
 #   actions are implemented using androwish specific buttons (Menu Back).
 # - fix old bug: Pause remains disabled after timeout/game over, re-enable
 # - console commands guarded with catch since the command is not present on unix
 #
 # TBD:
 # - adjust #jewels #cols #rows to match available screen size, save these in
 #   highscore file to allow users to compare scores fairly :)
 #
 # BUGS:
 # - backgrounding app while in portrait mode breaks resume, graphics are not
 #   redrawn. Problems with resume from backgrounded app in androwish, wrong
 #   screen size in sdltk root 0 0; trying to fix it using ScreenHack. It 
 #   mostly fixes it in an ugly way. See below at Suspected reason.
 # SUGGESTED TESTING METHOD (HELP WANTED):
 # - Save this file as TkGems2.tcl, note the game forces landscape mode.
 # - Start the program on a device (Android) using androwish (your version choice)
 # - Try the following: (it's not relevant if you play or not):
 #
 #   Start device  | Orient. when     | Orient. when restarting  | Outcome
 #   orientation   | when press. Back | using Android app manager| OK/NG
 #   ======================================================================
 #    Portrait     | Portrait         | Portrait                 | 1
 #   --------------+------------------+--------------------------+---------
 #    Portrait     | Port.            | Landscape                | 2
 #   --------------+------------------+--------------------------+---------
 #    Portrait     | Land.            | Port.                    | 3
 #   --------------+------------------+--------------------------+---------
 #    Portrait     | Land.            | Land.                    | 4
 #   --------------+------------------+--------------------------+---------
 #    Land.        | Port.            | Port.                    | 5
 #   --------------+------------------+--------------------------+---------
 #    Land.        | Port.            | Land.                    | 6
 #   --------------+------------------+--------------------------+---------
 #    Land.        | Land.            | Port.                    | 7
 #   --------------+------------------+--------------------------+---------
 #    Land.        | Land.            | Land.                    | 8
 #   --------------+------------------+--------------------------+---------
 #
 # Expected OK outcome: game screen restores and you can continue playing
 # Unexpected NG outcome: game screen is not full screen and or broken/rotated
 #   play may be possible or not, with "misplaced" buttons (sensitive areas).
 #   telnet $device_ip 22222 followed by commands like sdltk root etc does not
 #   fix it. Backgrounding and restarting from bg again does sometimes fix it
 #   after 2-3 tries (!). All situations where the 1st column above is 'Portrait'
 #   are suspect. I.e. cases 1 2 3 4, also cases where restore is commanded in
 #   Portrait mode, i.e. additionally 5 and 7.
 #
 # Suspected reason: Android internals prevent the data source(s) of sdltk root
 # sdltk viewport and borg screenorientation from being in sync when the app
 # starts under certain (higher load?) conditions. This results in conflicting
 # internal data in sdltk and borg and or android which cannot be fixed other
 # by backgrounding the app and repeating the whole process hopefully with a
 # better outcome. Is this true? Has anyone else seen this problem? ScreenHack
 # mimics the actions which are suspected to cause the problem, with delays, to
 # allow the updates to occur. It almost works most of the time. It will go away.
 # - ccbbaa
 #
 # Yes, I hope someone has the patience to try this. I did :) It's in the
 # interest of progress. You can also report the output of:
 # - set fd [open /assets/VERSION r]; puts [read $fd]; close $fd
 # - my output [ccbbaa]: The Wow! Signal (2016-08-15)
 #

 package require Tk 8.3

 catch {console hide}

 set ::wfnt systemfont
 set ::A 1 ;# assume; note we can use [sdltk android] to check we're on android
 if {[catch {package require borg} err]} {
   set ::A 0

   proc borg {cmd msg {long 0}} { ;# put a message on the canvas, in non borg wish
     update
     update idletasks
     catch {.c delete top_msg}
     .c create text \
       [expr {[.c cget -width]/2}] [expr {[.c cget -height]/2}] \
       -justify center -text $msg -tags top_msg \
       -disabledfill #ffffff
     .c itemconfigure top_msg -state disabled
     catch {.c raise top_msg} ;# also in NewGame
     if {![info exists ::borg_tmr] } {
       set ::borg_tmr 0 ;# dummy
     }
   }

 }

 set ::TelnetWishPort 22222         ;# telnet debug port on android
 set ::CheckWishIp    192.168.3.106 ;# check ip, only this one gives shell

 set ::S(highscore)       0         ;# saved to file
 set ::ConfigFile    ".TkGems2.cfg" ;# in env(HOME)

 array set S {title "Gem Game" version 1.5.7 cols 10 rows 10 cell 30 jewels 7 
              abcversion "0.2" over 0}
 set targetDpi 100                  ;# tbd: on borg dpi is known later, adjust?
 set S(w) [expr {$S(cell) * $S(cols) + 10}] ;# tbd: scale canvas objects?
 set S(h) [expr {$S(cell) * $S(rows) + 10}]
 set S(delay) 10
 set S(mute) 0
 set S(lvl) 2
 #set S(strlvl) "Level 2"
 #set S(strjew) "7 Jewels"
 # old - 2: Blue,Green 3:Yellow 4:Red 5:White 6:Cyan 7:Magenta 8:Grey
 # new -       ...     3:Red 4:White 5:Yellow ...
 array set S {lvl,1 0 lvl,2 180 lvl,3 90 lvl,4 60 lvl,5 30}

 # need to really redraw screen, backing store + etc do not keep the old screen
 proc DoRedisplay {} {
    wm state . withdrawn
    wm state . normal
    DoDisplay 1
 }

proc ScreenHack {} { ;# try to cause screen to re-display itself right, on bugy devices?
  borg screenorientation portrait
  update idletasks; after 100
  sdltk root 0 0
  update idletasks ; after 100
  borg screenorientation landscape
  update idletasks ; after 100
  sdltk root 0 0
  update idletasks ; after 100
}

 array set ::bdm {} ;# create
 set ::doDisplayOnce 1
 proc DoDisplay {{redraw 0}} { ;# display or redisplay - redisplay needs saved canvas contents and restore
    if {$::A} {
      # bm keys: density densitydpi width height xdpi xdpi scaleddensity rotation <- == 90 from above
      # note 'our' height is the width etc because of 90 deg rotation in landscape mode
      wm state . withdrawn
      ScreenHack
      array set ::bdm [borg displaymetrics]
      wm attributes . -fullscreen 1
      wm state . normal
      wm resizable . 0 0
    }
    wm title . $::S(title)
    CompressImages

    if {$::doDisplayOnce} { set ::doDisplayOnce 0; catch {
      option add *Label.background black ;# tbd, skin

      if {$::A} {
        frame .ctrl -relief ridge -bd 2 -bg black -height $::bdm(height) ;# forced height
      } else {
        frame .ctrl -relief ridge -bd 2 -bg black
      }
      canvas .c   -relief ridge       -bg black -height $::S(h) -width $::S(w) \
        -highlightthickness 0 -bd 2 -relief raised

      label .hiscore -text "Highscore:" -fg white
      .hiscore configure  -font "[font actual [.hiscore cget -font]] -weight bold"
      if {$::A && (($::bdm(height) <= 320) || ($::bdm(width) <= 320))} { ;# small device hack
          set ::wfnt "[font actual [.hiscore cget -font]] -weight bold -size 5"
          option add *font $::wfnt
          destroy .hiscore
          label .hiscore -text "Highscore:" -fg white
      } else {
        set ::wfnt [.hiscore cget -font]
        option add *font $::wfnt
      }
      label .vhiscore -textvariable S(highscore) -fg red -font $::wfnt

      label .score   -text "Score"           -fg yellow -font $::wfnt
      label .vscore  -textvariable S(score)  -fg yellow -font $::wfnt
      label .vscore2 -textvariable S(score2) -fg yellow -font $::wfnt
      label .ltimer  -text "Time:"           -fg white  -font $::wfnt
      label .timer   -textvariable S(timer)  -fg yellow  -font $::wfnt

      button .new -text "New Game" -underline 0 -command NewGame  -font $::wfnt
 #  tk_optionMenu .optlvl S(strlvl) "Level 1" "Level 2" "Level 3" "Level 4" "Level 5"
 #  .optlvl config -highlightthickness 0
 #  trace variable ::S(strlvl) w Tracer
      button .opt -text "Options"  -command {OptMenu .}  -font $::wfnt
      if {$::A} { ;# android Menu key
        bind . <App> {OptMenu . [winfo rootx .opt] [winfo rooty .opt]}
      }

 #  tk_optionMenu .optjew S(strjew) "3 Jewels" "4 Jewels" "5 Jewels" "6 Jewels" "7 Jewels" "8 Jewels"
 #  .optjew config -highlightthickness 0
 #  trace variable ::S(strjew) w Tracer

      button      .hint  -text "Hint"       -underline 0 -command Hint  -font $::wfnt
      bind .c <Button-3> {Hint 2}
      bind .c <h>         Hint
      bind .c <H>         Hint
 #  button      .bstat -text "Statistics" -underline 0 -command ShowStats
      button      .pause -text "Pause"      -underline 0 -command Pause  -font $::wfnt
      button      .about -text "About"      -command {Pause 1; About}  -font $::wfnt
 #  checkbutton .mute  -text "Mute"       -variable S(mute)
      bind .c <M>         Mute
      bind .c <m>         Mute

      bind all <F2> {catch {console show}; puts "GemGame-Console:"; \
         puts -nonewline "set S(jewels) "; puts $S(jewels); \
         puts -nonewline "set S(rows) ";   puts $S(rows); \
         puts -nonewline "set S(cols) ";   puts $S(cols) }
      bind .c <R> Robot
      bind .c <r> {Robot 10}
      bind .c <x> {Robot  1} ;#debug
      bind .c <z> Resize
      bind .c <n> NewGame
      bind .c <N> NewGame
      bind .c <p> Pause
      bind .c <P> Pause
      bind .c <s> ShowStats
      bind .c <S> ShowStats

      wm protocol . WM_DELETE_WINDOW { CheckWriteHighscore; exit 0 }
      if {$::A} {
        set ::aPauseBusy 0
        proc APause {} {      ;# should save all state
          if {$::aPauseBusy} {return}
          set ::aPauseBusy 1
          Pause 1
          CheckWriteHighscore ;# do NOT lose high score
          update idletasks
          after idle borg withdraw
          set ::aPauseBusy 0
        }
        bind . <Break>                 APause
        bind . <<WillEnterBackground>> APause
        bind . <<Terminating>>         CheckWriteHighscore
        bind . <<LowMemory>>           CheckWriteHighscore
        bind . <<WillEnterForeground>> {Pause 1}
        bind . <<DidEnterForeground>>  DoRedisplay
        bind . <<ViewportUpdate>>      {}
      } ;# if $::A
    } } ;# catch, do once

    if {$redraw} {
      foreach w [grid slaves .] { catch {grid forget $w} }
      foreach w [pack slaves .] { catch {pack forget $w} }
    }
      
    pack .ctrl -side left -fill y    -ipady 5 -ipadx 5
    pack .c    -side top  -fill both -expand 1

    grid .hiscore -in .ctrl -sticky ew -row 1
    grid .vhiscore -in .ctrl -sticky ew
    grid .score   -in .ctrl -sticky ew
    grid .vscore  -in .ctrl -sticky ew
    grid .vscore2 -in .ctrl -sticky ew
    grid .ltimer  -in .ctrl -sticky ew
    grid .timer   -in .ctrl -sticky ew

    grid rowconfigure .ctrl 20 -minsize 1
    grid .opt     -in .ctrl -sticky ew -row 25 -pady 1
    grid .new     -in .ctrl -sticky ew         -pady 1
 ## grid .optlvl  -in .ctrl -sticky ew -pady 1
 #  grid .optjew  -in .ctrl -sticky ew -pady 1

 ## grid .mute    -in .ctrl -sticky ew -pady 1
 ## grid .bstat   -in .ctrl -sticky ew -pady 1

    grid rowconfigure .ctrl 40 -weight 1
    grid .pause   -in .ctrl -sticky ew -row 45 -pady 1
    grid .hint    -in .ctrl -sticky ew         -pady 1

    grid rowconfigure .ctrl 60 -weight 4
    grid .about   -in .ctrl -row 100 -sticky ew -pady 1

    focus .c
 }

 proc OptMenu {w {x1 ""} {y1 ""}} {
    destroy .m
    menu .m        -tearoff 0
    menu .m.cols   -tearoff 0
    menu .m.rows   -tearoff 0
    menu .m.jewels -tearoff 0
    menu .m.level  -tearoff 0
    for {set i 6} {$i <= 16} {incr i} {
      .m.cols   add radiobutton -label $i -value $i -variable S(cols)   -command {NewGame} -font $::wfnt
      .m.rows   add radiobutton -label $i -value $i -variable S(rows)   -command {NewGame} -font $::wfnt
    }
    for {set i 3} {$i <= 8} {incr i} {
      .m.jewels add radiobutton -label $i -value $i -variable S(jewels) -command {NewGame} -font $::wfnt
    }
    for {set i 1} {$i <= 5} {incr i} {
      .m.level  add radiobutton -label $i -value $i -variable S(lvl)    -command {NewGame} -font $::wfnt
    }
   .m add cascade     -label "Cols"       -menu .m.cols  -font $::wfnt 
   .m add cascade     -label "Rows"       -menu .m.rows  -font $::wfnt 
   .m add cascade     -label "Jewels"     -menu .m.jewels -font $::wfnt
   .m add cascade     -label "Level"      -menu .m.level -font $::wfnt
   .m add separator
   .m add checkbutton -label "Mute"       -underline 0 -variable S(mute) -font $::wfnt
   .m add command     -label "Statistics" -underline 0 -command ShowStats -font $::wfnt
    if {$x1 == ""} { ;# androwish Menu key trigger passes in non pointer coords
      set x1 [winfo pointerx $w]
      set y1 [winfo pointery $w]
    }
    tk_popup .m $x1 $y1
  # tk_popup .m [winfo rootx $w] [winfo rooty $w]        ;# upper left corner
 }

 set ::didCompressImages 0                      ;# repeated redraws: do not recompress
 proc CompressImages {{force 0}} {              ;# force: allow Resize to compress
    if {!$force && $::didCompressImages} {return}
    set ::didCompressImages 1
    image create photo ::img::img(0)            ;# Blank image
    foreach id {1 2 3 4 5 6 7 8} {
        foreach a {2 3 4} {                     ;# We need narrower images
            image create photo ::img::img($id,$a)
            if {$a == 4} continue
            ::img::img($id,$a) copy ::img::img($id) -subsample $a $a
        }
    }
 }
 #proc Tracer {var1 var2 op} {
 #   if {$var2 == "strlvl"} {
 #       scan $::S(strlvl) "Level %d" lvl
 #       if {$lvl != $::S(lvl)} NewGame
 #       return
 #   }
 #   if {$var2 == "strjew"} {
 #       scan $::S(strjew) "%d Jewels" jew
 #       if {$jew != $::S(jewels)} NewGame
 #       return
 #   }
 #}
 set ::newGame1st 1
 proc NewGame {} {
    Timer off
    CheckWriteHighscore
  # scan $::S(strlvl) "Level %d"  ::S(lvl)
  # scan $::S(strjew) "%d Jewels" ::S(jewels)
    array set ::S {
        score 0 score2 "" busy 0 click {} click1 {} click2 {} pause 0
        cnt 0 time 00:00 sturn 0 tmin 0 best 0 robot 0 tbonus 0 tpause 0
        over 0
    }
    set ::S(timer) $::S(lvl,$::S(lvl))

    if {$::S(lvl) > 1} {
        .hint   config -state disabled
        .ltimer config -fg white
        .timer  config -fg yellow
    } else {
        .hint   config -state normal
        .ltimer config -fg black
        .timer  config -fg black
    }
    if {$::newGame1st} { ;# leave message on 1st time, if there
      .c delete [.c find withtag !top_msg]
      set ::newGame1st 0
    } else {
      .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() * $::S(jewels))}]
            .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() * $::S(jewels))}]
        }
    }
    DrawBoard 1
    .pause config -state normal ;# v2: re-enable pause at new game time
     catch {.c raise top_msg}   ;# also in startup @config read
 }
 proc DrawBoard {{resize 0}} {
    global S

    if {$resize} {              ;# tbd: contstrain H and W in borg mode
        set S(w) [expr {$S(cell) * $S(cols) + 10}]
        set S(h) [expr {$S(cell) * $S(rows) + 10}]
        .c config -height $S(h) -width $S(w)
    }

    .c delete box
    for {set row 0} {$row < $::S(rows)} {incr row} {
        for {set col 0} {$col < $::S(cols)} {incr col} {
            if {$resize} {
                .c coords "c$row,$col" [GetXY $row $col]
            }
            .c itemconfig "c$row,$col" -image ::img::img($::B($row,$col))
        }
    }
    set ::S(legal) [llength [FindLegalMoves 0]]
 }
 proc GetXY {r c} {
    global S
    set x [expr {5 + $c * $S(cell) + $S(cell)/2}]
    set y [expr {5 + $r * $S(cell) + $S(cell)/2}]
    return [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
        if {$::S(timer) <= 0 && $::S(lvl) > 1} {
            GameOver "Out of time"
            CheckWriteHighscore
        }
        return
    }

    foreach {row1 col1} $S(click) break         ;# 2nd click, swap and explode
    set click [list [concat $S(click) $row $col]]
    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} {                               ;# Something exploded
            set click {}                        ;# Clear for triple play
            incr S(cnt)
            incr S(tbonus) [expr {6 - $S(lvl)}] ;# Add to time bonus
            if {! $S(mute)} {after idle {catch { snd_ok play }}} ;# moved here
        } else {                                ;# Nothing exploded
            # Check for triple click
            if {$click == $S(click1) && $click == $S(click2)} {
                # decrease score by 10%...
                set ten [expr {round($S(score) / -10.0)}]
                if {$ten > -100} { set ten -100}
                incr S(score) $ten
                set S(score2) "($ten)"
                set click {}
                if {! $S(mute)} {catch { snd_badok play }}
                incr S(cnt)
            } else {
                if {! $S(mute)} {catch { snd_bad play }} ;# Nope, undo the move
                SwapCells $row1 $col1 $row $col
            }
        }
        set S(click2) $S(click1)
        set S(click1) $click
        if {! [Hint 1]} {                       ;# Is the game over???
            GameOver
        }
    }
    set S(legal) [llength [FindLegalMoves 0]]
    set S(busy) 0
    catch {
        set ::S(sturn) [format "%.1f" [expr {$::S(score) / double($::S(cnt))}]]
    }
    if {$::S(cnt) == 1} {Timer start; snd_ok play -blocking 0}
    if {$::S(timer) <= 0 && $::S(lvl) > 1} {
        GameOver "Out of time"
    }

 }
 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() * $::S(jewels))}]
        }
        .c create image [GetXY $r $c] -image ::img::img($M($r,$c)) -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 $::S(delay)
    }
    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)) -tag {slide1 slide}
    .c create image $x2 $y2 -image ::img::img($B($r2,$c2)) -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 $::S(delay)
    }
    .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]
        #if {! $::S(mute)} {catch { snd_ok play }}
        ExplodeCells $cells                     ;# Do the explosion affect
        CollapseCells                           ;# Move cells down
    }

    set n [expr {$cnt * $cnt}]
    incr ::S(score) $n
    set ::S(score2) ""                          ;# Show special scores
    if {$cnt > 3} {set ::S(score2) "([expr {$cnt*$cnt}])"}
    if {$n > $::S(best)}  {
      set ::S(best) $n
    }
    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 [expr {10 * $::S(delay)}]
    }
 }
 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]
 }
 # 0 => 1 hint, 1 => is game over, 2 => all hints
 proc Hint {{how 0}} {
    if {$how == 0} {
        if {$::S(pause) != 0} return
        incr ::S(score)   -50
        set  ::S(score2) (-50)
        if {$::S(cnt) > 0} {
            set ::S(sturn) [format "%.1f" [expr {$::S(score)/double($::S(cnt))}]]
        }
    }
    .c delete box
    set S(click) {}

    set hints [FindLegalMoves $how]
    set len [llength $hints]
    if {$how == 1} {return [expr {$len > 0 ? 1 : 0}]}
    if {$how == 0} {                            ;# Highlight only 1 hint
        set hints [list [lindex $hints [expr {int(rand() * $len)}]]]
    }

    foreach hint $hints {                       ;# Highlight every hint
        foreach {r c} $hint { .c addtag hint withtag c$r,$c }
        .c create rect [.c bbox hint] -outline white -width 3 -tag box
        .c dtag hint
    }
    return $hints
 }
 proc FindLegalMoves {how} {
    global S B

    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}

    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
                lappend hints [list $r $c [expr {$row+$dr3}] [expr {$col+$dc3}]]
                if {$how == 1} { return $hints }
            }
        }
    }
    return $hints
 }
 proc About {} {
    # andro mods: \r\r becomes \n\n for non andro display
    set msg "$::S(title) v$::S(version)\nby Keith Vetter, June 2003\n"
    append msg "Based on a program by Derek Ramey, small androwish\n"
    append msg "mods by plp / abc 2017 - modded version $::S(abcversion)\r\r"

    append msg "Click on adjacent gems to swap them. If you get three or\n"
    append msg "more gems in a row or column, they will explode and those\n"
    append msg "above will drop down and new gems will fill in the top.\n"
    append msg "The game ends when you have no more moves.\r\r"

    append msg "The score for a move is the square of the number of cells\n"
    append msg "exploded. Asking for a hint costs 50 points.\n"
    append msg "If you are insistent and repeat an illegal move three times,\n"
    append msg "it will do it, but cost you 10% of your score.\r\r"

    append msg "Keyboard-shortcuts:\r"
    append msg "N: New Game\r"
    append msg "P: Pause\r"
    append msg "H: Hint\r"
    append msg "M: Mute: Sound on/off\r"
    append msg "S: Statistics on/off\r"
    append msg "z: Resize \r"

    if {!$::A} {
      set msg [regsub -all {\r} $msg "\n"]
      tk_messageBox -message "$msg" -title "About"
    } else {
      catch {destroy .msg}
      toplevel .msg
      label .msg.l -text "About"  -font $::wfnt

      frame .msg.tf ;# for scrollbars
      text .msg.tf.t -wrap word -state disabled  -font $::wfnt;# for message
      grid .msg.tf.t -in .msg.tf -row 0 -column 0 -sticky nsew
      # scrollbar to scroll text widget can be here if needed, borg scrolls by swipe
      button .msg.bx -text "OK" -command {destroy .msg; wm attributes . -topmost 1} -font $::wfnt
      grid .msg.bx -in .msg.tf -row 1 -column 0 -sticky nsew
      grid columnconfigure .msg.tf 0 -weight 1
      grid columnconfigure .msg.tf 1 -weight 0
      grid rowconfigure .msg.tf 0 -weight 1
      grid rowconfigure .msg.tf 1 -weight 0 ;# button

      pack .msg.l -in .msg -side top -expand 1 -fill x
      pack .msg.tf -in .msg -side top -expand 1 -fill both
      set msg [regsub -all {\n} $msg { }]
      set msg [regsub -all {\r} $msg "\n"]
      .msg.tf.t configure -state normal
      .msg.tf.t insert 0.0 $msg ;# tbd: reformat message to auto fit on width
      .msg.tf.t configure -state disabled
      wm attributes .msg -fullscreen 1
      wm attributes . -topmost 0
      wm attributes .msg -topmost 1
    }
 }
 proc GameOver {{txt "Game Over"}} {
    set ::S(over) 1
    .c create rect 0 0 [winfo width .c] [winfo height .c] \
        -fill white -stipple gray25
    set x [expr {[winfo width  .c] / 2}]
    set y [expr {[winfo height .c] / 2}]
  # .c create text [GetXY 4 5] -text $txt -font {Helvetica 28 bold}
    .c create text $x $y -text $txt -font {Helvetica 28 bold} \
        -fill white -tag over  -font $::wfnt
    .c delete box
    .hint  config -state disabled
    .pause config -state disabled
    Timer off
    ShowStats 1
 }
 proc DoSounds {} {
    proc snd_ok  {play} {}                      ;# Stub
    proc snd_bad {play} {}                      ;# Stub
    proc snd_badok {play} {}
    if {[catch {package require base64}]} return
    if {[catch {package require snack}]}  return

    set s(ok) {UklGRkACAABXQVZFZm10IBAAAAABAAEAESsAABErAAABAAgAZGF0YRwCAACAgId0Z
        HZbU5aMj7/MsIZ6UX6nWIiITWiIRUGUlZesvrGCiKiKTl96Fit3YF5emrGHqcqhlJuAdWxgW
        01EbWSHubW1uJ2MkqGPYFVSamtvgHmEh5ybraWLkHp5Xm5oWGRvb3WSlYqMi4+JhY6Ac25xd
        Xp5jYR/hoODdIN8e356goCHgoqGgIV/g35/d3N2eHZ6gIOIgouHioaNioGAfHpycHp2dH2Hi
        ouNiYiKhIF9enZzd3l+dX2BgYKIjoaJhIJ/fX6AfHl8fICAgICEgISFhYF/gH+AfIJ/gH6Af
        X6AfICAfYB+gn2DfoGAgIOAgYB8e3x9gIKChYCDgIN/g32Afn+BgIF+gH+BgIOAgX2CfYGAg
        IB/gH9/fIB/gICBgH+Df4KAgIB9gHuBfYKAgoCAhICDgIN+gH+Af4CAgIGAg4CFgIOAgICAg
        H9/f32AfoF/gn+BgICAf4B/gICAgICAgIKAgYCAgH+AfYB8f4CAgoGBgIKBgHt0cnqEi4yIh
        oKHioOBeoF+gHRvbW10eYSHhoyMmI+PhIF5dm9tbW92fICJjpKRkY6JhHx5b2xlbnWAhYeOj
        pSQkIiAe3R1cnNzdnx/gomLj4yJhICAfHp3d3d6fYKDhoKGgIeAhX1/eXt9foCAg4GCg4CDf
        YF6gHmAfYCBgIR/h4CEf4B9fn98gHuEfYV/g4CAgn6Fe4R6gn1/gHuDe4V+g4CAgn8=}
    set s(bad) {UklGRrEHAABXQVZFZm10IBAAAAABAAEAESsAABErAAABAAgAZGF0YY0HAAB/f39/
        gICAgICAgICAf39/fn9/f4CAgICAf3+AgICBgYGBf359fX5/gIGChISEgX14dXZ6f4OFiIuM
        iYB2bm52foSHio+Sk4x+bWBXY3mHjY2NlZqSg3NtcXp6eHd5goqLiY6Nf2tqeIKLnLGrhmJC
        OWF8h4+xvJJ3WTJTeX6Eja+/mH1qUE5lfoKIlsK6h3tbL2l/go28xIR9Qz15gIq9w31+Qjp2
        f4a0y4yBbkM9b3mDls6zgnY3Q3d5goWSp8yxjoF4VRlVc3iHvdGGhVYlWnt6o9irf4NAKmh2
        fpnYuYOLRytleX2w2KKGg0cpYnZ9sdaiiXc7Qmx0jsbAknUvT32Dw7uhhXo+NGF1g7LPpoqE
        Wj9GYXV+jK3gq4+FVihab3uJv9OWjXdEMmJxjqGsr4xqXm96iH1zflphcoqyv4xvaVNpiZSA
        f4qCgIiloJh+TFRja259nbiphnxnbGJfdpKXmaKPbl1fX26JnKOYe3BiaXqMinyHgn18fYeA
        e29xiot2fYiIi4h7dn+Fl6eMamNmcYGFg5Gbjn56cHVzdYWXnpB+bmhgdIibqqWHbFpUYnGH
        m6igjXlrX1hohJWkjnd2e397en1/b2NufYKSoqqUe2hbVVtte5KjpKKhgmFaZ3B3f5GclYp/
        gnxyamdwgIyapaGOgXFdaHeBhYN9h5eMjImBfm1pfIJ/g46WiXx1cm92gYeKkZeNf3h7fGhb
        aHmAkamqnIt1X09Vb3+PoqSQhXFcYXGAhI+moYp2alZRbIKLm62tmHtkTk9hc4KVpKmehHBl
        Xmh4hI6TlpOMdmpnaHOBi5OUjoRwcG5tfIWLj5GPgXl8fXyChICDeWptd3qCiYyLjI2BfYJ9
        d3d3fIB/h4h+enh+g4OHhoKAeXV5gIOCgoOAfHd7gYeNj4+LgXNsam12foOMjYqLhoB+eXqD
        hYeMhHVtam55h4yNjYd/fH18fH6AgYGCgoWJhnxxbnR8g4uQjIN7eXt5e36AgYGEh4N8eXp+
        goSEg358e3l7gIGEh4WDgHl3eHqAhYeIhoJ7dnV3fYKEhoWDgHt8gYSGhX95dXV3fYSJiYWD
        fXl6e31+gYSEg4SCfXp4d3Z5gYmNjIh+c3F0e4OHiYuKhX56eHh5fYGDg4F/fn1/hYaDgX16
        eHl9gIOFh4mGgHx6d3Z6gYaJiIWCfXl4eXyBhIOBfn+Cg4SFg396dHJ0eoOLjouFgH57e36A
        gH58enp7fYCFioiFgX17ent9fH+Cg4F/fn+Af3+AgYODg4OBfnt4d3l8foGFiYmGg4F/e3h2
        d3uAhIaHhYJ+e3t+gIGChIOAfXp5eXt+gIOFhoOCg4F+fX19fXx8fX6AgYKDgX9/goOCgH58
        e3l5fICDhYaFg4B9fn9+fXx8fH6AgoSFhYKAfnp6e35/gYKDgoB/f3+AgIGCgICAgIGBfnp4
        eHyAhouNi4V8c29xeYGIjY2Gfnh1eHyBg4ODg4F+fX5+fXt7fYCEiImGgXx2dHd9g4eIh4WB
        fXp5e36ChoaDf3p4eXx+gYWGhYKAfXp7fH6Ag4SDf318fH1+gYSEgoB9fH1/goODgYB9e3t8
        gISIiIaAenZ2eX2Ch4qIhYB6d3h6foGFh4aDgH17ent9f4GCg4OCgX9+fX19fXx9gIKEhYSB
        fnt6enx/g4SDgYB/fn59fX1+gIGBgoOCf3x7fH1/gYODgH9/f39/gYGAf318e31/goOEhIJ/
        fHp6fYCDhYWDf3x6e32Ag4WFhIF+fHt8fX+AgYOEhIF/fHp6fYGEhYWDf3t6e32Ag4aGg397
        enp7foCCg4OCgH9+fn5+f4CBgYGAf359fX5+foGDhIWFgn57eHh6foKFhoSAfHp6fICEh4eD
        fnp4eHt/goSFhIF+fHx9gIKDgoF/fXx8fn+BgoKCgYCAf359foCAgYB/fn9/f4CBgYB+fn+A
        gYKCgX99fX1+gIGCgoGAfn18fX5/gYOEg4F+fHt7fX+Cg4OCgH58fHx+gIOEhIOBfnx7e31/
        gYOEhIKAfXx8fn+AgYGAf35+f3+BgoKBgH99fX5/gIGBgYB/fn1+f4GDg4OAfnx8fH6AgoOD
        gX59fX5/gYGBgIB/f3+AgYGBgH9+fn5/f4CAgICAgH9+fX5+gIGCgoF/fn19fX+AgoKCgYB/
        fn19foCBgoKAf359fn5/gIGBgIB/f39+fn5+f4CBgoKBgH9+fX1+gIGBgYGAgH9/fn9/f39/
        f3+AgICAgICAgIB/f39/f4CAgICAgICAgYCAf35+f39/gIGAgH9+fn5/gIGCgoB/fn1+fn+A
        gYGAf39/f3+AgICAgIB/f39/f3+AgICAgICAgH9/fn5/f4CAgIB/f39/gICAgIB/f35+fn9/
        gIGBgIB/f39/f39/f39/f39/f4CBgYGBgH9+fX1+gIGCgoGAfn5+fn+AgYGAf35+fn5/gIGB
        gYB/f35+f3+AgICAf39/f3+AgICAgH9/f39/gICAf39/f3+AgICAgICAf39/f3+AgICAgICA
        f39/f39/gICAgIB/f4CAgH9/f39/f3+AgICAgICAf39/f4CAgICA}
    foreach snd {ok bad} {
        regsub -all {\s} $s($snd) {} sdata            ;# Bug in base64 package
        sound snd_$snd
        snd_$snd data [::base64::decode $sdata]
    }
    sound snd_badok
    snd_badok data [::base64::decode [regsub -all {\s} $s(bad) {}]]
    snd_badok concatenate snd_ok
 }
 image create photo ::img::img(1) -data {
    R0lGODdhHgAeALMAAAAAAAAAyAAAKAAA6EhI2FBQ/xAQSBgQSDAw////////////////////////
    /////ywAAAAAHgAeAAAE/xDISau9OOvN+4RBhBDCCCEIQggshRAiAgRyyhCCCWGMEWAQhJRSCBEh
    BAjkBMLAI+cxUkAjpxBCQCBnCOHAImchIEAkpxSEQCBlGOHAIqc0EMk5DSEQSBlGOAQWOYuBSM5p
    SIFAyjDCgUXOQg5Eck5TCgRShhEOLHIWciCScxpSIJAyjHBgkVMeiOSchhQIpAwjHFjklAYiOach
    BAIpwwgHFjkLORDJOQ0hEEgZQjiwyEkIgEhOGQQhEEhpjDnHnHOMgUIaKaUUEMhJCDEBIjmDgEHO
    KSQEUpJCDERyShHgkHMEEQIEUpJCDERyShHgkHMEEwIEUpJCBERyShHgkIJzBBECBFKSQgxEckoR
    4JBzBBECBFKSQgxEckoT4JBzBBECBFKSQgxEckoR4JBzBBMCBFISQkSASM4gYJBzCgmBnMYIIYwR
    xggohDFCGCOEEBDICUIIYowxQoBBEEJKIUSMQSCQE5wAQhhjhAADKISUQgg55EAgpzwQyEmrvTjr
    zW8EADs=}
 image create photo ::img::img(2) -data {
    R0lGODdhHgAeAJEAAAAAABDgAGj/WP///ywAAAAAHgAeAAACzISPqcvtDyMi8YHkA8Un+EjxgeQD
    xSf4R/EDSD5Q/CD4QPEDSL4BxQ+CT/EDSL4BxQ+Cj6nLQPGB5BtQ/CD4QPGB5BtQ/CD4RvGB5APF
    D4J/FB9IPlD8IPhIsYHkA8Un+GgREQTKB4pN8PEoNpBsoNgEHzEigiCJAMUm+JgQEQRJBCKCQviY
    FhEESQQigkL4mBcRBEkgIgg+JkYEQRKICIKPmRFAMiIIPqZCAEmIIPiYahEEIYLgY+oFkBCCj6kq
    u7sAEeFj6nL7wxhJAQA7}
    image create photo ::img::img(5) -data {
    R0lGODdhHgAeAJEAAAAAAP//QOjwAODgACwAAAAAHgAeAAACxISPqctLgQg+pmYEQSL4mHoRFEiE
    4GMqRFACERGCj5kUG0g2wcc8ig8kn+BjAsUPIPlC8BEpvgHJN4KPRvEPSP4RfKT4CCQfCb5RfAwg
    +SgEn+KjAclHAwCg+HhA8vEIPqZuknw8oPl4AAAkHw1oPhrBJ/koQPNxCL6RfASajwQfSf4BzT+C
    j0byDWi+EXxEki9A84fgYwLJB5pP8DGPZAPNJviYKSIkbGYIPqaCCAmbIfiYeiKEjeBjagrQCB9T
    l9ufkQIAOw==}
 image create photo ::img::img(3) -data {
    R0lGODdhHgAeAJEAAAAAANAAAP8AAP84OCwAAAAAHgAeAAAC/4SPqcvtD0h8zAAh+CgCFB8TRAi+
    iQhQfEQQEYIPJBsoPh6ICInwSTZQfDQg2QQ7TESEwPgYICIEyCwijCRQfAQRAJIBABQbQODuCKZs
    AACKHwQfjeQLAADFN6D5BiTfAAAovgHNNyD5BgBA8Q1ovgHJNwAAim9A8w1IvgEAUHwDmm9A8g0A
    gOIb0HwDkm8AABTfgOYbkHwDAKD4BjTfgOQbAADFD4KPRvIFAIBiAwiQfAMBQCEYEWEiBMpHmAEg
    SAAAAQRJBEg+As0m+ECy4e4OaD7BJtlwdwc0n2CLiADJR4SZoRE+iAiQfESYGYJ/AiQfU2CG4J8A
    yccUGIKPqQK7BQA7}
 image create photo ::img::img(4) -data {
    R0lGODlhHgAeALMAAAAAAFyI/5zO/xtX/3qn/zx1/16T/zF5/2+V/wAwzT9w/6b5/wAduAA75SBg
    /424/yH5BAEAAAAALAAAAAAeAB4AAwT/EMhJq704601ZcyBYOAzDWYNYHGx7NKfUDEqxujjJJU5d
    BECD0HAgtkwZnmIJDAwJUILwiGHQFIFfAGFAEB4PgeAhZTkwg6sW4SWIF/CFoPyyfJbYLfsriMfn
    RkgTDXhMbF5vfnAPgR2FQAh6YYpxZEaOhVh7bn2UgAdnEwyPkGxglHCfB5h4pV5hnX+MRAWsTKVQ
    sLJQl6KZeYe5YmJgUrS2t3qvX8zGZhVXpMptUVwGAXUUhL+uwdZABwWCEqPcwIfo4AMX5ZkBCpGQ
    W00jVdGPeU1ANgowGff4gGCp0Y8DwF94HCSIkQBhIQcDxnHwALBHA38xKpTYWCKjx48gAytEAAA7}
 image create photo ::img::img(6) -data {
    R0lGODdhHgAeAJEAAAAAAIDw/xjo/1jo/ywAAAAAHgAeAAACv4SPqcvtD6OcjMTHI/iYIEDxMWAI
    PqKIAMU/mBmCj0ayCf7RbIKPJBto/gEOwTeSDTQfB5Lgk2yg+XiQAARQNtB8TEgAAiQCNB/T4IAA
    BAjQfEyEARoAEUDzMRUMCEgAzcdUMCAgIEDzMRECaACAiADNxzSIoAAAJBtoPiZQbAAAkg00Hw8o
    NsEn2UDzcYBiE3wj2UDzDyg2wUeSTfCPYhN8NBEBkn8QEQQfUYDko0AQfEwg+XgEH1OX2x9GORsp
    ADs=}
 image create photo ::img::img(7) -data {
    R0lGODlhHgAeALMAAAAAANtNyeId0/8A/wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    AAAAACH5BAAAAAAALAAAAAAeAB4AAwSWEMhJq703AMG7/8KGAUG5gegZWmWroty7Tm0tf/dc72Me
    SzvTYEgs5iYhXnFJlJEkMRdzOlCRNFYNlSpyvQDb7dX0DXNtZTNzjPWA1Us2tPOGN9FuuxFP19+9
    eX5VfDGCg4B9gnJZdXBdZFFCjnSQbFpmTliWklwpQEFkGDA6QZs2njQ2oDw4LCarpXQYGrCgIj24
    uQARADs=}
 image create photo ::img::img(8) -data {
    R0lGODlhHgAeALMAAAQCBATO/GSazDRmnJzO/KyqrDRmzHcAAMjAyNGz71/tEwB3AHg6AQEAABMA
    AAAAACH5BAEAAAAALAAAAAAeAB4AAwR5EMhJq704640L/1NBeOAmnmV2jmNqrbAbsl7s2gD+2YGk
    a7xAL0fjBIXDX+WITBYvzKYTtXxKr74npSDgkq5I36Aw7nS7ErCYTDJ708112XT+CuVt+huQHM9B
    Xmh4MoE1fnkphYcyW10GbIxLXX+RIZSVIZiam5wbEQA7}

 proc Robot {{cnt -1}} {
    global S

    if {$S(robot)} {                            ;# Already going
        set S(robot) 0
        return
    }
    set S(robot) 1
    .pause config -state disabled

    if {$cnt == -1} {
        foreach {delay S(delay)} [list $S(delay) 0] break
        foreach snd {ok bad} {                  ;# Disable sound
            rename snd_$snd org.snd_$snd
            proc snd_$snd {play} {}
        }
    }

    for {} {$cnt != 0} {incr cnt -1} {
        if {! $S(robot)} break
        set moves [FindLegalMoves 2]
        if {$moves == {}} break

        # Massage data by adding a sorting key
        set all {}
        foreach m $moves {
            foreach {r1 c1 r2 c2} $m break

            # Top most
            set mm [concat [expr {$r1 < $r2 ? $r1 : $r2}] $m]
            # Random
            #set mm [concat [expr {rand() * 10000}] $m]
            # Bottom most
            #set mm [concat [expr {$r1 > $r2 ? -$r1 : -$r2}] $m]
            lappend all $mm
        }
        set all [lsort -index 0 -integer $all]
        set move [lindex $all 0]

        foreach {. r1 c1 r2 c2} $move break
        DoClick $r1 $c1
        DoClick $r2 $c2
    }
    set S(robot) 0
    if {$cnt < 0} {
        set S(delay) $delay
        foreach snd {ok bad} {   ;# Re-Enable sound
            rename snd_$snd {}
            rename org.snd_$snd snd_$snd
        }
    }
    .pause config -state normal
 }

 proc Timer {{how go}} {
    global S
    foreach a [after info] { after cancel $a }

    if {$how == "off"} return
    if {$how == "start"} { set S(tstart) [clock seconds] }

    set sec [expr {[clock seconds] - $S(tstart)}]
    set pause 0
    if {$S(pause) != 0} {
        set pause [expr {[clock seconds] - $S(pause)}]
    }
    set sec [expr {$sec - $pause - $S(tpause)}]

    if {$sec < 3600} {
        set S(time) [clock format $sec -gmt 1 -format %M:%S]
    } else {
        set S(time) [clock format $sec -gmt 1 -format %H:%M:%S]
    }
    if {$sec > 0} {
        set S(tmin) [format "%.1f" [expr {60.0 * $S(cnt) / $sec}]]
    }
    set S(timer) [expr {$S(lvl,$S(lvl))-$sec+$S(tbonus)+$S(tpause)}]
    if {$S(timer) < 0} {set S(timer) 0}

    if {! $S(busy) && $S(timer) <= 0 && $S(lvl) > 1} {
        GameOver "Out of time"
        return
    }
    after 1000 Timer
 }

 proc Mute {} {
    global S
    if {$S(mute) == 0} {
      set S(mute) 1
    } else {
      set S(mute) 0
    }
 }
 proc Pause {{force 0}} { ;# force for borg
    global S

    if {$force || ($S(pause) == 0)} {           ;# Pause on
        if {$S(cnt) == 0} return                ;# Not started yet
        if {$S(over)} return                    ;# game over
        set S(pause) [clock seconds]
        .c create rect 0 0 [winfo width .c] [winfo height .c] \
            -fill black -tag pause
        set x [expr {[winfo width  .c] / 2}]
        set y [expr {[winfo height .c] / 2}]
      # .c create text [GetXY 4 5]         -font {Helvetica 28 bold}
        .c create text $x [expr {$y - 15}] -font {Helvetica 28 bold} \
            -fill white -tag pause -text "PAUSED" -justify center
      # .c create text [GetXY 6 5]         -font {Helvetica 12 bold}
        .c create text $x [expr {$y + 15}] -font {Helvetica 12 bold} \
            -fill white -tag pause -text "Press p to continue" -justify center
        .c delete box
    } else {                                    ;# Pause off
        incr S(tpause) [expr {[clock seconds] - $S(pause)}]
        set S(pause) 0
        .c delete pause
    }
 }
 proc ShowStats {{on 0}} {
    set w .stats

    if {[winfo exists $w]} {
        if {! $on} {destroy $w}
        return
    }
    toplevel $w -bg black
    wm title $w "$::S(title)"
    if {!$::A} {
      wm geom $w "+[expr {[winfo x .] + [winfo width .] + 10}]+[winfo y .]"
    } else {
      wm attributes $w -fullscreen 1
      wm attributes . -topmost 0
      wm attributes $w -topmost 1
    }

    label $w.title  -text "$::S(title) Statistics" -fg white -relief ridge
    label $w.lhscore -text "Highscore:"             -fg white
    label $w.vhscore -textvariable S(highscore)     -fg yellow
    label $w.lscore -text "Score:"                 -fg white
    label $w.vscore -textvariable S(score)         -fg yellow    
    label $w.lturn  -text "Turns:"                 -fg white
    label $w.vturn  -textvariable S(cnt)           -fg yellow
    label $w.lsturn -text "Score/turn:"            -fg white
    label $w.vsturn -textvariable S(sturn)         -fg yellow
    label $w.lbest  -text "Best:"                  -fg white
    label $w.vbest  -textvariable S(best)          -fg yellow
    label $w.ltime  -text "Time:"                  -fg white
    label $w.vtime  -textvariable S(time)          -fg yellow
    label $w.ltmin  -text "Turns/minute:"          -fg white
    label $w.vtmin  -textvariable S(tmin)          -fg yellow
    label $w.lgood  -text "Legal Moves:"           -fg white
    label $w.vgood  -textvariable S(legal)         -fg yellow

    grid $w.title -
    grid $w.lhscore $w.vhscore
    grid $w.lscore $w.vscore
    grid $w.lturn  $w.vturn
    grid $w.lsturn $w.vsturn
    grid $w.lbest  $w.vbest
    grid $w.ltime  $w.vtime
    grid $w.ltmin  $w.vtmin
    grid $w.lgood  $w.vgood

    button $w.brbest -text "RESET HIGH SCORE" -command {
      set ::S(highscore) 0
      WriteHighscore
    }
    grid $w.brbest -columnspan 2 -sticky ew

    if {$::A} {
      button $w.bx -text "OK" -command {
        destroy .stats ;
        wm attributes . -topmost 1
      }
      grid $w.bx -columnspan 2 -sticky ew
    }
 }
 proc Resize {} {
    if {[lsearch [image names] ::img::img(1).org] == -1} {
        foreach id {1 2 3 4 5 6 7 8} {
            image create photo ::img::img($id).org
            ::img::img($id).org copy ::img::img($id)
        }
    }
    set zoom [expr {$::S(cell) == 30 ? 2 : 1}]
    foreach id {1 2 3 4 5 6 7 8} {
        image delete ::img::img($id)            ;# For easier resizing
        image create photo ::img::img($id)
        ::img::img($id) copy ::img::img($id).org -zoom $zoom
    }
    CompressImages 1
    set ::S(cell) [image width ::img::img(1)]
    DrawBoard 1
 }

 DoDisplay
 DoRedisplay ;# hack to cause proper sizing on some devices
 DoSounds
 # NewGame moved from here, need the display mapped to measure things next
 
 if {$::A} { ;# borg stuff, remote debug, etc
   set ip ""
   if {[info exists ::TelnetWishPort]} {
     catch {set ip [exec ifconfig wlan0]} err ;# should get wlan if name from props
     if {$ip != ""} {
       set ip [lindex $ip 2] ;# wlan0: ip 1.2.3.4 ...
     }
     if {[info exists ::CheckWishIp] && ($::CheckWishIp != $ip)} {set ip ""}
     if {$ip != ""} {
       catch {
         package require tkconclient
         tkconclient::start $::TelnetWishPort
       }
     }
   }
 } else {
   if {1} {
     catch {
       package require tkconclient
       tkconclient::start $::TelnetWishPort
     }
   }
 }

 # find the location of the highscore file using borg/unix related env
 set is $env(HOME)             ;# use INTERNAL_STORAGE here? same?
 if {[file isdirectory $is]} { ;# verify path exists
   set ::cff $is/$::ConfigFile
 } else { ;# does not exist, do something about it later?
   set ::cff "" ;# mark inexistant, no writes will occur
   if {$::A} {borg toast "ERROR: Can't create Highscore Log (2)" 1}
 }

 # config file functions
 proc WriteHighscore {{toast 0}} {
   puts "* WriteHighscore cff=$::cff"
   if {$::cff == ""} {return}
   if {[catch {
     set fd [open $::cff w]
     puts $fd "# TkGems2.cfg"                ;# config file format
     puts $fd "version $::S(abcversion)"
     puts $fd $::S(highscore)
     close $fd
   } err]} { ;# err is unused for now
     if {$toast} {borg toast "ERROR: Can't create Highscore Log (1)" 1}
     return 0
   }
   if {$toast} {borg toast "Created Highscore Log" 1}
   return 1
 }

 proc CheckWriteHighscore {} {
   puts "* CheckWriteHighscore"
   if {($::S(score)!="") && ($::S(score) > $::S(highscore))} {
     set ::S(highscore) $::S(score)
     WriteHighscore
   }
 }

 proc ReadHighscore {{toast 0}} {
   puts "* ReadHighscore"
   if {$::cff == ""} {return}
   if {[catch {
     set fd [open $::cff r]
     set d [read -nonewline $fd]
     close $fd
   } err]} {
     if {$toast} {borg toast "ERROR: Can't read Highscore Log (3)" 1}
     return 0
   }
   set score 0; set i 0; set highscore ""
   foreach l [split $d "\n"] {
     switch $i {
       0 {if {[regexp {^# +TkGems2\.cfg} $l]} {set score [expr {$score | 1}]}}
       1 {if { "$l" == "version $::S(abcversion)" } {set score [expr {$score | 2}]}}
       2 {if {[regexp {^ *([0-9]+)} $l dummy highscore]} {set score [expr {$score | 4}]}}
     }
     incr i
   }
   if {($score == 7) && ($highscore != "")} {
     set ::S(highscore) $highscore
     if {$toast} {borg toast "Read Highscore Log" 1}
     return 1
   }
   return 0
 }

 # startup: load or create highscore
 # outcome: 00 - failed; 1x - success read; 01 - success write
 set t [ReadHighscore];
 if {($t != "") && !$t} {
   set t1 [WriteHighscore 1]
 }
 if {($t != "")&&($t == 1)} {
   borg toast "Read Highscore Log" 1
 }

 ### at end
 NewGame
 set ::borg_tmr [after 2000 {
   catch {.c delete top_msg}
   catch {unset ::borg_tmr}
 }]