cgit.sxemacs.org Git - packages/blob - xemacs-packages/games/gamegrid.el

   1 ;;; gamegrid.el -- Library for implementing grid-based games on Emacs.
   2
   3 ;; Copyright (C) 1998 Free Software Foundation, Inc.
   4
   5 ;; Author: Glynn Clements <glynn@gclements.plus.com>
   6 ;; Version: 1.03
   7 ;; Created: 1997-08-13
   8 ;; Keywords: games
   9
  10 ;; This file is part of XEmacs.
  11
  12 ;; XEmacs is free software; you can redistribute it and/or modify it
  13 ;; under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; XEmacs is distributed in the hope that it will be useful, but
  18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  24 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  25 ;; 02111-1307, USA.
  26
  27 ;;; Synched up with: Not synched.
  28
  29 ;;; Commentary:
  30
  31 ;; Modified: 1998-01-27, added gamegrid-event-x/y
  32 ;; Modified: 1998-05-28, enclose body of gamegrid-add-score in save-excursion
  33 ;; Modified: 1998-06-23, copyright assigned to FSF
  34 ;; Modified: 2003-06-14, update email address, remove URL
  35
  36 ;; Tested with XEmacs 20.3/4/5 and Emacs 19.34
  37
  38 (eval-when-compile
  39   (require 'cl))
  40
  41 (defun-when-void put-display-table (range value display-table)
  42   "Set the value for char RANGE to VALUE in DISPLAY-TABLE.  "
  43   (if (sequencep display-table)
  44       (aset display-table range value)
  45     (put-char-table range value display-table)))
  46
  47 (defun-when-void get-display-table (character display-table)
  48   "Find value for CHARACTER in DISPLAY-TABLE.  "
  49   (if (sequencep display-table)
  50       (aref display-table character)
  51     (get-char-table character display-table)))
  52
  53 ;; ;;;;;;;;;;;;; buffer-local variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  54
  55 (defvar gamegrid-use-glyphs t
  56   "Non-nil means use glyphs when available")
  57
  58 (defvar gamegrid-use-color t
  59   "Non-nil means use color when available")
  60
  61 (defvar gamegrid-font "-*-courier-medium-r-*-*-*-140-100-75-*-*-iso8859-*"
  62   "Name of the font used in X mode")
  63
  64 (defvar gamegrid-display-options nil)
  65
  66 (defvar gamegrid-buffer-width 0)
  67 (defvar gamegrid-buffer-height 0)
  68 (defvar gamegrid-blank 0)
  69
  70 (defvar gamegrid-timer nil)
  71
  72 (defvar gamegrid-display-mode nil)
  73
  74 (defvar gamegrid-display-table)
  75
  76 (defvar gamegrid-face-table nil)
  77
  78 (defvar gamegrid-buffer-start 1)
  79
  80 (defvar gamegrid-score-file-length 50
  81   "Number of high scores to keep")
  82
  83 (make-variable-buffer-local 'gamegrid-use-glyphs)
  84 (make-variable-buffer-local 'gamegrid-use-color)
  85 (make-variable-buffer-local 'gamegrid-font)
  86 (make-variable-buffer-local 'gamegrid-display-options)
  87 (make-variable-buffer-local 'gamegrid-buffer-width)
  88 (make-variable-buffer-local 'gamegrid-buffer-height)
  89 (make-variable-buffer-local 'gamegrid-blank)
  90 (make-variable-buffer-local 'gamegrid-timer)
  91 (make-variable-buffer-local 'gamegrid-display-mode)
  92 (make-variable-buffer-local 'gamegrid-display-table)
  93 (make-variable-buffer-local 'gamegrid-face-table)
  94 (make-variable-buffer-local 'gamegrid-buffer-start)
  95 (make-variable-buffer-local 'gamegrid-score-file-length)
  96
  97 ;; ;;;;;;;;;;;;; global variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  98
  99 (defvar gamegrid-grid-x-face nil)
 100 (defvar gamegrid-mono-x-face nil)
 101 (defvar gamegrid-mono-tty-face nil)
 102
 103 ;; ;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 104
 105 (defconst gamegrid-glyph-height 16)
 106
 107 (defconst gamegrid-xpm "\
 108 /* XPM */
 109 static char *noname[] = {
 110 /* width height ncolors chars_per_pixel */
 111 \"16 16 3 1\",
 112 /* colors */
 113 \"+ s col1\",
 114 \". s col2\",
 115 \"- s col3\",
 116 /* pixels */
 117 \"---------------+\",
 118 \"--------------++\",
 119 \"--............++\",
 120 \"--............++\",
 121 \"--............++\",
 122 \"--............++\",
 123 \"--............++\",
 124 \"--............++\",
 125 \"--............++\",
 126 \"--............++\",
 127 \"--............++\",
 128 \"--............++\",
 129 \"--............++\",
 130 \"--............++\",
 131 \"-+++++++++++++++\",
 132 \"++++++++++++++++\"
 133 };
 134 "
 135   "XPM format image used for each square")
 136
 137 ;; ;;;;;;;;;;;;;;;; miscellaneous functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 138
 139 (defsubst gamegrid-characterp (arg)
 140   (if (fboundp 'characterp)
 141       (characterp arg)
 142     (integerp arg)))
 143
 144 (defsubst gamegrid-event-x (event)
 145   (if (fboundp 'event-x)
 146       (event-x event)
 147     (car (posn-col-row (event-end event)))))
 148
 149 (defsubst gamegrid-event-y (event)
 150   (if (fboundp 'event-y)
 151       (event-y event)
 152     (cdr (posn-col-row (event-end event)))))
 153
 154 ;; ;;;;;;;;;;;;; display functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 155
 156 (defun gamegrid-color (color shade)
 157   (let* ((v (floor (* shade 255)))
 158          (r (* v (aref color 0)))
 159          (g (* v (aref color 1)))
 160          (b (* v (aref color 2))))
 161     (format "#%02x%02x%02x" r g b)))
 162
 163 (defun gamegrid-set-font (face)
 164   (if gamegrid-font
 165       (condition-case nil
 166           (set-face-font face gamegrid-font)
 167         ('error nil))))
 168
 169 (defun gamegrid-setup-face (face color)
 170   (set-face-foreground face color)
 171   (set-face-background face color)
 172   (gamegrid-set-font face)
 173   (condition-case nil
 174       (set-face-background-pixmap face [nothing]);; XEmacs
 175     ('error nil))
 176   (condition-case nil
 177       (set-face-background-pixmap face nil);; Emacs
 178     ('error nil)))
 179
 180 (defun gamegrid-make-mono-tty-face ()
 181   (let ((face (make-face 'gamegrid-mono-tty-face)))
 182     (condition-case nil
 183         (set-face-property face 'reverse t)
 184       ('error nil))
 185     face))
 186
 187 (defun gamegrid-make-color-tty-face (color)
 188   (let* ((hex (gamegrid-color color 1.0))
 189          (name (intern (format "gamegrid-color-tty-face-%s" hex)))
 190          (face (make-face name)))
 191     (gamegrid-setup-face face color)
 192     face))
 193
 194 (defun gamegrid-make-grid-x-face ()
 195   (let ((face (make-face 'gamegrid-x-border-face)))
 196     (gamegrid-set-font face)
 197     face))
 198
 199 (defun gamegrid-make-mono-x-face ()
 200   (let ((face (make-face 'gamegrid-mono-x-face))
 201         (color (face-foreground 'default)))
 202     (if (null color)
 203         (setq color
 204               (cdr-safe (assq 'foreground-color (frame-parameters)))))
 205     (gamegrid-setup-face face color)
 206     face))
 207
 208 (defun gamegrid-make-color-x-face (color)
 209   (let* ((hex (gamegrid-color color 1.0))
 210          (name (intern (format "gamegrid-color-x-face-%s" hex)))
 211          (face (make-face name)))
 212     (gamegrid-setup-face face (gamegrid-color color 1.0))
 213     face))
 214
 215 (defun gamegrid-make-face (data-spec-list color-spec-list)
 216   (let ((data (gamegrid-match-spec-list data-spec-list))
 217         (color (gamegrid-match-spec-list color-spec-list)))
 218     (case data
 219       ('color-x
 220        (gamegrid-make-color-x-face color))
 221       ('grid-x
 222        (unless gamegrid-grid-x-face
 223          (setq gamegrid-grid-x-face (gamegrid-make-grid-x-face)))
 224        gamegrid-grid-x-face)
 225       ('mono-x
 226        (unless gamegrid-mono-x-face
 227          (setq gamegrid-mono-x-face (gamegrid-make-mono-x-face)))
 228        gamegrid-mono-x-face)
 229       ('color-tty
 230        (gamegrid-make-color-tty-face color))
 231       ('mono-tty
 232        (unless gamegrid-mono-tty-face
 233          (setq gamegrid-mono-tty-face (gamegrid-make-mono-tty-face)))
 234        gamegrid-mono-tty-face))))
 235
 236 (defun gamegrid-colorize-glyph (color)
 237   (make-glyph
 238    (vector
 239     'xpm
 240     :data gamegrid-xpm
 241     :color-symbols (list (cons "col1" (gamegrid-color color 0.6))
 242                          (cons "col2" (gamegrid-color color 0.8))
 243                          (cons "col3" (gamegrid-color color 1.0))))))
 244
 245 (defun gamegrid-match-spec (spec)
 246   (let ((locale (car spec))
 247         (value (cadr spec)))
 248     (and (or (eq locale t)
 249              (and (listp locale)
 250                   (memq gamegrid-display-mode locale))
 251              (and (symbolp locale)
 252                   (eq gamegrid-display-mode locale)))
 253          value)))
 254
 255 (defun gamegrid-match-spec-list (spec-list)
 256   (and spec-list
 257        (or (gamegrid-match-spec (car spec-list))
 258            (gamegrid-match-spec-list (cdr spec-list)))))
 259
 260 (defun gamegrid-make-glyph (data-spec-list color-spec-list)
 261   (let ((data (gamegrid-match-spec-list data-spec-list))
 262         (color (gamegrid-match-spec-list color-spec-list)))
 263     (cond ((gamegrid-characterp data)
 264            (vector data))
 265           ((eq data 'colorize)
 266            (gamegrid-colorize-glyph color))
 267           ((vectorp data)
 268            (make-glyph data)))))
 269
 270 (defun gamegrid-color-display-p ()
 271   (if (fboundp 'device-class)
 272       (eq (device-class (selected-device)) 'color)
 273     (eq (cdr-safe (assq 'display-type (frame-parameters))) 'color)))
 274
 275 (defun gamegrid-display-type ()
 276   (let ((window-system-p
 277          (or (and (fboundp 'console-on-window-system-p)
 278                   (console-on-window-system-p))
 279              window-system)))
 280   (cond ((and gamegrid-use-glyphs
 281                 window-system-p
 282               (featurep 'xpm))
 283          'glyph)
 284         ((and gamegrid-use-color
 285                 window-system-p
 286               (gamegrid-color-display-p))
 287          'color-x)
 288           (window-system-p
 289          'mono-x)
 290         ((and gamegrid-use-color
 291               (gamegrid-color-display-p))
 292          'color-tty)
 293         ((fboundp 'set-face-property)
 294          'mono-tty)
 295         (t
 296            'emacs-tty))))
 297
 298 (defun gamegrid-set-display-table ()
 299   (if (fboundp 'specifierp)
 300       (add-spec-to-specifier current-display-table
 301                              gamegrid-display-table
 302                              (current-buffer)
 303                              nil
 304                              'remove-locale)
 305     (setq buffer-display-table gamegrid-display-table)))
 306
 307 (defun gamegrid-hide-cursor ()
 308   (if (fboundp 'specifierp)
 309       (set-specifier text-cursor-visible-p nil (current-buffer))))
 310
 311 (defun gamegrid-setup-default-font ()
 312   (cond ((eq gamegrid-display-mode 'glyph)
 313          (let* ((font-spec (face-property 'default 'font))
 314                 (name (font-name font-spec))
 315                 (max-height nil))
 316            (loop for c from 0 to 255 do
 317              (let ((glyph (get-display-table c gamegrid-display-table)))
 318                (cond ((glyphp glyph)
 319                       (let ((height (glyph-height glyph)))
 320                         (if (or (null max-height)
 321                                 (< max-height height))
 322                             (setq max-height height)))))))
 323            (if max-height
 324                (while (and (> (font-height font-spec) max-height)
 325                            (setq name
 326                                  (cond
 327                                   ((eq window-system 'x)
 328                                    (x-find-smaller-font name))
 329                                   ((eq window-system 'mswindows)
 330                                    (mswindows-find-smaller-font name)))))
 331                  (add-spec-to-specifier font-spec name (current-buffer))))))))
 332
 333 (defun gamegrid-initialize-display ()
 334   (setq gamegrid-display-mode (gamegrid-display-type))
 335   (setq gamegrid-display-table (make-display-table))
 336   (setq gamegrid-face-table (make-vector 256 nil))
 337   (loop for c from 0 to 255 do
 338     (let* ((spec (aref gamegrid-display-options c))
 339            (glyph (gamegrid-make-glyph (car spec) (caddr spec)))
 340            (face (gamegrid-make-face (cadr spec) (caddr spec))))
 341       (aset gamegrid-face-table c face)
 342       (put-display-table c glyph gamegrid-display-table)))
 343   (gamegrid-setup-default-font)
 344   (gamegrid-set-display-table)
 345   (gamegrid-hide-cursor))
 346
 347
 348 (defun gamegrid-set-face (c)
 349   (unless (eq gamegrid-display-mode 'glyph)
 350     (put-text-property (1- (point))
 351                        (point)
 352                        'face
 353                        (aref gamegrid-face-table c))))
 354
 355 (defun gamegrid-cell-offset (x y)
 356   (+ gamegrid-buffer-start
 357      (* (1+ gamegrid-buffer-width) y)
 358      x))
 359
 360 ;; ;;;;;;;;;;;;;;;; grid functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 361
 362 (defun gamegrid-get-cell (x y)
 363   (char-after (gamegrid-cell-offset x y)))
 364
 365 (defun gamegrid-set-cell (x y c)
 366   (save-excursion
 367     (let ((buffer-read-only nil))
 368       (goto-char (gamegrid-cell-offset x y))
 369       (delete-char 1)
 370       (insert-char c 1)
 371       (gamegrid-set-face c))))
 372
 373 (defun gamegrid-init-buffer (width height blank)
 374   (setq gamegrid-buffer-width width
 375         gamegrid-buffer-height height)
 376   (let ((line (concat
 377                (make-string width blank)
 378                "\n"))
 379         (buffer-read-only nil))
 380     (erase-buffer)
 381     (setq gamegrid-buffer-start (point))
 382     (dotimes (i height)
 383       (insert-string line))
 384     (goto-char (point-min))))
 385
 386 (defun gamegrid-init (options)
 387   (setq buffer-read-only t
 388         truncate-lines t
 389         gamegrid-display-options options)
 390   (buffer-disable-undo (current-buffer))
 391   (gamegrid-initialize-display))
 392
 393 ;; ;;;;;;;;;;;;;;;; timer functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 394
 395 (defun gamegrid-start-timer (period func)
 396   (setq gamegrid-timer
 397         (if (featurep 'itimer)
 398             (start-itimer "Gamegrid"
 399                           func
 400                           period
 401                           period
 402                           nil
 403                           t
 404                           (current-buffer))
 405           (run-with-timer period
 406                           period
 407                           func
 408                           (current-buffer)))))
 409
 410 (defun gamegrid-set-timer (delay)
 411   (if gamegrid-timer
 412       (if (featurep 'itimer)
 413           (set-itimer-restart gamegrid-timer delay)
 414         (timer-set-time gamegrid-timer
 415                         (list (aref gamegrid-timer 1)
 416                               (aref gamegrid-timer 2)
 417                               (aref gamegrid-timer 3))
 418                         delay))))
 419
 420 (defun gamegrid-kill-timer ()
 421   (if gamegrid-timer
 422       (if (featurep 'itimer)
 423           (delete-itimer gamegrid-timer)
 424         (timer-set-time gamegrid-timer '(0 0 0) nil)))
 425   (setq gamegrid-timer nil))
 426
 427 ;; ;;;;;;;;;;;;;;; high score functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 428
 429 (defun gamegrid-add-score (file score)
 430   "Adds the current score to the high score file"
 431   (save-excursion
 432   (find-file-other-window file)
 433   (setq buffer-read-only nil)
 434   (goto-char (point-max))
 435   (insert (format "%05d\t%s\t%s <%s>\n"
 436                   score
 437                   (current-time-string)
 438                   (user-full-name)
 439                   (cond ((fboundp 'user-mail-address)
 440                          (user-mail-address))
 441                         ((boundp 'user-mail-address)
 442                          user-mail-address)
 443                         (t ""))))
 444   ;; Prefixing numbers 0's will make `sort-numeric-fields' sort with
 445   ;; sort-numeric-base of 8.
 446   ;; One workaround is to use `sort-regexp-fields-numerically',
 447   ;; on the number, excluding leading 0's.
 448   (sort-regexp-fields-numerically
 449    nil
 450    "^[0]*\\([1-9][0-9]+\\)\\>.+$" "\\1" (point-min) (point-max))
 451   (reverse-region (point-min) (point-max))
 452   (goto-line (1+ gamegrid-score-file-length))
 453   (delete-region (point) (point-max))
 454   (setq buffer-read-only t)
 455     (save-buffer)))
 456
 457 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 458
 459 (provide 'gamegrid)