home *** CD-ROM | disk | FTP | other *** search
/ PCNET 2006 September - Disc 1 / PCNET_CD_2006_09.iso / linux / puppy-barebones-2.01r2.iso / pup_201.sfs / usr / local / bin / gemgame.tcl < prev    next >
Encoding:
Tcl/Tk script  |  2004-07-17  |  26.5 KB  |  687 lines
  1. #!/usr/bin/wish
  2.  
  3.  ##+###############################################################
  4.  #
  5.  # GemGame -- based on a game by Derek Ramey and others
  6.  # by Keith Vetter -- May 2003
  7.  #
  8.  # Also known as Elf balls, Santa Balls and Santa Balls 2
  9.  # http://www.afunzone.com/Kewel/santaballs.htm
  10.  # Flip the Mix w/ M&M's: http://www.afunzone.com/mm.htm
  11.  # Carnival Jackpot (hex): http://www.afunzone.com/Kewel/CarnJackpot.htm
  12.  #
  13.  # see http://javaboutique.internet.com/GemGame/
  14.  # 2003/06/12: zoom, robot on key, 8th jewel, resizable via console
  15.  # 2003/06/13: timer levels
  16.  # 2003/06/24: mute and pause
  17.  
  18.  package require Tk 8.3
  19.  
  20.  array set S {title "Gem Game" version 1.5 cols 10 rows 10 cell 30 jewels 7}
  21.  set S(w) [expr {$S(cell) * $S(cols) + 10}]
  22.  set S(h) [expr {$S(cell) * $S(rows) + 10}]
  23.  set S(delay) 10
  24.  set S(strlvl) "Level 1"
  25.  array set S {lvl,1 0 lvl,2 180 lvl,3 90 lvl,4 60 lvl,5 30}
  26.  
  27.  proc DoDisplay {} {
  28.     wm title . $::S(title)
  29.     CompressImages
  30.  
  31.     option add *Label.background black
  32.     frame .ctrl -relief ridge -bd 2 -bg black
  33.     canvas .c -relief ridge -bg black -height $::S(h) -width $::S(w) \
  34.         -highlightthickness 0 -bd 2 -relief raised
  35.     label .score -text Score: -fg white
  36.     .score configure  -font "[font actual [.score cget -font]] -weight bold"
  37.     option add *font [.score cget -font]
  38.  
  39.     label .vscore -textvariable S(score) -fg yellow
  40.     label .vscore2 -textvariable S(score2) -fg yellow
  41.     label .ltimer -text Time: -fg white
  42.     label .timer -textvariable S(timer) -fg yellow
  43.  
  44.     button .new -text "New Game" -command NewGame
  45.     tk_optionMenu .optlvl S(strlvl) "Level 1" "Level 2" "Level 3" "Level 4" "Level 5"
  46.     .optlvl config -highlightthickness 0
  47.     trace variable ::S(strlvl) w Tracer
  48.  
  49.     button .hint -text "Hint" -command Hint
  50.     bind .c <Button-3> {Hint 2}
  51.     button .bstat -text "Statistics" -command ShowStats
  52.     checkbutton .mute -text Mute -variable S(mute)
  53.     button .about -text About -command About
  54.  
  55.     pack .ctrl -side left -fill y -ipady 5 -ipadx 5
  56.     pack .c -side top -fill both -expand 1
  57.     grid .score -in .ctrl -sticky ew -row 1
  58.     grid .vscore -in .ctrl -sticky ew
  59.     grid .vscore2 -in .ctrl -sticky ew
  60.     grid .ltimer -in .ctrl -sticky ew
  61.     grid .timer -in .ctrl -sticky ew
  62.     grid rowconfigure .ctrl 20 -minsize 10
  63.     grid .new -in .ctrl -sticky ew -row 25 -pady 1
  64.     grid .optlvl -in .ctrl -sticky ew -pady 1
  65.     grid .hint -in .ctrl -sticky ew -pady 1
  66.     grid .bstat -in .ctrl -sticky ew -pady 1
  67.     grid .mute -in .ctrl -sticky ew -pady 1
  68.     grid rowconfigure .ctrl 50 -weight 1
  69.     grid .about -in .ctrl -row 100 -sticky ew -pady 5
  70.  
  71.     bind all <F2> {console show}
  72.     bind .c <R> Robot
  73.     bind .c <r> {Robot 10}
  74.     bind .c <z> Resize
  75.     bind .c <p> Pause
  76.     bind .c <P> Pause
  77.     focus .c
  78.  }
  79.  proc CompressImages {} {
  80.     image create photo ::img::img(0)            ;# Blank image
  81.     foreach id {1 2 3 4 5 6 7 8} {
  82.         foreach a {2 3 4} {                     ;# We need narrower images
  83.             image create photo ::img::img($id,$a)
  84.             if {$a == 4} continue
  85.             ::img::img($id,$a) copy ::img::img($id) -subsample $a $a
  86.         }
  87.     }
  88.  }
  89.  proc Tracer {var1 var2 op} {
  90.     if {$var2 == "strlvl"} {
  91.         scan $::S(strlvl) "Level %d" lvl
  92.         if {$lvl != $::S(lvl)} NewGame
  93.         return
  94.     }
  95.  }
  96.  proc NewGame {} {
  97.     Timer off
  98.     scan $::S(strlvl) "Level %d" ::S(lvl)
  99.     array set ::S {
  100.         score 0 score2 "" busy 0 click {} click1 {} click2 {} pause 0
  101.         cnt 0 time 00:00 sturn 0 tmin 0 best 0 robot 0 tbonus 0 tpause 0
  102.     }
  103.     set ::S(timer) $::S(lvl,$::S(lvl))
  104.  
  105.     if {$::S(lvl) > 1} {
  106.         .hint config -state disabled
  107.         .ltimer config -fg white
  108.         .timer config -fg yellow
  109.     } else {
  110.         .hint config -state normal
  111.         .ltimer config -fg black
  112.         .timer config -fg black
  113.     }
  114.     .c delete all
  115.     for {set row -2} {$row < $::S(rows)+2} {incr row} { ;# Initialize the board
  116.         for {set col -2} {$col < $::S(cols)+2} {incr col} {
  117.             set ::B($row,$col) -1
  118.             if {$row < 0 || $row >= $::S(rows)} continue
  119.             if {$col < 0 || $col >= $::S(cols)} continue
  120.             set ::B($row,$col) [expr {1 + int(rand() * $::S(jewels))}]
  121.             .c create image [GetXY $row $col] -tag "c$row,$col"
  122.             .c bind "c$row,$col" <Button-1> [list DoClick $row $col]
  123.         }
  124.     }
  125.     # Change all cells on initial board that would explode
  126.     while {1} {
  127.         set cells [FindExploders]
  128.         if {$cells == {}} break
  129.         foreach cell $cells {
  130.             set ::B($cell) [expr {1 + int(rand() * $::S(jewels))}]
  131.         }
  132.     }
  133.     DrawBoard 1
  134.  }
  135.  proc DrawBoard {{resize 0}} {
  136.     global S
  137.  
  138.     if {$resize} {
  139.         set S(w) [expr {$S(cell) * $S(cols) + 10}]
  140.         set S(h) [expr {$S(cell) * $S(rows) + 10}]
  141.         .c config -height $S(h) -width $S(w)
  142.     }
  143.  
  144.     .c delete box
  145.     for {set row 0} {$row < $::S(rows)} {incr row} {
  146.         for {set col 0} {$col < $::S(cols)} {incr col} {
  147.             if {$resize} {
  148.                 .c coords "c$row,$col" [GetXY $row $col]
  149.             }
  150.             .c itemconfig "c$row,$col" -image ::img::img($::B($row,$col))
  151.         }
  152.     }
  153.  }
  154.  proc GetXY {r c} {
  155.     global S
  156.     set x [expr {5 + $c * $S(cell) + $S(cell)/2}]
  157.     set y [expr {5 + $r * $S(cell) + $S(cell)/2}]
  158.     return [list $x $y]
  159.  }
  160.  proc DoClick {row col} {                        ;# Handles mouse clicks
  161.     global S
  162.  
  163.     if {$S(busy)} return
  164.     set S(busy) 1
  165.     .c delete box
  166.  
  167.     if {$S(click) == {}} {                      ;# 1st click, draw the box
  168.         set xy [.c bbox "c$row,$col"]
  169.         .c create rect $xy -tag box -outline white -width 2
  170.         set S(click) [list $row $col]
  171.         set S(busy) 0
  172.         if {$::S(timer) <= 0 && $::S(lvl) > 1} {
  173.             GameOver "Out of time"
  174.         }
  175.         return
  176.     }
  177.  
  178.     foreach {row1 col1} $S(click) break         ;# 2nd click, swap and explode
  179.     set click [list [concat $S(click) $row $col]]
  180.     set S(click) {}
  181.  
  182.     set dx [expr {abs($col - $col1)}]
  183.     set dy [expr {abs($row - $row1)}]
  184.     if {$dx <= 1 && $dy <= 1 && $dx != $dy} {   ;# Valid neighbors
  185.         SwapCells $row $col $row1 $col1
  186.         set n [Explode]
  187.         if {$n} {                               ;# Something exploded
  188.             set click {}                        ;# Clear for triple play
  189.             incr S(cnt)
  190.             incr S(tbonus) [expr {6 - $S(lvl)}] ;# Add to time bonus
  191.         } else {                                ;# Nothing exploded
  192.             # Check for triple click
  193.             if {$click == $S(click1) && $click == $S(click2)} {
  194.                 # decrease score by 10%...
  195.                 set ten [expr {round($S(score) / -10.0)}]
  196.                 if {$ten > -100} { set ten -100}
  197.                 incr S(score) $ten
  198.                 set S(score2) "($ten)"
  199.                 set click {}
  200.                 if {! $S(mute)} {catch { snd_bad play; snd_ok play }}
  201.                 incr S(cnt)
  202.             } else {
  203.                 if {! $S(mute)} {catch { snd_bad play }} ;# Nope, undo the move
  204.                 SwapCells $row1 $col1 $row $col
  205.             }
  206.         }
  207.         set S(click2) $S(click1)
  208.         set S(click1) $click
  209.         if {! [Hint 1]} {                       ;# Is the game over???
  210.             GameOver
  211.         }
  212.     }
  213.     set S(busy) 0
  214.     catch {
  215.         set ::S(sturn) [format "%.1f" [expr {$::S(score) / double($::S(cnt))}]]
  216.     }
  217.     if {$::S(cnt) == 1} {Timer start}
  218.     if {$::S(timer) <= 0 && $::S(lvl) > 1} {
  219.         GameOver "Out of time"
  220.     }
  221.  
  222.  }
  223.  proc SlideCells {cells} {                       ;# Slides some cells down
  224.     foreach {r c} $cells {
  225.         .c itemconfig c$r,$c -image {}
  226.         if {[info exists ::B($r,$c)] && $::B($r,$c) != -1} {
  227.             set M($r,$c) $::B($r,$c)
  228.         } else {
  229.             set M($r,$c) [expr {1 + int(rand() * $::S(jewels))}]
  230.         }
  231.         .c create image [GetXY $r $c] -image ::img::img($M($r,$c)) -tag slider
  232.     }
  233.     set numSteps 8
  234.     set dy [expr {double($::S(cell)) / $numSteps}]
  235.     for {set step 0} {$step < $numSteps} {incr step} {
  236.         .c move slider 0 $dy
  237.         update
  238.         after $::S(delay)
  239.     }
  240.     foreach {r c} $cells {                      ;# Update board data
  241.         set ::B([expr {$r+1}],$c) $M($r,$c)
  242.     }
  243.     DrawBoard
  244.     .c delete slider
  245.  }
  246.  proc SwapCells {r1 c1 r2 c2} {
  247.     global B
  248.  
  249.     .c itemconfig c$r1,$c1 -image {}
  250.     .c itemconfig c$r2,$c2 -image {}
  251.     foreach {x1 y1} [GetXY $r1 $c1] break
  252.     foreach {x2 y2} [GetXY $r2 $c2] break
  253.     .c create image $x1 $y1 -image ::img::img($B($r1,$c1)) -tag {slide1 slide}
  254.     .c create image $x2 $y2 -image ::img::img($B($r2,$c2)) -tag {slide2 slide}
  255.  
  256.     set numSteps 8
  257.     set dx [expr {$x2 - $x1}]
  258.     set dy [expr {$y2 - $y1}]
  259.     set dx1 [expr {double($dx) / $numSteps}]
  260.     set dy1 [expr {double($dy) / $numSteps}]
  261.     set dx2 [expr {-1 * $dx1}]
  262.     set dy2 [expr {-1 * $dy1}]
  263.     for {set step 0} {$step < $numSteps} {incr step} {
  264.         .c move slide1 $dx1 $dy1
  265.         .c move slide2 $dx2 $dy2
  266.         update
  267.         after $::S(delay)
  268.     }
  269.     .c delete slide
  270.     foreach [list B($r1,$c1) B($r2,$c2)] [list $B($r2,$c2) $B($r1,$c1)] break
  271.     DrawBoard
  272.  }
  273.  proc Explode {} {
  274.     set cnt 0
  275.     while {1} {
  276.         set cells [FindExploders]               ;# Find who should explode
  277.         if {$cells == {}} break                 ;# Nobody, we're done
  278.         incr cnt [llength $cells]
  279.         if {! $::S(mute)} {catch { snd_ok play }}
  280.         ExplodeCells $cells                     ;# Do the explosion affect
  281.         CollapseCells                           ;# Move cells down
  282.     }
  283.  
  284.     set n [expr {$cnt * $cnt}]
  285.     incr ::S(score) $n
  286.     set ::S(score2) ""                          ;# Show special scores
  287.     if {$cnt > 3} {set ::S(score2) "([expr {$cnt*$cnt}])"}
  288.     if {$n > $::S(best)} {set ::S(best) $n}
  289.     return [expr {$cnt > 0 ? 1 : 0}]
  290.  }
  291.  proc CollapseCells {} {
  292.     while {1} {                                 ;# Stop nothing slides down
  293.         set sliders {}
  294.         for {set col 0} {$col < $::S(cols)} {incr col} {
  295.             set collapse 0
  296.             for {set row [expr {$::S(rows)-1}]} {$row >= 0} {incr row -1} {
  297.                 if {$collapse || $::B($row,$col) == 0} {
  298.                     lappend sliders [expr {$row-1}] $col
  299.                     set collapse 1
  300.                 }
  301.             }
  302.         }
  303.         if {$sliders == {}} break
  304.         SlideCells $sliders
  305.     }
  306.  }
  307.  proc ExplodeCells {cells} {
  308.     foreach stage {2 3 4} {
  309.         foreach who $cells {
  310.             .c itemconfig c$who -image ::img::img($::B($who),$stage)
  311.             if {$stage == 4} {set ::B($who) 0}
  312.         }
  313.         update
  314.         after [expr {10 * $::S(delay)}]
  315.     }
  316.  }
  317.  proc FindExploders {} {                         ;# Find all triplets and up
  318.     global S B
  319.  
  320.     array set explode {}
  321.     for {set row 0} {$row < $S(rows)} {incr row} {
  322.         for {set col 0} {$col < $S(cols)} {incr col} {
  323.             set me $B($row,$col)
  324.             if {$me == 0} continue
  325.             foreach {dr dc} {-1 0 1 0 0 -1 0 1} {
  326.                 set who [list $row $col]
  327.                 for {set len 1} {1} {incr len} {
  328.                     set r [expr {$row + $len * $dr}]
  329.                     set c [expr {$col + $len * $dc}]
  330.                     if {$B($r,$c) != $me} break
  331.                     lappend who $r $c
  332.                 }
  333.                 if {$len < 3} continue
  334.                 foreach {r c} $who {
  335.                     set explode($r,$c) [list $r $c]
  336.                 }
  337.             }
  338.         }
  339.     }
  340.     return [array names explode]
  341.  }
  342.  # 0 => 1 hint, 1 => is game over, 2 => all hints
  343.  proc Hint {{how 0}} {
  344.     if {$how == 0} {
  345.         if {$::S(pause) != 0} return
  346.         incr ::S(score) -50
  347.         set ::S(score2) (-50)
  348.         if {$::S(cnt) > 0} {
  349.             set ::S(sturn) [format "%.1f" [expr {$::S(score)/double($::S(cnt))}]]
  350.         }
  351.     }
  352.     .c delete box
  353.     set S(click) {}
  354.  
  355.     set hints [FindLegalMoves $how]
  356.     set len [llength $hints]
  357.     if {$how == 1} {return [expr {$len > 0 ? 1 : 0}]}
  358.     if {$how == 0} {                            ;# Highlight only 1 hint
  359.         set hints [list [lindex $hints [expr {int(rand() * $len)}]]]
  360.     }
  361.  
  362.     foreach hint $hints {                       ;# Highlight every hint
  363.         foreach {r c} $hint { .c addtag hint withtag c$r,$c }
  364.         .c create rect [.c bbox hint] -outline white -width 3 -tag box
  365.         .c dtag hint
  366.     }
  367.     return $hints
  368.  }
  369.  proc FindLegalMoves {how} {
  370.     global S B
  371.  
  372.     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
  373.            0 1 -1 -1 0 -1    0 1  1 -1 0 -1    1 0  2  1  2 0   1 0  2 -1  2 0
  374.            2 0  1 -1 1  0    2 0  1  1 1  0    1 0 -1 -1 -1 0   1 0 -1  1 -1 0
  375.            0 1  0  3 0  2    0 1  0 -2 0 -1    1 0  3  0  2 0   1 0 -2  0 -1 0}
  376.  
  377.     set hints {}
  378.     for {set row 0} {$row < $::S(rows)} {incr row} { ;# Test each cell
  379.         for {set col 0} {$col < $::S(cols)} {incr col} {
  380.             set me $B($row,$col)
  381.             foreach {dr1 dc1 dr2 dc2 dr3 dc3} $h { ;# Check certain neighbors
  382.                 set r [expr {$row+$dr1}]; set c [expr {$col+$dc1}]
  383.                 if {$B($r,$c) != $me} continue
  384.                 set r [expr {$row+$dr2}]; set c [expr {$col+$dc2}]
  385.                 if {$B($r,$c) != $me} continue
  386.                 lappend hints [list $r $c [expr {$row+$dr3}] [expr {$col+$dc3}]]
  387.                 if {$how == 1} { return $hints }
  388.             }
  389.         }
  390.     }
  391.     return $hints
  392.  }
  393.  proc About {} {
  394.     set msg "$::S(title) v$::S(version)\nby Keith Vetter, June 2003\n"
  395.     append msg "Based on a program by Derek Ramey\n\n"
  396.     append msg "Click on adjacent gems to swap them. If you get three or\n"
  397.     append msg "more gems in a row or column, they will explode and those\n"
  398.     append msg "above will drop down and new gems will fill in the top. The\n"
  399.     append msg "game ends when you have no more moves.\n\n"
  400.  
  401.     append msg "The score for a move is the square of the number of cells\n"
  402.     append msg "exploded. Asking for a hint costs 50 points. If you are\n"
  403.     append msg "insistent and repeat an illegal move three times, it will do\n"
  404.     append msg "it but cost you 10% of your score."
  405.  
  406.     tk_messageBox -message $msg
  407.  }
  408.  proc GameOver {{txt "Game Over"}} {
  409.     .c create rect 0 0 [winfo width .c] [winfo height .c] \
  410.         -fill white -stipple gray25
  411.     .c create text [GetXY 4 5] -text $txt -font {Helvetica 28 bold} \
  412.         -fill white -tag over
  413.     .c delete box
  414.     .hint config -state disabled
  415.     Timer off
  416.     ShowStats 1
  417.  }
  418.  proc DoSounds {} {
  419.     proc snd_ok {play} {}                       ;# Stub
  420.     proc snd_bad {play} {}                      ;# Stub
  421.     if {[catch {package require base64}]} return
  422.     if {[catch {package require snack}]} return
  423.  
  424.     set s(ok) {UklGRkACAABXQVZFZm10IBAAAAABAAEAESsAABErAAABAAgAZGF0YRwCAACAgId0Z
  425.         HZbU5aMj7/MsIZ6UX6nWIiITWiIRUGUlZesvrGCiKiKTl96Fit3YF5emrGHqcqhlJuAdWxgW
  426.         01EbWSHubW1uJ2MkqGPYFVSamtvgHmEh5ybraWLkHp5Xm5oWGRvb3WSlYqMi4+JhY6Ac25xd
  427.         Xp5jYR/hoODdIN8e356goCHgoqGgIV/g35/d3N2eHZ6gIOIgouHioaNioGAfHpycHp2dH2Hi
  428.         ouNiYiKhIF9enZzd3l+dX2BgYKIjoaJhIJ/fX6AfHl8fICAgICEgISFhYF/gH+AfIJ/gH6Af
  429.         X6AfICAfYB+gn2DfoGAgIOAgYB8e3x9gIKChYCDgIN/g32Afn+BgIF+gH+BgIOAgX2CfYGAg
  430.         IB/gH9/fIB/gICBgH+Df4KAgIB9gHuBfYKAgoCAhICDgIN+gH+Af4CAgIGAg4CFgIOAgICAg
  431.         H9/f32AfoF/gn+BgICAf4B/gICAgICAgIKAgYCAgH+AfYB8f4CAgoGBgIKBgHt0cnqEi4yIh
  432.         oKHioOBeoF+gHRvbW10eYSHhoyMmI+PhIF5dm9tbW92fICJjpKRkY6JhHx5b2xlbnWAhYeOj
  433.         pSQkIiAe3R1cnNzdnx/gomLj4yJhICAfHp3d3d6fYKDhoKGgIeAhX1/eXt9foCAg4GCg4CDf
  434.         YF6gHmAfYCBgIR/h4CEf4B9fn98gHuEfYV/g4CAgn6Fe4R6gn1/gHuDe4V+g4CAgn8=}
  435.     set s(bad) {UklGRrEHAABXQVZFZm10IBAAAAABAAEAESsAABErAAABAAgAZGF0YY0HAAB/f39/
  436.         gICAgICAgICAf39/fn9/f4CAgICAf3+AgICBgYGBf359fX5/gIGChISEgX14dXZ6f4OFiIuM
  437.         iYB2bm52foSHio+Sk4x+bWBXY3mHjY2NlZqSg3NtcXp6eHd5goqLiY6Nf2tqeIKLnLGrhmJC
  438.         OWF8h4+xvJJ3WTJTeX6Eja+/mH1qUE5lfoKIlsK6h3tbL2l/go28xIR9Qz15gIq9w31+Qjp2
  439.         f4a0y4yBbkM9b3mDls6zgnY3Q3d5goWSp8yxjoF4VRlVc3iHvdGGhVYlWnt6o9irf4NAKmh2
  440.         fpnYuYOLRytleX2w2KKGg0cpYnZ9sdaiiXc7Qmx0jsbAknUvT32Dw7uhhXo+NGF1g7LPpoqE
  441.         Wj9GYXV+jK3gq4+FVihab3uJv9OWjXdEMmJxjqGsr4xqXm96iH1zflphcoqyv4xvaVNpiZSA
  442.         f4qCgIiloJh+TFRja259nbiphnxnbGJfdpKXmaKPbl1fX26JnKOYe3BiaXqMinyHgn18fYeA
  443.         e29xiot2fYiIi4h7dn+Fl6eMamNmcYGFg5Gbjn56cHVzdYWXnpB+bmhgdIibqqWHbFpUYnGH
  444.         m6igjXlrX1hohJWkjnd2e397en1/b2NufYKSoqqUe2hbVVtte5KjpKKhgmFaZ3B3f5GclYp/
  445.         gnxyamdwgIyapaGOgXFdaHeBhYN9h5eMjImBfm1pfIJ/g46WiXx1cm92gYeKkZeNf3h7fGhb
  446.         aHmAkamqnIt1X09Vb3+PoqSQhXFcYXGAhI+moYp2alZRbIKLm62tmHtkTk9hc4KVpKmehHBl
  447.         Xmh4hI6TlpOMdmpnaHOBi5OUjoRwcG5tfIWLj5GPgXl8fXyChICDeWptd3qCiYyLjI2BfYJ9
  448.         d3d3fIB/h4h+enh+g4OHhoKAeXV5gIOCgoOAfHd7gYeNj4+LgXNsam12foOMjYqLhoB+eXqD
  449.         hYeMhHVtam55h4yNjYd/fH18fH6AgYGCgoWJhnxxbnR8g4uQjIN7eXt5e36AgYGEh4N8eXp+
  450.         goSEg358e3l7gIGEh4WDgHl3eHqAhYeIhoJ7dnV3fYKEhoWDgHt8gYSGhX95dXV3fYSJiYWD
  451.         fXl6e31+gYSEg4SCfXp4d3Z5gYmNjIh+c3F0e4OHiYuKhX56eHh5fYGDg4F/fn1/hYaDgX16
  452.         eHl9gIOFh4mGgHx6d3Z6gYaJiIWCfXl4eXyBhIOBfn+Cg4SFg396dHJ0eoOLjouFgH57e36A
  453.         gH58enp7fYCFioiFgX17ent9fH+Cg4F/fn+Af3+AgYODg4OBfnt4d3l8foGFiYmGg4F/e3h2
  454.         d3uAhIaHhYJ+e3t+gIGChIOAfXp5eXt+gIOFhoOCg4F+fX19fXx8fX6AgYKDgX9/goOCgH58
  455.         e3l5fICDhYaFg4B9fn9+fXx8fH6AgoSFhYKAfnp6e35/gYKDgoB/f3+AgIGCgICAgIGBfnp4
  456.         eHyAhouNi4V8c29xeYGIjY2Gfnh1eHyBg4ODg4F+fX5+fXt7fYCEiImGgXx2dHd9g4eIh4WB
  457.         fXp5e36ChoaDf3p4eXx+gYWGhYKAfXp7fH6Ag4SDf318fH1+gYSEgoB9fH1/goODgYB9e3t8
  458.         gISIiIaAenZ2eX2Ch4qIhYB6d3h6foGFh4aDgH17ent9f4GCg4OCgX9+fX19fXx9gIKEhYSB
  459.         fnt6enx/g4SDgYB/fn59fX1+gIGBgoOCf3x7fH1/gYODgH9/f39/gYGAf318e31/goOEhIJ/
  460.         fHp6fYCDhYWDf3x6e32Ag4WFhIF+fHt8fX+AgYOEhIF/fHp6fYGEhYWDf3t6e32Ag4aGg397
  461.         enp7foCCg4OCgH9+fn5+f4CBgYGAf359fX5+foGDhIWFgn57eHh6foKFhoSAfHp6fICEh4eD
  462.         fnp4eHt/goSFhIF+fHx9gIKDgoF/fXx8fn+BgoKCgYCAf359foCAgYB/fn9/f4CBgYB+fn+A
  463.         gYKCgX99fX1+gIGCgoGAfn18fX5/gYOEg4F+fHt7fX+Cg4OCgH58fHx+gIOEhIOBfnx7e31/
  464.         gYOEhIKAfXx8fn+AgYGAf35+f3+BgoKBgH99fX5/gIGBgYB/fn1+f4GDg4OAfnx8fH6AgoOD
  465.         gX59fX5/gYGBgIB/f3+AgYGBgH9+fn5/f4CAgICAgH9+fX5+gIGCgoF/fn19fX+AgoKCgYB/
  466.         fn19foCBgoKAf359fn5/gIGBgIB/f39+fn5+f4CBgoKBgH9+fX1+gIGBgYGAgH9/fn9/f39/
  467.         f3+AgICAgICAgIB/f39/f4CAgICAgICAgYCAf35+f39/gIGAgH9+fn5/gIGCgoB/fn1+fn+A
  468.         gYGAf39/f3+AgICAgIB/f39/f3+AgICAgICAgH9/fn5/f4CAgIB/f39/gICAgIB/f35+fn9/
  469.         gIGBgIB/f39/f39/f39/f39/f4CBgYGBgH9+fX1+gIGCgoGAfn5+fn+AgYGAf35+fn5/gIGB
  470.         gYB/f35+f3+AgICAf39/f3+AgICAgH9/f39/gICAf39/f3+AgICAgICAf39/f3+AgICAgICA
  471.         f39/f39/gICAgIB/f4CAgH9/f39/f3+AgICAgICAf39/f4CAgICA}
  472.     foreach snd {ok bad} {
  473.         regsub -all {\s} $s($snd) {} sdata            ;# Bug in base64 package
  474.         sound snd_$snd
  475.         snd_$snd data [::base64::decode $sdata]
  476.     }
  477.  }
  478.  image create photo ::img::img(1) -data {
  479.     R0lGODdhHgAeALMAAAAAAAAAyAAAKAAA6EhI2FBQ/xAQSBgQSDAw////////////////////////
  480.     /////ywAAAAAHgAeAAAE/xDISau9OOvN+4RBhBDCCCEIQggshRAiAgRyyhCCCWGMEWAQhJRSCBEh
  481.     BAjkBMLAI+cxUkAjpxBCQCBnCOHAImchIEAkpxSEQCBlGOHAIqc0EMk5DSEQSBlGOAQWOYuBSM5p
  482.     SIFAyjDCgUXOQg5Eck5TCgRShhEOLHIWciCScxpSIJAyjHBgkVMeiOSchhQIpAwjHFjklAYiOach
  483.     BAIpwwgHFjkLORDJOQ0hEEgZQjiwyEkIgEhOGQQhEEhpjDnHnHOMgUIaKaUUEMhJCDEBIjmDgEHO
  484.     KSQEUpJCDERyShHgkHMEEQIEUpJCDERyShHgkHMEEwIEUpJCBERyShHgkIJzBBECBFKSQgxEckoR
  485.     4JBzBBECBFKSQgxEckoT4JBzBBECBFKSQgxEckoR4JBzBBMCBFISQkSASM4gYJBzCgmBnMYIIYwR
  486.     xggohDFCGCOEEBDICUIIYowxQoBBEEJKIUSMQSCQE5wAQhhjhAADKISUQgg55EAgpzwQyEmrvTjr
  487.     zW8EADs=}
  488.  image create photo ::img::img(2) -data {
  489.     R0lGODdhHgAeAJEAAAAAABDgAGj/WP///ywAAAAAHgAeAAACzISPqcvtDyMi8YHkA8Un+EjxgeQD
  490.     xSf4R/EDSD5Q/CD4QPEDSL4BxQ+CT/EDSL4BxQ+Cj6nLQPGB5BtQ/CD4QPGB5BtQ/CD4RvGB5APF
  491.     D4J/FB9IPlD8IPhIsYHkA8Un+GgREQTKB4pN8PEoNpBsoNgEHzEigiCJAMUm+JgQEQRJBCKCQviY
  492.     FhEESQQigkL4mBcRBEkgIgg+JkYEQRKICIKPmRFAMiIIPqZCAEmIIPiYahEEIYLgY+oFkBCCj6kq
  493.     u7sAEeFj6nL7wxhJAQA7}
  494.     image create photo ::img::img(3) -data {
  495.     R0lGODdhHgAeAJEAAAAAAP//QOjwAODgACwAAAAAHgAeAAACxISPqctLgQg+pmYEQSL4mHoRFEiE
  496.     4GMqRFACERGCj5kUG0g2wcc8ig8kn+BjAsUPIPlC8BEpvgHJN4KPRvEPSP4RfKT4CCQfCb5RfAwg
  497.     +SgEn+KjAclHAwCg+HhA8vEIPqZuknw8oPl4AAAkHw1oPhrBJ/koQPNxCL6RfASajwQfSf4BzT+C
  498.     j0byDWi+EXxEki9A84fgYwLJB5pP8DGPZAPNJviYKSIkbGYIPqaCCAmbIfiYeiKEjeBjagrQCB9T
  499.     l9ufkQIAOw==}
  500.  image create photo ::img::img(4) -data {
  501.     R0lGODdhHgAeAJEAAAAAANAAAP8AAP84OCwAAAAAHgAeAAAC/4SPqcvtD0h8zAAh+CgCFB8TRAi+
  502.     iQhQfEQQEYIPJBsoPh6ICInwSTZQfDQg2QQ7TESEwPgYICIEyCwijCRQfAQRAJIBABQbQODuCKZs
  503.     AACKHwQfjeQLAADFN6D5BiTfAAAovgHNNyD5BgBA8Q1ovgHJNwAAim9A8w1IvgEAUHwDmm9A8g0A
  504.     gOIb0HwDkm8AABTfgOYbkHwDAKD4BjTfgOQbAADFD4KPRvIFAIBiAwiQfAMBQCEYEWEiBMpHmAEg
  505.     SAAAAQRJBEg+As0m+ECy4e4OaD7BJtlwdwc0n2CLiADJR4SZoRE+iAiQfESYGYJ/AiQfU2CG4J8A
  506.     yccUGIKPqQK7BQA7}
  507.  image create photo ::img::img(5) -data {
  508.     R0lGODlhHgAeALMAAAAAAFyI/5zO/xtX/3qn/zx1/16T/zF5/2+V/wAwzT9w/6b5/wAduAA75SBg
  509.     /424/yH5BAEAAAAALAAAAAAeAB4AAwT/EMhJq704601ZcyBYOAzDWYNYHGx7NKfUDEqxujjJJU5d
  510.     BECD0HAgtkwZnmIJDAwJUILwiGHQFIFfAGFAEB4PgeAhZTkwg6sW4SWIF/CFoPyyfJbYLfsriMfn
  511.     RkgTDXhMbF5vfnAPgR2FQAh6YYpxZEaOhVh7bn2UgAdnEwyPkGxglHCfB5h4pV5hnX+MRAWsTKVQ
  512.     sLJQl6KZeYe5YmJgUrS2t3qvX8zGZhVXpMptUVwGAXUUhL+uwdZABwWCEqPcwIfo4AMX5ZkBCpGQ
  513.     W00jVdGPeU1ANgowGff4gGCp0Y8DwF94HCSIkQBhIQcDxnHwALBHA38xKpTYWCKjx48gAytEAAA7}
  514.  image create photo ::img::img(6) -data {
  515.     R0lGODdhHgAeAJEAAAAAAIDw/xjo/1jo/ywAAAAAHgAeAAACv4SPqcvtD6OcjMTHI/iYIEDxMWAI
  516.     PqKIAMU/mBmCj0ayCf7RbIKPJBto/gEOwTeSDTQfB5Lgk2yg+XiQAARQNtB8TEgAAiQCNB/T4IAA
  517.     BAjQfEyEARoAEUDzMRUMCEgAzcdUMCAgIEDzMRECaACAiADNxzSIoAAAJBtoPiZQbAAAkg00Hw8o
  518.     NsEn2UDzcYBiE3wj2UDzDyg2wUeSTfCPYhN8NBEBkn8QEQQfUYDko0AQfEwg+XgEH1OX2x9GORsp
  519.     ADs=}
  520.  image create photo ::img::img(7) -data {
  521.     R0lGODlhHgAeALMAAAAAANtNyeId0/8A/wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
  522.     AAAAACH5BAAAAAAALAAAAAAeAB4AAwSWEMhJq703AMG7/8KGAUG5gegZWmWroty7Tm0tf/dc72Me
  523.     SzvTYEgs5iYhXnFJlJEkMRdzOlCRNFYNlSpyvQDb7dX0DXNtZTNzjPWA1Us2tPOGN9FuuxFP19+9
  524.     eX5VfDGCg4B9gnJZdXBdZFFCjnSQbFpmTliWklwpQEFkGDA6QZs2njQ2oDw4LCarpXQYGrCgIj24
  525.     uQARADs=}
  526.  image create photo ::img::img(8) -data {
  527.     R0lGODlhHgAeALMAAAQCBATO/GSazDRmnJzO/KyqrDRmzHcAAMjAyNGz71/tEwB3AHg6AQEAABMA
  528.     AAAAACH5BAEAAAAALAAAAAAeAB4AAwR5EMhJq704640L/1NBeOAmnmV2jmNqrbAbsl7s2gD+2YGk
  529.     a7xAL0fjBIXDX+WITBYvzKYTtXxKr74npSDgkq5I36Aw7nS7ErCYTDJ708112XT+CuVt+huQHM9B
  530.     Xmh4MoE1fnkphYcyW10GbIxLXX+RIZSVIZiam5wbEQA7}
  531.  
  532.  proc Robot {{cnt -1}} {
  533.     global S
  534.  
  535.     if {$S(robot)} {                            ;# Already going
  536.         set S(robot) 0
  537.         return
  538.     }
  539.     set S(robot) 1
  540.  
  541.     if {$cnt == -1} {
  542.         foreach {delay S(delay)} [list $S(delay) 0] break
  543.         foreach snd {ok bad} {                      ;# Disable sound
  544.             rename snd_$snd org.snd_$snd
  545.             proc snd_$snd {play} {}
  546.         }
  547.     }
  548.  
  549.     for {} {$cnt != 0} {incr cnt -1} {
  550.         if {! $S(robot)} break
  551.         set moves [FindLegalMoves 2]
  552.         if {$moves == {}} break
  553.  
  554.         # Massage data by adding a sorting key
  555.         set all {}
  556.         foreach m $moves {
  557.             foreach {r1 c1 r2 c2} $m break
  558.  
  559.            # Top most
  560.             set mm [concat [expr {$r1 < $r2 ? $r1 : $r2}] $m]
  561.             # Random
  562.             #set mm [concat [expr {rand() * 10000}] $m]
  563.             # Bottom most
  564.             #set mm [concat [expr {$r1 > $r2 ? -$r1 : -$r2}] $m]
  565.             lappend all $mm
  566.         }
  567.         set all [lsort -index 0 -integer $all]
  568.         set move [lindex $all 0]
  569.  
  570.         foreach {. r1 c1 r2 c2} $move break
  571.         DoClick $r1 $c1
  572.         DoClick $r2 $c2
  573.     }
  574.     set S(robot) 0
  575.     if {$cnt < 0} {
  576.         set S(delay) $delay
  577.         foreach snd {ok bad} {
  578.             rename snd_$snd {}
  579.             rename org.snd_$snd snd_$snd
  580.         }
  581.     }
  582.  }
  583.  proc Timer {{how go}} {
  584.     global S
  585.     foreach a [after info] { after cancel $a }
  586.  
  587.     if {$how == "off"} return
  588.     if {$how == "start"} { set S(tstart) [clock seconds] }
  589.  
  590.     set sec [expr {[clock seconds] - $S(tstart)}]
  591.     set pause 0
  592.     if {$S(pause) != 0} {
  593.         set pause [expr {[clock seconds] - $S(pause)}]
  594.     }
  595.     set sec [expr {$sec - $pause - $S(tpause)}]
  596.  
  597.     if {$sec < 3600} {
  598.         set S(time) [clock format $sec -gmt 1 -format %M:%S]
  599.     } else {
  600.         set S(time) [clock format $sec -gmt 1 -format %H:%M:%S]
  601.     }
  602.     if {$sec > 0} {
  603.         set S(tmin) [format "%.1f" [expr {60.0 * $S(cnt) / $sec}]]
  604.     }
  605.     set S(timer) [expr {$S(lvl,$S(lvl))-$sec+$S(tbonus)+$S(tpause)}]
  606.     if {$S(timer) < 0} {set S(timer) 0}
  607.  
  608.     if {! $S(busy) && $S(timer) <= 0 && $S(lvl) > 1} {
  609.         GameOver "Out of time"
  610.         return
  611.     }
  612.     after 1000 Timer
  613.  }
  614.  proc Pause {} {
  615.     global S
  616.  
  617.     if {$S(pause) == 0} {                       ;# Pause on
  618.         if {$S(cnt) == 0} return                ;# Not started yet
  619.         set S(pause) [clock seconds]
  620.         .c create rect 0 0 [winfo width .c] [winfo height .c] \
  621.             -fill black -tag pause
  622.         .c create text [GetXY 4 5] -font {Helvetica 28 bold} \
  623.             -fill white -tag pause -text "PAUSED" -justify center
  624.         .c create text [GetXY 6 5] -font {Helvetica 12 bold} \
  625.             -fill white -tag pause -text "Press p to continue" -justify center
  626.         .c delete box
  627.     } else {                                    ;# Pause off
  628.         incr S(tpause) [expr {[clock seconds] - $S(pause)}]
  629.         set S(pause) 0
  630.         .c delete pause
  631.     }
  632.  }
  633.  proc ShowStats {{on 0}} {
  634.     set w .stats
  635.  
  636.     if {[winfo exists $w]} {
  637.         if {! $on} {destroy $w}
  638.         return
  639.     }
  640.     toplevel $w -bg black
  641.     wm title $w "$::S(title)"
  642.     wm geom $w "+[expr {[winfo x .] + [winfo width .] + 10}]+[winfo y .]"
  643.  
  644.     label $w.title -text "$::S(title) Statistics" -fg white -relief ridge
  645.     label $w.lscore -text Score: -fg white
  646.     label $w.vscore -textvariable S(score) -fg yellow
  647.     label $w.lturn -text "Turns:" -fg white
  648.     label $w.vturn -textvariable S(cnt) -fg yellow
  649.     label $w.lsturn -text "Score/turn:" -fg white
  650.     label $w.vsturn -textvariable S(sturn) -fg yellow
  651.     label $w.lbest -text "Best:" -fg white
  652.     label $w.vbest -textvariable S(best) -fg yellow
  653.     label $w.ltime -text "Time:" -fg white
  654.     label $w.vtime -textvariable S(time) -fg yellow
  655.     label $w.ltmin -text "Turns/minute:" -fg white
  656.     label $w.vtmin -textvariable S(tmin) -fg yellow
  657.  
  658.     grid $w.title -
  659.     grid $w.lscore $w.vscore
  660.     grid $w.lturn $w.vturn
  661.     grid $w.lsturn $w.vsturn
  662.     grid $w.lbest $w.vbest
  663.     grid $w.ltime $w.vtime
  664.     grid $w.ltmin $w.vtmin
  665.  }
  666.  proc Resize {} {
  667.     if {[lsearch [image names] ::img::img(1).org] == -1} {
  668.         foreach id {1 2 3 4 5 6 7 8} {
  669.             image create photo ::img::img($id).org
  670.             ::img::img($id).org copy ::img::img($id)
  671.         }
  672.     }
  673.     set zoom [expr {$::S(cell) == 30 ? 2 : 1}]
  674.     foreach id {1 2 3 4 5 6 7 8} {
  675.         image delete ::img::img($id)            ;# For easier resizing
  676.         image create photo ::img::img($id)
  677.         ::img::img($id) copy ::img::img($id).org -zoom $zoom
  678.     }
  679.     CompressImages
  680.     set ::S(cell) [image width ::img::img(1)]
  681.     DrawBoard 1
  682.  }
  683.  
  684.  DoDisplay
  685.  DoSounds
  686.  NewGame
  687.