1;;; gamegrid.el --- library for implementing grid-based games on Emacs
2
3;; Copyright (C) 1997, 1998, 2001, 2002, 2003, 2004,
4;;   2005, 2006, 2007 Free Software Foundation, Inc.
5
6;; Author: Glynn Clements <glynn@sensei.co.uk>
7;; Version: 1.02
8;; Created: 1997-08-13
9;; Keywords: games
10
11;; This file is part of GNU Emacs.
12
13;; GNU Emacs is free software; you can redistribute it and/or modify
14;; it under the terms of the GNU General Public License as published by
15;; the Free Software Foundation; either version 2, or (at your option)
16;; any later version.
17
18;; GNU Emacs is distributed in the hope that it will be useful,
19;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
21;; GNU General Public License for more details.
22
23;; You should have received a copy of the GNU General Public License
24;; along with GNU Emacs; see the file COPYING.  If not, write to the
25;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
26;; Boston, MA 02110-1301, USA.
27
28;;; Commentary:
29
30;;; Code:
31
32(eval-when-compile
33  (require 'cl))
34
35;; ;;;;;;;;;;;;; buffer-local variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
36
37(defvar gamegrid-use-glyphs t
38  "Non-nil means use glyphs when available.")
39
40(defvar gamegrid-use-color t
41  "Non-nil means use color when available.")
42
43(defvar gamegrid-font "-*-courier-medium-r-*-*-*-140-100-75-*-*-iso8859-*"
44  "Name of the font used in X mode.")
45
46(defvar gamegrid-face nil
47  "Indicates the face to use as a default.")
48(make-variable-buffer-local 'gamegrid-face)
49
50(defvar gamegrid-display-options nil)
51
52(defvar gamegrid-buffer-width 0)
53(defvar gamegrid-buffer-height 0)
54(defvar gamegrid-blank 0)
55
56(defvar gamegrid-timer nil)
57
58(defvar gamegrid-display-mode nil)
59
60(defvar gamegrid-display-table)
61
62(defvar gamegrid-face-table nil)
63
64(defvar gamegrid-buffer-start 1)
65
66(defvar gamegrid-score-file-length 50
67  "Number of high scores to keep")
68
69(defvar gamegrid-user-score-file-directory "~/.emacs.d/games"
70  "A directory for game scores which can't be shared.
71If Emacs was built without support for shared game scores, then this
72directory will be used.")
73
74(make-variable-buffer-local 'gamegrid-use-glyphs)
75(make-variable-buffer-local 'gamegrid-use-color)
76(make-variable-buffer-local 'gamegrid-font)
77(make-variable-buffer-local 'gamegrid-display-options)
78(make-variable-buffer-local 'gamegrid-buffer-width)
79(make-variable-buffer-local 'gamegrid-buffer-height)
80(make-variable-buffer-local 'gamegrid-blank)
81(make-variable-buffer-local 'gamegrid-timer)
82(make-variable-buffer-local 'gamegrid-display-mode)
83(make-variable-buffer-local 'gamegrid-display-table)
84(make-variable-buffer-local 'gamegrid-face-table)
85(make-variable-buffer-local 'gamegrid-buffer-start)
86(make-variable-buffer-local 'gamegrid-score-file-length)
87
88;; ;;;;;;;;;;;;; global variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
89
90(defvar gamegrid-grid-x-face nil)
91(defvar gamegrid-mono-x-face nil)
92(defvar gamegrid-mono-tty-face nil)
93
94;; ;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
95
96(defconst gamegrid-glyph-height 16)
97
98(defconst gamegrid-xpm "\
99/* XPM */
100static char *noname[] = {
101/* width height ncolors chars_per_pixel */
102\"16 16 3 1\",
103/* colors */
104\"+ s col1\",
105\". s col2\",
106\"- s col3\",
107/* pixels */
108\"---------------+\",
109\"--------------++\",
110\"--............++\",
111\"--............++\",
112\"--............++\",
113\"--............++\",
114\"--............++\",
115\"--............++\",
116\"--............++\",
117\"--............++\",
118\"--............++\",
119\"--............++\",
120\"--............++\",
121\"--............++\",
122\"-+++++++++++++++\",
123\"++++++++++++++++\"
124};
125"
126  "XPM format image used for each square")
127
128(defvar gamegrid-xbm "\
129/* gamegrid XBM */
130#define gamegrid_width 16
131#define gamegrid_height 16
132static unsigned char gamegrid_bits[] = {
133   0xff, 0xff, 0xff, 0x7f, 0xff, 0x3f, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a,
134   0x57, 0x15, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a,
135   0x57, 0x15, 0x07, 0x00, 0x03, 0x00, 0x01, 0x00 };"
136  "XBM format image used for each square.")
137
138;; ;;;;;;;;;;;;;;;; miscellaneous functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
139
140(defsubst gamegrid-characterp (arg)
141  (if (fboundp 'characterp)
142      (characterp arg)
143    (integerp arg)))
144
145(defsubst gamegrid-event-x (event)
146  (if (fboundp 'event-x)
147      (event-x event)
148    (car (posn-col-row (event-end event)))))
149
150(defsubst gamegrid-event-y (event)
151  (if (fboundp 'event-y)
152      (event-y event)
153    (cdr (posn-col-row (event-end event)))))
154
155;; ;;;;;;;;;;;;; display functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
156
157(defun gamegrid-color (color shade)
158  (let* ((v (floor (* shade 255)))
159	 (r (* v (aref color 0)))
160	 (g (* v (aref color 1)))
161	 (b (* v (aref color 2))))
162    (format "#%02x%02x%02x" r g b)))
163
164(defun gamegrid-set-font (face)
165  (if gamegrid-font
166      (condition-case nil
167	  (set-face-font face gamegrid-font)
168	(error nil))))
169
170(defun gamegrid-setup-face (face color)
171  (set-face-foreground face color)
172  (set-face-background face color)
173  (gamegrid-set-font face)
174  (condition-case nil
175      (set-face-background-pixmap face [nothing]);; XEmacs
176    (error nil))
177  (condition-case nil
178      (set-face-background-pixmap face nil);; Emacs
179    (error nil)))
180
181(defun gamegrid-make-mono-tty-face ()
182  (let ((face (make-face 'gamegrid-mono-tty-face)))
183    (set-face-inverse-video-p face t)
184    face))
185
186(defun gamegrid-make-color-tty-face (color)
187  (let* ((color-str (if (symbolp color) (symbol-value color) color))
188	 (name (intern (format "gamegrid-color-tty-face-%s" color-str)))
189	 (face (make-face name)))
190    (gamegrid-setup-face face color-str)
191    face))
192
193(defun gamegrid-make-grid-x-face ()
194  (let ((face (make-face 'gamegrid-x-border-face)))
195    (gamegrid-set-font face)
196    face))
197
198(defun gamegrid-make-mono-x-face ()
199  (let ((face (make-face 'gamegrid-mono-x-face))
200	(color (face-foreground 'default)))
201    (if (null color)
202	(setq color
203	      (cdr-safe (assq 'foreground-color (frame-parameters)))))
204    (gamegrid-setup-face face color)
205    face))
206
207(defun gamegrid-make-color-x-face (color)
208  (let* ((hex (gamegrid-color color 1.0))
209	 (name (intern (format "gamegrid-color-x-face-%s" hex)))
210	 (face (make-face name)))
211    (gamegrid-setup-face face hex)
212    face))
213
214(defun gamegrid-make-face (data-spec-list color-spec-list)
215  (let ((data (gamegrid-match-spec-list data-spec-list))
216	(color (gamegrid-match-spec-list color-spec-list)))
217    (case data
218      ('color-x
219       (gamegrid-make-color-x-face color))
220      ('grid-x
221       (unless gamegrid-grid-x-face
222	 (setq gamegrid-grid-x-face (gamegrid-make-grid-x-face)))
223       gamegrid-grid-x-face)
224      ('mono-x
225       (unless gamegrid-mono-x-face
226	 (setq gamegrid-mono-x-face (gamegrid-make-mono-x-face)))
227       gamegrid-mono-x-face)
228      ('color-tty
229       (gamegrid-make-color-tty-face color))
230      ('mono-tty
231       (unless gamegrid-mono-tty-face
232	 (setq gamegrid-mono-tty-face (gamegrid-make-mono-tty-face)))
233       gamegrid-mono-tty-face))))
234
235(defun gamegrid-colorize-glyph (color)
236  (find-image `((:type xpm :data ,gamegrid-xpm
237		       :ascent center
238		       :color-symbols
239		       (("col1" . ,(gamegrid-color color 0.6))
240			("col2" . ,(gamegrid-color color 0.8))
241			("col3" . ,(gamegrid-color color 1.0))))
242		(:type xbm :data ,gamegrid-xbm
243		       :ascent center
244		       :foreground ,(gamegrid-color color 1.0)
245		       :background ,(gamegrid-color color 0.5)))))
246
247(defun gamegrid-match-spec (spec)
248  (let ((locale (car spec))
249	(value (cadr spec)))
250    (and (or (eq locale t)
251	     (and (listp locale)
252		  (memq gamegrid-display-mode locale))
253	     (and (symbolp locale)
254		  (eq gamegrid-display-mode locale)))
255	 value)))
256
257(defun gamegrid-match-spec-list (spec-list)
258  (and spec-list
259       (or (gamegrid-match-spec (car spec-list))
260	   (gamegrid-match-spec-list (cdr spec-list)))))
261
262(defun gamegrid-make-glyph (data-spec-list color-spec-list)
263  (let ((data (gamegrid-match-spec-list data-spec-list))
264	(color (gamegrid-match-spec-list color-spec-list)))
265    (cond ((gamegrid-characterp data)
266	   (vector data))
267	  ((eq data 'colorize)
268	   (gamegrid-colorize-glyph color))
269	  ((listp data)
270	   (find-image data)) ;untested!
271	  ((vectorp data)
272	   (gamegrid-make-image-from-vector data)))))
273
274(defun gamegrid-make-image-from-vector (vect)
275  "Convert an XEmacs style \"glyph\" to an image-spec."
276  (let ((l (list 'image :type)))
277    (dotimes (n (length vect))
278      (setf l (nconc l (list (aref vect n)))))
279    (nconc l (list :ascent 'center))))
280
281(defun gamegrid-display-type ()
282  (cond ((and gamegrid-use-glyphs
283	      (display-images-p))
284	 'glyph)
285	((and gamegrid-use-color
286	      (display-graphic-p)
287	      (display-color-p))
288	 'color-x)
289	((display-graphic-p)
290	 'mono-x)
291	((and gamegrid-use-color
292	      (display-color-p))
293	 'color-tty)
294	((display-multi-font-p) ;???
295	 'mono-tty)
296	(t
297	   'emacs-tty)))
298
299(defun gamegrid-set-display-table ()
300  (if (featurep 'xemacs)
301      (add-spec-to-specifier current-display-table
302			     gamegrid-display-table
303			     (current-buffer)
304			     nil
305			     'remove-locale)
306    (setq buffer-display-table gamegrid-display-table)))
307
308(defun gamegrid-setup-default-font ()
309  (setq gamegrid-face
310	(copy-face 'default
311		   (intern (concat "gamegrid-face-" (buffer-name)))))
312  (when (eq gamegrid-display-mode 'glyph)
313    (let ((max-height nil))
314      (loop for c from 0 to 255 do
315	    (let ((glyph (aref gamegrid-display-table c)))
316	      (when (and (listp glyph) (eq (car  glyph) 'image))
317		(let ((height (cdr (image-size glyph))))
318		  (if (or (null max-height)
319			  (< max-height height))
320		      (setq max-height height))))))
321      (when (and max-height (< max-height 1))
322	(set-face-attribute gamegrid-face nil :height max-height)))))
323
324(defun gamegrid-initialize-display ()
325  (setq gamegrid-display-mode (gamegrid-display-type))
326  (setq gamegrid-display-table (make-display-table))
327  (setq gamegrid-face-table (make-vector 256 nil))
328  (loop for c from 0 to 255 do
329    (let* ((spec (aref gamegrid-display-options c))
330	   (glyph (gamegrid-make-glyph (car spec) (caddr spec)))
331	   (face (gamegrid-make-face (cadr spec) (caddr spec))))
332      (aset gamegrid-face-table c face)
333      (aset gamegrid-display-table c glyph)))
334  (gamegrid-setup-default-font)
335  (gamegrid-set-display-table)
336  (setq cursor-type nil))
337
338
339(defun gamegrid-set-face (c)
340  (if (eq gamegrid-display-mode 'glyph)
341      (add-text-properties (1- (point)) (point)
342			   (list 'display (list (aref gamegrid-display-table c))))
343    (put-text-property (1- (point))
344		       (point)
345		       'face
346		       (aref gamegrid-face-table c))))
347
348(defun gamegrid-cell-offset (x y)
349  (+ gamegrid-buffer-start
350     (* (1+ gamegrid-buffer-width) y)
351     x))
352
353;; ;;;;;;;;;;;;;;;; grid functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
354
355(defun gamegrid-get-cell (x y)
356  (char-after (gamegrid-cell-offset x y)))
357
358(defun gamegrid-set-cell (x y c)
359  (save-excursion
360    (let ((buffer-read-only nil))
361      (goto-char (gamegrid-cell-offset x y))
362      (delete-char 1)
363      (insert-char c 1)
364      (gamegrid-set-face c))))
365
366(defun gamegrid-init-buffer (width height blank)
367  (setq gamegrid-buffer-width width
368	gamegrid-buffer-height height)
369  (let ((line (concat
370	       (make-string width blank)
371	       "\n"))
372	(buffer-read-only nil))
373    (erase-buffer)
374    (setq gamegrid-buffer-start (point))
375    (dotimes (i height)
376      (insert line))
377    ;; Adjust the height of the default face to the height of the
378    ;; images. Unlike XEmacs, Emacs doesn't allow to make the default
379    ;; face buffer-local; so we do this with an overlay.
380    (when (eq gamegrid-display-mode 'glyph)
381      (overlay-put (make-overlay (point-min) (point-max))
382		   'face gamegrid-face))
383    (goto-char (point-min))))
384
385(defun gamegrid-init (options)
386  (setq buffer-read-only t
387	truncate-lines t
388	gamegrid-display-options options)
389  (buffer-disable-undo (current-buffer))
390  (gamegrid-initialize-display))
391
392;; ;;;;;;;;;;;;;;;; timer functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
393
394(defun gamegrid-start-timer (period func)
395  (setq gamegrid-timer
396	(if (featurep 'itimer)
397	    (start-itimer "Gamegrid"
398			  func
399			  period
400			  period
401			  nil
402			  t
403			  (current-buffer))
404	  (run-with-timer period
405			  period
406			  func
407			  (current-buffer)))))
408
409(defun gamegrid-set-timer (delay)
410  (if gamegrid-timer
411      (if (fboundp 'set-itimer-restart)
412	  (set-itimer-restart gamegrid-timer delay)
413	(timer-set-time gamegrid-timer
414			(list (aref gamegrid-timer 1)
415			      (aref gamegrid-timer 2)
416			      (aref gamegrid-timer 3))
417			delay))))
418
419(defun gamegrid-kill-timer ()
420  (if gamegrid-timer
421      (if (featurep 'itimer)
422          (delete-itimer gamegrid-timer)
423        (cancel-timer gamegrid-timer)))
424  (setq gamegrid-timer nil))
425
426;; ;;;;;;;;;;;;;;; high score functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
427
428(defun gamegrid-add-score (file score)
429  "Add the current score to the high score file.
430
431On POSIX systems there may be a shared game directory for all users in
432which the scorefiles are kept. On such systems Emacs doesn't create
433the score file FILE in this directory, if it doesn't already exist. In
434this case Emacs searches for FILE in the directory specified by
435`gamegrid-user-score-file-directory' and creates it there, if
436necessary.
437
438To add the score file for a game to the system wide shared game
439directory, create the file with the shell command \"touch\" in this
440directory and make sure that it is owned by the correct user and
441group. You probably need special user privileges to do this.
442
443On non-POSIX systems Emacs searches for FILE in the directory
444specified by the variable `temporary-file-directory'. If necessary,
445FILE is created there."
446  (case system-type
447    ((ms-dos windows-nt)
448     (gamegrid-add-score-insecure file score))
449    (t
450     (gamegrid-add-score-with-update-game-score file score))))
451
452
453;; On POSIX systems there are four cases to distinguish:
454
455;;     1. FILE is an absolute filename.  Then it should be a file in
456;;        temporary file directory.  This is the way,
457;;        `gamegrid-add-score' was supposed to be used in the past and
458;;        is covered here for backward-compatibility.
459;;
460;;     2. The helper program "update-game-score" is setuid and the
461;;        file FILE does already exist in a system wide shared game
462;;        directory.  This should be the normal case on POSIX systems,
463;;        if the game was installed system wide.  Use
464;;        "update-game-score" to add the score to the file in the
465;;        shared game directory.
466;;
467;;     3. "update-game-score" is setuid, but the file FILE does *not*
468;;        exist in the system wide shared game directory.  Use
469;;        `gamegrid-add-score-insecure' to create--if necessary--and
470;;        update FILE.  This is for the case that a user has installed
471;;        a game on her own.
472;;
473;;     4. "update-game-score" is not setuid.  Use it to create/update
474;;        FILE in the user's home directory.  There is presumably no
475;;        shared game directory.
476
477(defvar gamegrid-shared-game-dir)
478
479(defun gamegrid-add-score-with-update-game-score (file score)
480  (let* ((result nil) ;; What is this good for? -- os
481	 (gamegrid-shared-game-dir
482	  (not (zerop (logand (file-modes
483			       (expand-file-name "update-game-score"
484						 exec-directory))
485			      #o4000)))))
486    (cond ((file-name-absolute-p file)
487	   (gamegrid-add-score-insecure file score))
488	  ((and gamegrid-shared-game-dir
489		(file-exists-p (expand-file-name file shared-game-score-directory)))
490	   ;; Use the setuid "update-game-score" program to update a
491	   ;; system-wide score file.
492	   (gamegrid-add-score-with-update-game-score-1 file
493	    (expand-file-name file shared-game-score-directory) score))
494	  ;; Else: Add the score to a score file in the user's home
495	  ;; directory.
496	  (gamegrid-shared-game-dir
497	   ;; If `gamegrid-shared-game-dir' is non-nil, then
498	   ;; "update-gamescore" program is setuid, so don't use it.
499	   (unless (file-exists-p
500		    (directory-file-name gamegrid-user-score-file-directory))
501	     (make-directory gamegrid-user-score-file-directory t))
502	   (gamegrid-add-score-insecure file score
503					gamegrid-user-score-file-directory))
504	  (t (let ((f (expand-file-name
505		       gamegrid-user-score-file-directory)))
506	       (when (file-writable-p f)
507		 (unless (eq (car-safe (file-attributes f))
508			     t)
509		   (make-directory f))
510		 (setq f (expand-file-name file f))
511		 (unless (file-exists-p f)
512		   (write-region "" nil f nil 'silent nil 'excl)))
513	       (gamegrid-add-score-with-update-game-score-1 file f score))))))
514
515(defun gamegrid-add-score-with-update-game-score-1 (file target score)
516  (let ((default-directory "/")
517	(errbuf (generate-new-buffer " *update-game-score loss*"))
518        (marker-string (concat
519			(user-full-name)
520			" <"
521			(cond ((fboundp 'user-mail-address)
522			       (user-mail-address))
523			      ((boundp 'user-mail-address)
524			       user-mail-address)
525			      (t ""))
526			">  "
527			(current-time-string))))
528    ;; This can be called from a timer, so enable local quits.
529    (with-local-quit
530      (apply
531       'call-process
532       (append
533	(list
534	 (expand-file-name "update-game-score" exec-directory)
535	 nil errbuf nil
536	 "-m" (int-to-string gamegrid-score-file-length)
537	 "-d" (if gamegrid-shared-game-dir
538		  (expand-file-name shared-game-score-directory)
539		(file-name-directory target))
540	 file
541	 (int-to-string score)
542	 marker-string))))
543    (if (buffer-modified-p errbuf)
544	(progn
545	  (display-buffer errbuf)
546	  (error "Failed to update game score file"))
547      (kill-buffer errbuf))
548    (let ((buf (find-buffer-visiting target)))
549      (save-excursion
550        (if buf
551	    (progn
552	      (switch-to-buffer buf)
553	      (revert-buffer nil t nil)
554	      (display-buffer buf))
555	  (find-file-read-only target))
556        (goto-char (point-min))
557        (search-forward (concat (int-to-string score)
558				" " (user-login-name) " "
559				marker-string))
560        (beginning-of-line)))))
561
562(defun gamegrid-add-score-insecure (file score &optional directory)
563  (save-excursion
564    (setq file (expand-file-name file (or directory
565					  temporary-file-directory)))
566    (find-file-other-window file)
567    (setq buffer-read-only nil)
568    (goto-char (point-max))
569    (insert (format "%05d\t%s\t%s <%s>\n"
570		    score
571		    (current-time-string)
572		    (user-full-name)
573		    (cond ((fboundp 'user-mail-address)
574			   (user-mail-address))
575			  ((boundp 'user-mail-address)
576			   user-mail-address)
577			  (t ""))))
578    (sort-fields 1 (point-min) (point-max))
579    (reverse-region (point-min) (point-max))
580    (goto-line (1+ gamegrid-score-file-length))
581    (delete-region (point) (point-max))
582    (setq buffer-read-only t)
583    (save-buffer)))
584
585
586;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
587
588(provide 'gamegrid)
589
590;;; arch-tag: a96c2ff4-1c12-427e-bd3d-faeaf174cd46
591;;; gamegrid.el ends here
592