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 (eval-when-compile
  30   (require 'cl))
  31
  32 ;; ;;;;;;;;;;;;; buffer-local variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  33
  34 (defvar gamegrid-use-glyphs t
  35   "Non-nil means use glyphs when available.")
  36
  37 (defvar gamegrid-use-color t
  38   "Non-nil means use color when available.")
  39
  40 (defvar gamegrid-font "-*-courier-medium-r-*-*-*-140-100-75-*-*-iso8859-*"
  41   "Name of the font used in X mode.")
  42
  43 (defvar gamegrid-display-options nil)
  44
  45 (defvar gamegrid-buffer-width 0)
  46 (defvar gamegrid-buffer-height 0)
  47 (defvar gamegrid-blank 0)
  48
  49 (defvar gamegrid-timer nil)
  50
  51 (defvar gamegrid-display-mode nil)
  52
  53 (defvar gamegrid-display-table)
  54
  55 (defvar gamegrid-face-table nil)
  56
  57 (defvar gamegrid-buffer-start 1)
  58
  59 (defvar gamegrid-score-file-length 50
  60   "Number of high scores to keep")
  61
  62 (make-variable-buffer-local 'gamegrid-use-glyphs)
  63 (make-variable-buffer-local 'gamegrid-use-color)
  64 (make-variable-buffer-local 'gamegrid-font)
  65 (make-variable-buffer-local 'gamegrid-display-options)
  66 (make-variable-buffer-local 'gamegrid-buffer-width)
  67 (make-variable-buffer-local 'gamegrid-buffer-height)
  68 (make-variable-buffer-local 'gamegrid-blank)
  69 (make-variable-buffer-local 'gamegrid-timer)
  70 (make-variable-buffer-local 'gamegrid-display-mode)
  71 (make-variable-buffer-local 'gamegrid-display-table)
  72 (make-variable-buffer-local 'gamegrid-face-table)
  73 (make-variable-buffer-local 'gamegrid-buffer-start)
  74 (make-variable-buffer-local 'gamegrid-score-file-length)
  75
  76 ;; ;;;;;;;;;;;;; global variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  77
  78 (defvar gamegrid-grid-x-face nil)
  79 (defvar gamegrid-mono-x-face nil)
  80 (defvar gamegrid-mono-tty-face nil)
  81
  82 ;; ;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  83
  84 (defconst gamegrid-glyph-height 16)
  85
  86 (defconst gamegrid-xpm "\
  87 /* XPM */
  88 static char *noname[] = {
  89 /* width height ncolors chars_per_pixel */
  90 \"16 16 3 1\",
  91 /* colors */
  92 \"+ s col1\",
  93 \". s col2\",
  94 \"- s col3\",
  95 /* pixels */
  96 \"---------------+\",
  97 \"--------------++\",
  98 \"--............++\",
  99 \"--............++\",
 100 \"--............++\",
 101 \"--............++\",
 102 \"--............++\",
 103 \"--............++\",
 104 \"--............++\",
 105 \"--............++\",
 106 \"--............++\",
 107 \"--............++\",
 108 \"--............++\",
 109 \"--............++\",
 110 \"-+++++++++++++++\",
 111 \"++++++++++++++++\"
 112 };
 113 "
 114   "XPM format image used for each square")
 115
 116 ;; ;;;;;;;;;;;;;;;; miscellaneous functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 117
 118 (defsubst gamegrid-characterp (arg)
 119   (if (fboundp 'characterp)
 120       (characterp arg)
 121     (integerp arg)))
 122
 123 (defsubst gamegrid-event-x (event)
 124   (if (fboundp 'event-x)
 125       (event-x event)
 126     (car (posn-col-row (event-end event)))))
 127
 128 (defsubst gamegrid-event-y (event)
 129   (if (fboundp 'event-y)
 130       (event-y event)
 131     (cdr (posn-col-row (event-end event)))))
 132
 133 ;; ;;;;;;;;;;;;; display functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 134
 135 (defun gamegrid-color (color shade)
 136   (let* ((v (floor (* shade 255)))
 137          (r (* v (aref color 0)))
 138          (g (* v (aref color 1)))
 139          (b (* v (aref color 2))))
 140     (format "#%02x%02x%02x" r g b)))
 141
 142 (defun gamegrid-set-font (face)
 143   (if gamegrid-font
 144       (condition-case nil
 145           (set-face-font face gamegrid-font)
 146         ('error nil))))
 147
 148 (defun gamegrid-setup-face (face color)
 149   (set-face-foreground face color)
 150   (set-face-background face color)
 151   (gamegrid-set-font face)
 152   (condition-case nil
 153       (set-face-background-pixmap face [nothing]);; XEmacs
 154     ('error nil))
 155   (condition-case nil
 156       (set-face-background-pixmap face nil);; Emacs
 157     ('error nil)))
 158
 159 (defun gamegrid-make-mono-tty-face ()
 160   (let ((face (make-face 'gamegrid-mono-tty-face)))
 161     (condition-case nil
 162         (set-face-property face 'reverse t)
 163       ('error nil))
 164     face))
 165
 166 (defun gamegrid-make-color-tty-face (color)
 167   (let* ((hex (gamegrid-color color 1.0))
 168          (name (intern (format "gamegrid-color-tty-face-%s" hex)))
 169          (face (make-face name)))
 170     (gamegrid-setup-face face color)
 171     face))
 172
 173 (defun gamegrid-make-grid-x-face ()
 174   (let ((face (make-face 'gamegrid-x-border-face)))
 175     (gamegrid-set-font face)
 176     face))
 177
 178 (defun gamegrid-make-mono-x-face ()
 179   (let ((face (make-face 'gamegrid-mono-x-face))
 180         (color (face-foreground 'default)))
 181     (if (null color)
 182         (setq color
 183               (cdr-safe (assq 'foreground-color (frame-parameters)))))
 184     (gamegrid-setup-face face color)
 185     face))
 186
 187 (defun gamegrid-make-color-x-face (color)
 188   (let* ((hex (gamegrid-color color 1.0))
 189          (name (intern (format "gamegrid-color-x-face-%s" hex)))
 190          (face (make-face name)))
 191     (gamegrid-setup-face face (gamegrid-color color 1.0))
 192     face))
 193
 194 (defun gamegrid-make-face (data-spec-list color-spec-list)
 195   (let ((data (gamegrid-match-spec-list data-spec-list))
 196         (color (gamegrid-match-spec-list color-spec-list)))
 197     (case data
 198       ('color-x
 199        (gamegrid-make-color-x-face color))
 200       ('grid-x
 201        (unless gamegrid-grid-x-face
 202          (setq gamegrid-grid-x-face (gamegrid-make-grid-x-face)))
 203        gamegrid-grid-x-face)
 204       ('mono-x
 205        (unless gamegrid-mono-x-face
 206          (setq gamegrid-mono-x-face (gamegrid-make-mono-x-face)))
 207        gamegrid-mono-x-face)
 208       ('color-tty
 209        (gamegrid-make-color-tty-face color))
 210       ('mono-tty
 211        (unless gamegrid-mono-tty-face
 212          (setq gamegrid-mono-tty-face (gamegrid-make-mono-tty-face)))
 213        gamegrid-mono-tty-face))))
 214
 215 (defun gamegrid-colorize-glyph (color)
 216   (make-glyph
 217    (vector
 218     'xpm
 219     :data gamegrid-xpm
 220     :color-symbols (list (cons "col1" (gamegrid-color color 0.6))
 221                          (cons "col2" (gamegrid-color color 0.8))
 222                          (cons "col3" (gamegrid-color color 1.0))))))
 223
 224 (defun gamegrid-match-spec (spec)
 225   (let ((locale (car spec))
 226         (value (cadr spec)))
 227     (and (or (eq locale t)
 228              (and (listp locale)
 229                   (memq gamegrid-display-mode locale))
 230              (and (symbolp locale)
 231                   (eq gamegrid-display-mode locale)))
 232          value)))
 233
 234 (defun gamegrid-match-spec-list (spec-list)
 235   (and spec-list
 236        (or (gamegrid-match-spec (car spec-list))
 237            (gamegrid-match-spec-list (cdr spec-list)))))
 238
 239 (defun gamegrid-make-glyph (data-spec-list color-spec-list)
 240   (let ((data (gamegrid-match-spec-list data-spec-list))
 241         (color (gamegrid-match-spec-list color-spec-list)))
 242     (cond ((gamegrid-characterp data)
 243            (vector data))
 244           ((eq data 'colorize)
 245            (gamegrid-colorize-glyph color))
 246           ((vectorp data)
 247            (make-glyph data)))))
 248
 249 (defun gamegrid-color-display-p ()
 250   (if (fboundp 'device-class)
 251       (eq (device-class (selected-device)) 'color)
 252     (eq (cdr-safe (assq 'display-type (frame-parameters))) 'color)))
 253
 254 (defun gamegrid-display-type ()
 255   (let ((window-system-p
 256          (or (and (fboundp 'console-on-window-system-p)
 257                   (console-on-window-system-p))
 258              window-system)))
 259   (cond ((and gamegrid-use-glyphs
 260                 window-system-p
 261               (featurep 'xpm))
 262          'glyph)
 263         ((and gamegrid-use-color
 264                 window-system-p
 265               (gamegrid-color-display-p))
 266          'color-x)
 267           (window-system-p
 268          'mono-x)
 269         ((and gamegrid-use-color
 270               (gamegrid-color-display-p))
 271          'color-tty)
 272         ((fboundp 'set-face-property)
 273          'mono-tty)
 274         (t
 275            'emacs-tty))))
 276
 277 (defun gamegrid-set-display-table ()
 278   (if (fboundp 'specifierp)
 279       (add-spec-to-specifier current-display-table
 280                              gamegrid-display-table
 281                              (current-buffer)
 282                              nil
 283                              'remove-locale)
 284     (setq buffer-display-table gamegrid-display-table)))
 285
 286 (defun gamegrid-hide-cursor ()
 287   (if (fboundp 'specifierp)
 288       (set-specifier text-cursor-visible-p nil (current-buffer))))
 289
 290 (defun gamegrid-setup-default-font ()
 291   (cond ((eq gamegrid-display-mode 'glyph)
 292          (let* ((font-spec (face-property 'default 'font))
 293                 (name (font-name font-spec))
 294                 (max-height nil))
 295            (loop for c from 0 to 255 do
 296              (let ((glyph (aref gamegrid-display-table c)))
 297                (cond ((glyphp glyph)
 298                       (let ((height (glyph-height glyph)))
 299                         (if (or (null max-height)
 300                                 (< max-height height))
 301                             (setq max-height height)))))))
 302            (if max-height
 303                (while (and (> (font-height font-spec) max-height)
 304                            (setq name (x-find-smaller-font name)))
 305                  (add-spec-to-specifier font-spec name (current-buffer))))))))
 306
 307 (defun gamegrid-initialize-display ()
 308   (setq gamegrid-display-mode (gamegrid-display-type))
 309   (setq gamegrid-display-table (make-display-table))
 310   (setq gamegrid-face-table (make-vector 256 nil))
 311   (loop for c from 0 to 255 do
 312     (let* ((spec (aref gamegrid-display-options c))
 313            (glyph (gamegrid-make-glyph (car spec) (caddr spec)))
 314            (face (gamegrid-make-face (cadr spec) (caddr spec))))
 315       (aset gamegrid-face-table c face)
 316       (aset gamegrid-display-table c glyph)))
 317   (gamegrid-setup-default-font)
 318   (gamegrid-set-display-table)
 319   (gamegrid-hide-cursor))
 320
 321
 322 (defun gamegrid-set-face (c)
 323   (unless (eq gamegrid-display-mode 'glyph)
 324     (put-text-property (1- (point))
 325                        (point)
 326                        'face
 327                        (aref gamegrid-face-table c))))
 328
 329 (defun gamegrid-cell-offset (x y)
 330   (+ gamegrid-buffer-start
 331      (* (1+ gamegrid-buffer-width) y)
 332      x))
 333
 334 ;; ;;;;;;;;;;;;;;;; grid functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 335
 336 (defun gamegrid-get-cell (x y)
 337   (char-after (gamegrid-cell-offset x y)))
 338
 339 (defun gamegrid-set-cell (x y c)
 340   (save-excursion
 341     (let ((buffer-read-only nil))
 342       (goto-char (gamegrid-cell-offset x y))
 343       (delete-char 1)
 344       (insert-char c 1)
 345       (gamegrid-set-face c))))
 346
 347 (defun gamegrid-init-buffer (width height blank)
 348   (setq gamegrid-buffer-width width
 349         gamegrid-buffer-height height)
 350   (let ((line (concat
 351                (make-string width blank)
 352                "\n"))
 353         (buffer-read-only nil))
 354     (erase-buffer)
 355     (setq gamegrid-buffer-start (point))
 356     (dotimes (i height)
 357       (insert-string line))
 358     (goto-char (point-min))))
 359
 360 (defun gamegrid-init (options)
 361   (setq buffer-read-only t
 362         truncate-lines t
 363         gamegrid-display-options options)
 364   (buffer-disable-undo (current-buffer))
 365   (gamegrid-initialize-display))
 366
 367 ;; ;;;;;;;;;;;;;;;; timer functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 368
 369 (defun gamegrid-start-timer (period func)
 370   (setq gamegrid-timer
 371         (if (featurep 'itimer)
 372             (start-itimer "Gamegrid"
 373                           func
 374                           period
 375                           period
 376                           nil
 377                           t
 378                           (current-buffer))
 379           (run-with-timer period
 380                           period
 381                           func
 382                           (current-buffer)))))
 383
 384 (defun gamegrid-set-timer (delay)
 385   (if gamegrid-timer
 386       (if (featurep 'itimer)
 387           (set-itimer-restart gamegrid-timer delay)
 388         (timer-set-time gamegrid-timer
 389                         (list (aref gamegrid-timer 1)
 390                               (aref gamegrid-timer 2)
 391                               (aref gamegrid-timer 3))
 392                         delay))))
 393
 394 (defun gamegrid-kill-timer ()
 395   (if gamegrid-timer
 396       (if (featurep 'itimer)
 397           (delete-itimer gamegrid-timer)
 398         (timer-set-time gamegrid-timer '(0 0 0) nil)))
 399   (setq gamegrid-timer nil))
 400
 401 ;; ;;;;;;;;;;;;;;; high score functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 402
 403 (defun gamegrid-add-score (file score)
 404   "Add the current score to the high score file."
 405   (save-excursion
 406   (find-file-other-window file)
 407   (setq buffer-read-only nil)
 408   (goto-char (point-max))
 409   (insert (format "%05d\t%s\t%s <%s>\n"
 410                   score
 411                   (current-time-string)
 412                   (user-full-name)
 413                   (cond ((fboundp 'user-mail-address)
 414                          (user-mail-address))
 415                         ((boundp 'user-mail-address)
 416                          user-mail-address)
 417                         (t ""))))
 418   (sort-numeric-fields 1 (point-min) (point-max))
 419     (reverse-region (point-min) (point-max))
 420   (goto-line (1+ gamegrid-score-file-length))
 421   (delete-region (point) (point-max))
 422   (setq buffer-read-only t)
 423     (save-buffer)))
 424
 425 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 426
 427 (provide 'gamegrid)