lisp/play/gamegrid.el

   1 ;;; gamegrid.el --- library for implementing grid-based games on Emacs  -*- lexical-binding:t -*-
   2
   3 ;; Copyright (C) 1997-1998, 2001-2018 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 3 of the License, or
  15 ;; (at your option) 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.  If not, see <https://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 ;; ;;;;;;;;;;;;; buffer-local variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30
  31 (defvar gamegrid-use-glyphs t
  32   "Non-nil means use glyphs when available.")
  33
  34 (defvar gamegrid-use-color t
  35   "Non-nil means use color when available.")
  36
  37 (defvar gamegrid-font "-*-courier-medium-r-*-*-*-140-100-75-*-*-iso8859-*"
  38   "Name of the font used in X mode.")
  39
  40 (defvar gamegrid-face nil
  41   "Indicates the face to use as a default.")
  42 (make-variable-buffer-local 'gamegrid-face)
  43
  44 (defvar gamegrid-display-options nil)
  45
  46 (defvar gamegrid-buffer-width 0)
  47 (defvar gamegrid-buffer-height 0)
  48 (defvar gamegrid-blank 0)
  49
  50 (defvar gamegrid-timer nil)
  51
  52 (defvar gamegrid-display-mode nil)
  53
  54 (defvar gamegrid-display-table)
  55
  56 (defvar gamegrid-face-table nil)
  57
  58 (defvar gamegrid-buffer-start 1)
  59
  60 (defvar gamegrid-score-file-length 50
  61   "Number of high scores to keep.")
  62
  63 (defvar gamegrid-user-score-file-directory
  64   (locate-user-emacs-file "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 (defvar gamegrid-glyph-height-mm 7.0
  90   "Desired glyph height in mm.")
  91
  92 ;; ;;;;;;;;;;;;; glyph generation ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  93
  94 (defun gamegrid-calculate-glyph-size ()
  95   "Calculate appropriate glyph size in pixels based on display resolution.
  96 Return a multiple of 8 no less than 16."
  97   (if (and (display-pixel-height) (display-mm-height))
  98       (let* ((y-pitch (/ (display-pixel-height) (float (display-mm-height))))
  99              (pixels (* y-pitch gamegrid-glyph-height-mm))
 100              (rounded (* (floor (/ (+ pixels 4) 8)) 8)))
 101         (max 16 rounded))
 102     16))
 103
 104 ;; Example of glyph in XPM format:
 105 ;;
 106 ;; /* XPM */
 107 ;; static char *noname[] = {
 108 ;; /* width height ncolors chars_per_pixel */
 109 ;; \"16 16 3 1\",
 110 ;; /* colors */
 111 ;; \"+ s col1\",
 112 ;; \". s col2\",
 113 ;; \"- s col3\",
 114 ;; /* pixels */
 115 ;; \"---------------+\",
 116 ;; \"--------------++\",
 117 ;; \"--............++\",
 118 ;; \"--............++\",
 119 ;; \"--............++\",
 120 ;; \"--............++\",
 121 ;; \"--............++\",
 122 ;; \"--............++\",
 123 ;; \"--............++\",
 124 ;; \"--............++\",
 125 ;; \"--............++\",
 126 ;; \"--............++\",
 127 ;; \"--............++\",
 128 ;; \"--............++\",
 129 ;; \"-+++++++++++++++\",
 130 ;; \"++++++++++++++++\"
 131 ;; };
 132
 133 (defun gamegrid-xpm ()
 134   "Generate the XPM format image used for each square."
 135   (let* ((glyph-pixel-count (gamegrid-calculate-glyph-size))
 136          (border-pixel-count (/ glyph-pixel-count 8))
 137          (center-pixel-count (- glyph-pixel-count (* border-pixel-count 2))))
 138     (with-temp-buffer
 139       (insert (format "\
 140 /* XPM */
 141 static char *noname[] = {
 142 /* width height ncolors chars_per_pixel */
 143 \"%s %s 3 1\",
 144 /* colors */
 145 \"+ s col1\",
 146 \". s col2\",
 147 \"- s col3\",
 148 /* pixels */
 149 " glyph-pixel-count glyph-pixel-count))
 150
 151       (dotimes (row border-pixel-count)
 152         (let ((edge-pixel-count (+ row 1)))
 153           (insert "\"")
 154           (dotimes (_ (- glyph-pixel-count edge-pixel-count)) (insert "-"))
 155           (dotimes (_ edge-pixel-count) (insert "+"))
 156           (insert "\",\n")))
 157
 158       (let ((middle (format "\"%s%s%s\",\n"
 159                             (make-string border-pixel-count ?-)
 160                             (make-string center-pixel-count ?.)
 161                             (make-string border-pixel-count ?+))))
 162         (dotimes (_ center-pixel-count) (insert middle)))
 163
 164       (dotimes (row border-pixel-count)
 165         (let ((edge-pixel-count (- border-pixel-count row 1)))
 166           (insert "\"")
 167           (dotimes (_ edge-pixel-count) (insert "-"))
 168           (dotimes (_ (- glyph-pixel-count edge-pixel-count)) (insert "+"))
 169           (insert "\"")
 170           (if (/= row (1- border-pixel-count))
 171               (insert ",\n")
 172             (insert "\n};\n"))))
 173       (buffer-string))))
 174
 175 ;; Example of glyph in XBM format:
 176 ;;
 177 ;; /* gamegrid XBM */
 178 ;; #define gamegrid_width 16
 179 ;; #define gamegrid_height 16
 180 ;; static unsigned char gamegrid_bits[] = {
 181 ;;    0xff, 0xff, 0xff, 0x7f, 0xff, 0x3f, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a,
 182 ;;    0x57, 0x15, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a,
 183 ;;    0x57, 0x15, 0x07, 0x00, 0x03, 0x00, 0x01, 0x00 };
 184
 185 (defun gamegrid-xbm ()
 186   "Generate XBM format image used for each square."
 187   (let* ((glyph-pixel-count (gamegrid-calculate-glyph-size))
 188          (border-pixel-count (1- (/ glyph-pixel-count 4)))
 189          (center-pixel-count (- glyph-pixel-count (* 2 border-pixel-count))))
 190     (with-temp-buffer
 191       (insert (format "\
 192 /* gamegrid XBM */
 193 #define gamegrid_width %s
 194 #define gamegrid_height %s
 195 static unsigned char gamegrid_bits[] = {
 196 " glyph-pixel-count glyph-pixel-count))
 197       (dotimes (row border-pixel-count)
 198         (gamegrid-insert-xbm-bits
 199          (concat (make-string (- glyph-pixel-count row) ?1)
 200                  (make-string row ?0)))
 201         (insert ", \n"))
 202
 203       (let* ((left-border (make-string border-pixel-count ?1))
 204              (right-border (make-string border-pixel-count ?0))
 205              (even-line (apply 'concat
 206                                (append (list left-border)
 207                                        (make-list (/ center-pixel-count 2) "10")
 208                                        (list right-border))))
 209              (odd-line (apply 'concat
 210                               (append (list left-border)
 211                                       (make-list (/ center-pixel-count 2) "01")
 212                                       (list right-border)))))
 213         (dotimes (row center-pixel-count)
 214           (gamegrid-insert-xbm-bits (if (eq (logand row 1) 1) odd-line even-line))
 215           (insert ", \n")))
 216
 217       (dotimes (row border-pixel-count)
 218         (let ((edge-pixel-count (- border-pixel-count row)))
 219           (gamegrid-insert-xbm-bits
 220            (concat (make-string edge-pixel-count ?1)
 221                    (make-string (- glyph-pixel-count edge-pixel-count) ?0))))
 222         (if (/= row (1- border-pixel-count))
 223             (insert ", \n")
 224           (insert " };\n")))
 225       (buffer-string))))
 226
 227 (defun gamegrid-insert-xbm-bits (str)
 228   "Convert binary to hex and insert in current buffer.
 229 STR should be a string composed of 1s and 0s and be a multiple of
 230 8 in length.  Divide it into 8 bit bytes, reverse the order of
 231 each, convert them to hex and insert them in comma separated C
 232 format."
 233   (let ((byte-count (/ (length str) 8)))
 234     (dotimes (i byte-count)
 235       (let* ((byte (reverse (substring str (* i 8) (+ (* i 8) 8))))
 236              (value (string-to-number byte 2)))
 237         (insert (format "0x%02x" value))
 238         (unless (= i (1- byte-count))
 239           (insert ", "))))))
 240
 241 ;; ;;;;;;;;;;;;;;;; miscellaneous functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 242
 243 (defsubst gamegrid-characterp (arg)
 244   (if (fboundp 'characterp)
 245       (characterp arg)
 246     (integerp arg)))
 247
 248 (defsubst gamegrid-event-x (event)
 249   (if (fboundp 'event-x)
 250       (event-x event)
 251     (car (posn-col-row (event-end event)))))
 252
 253 (defsubst gamegrid-event-y (event)
 254   (if (fboundp 'event-y)
 255       (event-y event)
 256     (cdr (posn-col-row (event-end event)))))
 257
 258 ;; ;;;;;;;;;;;;; display functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 259
 260 (defun gamegrid-color (color shade)
 261   (let* ((v (floor (* shade 255)))
 262          (r (* v (aref color 0)))
 263          (g (* v (aref color 1)))
 264          (b (* v (aref color 2))))
 265     (format "#%02x%02x%02x" r g b)))
 266
 267 (defun gamegrid-set-font (face)
 268   (if gamegrid-font
 269       (condition-case nil
 270           (set-face-font face gamegrid-font)
 271         (error nil))))
 272
 273 (defun gamegrid-setup-face (face color)
 274   (set-face-foreground face color)
 275   (set-face-background face color)
 276   (gamegrid-set-font face)
 277   (condition-case nil
 278       (set-face-background-pixmap face [nothing]);; XEmacs
 279     (error nil))
 280   (condition-case nil
 281       (set-face-background-pixmap face nil);; Emacs
 282     (error nil)))
 283
 284 (defun gamegrid-make-mono-tty-face ()
 285   (let ((face (make-face 'gamegrid-mono-tty-face)))
 286     (set-face-inverse-video face t)
 287     face))
 288
 289 (defun gamegrid-make-color-tty-face (color)
 290   (let* ((color-str (if (symbolp color) (symbol-value color) color))
 291          (name (intern (format "gamegrid-color-tty-face-%s" color-str)))
 292          (face (make-face name)))
 293     (gamegrid-setup-face face color-str)
 294     face))
 295
 296 (defun gamegrid-make-grid-x-face ()
 297   (let ((face (make-face 'gamegrid-x-border-face)))
 298     (gamegrid-set-font face)
 299     face))
 300
 301 (defun gamegrid-make-mono-x-face ()
 302   (let ((face (make-face 'gamegrid-mono-x-face))
 303         (color (face-foreground 'default)))
 304     (if (null color)
 305         (setq color
 306               (cdr-safe (assq 'foreground-color (frame-parameters)))))
 307     (gamegrid-setup-face face color)
 308     face))
 309
 310 (defun gamegrid-make-color-x-face (color)
 311   (let* ((hex (gamegrid-color color 1.0))
 312          (name (intern (format "gamegrid-color-x-face-%s" hex)))
 313          (face (make-face name)))
 314     (gamegrid-setup-face face hex)
 315     face))
 316
 317 (defun gamegrid-make-face (data-spec-list color-spec-list)
 318   (let ((data (gamegrid-match-spec-list data-spec-list))
 319         (color (gamegrid-match-spec-list color-spec-list)))
 320     (pcase data
 321       (`color-x
 322        (gamegrid-make-color-x-face color))
 323       (`grid-x
 324        (unless gamegrid-grid-x-face
 325          (setq gamegrid-grid-x-face (gamegrid-make-grid-x-face)))
 326        gamegrid-grid-x-face)
 327       (`mono-x
 328        (unless gamegrid-mono-x-face
 329          (setq gamegrid-mono-x-face (gamegrid-make-mono-x-face)))
 330        gamegrid-mono-x-face)
 331       (`color-tty
 332        (gamegrid-make-color-tty-face color))
 333       (`mono-tty
 334        (unless gamegrid-mono-tty-face
 335          (setq gamegrid-mono-tty-face (gamegrid-make-mono-tty-face)))
 336        gamegrid-mono-tty-face))))
 337
 338 (defun gamegrid-colorize-glyph (color)
 339   (find-image `((:type xpm :data ,(gamegrid-xpm)
 340                        :ascent center
 341                        :color-symbols
 342                        (("col1" . ,(gamegrid-color color 0.6))
 343                         ("col2" . ,(gamegrid-color color 0.8))
 344                         ("col3" . ,(gamegrid-color color 1.0))))
 345                 (:type xbm :data ,(gamegrid-xbm)
 346                        :ascent center
 347                        :foreground ,(gamegrid-color color 1.0)
 348                        :background ,(gamegrid-color color 0.5)))))
 349
 350 (defun gamegrid-match-spec (spec)
 351   (let ((locale (car spec))
 352         (value (cadr spec)))
 353     (and (or (eq locale t)
 354              (and (listp locale)
 355                   (memq gamegrid-display-mode locale))
 356              (and (symbolp locale)
 357                   (eq gamegrid-display-mode locale)))
 358          value)))
 359
 360 (defun gamegrid-match-spec-list (spec-list)
 361   (and spec-list
 362        (or (gamegrid-match-spec (car spec-list))
 363            (gamegrid-match-spec-list (cdr spec-list)))))
 364
 365 (defun gamegrid-make-glyph (data-spec-list color-spec-list)
 366   (let ((data (gamegrid-match-spec-list data-spec-list))
 367         (color (gamegrid-match-spec-list color-spec-list)))
 368     (cond ((gamegrid-characterp data)
 369            (vector data))
 370           ((eq data 'colorize)
 371            (gamegrid-colorize-glyph color))
 372           ((listp data)
 373            (find-image data)) ;untested!
 374           ((vectorp data)
 375            (gamegrid-make-image-from-vector data)))))
 376
 377 (defun gamegrid-make-image-from-vector (vect)
 378   "Convert an XEmacs style \"glyph\" to an image-spec."
 379   (let ((l (list 'image :type)))
 380     (dotimes (n (length vect))
 381       (setf l (nconc l (list (aref vect n)))))
 382     (nconc l (list :ascent 'center))))
 383
 384 (defun gamegrid-display-type ()
 385   (cond ((and gamegrid-use-glyphs
 386               (display-images-p))
 387          'glyph)
 388         ((and gamegrid-use-color
 389               (display-graphic-p)
 390               (display-color-p))
 391          'color-x)
 392         ((display-graphic-p)
 393          'mono-x)
 394         ((and gamegrid-use-color
 395               (display-color-p))
 396          'color-tty)
 397         ((display-multi-font-p) ;???
 398          'mono-tty)
 399         (t
 400            'emacs-tty)))
 401
 402 (defun gamegrid-set-display-table ()
 403   (if (featurep 'xemacs)
 404       (add-spec-to-specifier current-display-table
 405                              gamegrid-display-table
 406                              (current-buffer)
 407                              nil
 408                              'remove-locale)
 409     (setq buffer-display-table gamegrid-display-table)))
 410
 411 (declare-function image-size "image.c" (spec &optional pixels frame))
 412
 413 (defun gamegrid-setup-default-font ()
 414   (setq gamegrid-face
 415         (copy-face 'default
 416                    (intern (concat "gamegrid-face-" (buffer-name)))))
 417   (when (eq gamegrid-display-mode 'glyph)
 418     (let ((max-height nil))
 419       (dotimes (c 256)
 420         (let ((glyph (aref gamegrid-display-table c)))
 421           (when (and (listp glyph) (eq (car  glyph) 'image))
 422             (let ((height (cdr (image-size glyph))))
 423               (if (or (null max-height)
 424                       (< max-height height))
 425                   (setq max-height height))))))
 426       (when (and max-height (< max-height 1))
 427         (let ((default-font-height (face-attribute 'default :height))
 428               (resy (/ (display-pixel-height) (/ (display-mm-height) 25.4)))
 429               point-size pixel-size)
 430           (setq point-size (/ (* (float default-font-height) max-height) 10)
 431                 pixel-size (floor (* resy (/ point-size 72.27)))
 432                 point-size (* (/ pixel-size resy) 72.27))
 433           (face-spec-set gamegrid-face
 434                          `((t :height ,(floor (* point-size 10))))))))))
 435
 436 (defun gamegrid-initialize-display ()
 437   (setq gamegrid-display-mode (gamegrid-display-type))
 438   (setq gamegrid-display-table (make-display-table))
 439   (setq gamegrid-face-table (make-vector 256 nil))
 440   (dotimes (c 256)
 441     (let* ((spec (aref gamegrid-display-options c))
 442            (glyph (gamegrid-make-glyph (car spec) (nth 2 spec)))
 443            (face (gamegrid-make-face (cadr spec) (nth 2 spec))))
 444       (aset gamegrid-face-table c face)
 445       (aset gamegrid-display-table c glyph)))
 446   (gamegrid-setup-default-font)
 447   (gamegrid-set-display-table)
 448   (setq cursor-type nil))
 449
 450
 451 (defun gamegrid-set-face (c)
 452   (if (eq gamegrid-display-mode 'glyph)
 453       (add-text-properties (1- (point)) (point)
 454                            (list 'display (list (aref gamegrid-display-table c))))
 455     (put-text-property (1- (point))
 456                        (point)
 457                        'face
 458                        (aref gamegrid-face-table c))))
 459
 460 (defun gamegrid-cell-offset (x y)
 461   (+ gamegrid-buffer-start
 462      (* (1+ gamegrid-buffer-width) y)
 463      x))
 464
 465 ;; ;;;;;;;;;;;;;;;; grid functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 466
 467 (defun gamegrid-get-cell (x y)
 468   (char-after (gamegrid-cell-offset x y)))
 469
 470 (defun gamegrid-set-cell (x y c)
 471   (save-excursion
 472     (let ((buffer-read-only nil))
 473       (goto-char (gamegrid-cell-offset x y))
 474       (delete-char 1)
 475       (insert-char c 1)
 476       (gamegrid-set-face c))))
 477
 478 (defun gamegrid-init-buffer (width height blank)
 479   (setq gamegrid-buffer-width width
 480         gamegrid-buffer-height height)
 481   (let ((line (concat
 482                (make-string width blank)
 483                "\n"))
 484         (buffer-read-only nil))
 485     (erase-buffer)
 486     (setq gamegrid-buffer-start (point))
 487     (dotimes (_ height)
 488       (insert line))
 489     ;; Adjust the height of the default face to the height of the
 490     ;; images. Unlike XEmacs, Emacs doesn't allow making the default
 491     ;; face buffer-local; so we do this with an overlay.
 492     (when (eq gamegrid-display-mode 'glyph)
 493       (overlay-put (make-overlay (point-min) (point-max))
 494                    'face gamegrid-face))
 495     (goto-char (point-min))))
 496
 497 (defun gamegrid-init (options)
 498   (setq buffer-read-only t
 499         truncate-lines t
 500         line-spacing 0
 501         gamegrid-display-options options)
 502   (buffer-disable-undo (current-buffer))
 503   (gamegrid-initialize-display))
 504
 505 ;; ;;;;;;;;;;;;;;;; timer functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 506
 507 (defun gamegrid-start-timer (period func)
 508   (setq gamegrid-timer
 509         (if (featurep 'xemacs)
 510             (start-itimer "Gamegrid"
 511                           func
 512                           period
 513                           period
 514                           nil
 515                           t
 516                           (current-buffer))
 517           (run-with-timer period
 518                           period
 519                           func
 520                           (current-buffer)))))
 521
 522 (defun gamegrid-set-timer (delay)
 523   (if gamegrid-timer
 524       (if (fboundp 'set-itimer-restart)
 525           (set-itimer-restart gamegrid-timer delay)
 526         (timer-set-time gamegrid-timer
 527                         (list (aref gamegrid-timer 1)
 528                               (aref gamegrid-timer 2)
 529                               (aref gamegrid-timer 3))
 530                         delay))))
 531
 532 (defun gamegrid-kill-timer ()
 533   (if gamegrid-timer
 534       (if (featurep 'xemacs)
 535           (delete-itimer gamegrid-timer)
 536         (cancel-timer gamegrid-timer)))
 537   (setq gamegrid-timer nil))
 538
 539 ;; ;;;;;;;;;;;;;;; high score functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 540
 541 (defun gamegrid-add-score (file score)
 542   "Add the current score to the high score file.
 543
 544 On POSIX systems there may be a shared game directory for all users in
 545 which the scorefiles are kept.  On such systems Emacs doesn't create
 546 the score file FILE in this directory, if it doesn't already exist.
 547 In this case Emacs searches for FILE in the directory specified by
 548 `gamegrid-user-score-file-directory' and creates it there, if
 549 necessary.
 550
 551 To add the score file for a game to the system wide shared game
 552 directory, create the file with the shell command \"touch\" in this
 553 directory and make sure that it is owned by the correct user and
 554 group.  You probably need special user privileges to do this.
 555
 556 On non-POSIX systems Emacs searches for FILE in the directory
 557 specified by the variable `temporary-file-directory'.  If necessary,
 558 FILE is created there."
 559   (pcase system-type
 560     ((or `ms-dos `windows-nt)
 561      (gamegrid-add-score-insecure file score))
 562     (_
 563      (gamegrid-add-score-with-update-game-score file score))))
 564
 565
 566 ;; On POSIX systems there are four cases to distinguish:
 567
 568 ;;     1. FILE is an absolute filename.  Then it should be a file in
 569 ;;        temporary file directory.  This is the way,
 570 ;;        `gamegrid-add-score' was supposed to be used in the past and
 571 ;;        is covered here for backward-compatibility.
 572 ;;
 573 ;;     2. The helper program "update-game-score" is setgid or setuid
 574 ;;        and the file FILE does already exist in a system wide shared
 575 ;;        game directory.  This should be the normal case on POSIX
 576 ;;        systems, if the game was installed system wide.  Use
 577 ;;        "update-game-score" to add the score to the file in the
 578 ;;        shared game directory.
 579 ;;
 580 ;;     3. "update-game-score" is setgid/setuid, but the file FILE does
 581 ;;        *not* exist in the system wide shared game directory.  Use
 582 ;;        `gamegrid-add-score-insecure' to create--if necessary--and
 583 ;;        update FILE.  This is for the case that a user has installed
 584 ;;        a game on her own.
 585 ;;
 586 ;;     4. "update-game-score" does not exist or is not setgid/setuid.
 587 ;;        Create/update FILE in the user's home directory, without
 588 ;;        using "update-game-score".  There is presumably no shared
 589 ;;        game directory.
 590
 591 (defvar gamegrid-shared-game-dir)
 592
 593 (defun gamegrid-add-score-with-update-game-score (file score)
 594   (let ((gamegrid-shared-game-dir
 595          (not (zerop (logand (or (file-modes
 596                                   (expand-file-name "update-game-score"
 597                                                     exec-directory))
 598                                   0)
 599                              #o6000)))))
 600     (cond ((file-name-absolute-p file)
 601            (gamegrid-add-score-insecure file score))
 602           ((and gamegrid-shared-game-dir
 603                 (file-exists-p (expand-file-name file shared-game-score-directory)))
 604            ;; Use the setgid (or setuid) "update-game-score" program
 605            ;; to update a system-wide score file.
 606            (gamegrid-add-score-with-update-game-score-1 file
 607             (expand-file-name file shared-game-score-directory) score))
 608           ;; Else: Add the score to a score file in the user's home
 609           ;; directory.
 610           (t
 611            (unless (file-exists-p
 612                     (directory-file-name gamegrid-user-score-file-directory))
 613              (make-directory gamegrid-user-score-file-directory t))
 614            (gamegrid-add-score-insecure file score
 615                                         gamegrid-user-score-file-directory)))))
 616
 617 (defun gamegrid-add-score-with-update-game-score-1 (file target score)
 618   (let ((default-directory "/")
 619         (errbuf (generate-new-buffer " *update-game-score loss*"))
 620         (marker-string (concat
 621                         (user-full-name)
 622                         " <"
 623                         (cond ((fboundp 'user-mail-address)
 624                                (user-mail-address))
 625                               ((boundp 'user-mail-address)
 626                                user-mail-address)
 627                               (t ""))
 628                         ">  "
 629                         (current-time-string))))
 630     ;; This can be called from a timer, so enable local quits.
 631     (with-local-quit
 632       (apply
 633        'call-process
 634        (append
 635         (list
 636          (expand-file-name "update-game-score" exec-directory)
 637          nil errbuf nil
 638          "-m" (int-to-string gamegrid-score-file-length)
 639          "-d" (if gamegrid-shared-game-dir
 640                   (expand-file-name shared-game-score-directory)
 641                 (file-name-directory target))
 642          file
 643          (int-to-string score)
 644          marker-string))))
 645     (if (buffer-modified-p errbuf)
 646         (progn
 647           (display-buffer errbuf)
 648           (error "Failed to update game score file"))
 649       (kill-buffer errbuf))
 650     (let ((buf (find-buffer-visiting target)))
 651       (save-excursion
 652         (if buf
 653             (progn
 654               (switch-to-buffer buf)
 655               (revert-buffer nil t nil)
 656               (display-buffer buf))
 657           (find-file-read-only target))
 658         (goto-char (point-min))
 659         (search-forward (concat (int-to-string score)
 660                                 " " (user-login-name) " "
 661                                 marker-string) nil t)
 662         (beginning-of-line)))))
 663
 664 (defun gamegrid-add-score-insecure (file score &optional directory)
 665   (save-excursion
 666     (setq file (expand-file-name file (or directory
 667                                           temporary-file-directory)))
 668     (find-file-other-window file)
 669     (setq buffer-read-only nil)
 670     (goto-char (point-max))
 671     (insert (format "%05d\t%s\t%s <%s>\n"
 672                     score
 673                     (current-time-string)
 674                     (user-full-name)
 675                     (cond ((fboundp 'user-mail-address)
 676                            (user-mail-address))
 677                           ((boundp 'user-mail-address)
 678                            user-mail-address)
 679                           (t ""))))
 680     (sort-fields 1 (point-min) (point-max))
 681     (reverse-region (point-min) (point-max))
 682     (goto-char (point-min))
 683     (forward-line gamegrid-score-file-length)
 684     (delete-region (point) (point-max))
 685     (setq buffer-read-only t)
 686     (save-buffer)))
 687
 688
 689 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 690
 691 (provide 'gamegrid)
 692
 693 ;;; gamegrid.el ends here