lisp/play/solitaire.el

   1 ;;; solitaire.el --- game of solitaire in Emacs Lisp
   2
   3 ;; Copyright (C) 1994, 2001, 2002, 2003, 2004, 2005,
   4 ;;   2006, 2007, 2008 Free Software Foundation, Inc.
   5
   6 ;; Author: Jan Schormann <Jan.Schormann@rechen-gilde.de>
   7 ;; Created: Fri afternoon, Jun  3,  1994
   8 ;; Keywords: games
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; This mode is for playing a well-known game of solitaire
  28 ;; in which you jump pegs across other pegs.
  29
  30 ;; The game itself is somehow self-explanatory.  Read the help text to
  31 ;; solitaire, and try it.
  32
  33 ;;; Code:
  34
  35 (defgroup solitaire nil
  36   "Game of solitaire."
  37   :prefix "solitaire-"
  38   :group 'games)
  39
  40 (defvar solitaire-mode-map nil
  41   "Keymap for playing solitaire.")
  42
  43 (defcustom solitaire-mode-hook nil
  44   "Hook to run upon entry to solitaire."
  45   :type 'hook
  46   :group 'solitaire)
  47
  48 (if solitaire-mode-map
  49     ()
  50   (setq solitaire-mode-map (make-sparse-keymap))
  51   (suppress-keymap solitaire-mode-map t)
  52   (define-key solitaire-mode-map "\C-f" 'solitaire-right)
  53   (define-key solitaire-mode-map "\C-b" 'solitaire-left)
  54   (define-key solitaire-mode-map "\C-p" 'solitaire-up)
  55   (define-key solitaire-mode-map "\C-n" 'solitaire-down)
  56   (define-key solitaire-mode-map [return] 'solitaire-move)
  57   (define-key solitaire-mode-map [remap undo] 'solitaire-undo)
  58   (define-key solitaire-mode-map " " 'solitaire-do-check)
  59   (define-key solitaire-mode-map "q" 'quit-window)
  60
  61   (define-key solitaire-mode-map [right] 'solitaire-right)
  62   (define-key solitaire-mode-map [left] 'solitaire-left)
  63   (define-key solitaire-mode-map [up] 'solitaire-up)
  64   (define-key solitaire-mode-map [down] 'solitaire-down)
  65
  66   (define-key solitaire-mode-map [S-right] 'solitaire-move-right)
  67   (define-key solitaire-mode-map [S-left]  'solitaire-move-left)
  68   (define-key solitaire-mode-map [S-up]    'solitaire-move-up)
  69   (define-key solitaire-mode-map [S-down]  'solitaire-move-down)
  70
  71   (define-key solitaire-mode-map [kp-6] 'solitaire-right)
  72   (define-key solitaire-mode-map [kp-4] 'solitaire-left)
  73   (define-key solitaire-mode-map [kp-8] 'solitaire-up)
  74   (define-key solitaire-mode-map [kp-2] 'solitaire-down)
  75   (define-key solitaire-mode-map [kp-5] 'solitaire-center-point)
  76
  77   (define-key solitaire-mode-map [S-kp-6] 'solitaire-move-right)
  78   (define-key solitaire-mode-map [S-kp-4] 'solitaire-move-left)
  79   (define-key solitaire-mode-map [S-kp-8] 'solitaire-move-up)
  80   (define-key solitaire-mode-map [S-kp-2] 'solitaire-move-down)
  81
  82   (define-key solitaire-mode-map [kp-enter] 'solitaire-move)
  83   (define-key solitaire-mode-map [kp-0] 'solitaire-undo)
  84
  85   ;; spoil it with s ;)
  86   (define-key solitaire-mode-map [?s] 'solitaire-solve)
  87
  88   ;;  (define-key solitaire-mode-map [kp-0] 'solitaire-hint) - Not yet provided ;)
  89   )
  90
  91 ;; Solitaire mode is suitable only for specially formatted data.
  92 (put 'solitaire-mode 'mode-class 'special)
  93
  94 (defun solitaire-mode ()
  95   "Major mode for playing solitaire.
  96 To learn how to play solitaire, see the documentation for function
  97 `solitaire'.
  98 \\<solitaire-mode-map>
  99 The usual mnemonic keys move the cursor around the board; in addition,
 100 \\[solitaire-move] is a prefix character for actually moving a stone on the board."
 101   (interactive)
 102   (kill-all-local-variables)
 103   (use-local-map solitaire-mode-map)
 104   (setq truncate-lines t)
 105   (setq major-mode 'solitaire-mode)
 106   (setq mode-name "Solitaire")
 107   (run-mode-hooks 'solitaire-mode-hook))
 108
 109 (defvar solitaire-stones 0
 110   "Counter for the stones that are still there.")
 111
 112 (defvar solitaire-center nil
 113   "Center of the board.")
 114
 115 (defvar solitaire-start nil
 116   "Upper left corner of the board.")
 117
 118 (defvar solitaire-start-x nil)
 119 (defvar solitaire-start-y nil)
 120
 121 (defvar solitaire-end nil
 122   "Lower right corner of the board.")
 123
 124 (defvar solitaire-end-x nil)
 125 (defvar solitaire-end-y nil)
 126
 127 (defcustom solitaire-auto-eval t
 128   "*Non-nil means check for possible moves after each major change.
 129 This takes a while, so switch this on if you like to be informed when
 130 the game is over, or off, if you are working on a slow machine."
 131   :type 'boolean
 132   :group 'solitaire)
 133
 134 (defconst solitaire-valid-directions
 135   '(solitaire-left solitaire-right solitaire-up solitaire-down))
 136
 137 ;;;###autoload
 138 (defun solitaire (arg)
 139   "Play Solitaire.
 140
 141 To play Solitaire, type \\[solitaire].
 142 \\<solitaire-mode-map>
 143 Move around the board using the cursor keys.
 144 Move stones using \\[solitaire-move] followed by a direction key.
 145 Undo moves using \\[solitaire-undo].
 146 Check for possible moves using \\[solitaire-do-check].
 147 \(The variable `solitaire-auto-eval' controls whether to automatically
 148 check after each move or undo)
 149
 150 What is Solitaire?
 151
 152 I don't know who invented this game, but it seems to be rather old and
 153 its origin seems to be northern Africa.  Here's how to play:
 154 Initially, the board will look similar to this:
 155
 156         Le Solitaire
 157         ============
 158
 159                 o   o   o
 160
 161                 o   o   o
 162
 163         o   o   o   o   o   o   o
 164
 165         o   o   o   .   o   o   o
 166
 167         o   o   o   o   o   o   o
 168
 169                 o   o   o
 170
 171                 o   o   o
 172
 173 Let's call the o's stones and the .'s holes.  One stone fits into one
 174 hole.  As you can see, all holes but one are occupied by stones.  The
 175 aim of the game is to get rid of all but one stone, leaving that last
 176 one in the middle of the board if you're cool.
 177
 178 A stone can be moved if there is another stone next to it, and a hole
 179 after that one.  Thus there must be three fields in a row, either
 180 horizontally or vertically, up, down, left or right, which look like
 181 this:  o  o  .
 182
 183 Then the first stone is moved to the hole, jumping over the second,
 184 which therefore is taken away.  The above thus `evaluates' to:  .  .  o
 185
 186 That's all.  Here's the board after two moves:
 187
 188                 o   o   o
 189
 190                 .   o   o
 191
 192         o   o   .   o   o   o   o
 193
 194         o   .   o   o   o   o   o
 195
 196         o   o   o   o   o   o   o
 197
 198                 o   o   o
 199
 200                 o   o   o
 201
 202 Pick your favourite shortcuts:
 203
 204 \\{solitaire-mode-map}"
 205
 206   (interactive "P")
 207   (switch-to-buffer "*Solitaire*")
 208   (solitaire-mode)
 209   (setq buffer-read-only t)
 210   (setq solitaire-stones 32)
 211   (solitaire-insert-board)
 212   (solitaire-build-modeline)
 213   (goto-char (point-max))
 214   (setq solitaire-center (search-backward "."))
 215   (setq buffer-undo-list (list (point)))
 216   (set-buffer-modified-p nil))
 217
 218 (defun solitaire-build-modeline ()
 219   (setq mode-line-format
 220         (list "" "---" 'mode-line-buffer-identification
 221               (if (< 1 solitaire-stones)
 222                   (format "--> There are %d stones left <--" solitaire-stones)
 223                 "------")
 224               'global-mode-string "   %[(" 'mode-name 'minor-mode-alist "%n"
 225               ")%]-%-"))
 226   (force-mode-line-update))
 227
 228 (defun solitaire-insert-board ()
 229   (let* ((buffer-read-only nil)
 230          (w (window-width))
 231          (h (window-height))
 232          (hsep (cond ((> w 26) "   ")
 233                      ((> w 20) " ")
 234                      (t "")))
 235          (vsep (cond ((> h 17) "\n\n")
 236                      (t "\n")))
 237          (indent (make-string (/ (- w 7 (* 6 (length hsep))) 2) ?\ )))
 238     (erase-buffer)
 239     (insert (make-string (/ (- h 7 (if (> h 12) 3 0)
 240                                (* 6 (1- (length vsep)))) 2) ?\n))
 241     (if (or (string= vsep "\n\n") (> h 12))
 242         (progn
 243           (insert (format "%sLe Solitaire\n" indent))
 244           (insert (format "%s============\n\n" indent))))
 245     (insert indent)
 246     (setq solitaire-start (point))
 247     (setq solitaire-start-x (current-column))
 248     (setq solitaire-start-y (solitaire-current-line))
 249     (insert (format " %s %so%so%so%s" hsep hsep hsep hsep vsep))
 250     (insert (format "%s %s %so%so%so%s" indent hsep hsep hsep hsep vsep))
 251     (insert (format "%so%so%so%so%so%so%so%s" indent hsep hsep hsep hsep hsep hsep vsep))
 252     (insert (format "%so%so%so%s" indent hsep hsep hsep))
 253     (setq solitaire-center (point))
 254     (insert (format ".%so%so%so%s" hsep hsep hsep vsep))
 255     (insert (format "%so%so%so%so%so%so%so%s" indent hsep hsep hsep hsep hsep hsep vsep))
 256     (insert (format "%s %s %so%so%so%s" indent hsep hsep hsep hsep vsep))
 257     (insert (format "%s %s %so%so%so%s %s " indent hsep hsep hsep hsep hsep hsep))
 258     (setq solitaire-end (point))
 259     (setq solitaire-end-x (current-column))
 260     (setq solitaire-end-y (solitaire-current-line))
 261     ))
 262
 263 (defun solitaire-right ()
 264   (interactive)
 265   (let ((start (point)))
 266     (forward-char)
 267     (while (= ?\  (following-char))
 268       (forward-char))
 269     (if (or  (= 0 (following-char))
 270              (= ?\  (following-char))
 271             (= ?\n (following-char)))
 272         (goto-char start))))
 273
 274 (defun solitaire-left ()
 275   (interactive)
 276   (let ((start (point)))
 277     (backward-char)
 278     (while (= ?\  (following-char))
 279       (backward-char))
 280     (if (or  (= 0 (preceding-char))
 281              (= ?\  (following-char))
 282             (= ?\n (following-char)))
 283         (goto-char start))))
 284
 285 (defun solitaire-up ()
 286   (interactive)
 287   (let ((start (point))
 288         (c (current-column)))
 289     (forward-line -1)
 290     (move-to-column c)
 291     (while (and (= ?\n (following-char))
 292                 (forward-line -1)
 293                 (move-to-column c)
 294                 (not (bolp))))
 295     (if (or (= 0 (preceding-char))
 296             (= ?\  (following-char))
 297             (= ?\= (following-char))
 298             (= ?\n (following-char)))
 299         (goto-char start)
 300         )))
 301
 302 (defun solitaire-down ()
 303   (interactive)
 304   (let ((start (point))
 305         (c (current-column)))
 306     (forward-line 1)
 307     (move-to-column c)
 308     (while (and (= ?\n (following-char))
 309                 (forward-line 1)
 310                 (move-to-column c)
 311                 (not (eolp))))
 312     (if (or (= 0 (following-char))
 313             (= ?\  (following-char))
 314             (= ?\n (following-char)))
 315         (goto-char start))))
 316
 317 (defun solitaire-center-point ()
 318   (interactive)
 319   (goto-char solitaire-center))
 320
 321 (defun solitaire-move-right () (interactive) (solitaire-move '[right]))
 322 (defun solitaire-move-left () (interactive) (solitaire-move '[left]))
 323 (defun solitaire-move-up () (interactive) (solitaire-move '[up]))
 324 (defun solitaire-move-down () (interactive) (solitaire-move '[down]))
 325
 326 (defun solitaire-possible-move (movesymbol)
 327   "Check if a move is possible from current point in the specified direction.
 328 MOVESYMBOL specifies the direction.
 329 Returns either a string, indicating cause of contraindication, or a
 330 list containing three numbers: starting field, skipped field (from
 331 which a stone will be taken away) and target."
 332
 333   (save-excursion
 334     (if (memq movesymbol solitaire-valid-directions)
 335         (let ((start (point))
 336               (skip (progn (funcall movesymbol) (point)))
 337               (target (progn (funcall movesymbol) (point))))
 338           (if (= skip target)
 339               "Off Board!"
 340             (if (or (/= ?o (char-after start))
 341                     (/= ?o (char-after skip))
 342                     (/= ?. (char-after target)))
 343                 "Wrong move!"
 344               (list start skip target))))
 345       "Not a valid direction")))
 346
 347 (defun solitaire-move (dir)
 348   "Pseudo-prefix command to move a stone in Solitaire."
 349   (interactive "kMove where? ")
 350   (let* ((class (solitaire-possible-move (lookup-key solitaire-mode-map dir)))
 351          (buffer-read-only nil))
 352     (if (stringp class)
 353         (error class)
 354       (let ((start (car class))
 355             (skip (car (cdr class)))
 356             (target (car (cdr (cdr class)))))
 357         (goto-char start)
 358         (delete-char 1)
 359         (insert ?.)
 360         (goto-char skip)
 361         (delete-char 1)
 362         (insert ?.)
 363         (goto-char target)
 364         (delete-char 1)
 365         (insert ?o)
 366         (goto-char target)
 367         (setq solitaire-stones (1- solitaire-stones))
 368         (solitaire-build-modeline)
 369         (if solitaire-auto-eval (solitaire-do-check))))))
 370
 371 (defun solitaire-undo (arg)
 372   "Undo a move in Solitaire."
 373   (interactive "P")
 374   (let ((buffer-read-only nil))
 375     (undo arg))
 376   (save-excursion
 377     (setq solitaire-stones
 378           (let ((count 0))
 379             (goto-char solitaire-end)
 380             (while (search-backward "o" solitaire-start 'done)
 381               (and (>= (current-column) solitaire-start-x)
 382                    (<= (current-column) solitaire-end-x)
 383                    (>= (solitaire-current-line) solitaire-start-y)
 384                    (<= (solitaire-current-line) solitaire-end-y)
 385                    (setq count (1+ count))))
 386             count)))
 387   (solitaire-build-modeline)
 388   (if solitaire-auto-eval (solitaire-do-check)))
 389
 390 (defun solitaire-check ()
 391   (save-excursion
 392     (if (= 1 solitaire-stones)
 393         0
 394       (goto-char solitaire-end)
 395       (let ((count 0))
 396         (while (search-backward "o" solitaire-start 'done)
 397           (and (>= (current-column) solitaire-start-x)
 398                (<= (current-column) solitaire-end-x)
 399                (>= (solitaire-current-line) solitaire-start-y)
 400                (<= (solitaire-current-line) solitaire-end-y)
 401                (mapc
 402                 (lambda (movesymbol)
 403                   (if (listp (solitaire-possible-move movesymbol))
 404                       (setq count (1+ count))))
 405                 solitaire-valid-directions)))
 406         count))))
 407
 408 (defun solitaire-do-check (&optional arg)
 409   "Check for any possible moves in Solitaire."
 410   (interactive "P")
 411   (let ((moves (solitaire-check)))
 412     (cond ((= 1 solitaire-stones)
 413            (message "Yeah! You made it! Only the King is left!"))
 414           ((zerop moves)
 415            (message "Sorry, no more possible moves."))
 416           ((= 1 moves)
 417            (message "There is one possible move."))
 418           (t (message "There are %d possible moves." moves)))))
 419
 420 (defun solitaire-current-line ()
 421   "Return the vertical position of point.
 422 Seen in info on text lines."
 423   (+ (count-lines (point-min) (point))
 424      (if (= (current-column) 0) 1 0)
 425      -1))
 426
 427 ;; And here's the spoiler:)
 428 (defun solitaire-solve ()
 429   "Spoil solitaire by solving the game for you - nearly ...
 430 ... stops with five stones left ;)"
 431   (interactive)
 432   (let ((allmoves [up up S-down up left left S-right up up left S-down
 433                       up up right right S-left down down down S-up up
 434                       S-down down down down S-up left left down
 435                       S-right left left up up S-down right right right
 436                       S-left left S-right right right right S-left
 437                       right down down S-up down down left left S-right
 438                       up up up S-down down S-up up up up S-down up
 439                       right right S-left down right right down S-up
 440                       left left left S-right right S-left down down
 441                       left S-right S-up S-left S-left S-down S-right
 442                       up S-right left left])
 443         ;; down down S-up left S-right
 444         ;; right S-left
 445         (solitaire-auto-eval nil))
 446     (solitaire-center-point)
 447     (mapc (lambda (op)
 448             (if (memq op '(S-left S-right S-up S-down))
 449                 (sit-for 0.2))
 450             (execute-kbd-macro (vector op))
 451             (if (memq op '(S-left S-right S-up S-down))
 452                 (sit-for 0.4)))
 453           allmoves))
 454   (solitaire-do-check))
 455
 456 (provide 'solitaire)
 457
 458 ;; arch-tag: 1b18ee1c-1e79-4a5b-8658-9560b82e63dd
 459 ;;; solitaire.el ends here