[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* ((color-str (symbol-value color))
	 (name (intern (format "gamegrid-color-tty-face-%s" color-str)))
	 (face (make-face name)))
    (gamegrid-setup-face face color-str)
    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 hex)
    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))
	     (and (fboundp 'display-color-p)
		  (display-color-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 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)
c7e6cdba EZ	169	(let* ((color-str (symbol-value color))
c7e6cdba EZ	170	(name (intern (format "gamegrid-color-tty-face-%s" color-str)))
3d4ae13e	171	(face (make-face name)))
c7e6cdba	172	(gamegrid-setup-face face color-str)
3d4ae13e RS	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)))
c7e6cdba	193	(gamegrid-setup-face face hex)
3d4ae13e RS	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))
c7e6cdba EZ	260	(and (fboundp 'display-color-p)
c7e6cdba EZ	261	(display-color-p))
3d4ae13e RS	262	window-system)))
	263	(cond ((and gamegrid-use-glyphs
	264	window-system-p
	265	(featurep 'xpm))
	266	'glyph)
	267	((and gamegrid-use-color
	268	window-system-p
	269	(gamegrid-color-display-p))
	270	'color-x)
	271	(window-system-p
	272	'mono-x)
	273	((and gamegrid-use-color
	274	(gamegrid-color-display-p))
	275	'color-tty)
	276	((fboundp 'set-face-property)
	277	'mono-tty)
	278	(t
	279	'emacs-tty))))
	280
	281	(defun gamegrid-set-display-table ()
	282	(if (fboundp 'specifierp)
	283	(add-spec-to-specifier current-display-table
	284	gamegrid-display-table
	285	(current-buffer)
	286	nil
	287	'remove-locale)
	288	(setq buffer-display-table gamegrid-display-table)))
	289
	290	(defun gamegrid-hide-cursor ()
	291	(if (fboundp 'specifierp)
	292	(set-specifier text-cursor-visible-p nil (current-buffer))))
	293
	294	(defun gamegrid-setup-default-font ()
	295	(cond ((eq gamegrid-display-mode 'glyph)
	296	(let* ((font-spec (face-property 'default 'font))
	297	(name (font-name font-spec))
	298	(max-height nil))
	299	(loop for c from 0 to 255 do
	300	(let ((glyph (aref gamegrid-display-table c)))
	301	(cond ((glyphp glyph)
	302	(let ((height (glyph-height glyph)))
	303	(if (or (null max-height)
	304	(< max-height height))
	305	(setq max-height height)))))))
	306	(if max-height
	307	(while (and (> (font-height font-spec) max-height)
	308	(setq name (x-find-smaller-font name)))
	309	(add-spec-to-specifier font-spec name (current-buffer))))))))
	310
	311	(defun gamegrid-initialize-display ()
	312	(setq gamegrid-display-mode (gamegrid-display-type))
	313	(setq gamegrid-display-table (make-display-table))
	314	(setq gamegrid-face-table (make-vector 256 nil))
	315	(loop for c from 0 to 255 do
	316	(let* ((spec (aref gamegrid-display-options c))
	317	(glyph (gamegrid-make-glyph (car spec) (caddr spec)))
	318	(face (gamegrid-make-face (cadr spec) (caddr spec))))
	319	(aset gamegrid-face-table c face)
	320	(aset gamegrid-display-table c glyph)))
	321	(gamegrid-setup-default-font)
	322	(gamegrid-set-display-table)
	323	(gamegrid-hide-cursor))
	324
	325
326	(defun gamegrid-set-face (c)
327	(unless (eq gamegrid-display-mode 'glyph)
328	(put-text-property (1- (point))
329	(point)
330	'face
331	(aref gamegrid-face-table c))))
332
333	(defun gamegrid-cell-offset (x y)
334	(+ gamegrid-buffer-start
335	(* (1+ gamegrid-buffer-width) y)
336	x))
337
338	;; ;;;;;;;;;;;;;;;; grid functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
339
340	(defun gamegrid-get-cell (x y)
341	(char-after (gamegrid-cell-offset x y)))
342
343	(defun gamegrid-set-cell (x y c)
344	(save-excursion
345	(let ((buffer-read-only nil))
346	(goto-char (gamegrid-cell-offset x y))
347	(delete-char 1)
348	(insert-char c 1)
349	(gamegrid-set-face c))))
350
351	(defun gamegrid-init-buffer (width height blank)
352	(setq gamegrid-buffer-width width
353	gamegrid-buffer-height height)
354	(let ((line (concat
355	(make-string width blank)
356	"\n"))
357	(buffer-read-only nil))
358	(erase-buffer)
359	(setq gamegrid-buffer-start (point))
360	(dotimes (i height)
8b78491a	361	(insert line))
3d4ae13e RS	362	(goto-char (point-min))))
	363
	364	(defun gamegrid-init (options)
	365	(setq buffer-read-only t
	366	truncate-lines t
	367	gamegrid-display-options options)
	368	(buffer-disable-undo (current-buffer))
	369	(gamegrid-initialize-display))
	370
	371	;; ;;;;;;;;;;;;;;;; timer functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	372
	373	(defun gamegrid-start-timer (period func)
	374	(setq gamegrid-timer
	375	(if (featurep 'itimer)
	376	(start-itimer "Gamegrid"
	377	func
	378	period
	379	period
	380	nil
	381	t
	382	(current-buffer))
	383	(run-with-timer period
	384	period
	385	func
	386	(current-buffer)))))
	387
	388	(defun gamegrid-set-timer (delay)
	389	(if gamegrid-timer
	390	(if (featurep 'itimer)
	391	(set-itimer-restart gamegrid-timer delay)
	392	(timer-set-time gamegrid-timer
	393	(list (aref gamegrid-timer 1)
	394	(aref gamegrid-timer 2)
	395	(aref gamegrid-timer 3))
	396	delay))))
	397
	398	(defun gamegrid-kill-timer ()
	399	(if gamegrid-timer
	400	(if (featurep 'itimer)
	401	(delete-itimer gamegrid-timer)
	402	(timer-set-time gamegrid-timer '(0 0 0) nil)))
	403	(setq gamegrid-timer nil))
	404
	405	;; ;;;;;;;;;;;;;;; high score functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	406
	407	(defun gamegrid-add-score (file score)
	408	"Add the current score to the high score file."
	409	(save-excursion
	410	(find-file-other-window file)
	411	(setq buffer-read-only nil)
	412	(goto-char (point-max))
	413	(insert (format "%05d\t%s\t%s <%s>\n"
	414	score
	415	(current-time-string)
	416	(user-full-name)
	417	(cond ((fboundp 'user-mail-address)
	418	(user-mail-address))
	419	((boundp 'user-mail-address)
	420	user-mail-address)
	421	(t ""))))
	422	(sort-numeric-fields 1 (point-min) (point-max))
	423	(reverse-region (point-min) (point-max))
	424	(goto-line (1+ gamegrid-score-file-length))
	425	(delete-region (point) (point-max))
426	(setq buffer-read-only t)
427	(save-buffer)))
428
429	;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
430
431	(provide 'gamegrid)
6e44da43 PJ	432
6e44da43 PJ	433	;;; gamegrid.el ends here