code.delx.au - gnu-emacs/blob - 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 (symbol-value 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              (and (fboundp 'display-color-p)
 261                   (display-color-p))
 262              window-system)))
 263   (cond ((and gamegrid-use-glyphs
 264                 window-system-p
 265               (featurep 'xpm))
 266          'glyph)
 267         ((and gamegrid-use-color
 268                 window-system-p
 269               (gamegrid-color-display-p))
 270          'color-x)
 271           (window-system-p
 272          'mono-x)
 273         ((and gamegrid-use-color
 274               (gamegrid-color-display-p))
 275          'color-tty)
 276         ((fboundp 'set-face-property)
 277          'mono-tty)
 278         (t
 279            'emacs-tty))))
 280
 281 (defun gamegrid-set-display-table ()
 282   (if (fboundp 'specifierp)
 283       (add-spec-to-specifier current-display-table
 284                              gamegrid-display-table
 285                              (current-buffer)
 286                              nil
 287                              'remove-locale)
 288     (setq buffer-display-table gamegrid-display-table)))
 289
 290 (defun gamegrid-hide-cursor ()
 291   (if (fboundp 'specifierp)
 292       (set-specifier text-cursor-visible-p nil (current-buffer))))
 293
 294 (defun gamegrid-setup-default-font ()
 295   (cond ((eq gamegrid-display-mode 'glyph)
 296          (let* ((font-spec (face-property 'default 'font))
 297                 (name (font-name font-spec))
 298                 (max-height nil))
 299            (loop for c from 0 to 255 do
 300              (let ((glyph (aref gamegrid-display-table c)))
 301                (cond ((glyphp glyph)
 302                       (let ((height (glyph-height glyph)))
 303                         (if (or (null max-height)
 304                                 (< max-height height))
 305                             (setq max-height height)))))))
 306            (if max-height
 307                (while (and (> (font-height font-spec) max-height)
 308                            (setq name (x-find-smaller-font name)))
 309                  (add-spec-to-specifier font-spec name (current-buffer))))))))
 310
 311 (defun gamegrid-initialize-display ()
 312   (setq gamegrid-display-mode (gamegrid-display-type))
 313   (setq gamegrid-display-table (make-display-table))
 314   (setq gamegrid-face-table (make-vector 256 nil))
 315   (loop for c from 0 to 255 do
 316     (let* ((spec (aref gamegrid-display-options c))
 317            (glyph (gamegrid-make-glyph (car spec) (caddr spec)))
 318            (face (gamegrid-make-face (cadr spec) (caddr spec))))
 319       (aset gamegrid-face-table c face)
 320       (aset gamegrid-display-table c glyph)))
 321   (gamegrid-setup-default-font)
 322   (gamegrid-set-display-table)
 323   (gamegrid-hide-cursor))
 324
 325
 326 (defun gamegrid-set-face (c)
 327   (unless (eq gamegrid-display-mode 'glyph)
 328     (put-text-property (1- (point))
 329                        (point)
 330                        'face
 331                        (aref gamegrid-face-table c))))
 332
 333 (defun gamegrid-cell-offset (x y)
 334   (+ gamegrid-buffer-start
 335      (* (1+ gamegrid-buffer-width) y)
 336      x))
 337
 338 ;; ;;;;;;;;;;;;;;;; grid functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 339
 340 (defun gamegrid-get-cell (x y)
 341   (char-after (gamegrid-cell-offset x y)))
 342
 343 (defun gamegrid-set-cell (x y c)
 344   (save-excursion
 345     (let ((buffer-read-only nil))
 346       (goto-char (gamegrid-cell-offset x y))
 347       (delete-char 1)
 348       (insert-char c 1)
 349       (gamegrid-set-face c))))
 350
 351 (defun gamegrid-init-buffer (width height blank)
 352   (setq gamegrid-buffer-width width
 353         gamegrid-buffer-height height)
 354   (let ((line (concat
 355                (make-string width blank)
 356                "\n"))
 357         (buffer-read-only nil))
 358     (erase-buffer)
 359     (setq gamegrid-buffer-start (point))
 360     (dotimes (i height)
 361       (insert line))
 362     (goto-char (point-min))))
 363
 364 (defun gamegrid-init (options)
 365   (setq buffer-read-only t
 366         truncate-lines t
 367         gamegrid-display-options options)
 368   (buffer-disable-undo (current-buffer))
 369   (gamegrid-initialize-display))
 370
 371 ;; ;;;;;;;;;;;;;;;; timer functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 372
 373 (defun gamegrid-start-timer (period func)
 374   (setq gamegrid-timer
 375         (if (featurep 'itimer)
 376             (start-itimer "Gamegrid"
 377                           func
 378                           period
 379                           period
 380                           nil
 381                           t
 382                           (current-buffer))
 383           (run-with-timer period
 384                           period
 385                           func
 386                           (current-buffer)))))
 387
 388 (defun gamegrid-set-timer (delay)
 389   (if gamegrid-timer
 390       (if (featurep 'itimer)
 391           (set-itimer-restart gamegrid-timer delay)
 392         (timer-set-time gamegrid-timer
 393                         (list (aref gamegrid-timer 1)
 394                               (aref gamegrid-timer 2)
 395                               (aref gamegrid-timer 3))
 396                         delay))))
 397
 398 (defun gamegrid-kill-timer ()
 399   (if gamegrid-timer
 400       (if (featurep 'itimer)
 401           (delete-itimer gamegrid-timer)
 402         (timer-set-time gamegrid-timer '(0 0 0) nil)))
 403   (setq gamegrid-timer nil))
 404
 405 ;; ;;;;;;;;;;;;;;; high score functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 406
 407 (defun gamegrid-add-score (file score)
 408   "Add the current score to the high score file."
 409   (save-excursion
 410   (find-file-other-window file)
 411   (setq buffer-read-only nil)
 412   (goto-char (point-max))
 413   (insert (format "%05d\t%s\t%s <%s>\n"
 414                   score
 415                   (current-time-string)
 416                   (user-full-name)
 417                   (cond ((fboundp 'user-mail-address)
 418                          (user-mail-address))
 419                         ((boundp 'user-mail-address)
 420                          user-mail-address)
 421                         (t ""))))
 422   (sort-numeric-fields 1 (point-min) (point-max))
 423     (reverse-region (point-min) (point-max))
 424   (goto-line (1+ gamegrid-score-file-length))
 425   (delete-region (point) (point-max))
 426   (setq buffer-read-only t)
 427     (save-buffer)))
 428
 429 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 430
 431 (provide 'gamegrid)
 432
 433 ;;; gamegrid.el ends here