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