code.delx.au - gnu-emacs/blob - lisp/play/blackbox.el

   1 ;;; blackbox.el --- blackbox game in Emacs Lisp
   2
   3 ;; Copyright (C) 1985, 1986, 1987, 1992, 2001, 2002, 2003, 2004,
   4 ;;   2005 Free Software Foundation, Inc.
   5
   6 ;; Author: F. Thomas May <uw-nsr!uw-warp!tom@beaver.cs.washington.edu>
   7 ;; Adapted-By: ESR
   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., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; by F. Thomas May <uw-nsr!uw-warp!tom@beaver.cs.washington.edu>
  30 ;; doc comment by Root Boy Jim <rbj@dsys.icst.nbs.gov>, 27 Apr 89
  31 ;; interface improvements by ESR, Dec 5 1991.
  32
  33 ;; The object of the game is to find four hidden balls by shooting rays
  34 ;; into the black box.  There are four possibilities: 1) the ray will
  35 ;; pass thru the box undisturbed, 2) it will hit a ball and be absorbed,
  36 ;; 3) it will be deflected and exit the box, or 4) be deflected immediately,
  37 ;; not even being allowed entry into the box.
  38 ;;
  39 ;; The strange part is the method of deflection.  It seems that rays will
  40 ;; not pass next to a ball, and change direction at right angles to avoid it.
  41 ;;
  42 ;;                           R   3
  43 ;;               1 - - - - - - - - 1
  44 ;;                 - - - - - - - -
  45 ;;                 - O - - - - - - 3
  46 ;;               2 - - - - O - O -
  47 ;;               4 - - - - - - - -
  48 ;;               5 - - - - - - - - 5
  49 ;;                 - - - - - - - - R
  50 ;;               H - - - - - - - O
  51 ;;                 2   H 4       H
  52 ;;
  53 ;; Rays which enter and exit are numbered.  You can see that rays 1 & 5 pass
  54 ;; thru the box undisturbed. Ray 2 is deflected by the northwesternmost
  55 ;; ball.  Likewise rays 3 and 4. Rays which hit balls and are absorbed are
  56 ;; marked with H.  The bottom of the left and the right of the bottom hit
  57 ;; the southeastern ball directly.  Rays may also hit balls after being
  58 ;; reflected. Consider the H on the bottom next to the 4.  It bounces off
  59 ;; the NW-ern most ball and hits the central ball.  A ray shot from above
  60 ;; the right side 5 would hit the SE-ern most ball.  The R beneath the 5
  61 ;; is because the ball is returned instantly.  It is not allowed into
  62 ;; the box if it would reflect immediately.  The R on the top is a more
  63 ;; leisurely return.  Both central balls would tend to deflect it east
  64 ;; or west, but it cannot go either way, so it just retreats.
  65 ;;
  66 ;; At the end of the game, if you've placed guesses for as many balls as
  67 ;; there are in the box, the true board position will be revealed.  Each
  68 ;; `x' is an incorrect guess of yours; `o' is the true location of a ball.
  69
  70 ;;; Code:
  71
  72 (defvar blackbox-mode-map nil "")
  73
  74 (defvar bb-board nil
  75   "Blackbox board.")
  76
  77 (defvar bb-x -1
  78   "Current x-position.")
  79
  80 (defvar bb-y -1
  81   "Current y-position.")
  82
  83 (defvar bb-score 0
  84   "Current score.")
  85
  86 (defvar bb-detour-count 0
  87   "Number of detours.")
  88
  89 (defvar bb-balls-placed nil
  90   "List of already placed balls.")
  91
  92 (unless blackbox-mode-map
  93   (setq blackbox-mode-map (make-keymap))
  94   (suppress-keymap blackbox-mode-map t)
  95   (define-key blackbox-mode-map "\C-f" 'bb-right)
  96   (define-key blackbox-mode-map [right] 'bb-right)
  97   (define-key blackbox-mode-map "\C-b" 'bb-left)
  98   (define-key blackbox-mode-map [left] 'bb-left)
  99   (define-key blackbox-mode-map "\C-p" 'bb-up)
 100   (define-key blackbox-mode-map [up] 'bb-up)
 101   (define-key blackbox-mode-map "\C-n" 'bb-down)
 102   (define-key blackbox-mode-map [down] 'bb-down)
 103   (define-key blackbox-mode-map "\C-e" 'bb-eol)
 104   (define-key blackbox-mode-map "\C-a" 'bb-bol)
 105   (define-key blackbox-mode-map " " 'bb-romp)
 106   (define-key blackbox-mode-map [insert] 'bb-romp)
 107   (define-key blackbox-mode-map "\C-m" 'bb-done)
 108   (define-key blackbox-mode-map [kp-enter] 'bb-done))
 109
 110 ;; Blackbox mode is suitable only for specially formatted data.
 111 (put 'blackbox-mode 'mode-class 'special)
 112
 113 (defun blackbox-mode ()
 114   "Major mode for playing blackbox.
 115 To learn how to play blackbox, see the documentation for function `blackbox'.
 116
 117 The usual mnemonic keys move the cursor around the box.
 118 \\<blackbox-mode-map>\\[bb-bol] and \\[bb-eol] move to the beginning and end of line, respectively.
 119
 120 \\[bb-romp] -- send in a ray from point, or toggle a ball at point
 121 \\[bb-done] -- end game and get score"
 122   (interactive)
 123   (kill-all-local-variables)
 124   (use-local-map blackbox-mode-map)
 125   (setq truncate-lines t)
 126   (setq major-mode 'blackbox-mode)
 127   (setq mode-name "Blackbox")
 128   (run-mode-hooks 'blackbox-mode-hook))
 129
 130 ;;;###autoload
 131 (defun blackbox (num)
 132   "Play blackbox.
 133 Optional prefix argument is the number of balls; the default is 4.
 134
 135 What is blackbox?
 136
 137 Blackbox is a game of hide and seek played on an 8 by 8 grid (the
 138 Blackbox).  Your opponent (Emacs, in this case) has hidden several
 139 balls (usually 4) within this box.  By shooting rays into the box and
 140 observing where they emerge it is possible to deduce the positions of
 141 the hidden balls.  The fewer rays you use to find the balls, the lower
 142 your score.
 143
 144 Overview of play:
 145
 146 \\<blackbox-mode-map>\
 147 To play blackbox, type \\[blackbox].  An optional prefix argument
 148 specifies the number of balls to be hidden in the box; the default is
 149 four.
 150
 151 The cursor can be moved around the box with the standard cursor
 152 movement keys.
 153
 154 To shoot a ray, move the cursor to the edge of the box and press SPC.
 155 The result will be determined and the playfield updated.
 156
 157 You may place or remove balls in the box by moving the cursor into the
 158 box and pressing \\[bb-romp].
 159
 160 When you think the configuration of balls you have placed is correct,
 161 press \\[bb-done].  You will be informed whether you are correct or
 162 not, and be given your score.  Your score is the number of letters and
 163 numbers around the outside of the box plus five for each incorrectly
 164 placed ball.  If you placed any balls incorrectly, they will be
 165 indicated with `x', and their actual positions indicated with `o'.
 166
 167 Details:
 168
 169 There are three possible outcomes for each ray you send into the box:
 170
 171         Detour: the ray is deflected and emerges somewhere other than
 172                 where you sent it in.  On the playfield, detours are
 173                 denoted by matching pairs of numbers -- one where the
 174                 ray went in, and the other where it came out.
 175
 176         Reflection: the ray is reflected and emerges in the same place
 177                 it was sent in.  On the playfield, reflections are
 178                 denoted by the letter `R'.
 179
 180         Hit:    the ray strikes a ball directly and is absorbed.  It does
 181                 not emerge from the box.  On the playfield, hits are
 182                 denoted by the letter `H'.
 183
 184 The rules for how balls deflect rays are simple and are best shown by
 185 example.
 186
 187 As a ray approaches a ball it is deflected ninety degrees.  Rays can
 188 be deflected multiple times.  In the diagrams below, the dashes
 189 represent empty box locations and the letter `O' represents a ball.
 190 The entrance and exit points of each ray are marked with numbers as
 191 described under \"Detour\" above.  Note that the entrance and exit
 192 points are always interchangeable.  `*' denotes the path taken by the
 193 ray.
 194
 195 Note carefully the relative positions of the ball and the ninety
 196 degree deflection it causes.
 197
 198     1
 199   - * - - - - - -         - - - - - - - -         - - - - - - - -
 200   - * - - - - - -         - - - - - - - -         - - - - - - - -
 201 1 * * - - - - - -         - - - - - - - -         - O - - - - O -
 202   - - O - - - - -         - - O - - - - -         - - * * * * - -
 203   - - - - - - - -         - - - * * * * * 2     3 * * * - - * - -
 204   - - - - - - - -         - - - * - - - -         - - - O - * - -
 205   - - - - - - - -         - - - * - - - -         - - - - * * - -
 206   - - - - - - - -         - - - * - - - -         - - - - * - O -
 207                                 2                         3
 208
 209 As mentioned above, a reflection occurs when a ray emerges from the same point
 210 it was sent in.  This can happen in several ways:
 211
 212
 213   - - - - - - - -         - - - - - - - -          - - - - - - - -
 214   - - - - O - - -         - - O - O - - -          - - - - - - - -
 215 R * * * * - - - -         - - - * - - - -          O - - - - - - -
 216   - - - - O - - -         - - - * - - - -        R - - - - - - - -
 217   - - - - - - - -         - - - * - - - -          - - - - - - - -
 218   - - - - - - - -         - - - * - - - -          - - - - - - - -
 219   - - - - - - - -       R * * * * - - - -          - - - - - - - -
 220   - - - - - - - -         - - - - O - - -          - - - - - - - -
 221
 222 In the first example, the ray is deflected downwards by the upper
 223 ball, then left by the lower ball, and finally retraces its path to
 224 its point of origin.  The second example is similar.  The third
 225 example is a bit anomalous but can be rationalized by realizing the
 226 ray never gets a chance to get into the box.  Alternatively, the ray
 227 can be thought of as being deflected downwards and immediately
 228 emerging from the box.
 229
 230 A hit occurs when a ray runs straight into a ball:
 231
 232   - - - - - - - -         - - - - - - - -          - - - - - - - -
 233   - - - - - - - -         - - - - - - - -          - - - - O - - -
 234   - - - - - - - -         - - - - O - - -        H * * * * - - - -
 235   - - - - - - - -       H * * * * O - - -          - - - * - - - -
 236   - - - - - - - -         - - - - O - - -          - - - O - - - -
 237 H * * * O - - - -         - - - - - - - -          - - - - - - - -
 238   - - - - - - - -         - - - - - - - -          - - - - - - - -
 239   - - - - - - - -         - - - - - - - -          - - - - - - - -
 240
 241 Be sure to compare the second example of a hit with the first example of
 242 a reflection."
 243   (interactive "P")
 244   (switch-to-buffer "*Blackbox*")
 245   (blackbox-mode)
 246   (setq buffer-read-only t)
 247   (buffer-disable-undo (current-buffer))
 248   (setq bb-board (bb-init-board (or num 4)))
 249   (setq bb-balls-placed nil)
 250   (setq bb-x -1)
 251   (setq bb-y -1)
 252   (setq bb-score 0)
 253   (setq bb-detour-count 0)
 254   (bb-insert-board)
 255   (bb-goto (cons bb-x bb-y)))
 256
 257 (defun bb-init-board (num-balls)
 258   (random t)
 259   (let (board pos)
 260     (while (>= (setq num-balls (1- num-balls)) 0)
 261       (while
 262           (progn
 263             (setq pos (cons (random 8) (random 8)))
 264             (member pos board)))
 265       (setq board (cons pos board)))
 266     board))
 267
 268 (defun bb-insert-board ()
 269   (let (i (buffer-read-only nil))
 270     (erase-buffer)
 271     (insert "                     \n")
 272     (setq i 8)
 273     (while (>= (setq i (1- i)) 0)
 274       (insert "   - - - - - - - -   \n"))
 275     (insert "                     \n")
 276     (insert (format "\nThere are %d balls in the box" (length bb-board)))
 277     ))
 278
 279 (defun bb-right (count)
 280   (interactive "p")
 281   (while (and (> count 0) (< bb-x 8))
 282     (forward-char 2)
 283     (setq bb-x (1+ bb-x))
 284     (setq count (1- count))))
 285
 286 (defun bb-left (count)
 287   (interactive "p")
 288   (while (and (> count 0) (> bb-x -1))
 289     (backward-char 2)
 290     (setq bb-x (1- bb-x))
 291     (setq count (1- count))))
 292
 293 (defun bb-up (count)
 294   (interactive "p")
 295   (while (and (> count 0) (> bb-y -1))
 296     (previous-line 1)
 297     (setq bb-y (1- bb-y))
 298     (setq count (1- count))))
 299
 300 (defun bb-down (count)
 301   (interactive "p")
 302   (while (and (> count 0) (< bb-y 8))
 303     (next-line 1)
 304     (setq bb-y (1+ bb-y))
 305     (setq count (1- count))))
 306
 307 (defun bb-eol ()
 308   (interactive)
 309   (setq bb-x 8)
 310   (bb-goto (cons bb-x bb-y)))
 311
 312 (defun bb-bol ()
 313   (interactive)
 314   (setq bb-x -1)
 315   (bb-goto (cons bb-x bb-y)))
 316
 317 (defun bb-romp ()
 318   (interactive)
 319   (cond
 320    ((and
 321      (or (= bb-x -1) (= bb-x 8))
 322      (or (= bb-y -1) (= bb-y 8))))
 323    ((bb-outside-box bb-x bb-y)
 324     (bb-trace-ray bb-x bb-y))
 325    (t
 326     (bb-place-ball bb-x bb-y))))
 327
 328 (defun bb-place-ball (x y)
 329   (let ((coord (cons x y)))
 330     (cond
 331      ((member coord bb-balls-placed)
 332       (setq bb-balls-placed (delete coord bb-balls-placed))
 333       (bb-update-board "-"))
 334      (t
 335       (setq bb-balls-placed (cons coord bb-balls-placed))
 336       (bb-update-board (propertize "O" 'help-echo "Placed ball"))))))
 337
 338 (defun bb-trace-ray (x y)
 339   (when (= (following-char) 32)
 340     (let ((result (bb-trace-ray-2
 341                    t
 342                    x
 343                    (cond
 344                     ((= x -1) 1)
 345                     ((= x 8) -1)
 346                     (t 0))
 347                    y
 348                    (cond
 349                     ((= y -1) 1)
 350                     ((= y 8) -1)
 351                     (t 0)))))
 352       (cond
 353        ((eq result 'hit)
 354         (bb-update-board (propertize "H" 'help-echo "Hit"))
 355         (setq bb-score (1+ bb-score)))
 356        ((equal result (cons x y))
 357         (bb-update-board (propertize "R" 'help-echo "Reflection"))
 358         (setq bb-score (1+ bb-score)))
 359        (t
 360         (setq bb-detour-count (1+ bb-detour-count))
 361         (bb-update-board (propertize (format "%d" bb-detour-count)
 362                                      'help-echo "Detour"))
 363         (save-excursion
 364           (bb-goto result)
 365           (bb-update-board (propertize (format "%d" bb-detour-count)
 366                                        'help-echo "Detour")))
 367         (setq bb-score (+ bb-score 2)))))))
 368
 369 (defun bb-trace-ray-2 (first x dx y dy)
 370   (cond
 371    ((and (not first)
 372          (bb-outside-box x y))
 373     (cons x y))
 374    ((member (cons (+ x dx) (+ y dy)) bb-board)
 375     'hit)
 376    ((member (cons (+ x dx dy) (+ y dy dx)) bb-board)
 377     (bb-trace-ray-2 nil x (- dy) y (- dx)))
 378    ((member (cons (+ x dx (- dy)) (+ y dy (- dx))) bb-board)
 379     (bb-trace-ray-2 nil x dy y dx))
 380    (t
 381     (bb-trace-ray-2 nil (+ x dx) dx (+ y dy) dy))))
 382
 383 (defun bb-done ()
 384   "Finish the game and report score."
 385   (interactive)
 386   (let (bogus-balls)
 387     (cond
 388      ((not (= (length bb-balls-placed) (length bb-board)))
 389       (message "There %s %d hidden ball%s; you have placed %d."
 390                (if (= (length bb-board) 1) "is" "are")
 391                (length bb-board)
 392                (if (= (length bb-board) 1) "" "s")
 393                (length bb-balls-placed)))
 394      (t
 395       (setq bogus-balls (bb-show-bogus-balls bb-balls-placed bb-board))
 396       (if (= bogus-balls 0)
 397           (message "Right!  Your score is %d." bb-score)
 398         (message "Oops!  You missed %d ball%s.  Your score is %d."
 399                  bogus-balls
 400                  (if (= bogus-balls 1) "" "s")
 401                  (+ bb-score (* 5 bogus-balls))))
 402       (bb-goto '(-1 . -1))))))
 403
 404 (defun bb-show-bogus-balls (balls-placed board)
 405   (bb-show-bogus-balls-2 balls-placed board "x")
 406   (bb-show-bogus-balls-2 board balls-placed "o"))
 407
 408 (defun bb-show-bogus-balls-2 (list-1 list-2 c)
 409   (cond
 410    ((null list-1)
 411     0)
 412    ((member (car list-1) list-2)
 413     (bb-show-bogus-balls-2 (cdr list-1) list-2 c))
 414    (t
 415     (bb-goto (car list-1))
 416     (bb-update-board c)
 417     (1+ (bb-show-bogus-balls-2 (cdr list-1) list-2 c)))))
 418
 419 (defun bb-outside-box (x y)
 420   (or (= x -1) (= x 8) (= y -1) (= y 8)))
 421
 422 (defun bb-goto (pos)
 423   (goto-char (+ (* (car pos) 2) (* (cdr pos) 22) 26)))
 424
 425 (defun bb-update-board (c)
 426   (let ((buffer-read-only nil))
 427     (backward-char (1- (length c)))
 428     (delete-char (length c))
 429     (insert c)
 430     (backward-char 1)))
 431
 432 (provide 'blackbox)
 433
 434 ;;; arch-tag: 6c474c62-5617-4b10-9b44-ac430168c0e2
 435 ;;; blackbox.el ends here