home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / packages / blackbox.el < prev    next >
Encoding:
Text File  |  1992-06-29  |  11.8 KB  |  367 lines
  1. ;  Blackbox game in Emacs Lisp
  2. ;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of GNU Emacs.
  5.  
  6. ;; GNU Emacs is free software; you can redistribute it and/or modify
  7. ;; it under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation; either version 1, or (at your option)
  9. ;; any later version.
  10.  
  11. ;; GNU Emacs is distributed in the hope that it will be useful,
  12. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;; GNU General Public License for more details.
  15.  
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  18. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. ;  by F. Thomas May
  21. ;  uw-nsr!uw-warp!tom@beaver.cs.washington.edu
  22.  
  23. (defvar blackbox-mode-map nil "")
  24.  
  25. (if blackbox-mode-map
  26.     ()
  27.   (setq blackbox-mode-map (make-keymap))
  28.   (suppress-keymap blackbox-mode-map t)
  29.   (define-key blackbox-mode-map "\C-f" 'bb-right)
  30.   (define-key blackbox-mode-map "\C-b" 'bb-left)
  31.   (define-key blackbox-mode-map "\C-p" 'bb-up)
  32.   (define-key blackbox-mode-map "\C-n" 'bb-down)
  33.   (define-key blackbox-mode-map "\C-e" 'bb-eol)
  34.   (define-key blackbox-mode-map "\C-a" 'bb-bol)
  35.   (define-key blackbox-mode-map " " 'bb-romp)
  36.   (define-key blackbox-mode-map "\C-m" 'bb-done))
  37.  
  38.  
  39. ;; Blackbox mode is suitable only for specially formatted data.
  40. (put 'blackbox-mode 'mode-class 'special)
  41.  
  42. (defun blackbox-mode ()
  43.   "Major mode for playing blackbox.  To learn how to play blackbox,
  44. see the documentation for function  blackbox.
  45.  
  46. The usual mnemonic keys move the cursor around the box.
  47. C-a and C-e move to the beginning and end of line, respectively.
  48. Using other methods of moving point loses.
  49.  
  50. SPC -- send in a ray from point, or toggle a ball at point
  51. RET -- end game and get score
  52.  
  53. Precisely,\\{blackbox-mode-map}"
  54.   (interactive)
  55.   (kill-all-local-variables)
  56.   (use-local-map blackbox-mode-map)
  57.   (setq truncate-lines t)
  58.   (setq major-mode 'blackbox-mode)
  59.   (setq mode-name "Blackbox"))
  60.  
  61. (defun blackbox (num)
  62.   "Play blackbox.  Arg is number of balls; default is 4.
  63.  
  64. What is blackbox?
  65.  
  66. Blackbox is a game of hide and seek played on an 8 by 8 grid (the
  67. Blackbox).  Your opponent (Emacs, in this case) has hidden several
  68. balls (usually 4) within this box.  By shooting rays into the box and
  69. observing where they emerge it is possible to deduce the positions of
  70. the hidden balls.  The fewer rays you use to find the balls, the lower
  71. your score.
  72.  
  73. Overview of play:
  74.  
  75. To play blackbox, call the function blackbox.  An optional prefix
  76. argument specifies the number of balls to be hidden in the box; the
  77. default is four.
  78.  
  79. The cursor can be moved around the box with the standard cursor
  80. movement keys.  Using any other form of cursor movement is guaranteed
  81. not to work correctly.
  82.  
  83. To shoot a ray, move the cursor to the edge of the box and press SPC.
  84. The result will be determined and the playfield updated.
  85.  
  86. You may place or remove balls in the box by moving the cursor into the
  87. box and pressing SPC.
  88.  
  89. When you think the configuration of balls you have placed is correct,
  90. press RET.  You will be informed whether you are correct or not, and
  91. be given your score.  Your score is the number of letters and numbers
  92. around the outside of the box plus five for each incorrectly placed
  93. ball.  If you placed any balls incorrectly, they will be indicated
  94. with 'x', and their actual positions indicated with 'o'.
  95.  
  96. Details:
  97.  
  98. There are three possible outcomes for each ray you send into the box:
  99.  
  100.     Detour: the ray is deflected and emerges somewhere other than
  101.         where you sent it in.  On the playfield, detours are
  102.         denoted by matching pairs of numbers -- one where the
  103.         ray went in, and the other where it came out.
  104.  
  105.     Reflection: the ray is reflected and emerges in the same place
  106.         it was sent in.  On the playfield, reflections are
  107.         denoted by the letter 'R'.
  108.  
  109.     Hit:    the ray strikes a ball directly and is absorbed.  It does
  110.         not emerge from the box.  On the playfield, hits are
  111.         denoted by the letter 'H'.
  112.  
  113. The rules for how balls deflect rays are simple and are best shown by
  114. example.
  115.  
  116. As a ray approaches a ball it is deflected ninety degrees.  Rays can
  117. be deflected multiple times.  In the diagrams below, the dashes
  118. represent empty box locations and the letter 'O' represents a ball.
  119. The entrance and exit points of each ray are marked with numbers as
  120. described under 'Detour' above.  Note that the entrance and exit
  121. points are always interchangeable.  '*' denotes the path taken by the
  122. ray.
  123.  
  124. Note carefully the relative positions of the ball and the ninety
  125. degree deflection it causes.
  126.  
  127.     1                                            
  128.   - * - - - - - -         - - - - - - - -         - - - - - - - -       
  129.   - * - - - - - -         - - - - - - - -         - - - - - - - -       
  130. 1 * * - - - - - -         - - - - - - - -         - O - - - - O -       
  131.   - - O - - - - -         - - O - - - - -         - - * * * * - -
  132.   - - - - - - - -         - - - * * * * * 2     3 * * * - - * - -
  133.   - - - - - - - -         - - - * - - - -         - - - O - * - -      
  134.   - - - - - - - -         - - - * - - - -         - - - - * * - -       
  135.   - - - - - - - -         - - - * - - - -         - - - - * - O -       
  136.                                 2                         3
  137.  
  138. As mentioned above, a reflection occurs when a ray emerges from the same point
  139. it was sent in.  This can happen in several ways:
  140.  
  141.                                                                            
  142.   - - - - - - - -         - - - - - - - -          - - - - - - - -
  143.   - - - - O - - -         - - O - O - - -          - - - - - - - -
  144. R * * * * - - - -         - - - * - - - -          O - - - - - - -
  145.   - - - - O - - -         - - - * - - - -        R - - - - - - - -
  146.   - - - - - - - -         - - - * - - - -          - - - - - - - -
  147.   - - - - - - - -         - - - * - - - -          - - - - - - - -
  148.   - - - - - - - -       R * * * * - - - -          - - - - - - - -
  149.   - - - - - - - -         - - - - O - - -          - - - - - - - -
  150.  
  151. In the first example, the ray is deflected downwards by the upper ball,
  152. then left by the lower ball, and finally retraces its path to its point
  153. of origin.  The second example is similar.  The third example is a bit
  154. anomalous but can be rationalized by realizing the ray never gets a chance
  155. to get into the box.  Alternatively, the ray can be thought of as being
  156. deflected downwards and immediately emerging from the box.
  157.  
  158. A hit occurs when a ray runs straight into a ball:
  159.  
  160.   - - - - - - - -         - - - - - - - -          - - - - - - - -
  161.   - - - - - - - -         - - - - - - - -          - - - - O - - -
  162.   - - - - - - - -         - - - - O - - -        H * * * * - - - -
  163.   - - - - - - - -       H * * * * O - - -          - - - * - - - -
  164.   - - - - - - - -         - - - - O - - -          - - - O - - - -
  165. H * * * O - - - -         - - - - - - - -          - - - - - - - -
  166.   - - - - - - - -         - - - - - - - -          - - - - - - - -
  167.   - - - - - - - -         - - - - - - - -          - - - - - - - -
  168.  
  169. Be sure to compare the second example of a hit with the first example of
  170. a reflection."
  171.   (interactive "P")
  172.   (switch-to-buffer "*Blackbox*")
  173.   (blackbox-mode)
  174.   (setq buffer-read-only t)
  175.   (buffer-disable-undo (current-buffer))
  176.   (setq bb-board (bb-init-board (or num 4)))
  177.   (setq bb-balls-placed nil)
  178.   (setq bb-x -1)
  179.   (setq bb-y -1)
  180.   (setq bb-score 0)
  181.   (setq bb-detour-count 0)
  182.   (bb-insert-board)
  183.   (bb-goto (cons bb-x bb-y)))
  184.  
  185. (defun bb-init-board (num-balls)
  186.   (random t)
  187.   (let (board pos)
  188.     (while (>= (setq num-balls (1- num-balls)) 0)
  189.       (while
  190.       (progn
  191.         (setq pos (cons (random 8) (random 8)))
  192.         (bb-member pos board)))
  193.       (setq board (cons pos board)))
  194.     board))
  195.  
  196. (defun bb-insert-board ()
  197.   (let (i (buffer-read-only nil))
  198.     (erase-buffer)
  199.     (insert "                     \n")
  200.     (setq i 8)
  201.     (while (>= (setq i (1- i)) 0)
  202.       (insert "   - - - - - - - -   \n"))
  203.     (insert "                     \n")))
  204.  
  205. (defun bb-right ()
  206.   (interactive)
  207.   (if (= bb-x 8)
  208.       ()
  209.     (forward-char 2)
  210.     (setq bb-x (1+ bb-x))))
  211.  
  212. (defun bb-left ()
  213.   (interactive)
  214.   (if (= bb-x -1)
  215.       ()
  216.     (backward-char 2)
  217.     (setq bb-x (1- bb-x))))
  218.  
  219. (defun bb-up ()
  220.   (interactive)
  221.   (if (= bb-y -1)
  222.       ()
  223.     (previous-line 1)
  224.     (setq bb-y (1- bb-y))))
  225.  
  226. (defun bb-down ()
  227.   (interactive)
  228.   (if (= bb-y 8)
  229.       ()
  230.     (next-line 1)
  231.     (setq bb-y (1+ bb-y))))
  232.  
  233. (defun bb-eol ()
  234.   (interactive)
  235.   (setq bb-x 8)
  236.   (bb-goto (cons bb-x bb-y)))
  237.  
  238. (defun bb-bol ()
  239.   (interactive)
  240.   (setq bb-x -1)
  241.   (bb-goto (cons bb-x bb-y)))
  242.  
  243. (defun bb-romp ()
  244.   (interactive)
  245.   (cond
  246.    ((and
  247.      (or (= bb-x -1) (= bb-x 8))
  248.      (or (= bb-y -1) (= bb-y 8))))
  249.    ((bb-outside-box bb-x bb-y)
  250.     (bb-trace-ray bb-x bb-y))
  251.    (t
  252.     (bb-place-ball bb-x bb-y))))
  253.  
  254. (defun bb-place-ball (x y)
  255.   (let ((coord (cons x y)))
  256.     (cond
  257.      ((bb-member coord bb-balls-placed)
  258.       (setq bb-balls-placed (bb-delete coord bb-balls-placed))
  259.       (bb-update-board "-"))
  260.      (t
  261.       (setq bb-balls-placed (cons coord bb-balls-placed))
  262.       (bb-update-board "O")))))
  263.  
  264. (defun bb-trace-ray (x y)
  265.   (let ((result (bb-trace-ray-2
  266.          t
  267.          x
  268.          (cond
  269.           ((= x -1) 1)
  270.           ((= x 8) -1)
  271.           (t 0))
  272.          y
  273.          (cond
  274.           ((= y -1) 1)
  275.           ((= y 8) -1)
  276.           (t 0)))))
  277.     (cond
  278.      ((eq result 'hit)
  279.       (bb-update-board "H")
  280.       (setq bb-score (1+ bb-score)))
  281.      ((equal result (cons x y))
  282.       (bb-update-board "R")
  283.       (setq bb-score (1+ bb-score)))
  284.      (t
  285.       (setq bb-detour-count (1+ bb-detour-count))
  286.       (bb-update-board (format "%d" bb-detour-count))
  287.       (save-excursion
  288.     (bb-goto result)
  289.     (bb-update-board (format "%d" bb-detour-count)))
  290.       (setq bb-score (+ bb-score 2))))))
  291.  
  292. (defun bb-trace-ray-2 (first x dx y dy)
  293.   (cond
  294.    ((and (not first)
  295.      (bb-outside-box x y))
  296.     (cons x y))
  297.    ((bb-member (cons (+ x dx) (+ y dy)) bb-board)
  298.     'hit)
  299.    ((bb-member (cons (+ x dx dy) (+ y dy dx)) bb-board)
  300.     (bb-trace-ray-2 nil x (- dy) y (- dx)))
  301.    ((bb-member (cons (+ x dx (- dy)) (+ y dy (- dx))) bb-board)
  302.     (bb-trace-ray-2 nil x dy y dx))
  303.    (t
  304.     (bb-trace-ray-2 nil (+ x dx) dx (+ y dy) dy))))
  305.  
  306. (defun bb-done ()
  307.   "Finish the game and report score."
  308.   (interactive)
  309.   (let (bogus-balls)
  310.     (cond
  311.      ((not (= (length bb-balls-placed) (length bb-board)))
  312.       (message "There %s %d hidden ball%s; you have placed %d."
  313.            (if (= (length bb-board) 1) "is" "are")
  314.            (length bb-board)
  315.            (if (= (length bb-board) 1) "" "s")
  316.            (length bb-balls-placed)))
  317.      (t
  318.       (setq bogus-balls (bb-show-bogus-balls bb-balls-placed bb-board))
  319.       (if (= bogus-balls 0)
  320.       (message "Right!  Your score is %d." bb-score)
  321.     (message "Oops!  You missed %d ball%s.  Your score is %d."
  322.          bogus-balls
  323.          (if (= bogus-balls 1) "" "s")
  324.          (+ bb-score (* 5 bogus-balls))))
  325.       (bb-goto '(-1 . -1))))))
  326.  
  327. (defun bb-show-bogus-balls (balls-placed board)
  328.   (bb-show-bogus-balls-2 balls-placed board "x")
  329.   (bb-show-bogus-balls-2 board balls-placed "o"))
  330.  
  331. (defun bb-show-bogus-balls-2 (list-1 list-2 c)
  332.   (cond
  333.    ((null list-1)
  334.     0)
  335.    ((bb-member (car list-1) list-2)
  336.     (bb-show-bogus-balls-2 (cdr list-1) list-2 c))
  337.    (t
  338.     (bb-goto (car list-1))
  339.     (bb-update-board c)
  340.     (1+ (bb-show-bogus-balls-2 (cdr list-1) list-2 c)))))
  341.  
  342. (defun bb-outside-box (x y)
  343.   (or (= x -1) (= x 8) (= y -1) (= y 8)))
  344.  
  345. (defun bb-goto (pos)
  346.   (goto-char (+ (* (car pos) 2) (* (cdr pos) 22) 26)))
  347.  
  348. (defun bb-update-board (c)
  349.   (let ((buffer-read-only nil))
  350.     (backward-char (1- (length c)))
  351.     (delete-char (length c))
  352.     (insert c)
  353.     (backward-char 1)))
  354.   
  355. (defun bb-member (elt list)
  356.   "Returns non-nil if ELT is an element of LIST.  Comparison done with equal."
  357.   (eval (cons 'or (mapcar (function (lambda (x) (equal x elt))) list))))
  358.  
  359. (defun bb-delete (item list)
  360.   "Deletes ITEM from LIST and returns a copy."
  361.   (cond
  362.    ((equal item (car list)) (cdr list))
  363.    (t (cons (car list) (bb-delete item (cdr list))))))
  364.  
  365.  
  366.  
  367.