diff lisp/play/gamegrid.el @ 22490:75a50246a099

Initial revision

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/play/gamegrid.el	Sun Jun 14 21:32:23 1998 +0000
@@ -0,0 +1,427 @@
+;;; gamegrid.el -- Library for implementing grid-based games on Emacs
+
+;; Copyright (C) 1997, 1998 Free Software Foundation, Inc.
+
+;; Author: Glynn Clements <[e-mail]>
+;; 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:
+
+(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)