view lisp/play/gamegrid.el @ 48150:2b5f7e1254d1

(Fcall_interactively): New local filter_specs. (Fcall_interactively): Check for progn as well as let. Add a gcpro. (Qprogn): New variable. (syms_of_callint): Staticpro and init Qprogn.

;;; 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:

;;; 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-face nil
  "Indicates the face to use as a default.")
(make-variable-buffer-local 'gamegrid-face)

(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")

(defvar gamegrid-user-score-file-directory "~/.emacs.d/games"
  "A directory for game scores which can't be shared.
If Emacs was built without support for shared game scores, then this
directory will be used.")

(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")

(defvar gamegrid-xbm "\
/* gamegrid XBM */
#define gamegrid_width 16
#define gamegrid_height 16
static unsigned char gamegrid_bits[] = {
   0xff, 0xff, 0xff, 0x7f, 0xff, 0x3f, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a,
   0x57, 0x15, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a,
   0x57, 0x15, 0x07, 0x00, 0x03, 0x00, 0x01, 0x00 };"
  "XBM 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 (if (symbolp color) (symbol-value color) 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)
  (find-image `((:type xpm :data ,gamegrid-xpm
		       :ascent center
		       :color-symbols 
		       (("col1" . ,(gamegrid-color color 0.6))
			("col2" . ,(gamegrid-color color 0.8))
			("col3" . ,(gamegrid-color color 1.0))))
		(:type xbm :data ,gamegrid-xbm
		       :ascent center
		       :foreground ,(gamegrid-color color 1.0)
		       :background ,(gamegrid-color color 0.5)))))

(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))
	  ((listp data)
	   (find-image data)) ;untested!
	  ((vectorp data)
	   (gamegrid-make-image-from-vector data)))))

(defun gamegrid-make-image-from-vector (vect)
  "Convert an XEmacs style \"glyph\" to an image-spec."
  (let ((l (list 'image :type)))
    (dotimes (n (length vect))
      (setf l (nconc l (list (aref vect n)))))
    (nconc l (list :ascent 'center))))

(defun gamegrid-display-type ()
  (cond ((and gamegrid-use-glyphs
	      (display-images-p))
	 'glyph)
	((and gamegrid-use-color
	      (display-graphic-p)
	      (display-color-p))
	 'color-x)
	((display-graphic-p)
	 'mono-x)
	((and gamegrid-use-color
	      (display-color-p))
	 'color-tty)
	((display-multi-font-p) ;???
	 '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-setup-default-font ()
  (setq gamegrid-face
	(copy-face 'default
		   (intern (concat "gamegrid-face-" (buffer-name)))))
  (when (eq gamegrid-display-mode 'glyph)
    (let ((max-height nil))
      (loop for c from 0 to 255 do
	    (let ((glyph (aref gamegrid-display-table c)))
	      (when (and (listp glyph) (eq (car  glyph) 'image))
		(let ((height (cdr (image-size glyph))))
		  (if (or (null max-height)
			  (< max-height height))
		      (setq max-height height))))))
      (when (and max-height (< max-height 1))
	(set-face-attribute gamegrid-face nil :height max-height)))))

(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)
  (setq cursor-type nil))


(defun gamegrid-set-face (c)
  (if (eq gamegrid-display-mode 'glyph)
      (add-text-properties (1- (point)) (point)
			   (list 'display (list (aref gamegrid-display-table c))))
    (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))
    ;; Adjust the height of the default face to the height of the
    ;; images. Unlike XEmacs, Emacs doesn't allow to make the default
    ;; face buffer-local; so we do this with an overlay.
    (when (eq gamegrid-display-mode 'glyph)
      (overlay-put (make-overlay (point-min) (point-max))
		   'face gamegrid-face))
    (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."
  (case system-type
    ((ms-dos windows-nt)
     (gamegrid-add-score-insecure file score))
    (t
     (gamegrid-add-score-with-update-game-score file score))))

(defun gamegrid-add-score-with-update-game-score (file score)
  (let* ((result nil)
	 (errbuf (generate-new-buffer " *update-game-score loss*"))
	 (have-shared-game-dir
	  (not (zerop (logand (file-modes
			       (expand-file-name "update-game-score"
						 exec-directory))
			      #o4000))))
	 (target (if have-shared-game-dir
		     (expand-file-name file shared-game-score-directory)
		   (let ((f (expand-file-name
			     gamegrid-user-score-file-directory)))
		     (when (file-writable-p f)
		       (unless (eq (car-safe (file-attributes f))
				   t)
			 (make-directory f))
		       (setq f (expand-file-name file f))
		       (unless (file-exists-p f)
			 (write-region "" nil f nil 'silent nil 'excl)))
		     f))))
    (let ((default-directory "/"))
      (apply
       'call-process
       (append
	(list
	 (expand-file-name "update-game-score" exec-directory)
	 nil errbuf nil
	 "-m" (int-to-string gamegrid-score-file-length)
	 "-d" (if have-shared-game-dir
		  (expand-file-name shared-game-score-directory)
		(file-name-directory target))
	 file
	 (int-to-string score)
	 (concat
	  (user-full-name)
	  " <"
	  (cond ((fboundp 'user-mail-address)
		 (user-mail-address))
		((boundp 'user-mail-address)
		 user-mail-address)
		(t ""))
	  ">  "
	  (current-time-string))))))
    (if (buffer-modified-p errbuf)
	(progn
	  (display-buffer errbuf)
	  (error "Failed to update game score file"))
      (kill-buffer errbuf))
    (save-excursion
      (let ((buf (find-buffer-visiting target)))
	(if buf
	    (progn
	      (with-current-buffer buf
		(revert-buffer nil t nil))
	      (display-buffer buf))
	  (find-file-read-only-other-window target))))))

(defun gamegrid-add-score-insecure (file score)
  (save-excursion
    (setq file (expand-file-name file temporary-file-directory))
    (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