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 (defvar gamegrid-user-score-file-directory "~/.emacs.d/games"
  65   "A directory for game scores which can't be shared.
  66 If Emacs was built without support for shared game scores, then this
  67 directory will be used.")
  68
  69 (make-variable-buffer-local 'gamegrid-use-glyphs)
  70 (make-variable-buffer-local 'gamegrid-use-color)
  71 (make-variable-buffer-local 'gamegrid-font)
  72 (make-variable-buffer-local 'gamegrid-display-options)
  73 (make-variable-buffer-local 'gamegrid-buffer-width)
  74 (make-variable-buffer-local 'gamegrid-buffer-height)
  75 (make-variable-buffer-local 'gamegrid-blank)
  76 (make-variable-buffer-local 'gamegrid-timer)
  77 (make-variable-buffer-local 'gamegrid-display-mode)
  78 (make-variable-buffer-local 'gamegrid-display-table)
  79 (make-variable-buffer-local 'gamegrid-face-table)
  80 (make-variable-buffer-local 'gamegrid-buffer-start)
  81 (make-variable-buffer-local 'gamegrid-score-file-length)
  82
  83 ;; ;;;;;;;;;;;;; global variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  84
  85 (defvar gamegrid-grid-x-face nil)
  86 (defvar gamegrid-mono-x-face nil)
  87 (defvar gamegrid-mono-tty-face nil)
  88
  89 ;; ;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  90
  91 (defconst gamegrid-glyph-height 16)
  92
  93 (defconst gamegrid-xpm "\
  94 /* XPM */
  95 static char *noname[] = {
  96 /* width height ncolors chars_per_pixel */
  97 \"16 16 3 1\",
  98 /* colors */
  99 \"+ s col1\",
 100 \". s col2\",
 101 \"- s col3\",
 102 /* pixels */
 103 \"---------------+\",
 104 \"--------------++\",
 105 \"--............++\",
 106 \"--............++\",
 107 \"--............++\",
 108 \"--............++\",
 109 \"--............++\",
 110 \"--............++\",
 111 \"--............++\",
 112 \"--............++\",
 113 \"--............++\",
 114 \"--............++\",
 115 \"--............++\",
 116 \"--............++\",
 117 \"-+++++++++++++++\",
 118 \"++++++++++++++++\"
 119 };
 120 "
 121   "XPM format image used for each square")
 122
 123 ;; ;;;;;;;;;;;;;;;; miscellaneous functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 124
 125 (defsubst gamegrid-characterp (arg)
 126   (if (fboundp 'characterp)
 127       (characterp arg)
 128     (integerp arg)))
 129
 130 (defsubst gamegrid-event-x (event)
 131   (if (fboundp 'event-x)
 132       (event-x event)
 133     (car (posn-col-row (event-end event)))))
 134
 135 (defsubst gamegrid-event-y (event)
 136   (if (fboundp 'event-y)
 137       (event-y event)
 138     (cdr (posn-col-row (event-end event)))))
 139
 140 ;; ;;;;;;;;;;;;; display functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 141
 142 (defun gamegrid-color (color shade)
 143   (let* ((v (floor (* shade 255)))
 144          (r (* v (aref color 0)))
 145          (g (* v (aref color 1)))
 146          (b (* v (aref color 2))))
 147     (format "#%02x%02x%02x" r g b)))
 148
 149 (defun gamegrid-set-font (face)
 150   (if gamegrid-font
 151       (condition-case nil
 152           (set-face-font face gamegrid-font)
 153         (error nil))))
 154
 155 (defun gamegrid-setup-face (face color)
 156   (set-face-foreground face color)
 157   (set-face-background face color)
 158   (gamegrid-set-font face)
 159   (condition-case nil
 160       (set-face-background-pixmap face [nothing]);; XEmacs
 161     (error nil))
 162   (condition-case nil
 163       (set-face-background-pixmap face nil);; Emacs
 164     (error nil)))
 165
 166 (defun gamegrid-make-mono-tty-face ()
 167   (let ((face (make-face 'gamegrid-mono-tty-face)))
 168     (condition-case nil
 169         (set-face-property face 'reverse t)
 170       (error nil))
 171     face))
 172
 173 (defun gamegrid-make-color-tty-face (color)
 174   (let* ((color-str (symbol-value color))
 175          (name (intern (format "gamegrid-color-tty-face-%s" color-str)))
 176          (face (make-face name)))
 177     (gamegrid-setup-face face color-str)
 178     face))
 179
 180 (defun gamegrid-make-grid-x-face ()
 181   (let ((face (make-face 'gamegrid-x-border-face)))
 182     (gamegrid-set-font face)
 183     face))
 184
 185 (defun gamegrid-make-mono-x-face ()
 186   (let ((face (make-face 'gamegrid-mono-x-face))
 187         (color (face-foreground 'default)))
 188     (if (null color)
 189         (setq color
 190               (cdr-safe (assq 'foreground-color (frame-parameters)))))
 191     (gamegrid-setup-face face color)
 192     face))
 193
 194 (defun gamegrid-make-color-x-face (color)
 195   (let* ((hex (gamegrid-color color 1.0))
 196          (name (intern (format "gamegrid-color-x-face-%s" hex)))
 197          (face (make-face name)))
 198     (gamegrid-setup-face face hex)
 199     face))
 200
 201 (defun gamegrid-make-face (data-spec-list color-spec-list)
 202   (let ((data (gamegrid-match-spec-list data-spec-list))
 203         (color (gamegrid-match-spec-list color-spec-list)))
 204     (case data
 205       ('color-x
 206        (gamegrid-make-color-x-face color))
 207       ('grid-x
 208        (unless gamegrid-grid-x-face
 209          (setq gamegrid-grid-x-face (gamegrid-make-grid-x-face)))
 210        gamegrid-grid-x-face)
 211       ('mono-x
 212        (unless gamegrid-mono-x-face
 213          (setq gamegrid-mono-x-face (gamegrid-make-mono-x-face)))
 214        gamegrid-mono-x-face)
 215       ('color-tty
 216        (gamegrid-make-color-tty-face color))
 217       ('mono-tty
 218        (unless gamegrid-mono-tty-face
 219          (setq gamegrid-mono-tty-face (gamegrid-make-mono-tty-face)))
 220        gamegrid-mono-tty-face))))
 221
 222 (defun gamegrid-colorize-glyph (color)
 223   (make-glyph
 224    (vector
 225     'xpm
 226     :data gamegrid-xpm
 227     :color-symbols (list (cons "col1" (gamegrid-color color 0.6))
 228                          (cons "col2" (gamegrid-color color 0.8))
 229                          (cons "col3" (gamegrid-color color 1.0))))))
 230
 231 (defun gamegrid-match-spec (spec)
 232   (let ((locale (car spec))
 233         (value (cadr spec)))
 234     (and (or (eq locale t)
 235              (and (listp locale)
 236                   (memq gamegrid-display-mode locale))
 237              (and (symbolp locale)
 238                   (eq gamegrid-display-mode locale)))
 239          value)))
 240
 241 (defun gamegrid-match-spec-list (spec-list)
 242   (and spec-list
 243        (or (gamegrid-match-spec (car spec-list))
 244            (gamegrid-match-spec-list (cdr spec-list)))))
 245
 246 (defun gamegrid-make-glyph (data-spec-list color-spec-list)
 247   (let ((data (gamegrid-match-spec-list data-spec-list))
 248         (color (gamegrid-match-spec-list color-spec-list)))
 249     (cond ((gamegrid-characterp data)
 250            (vector data))
 251           ((eq data 'colorize)
 252            (gamegrid-colorize-glyph color))
 253           ((vectorp data)
 254            (make-glyph data)))))
 255
 256 (defun gamegrid-color-display-p ()
 257   (if (fboundp 'device-class)
 258       (eq (device-class (selected-device)) 'color)
 259     (eq (cdr-safe (assq 'display-type (frame-parameters))) 'color)))
 260
 261 (defun gamegrid-display-type ()
 262   (let ((window-system-p
 263          (or (and (fboundp 'console-on-window-system-p)
 264                   (console-on-window-system-p))
 265              (and (fboundp 'display-color-p)
 266                   (display-color-p))
 267              window-system)))
 268   (cond ((and gamegrid-use-glyphs
 269                 window-system-p
 270               (featurep 'xpm))
 271          'glyph)
 272         ((and gamegrid-use-color
 273                 window-system-p
 274               (gamegrid-color-display-p))
 275          'color-x)
 276           (window-system-p
 277          'mono-x)
 278         ((and gamegrid-use-color
 279               (gamegrid-color-display-p))
 280          'color-tty)
 281         ((fboundp 'set-face-property)
 282          'mono-tty)
 283         (t
 284            'emacs-tty))))
 285
 286 (defun gamegrid-set-display-table ()
 287   (if (fboundp 'specifierp)
 288       (add-spec-to-specifier current-display-table
 289                              gamegrid-display-table
 290                              (current-buffer)
 291                              nil
 292                              'remove-locale)
 293     (setq buffer-display-table gamegrid-display-table)))
 294
 295 (defun gamegrid-hide-cursor ()
 296   (if (fboundp 'specifierp)
 297       (set-specifier text-cursor-visible-p nil (current-buffer))))
 298
 299 (defun gamegrid-setup-default-font ()
 300   (cond ((eq gamegrid-display-mode 'glyph)
 301          (let* ((font-spec (face-property 'default 'font))
 302                 (name (font-name font-spec))
 303                 (max-height nil))
 304            (loop for c from 0 to 255 do
 305              (let ((glyph (aref gamegrid-display-table c)))
 306                (cond ((glyphp glyph)
 307                       (let ((height (glyph-height glyph)))
 308                         (if (or (null max-height)
 309                                 (< max-height height))
 310                             (setq max-height height)))))))
 311            (if max-height
 312                (while (and (> (font-height font-spec) max-height)
 313                            (setq name (x-find-smaller-font name)))
 314                  (add-spec-to-specifier font-spec name (current-buffer))))))))
 315
 316 (defun gamegrid-initialize-display ()
 317   (setq gamegrid-display-mode (gamegrid-display-type))
 318   (setq gamegrid-display-table (make-display-table))
 319   (setq gamegrid-face-table (make-vector 256 nil))
 320   (loop for c from 0 to 255 do
 321     (let* ((spec (aref gamegrid-display-options c))
 322            (glyph (gamegrid-make-glyph (car spec) (caddr spec)))
 323            (face (gamegrid-make-face (cadr spec) (caddr spec))))
 324       (aset gamegrid-face-table c face)
 325       (aset gamegrid-display-table c glyph)))
 326   (gamegrid-setup-default-font)
 327   (gamegrid-set-display-table)
 328   (gamegrid-hide-cursor))
 329
 330
 331 (defun gamegrid-set-face (c)
 332   (unless (eq gamegrid-display-mode 'glyph)
 333     (put-text-property (1- (point))
 334                        (point)
 335                        'face
 336                        (aref gamegrid-face-table c))))
 337
 338 (defun gamegrid-cell-offset (x y)
 339   (+ gamegrid-buffer-start
 340      (* (1+ gamegrid-buffer-width) y)
 341      x))
 342
 343 ;; ;;;;;;;;;;;;;;;; grid functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 344
 345 (defun gamegrid-get-cell (x y)
 346   (char-after (gamegrid-cell-offset x y)))
 347
 348 (defun gamegrid-set-cell (x y c)
 349   (save-excursion
 350     (let ((buffer-read-only nil))
 351       (goto-char (gamegrid-cell-offset x y))
 352       (delete-char 1)
 353       (insert-char c 1)
 354       (gamegrid-set-face c))))
 355
 356 (defun gamegrid-init-buffer (width height blank)
 357   (setq gamegrid-buffer-width width
 358         gamegrid-buffer-height height)
 359   (let ((line (concat
 360                (make-string width blank)
 361                "\n"))
 362         (buffer-read-only nil))
 363     (erase-buffer)
 364     (setq gamegrid-buffer-start (point))
 365     (dotimes (i height)
 366       (insert line))
 367     (goto-char (point-min))))
 368
 369 (defun gamegrid-init (options)
 370   (setq buffer-read-only t
 371         truncate-lines t
 372         gamegrid-display-options options)
 373   (buffer-disable-undo (current-buffer))
 374   (gamegrid-initialize-display))
 375
 376 ;; ;;;;;;;;;;;;;;;; timer functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 377
 378 (defun gamegrid-start-timer (period func)
 379   (setq gamegrid-timer
 380         (if (featurep 'itimer)
 381             (start-itimer "Gamegrid"
 382                           func
 383                           period
 384                           period
 385                           nil
 386                           t
 387                           (current-buffer))
 388           (run-with-timer period
 389                           period
 390                           func
 391                           (current-buffer)))))
 392
 393 (defun gamegrid-set-timer (delay)
 394   (if gamegrid-timer
 395       (if (featurep 'itimer)
 396           (set-itimer-restart gamegrid-timer delay)
 397         (timer-set-time gamegrid-timer
 398                         (list (aref gamegrid-timer 1)
 399                               (aref gamegrid-timer 2)
 400                               (aref gamegrid-timer 3))
 401                         delay))))
 402
 403 (defun gamegrid-kill-timer ()
 404   (if gamegrid-timer
 405       (if (featurep 'itimer)
 406           (delete-itimer gamegrid-timer)
 407         (timer-set-time gamegrid-timer '(0 0 0) nil)))
 408   (setq gamegrid-timer nil))
 409
 410 ;; ;;;;;;;;;;;;;;; high score functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 411
 412 (defun gamegrid-add-score (file score)
 413   "Add the current score to the high score file."
 414   (case system-type
 415     ((ms-dos windows-nt)
 416      (gamegrid-add-score-insecure file score))
 417     (t
 418      (gamegrid-add-score-with-update-game-score file score))))
 419
 420 (defun gamegrid-add-score-with-update-game-score (file score)
 421   (let* ((result nil)
 422          (errbuf (generate-new-buffer " *update-game-score loss*"))
 423          (have-shared-game-dir
 424           (not (zerop (logand (file-modes
 425                                (expand-file-name "update-game-score"
 426                                                  exec-directory))
 427                               #o4000))))
 428          (target (if have-shared-game-dir
 429                      (expand-file-name file shared-game-score-directory)
 430                    (let ((f (expand-file-name
 431                              gamegrid-user-score-file-directory)))
 432                      (when (file-writable-p f)
 433                        (unless (eq (car-safe (file-attributes f))
 434                                    t)
 435                          (make-directory f))
 436                        (setq f (expand-file-name file f))
 437                        (unless (file-exists-p f)
 438                          (write-region "" nil f nil 'silent nil 'excl)))
 439                      f))))
 440     (let ((default-directory "/"))
 441       (apply
 442        'call-process
 443        (append
 444         (list
 445          (expand-file-name "update-game-score" exec-directory)
 446          nil errbuf nil
 447          "-m" (int-to-string gamegrid-score-file-length)
 448          "-d" (if have-shared-game-dir
 449                   (expand-file-name shared-game-score-directory)
 450                 (file-name-directory target))
 451          file
 452          (int-to-string score)
 453          (concat
 454           (user-full-name)
 455           " <"
 456           (cond ((fboundp 'user-mail-address)
 457                  (user-mail-address))
 458                 ((boundp 'user-mail-address)
 459                  user-mail-address)
 460                 (t ""))
 461           ">  "
 462           (current-time-string))))))
 463     (if (buffer-modified-p errbuf)
 464         (progn
 465           (display-buffer errbuf)
 466           (error "Failed to update game score file"))
 467       (kill-buffer errbuf))
 468     (save-excursion
 469       (let ((buf (find-buffer-visiting target)))
 470         (if buf
 471             (progn
 472               (with-current-buffer buf
 473                 (revert-buffer nil t nil))
 474               (display-buffer buf))
 475           (find-file-read-only-other-window target))))))
 476
 477 (defun gamegrid-add-score-insecure (file score)
 478   (save-excursion
 479     (setq file (expand-file-name file temporary-file-directory))
 480     (find-file-other-window file)
 481     (setq buffer-read-only nil)
 482     (goto-char (point-max))
 483     (insert (format "%05d\t%s\t%s <%s>\n"
 484                     score
 485                     (current-time-string)
 486                     (user-full-name)
 487                     (cond ((fboundp 'user-mail-address)
 488                            (user-mail-address))
 489                           ((boundp 'user-mail-address)
 490                            user-mail-address)
 491                           (t ""))))
 492     (sort-numeric-fields 1 (point-min) (point-max))
 493     (reverse-region (point-min) (point-max))
 494     (goto-line (1+ gamegrid-score-file-length))
 495     (delete-region (point) (point-max))
 496     (setq buffer-read-only t)
 497     (save-buffer)))
 498
 499
 500 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 501
 502 (provide 'gamegrid)
 503
 504 ;;; gamegrid.el ends here