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