view lisp/play/gamegrid.el @ 33863:2e449f784ca7

(init_from_display_pos): If POS says we're already after an overlay string ending at POS, make sure to pop the iterator because it will be in front of that overlay string. When POS is ZV, we've thereby also ``processed'' overlay strings at ZV.

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