cgit.sxemacs.org Git - packages/blob - xemacs-packages/mine/xmine.el

   1 ;;; xmine.el --- Mine game for XEmacs
   2
   3 ;; Author:     Jens Lautenbacher <jens@tellux.de>
   4 ;; Keywords:   games
   5 ;; Version:    1.9
   6
   7 ;; This file is part of XEmacs.
   8
   9 ;; XEmacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; XEmacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with XEmacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;; Commentary: This is a complete reimplementation of the classical
  25 ;; mine searching game known from various OS/GUIs under names like
  26 ;; xmine, minesweeper etc.
  27
  28 ;; The idea to implement this in elisp is from
  29 ;; Jacques Duthen <duthen@cegelec-red.fr>,
  30 ;; the author of the original mine game for GNU Emacs. This version
  31 ;; has to the best of my knowledge no code in common with his version,
  32 ;; but cudos go to him for first starting this...
  33 ;;
  34 ;; I mainly wrote this as an example how graphics handling in XEmacs
  35 ;; is possible. I think I did it the right way, using an extension to
  36 ;; the annotation mechanism and via extensive use of `slots' (realized
  37 ;; as properties of extents) to hold the data in the object itself.
  38 ;; (Of course this is not true. The keyboard handling is controlled from
  39 ;; the "outside" of the objects. But at one time during development
  40 ;; before hacking the keyboard controls the code really _was_ nice...
  41 ;; now it's a bad messing with slots and controls from the outside)
  42 ;;
  43 ;; Code:
  44 ;;
  45 ;;; First of all we'll define the needed variables.
  46
  47 (defconst xmine-version-number "1.9" "XEmacs Mine version number.")
  48 (defconst xmine-version (format "XEmacs Mine v%s by Jens Lautenbacher © 1997"
  49                                xmine-version-number)
  50   "Full XEmacs Mine version number.")
  51
  52 (defgroup xmine nil
  53   "The well known mine searching game."
  54   :group 'games)
  55
  56 (defcustom xmine-width 25
  57   "The width of the mine field"
  58   :group 'xmine
  59   :type 'integer)
  60
  61 (defcustom xmine-height 20
  62   "The height of the mine field"
  63   :group 'xmine
  64   :type 'integer)
  65
  66 (defcustom xmine-glyph-dir (locate-data-directory "mine")
  67   "The directory where the mine glyphs reside"
  68   :group 'xmine
  69   :type 'directory)
  70
  71 (defface xmine-hidden-face
  72   '((t
  73      (:background "blue")))
  74   "The face used for hidden tiles on ttys"
  75   :group 'xmine)
  76
  77 (defface xmine-flagged-face
  78   '((t
  79      (:background "red")))
  80   "The face used for flagged tiles on ttys"
  81   :group 'xmine)
  82
  83 (defface xmine-number-face
  84   '((t
  85      (:background "green")))
  86   "The face used for unhidden, numbered tiles on ttys"
  87   :group 'xmine)
  88
  89
  90 (defvar xmine-pad-glyph
  91   (make-glyph
  92    (if (and (console-on-window-system-p) (featurep 'xpm))
  93        (concat xmine-glyph-dir "pad.xpm")
  94      "      ")))
  95
  96 (defvar xmine-title-glyph
  97   (make-glyph
  98    (if (and (console-on-window-system-p) (featurep 'xpm))
  99        (concat xmine-glyph-dir "splash.xpm")
 100      "------------------ XEmacs XMine ------------------")))
 101
 102 (defvar xmine-glyph-production-list
 103   '(("xmine-new-up"            "new_up.png"               "new"  nil)
 104     ("xmine-new-down"          "new_down.png"             "NEW"  nil)
 105     ("xmine-quit-up"           "quit_up.png"              "quit" nil)
 106     ("xmine-quit-down"         "quit_down.png"            "QUIT" nil)
 107     ("xmine-up-glyph"          "empty_16_up.png"          "@ "   xmine-hidden-face)
 108     ("xmine-up-sel-glyph"      "empty_16_up_sel.png"      "@<"   xmine-hidden-face)
 109     ("xmine-down-glyph"        "empty_16_down.png"        "? "   nil)
 110     ("xmine-flagged-glyph"     "flagged_16_up.png"        "! "   xmine-flagged-face)
 111     ("xmine-flagged-sel-glyph" "flagged_16_up_sel.png"    "!<"   xmine-flagged-face)
 112     ("xmine-mine-glyph"        "bomb_16_flat.png"         "* "   nil)
 113     ("xmine-mine-sel-glyph"    "bomb_16_flat.png"         "*<"   nil)
 114     ("xmine-trapped-glyph"     "bomb_trapped_16_flat.png" "X "   nil)
 115     ("xmine-0-glyph"           "empty_16_flat.png"        ". "   nil)
 116     ("xmine-0-sel-glyph"       "empty_16_flat_sel.png"    ".<"   nil)
 117     ("xmine-1-glyph"           "1_16_flat.png"            "1 "   xmine-number-face)
 118     ("xmine-1-sel-glyph"       "1_16_flat_sel.png"        "1<"   xmine-number-face)
 119     ("xmine-2-glyph"           "2_16_flat.png"            "2 "   xmine-number-face)
 120     ("xmine-2-sel-glyph"       "2_16_flat_sel.png"        "2<"   xmine-number-face)
 121     ("xmine-3-glyph"           "3_16_flat.png"            "3 "   xmine-number-face)
 122     ("xmine-3-sel-glyph"       "3_16_flat_sel.png"        "3<"   xmine-number-face)
 123     ("xmine-4-glyph"           "4_16_flat.png"            "4 "   xmine-number-face)
 124     ("xmine-4-sel-glyph"       "4_16_flat_sel.png"        "4<"   xmine-number-face)
 125     ("xmine-5-glyph"           "5_16_flat.png"            "5 "   xmine-number-face)
 126     ("xmine-5-sel-glyph"       "5_16_flat_sel.png"        "5<"   xmine-number-face)
 127     ("xmine-6-glyph"           "6_16_flat.png"            "6 "   xmine-number-face)
 128     ("xmine-6-sel-glyph"       "6_16_flat_sel.png"        "6<"   xmine-number-face)
 129     ("xmine-7-glyph"           "7_16_flat.png"            "7 "   xmine-number-face)
 130     ("xmine-7-sel-glyph"       "7_16_flat_sel.png"        "7<"   xmine-number-face)
 131     ("xmine-8-glyph"           "8_16_flat.png"            "8 "   xmine-number-face)
 132     ("xmine-8-sel-glyph"       "8_16_flat_sel.png"        "8<"   xmine-number-face)))
 133
 134 (defvar xmine-force-textual nil
 135   "This is for debugging purposes only. No need to set it. Really.")
 136
 137 (defun xmine-generate-glyphs ()
 138   (let ((list xmine-glyph-production-list)
 139         elem var gif text face)
 140     (while (setq elem (pop list))
 141       (setq var  (car    elem)
 142             gif  (cadr   elem)
 143             text (caddr  elem)
 144             face (cadddr elem))
 145       (set (intern var)
 146            (make-glyph (if (and (not xmine-force-textual)
 147                                 (console-on-window-system-p))
 148                            (concat xmine-glyph-dir gif)
 149                          text)))
 150       (if face
 151           (set-glyph-face (eval (intern-soft var)) face)))))
 152
 153 (xmine-generate-glyphs)
 154
 155 (defvar xmine-key-sel-button nil)
 156
 157 (defun xmine-up-glyph (ext)
 158   (if (equal ext xmine-key-sel-button)
 159       (progn
 160         (set-extent-property ext 'xmine-non-selected-glyph xmine-up-glyph)
 161         xmine-up-sel-glyph)
 162     xmine-up-glyph))
 163
 164 (defun xmine-flagged-glyph (ext)
 165   (if (equal ext xmine-key-sel-button)
 166       (progn
 167         (set-extent-property ext 'xmine-non-selected-glyph xmine-flagged-glyph)
 168         xmine-flagged-sel-glyph)
 169     xmine-flagged-glyph))
 170
 171 (defcustom xmine-%-of-mines 12
 172   "The percentage of tiles that should be mines."
 173   :group 'xmine
 174   :type 'integer)
 175
 176 (defcustom xmine-balloon-list (list "Push Me!"
 177                                     "Don't Sleep."
 178                                     "Are you sure?"
 179                                     "I'm getting bored.")
 180   "(Random) texts for the balloon-help property of the tiles.
 181 This can be a list of strings or the symbol 'yow, in which case a random quote from
 182 Zippy The Pinhead will be used..."
 183   :group 'xmine
 184   :type '(choice (repeat string) (const yow)))
 185
 186 (defcustom xmine-background "white"
 187   "The background color of XMine's buffer.
 188 Many colors will not blend nicely with the logo. Shades of light grey are
 189 preferred if you don't want to use white."
 190   :group 'xmine
 191   :type 'color)
 192
 193 (defvar xmine-keymap nil)
 194
 195 (if xmine-keymap ()
 196   (setq xmine-keymap (make-sparse-keymap))
 197   (suppress-keymap xmine-keymap)
 198   (define-key xmine-keymap [up] 'xmine-key-up)
 199   (define-key xmine-keymap [down] 'xmine-key-down)
 200   (define-key xmine-keymap [right] 'xmine-key-right)
 201   (define-key xmine-keymap [left] 'xmine-key-left)
 202   (define-key xmine-keymap "e" 'xmine-key-up)
 203   (define-key xmine-keymap "c" 'xmine-key-down)
 204   (define-key xmine-keymap "f" 'xmine-key-right)
 205   (define-key xmine-keymap "s" 'xmine-key-left)
 206   (define-key xmine-keymap "w" 'xmine-key-up-left)
 207   (define-key xmine-keymap "x" 'xmine-key-down-left)
 208   (define-key xmine-keymap "r" 'xmine-key-up-right)
 209   (define-key xmine-keymap "v" 'xmine-key-down-right)
 210   (define-key xmine-keymap [return] 'xmine-key-action3)
 211   (define-key xmine-keymap "d" 'xmine-key-action3)
 212   (define-key xmine-keymap [(shift space)] 'xmine-key-action2)
 213   (define-key xmine-keymap "a" 'xmine-key-action2)
 214   (define-key xmine-keymap [space] 'xmine-key-action1)
 215   (define-key xmine-keymap [Q] 'xmine-key-quit)
 216   (define-key xmine-keymap [N] 'xmine-key-new))
 217
 218 (defvar xmine-number-of-flagged 0)
 219
 220 (defvar xmine-number-of-opened 0)
 221
 222 (defvar xmine-number-of-mines 0)
 223
 224 (defvar xmine-field nil)
 225
 226 (defvar xmine-buffer nil)
 227
 228 (defvar xmine-quit-ann nil)
 229
 230 (defvar xmine-new-ann nil)
 231
 232 (defvar xmine-count-ann nil)
 233
 234 (defvar xmine-count-glyph (make-glyph "Mines: 00"))
 235
 236 (defvar xmine-mode-hook nil
 237   "*Hook called by `xmine-mode-hook'.")
 238
 239 ;; the next function is more or less stolen from annotation.el and
 240 ;; modified to fit in our scheme were all three buttons should trigger
 241 ;; actions
 242
 243 (defun xmine-activate-function-button (event)
 244   (interactive "e")
 245   (let* ((extent (event-glyph-extent event))
 246          (button (number-to-string (event-button event)))
 247          (action (intern (concat "action" button)))
 248          (down-action (intern (concat "down-action" button)))
 249          (restore-down-action (intern (concat "restore-down-action" button)))
 250          (mouse-down t)
 251          (action-do-it t)
 252          up-glyph)
 253     ;; make the glyph look pressed
 254     (cond ((annotation-down-glyph extent)
 255            (setq up-glyph (annotation-glyph extent))
 256            (set-annotation-glyph extent (annotation-down-glyph extent))))
 257     (if (extent-property extent down-action)
 258         (setq action-do-it
 259               (funcall (extent-property extent down-action) extent)))
 260     (while mouse-down
 261       (setq event (next-event event))
 262       (if (button-release-event-p event)
 263           (setq mouse-down nil)))
 264     ;; make the glyph look released
 265     (cond ((annotation-down-glyph extent)
 266            (set-annotation-glyph extent up-glyph)))
 267     (if (eq extent (event-glyph-extent event))
 268         (if (and (extent-property extent action) action-do-it)
 269             (funcall (extent-property extent action) extent)
 270           (if (extent-property extent restore-down-action)
 271               (funcall (extent-property extent restore-down-action) extent)))
 272       (if (extent-property extent restore-down-action)
 273               (funcall (extent-property extent restore-down-action) extent)))))
 274
 275 ;;; Here we define the button object's constructor function
 276
 277 (defun xmine-button-create (x y type)
 278   (let ((ext (make-annotation
 279               xmine-up-glyph nil 'text nil nil xmine-down-glyph nil)))
 280     (set-extent-property ext 'action1 'xmine-action1)
 281     (set-extent-property ext 'action2 'xmine-beep)
 282     (set-extent-property ext 'action3 'xmine-action3)
 283     (set-extent-property ext 'down-action2 'xmine-down-action2)
 284     (set-extent-property ext 'restore-down-action2 'xmine-restore-down-action2)
 285     (set-extent-property ext 'xmine-glyph (xmine-type-to-glyph type))
 286     (set-extent-property ext 'xmine-sel-glyph (xmine-type-to-sel-glyph type))
 287     (set-extent-property ext 'xmine-type type)
 288     (set-extent-property ext 'xmine-x x)
 289     (set-extent-property ext 'xmine-y y)
 290     (set-extent-property ext 'xmine-flagged nil)
 291     (set-extent-property ext 'xmine-hidden t)
 292     (set-extent-property ext 'end-open t)
 293     (set-extent-property ext 'balloon-help (xmine-balloon-text))
 294     (aset xmine-field (+ (* (1- y) xmine-width) (1- x)) ext)))
 295
 296 ;;; ...and this is the second global function to change a
 297 ;;; button object. It is only needed during creation of the board.
 298
 299 (defun xmine-button-change-type (ext type)
 300   (set-extent-property ext 'xmine-glyph (xmine-type-to-glyph type))
 301   (set-extent-property ext 'xmine-sel-glyph (xmine-type-to-sel-glyph type))
 302   (set-extent-property ext 'xmine-type type))
 303
 304 ;;; some needed predicates.
 305
 306 (defun xmine-flat-button-p (ext)
 307   (and ext
 308        (not (extent-property ext 'xmine-hidden))
 309        (equal "0" (extent-property ext 'xmine-type))))
 310
 311 (defun xmine-enough-flagged-p (ext)
 312   (let ((list (xmine-get-neighbours ext))
 313         (number (extent-property ext 'xmine-type))
 314         (flagged 0) elem res)
 315     (if (not (or (equal number "mine")
 316                  (equal number "0")))
 317         (progn
 318           (setq number (string-to-number number))
 319           (while (setq elem (pop list))
 320             (if (extent-property elem 'xmine-flagged)
 321                 (setq flagged (1+ flagged))))
 322           (setq res (>= flagged number))
 323           ))
 324     res))
 325
 326
 327 (defun xmine-mine-button-p (ext)
 328   (and ext
 329        (equal "mine" (extent-property ext 'xmine-type))))
 330
 331 ;;; the next three functions are helper functions used inside a button
 332 ;;; object.
 333
 334 (defun xmine-balloon-text ()
 335   (if (eq xmine-balloon-list 'yow)
 336       (progn
 337         (or (featurep 'yow) (require 'yow)
 338             (error "You need to have YOW installed!"))
 339         (yow))
 340     (nth (random (length xmine-balloon-list)) xmine-balloon-list)))
 341
 342 (defun xmine-beep (&rest forget)
 343   (beep))
 344
 345 (defun xmine-type-to-glyph (type)
 346   (eval (intern-soft (concat "xmine-" type "-glyph"))))
 347
 348 (defun xmine-type-to-sel-glyph (type)
 349   (eval (intern-soft (concat "xmine-" type "-sel-glyph"))))
 350
 351 ;;; the next 3 functions are the main functions that are used
 352 ;;; inside the button objects and which are bound to the 'action1,
 353 ;;; 'action2 and 'action3 slots respectively
 354
 355 (defun xmine-action1 (ext &optional no-repaint force)
 356   "This unhides a hidden button"
 357   (if (or force
 358           (not (extent-property ext 'xmine-flagged)))
 359       (progn
 360         (if (and (not force)
 361                  (extent-property ext 'xmine-hidden))
 362             (setq xmine-number-of-opened (1+ xmine-number-of-opened)))
 363         (set-extent-property ext 'xmine-hidden nil)
 364         (set-annotation-glyph ext (if (equal ext xmine-key-sel-button)
 365                                       (progn
 366                                         (set-extent-property
 367                                          ext 'xmine-non-selected-glyph
 368                                          (extent-property ext 'xmine-glyph))
 369                                         (extent-property ext 'xmine-sel-glyph))
 370                                     (extent-property ext 'xmine-glyph)))
 371         (set-extent-property ext 'action3 nil)
 372         (set-extent-property ext 'action1 nil)
 373         (set-extent-property ext 'balloon-help nil)
 374         (set-extent-property ext 'action2 'xmine-action2)
 375         (if (not no-repaint)
 376             (progn
 377               (xmine-unhide-sound)
 378               (xmine-field-repaint ext)
 379               (if (and (xmine-game-solved-p)
 380                        (not (xmine-mine-button-p ext)))
 381                        (xmine-end-game)))))))
 382
 383 (defun xmine-action2 (ext)
 384   "This unhides all hidden neighbours of a button.
 385 It is meant as convenience function you can use if you're sure that
 386 you've marked all mines around the button correctly (or you're sure
 387 there isn't one)"
 388   (let ((list (xmine-get-neighbours ext))
 389         (xmine-no-unhide-sound t)
 390         next)
 391 ;;    (xmine-restore-down-action2 ext)
 392     (if list (xmine-unhide-many-sound))
 393     (while (setq next (pop list))
 394       (if (not (xmine-flat-button-p next)) (xmine-action1 next)))))
 395
 396 (defun xmine-action3 (ext)
 397   "This toggles the flagged status of a button.
 398 You flag a button if you know - or think - that there's a mine under it"
 399   (if (extent-property ext 'xmine-flagged)
 400       (progn
 401         (set-annotation-glyph ext (xmine-up-glyph ext))
 402         (set-extent-property ext 'action1 'xmine-action1)
 403         (set-extent-property ext 'xmine-flagged nil)
 404         (setq xmine-number-of-flagged (1- xmine-number-of-flagged))
 405         (xmine-flag-sound)
 406         (set-annotation-glyph xmine-count-ann
 407                               (make-glyph
 408                                (format "Mines: %2d"
 409                                        (- xmine-number-of-mines
 410                                             xmine-number-of-flagged)))))
 411     (if (= xmine-number-of-flagged xmine-number-of-mines)
 412         (progn
 413           (beep)
 414           (message
 415            "Impossible. You seem to have marked too many tiles as mines?"))
 416       (set-annotation-glyph ext (xmine-flagged-glyph ext))
 417       (set-extent-property ext 'action1 nil)
 418       (set-extent-property ext 'xmine-flagged t)
 419       (setq xmine-number-of-flagged (1+ xmine-number-of-flagged))
 420       (xmine-flag-sound)
 421       (if (xmine-game-solved-p) (xmine-end-game)
 422         (set-annotation-glyph xmine-count-ann
 423                               (make-glyph
 424                                (format "Mines: %2d"
 425                                        (- xmine-number-of-mines
 426                                           xmine-number-of-flagged))))))))
 427
 428
 429 (defun xmine-down-action2 (ext)
 430   (let ((list (xmine-get-neighbours ext))
 431         (do-it (xmine-enough-flagged-p ext))
 432         elem)
 433     (if (not do-it)
 434         (while (setq elem (pop list))
 435           (set-extent-property elem 'xmine-temp-glyph (annotation-glyph elem))
 436           (set-annotation-glyph elem (annotation-down-glyph elem))))
 437     do-it))
 438
 439 (defun xmine-restore-down-action2 (ext)
 440   (let ((list (xmine-get-neighbours ext))
 441         elem)
 442     (while (setq elem (pop list))
 443       (set-annotation-glyph elem (extent-property elem 'xmine-temp-glyph)))))
 444
 445 ;;; the sounds...
 446 (defcustom xmine-play-sounds nil
 447   "If XMine should play some sounds for various events to happen."
 448   :group 'xmine
 449   :type 'boolean)
 450
 451 (defun xmine-play-sounds-p ()
 452   (and xmine-play-sounds
 453        (or (featurep 'native-sound)
 454            (featurep 'nas-sound))
 455        (or (device-sound-enabled-p)
 456            (and (featurep 'native-sound)
 457                 (not native-sound-only-on-console)
 458                 (eq (device-type) 'x)))))
 459
 460
 461 (defcustom xmine-flag-sound (locate-data-file (concat
 462                         (file-name-as-directory "sounds") "click.au"))
 463   "The sound played when flagging/un-flagging a tile"
 464   :group 'xmine
 465   :type 'file)
 466
 467 (defcustom xmine-unhide-sound (locate-data-file (concat
 468                         (file-name-as-directory "sounds") "drip.au"))
 469   "The sound played when unhiding a tile"
 470   :group 'xmine
 471   :type 'file)
 472
 473 (defcustom xmine-unhide-many-sound (locate-data-file (concat
 474                         (file-name-as-directory "sounds") "boing.au"))
 475   "The sound played when unhiding all neighbours of a tile"
 476   :group 'xmine
 477   :type 'file)
 478
 479 (defcustom xmine-explode-sound (concat xmine-glyph-dir "explosion3.au")
 480   "The sound played when you unhide a mine"
 481   :group 'xmine
 482   :type 'file)
 483
 484 (defcustom xmine-solved-sound (locate-data-file (concat
 485                         (file-name-as-directory "sounds") "im_so_happy.au"))
 486   "The sound played if you managed to win the game."
 487   :group 'xmine
 488   :type 'file)
 489
 490 (defun xmine-flag-sound ()
 491   (if (xmine-play-sounds-p)
 492       (play-sound-file xmine-flag-sound)))
 493
 494 (defvar xmine-no-unhide-sound nil)
 495
 496 (defun xmine-unhide-sound ()
 497   (if (and (xmine-play-sounds-p)
 498            (not xmine-no-unhide-sound))
 499       (play-sound-file xmine-unhide-sound)))
 500
 501 (defun xmine-unhide-many-sound ()
 502   (if (xmine-play-sounds-p)
 503       (play-sound-file xmine-unhide-many-sound)))
 504
 505 (defun xmine-explode-sound ()
 506   (if (xmine-play-sounds-p)
 507       (play-sound-file xmine-explode-sound)
 508     (beep)))
 509
 510 (defun xmine-solved-sound ()
 511   (if (xmine-play-sounds-p)
 512       (play-sound-file xmine-solved-sound)
 513     (beep)))
 514
 515
 516 ;;; what to do after a button is unhidden: We (maybe) have to repaint
 517 ;;; parts of the board. This is done here recursively.
 518
 519 (defun xmine-field-repaint (ext)
 520   (let* ((flatp  (xmine-flat-button-p ext))
 521          (minep  (xmine-mine-button-p ext))
 522          (neighbours (xmine-get-neighbours ext))
 523          (max-lisp-eval-depth (* 8 xmine-width xmine-height))
 524          next-ext ext-list)
 525     (cond (flatp
 526            (while (setq next-ext (pop neighbours))
 527              (if (extent-property next-ext 'xmine-hidden)
 528                  (progn
 529                    (xmine-action1 next-ext 'no-repaint)
 530                    (and (equal "0" (extent-property next-ext 'xmine-type))
 531                         (push next-ext ext-list)))))
 532            (while ext-list
 533              (setq next-ext (pop ext-list))
 534              (xmine-field-repaint next-ext)))
 535           (minep
 536            (set-extent-property ext 'xmine-glyph xmine-trapped-glyph)
 537            (set-extent-property ext 'xmine-sel-glyph xmine-trapped-glyph)
 538            (xmine-show-all)
 539            (xmine-end-game-trapped)))))
 540
 541
 542 (defun xmine-get-neighbours (ext)
 543   "This gives back a list of all neighbours of a button, correctly
 544   handling buttons at the side or corner of course"
 545 (let* ((x (extent-property ext 'xmine-x))
 546          (y (extent-property ext 'xmine-y))
 547          next-coord next list
 548          (neighbours  (list (list (1- x) (1+ y))
 549                             (list     x  (1+ y))
 550                             (list (1+ x) (1+ y))
 551                             (list (1- x) (1- y))
 552                             (list     x  (1- y))
 553                             (list (1+ x) (1- y))
 554                             (list (1+ x)     y)
 555                             (list (1- x)     y))))
 556     (while (setq next-coord (pop neighbours))
 557       (if (setq next (xmine-field-button-at (car next-coord)
 558                                             (cadr next-coord)))
 559           (push next list)))
 560     list))
 561
 562
 563 ;;; the next four functions are used to know if we're at the end of
 564 ;;; the game (either successfully or exploded) and do the approbate
 565 ;;; action
 566
 567 (defun xmine-game-solved-p ()
 568   "You have solved the game successfully if the number of flagged
 569 mines plus the number of unhidden buttons equals width*height of the field"
 570   (equal (+ xmine-number-of-flagged xmine-number-of-opened)
 571          (* xmine-width xmine-height)))
 572
 573 (defun xmine-end-game ()
 574   (set-annotation-glyph xmine-count-ann
 575                         (make-glyph " Solved. "))
 576   (sit-for 0)
 577   (xmine-solved-sound))
 578
 579 (defun xmine-end-game-trapped ()
 580   (xmine-explode-sound)
 581   (set-annotation-glyph xmine-count-ann
 582                         (make-glyph "++ RIP ++")))
 583
 584 (defun xmine-show-all ()
 585   (let ((list (append xmine-field nil))
 586         next)
 587     (while (setq next (pop list))
 588       (xmine-action1 next 'no-repaint 'force))))
 589
 590
 591 (defun xmine-field-button-at (x y)
 592   "This function gives back the button at a given coordinate pair (x y)
 593 It is only used during creation of the board and when getting the
 594 neighbours of a button (and for keyboard handling...), as we don't
 595 want to use coordinates in the main loop, only the button object
 596 itself should be referenced. Of course the use of this function could
 597 be avoided in xmine-get-neighbours by storing the neighbour buttons
 598 directly in the button, but this seems to be a bit oversized for this
 599 little game."
 600   (if (or (> x xmine-width)  (< x 1)
 601           (> y xmine-height) (< y 1)) nil
 602     (aref xmine-field (+ (* (1- y) xmine-width) (1- x)))))
 603
 604 ;;;###autoload
 605 (defun xmine-mode ()
 606 "A mode for playing the well known mine searching game.
 607
 608    `\\<annotation-local-map-default>\\[xmine-activate-function-button1]' or `\\<xmine-keymap>\\[xmine-key-action1]' unhides a tile,
 609    `\\<annotation-local-map-default>\\[xmine-activate-function-button2]' or `\\<xmine-keymap>\\[xmine-key-action2]' unhides all neighbours of a tile,
 610    `\\<annotation-local-map-default>\\[xmine-activate-function-button3]' or `\\<xmine-keymap>\\[xmine-key-action3]' (un)flagges a tile to hold a mine.
 611
 612    `\\[xmine-key-new]' starts a new game.
 613    `\\[xmine-key-quit]' ends a game.
 614
 615 All keybindings (with alternatives) currently in effect:
 616    \\{xmine-keymap}
 617
 618 The rules are quite easy: You start by unhiding (random) tiles. An unhidden
 619 tile showing a number tells you something about the number of mines in it's
 620 neighborhood, where the neighborhood are all 8 tiles (or less if it's
 621 at a border) around the tile.
 622
 623 E.g. a \"1\" shows you that there is only one mine in the neighborhood of
 624 this tile. Empty tiles have no mines around them, and empty tiles in
 625 the neighborhood of another empty tile are all automatically unhidden
 626 if you unhide one of them. You need to find a strategy to use the
 627 information you have from the numbers to \"flag\" the tiles with mines
 628 under them and unhide all other tiles. If you correctly made this
 629 without accidently unhiding a mine, you've won.
 630
 631 If you are sure you have correctly flagged all mines around a unhidden tile,
 632 you can use Button-2 or \\[xmine-key-action2] on it to unhide all it's
 633 neighbors. But beware: If you made a mistake by flagging the wrong mines,
 634 you'll blow up!
 635
 636 Have Fun."
 637   (interactive)
 638   (xmine-field-create))
 639
 640 ;;;###autoload
 641 (fset 'xmine 'xmine-mode)
 642
 643 (defun xmine-field-create ()
 644   "We create the playing board here."
 645   (let ((width 1)
 646         (height 1)
 647         (pop-up-windows nil)
 648         total)
 649     (xmine-buffer-init)
 650     (pop-to-buffer xmine-buffer)
 651     (setq total (* xmine-height xmine-width))
 652     (setq xmine-field (make-vector total nil))
 653     (xmine-init-mines
 654      (setq xmine-number-of-mines
 655            (min 99 (round (* (/ (float xmine-%-of-mines) 100) total)))))
 656     (insert "\n ")
 657     (set-extent-end-glyph (make-extent (point) (point)) xmine-title-glyph)
 658     (insert "\n\n")
 659     (while (<= height xmine-height)
 660       (insert " ")
 661       (while (<= width xmine-width)
 662         (if (xmine-field-button-at width height)
 663             (xmine-button-create width height "mine")
 664           (xmine-button-create width height "0"))
 665         (setq width (+ width 1)))
 666       (insert " \n")
 667       (setq width 1)
 668       (setq height (+ height 1)))
 669     (insert "\n  ")
 670     (set-extent-begin-glyph (make-extent (point) (point)) xmine-pad-glyph)
 671     (setq xmine-new-ann
 672           (make-annotation xmine-new-up nil
 673                            'text nil nil xmine-new-down nil))
 674     (set-extent-property xmine-new-ann 'action1 '(lambda (&rest egal)
 675                                                    (xmine-field-create)))
 676     (set-extent-property xmine-new-ann 'action2 nil)
 677     (set-extent-property xmine-new-ann 'action3 nil)
 678     (set-extent-property xmine-new-ann 'end-open t)
 679     (set-extent-begin-glyph (make-extent (point) (point)) xmine-pad-glyph)
 680     (setq xmine-count-ann
 681           (make-annotation xmine-count-glyph nil
 682                            'text nil nil nil nil))
 683     (set-extent-begin-glyph (make-extent (point) (point)) xmine-pad-glyph)
 684     (setq xmine-quit-ann
 685           (make-annotation xmine-quit-up nil
 686                            'text nil nil xmine-quit-down nil))
 687     (set-extent-property xmine-quit-ann 'action1
 688                          '(lambda (&rest egal)
 689                             (kill-buffer (current-buffer))))
 690     (set-extent-property xmine-quit-ann 'action2 nil)
 691     (set-extent-property xmine-quit-ann 'action3 nil)
 692     (set-extent-property xmine-quit-ann 'end-open t)
 693     (xmine-attach-numbers)
 694     (setq xmine-number-of-flagged 0)
 695     (setq xmine-number-of-opened 0)
 696     (set-annotation-glyph xmine-count-ann
 697                           (make-glyph
 698                            (format "Mines: %2d" xmine-number-of-mines)))
 699     (goto-char (point-min))
 700     (setq buffer-read-only 't)
 701     (if (console-on-window-system-p)
 702         (set-specifier (face-background 'default)
 703                        xmine-background xmine-buffer))
 704     (set-specifier (face-background 'text-cursor)
 705                    xmine-background xmine-buffer)
 706     (setq xmine-key-sel-button nil)
 707     (xmine-select-button (xmine-field-button-at (/ xmine-width 2)
 708                                                 (/ xmine-height 2)))))
 709
 710
 711 (defun xmine-init-mines (num)
 712   "A subroutine for xmine-field create.
 713 We randomly set a part of the nil-filled board vector with t to
 714 indicate the places where mines should reside."
 715   (let (x y elem)
 716     (random t)
 717     (while (> num 0)
 718       (setq x (1+ (random xmine-width)))
 719       (setq y (1+ (random xmine-height)))
 720       (setq elem (xmine-field-button-at x y))
 721       (if (not elem)
 722           (progn
 723             (aset xmine-field (+ (* (1- y) xmine-width) (1- x)) t)
 724             (setq num (1- num)))))))
 725
 726 (defun xmine-attach-numbers ()
 727   "A subroutine for xmine-field-create.
 728 The board is populated by now with empty buttons and mines. Here we
 729 change the correct empty buttons to \"numbered\" buttons"
 730   (let
 731       ((buttons (append xmine-field nil))
 732        ext)
 733     (while (setq ext (pop buttons))
 734       (let ((num 0)
 735             (minep (xmine-mine-button-p ext))
 736             (neighbours (xmine-get-neighbours ext))
 737             next)
 738         (if (not minep)
 739             (progn
 740               (while (setq next (pop neighbours))
 741                 (if (xmine-mine-button-p next) (setq num (1+ num))))
 742               (if (> num 0)
 743                   (xmine-button-change-type ext (number-to-string num)))))))))
 744
 745
 746 (defun xmine-buffer-init ()
 747   "A subroutine for xmine-create-field.
 748 We set up the XMine buffer, set up the keymap and so on."
 749   (if xmine-buffer (kill-buffer xmine-buffer))
 750   (setq xmine-buffer (get-buffer-create "XEmacs Mine"))
 751   (save-excursion
 752     (set-buffer xmine-buffer)
 753     (kill-all-local-variables)
 754     (make-local-variable 'annotation-local-map-default)
 755     (setq truncate-lines 't)
 756     (setq major-mode 'xmine-mode)
 757     (setq mode-name "XMine")
 758     (put 'xmine-mode 'mode-class 'special)
 759     (use-local-map xmine-keymap)
 760     (buffer-disable-undo (current-buffer))
 761     (setq annotation-local-map-default
 762           (let ((map (make-sparse-keymap)))
 763             (set-keymap-name map 'annotation-local-map)
 764             (define-key map 'button1 'xmine-activate-function-button)
 765             (define-key map 'button2 'xmine-activate-function-button)
 766             (define-key map 'button3 'xmine-activate-function-button)
 767             map))
 768     (run-hooks 'xmine-mode-hook)))
 769
 770 ;;; The keyboard navigation.
 771
 772 (defun xmine-select-button (ext)
 773   (let ((flagged (extent-property ext 'xmine-flagged))
 774         (hidden  (extent-property ext 'xmine-hidden))
 775         sel-glyph)
 776     (setq sel-glyph (if hidden
 777                        (if flagged xmine-flagged-sel-glyph
 778                          xmine-up-sel-glyph)
 779                       (extent-property ext 'xmine-sel-glyph)))
 780     (if xmine-key-sel-button
 781         (set-annotation-glyph xmine-key-sel-button
 782                               (extent-property xmine-key-sel-button
 783                                                'xmine-non-selected-glyph)))
 784     (set-extent-property ext 'xmine-non-selected-glyph
 785                          (annotation-glyph ext))
 786     (set-annotation-glyph ext sel-glyph)
 787     (setq xmine-key-sel-button ext)))
 788
 789 (defun xmine-key-action1 ()
 790   (interactive)
 791   (let ((action (extent-property xmine-key-sel-button 'action1)))
 792     (if action
 793         (funcall action xmine-key-sel-button))))
 794
 795 (defun xmine-key-action2 ()
 796   (interactive)
 797   (let ((action (extent-property xmine-key-sel-button 'action2)))
 798     (if (and action (xmine-enough-flagged-p xmine-key-sel-button))
 799         (funcall action xmine-key-sel-button)
 800       (beep))))
 801
 802 (defun xmine-key-action3 ()
 803   (interactive)
 804   (let ((action (extent-property xmine-key-sel-button 'action3)))
 805     (if action
 806         (funcall action xmine-key-sel-button))))
 807
 808 (defun xmine-key-quit ()
 809   (interactive)
 810   (kill-buffer (current-buffer)))
 811
 812 (defun xmine-key-new ()
 813   (interactive)
 814   (xmine-field-create))
 815
 816 (defun xmine-key-down-right ()
 817   (interactive)
 818   (xmine-key-down)
 819   (xmine-key-right))
 820
 821 (defun xmine-key-down-left ()
 822   (interactive)
 823   (xmine-key-down)
 824   (xmine-key-left))
 825
 826 (defun xmine-key-up-right ()
 827   (interactive)
 828   (xmine-key-up)
 829   (xmine-key-right))
 830
 831 (defun xmine-key-up-left ()
 832   (interactive)
 833   (xmine-key-up)
 834   (xmine-key-left))
 835
 836 (defun xmine-key-down ()
 837   (interactive)
 838   (let* ((x (extent-property xmine-key-sel-button 'xmine-x))
 839          (y (extent-property xmine-key-sel-button 'xmine-y))
 840          (ext (xmine-field-button-at x (1+ y))))
 841     (if ext (xmine-select-button ext)
 842       (xmine-select-button (xmine-field-button-at x 1)))))
 843
 844 (defun xmine-key-up ()
 845   (interactive)
 846   (let* ((x (extent-property xmine-key-sel-button 'xmine-x))
 847          (y (extent-property xmine-key-sel-button 'xmine-y))
 848          (ext (xmine-field-button-at x (1- y))))
 849     (if ext (xmine-select-button ext)
 850       (xmine-select-button (xmine-field-button-at x xmine-height)))))
 851
 852 (defun xmine-key-right ()
 853   (interactive)
 854   (let* ((x (extent-property xmine-key-sel-button 'xmine-x))
 855          (y (extent-property xmine-key-sel-button 'xmine-y))
 856          (ext (xmine-field-button-at (1+ x) y)))
 857     (if ext (xmine-select-button ext)
 858       (xmine-select-button (xmine-field-button-at 1 y)))))
 859
 860 (defun xmine-key-left ()
 861   (interactive)
 862   (let* ((x (extent-property xmine-key-sel-button 'xmine-x))
 863          (y (extent-property xmine-key-sel-button 'xmine-y))
 864          (ext (xmine-field-button-at (1- x) y)))
 865     (if ext (xmine-select-button ext)
 866       (xmine-select-button (xmine-field-button-at xmine-width y)))))
 867
 868 (provide 'xmine)
 869