Version 7 of tkmines

Updated 2013-08-01 19:38:21 by uniquename

Keith Vetter 2003-09-24 : There haven't been enough light entertainment pages put up on wiki recently so I thought I'd dredge up this game I revised many years ago.

P. Kern ported a simple version of XMines to tcl/tk back in 1999, but he left out what I think is the most important feature--the middle button. Those who just dabble with minesweeper probably don't know this feature, but those who want fast times rely on it heavily.

I've also added two extra features. The first, inspired by a shareware program called MineHelp, automatically uncovers neighboring squares when a numbered square has the correct number of neighboring bombs.

The second extra feature is to cheat and have the program uncover an empty or lonely square. Before you dismiss this as too cheaty, let me say that when used in a certain limited way it is extremely helpful--to wit, I use it once when beginning a new game to get something to work with (as opposed to randomly clicking squares until one pops).

The original P. Kern version can found at [L1 ]. A C and tcl version based on tclx by Joel Fine can be found at [L2 ].


HZe 16-OCT-2005 : I like this one. And I appreciate every game that's available as Tcl/Tk version. I added some features, I hope you like it:

  • when the main windows is resized, the squares adapts to the size of the window
  • the size when starting the game is set as minimum size of the window
  • seen squares get background white; this way I find it easier to distinguish them from the unseen squares

DKF 24-Nov-2005: Bug report time :-)

  • Classic minesweeper never hits a mine with your first move. It does this by moving the mine if you were about to hit it (there certainly used to be a cheat that let you confirm this). This is only the case for the first move.
  • You can continue your game after losing!
  • On slower Windows machines, the use of loads of buttons makes the whole app seem a bit sluggish (Win isn't too keen on hundreds of windows at once). Better to use a few more images and put everything on a canvas.

 #!/bin/sh
 # Restart with tcl: -*- mode: tcl; tab-width: 8; -*- \
 exec wish $0 ${1+"$@"}

 # Tkmines -- plays minesweeper w/ some extra features
 # Original tcl version: P Kern, [email protected], 99/02/18
 # (http://cns.utoronto.ca/~pkern/stuff/tkmines)
 # Revised: Keith Vetter

 # GLOBAL ARRAYS
 # board(type,x,y) => "mine", "seen", or # of neighboring mines
 # board(mark,x,y) => 0 nothing, 1 flag, 2 question
 # board(was,$x,$y) for "pop"
 # Map(Bombs)      => x,y  x,y  x,y ... => where the mines are
 # Map(Flags)      => x,y  x,y  x,y ... => where the flags are
 # player(count)   => # of mines left to be found
 # player(elapsed) => seconds since starting
 # player(auto)    => true or false
 # player(marks)   => true or false for flag marks

 package require Tk

 set usage {
    -beginner       beginner level (8x8  40 mines).
    -intermediate   medium level (16x16  60 mines).
    -expert         expert level (30x16  99 mines).
    -x <val>        x dimension of board.
    -y <val>        y dimension of board.
    -mines <val>    number of mines.
    -ratio <val>    ratio of mines to board squares.
    -seed <val>     seed for random numbers.
 }
 array set modes {beg,ident Beginner beg,XSize 8 beg,YSize 8 beg,Mines 10}
 array set modes {int,ident Intermediate int,XSize 16 int,YSize 16 int,Mines 40}
 array set modes {exp,ident Expert exp,XSize 30 exp,YSize 16 exp,Mines 99}
 array set modes {usr,ident Custom usr,XSize 16 usr,YSize 16 usr,Mines 40}
 array set board {Seed -1 ratio -1.0 custom 0}
 array set player {auto 1 marks 0 timing 0}

 # bitmaps: smiley, shades, croak, oops, flag, blank, qmark, mine, wrong, numbers

 image create bitmap smiley -background yellow -data "
 #define smiley_width 26
 #define smiley_height 26
 static unsigned char smiley_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x01, 0x00,
   0x00, 0x03, 0x06, 0x00, 0xc0, 0x00, 0x18, 0x00, 0x20, 0x00, 0x20, 0x00,
   0x10, 0x00, 0x40, 0x00, 0x10, 0x00, 0x40, 0x00, 0x08, 0x00, 0x80, 0x00,
   0x08, 0x06, 0x83, 0x00, 0x04, 0x06, 0x03, 0x01, 0x04, 0x00, 0x00, 0x01,
   0x04, 0x00, 0x00, 0x01, 0x04, 0x00, 0x00, 0x01, 0x04, 0x00, 0x00, 0x01,
   0x44, 0x00, 0x10, 0x01, 0x84, 0x00, 0x08, 0x01, 0x08, 0x03, 0x86, 0x00,
   0x08, 0xfc, 0x81, 0x00, 0x10, 0x00, 0x40, 0x00, 0x10, 0x00, 0x40, 0x00,
   0x20, 0x00, 0x20, 0x00, 0xc0, 0x00, 0x18, 0x00, 0x00, 0x03, 0x06, 0x00,
   0x00, 0xfc, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00};
 " -maskdata "
 #define smiley_width 26
 #define smiley_height 26
 static unsigned char smiley_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x01, 0x00,
   0x00, 0xff, 0x07, 0x00, 0xc0, 0xff, 0x1f, 0x00, 0xe0, 0xff, 0x3f, 0x00,
   0xf0, 0xff, 0x7f, 0x00, 0xf0, 0xff, 0x7f, 0x00, 0xf8, 0xff, 0xff, 0x00,
   0xf8, 0xff, 0xff, 0x00, 0xfc, 0xff, 0xff, 0x01, 0xfc, 0xff, 0xff, 0x01,
   0xfc, 0xff, 0xff, 0x01, 0xfc, 0xff, 0xff, 0x01, 0xfc, 0xff, 0xff, 0x01,
   0xfc, 0xff, 0xff, 0x01, 0xfc, 0xff, 0xff, 0x01, 0xf8, 0xff, 0xff, 0x00,
   0xf8, 0xff, 0xff, 0x00, 0xf0, 0xff, 0x7f, 0x00, 0xf0, 0xff, 0x7f, 0x00,
   0xe0, 0xff, 0x3f, 0x00, 0xc0, 0xff, 0x1f, 0x00, 0x00, 0xff, 0x07, 0x00,
   0x00, 0xfc, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00};
 "

 image create bitmap shades -background yellow -data "
 #define shades_width 26
 #define shades_height 26
 static unsigned char shades_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x01, 0x00,
   0x00, 0x03, 0x06, 0x00, 0xc0, 0x00, 0x18, 0x00, 0x20, 0x00, 0x20, 0x00,
   0x10, 0x00, 0x40, 0x00, 0x10, 0x00, 0x40, 0x00, 0x08, 0x00, 0x80, 0x00,
   0xc8, 0xff, 0x9f, 0x00, 0xe4, 0xdf, 0x3f, 0x01, 0x94, 0x8f, 0x4f, 0x01,
   0x0c, 0x07, 0x87, 0x01, 0x04, 0x00, 0x00, 0x01, 0x04, 0x00, 0x00, 0x01,
   0x44, 0x00, 0x10, 0x01, 0x84, 0x00, 0x08, 0x01, 0x08, 0x03, 0x86, 0x00,
   0x08, 0xfc, 0x81, 0x00, 0x10, 0x00, 0x40, 0x00, 0x10, 0x00, 0x40, 0x00,
   0x20, 0x00, 0x20, 0x00, 0xc0, 0x00, 0x18, 0x00, 0x00, 0x03, 0x06, 0x00,
   0x00, 0xfc, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00};
 " -maskdata "
 #define smiley_width 26
 #define smiley_height 26
 static unsigned char smiley_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x01, 0x00,
   0x00, 0xff, 0x07, 0x00, 0xc0, 0xff, 0x1f, 0x00, 0xe0, 0xff, 0x3f, 0x00,
   0xf0, 0xff, 0x7f, 0x00, 0xf0, 0xff, 0x7f, 0x00, 0xf8, 0xff, 0xff, 0x00,
   0xf8, 0xff, 0xff, 0x00, 0xfc, 0xff, 0xff, 0x01, 0xfc, 0xff, 0xff, 0x01,
   0xfc, 0xff, 0xff, 0x01, 0xfc, 0xff, 0xff, 0x01, 0xfc, 0xff, 0xff, 0x01,
   0xfc, 0xff, 0xff, 0x01, 0xfc, 0xff, 0xff, 0x01, 0xf8, 0xff, 0xff, 0x00,
   0xf8, 0xff, 0xff, 0x00, 0xf0, 0xff, 0x7f, 0x00, 0xf0, 0xff, 0x7f, 0x00,
   0xe0, 0xff, 0x3f, 0x00, 0xc0, 0xff, 0x1f, 0x00, 0x00, 0xff, 0x07, 0x00,
   0x00, 0xfc, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00};
 "
 image create bitmap croak -background yellow -data "
 #define croak_width 26
 #define croak_height 26
 static unsigned char croak_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x01, 0x00,
   0x00, 0x03, 0x06, 0x00, 0xc0, 0x00, 0x18, 0x00, 0x20, 0x00, 0x20, 0x00,
   0x10, 0x00, 0x40, 0x00, 0x90, 0x88, 0x48, 0x00, 0x08, 0x05, 0x85, 0x00,
   0x08, 0x02, 0x82, 0x00, 0x04, 0x05, 0x05, 0x01, 0x84, 0x88, 0x08, 0x01,
   0x04, 0x00, 0x00, 0x01, 0x04, 0x00, 0x00, 0x01, 0x04, 0x00, 0x00, 0x01,
   0x04, 0xfc, 0x01, 0x01, 0x04, 0xa3, 0x06, 0x01, 0x88, 0xa0, 0x8a, 0x00,
   0x48, 0xa0, 0x92, 0x00, 0x10, 0x20, 0x42, 0x00, 0x10, 0xc0, 0x41, 0x00,
   0x20, 0x00, 0x20, 0x00, 0xc0, 0x00, 0x18, 0x00, 0x00, 0x03, 0x06, 0x00,
   0x00, 0xfc, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00};
 " -maskdata "
 #define smiley_width 26
 #define smiley_height 26
 static unsigned char smiley_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x01, 0x00,
   0x00, 0xff, 0x07, 0x00, 0xc0, 0xff, 0x1f, 0x00, 0xe0, 0xff, 0x3f, 0x00,
   0xf0, 0xff, 0x7f, 0x00, 0xf0, 0xff, 0x7f, 0x00, 0xf8, 0xff, 0xff, 0x00,
   0xf8, 0xff, 0xff, 0x00, 0xfc, 0xff, 0xff, 0x01, 0xfc, 0xff, 0xff, 0x01,
   0xfc, 0xff, 0xff, 0x01, 0xfc, 0xff, 0xff, 0x01, 0xfc, 0xff, 0xff, 0x01,
   0xfc, 0xff, 0xff, 0x01, 0xfc, 0xff, 0xff, 0x01, 0xf8, 0xff, 0xff, 0x00,
   0xf8, 0xff, 0xff, 0x00, 0xf0, 0xff, 0x7f, 0x00, 0xf0, 0xff, 0x7f, 0x00,
   0xe0, 0xff, 0x3f, 0x00, 0xc0, 0xff, 0x1f, 0x00, 0x00, 0xff, 0x07, 0x00,
   0x00, 0xfc, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00};
 "
 image create bitmap oops -background yellow -data "
 #define img_width 26
 #define img_height 26
 static unsigned char img_bits[] = {
    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x01, 0x00,
    0x00, 0x03, 0x06, 0x00, 0xc0, 0x00, 0x18, 0x00, 0x20, 0x00, 0x20, 0x00,
    0x10, 0x00, 0x40, 0x00, 0x10, 0x00, 0x40, 0x00, 0x08, 0x07, 0x87, 0x00,
    0x08, 0x07, 0x87, 0x00, 0x04, 0x07, 0x07, 0x01, 0x04, 0x00, 0x00, 0x01,
    0x04, 0x00, 0x00, 0x01, 0x04, 0x00, 0x00, 0x01, 0x04, 0xf8, 0x00, 0x01,
    0x04, 0x8c, 0x01, 0x01, 0x04, 0x8c, 0x01, 0x01, 0x08, 0x8c, 0x81, 0x00,
    0x08, 0xf8, 0x80, 0x00, 0x10, 0x00, 0x40, 0x00, 0x10, 0x00, 0x40, 0x00,
    0x20, 0x00, 0x20, 0x00, 0xc0, 0x00, 0x18, 0x00, 0x00, 0x03, 0x06, 0x00,
    0x00, 0xfc, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00,
 };
 " -maskdata "
 #define smiley_width 26
 #define smiley_height 26
 static unsigned char smiley_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x01, 0x00,
   0x00, 0xff, 0x07, 0x00, 0xc0, 0xff, 0x1f, 0x00, 0xe0, 0xff, 0x3f, 0x00,
   0xf0, 0xff, 0x7f, 0x00, 0xf0, 0xff, 0x7f, 0x00, 0xf8, 0xff, 0xff, 0x00,
   0xf8, 0xff, 0xff, 0x00, 0xfc, 0xff, 0xff, 0x01, 0xfc, 0xff, 0xff, 0x01,
   0xfc, 0xff, 0xff, 0x01, 0xfc, 0xff, 0xff, 0x01, 0xfc, 0xff, 0xff, 0x01,
   0xfc, 0xff, 0xff, 0x01, 0xfc, 0xff, 0xff, 0x01, 0xf8, 0xff, 0xff, 0x00,
   0xf8, 0xff, 0xff, 0x00, 0xf0, 0xff, 0x7f, 0x00, 0xf0, 0xff, 0x7f, 0x00,
   0xe0, 0xff, 0x3f, 0x00, 0xc0, 0xff, 0x1f, 0x00, 0x00, 0xff, 0x07, 0x00,
   0x00, 0xfc, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00};
 "
 image create bitmap flag -background red -data "
 #define flag_width 12
 #define flag_height 12
 static unsigned char flag_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0xe0, 0x01, 0xe0, 0x01, 0xf8, 0x03, 0xf8, 0x03};
 " -maskdata "
 #define flag_width 12
 #define flag_height 12
 static unsigned char flag_bits[] = {
   0x80, 0x00, 0xc0, 0x00, 0xf0, 0x00, 0xf8, 0x00, 0xf0, 0x00, 0xc0, 0x00,
   0x80, 0x00, 0x80, 0x00, 0xe0, 0x01, 0xe0, 0x01, 0xf8, 0x03, 0xf8, 0x03};
 "
 image create bitmap blank -data "
 #define blank_width 12
 #define blank_height 12
 static unsigned char blank_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
 "
 image create bitmap qmark -foreground blue -data "
 #define huh_width 12
 #define huh_height 12
 static unsigned char huh_bits[] = {
   0xf0, 0x00, 0xf8, 0x01, 0x0c, 0x03, 0x0c, 0x03, 0x80, 0x01, 0xc0, 0x00,
   0x60, 0x00, 0x60, 0x00, 0x60, 0x00, 0x00, 0x00, 0x60, 0x00, 0x60, 0x00};
 "
 image create bitmap mine -data "
 #define mine_width 12
 #define mine_height 12
 static unsigned char mine_bits[] = {
   0x00, 0x00, 0x42, 0x08, 0xf4, 0x05, 0xf8, 0x03, 0xec, 0x07, 0xec, 0x07,
   0xfe, 0x0f, 0xfc, 0x07, 0xfc, 0x07, 0xf8, 0x03, 0xf4, 0x05, 0x42, 0x08};
 "
 image create bitmap wrong -background red -data "
 #define wrong_width 12
 #define wrong_height 12
 static unsigned char wrong_bits[] = {
   0x00, 0x00, 0x40, 0x00, 0xf0, 0x01, 0xf0, 0x00, 0x64, 0x06, 0x0c, 0x07,
   0x9e, 0x0f, 0x0c, 0x07, 0x64, 0x06, 0xf0, 0x00, 0xf0, 0x01, 0x40, 0x00};
 " -maskdata "
 #define wrong_width 12
 #define wrong_height 12
 static unsigned char wrong_bits[] = {
   0x00, 0x00, 0x42, 0x0c, 0xf6, 0x07, 0xfc, 0x03, 0xec, 0x07, 0xfc, 0x07,
   0xfe, 0x0f, 0xfc, 0x07, 0xfc, 0x07, 0xfc, 0x03, 0xf6, 0x07, 0x42, 0x0c};
 "
 set numb(0) "
 #define 0_width 12
 #define 0_height 12
 static unsigned char 0_bits[] = {
   0xf0, 0x01, 0xf8, 0x03, 0x18, 0x03, 0x18, 0x03, 0x18, 0x03, 0x18, 0x03,
   0x18, 0x03, 0x18, 0x03, 0x18, 0x03, 0x18, 0x03, 0xf8, 0x03, 0xf0, 0x01};
 "
 set numb(1) "
 #define 1_width 12
 #define 1_height 12
 static unsigned char 1_bits[] = {
   0xe0, 0x00, 0xe0, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00,
   0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xf0, 0x03, 0xf0, 0x03};
 "
 set numb(2) "
 #define 2_width 12
 #define 2_height 12
 static unsigned char 2_bits[] = {
   0xf8, 0x03, 0xf8, 0x03, 0x18, 0x03, 0x18, 0x03, 0x00, 0x03, 0x80, 0x03,
   0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0xf8, 0x03, 0xf8, 0x03};
 "
 set numb(3) "
 #define 3_width 12
 #define 3_height 12
 static unsigned char 3_bits[] = {
   0xf8, 0x03, 0xf8, 0x03, 0x00, 0x03, 0x00, 0x03, 0x00, 0x03, 0xf0, 0x03,
   0xf0, 0x03, 0x00, 0x03, 0x00, 0x03, 0x00, 0x03, 0xf8, 0x03, 0xf8, 0x03};
 "
 set numb(4) "
 #define 4_width 12
 #define 4_height 12
 static unsigned char 4_bits[] = {
   0x18, 0x00, 0x18, 0x00, 0x98, 0x01, 0x98, 0x01, 0x98, 0x01, 0x98, 0x01,
   0xf8, 0x03, 0xf8, 0x03, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01};
 "
 set numb(5) "
 #define 5_width 12
 #define 5_height 12
 static unsigned char 5_bits[] = {
   0xf8, 0x03, 0xf8, 0x03, 0x18, 0x00, 0x18, 0x00, 0x18, 0x00, 0xf8, 0x01,
   0xf0, 0x03, 0x00, 0x03, 0x00, 0x03, 0x00, 0x03, 0xf8, 0x03, 0xf8, 0x01};
 "
 set numb(6) "
 #define 6_width 12
 #define 6_height 12
 static unsigned char 6_bits[] = {
   0xf8, 0x03, 0xf8, 0x03, 0x18, 0x00, 0x18, 0x00, 0x18, 0x00, 0xf8, 0x03,
   0xf8, 0x03, 0x18, 0x03, 0x18, 0x03, 0x18, 0x03, 0xf8, 0x03, 0xf8, 0x03};
 "
 set numb(7) "
 #define 7_width 12
 #define 7_height 12
 static unsigned char 7_bits[] = {
   0xf8, 0x03, 0xf8, 0x03, 0x00, 0x03, 0x00, 0x03, 0x00, 0x03, 0x80, 0x03,
   0xc0, 0x01, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00};
 "
 set numb(8) "
 #define 8_width 12
 #define 8_height 12
 static unsigned char 8_bits[] = {
   0xf8, 0x03, 0xf8, 0x03, 0x18, 0x03, 0x18, 0x03, 0x18, 0x03, 0xf8, 0x03,
   0xf8, 0x03, 0x18, 0x03, 0x18, 0x03, 0x18, 0x03, 0xf8, 0x03, 0xf8, 0x03};
 "
 set numb(9) "
 #define 9_width 12
 #define 9_height 12
 static unsigned char 9_bits[] = {
   0xf8, 0x03, 0xf8, 0x03, 0x18, 0x03, 0x18, 0x03, 0x18, 0x03, 0xf8, 0x03,
   0xf8, 0x03, 0x00, 0x03, 0x00, 0x03, 0x00, 0x03, 0xf8, 0x03, 0xf8, 0x03};
 "

 image create bitmap 0 -data [blank cget -data]
 #image create bitmap 0 -data $numb(0) -foreground #646464
 image create bitmap 1 -data $numb(1) -foreground #0000ff
 image create bitmap 2 -data $numb(2) -foreground #00c800 ;# 00c850
 image create bitmap 3 -data $numb(3) -foreground #ff0000
 image create bitmap 4 -data $numb(4) -foreground #0000af
 image create bitmap 5 -data $numb(5) -foreground #ff00ff
 image create bitmap 6 -data $numb(6) -foreground #00c8c8
 image create bitmap 7 -data $numb(7) -foreground #b400b4
 image create bitmap 8 -data $numb(8) -foreground #000000

 proc setmode {mode} {
    global board modes

    set m [string range $mode 1 3]
    if {! [info exists modes($m,XSize)]} { return 0 }

    set board(XSize) $modes($m,XSize)
    set board(YSize) $modes($m,YSize)
    set board(Mines) $modes($m,Mines)
    return 1
 }
 ##+##########################################################################
 #
 # reveal -- Shows all the mines, and mistakes if victory is false
 #
 proc reveal {victory} {
    global board Map

    foreach coord $Map(Bombs) {
        foreach {x y} $coord break
        if {$victory} {
            if {! $board(mark,$x,$y)} {
                mark $x $y
            }
            continue
        } else {
            if {! $board(mark,$x,$y)} {
                .field.y$y.x$x configure -relief flat -image mine
            }
        }
        # Remove from the flags coordinate list
        set f [ lsearch $Map(Flags) $coord ]
        if { $f > -1 } {
            set Map(Flags) [ lreplace $Map(Flags) $f $f ]
        }
    }
    if {$victory} return

    # show mistakes, i.e. anything left in the flag coordinate list
    foreach coord $Map(Flags) {
        set j [ lindex $coord 1 ]
        set i [ lindex $coord 0 ]
        .field.y$j.x$i configure -relief flat -image wrong
    }
 }
 ##+##########################################################################
 #
 # done -- Finished, show results
 #
 proc done { type } {
    after cancel timer
    .status.butn configure -image $type
    reveal [string equal $type "shades"]
 }
 ##+##########################################################################
 #
 # step -- step on a square.
 # Value: mark, nop         if square is marked
 #        seen, nop         if square already stepped on
 #        mine, game over   if square is a mine
 #        #,    open        otherwise
 #
 proc step { x y } {
    global board

    if {$board(mark,$x,$y)} { return "mark" }
    bind .field.y$y.x$x <Button-1> break        ;# disable buttonclicks.
    # use white background for all seen squares
    .field.y$y.x$x configure -background white -activebackground white

    set type $board(type,$x,$y)
    if { $type == "seen" } { return $type }
    if { $type == "mine" } {                    ;# stepped on a mine! game over.
        .field.y$y.x$x configure -background red
        .field.y$y.x$x configure -activebackground red
        done croak
        return $type
    }
    .field.y$y.x$x configure -relief flat -image $board(type,$x,$y)
    set board(type,$x,$y) seen
    set board(mark,$x,$y) -1
    if {[incr board(Unseen) -1] == 0} { done shades }

    return $type
 }
 proc updatestatus {} {
    set ::status(count) [ format "%03d" $::player(count) ]
    set ::status(scnds) [ format "%03d" $::player(elapsed) ]
 }
 # game clock
 proc timer {} {
    set ::player(elapsed) [expr {[clock seconds] - $::player(start)}]
    after 1000 timer
    updatestatus
 }
 proc blink {how who} {
    set win .field
    foreach coord $who {
        foreach {x y} $coord {
            if {$how} {
                $win.y$y.x$x config -relief flat
            } else {
                $win.y$y.x$x config -relief raised
            }
        }
    }
    update idletasks
 }
 ##+##########################################################################
 #
 # oop -- Toggles the smiley face w/ the oops face
 #
 proc oop { how } {
    global board
    if {$board(Unseen) == 0} return             ;# If done, don't animate
    set image smiley
    if {$how} {
        set image oops
    }
    .status.butn config -image $image
 }
 ##+##########################################################################
 #
 # pop
 #
 # It clears around an uncovered numbered mine. Clearing involves stepping
 # on any unmarked & unseen neighboring squares providing:
 #  o there are exactly N squares marked as mines
 #
 # On button-down, it just sinks the neighboring squares
 # On button-up, it does the clearing
 #
 proc pop { down x y } {
    global board

    foreach {marked unseen} [neighbors $x $y] break
    blink $down $unseen

    if {$down} return                           ;# Don't clear on button-down
    if { $board(type,$x,$y) != "seen" } return  ;# Ignore if not yet uncovered

    set missing [expr {$board(was,$x,$y) - $marked}]
    if {$missing == 0} {
        foreach coord $unseen {
            foreach {xx yy} $coord break
            look $xx $yy
        }
    } elseif { $missing == [llength $unseen] } {
        ;# all unseen neighbors are mines
        ;#puts "obvious"
    }
 }
 ##+##########################################################################
 #
 # neighbors -- Returns number of marked neighbors and list of unseen neighbors.
 #
 proc neighbors {x y} {
    global board

    set unseen {}                               ;# Unseen neighbors
    set marked 0                                ;# Unmarked neighbors

    set ylist [list [expr {$y - 1}] $y [expr {$y + 1}]]
    set xlist [list [expr {$x - 1}] $x [expr {$x + 1}]]
    foreach yy $ylist {
        if { $yy < 0 || $yy >= $board(YSize) } continue
        foreach xx $xlist {
            if { $xx < 0 || $xx >= $board(XSize) } continue
            if { $yy == $y && $xx == $x } continue
            if {$board(mark,$xx,$yy) == 1} {
                incr marked
            } elseif { $board(type,$xx,$yy) != "seen" } {
                lappend unseen [list $xx $yy]
            }
        }
    }
    return [list $marked $unseen]
 }

 ##+##########################################################################
 #
 # look -- examine a square. Returns 1 if we die
 #
 proc look {x y} {
    global board timing player

    if { $player(timing) == 0 } {               ;# start the game clock.
        incr player(timing)
        after 1000 timer
    }

    set type [ step $x $y ]                 ;# "step" on it to see what's there.
    if { $type == "mine" } { return 1}
    if { $type == "mark" } { return 0}
    if { $type == "seen" } { return 0}

    auto
    if { $type > 0 } { return 0}

    # no mine(s) near by. check out neighbouring squares.
    set ylist [list [expr {$y - 1}] $y [expr {$y + 1}]]
    set xlist [list [expr {$x - 1}] $x [expr {$x + 1}]]

    incr player(inauto)                         ;# Turn off auto mode
    foreach j $ylist {
        if { $j < 0 || $j >= $board(YSize) } continue
        foreach i $xlist {
            if { $i < 0 || $i >= $board(XSize) } continue
            if { $j != $y || $i != $x } {
                look $i $j
            }
        }
    }
    incr player(inauto) -1                      ;# Turn back on auto mode
    auto
    return 0
 }
 ##+##########################################################################
 #
 # mark -- Marks a square, toggling between blank -> flag -> qmark -> blank
 #   qmark is toggled by player(marks)
 #
 proc mark { x y} {
    global player Map board

    set coord [ list $x $y ]

    # mark of -1 means already seen
    # cycle: blank (0) -> flag (1) -> qmark (2) -> blank (0)
    switch -- $board(mark,$x,$y) {
        -1 {return 0}
        0 { set bm flag
            incr player(count) -1
            lappend Map(Flags) $coord
            set board(mark,$x,$y) 1
        }
        1 { incr player(count)
            set f [ lsearch $Map(Flags) $coord ]
            if { $f > -1 } {
                set Map(Flags) [ lreplace $Map(Flags) $f $f ]
            }
            if {$player(marks)} {
                set bm qmark
                set board(mark,$x,$y) 2
            } else {
                set bm blank
                set board(mark,$x,$y) 0
            }
        }
        2 { set board(mark,$x,$y) 0
            set bm blank
        }
    }
    .field.y$y.x$x configure -image $bm
    if {$board(mark,$x,$y) > 0} {
        bind .field.y$y.x$x <Button-1> break
    } else {
        bind .field.y$y.x$x <Button-1> [list oop 1]
    }
    auto
    updatestatus
    return 0
 }
 # build the minefield. initialize settings.
 proc initboard {{force 0}} {
    global board Map player

    # Clear the board and randomize: we put all the positions into an
    # associative array keyed by a random number, and extract out the
    # first N keys for where the mines go

    catch {unset all}
    for { set y -1 } { $y <= $board(YSize) } { incr y } {
        for { set x -1 } { $x <= $board(XSize) } { incr x } {
            set board(type,$x,$y) 0             ;# No neighboring mines yet
            set board(mark,$x,$y) 0             ;# 0 blank, 1 marked
            set board(was,$x,$y)  0             ;# Copy of type
            if {$y == -1            || $x == -1}            continue
            if {$y == $board(YSize) || $x == $board(XSize)} continue

            set a [expr {rand()}]
            set all($a) [list $x $y]
        }
    }

    expr {srand([expr {$board(Seed) == -1 ? [clock clicks] : $board(Seed)}])}
    if {$board(ratio) > 0.0} {
        set v [ expr {$board(ratio) * $board(XSize) * $board(YSize) + 0.5} ]
        set board(Mines) [ expr {int($v)} ]
    }

    set mines $board(Mines)

    set Map(Bombs) {}
    set Map(Flags) {}

    foreach coord [array name all] {
        if {$mines == 0} break;
        foreach {x y} $all($coord) break

        set board(type,$x,$y) mine
        set board(was,$x,$y) mine
        incr mines -1
        lappend Map(Bombs) [ list $x $y ]

        set ylist [list [expr {$y - 1}] $y [expr {$y + 1}]]
        set xlist [list [expr {$x - 1}] $x [expr {$x + 1}]]

        # increment neighbour's counts.
        foreach j $ylist {
            foreach i $xlist {
                if { [string compare $board(type,$i,$j) "mine"] } {
                    incr board(type,$i,$j)
                    incr board(was,$i,$j)
                }
            }
        }
    }

    set player(count) $board(Mines)
    set player(inauto) 0
    set board(Unseen) [expr {($board(XSize) * $board(YSize)) - $board(Mines)}]

    set win .field
    if {!$force && [winfo exists $win]} {
        fixboard
    } else {
        catch { destroy $win }
        frame $win -relief ridge -bd 8
        pack $win -side bottom -fill both -expand 1

        for { set y 0 } { $y < $board(YSize) } { incr y } {
            frame $win.y$y
            for { set x 0 } { $x < $board(XSize) } { incr x } {
                set b $win.y$y.x$x
                button $b -bd 2 -highlightthickness 0 -image blank
                set bgnd [ $b cget -background ]
                $b configure -activebackground $bgnd
                $b config -command [list look $x $y]
                #bind $b <Button-1> "look $x $y"
                bind $b <Button-1> "oop 1"
                bind $b <ButtonRelease-1> "oop 0"
                bind $b <Button-2> "pop 1 $x $y; oop 1"
                bind $b <ButtonRelease-2> "pop 0 $x $y; oop 0"
                bind $b <Shift-Button-3> "pop 1 $x $y ; oop 1"
                bind $b <Shift-ButtonRelease-3> "pop 0 $x $y ; oop 0"
                bind $b <Button-3> "mark $x $y"
                pack $b -side left -expand 1 -fill both
            }
            pack $win.y$y -expand 1 -fill both
        }
    }
    after cancel timer
    set player(elapsed) 0
    set player(start) [clock seconds]
    set player(timing) 0
    updatestatus

    .status.butn configure -image smiley
    .status.butn configure -command initboard
    bind . <F2> initboard
    bind . <Control-a> [list auto 1]
    bind . <Control-z> [list zero]
    bind . <Control-x> [list zero 1]
 }
 ##+##########################################################################
 #
 # fixboard
 #
 # Resets the board buttons to starting state without
 # destroying and rebuilding it.
 #
 proc fixboard {} {
    global board

    catch {destroy .xyz}                        ;# Default background color
    button .xyz
    set bgnd [.xyz cget -bg]
    catch {destroy .xyz}

    set win .field
    for { set y 0 } { $y < $board(YSize) } { incr y } {
        for { set x 0 } { $x < $board(XSize) } { incr x } {
            set b $win.y$y.x$x
            $b config -image blank -relief raised
            $b config -background $bgnd -activebackground $bgnd
            bind $win.y$y.x$x <Button-1> "oop 1"
        }
    }
 }
 ##+##########################################################################
 #
 # cheat -- Prints out an text version of the board
 #
 proc cheat {} {
    global board
    for { set y 0 } { $y < $board(YSize) } { incr y } {
        for { set x 0 } { $x < $board(XSize) } { incr x } {
            if {$board(type,$x,$y) == "mine"} {
                puts -nonewline "B"
            } else {
                puts -nonewline "."
            }
        }
        puts ""
    }
 }
 ##+##########################################################################
 #
 # zero -- Finds a random safe position on the board
 #
 proc zero {{safe 0}} {
    global board

    set zero ""
    set zero2 ""
    for { set y 0 } { $y < $board(YSize) } { incr y } {
        for { set x 0 } { $x < $board(XSize) } { incr x } {
            if {$board(type,$x,$y) == 0} {
                lappend zero [list $x $y]
            } elseif {$safe && [string is int $board(type,$x,$y)]} {
                lappend zero [list $x $y]
                lappend zero2 [list $x $y]
            }
        }
    }
    set l [llength $zero]
    if {$l == 0} {set zero $zero2}
    set l [llength $zero]
    if {$l == 0} return
    set n [expr {int ($l * rand())}]
    set pos [lindex $zero $n]
    eval look $pos
 }
 # choose another mode and restart (invoked by the "Mode" menu).
 proc newmode { type } {
    setmode "-$type"
    initboard 1
 }
 # display help information (invoked by the "Help" menu).
 proc help {} {
    set w .help
    catch {destroy $w}
    wm title [toplevel $w] "TkMines Help"
    focus $w
    text $w.t -border 5 -relief flat -wrap word -yscrollcommand [list $w.s set]
    scrollbar $w.s -orient v -command [list $w.t yview]

    frame $w.bottom -bd 2 -relief ridge
    button $w.b -text "Dismiss" -command [list destroy $w]
    pack $w.bottom -side bottom -fill both
    pack $w.b -side bottom -expand 1 -pady 10 -in $w.bottom
    pack $w.s -fill y -side right
    pack $w.t -fill both -expand 1 -side left
    focus $w.t

    $w.t tag config hdr -font {Times 16}
    $w.t tag config hdr2 -font {Times 9 bold}
    $w.t tag config fix -font {Courier 9} -lmargin1 10 -lmargin2 10
    set n [font measure [$w.t cget -font] "* "]
    $w.t tag config blt -lmargin1 5 -lmargin2 [expr {5 + $n}]

    $w.t insert end "Overview" hdr \n\n
    set m "TkMines is a tcl/tk port of the popular Windows game of "
    append m "Minesweeper with a few extra features."
    append m "The object of the game is to locate all mines. If you "
    append m "uncover a mine, you lose the game.\n\n"
    $w.t insert end $m

    set m "This version contains all the features of the standard Windows "
    append m "version including the middle button functionality, plus is has a "
    append m "few extra features to eliminate some of the mechanical aspects "
    append m "of the games. See the \"Extra Menu\" section below for "
    append m "details.\n\n"
    $w.t insert end $m

    $w.t insert end "Starting a new game" hdr \n\n
    $w.t insert end "* To start a new game either click on the " blt
    $w.t insert end "smiley face or click on New on the Game menu.\n" blt
    $w.t insert end "* To change the size of the board, select Beginner, " blt
    $w.t insert end "Intermediate or Expert on the Game menu.\n\n" blt

    $w.t insert end "Playing TkMines" hdr \n\n
    $w.t insert end "* Click on a square to uncover it. " blt
    $w.t insert end "If you uncover a mine you lose." blt \n
    $w.t insert end "* If a number appears on a square, " blt
    $w.t insert end "it indicates how many of the eight neighboring " blt
    $w.t insert end "squares contain mines." blt \n
    $w.t insert end "* Right clicking on a square will mark it as a mine" blt \n
    $w.t insert end "* Middle clicking on a numbered square " blt
    $w.t insert end "will uncover all unmarked neighboring squares if the " blt
    $w.t insert end "number of marked mines equals the square's number.\n\n" blt

    $w.t insert end "Command Line Options" hdr \n\n
    $w.t insert end "TkMines recognizes the following command line options:\n"
    foreach line [split [string trim $::usage] \n] {
        $w.t insert end [string trim $line] fix \n
    }
    $w.t insert end \n

    $w.t insert end "Extra Menu" hdr \n\n

    set m "TkMines has two sets of extra features for solving the puzzle: one "
    append m "assists in the mechanical aspect of clearing mines, the other "
    append m "lets you cheat.\n\n"
    $w.t insert end $m

    $w.t insert end "The first extra feature I call "
    $w.t insert end "Auto Step." hdr2
    set m " The program searches the board for all numbered squares which "
    append m "have the correct number of marked neighboring bombs. When it "
    append m "finds such a square, it automatically uncovers all other "
    append m "neighboring squares. You can think of this as having the program "
    append m "pressing the middle button on every square of the board. "
    append m "You can have the program do this just once or always.\n\n"
    $w.t insert end $m

    set m "The second extra feature is a pure cheat. If you get stuck, you "
    append m "can have the program uncover an empty (non-bomb) square. Or it "
    append m "can uncover a lonely square--an empty square with no neighboring "
    append m "bombs.\n\n"
    append m "I typically start each game by revealing a lonely square.\n\n"
    $w.t insert end $m

    $w.t insert end "Credits" hdr \n\n
    set m "The original version was XMine by Greg Lesher ([email protected]) "
    append m "released January 1993. P. Kern ([email protected]) ported "
    append m "it to tcl/tk on February 18, 1999. This version, by "
    append m "Keith Vetter, is released in September, 2003. There's a totally "
    append m "separate version of TkMines by Joel Fine from October 1993 that "
    append m "runs under tclx."
    $w.t insert end $m
 }
 ##+##########################################################################
 #
 # DoDisplay  -- Draws the non-playing area of the display
 #
 proc DoDisplay {} {
    global board modes

    menu .m -tearoff 0
    .m add cascade -menu .m.game -label "Game" -underline 0
    .m add cascade -menu .m.extra -label  "Extra" -underline 0
    .m add cascade -menu .m.help -label "Help" -underline 0

    menu .m.game -tearoff 0
    .m.game add command -label "New" -command initboard -underline 0
    .m.game add separator
    set mlist { beg int exp }
    if {$board(custom) > 0} { lappend mlist usr }
    foreach mn $mlist {
        .m.game add command -command "newmode $mn" \
                -label $modes($mn,ident) -underline 0
    }
    .m.game add separator
    .m.game add checkbutton -label "Marks (?)" -underline 0 \
        -variable player(marks)
    .m.game add separator
    .m.game add command -label Exit -command exit -underline 1

    menu .m.extra -tearoff 0
    .m.extra add checkbutton -label "Auto Step" -command AutoToggle \
        -underline 0 -variable player(auto)
    .m.extra add command -label "Auto Step Once" -accelerator "Ctrl-A" \
        -command {auto 1} -underline 10
    AutoToggle ;# Set state of previous entry
    .m.extra add separator
    .m.extra add command -label "Step Empty Square" \
        -command {zero 1} -underline 5
    .m.extra add command -label "Step Lonely Square" -accelerator "Ctrl-Z" \
        -command zero -underline 5

    menu .m.help -tearoff 0
    .m.help add command -command help -label "Help"
    . configure -menu .m

    #####
    # set up the status display.
    set font [eval font create [font actual 12x24]]
    font configure $font -weight bold

    set win .status
    frame $win -relief ridge -bd 8
    button $win.butn -bd 3 -image smiley
    label $win.minesleft -textvariable status(count) -anchor e \
            -relief sunken -foreground red -background black \
            -font $font -width 3
    label $win.seconds -textvariable status(scnds) -anchor e \
            -relief sunken -foreground red -background black \
            -font $font -width 3
    pack $win.minesleft -side left -pady 1m -padx 1m
    pack $win.seconds -side right  -pady 1m -padx 1m
    pack $win.butn -side left -expand 1 ;#-before $win.minesleft
    pack $win -side top -fill both
    
    # set the size after first creation to the minimum size
    after 1000 {catch {wm minsize . [lindex [split [wm geometry .] x+] 0] \
        [lindex [split [wm geometry .] x+] 1]}}

 }
 ##+##########################################################################
 #
 # auto -- Loops through every square seeing if it is eligible for assistance.
 #
 proc auto {{once 0}} {
    global board player
    if {! $once && !$player(auto)} return
    if {$player(inauto)} return
    incr player(inauto) 1

    set action(1) "look"
    set action(2) "mark"

    set changes 0
    set change 1
    while {$change} {
        set change 0

        for { set x 0 } { $x < $board(XSize) } { incr x } {
            for { set y 0 } { $y < $board(YSize) } { incr y } {
                foreach {what who} [auto2 $x $y] break
                if {$what == 0} continue
                set change 1
                incr changes
                foreach pos $who {
                    set die [eval $action($what) $pos]
                    if {$die} {return $changes}
                }
                if {$once > 0} {
                    incr player(inauto) -1
                    return $changes
                }
            }
        }
        update idletasks
        if {$once > 0} break
    }
    incr player(inauto) -1
    return $changes
 }
 ##+##########################################################################
 #
 # auto2 -- Determines if square X Y is either:
 #  o has all its needed mines
 #    => step on all it's unseen neighbors
 #    => value: 1 <neighbor list>
 #
 #  o has the same amount of unseen neighbors as missing mines
 #    => mark all unseen neighbors as mines
 #    => value: 2 <neighbor list>
 #
 proc auto2 {x y} {
    global board

    if {$board(type,$x,$y) != "seen"} { return 0 }
    if {$board(was,$x,$y) == 0} { return 0 }
    foreach {marked unseen} [neighbors $x $y] break
    set l [llength $unseen]
    if {$l == 0} {return 0}

    if {$marked == $board(was,$x,$y)} {
        return [list 1 $unseen]
    }
    set missing [expr {$board(was,$x,$y) - $marked}]
    if {$missing == $l} {
        return [list 2 $unseen]
    }
    return 0
 }
 proc AutoToggle {} {
    set state normal
    if {$::player(auto)} { set state disabled }
    .m.extra entryconfigure 1 -state $state
 }

 #+##############################################################

 setmode "-exp"                                  ;# Set the default mode

 # parse command-line arguments.
 set ac 0
 foreach arg $argv {
    incr ac
    if {[ setmode $arg ] != 0} continue
    set field ""
    switch -glob -- $arg {
        -x  { set field XSize }
        -y  { set field YSize }
        -mines  { set field Mines }
        -ratio  { set board(ratio) [ lindex $argv $ac] }
        -seed   { set board(Seed) [ lindex $argv $ac] }
        -*  { puts stderr "$argv0 options: $usage"; exit 0 }
    }
    if {$field != ""} {
        set board($field) [ lindex $argv $ac ]
        set board(custom) 1

    }
 }
 if {$board(custom) > 0} {                      ;# save custom choices
    foreach field { XSize YSize Mines } {
        set modes(usr,$field) $board($field)
    }
 }
 DoDisplay
 initboard

http://img40.imageshack.us/img40/9460/image24u.gif gold added pix


uniquename 2013aug01

The image above is stored at 'external site' imageshack.us. In case that image goes dead, here is a 'locally stored' image, stored at this wiki.

vetter_tkmines_screenshot_1011x665.jpg

Note the 'smiley-face-is-dead' image at the top of the GUI. I found a mine in one click.


Category Games | Tcl/Tk games | Category Application