[bpt/emacs.git] / lisp / play / gamegrid.el

;;; gamegrid.el --- library for implementing grid-based games on Emacs

;; Copyright (C) 1997, 1998 Free Software Foundation, Inc.

;; Author: Glynn Clements <glynn@sensei.co.uk>
;; Version: 1.02
;; Created: 1997-08-13
;; Keywords: games

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;;; Code:

(eval-when-compile
  (require 'cl))

;; ;;;;;;;;;;;;; buffer-local variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar gamegrid-use-glyphs t
  "Non-nil means use glyphs when available.")

(defvar gamegrid-use-color t
  "Non-nil means use color when available.")

(defvar gamegrid-font "-*-courier-medium-r-*-*-*-140-100-75-*-*-iso8859-*"
  "Name of the font used in X mode.")

(defvar gamegrid-display-options nil)

(defvar gamegrid-buffer-width 0)
(defvar gamegrid-buffer-height 0)
(defvar gamegrid-blank 0)

(defvar gamegrid-timer nil)

(defvar gamegrid-display-mode nil)

(defvar gamegrid-display-table)

(defvar gamegrid-face-table nil)

(defvar gamegrid-buffer-start 1)

(defvar gamegrid-score-file-length 50
  "Number of high scores to keep")

(make-variable-buffer-local 'gamegrid-use-glyphs)
(make-variable-buffer-local 'gamegrid-use-color)
(make-variable-buffer-local 'gamegrid-font)
(make-variable-buffer-local 'gamegrid-display-options)
(make-variable-buffer-local 'gamegrid-buffer-width)
(make-variable-buffer-local 'gamegrid-buffer-height)
(make-variable-buffer-local 'gamegrid-blank)
(make-variable-buffer-local 'gamegrid-timer)
(make-variable-buffer-local 'gamegrid-display-mode)
(make-variable-buffer-local 'gamegrid-display-table)
(make-variable-buffer-local 'gamegrid-face-table)
(make-variable-buffer-local 'gamegrid-buffer-start)
(make-variable-buffer-local 'gamegrid-score-file-length)

;; ;;;;;;;;;;;;; global variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar gamegrid-grid-x-face nil)
(defvar gamegrid-mono-x-face nil)
(defvar gamegrid-mono-tty-face nil)

;; ;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defconst gamegrid-glyph-height 16)

(defconst gamegrid-xpm "\
/* XPM */
static char *noname[] = {
/* width height ncolors chars_per_pixel */
\"16 16 3 1\",
/* colors */
\"+ s col1\",
\". s col2\",
\"- s col3\",
/* pixels */
\"---------------+\",
\"--------------++\",
\"--............++\",
\"--............++\",
\"--............++\",
\"--............++\",
\"--............++\",
\"--............++\",
\"--............++\",
\"--............++\",
\"--............++\",
\"--............++\",
\"--............++\",
\"--............++\",
\"-+++++++++++++++\",
\"++++++++++++++++\"
};
"
  "XPM format image used for each square")

;; ;;;;;;;;;;;;;;;; miscellaneous functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsubst gamegrid-characterp (arg)
  (if (fboundp 'characterp)
      (characterp arg)
    (integerp arg)))

(defsubst gamegrid-event-x (event)
  (if (fboundp 'event-x)
      (event-x event)
    (car (posn-col-row (event-end event)))))

(defsubst gamegrid-event-y (event)
  (if (fboundp 'event-y)
      (event-y event)
    (cdr (posn-col-row (event-end event)))))

;; ;;;;;;;;;;;;; display functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun gamegrid-color (color shade)
  (let* ((v (floor (* shade 255)))
	 (r (* v (aref color 0)))
	 (g (* v (aref color 1)))
	 (b (* v (aref color 2))))
    (format "#%02x%02x%02x" r g b)))

(defun gamegrid-set-font (face)
  (if gamegrid-font
      (condition-case nil
	  (set-face-font face gamegrid-font)
	('error nil))))

(defun gamegrid-setup-face (face color)
  (set-face-foreground face color)
  (set-face-background face color)
  (gamegrid-set-font face)
  (condition-case nil
      (set-face-background-pixmap face [nothing]);; XEmacs
    ('error nil))
  (condition-case nil
      (set-face-background-pixmap face nil);; Emacs
    ('error nil)))

(defun gamegrid-make-mono-tty-face ()
  (let ((face (make-face 'gamegrid-mono-tty-face)))
    (condition-case nil
	(set-face-property face 'reverse t)
      ('error nil))
    face))

(defun gamegrid-make-color-tty-face (color)
  (let* ((hex (gamegrid-color color 1.0))
	 (name (intern (format "gamegrid-color-tty-face-%s" hex)))
	 (face (make-face name)))
    (gamegrid-setup-face face color)
    face))

(defun gamegrid-make-grid-x-face ()
  (let ((face (make-face 'gamegrid-x-border-face)))
    (gamegrid-set-font face)
    face))

(defun gamegrid-make-mono-x-face ()
  (let ((face (make-face 'gamegrid-mono-x-face))
	(color (face-foreground 'default)))
    (if (null color)
	(setq color
	      (cdr-safe (assq 'foreground-color (frame-parameters)))))
    (gamegrid-setup-face face color)
    face))

(defun gamegrid-make-color-x-face (color)
  (let* ((hex (gamegrid-color color 1.0))
	 (name (intern (format "gamegrid-color-x-face-%s" hex)))
	 (face (make-face name)))
    (gamegrid-setup-face face (gamegrid-color color 1.0))
    face))

(defun gamegrid-make-face (data-spec-list color-spec-list)
  (let ((data (gamegrid-match-spec-list data-spec-list))
	(color (gamegrid-match-spec-list color-spec-list)))
    (case data
      ('color-x
       (gamegrid-make-color-x-face color))
      ('grid-x
       (unless gamegrid-grid-x-face
	 (setq gamegrid-grid-x-face (gamegrid-make-grid-x-face)))
       gamegrid-grid-x-face)
      ('mono-x
       (unless gamegrid-mono-x-face
	 (setq gamegrid-mono-x-face (gamegrid-make-mono-x-face)))
       gamegrid-mono-x-face)
      ('color-tty
       (gamegrid-make-color-tty-face color))
      ('mono-tty
       (unless gamegrid-mono-tty-face
	 (setq gamegrid-mono-tty-face (gamegrid-make-mono-tty-face)))
       gamegrid-mono-tty-face))))

(defun gamegrid-colorize-glyph (color)
  (make-glyph
   (vector
    'xpm
    :data gamegrid-xpm
    :color-symbols (list (cons "col1" (gamegrid-color color 0.6))
			 (cons "col2" (gamegrid-color color 0.8))
			 (cons "col3" (gamegrid-color color 1.0))))))

(defun gamegrid-match-spec (spec)
  (let ((locale (car spec))
	(value (cadr spec)))
    (and (or (eq locale t)
	     (and (listp locale)
		  (memq gamegrid-display-mode locale))
	     (and (symbolp locale)
		  (eq gamegrid-display-mode locale)))
	 value)))

(defun gamegrid-match-spec-list (spec-list)
  (and spec-list
       (or (gamegrid-match-spec (car spec-list))
	   (gamegrid-match-spec-list (cdr spec-list)))))

(defun gamegrid-make-glyph (data-spec-list color-spec-list)
  (let ((data (gamegrid-match-spec-list data-spec-list))
	(color (gamegrid-match-spec-list color-spec-list)))
    (cond ((gamegrid-characterp data)
	   (vector data))
	  ((eq data 'colorize)
	   (gamegrid-colorize-glyph color))
	  ((vectorp data)
	   (make-glyph data)))))

(defun gamegrid-color-display-p ()
  (if (fboundp 'device-class)
      (eq (device-class (selected-device)) 'color)
    (eq (cdr-safe (assq 'display-type (frame-parameters))) 'color)))

(defun gamegrid-display-type ()
  (let ((window-system-p 
	 (or (and (fboundp 'console-on-window-system-p)
		  (console-on-window-system-p))
	     window-system)))
  (cond ((and gamegrid-use-glyphs
		window-system-p
	      (featurep 'xpm))
	 'glyph)
	((and gamegrid-use-color
		window-system-p
	      (gamegrid-color-display-p))
	 'color-x)
	  (window-system-p
	 'mono-x)
	((and gamegrid-use-color
	      (gamegrid-color-display-p))
	 'color-tty)
	((fboundp 'set-face-property)
	 'mono-tty)
	(t
	   'emacs-tty))))

(defun gamegrid-set-display-table ()
  (if (fboundp 'specifierp)
      (add-spec-to-specifier current-display-table
			     gamegrid-display-table
			     (current-buffer)
			     nil
			     'remove-locale)
    (setq buffer-display-table gamegrid-display-table)))

(defun gamegrid-hide-cursor ()
  (if (fboundp 'specifierp)
      (set-specifier text-cursor-visible-p nil (current-buffer))))

(defun gamegrid-setup-default-font ()
  (cond ((eq gamegrid-display-mode 'glyph)
	 (let* ((font-spec (face-property 'default 'font))
		(name (font-name font-spec))
		(max-height nil))
	   (loop for c from 0 to 255 do
	     (let ((glyph (aref gamegrid-display-table c)))
	       (cond ((glyphp glyph)
		      (let ((height (glyph-height glyph)))
			(if (or (null max-height)
				(< max-height height))
			    (setq max-height height)))))))
	   (if max-height
	       (while (and (> (font-height font-spec) max-height)
			   (setq name (x-find-smaller-font name)))
		 (add-spec-to-specifier font-spec name (current-buffer))))))))

(defun gamegrid-initialize-display ()
  (setq gamegrid-display-mode (gamegrid-display-type))
  (setq gamegrid-display-table (make-display-table))
  (setq gamegrid-face-table (make-vector 256 nil))
  (loop for c from 0 to 255 do
    (let* ((spec (aref gamegrid-display-options c))
	   (glyph (gamegrid-make-glyph (car spec) (caddr spec)))
	   (face (gamegrid-make-face (cadr spec) (caddr spec))))
      (aset gamegrid-face-table c face)
      (aset gamegrid-display-table c glyph)))
  (gamegrid-setup-default-font)
  (gamegrid-set-display-table)
  (gamegrid-hide-cursor))


(defun gamegrid-set-face (c)
  (unless (eq gamegrid-display-mode 'glyph)
    (put-text-property (1- (point))
		       (point)
		       'face
		       (aref gamegrid-face-table c))))

(defun gamegrid-cell-offset (x y)
  (+ gamegrid-buffer-start
     (* (1+ gamegrid-buffer-width) y)
     x))

;; ;;;;;;;;;;;;;;;; grid functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun gamegrid-get-cell (x y)
  (char-after (gamegrid-cell-offset x y)))

(defun gamegrid-set-cell (x y c)
  (save-excursion
    (let ((buffer-read-only nil))
      (goto-char (gamegrid-cell-offset x y))
      (delete-char 1)
      (insert-char c 1)
      (gamegrid-set-face c))))

(defun gamegrid-init-buffer (width height blank)
  (setq gamegrid-buffer-width width
	gamegrid-buffer-height height)
  (let ((line (concat
	       (make-string width blank)
	       "\n"))
	(buffer-read-only nil))
    (erase-buffer)
    (setq gamegrid-buffer-start (point))
    (dotimes (i height)
      (insert-string line))
    (goto-char (point-min))))

(defun gamegrid-init (options)
  (setq buffer-read-only t
	truncate-lines t
	gamegrid-display-options options)
  (buffer-disable-undo (current-buffer))
  (gamegrid-initialize-display))

;; ;;;;;;;;;;;;;;;; timer functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun gamegrid-start-timer (period func)
  (setq gamegrid-timer
	(if (featurep 'itimer)
	    (start-itimer "Gamegrid"
			  func
			  period
			  period
			  nil
			  t
			  (current-buffer))
	  (run-with-timer period
			  period
			  func
			  (current-buffer)))))

(defun gamegrid-set-timer (delay)
  (if gamegrid-timer
      (if (featurep 'itimer)
	  (set-itimer-restart gamegrid-timer delay)
	(timer-set-time gamegrid-timer
			(list (aref gamegrid-timer 1)
			      (aref gamegrid-timer 2)
			      (aref gamegrid-timer 3))
			delay))))

(defun gamegrid-kill-timer ()
  (if gamegrid-timer
      (if (featurep 'itimer)
          (delete-itimer gamegrid-timer)
        (timer-set-time gamegrid-timer '(0 0 0) nil)))
  (setq gamegrid-timer nil))

;; ;;;;;;;;;;;;;;; high score functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun gamegrid-add-score (file score)
  "Add the current score to the high score file."
  (save-excursion
  (find-file-other-window file)
  (setq buffer-read-only nil)
  (goto-char (point-max))
  (insert (format "%05d\t%s\t%s <%s>\n"
		  score
		  (current-time-string)
		  (user-full-name)
		  (cond ((fboundp 'user-mail-address)
			 (user-mail-address))
			((boundp 'user-mail-address)
			 user-mail-address)
			(t ""))))
  (sort-numeric-fields 1 (point-min) (point-max))
    (reverse-region (point-min) (point-max))
  (goto-line (1+ gamegrid-score-file-length))
  (delete-region (point) (point-max))
  (setq buffer-read-only t)
    (save-buffer)))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(provide 'gamegrid)

;;; gamegrid.el ends here
Commit	Line	Data
6e44da43	1	;;; gamegrid.el --- library for implementing grid-based games on Emacs
3d4ae13e RS	2
	3	;; Copyright (C) 1997, 1998 Free Software Foundation, Inc.
	4
	5	;; Author: Glynn Clements <glynn@sensei.co.uk>
	6	;; Version: 1.02
	7	;; Created: 1997-08-13
	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 the
	24	;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
	25	;; Boston, MA 02111-1307, USA.
	26
	27	;;; Commentary:
	28
6e44da43 PJ	29	;;; Code:
6e44da43 PJ	30
3d4ae13e RS	31	(eval-when-compile
	32	(require 'cl))
	33
	34	;; ;;;;;;;;;;;;; buffer-local variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	35
	36	(defvar gamegrid-use-glyphs t
	37	"Non-nil means use glyphs when available.")
	38
	39	(defvar gamegrid-use-color t
	40	"Non-nil means use color when available.")
	41
	42	(defvar gamegrid-font "--courier-medium-r----140-100-75---iso8859-*"
	43	"Name of the font used in X mode.")
	44
	45	(defvar gamegrid-display-options nil)
	46
	47	(defvar gamegrid-buffer-width 0)
	48	(defvar gamegrid-buffer-height 0)
	49	(defvar gamegrid-blank 0)
	50
	51	(defvar gamegrid-timer nil)
	52
	53	(defvar gamegrid-display-mode nil)
	54
	55	(defvar gamegrid-display-table)
	56
	57	(defvar gamegrid-face-table nil)
	58
	59	(defvar gamegrid-buffer-start 1)
	60
	61	(defvar gamegrid-score-file-length 50
	62	"Number of high scores to keep")
	63
	64	(make-variable-buffer-local 'gamegrid-use-glyphs)
	65	(make-variable-buffer-local 'gamegrid-use-color)
	66	(make-variable-buffer-local 'gamegrid-font)
	67	(make-variable-buffer-local 'gamegrid-display-options)
	68	(make-variable-buffer-local 'gamegrid-buffer-width)
	69	(make-variable-buffer-local 'gamegrid-buffer-height)
	70	(make-variable-buffer-local 'gamegrid-blank)
	71	(make-variable-buffer-local 'gamegrid-timer)
	72	(make-variable-buffer-local 'gamegrid-display-mode)
	73	(make-variable-buffer-local 'gamegrid-display-table)
	74	(make-variable-buffer-local 'gamegrid-face-table)
	75	(make-variable-buffer-local 'gamegrid-buffer-start)
	76	(make-variable-buffer-local 'gamegrid-score-file-length)
	77
	78	;; ;;;;;;;;;;;;; global variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	79
	80	(defvar gamegrid-grid-x-face nil)
	81	(defvar gamegrid-mono-x-face nil)
	82	(defvar gamegrid-mono-tty-face nil)
	83
	84	;; ;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	85
	86	(defconst gamegrid-glyph-height 16)
	87
	88	(defconst gamegrid-xpm "\
	89	/* XPM */
	90	static char *noname[] = {
	91	/* width height ncolors chars_per_pixel */
	92	\"16 16 3 1\",
	93	/* colors */
	94	\"+ s col1\",
95	\". s col2\",
96	\"- s col3\",
97	/* pixels */
98	\"---------------+\",
99	\"--------------++\",
100	\"--............++\",
101	\"--............++\",
102	\"--............++\",
103	\"--............++\",
104	\"--............++\",
105	\"--............++\",
106	\"--............++\",
107	\"--............++\",
108	\"--............++\",
109	\"--............++\",
110	\"--............++\",
111	\"--............++\",
112	\"-+++++++++++++++\",
113	\"++++++++++++++++\"
114	};
115	"
116	"XPM format image used for each square")
117
118	;; ;;;;;;;;;;;;;;;; miscellaneous functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
119
120	(defsubst gamegrid-characterp (arg)
121	(if (fboundp 'characterp)
122	(characterp arg)
123	(integerp arg)))
124
125	(defsubst gamegrid-event-x (event)
126	(if (fboundp 'event-x)
127	(event-x event)
128	(car (posn-col-row (event-end event)))))
129
130	(defsubst gamegrid-event-y (event)
131	(if (fboundp 'event-y)
132	(event-y event)
133	(cdr (posn-col-row (event-end event)))))
134
135	;; ;;;;;;;;;;;;; display functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
136
137	(defun gamegrid-color (color shade)
138	(let* ((v (floor (* shade 255)))
139	(r (* v (aref color 0)))
140	(g (* v (aref color 1)))
141	(b (* v (aref color 2))))
142	(format "#%02x%02x%02x" r g b)))
143
144	(defun gamegrid-set-font (face)
145	(if gamegrid-font
146	(condition-case nil
147	(set-face-font face gamegrid-font)
148	('error nil))))
149
150	(defun gamegrid-setup-face (face color)
151	(set-face-foreground face color)
152	(set-face-background face color)
153	(gamegrid-set-font face)
154	(condition-case nil
155	(set-face-background-pixmap face [nothing]);; XEmacs
156	('error nil))
157	(condition-case nil
158	(set-face-background-pixmap face nil);; Emacs
159	('error nil)))
160
161	(defun gamegrid-make-mono-tty-face ()
162	(let ((face (make-face 'gamegrid-mono-tty-face)))
163	(condition-case nil
164	(set-face-property face 'reverse t)
165	('error nil))
166	face))
167
168	(defun gamegrid-make-color-tty-face (color)
169	(let* ((hex (gamegrid-color color 1.0))
170	(name (intern (format "gamegrid-color-tty-face-%s" hex)))
171	(face (make-face name)))
172	(gamegrid-setup-face face color)
173	face))
174
175	(defun gamegrid-make-grid-x-face ()
176	(let ((face (make-face 'gamegrid-x-border-face)))
177	(gamegrid-set-font face)
178	face))
179
180	(defun gamegrid-make-mono-x-face ()
181	(let ((face (make-face 'gamegrid-mono-x-face))
182	(color (face-foreground 'default)))
183	(if (null color)
184	(setq color
185	(cdr-safe (assq 'foreground-color (frame-parameters)))))
186	(gamegrid-setup-face face color)
187	face))
188
189	(defun gamegrid-make-color-x-face (color)
190	(let* ((hex (gamegrid-color color 1.0))
191	(name (intern (format "gamegrid-color-x-face-%s" hex)))
192	(face (make-face name)))
193	(gamegrid-setup-face face (gamegrid-color color 1.0))
194	face))
195
196	(defun gamegrid-make-face (data-spec-list color-spec-list)
197	(let ((data (gamegrid-match-spec-list data-spec-list))
198	(color (gamegrid-match-spec-list color-spec-list)))
199	(case data
200	('color-x
201	(gamegrid-make-color-x-face color))
202	('grid-x
203	(unless gamegrid-grid-x-face
204	(setq gamegrid-grid-x-face (gamegrid-make-grid-x-face)))
205	gamegrid-grid-x-face)
206	('mono-x
207	(unless gamegrid-mono-x-face
208	(setq gamegrid-mono-x-face (gamegrid-make-mono-x-face)))
209	gamegrid-mono-x-face)
210	('color-tty
211	(gamegrid-make-color-tty-face color))
212	('mono-tty
213	(unless gamegrid-mono-tty-face
214	(setq gamegrid-mono-tty-face (gamegrid-make-mono-tty-face)))
215	gamegrid-mono-tty-face))))
216
217	(defun gamegrid-colorize-glyph (color)
218	(make-glyph
219	(vector
220	'xpm
221	:data gamegrid-xpm
222	:color-symbols (list (cons "col1" (gamegrid-color color 0.6))
223	(cons "col2" (gamegrid-color color 0.8))
224	(cons "col3" (gamegrid-color color 1.0))))))
225
226	(defun gamegrid-match-spec (spec)
227	(let ((locale (car spec))
228	(value (cadr spec)))
229	(and (or (eq locale t)
230	(and (listp locale)
231	(memq gamegrid-display-mode locale))
232	(and (symbolp locale)
233	(eq gamegrid-display-mode locale)))
234	value)))
235
236	(defun gamegrid-match-spec-list (spec-list)
237	(and spec-list
238	(or (gamegrid-match-spec (car spec-list))
239	(gamegrid-match-spec-list (cdr spec-list)))))
240
241	(defun gamegrid-make-glyph (data-spec-list color-spec-list)
242	(let ((data (gamegrid-match-spec-list data-spec-list))
243	(color (gamegrid-match-spec-list color-spec-list)))
244	(cond ((gamegrid-characterp data)
245	(vector data))
246	((eq data 'colorize)
247	(gamegrid-colorize-glyph color))
248	((vectorp data)
249	(make-glyph data)))))
250
251	(defun gamegrid-color-display-p ()
252	(if (fboundp 'device-class)
253	(eq (device-class (selected-device)) 'color)
254	(eq (cdr-safe (assq 'display-type (frame-parameters))) 'color)))
255
256	(defun gamegrid-display-type ()
257	(let ((window-system-p
258	(or (and (fboundp 'console-on-window-system-p)
259	(console-on-window-system-p))
260	window-system)))
261	(cond ((and gamegrid-use-glyphs
262	window-system-p
263	(featurep 'xpm))
264	'glyph)
265	((and gamegrid-use-color
266	window-system-p
267	(gamegrid-color-display-p))
268	'color-x)
269	(window-system-p
270	'mono-x)
271	((and gamegrid-use-color
272	(gamegrid-color-display-p))
273	'color-tty)
274	((fboundp 'set-face-property)
275	'mono-tty)
276	(t
277	'emacs-tty))))
278
279	(defun gamegrid-set-display-table ()
280	(if (fboundp 'specifierp)
281	(add-spec-to-specifier current-display-table
282	gamegrid-display-table
283	(current-buffer)
284	nil
285	'remove-locale)
286	(setq buffer-display-table gamegrid-display-table)))
287
288	(defun gamegrid-hide-cursor ()
289	(if (fboundp 'specifierp)
290	(set-specifier text-cursor-visible-p nil (current-buffer))))
291
292	(defun gamegrid-setup-default-font ()
293	(cond ((eq gamegrid-display-mode 'glyph)
294	(let* ((font-spec (face-property 'default 'font))
295	(name (font-name font-spec))
296	(max-height nil))
297	(loop for c from 0 to 255 do
298	(let ((glyph (aref gamegrid-display-table c)))
299	(cond ((glyphp glyph)
300	(let ((height (glyph-height glyph)))
301	(if (or (null max-height)
302	(< max-height height))
303	(setq max-height height)))))))
304	(if max-height
305	(while (and (> (font-height font-spec) max-height)
306	(setq name (x-find-smaller-font name)))
307	(add-spec-to-specifier font-spec name (current-buffer))))))))
308
309	(defun gamegrid-initialize-display ()
310	(setq gamegrid-display-mode (gamegrid-display-type))
311	(setq gamegrid-display-table (make-display-table))
312	(setq gamegrid-face-table (make-vector 256 nil))
313	(loop for c from 0 to 255 do
314	(let* ((spec (aref gamegrid-display-options c))
315	(glyph (gamegrid-make-glyph (car spec) (caddr spec)))
316	(face (gamegrid-make-face (cadr spec) (caddr spec))))
317	(aset gamegrid-face-table c face)
318	(aset gamegrid-display-table c glyph)))
319	(gamegrid-setup-default-font)
320	(gamegrid-set-display-table)
321	(gamegrid-hide-cursor))
322
323
324	(defun gamegrid-set-face (c)
325	(unless (eq gamegrid-display-mode 'glyph)
326	(put-text-property (1- (point))
327	(point)
328	'face
329	(aref gamegrid-face-table c))))
330
331	(defun gamegrid-cell-offset (x y)
332	(+ gamegrid-buffer-start
333	(* (1+ gamegrid-buffer-width) y)
334	x))
335
336	;; ;;;;;;;;;;;;;;;; grid functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
337
338	(defun gamegrid-get-cell (x y)
339	(char-after (gamegrid-cell-offset x y)))
340
341	(defun gamegrid-set-cell (x y c)
342	(save-excursion
343	(let ((buffer-read-only nil))
344	(goto-char (gamegrid-cell-offset x y))
345	(delete-char 1)
346	(insert-char c 1)
347	(gamegrid-set-face c))))
348
349	(defun gamegrid-init-buffer (width height blank)
350	(setq gamegrid-buffer-width width
351	gamegrid-buffer-height height)
352	(let ((line (concat
353	(make-string width blank)
354	"\n"))
355	(buffer-read-only nil))
356	(erase-buffer)
357	(setq gamegrid-buffer-start (point))
358	(dotimes (i height)
359	(insert-string line))
360	(goto-char (point-min))))
361
362	(defun gamegrid-init (options)
363	(setq buffer-read-only t
364	truncate-lines t
365	gamegrid-display-options options)
366	(buffer-disable-undo (current-buffer))
367	(gamegrid-initialize-display))
368
369	;; ;;;;;;;;;;;;;;;; timer functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
370
371	(defun gamegrid-start-timer (period func)
372	(setq gamegrid-timer
373	(if (featurep 'itimer)
374	(start-itimer "Gamegrid"
375	func
376	period
377	period
378	nil
379	t
380	(current-buffer))
381	(run-with-timer period
382	period
383	func
384	(current-buffer)))))
385
386	(defun gamegrid-set-timer (delay)
387	(if gamegrid-timer
388	(if (featurep 'itimer)
389	(set-itimer-restart gamegrid-timer delay)
390	(timer-set-time gamegrid-timer
391	(list (aref gamegrid-timer 1)
392	(aref gamegrid-timer 2)
393	(aref gamegrid-timer 3))
394	delay))))
395
396	(defun gamegrid-kill-timer ()
397	(if gamegrid-timer
398	(if (featurep 'itimer)
399	(delete-itimer gamegrid-timer)
400	(timer-set-time gamegrid-timer '(0 0 0) nil)))
401	(setq gamegrid-timer nil))
402
403	;; ;;;;;;;;;;;;;;; high score functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
404
405	(defun gamegrid-add-score (file score)
406	"Add the current score to the high score file."
407	(save-excursion
408	(find-file-other-window file)
409	(setq buffer-read-only nil)
410	(goto-char (point-max))
411	(insert (format "%05d\t%s\t%s <%s>\n"
412	score
413	(current-time-string)
414	(user-full-name)
415	(cond ((fboundp 'user-mail-address)
416	(user-mail-address))
417	((boundp 'user-mail-address)
418	user-mail-address)
419	(t ""))))
420	(sort-numeric-fields 1 (point-min) (point-max))
421	(reverse-region (point-min) (point-max))
422	(goto-line (1+ gamegrid-score-file-length))
423	(delete-region (point) (point-max))
424	(setq buffer-read-only t)
425	(save-buffer)))
426
427	;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
428
429	(provide 'gamegrid)
6e44da43 PJ	430
6e44da43 PJ	431	;;; gamegrid.el ends here