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