[Keith Vetter] 2003-06-04 : here's an addictive little puzzle game copied from an applet at [http://javaboutique.internet.com/GemGame/]. 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'' [http://www.afunzone.com/Kewel/santaballs.htm], ''Santa Balls 2'' which uses a hexagonal board [http://www.afunzone.com/Kewel/santaballs2.htm], ''Flip the Mix'' which uses M&M pieces [http://www.afunzone.com/mm.htm] and ''Carnival Jackpot'' which is also played on a hexagonal board [http://www.afunzone.com/Kewel/CarnJackpot.htm]. ---- [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 [http://mywebpages.comcast.net/jakeforce/iGem.tcl] (''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 [http://mini.net/files/iGems.tcl], where gems are smaller but well-looking. MPJ: [http://mywebpages.comcast.net/jakeforce/iGem.jpg] RS: [http://mini.net/files/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 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. 1. 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 binding. Just bind to bind . "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. ---- ##+############################################################### # # 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.6 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 {Hint 2} bind .c Hint bind .c 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 Mute bind .c 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 {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 Robot bind .c {Robot 10} bind .c {Robot 1} ;#debug bind .c Resize bind .c NewGame bind .c NewGame bind .c

Pause bind .c

Pause bind .c ShowStats bind .c 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" [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)) } } } 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(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 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 } 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 ---- [Category Games] | [Tcl/Tk Games] | [Category Application]