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. 98To learn how to play solitaire, see the documentation for function 99`solitaire'. 100\\<solitaire-mode-map> 101The 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. 131This takes a while, so switch this on if you like to be informed when 132the 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 143To play Solitaire, type \\[solitaire]. 144\\<solitaire-mode-map> 145Move around the board using the cursor keys. 146Move stones using \\[solitaire-move] followed by a direction key. 147Undo moves using \\[solitaire-undo]. 148Check for possible moves using \\[solitaire-do-check]. 149\(The variable `solitaire-auto-eval' controls whether to automatically 150check after each move or undo) 151 152What is Solitaire? 153 154I don't know who invented this game, but it seems to be rather old and 155its origin seems to be northern Africa. Here's how to play: 156Initially, 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 175Let's call the o's stones and the .'s holes. One stone fits into one 176hole. As you can see, all holes but one are occupied by stones. The 177aim of the game is to get rid of all but one stone, leaving that last 178one in the middle of the board if you're cool. 179 180A stone can be moved if there is another stone next to it, and a hole 181after that one. Thus there must be three fields in a row, either 182horizontally or vertically, up, down, left or right, which look like 183this: o o . 184 185Then the first stone is moved to the hole, jumping over the second, 186which therefore is taken away. The above thus `evaluates' to: . . o 187 188That'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 204Pick 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. 330MOVESYMBOL specifies the direction. 331Returns either a string, indicating cause of contraindication, or a 332list containing three numbers: starting field, skipped field (from 333which 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. 424Seen 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 462