lisp/play/gamegrid.el

   1 ;;; gamegrid.el --- library for implementing grid-based games on Emacs
   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
  29 ;;; Code:
  30
  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* ((color-str (if (symbolp color) (symbol-value color) color))
 170          (name (intern (format "gamegrid-color-tty-face-%s" color-str)))
 171          (face (make-face name)))
 172     (gamegrid-setup-face face color-str)
 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 hex)
 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   (make-local-variable 'cursor-type)
 290   (setq cursor-type nil))
 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)
 430
 431 ;;; gamegrid.el ends here