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 (if (symbolp color) (symbol-value color) 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              window-system)))
 266     (cond ((and gamegrid-use-glyphs
 267                 window-system-p
 268                 (featurep 'xpm))
 269            'glyph)
 270           ((and gamegrid-use-color
 271                 window-system-p
 272                 (gamegrid-color-display-p))
 273            'color-x)
 274           (window-system-p
 275            'mono-x)
 276           ((and gamegrid-use-color
 277                 (gamegrid-color-display-p))
 278            'color-tty)
 279           ((fboundp 'set-face-property)
 280            'mono-tty)
 281           (t
 282            'emacs-tty))))
 283
 284 (defun gamegrid-set-display-table ()
 285   (if (fboundp 'specifierp)
 286       (add-spec-to-specifier current-display-table
 287                              gamegrid-display-table
 288                              (current-buffer)
 289                              nil
 290                              'remove-locale)
 291     (setq buffer-display-table gamegrid-display-table)))
 292
 293 (defun gamegrid-hide-cursor ()
 294   (make-local-variable 'cursor-type)
 295   (setq cursor-type nil))
 296
 297 (defun gamegrid-setup-default-font ()
 298   (cond ((eq gamegrid-display-mode 'glyph)
 299          (let* ((font-spec (face-property 'default 'font))
 300                 (name (font-name font-spec))
 301                 (max-height nil))
 302            (loop for c from 0 to 255 do
 303              (let ((glyph (aref gamegrid-display-table c)))
 304                (cond ((glyphp glyph)
 305                       (let ((height (glyph-height glyph)))
 306                         (if (or (null max-height)
 307                                 (< max-height height))
 308                             (setq max-height height)))))))
 309            (if max-height
 310                (while (and (> (font-height font-spec) max-height)
 311                            (setq name (x-find-smaller-font name)))
 312                  (add-spec-to-specifier font-spec name (current-buffer))))))))
 313
 314 (defun gamegrid-initialize-display ()
 315   (setq gamegrid-display-mode (gamegrid-display-type))
 316   (setq gamegrid-display-table (make-display-table))
 317   (setq gamegrid-face-table (make-vector 256 nil))
 318   (loop for c from 0 to 255 do
 319     (let* ((spec (aref gamegrid-display-options c))
 320            (glyph (gamegrid-make-glyph (car spec) (caddr spec)))
 321            (face (gamegrid-make-face (cadr spec) (caddr spec))))
 322       (aset gamegrid-face-table c face)
 323       (aset gamegrid-display-table c glyph)))
 324   (gamegrid-setup-default-font)
 325   (gamegrid-set-display-table)
 326   (gamegrid-hide-cursor))
 327
 328
 329 (defun gamegrid-set-face (c)
 330   (unless (eq gamegrid-display-mode 'glyph)
 331     (put-text-property (1- (point))
 332                        (point)
 333                        'face
 334                        (aref gamegrid-face-table c))))
 335
 336 (defun gamegrid-cell-offset (x y)
 337   (+ gamegrid-buffer-start
 338      (* (1+ gamegrid-buffer-width) y)
 339      x))
 340
 341 ;; ;;;;;;;;;;;;;;;; grid functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 342
 343 (defun gamegrid-get-cell (x y)
 344   (char-after (gamegrid-cell-offset x y)))
 345
 346 (defun gamegrid-set-cell (x y c)
 347   (save-excursion
 348     (let ((buffer-read-only nil))
 349       (goto-char (gamegrid-cell-offset x y))
 350       (delete-char 1)
 351       (insert-char c 1)
 352       (gamegrid-set-face c))))
 353
 354 (defun gamegrid-init-buffer (width height blank)
 355   (setq gamegrid-buffer-width width
 356         gamegrid-buffer-height height)
 357   (let ((line (concat
 358                (make-string width blank)
 359                "\n"))
 360         (buffer-read-only nil))
 361     (erase-buffer)
 362     (setq gamegrid-buffer-start (point))
 363     (dotimes (i height)
 364       (insert line))
 365     (goto-char (point-min))))
 366
 367 (defun gamegrid-init (options)
 368   (setq buffer-read-only t
 369         truncate-lines t
 370         gamegrid-display-options options)
 371   (buffer-disable-undo (current-buffer))
 372   (gamegrid-initialize-display))
 373
 374 ;; ;;;;;;;;;;;;;;;; timer functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 375
 376 (defun gamegrid-start-timer (period func)
 377   (setq gamegrid-timer
 378         (if (featurep 'itimer)
 379             (start-itimer "Gamegrid"
 380                           func
 381                           period
 382                           period
 383                           nil
 384                           t
 385                           (current-buffer))
 386           (run-with-timer period
 387                           period
 388                           func
 389                           (current-buffer)))))
 390
 391 (defun gamegrid-set-timer (delay)
 392   (if gamegrid-timer
 393       (if (featurep 'itimer)
 394           (set-itimer-restart gamegrid-timer delay)
 395         (timer-set-time gamegrid-timer
 396                         (list (aref gamegrid-timer 1)
 397                               (aref gamegrid-timer 2)
 398                               (aref gamegrid-timer 3))
 399                         delay))))
 400
 401 (defun gamegrid-kill-timer ()
 402   (if gamegrid-timer
 403       (if (featurep 'itimer)
 404           (delete-itimer gamegrid-timer)
 405         (timer-set-time gamegrid-timer '(0 0 0) nil)))
 406   (setq gamegrid-timer nil))
 407
 408 ;; ;;;;;;;;;;;;;;; high score functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 409
 410 (defun gamegrid-add-score (file score)
 411   "Add the current score to the high score file."
 412   (case system-type
 413     ((ms-dos windows-nt)
 414      (gamegrid-add-score-insecure file score))
 415     (t
 416      (gamegrid-add-score-with-update-game-score file score))))
 417
 418 (defun gamegrid-add-score-with-update-game-score (file score)
 419   (let* ((result nil)
 420          (errbuf (generate-new-buffer " *update-game-score loss*"))
 421          (have-shared-game-dir
 422           (not (zerop (logand (file-modes
 423                                (expand-file-name "update-game-score"
 424                                                  exec-directory))
 425                               #o4000))))
 426          (target (if have-shared-game-dir
 427                      (expand-file-name file shared-game-score-directory)
 428                    (let ((f (expand-file-name
 429                              gamegrid-user-score-file-directory)))
 430                      (when (file-writable-p f)
 431                        (unless (eq (car-safe (file-attributes f))
 432                                    t)
 433                          (make-directory f))
 434                        (setq f (expand-file-name file f))
 435                        (unless (file-exists-p f)
 436                          (write-region "" nil f nil 'silent nil 'excl)))
 437                      f))))
 438     (let ((default-directory "/"))
 439       (apply
 440        'call-process
 441        (append
 442         (list
 443          (expand-file-name "update-game-score" exec-directory)
 444          nil errbuf nil
 445          "-m" (int-to-string gamegrid-score-file-length)
 446          "-d" (if have-shared-game-dir
 447                   (expand-file-name shared-game-score-directory)
 448                 (file-name-directory target))
 449          file
 450          (int-to-string score)
 451          (concat
 452           (user-full-name)
 453           " <"
 454           (cond ((fboundp 'user-mail-address)
 455                  (user-mail-address))
 456                 ((boundp 'user-mail-address)
 457                  user-mail-address)
 458                 (t ""))
 459           ">  "
 460           (current-time-string))))))
 461     (if (buffer-modified-p errbuf)
 462         (progn
 463           (display-buffer errbuf)
 464           (error "Failed to update game score file"))
 465       (kill-buffer errbuf))
 466     (save-excursion
 467       (let ((buf (find-buffer-visiting target)))
 468         (if buf
 469             (progn
 470               (with-current-buffer buf
 471                 (revert-buffer nil t nil))
 472               (display-buffer buf))
 473           (find-file-read-only-other-window target))))))
 474
 475 (defun gamegrid-add-score-insecure (file score)
 476   (save-excursion
 477     (setq file (expand-file-name file temporary-file-directory))
 478     (find-file-other-window file)
 479     (setq buffer-read-only nil)
 480     (goto-char (point-max))
 481     (insert (format "%05d\t%s\t%s <%s>\n"
 482                     score
 483                     (current-time-string)
 484                     (user-full-name)
 485                     (cond ((fboundp 'user-mail-address)
 486                            (user-mail-address))
 487                           ((boundp 'user-mail-address)
 488                            user-mail-address)
 489                           (t ""))))
 490     (sort-numeric-fields 1 (point-min) (point-max))
 491     (reverse-region (point-min) (point-max))
 492     (goto-line (1+ gamegrid-score-file-length))
 493     (delete-region (point) (point-max))
 494     (setq buffer-read-only t)
 495     (save-buffer)))
 496
 497
 498 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 499
 500 (provide 'gamegrid)
 501
 502 ;;; gamegrid.el ends here