xemacs-beta: lisp/games/mine.el comparison

comparison lisp/games/mine.el @ 98:0d2f883870bc r20-1b1

Import from CVS: tag r20-1b1

author	cvs
date	Mon, 13 Aug 2007 09:13:56 +0200
parents	8fc7fe29b841
children	1917ad0d78d7

comparison

equal deleted inserted replaced

-:498bf5da1c90
+:0d2f883870bc
+;;; mine.el --- Mine game for GNU Emacs
+;; Author:     Jacques Duthen <duthen@cegelec-red.fr>
+;; Keywords:   games
+;; Time-stamp: <97/01/20 14:37:36 duthen>
+;; Version:    1.17
+(defconst mine-version-number "1.17" "Emacs Mine version number.")
+(defconst mine-version (format "Emacs Mine v%s by Jacques Duthen © 1997"
+			       mine-version-number)
+"Full Emacs Mine version number.")
+;; This file is not yet part of GNU Emacs.
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+;;; Commentary:
+;; The object of this classical game is to locate the hidden mines.
+;; To do this, you hit the squares on the game board that do not
+;; contain mines, and you mark the squares that do contain mines.
+;; The number of hidden mines remaining in the mine field is indicated
+;; inside the buffer.  Every time you mark a square as a mine, this
+;; number decreases by one, even if you incorrectly mark a square.
+;; To hit a square: Point to the square, and click the left button.
+;; If the square is a mine, you loose.
+;; If the square isn't a mine, a number appears, which represents
+;; the number of mines in the surrounding eight squares.
+;; To mark a square as a mine: Point to the square, and click
+;; the right button.
+;; To play Mine, compile it if you want, load it, and type `M-x mine'.
+;; To get help and doc, see the functions `mine' and `mine-help'
+;; (ie. type `?' in the *Mine* buffer or type `C-h f mine')
+;; This module has been developed and tested with GNU Emacs 19.31.1,
+;; but it should run with any GNU Emacs 19.* (at least with versions
+;; superior to 19.31).
+;; This module has not been tested (yet) with XEmacs.  It may or may
+;; not run (can anybody tell me?).
+;; Send any comment or bug report (do you expect to find any? ;-) to me:
+;; duthen@cegelec-red.fr (Jacques Duthen)
+;; Good luck.
+;; 1.17 Thanks to Vladimir Alexiev <vladimir@cs.ualberta.ca>.
+;; Fix bug: (void-function unless), add minimal support for xemacs.
+;; (mine-xemacs-p): Added.
+;; (event-point): New function.
+;; (mine-mouse-hit, mine-mouse-mark): Use (interactive "@e") and `event-point'
+;; (mine-init-mode-map): Support xemacs mouse binding.
+;; (mine-make-face): Support xemacs get-face.
+;; (mine-goto): Support `auto-show-make-point-visible' as well as
+;; `hscroll-point-visible'.
+;; 1.16 Initial released version.
+;;; Code:
+(defvar mine-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version))
+;;; ================================================================
+;;; User Variables:
+;;; -1- size
+;;; The mine field is a rectangle (mine-xmax x mine-ymax), which is
+;;; duplicated to fill a bigger rectangle periodically tiled with the
+;;; smaller one, the period being (mine-xmax x mine-ymax).
+(defvar mine-xmax 16 "*The logical width  of the mine field.")
+(defvar mine-ymax 24 "*The logical height of the mine field.")
+(defvar mine-mines-%  16
+"*Percentage (between 0 and 100) of mines in the mine field.")
+(defvar mine-torus 't
+"*Non-nil (the default) to play the game on a periodic board (a torus).")
+(defvar mine-nb-tiles-x 2
+"*Number of duplications in the x direction, when `mine-torus' is non-nil.
+Indicate the number of times the original mine field is duplicated
+in the x direction.
+It's better looking when it's an integer.
+nil means fill exactly the whole window.
+0 means fill the whole window with the biggest integer that fits.
+a negative number means use exactly the opposite number.  If it's
+too big, the rows are truncated by emacs.  Automatic horizontal
+scrolling will occur if you move to an invisible point.
+a positive float means limit to the window width if needed.
+a positive integer means limit to the window width if needed,
+with the biggest possible integer value anyway.
+")
+(defvar mine-nb-tiles-y 2
+"*Number of duplications in the y direction, when `mine-torus' is non-nil.
+Indicate the number of times the original mine field is duplicated
+in the y direction.
+It's better looking when it's an integer.
+nil means fill exactly the whole window.
+0 means fill the whole window with the biggest integer that fits.
+a negative number means use exactly the opposite number.  If it's
+too big, the rows will be simply scrolled up or down by emacs.
+a positive float means limit to the window height if needed.
+a positive integer means limit to the window height if needed,
+with the biggest possible integer value anyway.
+")
+;;; -2- square characters
+;;; All these characters may be changed but the first three ones
+;;; `unmarked' `marked' `zero' must differ from each other.
+(defvar mine-char-unmarked  ?-
+"*Character for a square not yet marked nor hit.")
+(defvar mine-char-marked    ?@
+"*Character for a square marked as containing a mine.")
+(defvar mine-char-zero      ?\
+"*Character for a square hit with no adjacent mine.")
+(defvar mine-char-pad       ?\
+"*Character to pad in the x direction or nil (not yet implemented).")
+(defvar mine-char-not-found ?o
+"*Character for a square marked but with no mine.")
+(defvar mine-char-bogus     ?x
+"*Character for a square not marked but with a mine.")
+;;; -3- colors
+(defvar mine-colorp (if window-system 't 'nil)
+"*Non-nil means with colors.  Nil means in black and white.")
+(defvar mine-colors nil
+"*Set this variable to override the colors defined by
+`mine-default-colors' (use the same format).")
+(defconst mine-default-colors
+'((mine-face-unmarked  . "LightBlue")
+(mine-face-marked    . "Red")
+(0 . nil)
+(1 . "Cyan")
+(2 . "Green")
+(3 . "Yellow")
+(4 . "Orange")
+(5 . "OrangeRed")
+(6 . "Red")
+(7 . "Red")
+(8 . "Red")
+(mine-face-pad       . nil)
+(mine-face-not-found . "Red")
+(mine-face-bogus     . "Red")
+)
+"A-list of default colors for Mine faces.  Don't change its value.
+You can override these settings with `mine-colors' using the same format.")
+;;; -4- redisplay
+(defvar mine-level 2
+"*Redisplay speed.  0 is the slowest redisplay, 5 is the fastest one.
+0 means redisplay when every single square changes.
+1 means redisplay when one square and its periodic images change.
+2 means redisplay every `mine-count1-max' change.
+3 means redisplay every `mine-count1-max'*`mine-count2-max' change.
+-1 or nil means redisplay only when all the changes are done.
+")
+(defvar mine-count1-max 16
+"*See `mine-level'.
+Redisplay when the number of empty squares which have changed
+is greater than `mine-count1-max'.
+8 means redisplay each time 8 squares have been changed.
+-1 means redisplay only when all the changes are done.")
+(defvar mine-count2-max  4
+"*See `mine-level'.
+Redisplay when the number of empty squares which have changed
+is greater than `mine-count1-max'.
+8 means redisplay each time 8 squares have been changed.
+-1 means redisplay only when all the changes are done.")
+(defvar mine-hscroll-step 4
+"*Local value for `hscroll-step'")
+(defvar mine-mode-hook nil
+"*Hook called by `mine-mode-hook'.")
+;;; ================================================================
+;;; Internal variables:
+(defvar mine-user-variables
+'("Size"
+mine-xmax mine-ymax mine-mines-%
+mine-torus mine-nb-tiles-x mine-nb-tiles-y
+"Square characters"
+mine-char-unmarked mine-char-marked mine-char-zero
+mine-char-pad mine-char-not-found mine-char-bogus
+"Colors"
+mine-colorp mine-colors
+"Redisplay"
+mine-level mine-count1-max mine-count2-max
+"Scrolling"
+mine-hscroll-step
+"Hook"
+mine-mode-hook))
+(defvar mine-user-commands
+'("Help"
+mine mine-help mine-help-bindings mine-help-variables
+"Mouse control"
+mine-mouse-hit mine-mouse-mark
+"Move"
+mine-left mine-right mine-up mine-down
+mine-bol mine-eol mine-top mine-bottom
+"Hit and mark"
+mine-hit-curpoint mine-mark-curpoint
+"Quit"
+mine-quit))
+;; pad x factor == (if mine-char-pad 2 1)
+(defvar mine-padx*)
+(defvar mine-width)
+(defvar mine-height)
+;; (x y) of current point
+(defvar mine-x) ;; 1 <= mine-x <= mine-width
+(defvar mine-y) ;; 1 <= mine-y <= mine-height
+;; limits of the playable part of the board
+(defvar mine-point-min)
+(defvar mine-point-max)
+(defvar mine-point-remaining-mines)
+(defvar mine-point-mines-hit)
+(defvar mine-mode-map nil)
+(defvar mine-real-mines)
+(defvar mine-nb-remaining-mines)
+(defvar mine-nb-remaining-marks)
+(defvar mine-nb-mines-hit)
+(defvar mine-faces)
+;;; This variable is more special rather than global.
+(defvar mine-adjacent-points)
+(defvar mine-count1)
+(defvar mine-count2)
+;;; ================================================================
+;;; Macros (stolen from "cl.el" (soon in "subr.el" (thanks to rms)))
+(eval-when-compile
+(or (fboundp 'when)
+(defmacro when (cond &rest body)
+"(when COND BODY...): if COND yields non-nil, do BODY, else return nil."
+(list 'if cond (cons 'progn body)))))
+;;; ================================================================
+;;; User commands
+;;;###autoload
+(defun mine (num)
+"Play Mine.  Optional prefix argument is the number of mines.
+To play Mine, type `\\[mine]' or `\\[universal-argument] NUM \\[mine]'.
+An optional prefix argument specifies the number of mines to be hidden
+in the field.  If no prefix argument is given, a percentage
+`mine-mines-%' of the field will contain mines.
+What is Mine?\\<mine-mode-map>
+Mine is a classical game of hide and seek played on a rectangular grid
+containing `mine-xmax' by `mine-ymax' squares (the mine field).
+Your opponent (Emacs, in this case) has hidden several mines within
+this field.  The object of the game is to find every hidden mine.
+When you're sure a square does NOT contain a mine, you can hit it:
+move the mouse over the square and press `\\[mine-mouse-hit]' or
+move the cursor with the usual keys and press `\\[mine-hit-curpoint]'.
+If the square is a mine, you loose.
+If the square isn't a mine, a number appears which represents
+the number of mines in the surrounding eight squares.
+When you think a square DOES contain a mine, you can mark it:
+move the mouse over the square and press `\\[mine-mouse-mark]' or
+move the cursor with the usual keys and press `\\[mine-mark-curpoint]'.
+The number of hidden mines remaining in the mine field is indicated
+inside the buffer.  Every time you mark a square as a mine, this
+number decreases by one, even if you incorrectly mark a square.
+If `mine-torus' is non-nil (the default), the Mine game is played over
+a periodic field (like a torus).  Each mine is hidden periodically
+over the mine board `mine-nb-tiles-x' times in the x direction and
+`mine-nb-tiles-y' times in the y direction.
+If `mine-colorp' is non-nil (the default, if the system allows it),
+the game is displayed with colors.  The colors can be chosen with the
+variable `mine-colors'.
+If the redisplay is not fast enough, increase `mine-level'.  If you
+want to see a smoother (slower) redisplay, decrease `mine-level',
+`mine-count1-max' and `mine-count2-max'.
+You can get help on `mine-mode' and its key bindings by pressing `\\[mine-help]'
+while in the *Mine* buffer.
+"
+(interactive "P")
+(switch-to-buffer "*Mine*")
+(mine-mode)
+(setq buffer-read-only 't)
+(buffer-disable-undo (current-buffer))
+(setq mine-nb-remaining-mines
+	(or num (round (/ (* mine-xmax mine-ymax mine-mines-%) 100)))
+mine-nb-remaining-marks mine-nb-remaining-mines)
+(if (> mine-nb-remaining-mines (* mine-xmax mine-ymax))
+(error "Too many mines: %d" mine-nb-remaining-mines))
+(mine-init-faces)
+(setq mine-real-mines (mine-init-mines mine-nb-remaining-mines))
+(setq mine-nb-mines-hit 0)
+(mine-init-board)
+(mine-reset-counters)
+(mine-update-remaining-mines)
+(setq hscroll-step mine-hscroll-step)
+;; initial position
+(setq mine-x 1)
+(setq mine-y 1)
+(mine-goto mine-x mine-y)
+)
+;; Mine mode is suitable only for specially formatted data.
+(put 'mine-mode 'mode-class 'special)
+(defun mine-mode ()
+"Major mode for playing Mine.  To learn how to play Mine, see `mine'.
+If you have a mouse, you can do:\\<mine-mode-map>
+`\\[mine-mouse-hit]' -- hit point
+`\\[mine-mouse-mark]' -- mark or unmark a mine at point
+If you don't have a mouse, you can move the cursor over the mine
+field with the usual mnemonic keys and:
+`\\[mine-hit-curpoint]' -- hit point
+`\\[mine-mark-curpoint]' -- mark or unmark a mine at point
+`\\[mine-quit]' -- give up and see the hidden mines
+You can get help with:
+`\\[mine-help-variables]' -- get help on Mine variables
+`\\[mine-help-bindings]' -- get help on Mine bindings
+\\{mine-mode-map}
+"
+(interactive)
+(kill-all-local-variables)
+(make-local-variable 'hscroll-step)
+(use-local-map mine-mode-map)
+(setq truncate-lines 't)
+(setq major-mode 'mine-mode)
+(setq mode-name "Mine")
+(run-hooks 'mine-mode-hook)
+)
+;;;###autoload
+(defun mine-version ()
+"Return string describing the current version of Mine.
+When called interactively, displays the version."
+(interactive)
+(if (interactive-p)
+(message (mine-version))
+mine-version))
+;;;###autoload
+(defun mine-help ()
+"*Get help on `mine-mode'."
+(interactive)
+(save-excursion
+(switch-to-buffer "*Mine*")
+(mine-mode)
+(describe-mode)))
+(defun mine-help-variables ()
+"*Get help on Mine variables."
+(interactive)
+(save-excursion
+(switch-to-buffer "*Mine*")
+(mine-mode)
+(apropos-symbols mine-user-variables 't)))
+(defun mine-help-bindings ()
+"*Get help on Mine bindings."
+(interactive)
+(save-excursion
+(switch-to-buffer "*Mine*")
+(mine-mode)
+(apropos-symbols mine-user-commands 't)))
+(defun mine-print-settings ()
+"*Print the current Mine settings (value of all the user variables)."
+(interactive)
+(with-output-to-temp-buffer "*scratch*"
+(mine-print-variables mine-user-variables)))
+;;; ================================================================
+;;; Click events - nop hit mark
+;;; [jack] The elisp manual says:
+;;; If you want to take action as soon as a button is pressed,
+;;; you need to handle "button-down" events.
+;;; The global map (cf. `mouse.el') has, by default, the binding:
+;;;	(define-key global-map [down-mouse-1] 'mouse-drag-region)
+;;; It seems that this function "eats" the final event [mouse-1].
+;;; So, we need a local binding for [down-mouse-1] which shadows
+;;; the global one and prevents `mouse-drag-region' from being called.
+;;; Hence, in `mine-init-mode-map' I use the following binding:
+;;;	(define-key mine-mode-map [down-mouse-1] 'mine-mouse-nop)
+;;; I found a better binding in "apropos.el"
+;;;	(define-key mine-mode-map [down-mouse-1] nil)
+;;; but, as it does not work, let's go back to nop...
+(or (fboundp 'event-point)
+(defun event-point (event)
+(posn-point (event-end event))))
+(defun mine-mouse-nop (event)
+"Nop"
+(interactive "e"))
+(defun mine-mouse-hit (event)
+"Move point to the position clicked on with the mouse and hit this point."
+(interactive "@e")
+(if (mine-goto-point (event-point event))
+(mine-hit-curpoint)
+(mine-message 'mine-msg-click-precisely)))
+(defun mine-mouse-mark (event)
+"Move point to the position clicked on with the mouse and mark or unmark
+this point."
+(interactive "@e")
+(if (mine-goto-point (event-point event))
+(mine-mark-curpoint)
+(mine-message 'mine-msg-click-precisely)))
+;;; ================================================================
+;;; Key events - hit mark quit
+(defun mine-hit-curpoint ()
+"Hit point"
+(interactive)
+(mine-reset-counters)
+(let ((c (following-char)))
+(save-excursion
+(cond
+	((eq c mine-char-marked)
+(mine-message 'mine-msg-unmark-before-hit))
+	((not (eq c mine-char-unmarked))
+(mine-message 'mine-msg-point-already-hit))
+	((mine-mine-at-point-p (point) 'slowp)
+	 (setq mine-nb-mines-hit (1+ mine-nb-mines-hit))
+	 (mine-update-mines-hit)
+(mine-message 'mine-msg-loose)
+	 (mine-quit))
+	(t ;; the real job...
+	 (let* ((x.y (mine-top-left (mine-point-to-x.y (point))))
+		(pxy (cons (point) x.y))
+		(mine-adjacent-points (list pxy))) ; special variable
+	   (while mine-adjacent-points
+	     (setq pxy (car mine-adjacent-points)
+		   mine-adjacent-points (cdr mine-adjacent-points))
+	     (mine-deep-hit pxy))))))))
+(defun mine-mark-curpoint ()
+"Mark or unmark current position"
+(interactive)
+(mine-reset-counters)
+(let ((c (following-char)))
+(save-excursion
+(cond
+	((eq c mine-char-unmarked)
+	 (mine-mark-board (point))
+	 (setq mine-nb-remaining-marks
+	       (1- mine-nb-remaining-marks))
+	 (if (mine-mine-at-point-p (point) 'slowp)
+	     (setq mine-nb-remaining-mines
+		   (1- mine-nb-remaining-mines))))
+	((eq c mine-char-marked)
+	 (mine-unmark-board (point))
+	 (setq mine-nb-remaining-marks
+	       (1+ mine-nb-remaining-marks))
+	 (if (mine-mine-at-point-p (point) 'slowp)
+	     (setq mine-nb-remaining-mines
+		   (1+ mine-nb-remaining-mines))))
+	(t
+(mine-message 'mine-msg-cannot-mark)))
+(mine-update-remaining-mines))))
+(defun mine-quit ()
+"*Display hidden and bogus mines."
+(interactive)
+(when (y-or-n-p "Do you want to see the remaining and bogus mines? ")
+(mine-show-bogus-mines)))
+(defun mine-show-bogus-mines ()
+(mine-reset-counters)
+(let ((nrb 0) (nbb 0)
+(x.y (cons nil nil))
+(y 1) x
+point c)
+(while (<= y mine-ymax)
+(setq x 1)
+(setcdr x.y y)
+(while (<= x mine-xmax)
+(setq point (mine-xy-to-point x y)
+c (char-after point))
+(cond
+((eq c mine-char-unmarked)
+(setcar x.y x)
+(when (mine-mine-at-xy-p x.y)
+(setq nrb (1+ nrb))
+(mine-update-board point mine-char-not-found 'mine-face-not-found)))
+((eq c mine-char-marked)
+(setcar x.y x)
+(when (not (mine-mine-at-xy-p x.y))
+(setq nbb (1+ nbb))
+(mine-update-board point mine-char-bogus 'mine-face-bogus))))
+(setq x (1+ x)))
+(setq y (1+ y)))
+(mine-update-bogus-mines nrb nbb)))
+;;; ================================================================
+;;; Key events - moves
+(defun mine-left ()
+"Move left"
+(interactive)
+(setq mine-x (1- mine-x))
+(when (<= mine-x 0)
+(while (<= mine-x mine-width)
+(setq mine-x (+ mine-x mine-xmax)))
+(setq mine-x (- mine-x mine-xmax)))
+(mine-goto mine-x mine-y))
+(defun mine-right ()
+"Move right"
+(interactive)
+(setq mine-x (1+ mine-x))
+(when (> mine-x mine-width)
+(while (>= mine-x 0)
+(setq mine-x (- mine-x mine-xmax)))
+(setq mine-x (+ mine-x mine-xmax)))
+(mine-goto mine-x mine-y))
+(defun mine-up ()
+"Move up"
+(interactive)
+(setq mine-y (1- mine-y))
+(when (<= mine-y 0)
+(while (<= mine-y mine-height)
+(setq mine-y (+ mine-y mine-ymax)))
+(setq mine-y (- mine-y mine-ymax)))
+(mine-goto mine-x mine-y))
+(defun mine-down ()
+"Move down"
+(interactive)
+(setq mine-y (1+ mine-y))
+(when (> mine-y mine-height)
+(while (>= mine-y 0)
+(setq mine-y (- mine-y mine-ymax)))
+(setq mine-y (+ mine-y mine-ymax)))
+(mine-goto mine-x mine-y))
+(defun mine-bol ()
+"Move to the beginning of the row"
+(interactive)
+(setq mine-x 1)
+(mine-goto mine-x mine-y))
+(defun mine-eol ()
+"Move to the end of the row"
+(interactive)
+(setq mine-x mine-width)
+(mine-goto mine-x mine-y))
+(defun mine-top ()
+"Move to the top of the column"
+(interactive)
+(setq mine-y 1)
+(mine-goto mine-x mine-y))
+(defun mine-bottom ()
+"Move to the bottom of the column"
+(interactive)
+(setq mine-y mine-height)
+(mine-goto mine-x mine-y))
+;;; ================================================================
+;;; Internal model functions
+(defun mine-init-mines (num-mines)
+(random t)
+(let ((mines (list)) (n num-mines) x y x.y)
+(while (> n 0)
+(setq n (1- n)
+x (1+ (random mine-xmax))
+y (1+ (random mine-ymax))
+x.y (cons x y))
+(while (mine-member x.y mines 'nil)
+	;; replace by the point to the right (or next row if eol)
+(if (< x mine-xmax)
+	    (setcar x.y (setq x (1+ x)))
+(setcar x.y (setq x 1))
+(setcdr x.y (setq y (if (< y mine-ymax) (1+ y) 1)))))
+(setq mines (cons x.y mines)))
+mines))
+(defun mine-mine-at-point-p (point slowp)
+(mine-member (mine-top-left (mine-point-to-x.y point))
+mine-real-mines slowp))
+(defun mine-mine-at-xy-p (x.y)
+(mine-member x.y mine-real-mines 'nil))
+;;; Returns non-nil if ELT is an element of LIST.
+;;; Constant time execution if slowp is non-nil.
+(defun mine-member (x.y list slowp)
+(let ((found 'nil))
+(while (and list (or slowp (not found)))
+(if (equal x.y (car list))
+(setq found 't))
+(setq list (cdr list)))
+found))
+;;; ================================================================
+;;; Internal model & interface functions
+(defun mine-pxy (x y)
+(cons (mine-xy-to-point x y) (cons x y)))
+;; pxy == (point . (x . y))
+;; with 1 <= {xy} <= mine-{xy}max
+(defun mine-deep-hit (pxy)
+(interactive)
+(let (point x.y c)
+(setq point (car pxy)
+	  x.y   (cdr pxy)
+c     (char-after point))
+(cond
+((eq c mine-char-marked)) ;; free but marked (user bug)
+((not (eq c mine-char-unmarked))) ;; already done
+((mine-mine-at-xy-p x.y)
+(error "Internal error: mine-deep-hit mine at %s" point))
+(t ;; the real job...
+(let* ((adjacent-points (mine-adjacent-points point x.y))
+(nb-adjacent-mines (mine-nb-adjacent-mines adjacent-points)))
+(mine-display-nb-adjacent-mines point nb-adjacent-mines)
+(when (zerop nb-adjacent-mines)
+	  ;; Stack overflow: "Lisp nesting exceeds max-lisp-eval-depth"
+;;(mapc 'mine-deep-hit adjacent-points)
+	  (setq mine-adjacent-points
+		(nconc adjacent-points mine-adjacent-points))))))))
+;; return == ((point . (x . y))*)
+;; with 1 <= {xy} <= mine-{xy}max
+(defun mine-adjacent-points (point x.y)
+(mine-random-permut
+(if mine-torus
+(mine-adjacent-points-on-torus point x.y)
+(mine-adjacent-points-no-torus point x.y))))
+(defun mine-random-permut (l)
+(let ((ll (nthcdr (random (length l)) l)))
+(nconc ll l)
+(prog1 (cdr ll) (setcdr ll ()))))
+(defun mine-adjacent-points-no-torus (point x.y)
+(let ((x (car x.y)) (y (cdr x.y)) (points (list)) xx yy)
+;; left column
+(when (not (= x 1))
+(setq xx (1- x))
+(when (not (= y 1))
+(setq yy (1- y))
+(setq points (cons (mine-pxy xx yy) points)))
+(setq points (cons (mine-pxy xx y) points))
+(when (not (= y mine-ymax))
+(setq yy (1+ y))
+(setq points (cons (mine-pxy xx yy) points))))
+;; middle column
+(setq xx x)
+(when (not (= y 1))
+(setq yy (1- y))
+(setq points (cons (mine-pxy xx yy) points)))
+(when (not (= y mine-ymax))
+(setq yy (1+ y))
+(setq points (cons (mine-pxy xx yy) points)))
+;; right column
+(when (not (= x mine-xmax))
+(setq xx (1+ x))
+(when (not (= y 1))
+(setq yy (1- y))
+(setq points (cons (mine-pxy xx yy) points)))
+(setq points (cons (mine-pxy xx y) points))
+(when (not (= y mine-ymax))
+(setq yy (1+ y))
+(setq points (cons (mine-pxy xx yy) points))))
+(nreverse points)))
+(defun mine-adjacent-points-on-torus (point x.y)
+(let ((x (car x.y)) (y (cdr x.y)) (points (list)) xx yy)
+;; left column
+(setq xx (if (= x 1) mine-xmax (1- x)))
+(setq yy (if (= y 1) mine-ymax (1- y)))
+(setq points (cons (mine-pxy xx yy) points))
+(setq points (cons (mine-pxy xx y) points))
+(setq yy (if (= y mine-ymax) 1 (1+ y)))
+(setq points (cons (mine-pxy xx yy) points))
+;; middle column
+(setq xx x)
+(setq yy (if (= y 1) mine-ymax (1- y)))
+(setq points (cons (mine-pxy xx yy) points))
+(setq yy (if (= y mine-ymax) 1 (1+ y)))
+(setq points (cons (mine-pxy xx yy) points))
+;; right column
+(setq xx (if (= x mine-xmax) 1 (1+ x)))
+(setq yy (if (= y 1) mine-ymax (1- y)))
+(setq points (cons (mine-pxy xx yy) points))
+(setq points (cons (mine-pxy xx y) points))
+(setq yy (if (= y mine-ymax) 1 (1+ y)))
+(setq points (cons (mine-pxy xx yy) points))
+(nreverse points)))
+;; l == ((p . (x . y))*)
+(defun mine-nb-adjacent-mines (l)
+(let ((nb 0) pxy x.y)
+(while l
+(setq pxy (car l)  l (cdr l)  x.y (cdr pxy))
+(if (mine-mine-at-xy-p x.y)
+(setq nb (1+ nb))))
+nb))
+;;; ================================================================
+;;; Mode map
+(defun mine-init-mode-map ()
+(let ((map (make-keymap)) (gm global-map))
+;; All normally self-inserting keys (except digits) are undefined
+(suppress-keymap map 'nil)
+;; Help
+(define-key map "?"      'mine-help)
+(define-key map "h"      'mine-help)
+(define-key map "b"      'mine-help-bindings)
+(define-key map "v"      'mine-help-variables)
+(cond
+(mine-xemacs-p
+;; Mouse control
+(define-key map [mouse-1] 'mine-mouse-hit)
+(define-key map [mouse-3] 'mine-mouse-mark)
+;; Mouse control to prevent problems
+(define-key map [mouse-2] 'mine-mouse-nop))
+(t
+;; Mouse control
+(define-key map [mouse-1] 'mine-mouse-hit)
+(define-key map [mouse-3] 'mine-mouse-mark)
+;; Mouse control to prevent problems
+(define-key map [mouse-2] 'mine-mouse-nop)
+(define-key map [down-mouse-1] 'mine-mouse-nop)
+(define-key map [down-mouse-2] 'mine-mouse-nop)
+(define-key map [down-mouse-3] 'mine-mouse-nop)
+(define-key map [drag-mouse-1] 'mine-mouse-nop)
+(define-key map [drag-mouse-2] 'mine-mouse-nop)
+(define-key map [drag-mouse-3] 'mine-mouse-nop)
+(define-key map [mouse-2] 'mine-mouse-nop)))
+;; Move
+(substitute-key-definition 'backward-char 'mine-left  map gm)
+(substitute-key-definition 'forward-char  'mine-right map gm)
+(substitute-key-definition 'previous-line 'mine-up    map gm)
+(substitute-key-definition 'next-line     'mine-down  map gm)
+(substitute-key-definition 'beginning-of-line 'mine-bol map gm)
+(substitute-key-definition 'backward-word     'mine-bol map gm)
+(substitute-key-definition 'backward-sexp     'mine-bol map gm)
+(substitute-key-definition 'end-of-line       'mine-eol map gm)
+(substitute-key-definition 'forward-word      'mine-eol map gm)
+(substitute-key-definition 'forward-sexp      'mine-eol map gm)
+(define-key map "\M-p"   'mine-top)
+(define-key map "\M-n"   'mine-bottom)
+;; Hit and mark
+(define-key map " "      'mine-hit-curpoint)
+(define-key map "\C-m"   'mine-mark-curpoint)
+(define-key map [kp-enter] 'mine-mark-curpoint)
+(define-key map "m"      'mine-mark-curpoint)
+(define-key map "q"      'mine-quit)
+(setq mine-mode-map map)))
+;;; ================================================================
+;;; Faces
+(defun mine-init-faces ()
+(setq mine-faces (list))
+(when mine-colorp
+(let ((l (append mine-colors mine-default-colors))
+key.col key col name)
+(while l
+(setq key.col (car l)
+l (cdr l)
+key (car key.col)
+col (cdr key.col))
+(when (null (assoc key mine-faces))
+(setq name
+(cond
+	      ((null key) nil)
+	      ((symbolp key) (mine-make-face key col))
+	      ((not (integerp key))
+	       (error "Key should be a symbol or a number: '%s'" key))
+	      ((or (< key 0) (> key 8))
+	       (error "Key should be a number between 0 and 8: '%s'" key))
+	      (t
+	       (setq name (intern (concat "mine-face-" key)))
+	       (mine-make-face name col))))
+(setq mine-faces (cons (cons key name) mine-faces))))
+(setq mine-faces (nreverse mine-faces)))))
+(defun mine-make-face (name col)
+(or (if (fboundp 'internal-find-face)
+	  (internal-find-face name)
+	(find-face name))
+(let ((face (make-face name)))
+	(unless (or (not mine-xemacs-p) col)
+	  (setq col (cdr (face-background 'default 'global))))
+	(set-face-background face col)
+	face))
+name)
+(defun mine-get-face (key)
+(cdr (assoc key mine-faces)))
+;;; ================================================================
+;;; Init board
+(defun mine-init-board ()
+(setq mine-padx* (if mine-char-pad 2 1))
+(if (not mine-torus)
+(setq  mine-width  mine-xmax
+mine-height mine-ymax)
+(let (window-xmax window-nb-tiles-x window-xmax-int
+window-ymax window-nb-tiles-y window-ymax-int)
+(setq window-xmax       (/ (window-width) mine-padx*)
+window-nb-tiles-x (/ window-xmax mine-xmax)
+window-xmax-int   (* window-nb-tiles-x window-xmax))
+(setq mine-width
+(max mine-xmax ; at least mine-xmax
+(cond
+((null mine-nb-tiles-x) window-xmax)
+((not (numberp mine-nb-tiles-x))
+(error "mine-nb-tiles-x should be nil or a number: %s"
+mine-nb-tiles-x))
+((zerop mine-nb-tiles-x) window-xmax-int)
+((< mine-nb-tiles-x 0)
+(floor (* mine-xmax (- mine-nb-tiles-x))))
+((floatp mine-nb-tiles-x)
+(min window-xmax (floor (* mine-xmax mine-nb-tiles-x))))
+(t (min window-xmax-int (* mine-xmax mine-nb-tiles-x))))))
+(setq window-ymax (- (window-height) 5)
+window-nb-tiles-y (/ window-ymax mine-ymax)
+window-ymax-int (* window-nb-tiles-y window-ymax))
+(setq mine-height
+(max mine-ymax
+(cond
+((null mine-nb-tiles-y) window-ymax)
+((not (numberp mine-nb-tiles-y))
+(error "mine-nb-tiles-y should be nil or a number: %s"
+mine-nb-tiles-y))
+((zerop mine-nb-tiles-y) window-ymax-int)
+((< mine-nb-tiles-y 0)
+(floor (* mine-ymax (- mine-nb-tiles-y))))
+((floatp mine-nb-tiles-y)
+(min window-ymax (floor (* mine-ymax mine-nb-tiles-y))))
+(t (min window-ymax-int (* mine-ymax mine-nb-tiles-y))))))))
+(let ((buffer-read-only 'nil)
+	(face-unmarked (mine-get-face 'mine-face-unmarked))
+	(face-pad      (mine-get-face 'mine-face-pad))
+row col)
+(erase-buffer)
+(mine-insert-copyright)
+(mine-insert-remaining-mines)
+(mine-insert-mines-hit)
+(setq mine-point-min (point))
+(setq row mine-height)
+(while (>= (setq row (1- row)) 0)
+(setq col (1- mine-width))
+(insert mine-char-unmarked)
+(when face-unmarked
+	(put-text-property (1- (point)) (point) 'face face-unmarked))
+(while (>= (setq col (1- col)) 0)
+(when mine-char-pad
+(insert mine-char-pad)
+(when face-pad
+(put-text-property (1- (point)) (point) 'face face-pad)))
+(insert mine-char-unmarked)
+	(when face-unmarked
+	  (put-text-property (1- (point)) (point) 'face face-unmarked)))
+(insert ?\n))
+(setq mine-point-max (1- (point)))
+(mine-update-remaining-mines)
+(mine-update-mines-hit)
+(set-buffer-modified-p 'nil)))
+;;; ================================================================
+;;; Internal moves
+(defun mine-goto-point (point)
+(let ((x.y (mine-point-to-x.y point)))
+(setq mine-x (car x.y) mine-y (cdr x.y))
+(mine-goto mine-x mine-y)
+(= point (point))))
+(defun mine-goto (x y)
+(goto-char (mine-xy-to-point x y))
+(cond ((fboundp 'hscroll-point-visible)
+	 (hscroll-point-visible))
+	((fboundp 'auto-show-make-point-visible)
+	 (auto-show-make-point-visible))))
+;;; ================================================================
+;;; Conversions
+(defun mine-xy-to-point (x y)
+;; p = pmin + 2*w*(y-1) + 2*(x-1)
+(+ mine-point-min
+(* mine-padx* mine-width (1- y))
+(* mine-padx* (1- x))))
+;;; Returns the topleft equivalent of point,
+;;; on the periodic board, ie. converts point to model coordinates.
+(defun mine-top-left (x.y)
+(setcar x.y (1+ (mod (1- (car x.y)) mine-xmax)))
+(setcdr x.y (1+ (mod (1- (cdr x.y)) mine-ymax)))
+x.y)
+(defun mine-point-to-x.y (point)
+(let (x y (p0 (- point mine-point-min)))
+(cond
+((<= p0 0)
+(setq x 1  y 1))
+((>= point mine-point-max)
+(setq x mine-width  y mine-height))
+(t
+;; p = pmin + 2*w*(y-1) + 2*(x-1)
+;; y = (p - pmin)/2w + 1
+;; x = (p - pmin - 2*w*(y-1)) / 2  +  1
+(setq y (1+ (/ p0 mine-width mine-padx*))
+x (1+ (/ (- p0 (* mine-padx* mine-width (1- y))) mine-padx*)))))
+(cons x y)))
+;;; ================================================================
+;;; Screen display
+(defun mine-mark-board (point)
+(mine-update-board point mine-char-marked 'mine-face-marked))
+(defun mine-unmark-board (point)
+(mine-update-board point mine-char-unmarked 'mine-face-unmarked))
+(defun mine-display-nb-adjacent-mines (point nb)
+(mine-update-board point
+(if (zerop nb) mine-char-zero (+ ?0 nb))
+nb))
+;; todo: enumerer tous les points periodiques
+(defun mine-update-board (point c key)
+(let ((buffer-read-only 'nil)
+	(face (mine-get-face key))
+	(x.y (mine-top-left (mine-point-to-x.y point)))
+	x y)
+(setq x (car x.y))
+(while (<= x mine-width)
+(setq y (cdr x.y))
+(while (<= y mine-height)
+	(mine-update-point (mine-xy-to-point x y) c face)
+	(setq y (+ y mine-ymax)))
+(setq x (+ x mine-xmax)))
+(mine-reach-level 1) ; redisplay point and its periodic images
+(set-buffer-modified-p 'nil)))
+(defun mine-update-point (point c face)
+(goto-char point)
+(delete-char 1)
+(insert c)
+(when face
+(put-text-property point (point) 'face face))
+(mine-reach-level 0)) ; redisplay point
+(defun mine-reach-level (level)
+(cond
+((null mine-level)) ; no update at all
+((< mine-level 0))  ; no update at all
+((zerop mine-level) ; unconditional update
+(sit-for 0))
+((zerop level))     ; wait for level 1
+((= level 1)
+(cond
+((= mine-level level)
+	(sit-for 0))
+((= mine-count1 mine-count1-max)
+	(setq mine-count1 0)
+	(mine-reach-level (1+ level)))
+(t (setq mine-count1 (1+ mine-count1)))))
+((= level 2)
+(setq mine-count1 0)
+(cond
+((= mine-level level)
+	(sit-for 0))
+((= mine-count2 mine-count2-max)
+	(setq mine-count2 0)
+	(mine-reach-level (1+ level)))
+(t (setq mine-count2 (1+ mine-count2)))))
+((= level 3)
+(setq mine-count1 0)
+(setq mine-count2 0)
+(cond
+((= mine-level level)
+	(sit-for 0))))))
+(defun mine-reset-counters ()
+(setq mine-count1 0
+mine-count2 0))
+;;; ================================================================
+;;; Messages - init board
+(defun mine-insert-copyright ()
+(insert mine-version "\n\n"))
+(defun mine-insert-remaining-mines ()
+(insert (format "%16s" "Remaining mines") ":")
+(setq mine-point-remaining-mines (point))
+(insert "   \n"))
+(defun mine-insert-mines-hit ()
+(insert (format "%16s" "mines hit") ":")
+(setq mine-point-mines-hit (point))
+(insert "   \n\n"))
+;;; ================================================================
+;;; Messages - update board
+(defun mine-update-remaining-mines ()
+(let ((buffer-read-only 'nil))
+(save-excursion
+(goto-char mine-point-remaining-mines)
+(delete-char 3)
+(insert (format "%3d" mine-nb-remaining-marks)))
+(set-buffer-modified-p 'nil))
+(sit-for 0)
+(message "mines remaining to find...%d" mine-nb-remaining-marks)
+(when (and (zerop mine-nb-remaining-mines)
+	     (zerop mine-nb-remaining-marks))
+(mine-message 'mine-msg-win)))
+(defun mine-update-mines-hit ()
+(let ((buffer-read-only 'nil))
+(save-excursion
+(goto-char mine-point-mines-hit)
+(delete-char 3)
+(insert (format "%3d" mine-nb-mines-hit)))
+(set-buffer-modified-p 'nil)))
+(defun mine-update-bogus-mines (nrb nbb)
+(let ((buffer-read-only 'nil)
+	(msg (format "There were %d remaining mines and %d bogus mines"
+		     nrb nbb)))
+(save-excursion
+(goto-char (point-max))
+(insert "\n" msg))
+(set-buffer-modified-p 'nil)
+(message msg)))
+;;; ================================================================
+;;; Messages - write minibuffer
+(defun mine-message (msg)
+(ding)
+(cond
+((eq msg 'mine-msg-click-precisely)
+(message "Please, click more precisely"))
+((eq msg 'mine-msg-unmark-before-hit)
+(message "You must unmark point before hitting it."))
+((eq msg 'mine-msg-point-already-hit)
+(message "Point has already been hit."))
+((eq msg 'mine-msg-cannot-mark)
+(message "Can't (un)mark point..."))
+((eq msg 'mine-msg-loose)
+(message "Sorry... There's a mine here...")
+(sit-for 1)
+(message "Sorry... There's a mine here... You lost!"))
+((eq msg 'mine-msg-win)
+(message "Congratulations...")
+(sit-for 1)
+(message "Congratulations... You won!"))
+(t
+(message (format "%s" msg)))))
+(mine-init-mode-map)
+;;; ================================================================
+(defun mine-print-variables (l)
+(let (var)
+(princ "(setq ")
+(while l
+(setq var (car l) l (cdr l))
+(cond
+	((stringp var) (princ (format ";; %s\n      " var)))
+	((not (symbolp var)) (error "Not a symbol: %s" var))
+	((not (boundp var))  (error "Unboundp symbol: %s" var))
+	(t (princ (format "%-20s'%s" var (symbol-value var)))
+	   (when l (princ "\n      ")))))
+(princ "))\n")))
+;;; ================================================================
+;;(autoload 'apropos-print  "apropos")
+;;(autoload 'apropos-do-all "apropos")
+(if (not (boundp 'apropos-accumulator))
+(load "apropos"))
+(if (boundp 'apropos-item)
+;; (Daniel.Pfeiffer's) old official version of apropos
+(defun apropos-symbols (l &optional do-all)
+(let ((ll (list)))
+(while l
+(when (not (stringp (car l)))
+	(setq ll (cons (car l) ll)))
+(setq l (cdr l)))
+(setq apropos-accumulator (nreverse ll)))
+(or do-all (setq do-all apropos-do-all))
+(apropos-print
+t
+(lambda (p)
+(let (doc symbol)
+(while p
+(setcar p
+(list ; (s f v p)
+(setq symbol (car p))
+(if (commandp symbol)
+(if (setq doc (documentation symbol t))
+(substring doc 0 (string-match "\n" doc))
+"(not documented)"))
+(and do-all
+(user-variable-p symbol)
+(if (setq doc (documentation-property
+symbol 'variable-documentation t))
+(substring doc 0 (string-match "\n" doc))))))
+(setq p (cdr p)))))
+t)))
+(provide 'mine)
+;;; mine.el ends here

Mercurial > hg > xemacs-beta

comparison lisp/games/mine.el @ 98:0d2f883870bc r20-1b1