Mercurial > hg > xemacs-beta

comparison lisp/games/xmine.el @ 138:6608ceec7cf8 r20-2b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-2b3
author cvs
date Mon, 13 Aug 2007 09:31:46 +0200
parents 9b50b4588a93
children
comparison
equal deleted inserted replaced
137:cae984061f40 138:6608ceec7cf8
1 ;;; xmine.el --- Mine game for XEmacs 1 ;;; xmine.el --- Mine game for XEmacs
2 2
3 ;; Author: Jens Lautenbacher <jens@lemming0.lem.uni-karlsruhe.de> 3 ;; Author: Jens Lautenbacher <jens@lemming0.lem.uni-karlsruhe.de>
4 ;; Keywords: games 4 ;; Keywords: games
5 ;; Version: 1.7 5 ;; Version: 1.8
6 6
7 ;; This file is part of XEmacs. 7 ;; This file is part of XEmacs.
8 8
9 ;; XEmacs is free software; you can redistribute it and/or modify 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 10 ;; it under the terms of the GNU General Public License as published by
42 ;; 42 ;;
43 ;; Code: 43 ;; Code:
44 ;; 44 ;;
45 ;;; First of all we'll define the needed varibles. 45 ;;; First of all we'll define the needed varibles.
46 46
47 (defconst xmine-version-number "1.7" "XEmacs Mine version number.") 47 (defconst xmine-version-number "1.8" "XEmacs Mine version number.")
48 (defconst xmine-version (format "XEmacs Mine v%s by Jens Lautenbacher © 1997" 48 (defconst xmine-version (format "XEmacs Mine v%s by Jens Lautenbacher © 1997"
49 xmine-version-number) 49 xmine-version-number)
50 "Full XEmacs Mine version number.") 50 "Full XEmacs Mine version number.")
51 51
52 (defgroup xmine nil 52 (defgroup xmine nil
98 (if (and (eq window-system 'x) (featurep 'xpm)) 98 (if (and (eq window-system 'x) (featurep 'xpm))
99 (concat xmine-glyph-dir "splash.xpm") 99 (concat xmine-glyph-dir "splash.xpm")
100 "------------------ XEmacs XMine ------------------"))) 100 "------------------ XEmacs XMine ------------------")))
101 101
102 (defvar xmine-glyph-production-list 102 (defvar xmine-glyph-production-list
103 '(("xmine-new-up" "new_up.gif" "new" nil ) 103 '(("xmine-new-up" "new_up.gif" "new" nil)
104 ("xmine-new-down" "new_down.gif" "NEW" nil ) 104 ("xmine-new-down" "new_down.gif" "NEW" nil)
105 ("xmine-quit-up" "quit_up.gif" "quit" nil ) 105 ("xmine-quit-up" "quit_up.gif" "quit" nil)
106 ("xmine-quit-down" "quit_down.gif" "QUIT" nil ) 106 ("xmine-quit-down" "quit_down.gif" "QUIT" nil)
107 ("xmine-up-glyph" "empty_16_up.gif" "@ " xmine-hidden-face ) 107 ("xmine-up-glyph" "empty_16_up.gif" "@ " xmine-hidden-face)
108 ("xmine-up-sel-glyph" "empty_16_up_sel.gif" "@<" xmine-hidden-face ) 108 ("xmine-up-sel-glyph" "empty_16_up_sel.gif" "@<" xmine-hidden-face)
109 ("xmine-down-glyph" "empty_16_down.gif" "? " nil ) 109 ("xmine-down-glyph" "empty_16_down.gif" "? " nil)
110 ("xmine-flagged-glyph" "flagged_16_up.gif" "! " xmine-flagged-face) 110 ("xmine-flagged-glyph" "flagged_16_up.gif" "! " xmine-flagged-face)
111 ("xmine-flagged-sel-glyph" "flagged_16_up_sel.gif" "!<" xmine-flagged-face) 111 ("xmine-flagged-sel-glyph" "flagged_16_up_sel.gif" "!<" xmine-flagged-face)
112 ("xmine-mine-glyph" "bomb_16_flat.gif" "* " nil ) 112 ("xmine-mine-glyph" "bomb_16_flat.gif" "* " nil)
113 ("xmine-mine-sel-glyph" "bomb_16_flat.gif" "*<" nil ) 113 ("xmine-mine-sel-glyph" "bomb_16_flat.gif" "*<" nil)
114 ("xmine-trapped-glyph" "bomb_trapped_16_flat.gif" "X " nil ) 114 ("xmine-trapped-glyph" "bomb_trapped_16_flat.gif" "X " nil)
115 ("xmine-0-glyph" "empty_16_flat.gif" ". " nil ) 115 ("xmine-0-glyph" "empty_16_flat.gif" ". " nil)
116 ("xmine-0-sel-glyph" "empty_16_flat_sel.gif" ".<" nil ) 116 ("xmine-0-sel-glyph" "empty_16_flat_sel.gif" ".<" nil)
117 ("xmine-1-glyph" "1_16_flat.gif" "1 " xmine-number-face ) 117 ("xmine-1-glyph" "1_16_flat.gif" "1 " xmine-number-face)
118 ("xmine-1-sel-glyph" "1_16_flat_sel.gif" "1<" xmine-number-face ) 118 ("xmine-1-sel-glyph" "1_16_flat_sel.gif" "1<" xmine-number-face)
119 ("xmine-2-glyph" "2_16_flat.gif" "2 " xmine-number-face ) 119 ("xmine-2-glyph" "2_16_flat.gif" "2 " xmine-number-face)
120 ("xmine-2-sel-glyph" "2_16_flat_sel.gif" "2<" xmine-number-face ) 120 ("xmine-2-sel-glyph" "2_16_flat_sel.gif" "2<" xmine-number-face)
121 ("xmine-3-glyph" "3_16_flat.gif" "3 " xmine-number-face ) 121 ("xmine-3-glyph" "3_16_flat.gif" "3 " xmine-number-face)
122 ("xmine-3-sel-glyph" "3_16_flat_sel.gif" "3<" xmine-number-face ) 122 ("xmine-3-sel-glyph" "3_16_flat_sel.gif" "3<" xmine-number-face)
123 ("xmine-4-glyph" "4_16_flat.gif" "4 " xmine-number-face ) 123 ("xmine-4-glyph" "4_16_flat.gif" "4 " xmine-number-face)
124 ("xmine-4-sel-glyph" "4_16_flat_sel.gif" "4<" xmine-number-face ) 124 ("xmine-4-sel-glyph" "4_16_flat_sel.gif" "4<" xmine-number-face)
125 ("xmine-5-glyph" "5_16_flat.gif" "5 " xmine-number-face ) 125 ("xmine-5-glyph" "5_16_flat.gif" "5 " xmine-number-face)
126 ("xmine-5-sel-glyph" "5_16_flat_sel.gif" "5<" xmine-number-face ) 126 ("xmine-5-sel-glyph" "5_16_flat_sel.gif" "5<" xmine-number-face)
127 ("xmine-6-glyph" "6_16_flat.gif" "6 " xmine-number-face ) 127 ("xmine-6-glyph" "6_16_flat.gif" "6 " xmine-number-face)
128 ("xmine-6-sel-glyph" "6_16_flat_sel.gif" "6<" xmine-number-face ) 128 ("xmine-6-sel-glyph" "6_16_flat_sel.gif" "6<" xmine-number-face)
129 ("xmine-7-glyph" "7_16_flat.gif" "7 " xmine-number-face ) 129 ("xmine-7-glyph" "7_16_flat.gif" "7 " xmine-number-face)
130 ("xmine-7-sel-glyph" "7_16_flat_sel.gif" "7<" xmine-number-face ) 130 ("xmine-7-sel-glyph" "7_16_flat_sel.gif" "7<" xmine-number-face)
131 ("xmine-8-glyph" "8_16_flat.gif" "8 " xmine-number-face ) 131 ("xmine-8-glyph" "8_16_flat.gif" "8 " xmine-number-face)
132 ("xmine-8-sel-glyph" "8_16_flat_sel.gif" "8<" xmine-number-face ))) 132 ("xmine-8-sel-glyph" "8_16_flat_sel.gif" "8<" xmine-number-face)))
133
134 (defvar xmine-force-textual nil
135 "This is for debugging purposes only. No need to set it. Really.")
133 136
134 (defun xmine-generate-glyphs () 137 (defun xmine-generate-glyphs ()
135 (let ((list xmine-glyph-production-list) 138 (let ((list xmine-glyph-production-list)
136 elem var gif text face) 139 elem var gif text face)
137 (while (setq elem (pop list)) 140 (while (setq elem (pop list))
138 (setq var (car elem) 141 (setq var (car elem)
139 gif (cadr elem) 142 gif (cadr elem)
140 text (caddr elem) 143 text (caddr elem)
141 face (cadddr elem)) 144 face (cadddr elem))
142 (set (intern var) 145 (set (intern var)
143 (make-glyph (if (eq window-system 'x) 146 (make-glyph (if (and (not xmine-force-textual)
147 (eq window-system 'x))
144 (concat xmine-glyph-dir gif) 148 (concat xmine-glyph-dir gif)
145 text))) 149 text)))
146 (if face 150 (if face
147 (set-glyph-face (eval (intern-soft var)) face))))) 151 (set-glyph-face (eval (intern-soft var)) face)))))
148 152
239 ;; actions 243 ;; actions
240 244
241 (defun xmine-activate-function-button (event) 245 (defun xmine-activate-function-button (event)
242 (interactive "e") 246 (interactive "e")
243 (let* ((extent (event-glyph-extent event)) 247 (let* ((extent (event-glyph-extent event))
244 (button (event-button event)) 248 (button (number-to-string (event-button event)))
245 (action (intern (concat "action" (number-to-string button)))) 249 (action (intern (concat "action" button)))
250 (down-action (intern (concat "down-action" button)))
251 (restore-down-action (intern (concat "restore-down-action" button)))
246 (mouse-down t) 252 (mouse-down t)
247 (up-glyph nil)) 253 (action-do-it t)
254 up-glyph)
248 ;; make the glyph look pressed 255 ;; make the glyph look pressed
249 (cond ((annotation-down-glyph extent) 256 (cond ((annotation-down-glyph extent)
250 (setq up-glyph (annotation-glyph extent)) 257 (setq up-glyph (annotation-glyph extent))
251 (set-annotation-glyph extent (annotation-down-glyph extent)))) 258 (set-annotation-glyph extent (annotation-down-glyph extent))))
259 (if (extent-property extent down-action)
260 (setq action-do-it
261 (funcall (extent-property extent down-action) extent)))
252 (while mouse-down 262 (while mouse-down
253 (setq event (next-event event)) 263 (setq event (next-event event))
254 (if (button-release-event-p event) 264 (if (button-release-event-p event)
255 (setq mouse-down nil))) 265 (setq mouse-down nil)))
256 ;; make the glyph look released 266 ;; make the glyph look released
257 (cond ((annotation-down-glyph extent) 267 (cond ((annotation-down-glyph extent)
258 (set-annotation-glyph extent up-glyph))) 268 (set-annotation-glyph extent up-glyph)))
259 (if (eq extent (event-glyph-extent event)) 269 (if (eq extent (event-glyph-extent event))
260 (if (extent-property extent action) 270 (if (and (extent-property extent action) action-do-it)
261 (funcall (extent-property extent action) extent))))) 271 (funcall (extent-property extent action) extent)
272 (if (extent-property extent restore-down-action)
273 (funcall (extent-property extent restore-down-action) extent)))
274 (if (extent-property extent restore-down-action)
275 (funcall (extent-property extent restore-down-action) extent)))))
262 276
263 ;;; Here we define the button object's constructor function 277 ;;; Here we define the button object's constructor function
264 278
265 (defun xmine-button-create (x y type) 279 (defun xmine-button-create (x y type)
266 (let ((ext (make-annotation 280 (let ((ext (make-annotation
267 xmine-up-glyph nil 'text nil nil xmine-down-glyph nil))) 281 xmine-up-glyph nil 'text nil nil xmine-down-glyph nil)))
268 (set-extent-property ext 'action1 'xmine-action1) 282 (set-extent-property ext 'action1 'xmine-action1)
269 (set-extent-property ext 'action2 'xmine-beep) 283 (set-extent-property ext 'action2 'xmine-beep)
270 (set-extent-property ext 'action3 'xmine-action3) 284 (set-extent-property ext 'action3 'xmine-action3)
285 (set-extent-property ext 'down-action2 'xmine-down-action2)
286 (set-extent-property ext 'restore-down-action2 'xmine-restore-down-action2)
271 (set-extent-property ext 'xmine-glyph (xmine-type-to-glyph type)) 287 (set-extent-property ext 'xmine-glyph (xmine-type-to-glyph type))
272 (set-extent-property ext 'xmine-sel-glyph (xmine-type-to-sel-glyph type)) 288 (set-extent-property ext 'xmine-sel-glyph (xmine-type-to-sel-glyph type))
273 (set-extent-property ext 'xmine-type type) 289 (set-extent-property ext 'xmine-type type)
274 (set-extent-property ext 'xmine-x x) 290 (set-extent-property ext 'xmine-x x)
275 (set-extent-property ext 'xmine-y y) 291 (set-extent-property ext 'xmine-y y)
292 (defun xmine-flat-button-p (ext) 308 (defun xmine-flat-button-p (ext)
293 (and ext 309 (and ext
294 (not (extent-property ext 'xmine-hidden)) 310 (not (extent-property ext 'xmine-hidden))
295 (equal "0" (extent-property ext 'xmine-type)))) 311 (equal "0" (extent-property ext 'xmine-type))))
296 312
313 (defun xmine-enough-flagged-p (ext)
314 (let ((list (xmine-get-neighbours ext))
315 (number (extent-property ext 'xmine-type))
316 (flagged 0) elem res)
317 (if (not (or (equal number "mine")
318 (equal number "0")))
319 (progn
320 (setq number (string-to-number number))
321 (while (setq elem (pop list))
322 (if (extent-property elem 'xmine-flagged)
323 (setq flagged (1+ flagged))))
324 (setq res (>= flagged number))
325 ))
326 res))
327
328
297 (defun xmine-mine-button-p (ext) 329 (defun xmine-mine-button-p (ext)
298 (and ext 330 (and ext
299 (equal "mine" (extent-property ext 'xmine-type)))) 331 (equal "mine" (extent-property ext 'xmine-type))))
300 332
301 ;;; the next three functions are helper functions used inside a button 333 ;;; the next three functions are helper functions used inside a button
311 (eval (intern-soft (concat "xmine-" type "-glyph")))) 343 (eval (intern-soft (concat "xmine-" type "-glyph"))))
312 344
313 (defun xmine-type-to-sel-glyph (type) 345 (defun xmine-type-to-sel-glyph (type)
314 (eval (intern-soft (concat "xmine-" type "-sel-glyph")))) 346 (eval (intern-soft (concat "xmine-" type "-sel-glyph"))))
315 347
316 ;;; the next three functions are the main functions that are used 348 ;;; the next 3 functions are the main functions that are used
317 ;;; inside the button objects and which are bound to the 'action1, 349 ;;; inside the button objects and which are bound to the 'action1,
318 ;;; 'action2 and 'action3 slots respectively 350 ;;; 'action2 and 'action3 slots respectively
319 351
320 (defun xmine-action1 (ext &optional no-repaint force) 352 (defun xmine-action1 (ext &optional no-repaint force)
321 "This unhides a hidden button" 353 "This unhides a hidden button"
351 you've marked all mines around the button correctly (or you're sure 383 you've marked all mines around the button correctly (or you're sure
352 there isn't one)" 384 there isn't one)"
353 (let ((list (xmine-get-neighbours ext)) 385 (let ((list (xmine-get-neighbours ext))
354 (xmine-no-unhide-sound t) 386 (xmine-no-unhide-sound t)
355 next) 387 next)
388 ;; (xmine-restore-down-action2 ext)
356 (if list (xmine-unhide-many-sound)) 389 (if list (xmine-unhide-many-sound))
357 (while (setq next (pop list)) 390 (while (setq next (pop list))
358 (if (not (xmine-flat-button-p next)) (xmine-action1 next))))) 391 (if (not (xmine-flat-button-p next)) (xmine-action1 next)))))
359 392
360 (defun xmine-action3 (ext) 393 (defun xmine-action3 (ext)
388 (format "Mines: %2d" 421 (format "Mines: %2d"
389 (- xmine-number-of-mines 422 (- xmine-number-of-mines
390 xmine-number-of-flagged)))))))) 423 xmine-number-of-flagged))))))))
391 424
392 425
426 (defun xmine-down-action2 (ext)
427 (let ((list (xmine-get-neighbours ext))
428 (do-it (xmine-enough-flagged-p ext))
429 elem)
430 (if (not do-it)
431 (while (setq elem (pop list))
432 (set-extent-property elem 'xmine-temp-glyph (annotation-glyph elem))
433 (set-annotation-glyph elem (annotation-down-glyph elem))))
434 do-it))
435
436 (defun xmine-restore-down-action2 (ext)
437 (let ((list (xmine-get-neighbours ext))
438 elem)
439 (while (setq elem (pop list))
440 (set-annotation-glyph elem (extent-property elem 'xmine-temp-glyph)))))
441
393 ;;; the sounds... 442 ;;; the sounds...
394 (defcustom xmine-play-sounds nil 443 (defcustom xmine-play-sounds nil
395 "If XMine should play some sounds for various events to happen." 444 "If XMine should play some sounds for various events to happen."
396 :group 'xmine 445 :group 'xmine
397 :type 'boolean) 446 :type 'boolean)
737 (funcall action xmine-key-sel-button)))) 786 (funcall action xmine-key-sel-button))))
738 787
739 (defun xmine-key-action2 () 788 (defun xmine-key-action2 ()
740 (interactive) 789 (interactive)
741 (let ((action (extent-property xmine-key-sel-button 'action2))) 790 (let ((action (extent-property xmine-key-sel-button 'action2)))
742 (if action 791 (if (and action (xmine-enough-flagged-p xmine-key-sel-button))
743 (funcall action xmine-key-sel-button)))) 792 (funcall action xmine-key-sel-button)
793 (beep))))
744 794
745 (defun xmine-key-action3 () 795 (defun xmine-key-action3 ()
746 (interactive) 796 (interactive)
747 (let ((action (extent-property xmine-key-sel-button 'action3))) 797 (let ((action (extent-property xmine-key-sel-button 'action3)))
748 (if action 798 (if action