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-2011 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 'forward-char 'bb-right)
 101     (blackbox-redefine-key map 'previous-line 'bb-up)
 102     (blackbox-redefine-key map 'next-line 'bb-down)
 103     (blackbox-redefine-key map 'move-end-of-line 'bb-eol)
 104     (blackbox-redefine-key map 'move-beginning-of-line 'bb-bol)
 105     (define-key map " " 'bb-romp)
 106     (define-key map "q" 'bury-buffer)
 107     (define-key map [insert] 'bb-romp)
 108     (define-key map [return] 'bb-done)
 109     (blackbox-redefine-key map 'newline 'bb-done)
 110     map))
 111
 112 ;; Blackbox mode is suitable only for specially formatted data.
 113 (put 'blackbox-mode 'mode-class 'special)
 114
 115 (defun blackbox-mode ()
 116   "Major mode for playing blackbox.
 117 To learn how to play blackbox, see the documentation for function `blackbox'.
 118
 119 The usual mnemonic keys move the cursor around the box.
 120 \\<blackbox-mode-map>\\[bb-bol] and \\[bb-eol] move to the beginning and end of line, respectively.
 121
 122 \\[bb-romp] -- send in a ray from point, or toggle a ball at point
 123 \\[bb-done] -- end game and get score"
 124   (interactive)
 125   (kill-all-local-variables)
 126   (use-local-map blackbox-mode-map)
 127   (setq truncate-lines t)
 128   (setq major-mode 'blackbox-mode)
 129   (setq mode-name "Blackbox")
 130   (run-mode-hooks 'blackbox-mode-hook))
 131
 132 ;;;###autoload
 133 (defun blackbox (num)
 134   "Play blackbox.
 135 Optional prefix argument is the number of balls; the default is 4.
 136
 137 What is blackbox?
 138
 139 Blackbox is a game of hide and seek played on an 8 by 8 grid (the
 140 Blackbox).  Your opponent (Emacs, in this case) has hidden several
 141 balls (usually 4) within this box.  By shooting rays into the box and
 142 observing where they emerge it is possible to deduce the positions of
 143 the hidden balls.  The fewer rays you use to find the balls, the lower
 144 your score.
 145
 146 Overview of play:
 147
 148 \\<blackbox-mode-map>\
 149 To play blackbox, type \\[blackbox].  An optional prefix argument
 150 specifies the number of balls to be hidden in the box; the default is
 151 four.
 152
 153 The cursor can be moved around the box with the standard cursor
 154 movement keys.
 155
 156 To shoot a ray, move the cursor to the edge of the box and press SPC.
 157 The result will be determined and the playfield updated.
 158
 159 You may place or remove balls in the box by moving the cursor into the
 160 box and pressing \\[bb-romp].
 161
 162 When you think the configuration of balls you have placed is correct,
 163 press \\[bb-done].  You will be informed whether you are correct or
 164 not, and be given your score.  Your score is the number of letters and
 165 numbers around the outside of the box plus five for each incorrectly
 166 placed ball.  If you placed any balls incorrectly, they will be
 167 indicated with `x', and their actual positions indicated with `o'.
 168
 169 Details:
 170
 171 There are three possible outcomes for each ray you send into the box:
 172
 173         Detour: the ray is deflected and emerges somewhere other than
 174                 where you sent it in.  On the playfield, detours are
 175                 denoted by matching pairs of numbers -- one where the
 176                 ray went in, and the other where it came out.
 177
 178         Reflection: the ray is reflected and emerges in the same place
 179                 it was sent in.  On the playfield, reflections are
 180                 denoted by the letter `R'.
 181
 182         Hit:    the ray strikes a ball directly and is absorbed.  It does
 183                 not emerge from the box.  On the playfield, hits are
 184                 denoted by the letter `H'.
 185
 186 The rules for how balls deflect rays are simple and are best shown by
 187 example.
 188
 189 As a ray approaches a ball it is deflected ninety degrees.  Rays can
 190 be deflected multiple times.  In the diagrams below, the dashes
 191 represent empty box locations and the letter `O' represents a ball.
 192 The entrance and exit points of each ray are marked with numbers as
 193 described under \"Detour\" above.  Note that the entrance and exit
 194 points are always interchangeable.  `*' denotes the path taken by the
 195 ray.
 196
 197 Note carefully the relative positions of the ball and the ninety
 198 degree deflection it causes.
 199
 200     1
 201   - * - - - - - -         - - - - - - - -         - - - - - - - -
 202   - * - - - - - -         - - - - - - - -         - - - - - - - -
 203 1 * * - - - - - -         - - - - - - - -         - O - - - - O -
 204   - - O - - - - -         - - O - - - - -         - - * * * * - -
 205   - - - - - - - -         - - - * * * * * 2     3 * * * - - * - -
 206   - - - - - - - -         - - - * - - - -         - - - O - * - -
 207   - - - - - - - -         - - - * - - - -         - - - - * * - -
 208   - - - - - - - -         - - - * - - - -         - - - - * - O -
 209                                 2                         3
 210
 211 As mentioned above, a reflection occurs when a ray emerges from the same point
 212 it was sent in.  This can happen in several ways:
 213
 214
 215   - - - - - - - -         - - - - - - - -          - - - - - - - -
 216   - - - - O - - -         - - O - O - - -          - - - - - - - -
 217 R * * * * - - - -         - - - * - - - -          O - - - - - - -
 218   - - - - O - - -         - - - * - - - -        R - - - - - - - -
 219   - - - - - - - -         - - - * - - - -          - - - - - - - -
 220   - - - - - - - -         - - - * - - - -          - - - - - - - -
 221   - - - - - - - -       R * * * * - - - -          - - - - - - - -
 222   - - - - - - - -         - - - - O - - -          - - - - - - - -
 223
 224 In the first example, the ray is deflected downwards by the upper
 225 ball, then left by the lower ball, and finally retraces its path to
 226 its point of origin.  The second example is similar.  The third
 227 example is a bit anomalous but can be rationalized by realizing the
 228 ray never gets a chance to get into the box.  Alternatively, the ray
 229 can be thought of as being deflected downwards and immediately
 230 emerging from the box.
 231
 232 A hit occurs when a ray runs straight into a ball:
 233
 234   - - - - - - - -         - - - - - - - -          - - - - - - - -
 235   - - - - - - - -         - - - - - - - -          - - - - O - - -
 236   - - - - - - - -         - - - - O - - -        H * * * * - - - -
 237   - - - - - - - -       H * * * * O - - -          - - - * - - - -
 238   - - - - - - - -         - - - - O - - -          - - - O - - - -
 239 H * * * O - - - -         - - - - - - - -          - - - - - - - -
 240   - - - - - - - -         - - - - - - - -          - - - - - - - -
 241   - - - - - - - -         - - - - - - - -          - - - - - - - -
 242
 243 Be sure to compare the second example of a hit with the first example of
 244 a reflection."
 245   (interactive "P")
 246   (switch-to-buffer "*Blackbox*")
 247   (blackbox-mode)
 248   (setq buffer-read-only t)
 249   (buffer-disable-undo (current-buffer))
 250   (setq bb-board (bb-init-board (or num 4)))
 251   (setq bb-balls-placed nil)
 252   (setq bb-x -1)
 253   (setq bb-y -1)
 254   (setq bb-score 0)
 255   (setq bb-detour-count 0)
 256   (bb-insert-board)
 257   (bb-goto (cons bb-x bb-y)))
 258
 259 (defun bb-init-board (num-balls)
 260   (random t)
 261   (let (board pos)
 262     (while (>= (setq num-balls (1- num-balls)) 0)
 263       (while
 264           (progn
 265             (setq pos (cons (random 8) (random 8)))
 266             (member pos board)))
 267       (setq board (cons pos board)))
 268     board))
 269
 270 (defun bb-insert-board ()
 271   (let (i (buffer-read-only nil))
 272     (erase-buffer)
 273     (insert "                     \n")
 274     (setq i 8)
 275     (while (>= (setq i (1- i)) 0)
 276       (insert "   - - - - - - - -   \n"))
 277     (insert "                     \n")
 278     (insert (format "\nThere are %d balls in the box" (length bb-board)))
 279     ))
 280
 281 (defun bb-right (count)
 282   (interactive "p")
 283   (while (and (> count 0) (< bb-x 8))
 284     (forward-char 2)
 285     (setq bb-x (1+ bb-x))
 286     (setq count (1- count))))
 287
 288 (defun bb-left (count)
 289   (interactive "p")
 290   (while (and (> count 0) (> bb-x -1))
 291     (backward-char 2)
 292     (setq bb-x (1- bb-x))
 293     (setq count (1- count))))
 294
 295 (defun bb-up (count)
 296   (interactive "p")
 297   (while (and (> count 0) (> bb-y -1))
 298     (with-no-warnings (previous-line))
 299     (setq bb-y (1- bb-y))
 300     (setq count (1- count))))
 301
 302 (defun bb-down (count)
 303   (interactive "p")
 304   (while (and (> count 0) (< bb-y 8))
 305     (with-no-warnings (next-line))
 306     (setq bb-y (1+ bb-y))
 307     (setq count (1- count))))
 308
 309 (defun bb-eol ()
 310   (interactive)
 311   (setq bb-x 8)
 312   (bb-goto (cons bb-x bb-y)))
 313
 314 (defun bb-bol ()
 315   (interactive)
 316   (setq bb-x -1)
 317   (bb-goto (cons bb-x bb-y)))
 318
 319 (defun bb-romp ()
 320   (interactive)
 321   (cond
 322    ((and
 323      (or (= bb-x -1) (= bb-x 8))
 324      (or (= bb-y -1) (= bb-y 8))))
 325    ((bb-outside-box bb-x bb-y)
 326     (bb-trace-ray bb-x bb-y))
 327    (t
 328     (bb-place-ball bb-x bb-y))))
 329
 330 (defun bb-place-ball (x y)
 331   (let ((coord (cons x y)))
 332     (cond
 333      ((member coord bb-balls-placed)
 334       (setq bb-balls-placed (delete coord bb-balls-placed))
 335       (bb-update-board "-"))
 336      (t
 337       (setq bb-balls-placed (cons coord bb-balls-placed))
 338       (bb-update-board (propertize "O" 'help-echo "Placed ball"))))))
 339
 340 (defun bb-trace-ray (x y)
 341   (when (= (following-char) 32)
 342     (let ((result (bb-trace-ray-2
 343                    t
 344                    x
 345                    (cond
 346                     ((= x -1) 1)
 347                     ((= x 8) -1)
 348                     (t 0))
 349                    y
 350                    (cond
 351                     ((= y -1) 1)
 352                     ((= y 8) -1)
 353                     (t 0)))))
 354       (cond
 355        ((eq result 'hit)
 356         (bb-update-board (propertize "H" 'help-echo "Hit"))
 357         (setq bb-score (1+ bb-score)))
 358        ((equal result (cons x y))
 359         (bb-update-board (propertize "R" 'help-echo "Reflection"))
 360         (setq bb-score (1+ bb-score)))
 361        (t
 362         (setq bb-detour-count (1+ bb-detour-count))
 363         (bb-update-board (propertize (format "%d" bb-detour-count)
 364                                      'help-echo "Detour"))
 365         (save-excursion
 366           (bb-goto result)
 367           (bb-update-board (propertize (format "%d" bb-detour-count)
 368                                        'help-echo "Detour")))
 369         (setq bb-score (+ bb-score 2)))))))
 370
 371 (defun bb-trace-ray-2 (first x dx y dy)
 372   (cond
 373    ((and (not first)
 374          (bb-outside-box x y))
 375     (cons x y))
 376    ((member (cons (+ x dx) (+ y dy)) bb-board)
 377     'hit)
 378    ((member (cons (+ x dx dy) (+ y dy dx)) bb-board)
 379     (bb-trace-ray-2 nil x (- dy) y (- dx)))
 380    ((member (cons (+ x dx (- dy)) (+ y dy (- dx))) bb-board)
 381     (bb-trace-ray-2 nil x dy y dx))
 382    (t
 383     (bb-trace-ray-2 nil (+ x dx) dx (+ y dy) dy))))
 384
 385 (defun bb-done ()
 386   "Finish the game and report score."
 387   (interactive)
 388   (let (bogus-balls)
 389     (cond
 390      ((not (= (length bb-balls-placed) (length bb-board)))
 391       (message "There %s %d hidden ball%s; you have placed %d."
 392                (if (= (length bb-board) 1) "is" "are")
 393                (length bb-board)
 394                (if (= (length bb-board) 1) "" "s")
 395                (length bb-balls-placed)))
 396      (t
 397       (setq bogus-balls (bb-show-bogus-balls bb-balls-placed bb-board))
 398       (if (= bogus-balls 0)
 399           (message "Right!  Your score is %d." bb-score)
 400         (message "Oops!  You missed %d ball%s.  Your score is %d."
 401                  bogus-balls
 402                  (if (= bogus-balls 1) "" "s")
 403                  (+ bb-score (* 5 bogus-balls))))
 404       (bb-goto '(-1 . -1))))))
 405
 406 (defun bb-show-bogus-balls (balls-placed board)
 407   (bb-show-bogus-balls-2 balls-placed board "x")
 408   (bb-show-bogus-balls-2 board balls-placed "o"))
 409
 410 (defun bb-show-bogus-balls-2 (list-1 list-2 c)
 411   (cond
 412    ((null list-1)
 413     0)
 414    ((member (car list-1) list-2)
 415     (bb-show-bogus-balls-2 (cdr list-1) list-2 c))
 416    (t
 417     (bb-goto (car list-1))
 418     (bb-update-board c)
 419     (1+ (bb-show-bogus-balls-2 (cdr list-1) list-2 c)))))
 420
 421 (defun bb-outside-box (x y)
 422   (or (= x -1) (= x 8) (= y -1) (= y 8)))
 423
 424 (defun bb-goto (pos)
 425   (goto-char (+ (* (car pos) 2) (* (cdr pos) 22) 26)))
 426
 427 (defun bb-update-board (c)
 428   (let ((buffer-read-only nil))
 429     (backward-char (1- (length c)))
 430     (delete-char (length c))
 431     (insert c)
 432     (backward-char 1)))
 433
 434 (provide 'blackbox)
 435
 436 ;;; blackbox.el ends here