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

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