/[emacs]/emacs/lisp/play/blackbox.el
ViewVC logotype

Diff of /emacs/lisp/play/blackbox.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.11 by pj, Thu Nov 29 08:39:25 2001 UTC revision 1.12 by pj, Thu Dec 20 06:50:42 2001 UTC
# Line 1  Line 1 
1  ;;; blackbox.el --- blackbox game in Emacs Lisp  ;;; blackbox.el --- blackbox game in Emacs Lisp
2    
3  ;; Copyright (C) 1985, 1986, 1987, 1992 Free Software Foundation, Inc.  ;; Copyright (C) 1985, 1986, 1987, 1992, 2001 Free Software Foundation, Inc.
4    
5  ;; Author: F. Thomas May <uw-nsr!uw-warp!tom@beaver.cs.washington.edu>  ;; Author: F. Thomas May <uw-nsr!uw-warp!tom@beaver.cs.washington.edu>
6  ;; Adapted-By: ESR  ;; Adapted-By: ESR
# Line 70  Line 70 
70    
71  (defvar blackbox-mode-map nil "")  (defvar blackbox-mode-map nil "")
72    
73  (if blackbox-mode-map  (defvar bb-board nil
74      ()    "Blackbox board.")
75    
76    (defvar bb-x -1
77      "Current x-position.")
78    
79    (defvar bb-y -1
80      "Current y-position.")
81    
82    (defvar bb-score 0
83      "Current score.")
84    
85    (defvar bb-detour-count 0
86      "Number of detours.")
87    
88    (defvar bb-balls-placed nil
89      "List of already placed balls.")
90    
91    (unless blackbox-mode-map
92    (setq blackbox-mode-map (make-keymap))    (setq blackbox-mode-map (make-keymap))
93    (suppress-keymap blackbox-mode-map t)    (suppress-keymap blackbox-mode-map t)
94    (define-key blackbox-mode-map "\C-f" 'bb-right)    (define-key blackbox-mode-map "\C-f" 'bb-right)
# Line 243  a reflection." Line 260  a reflection."
260        (while        (while
261            (progn            (progn
262              (setq pos (cons (random 8) (random 8)))              (setq pos (cons (random 8) (random 8)))
263              (bb-member pos board)))              (member pos board)))
264        (setq board (cons pos board)))        (setq board (cons pos board)))
265      board))      board))
266    
# Line 310  a reflection." Line 327  a reflection."
327  (defun bb-place-ball (x y)  (defun bb-place-ball (x y)
328    (let ((coord (cons x y)))    (let ((coord (cons x y)))
329      (cond      (cond
330       ((bb-member coord bb-balls-placed)       ((member coord bb-balls-placed)
331        (setq bb-balls-placed (bb-delete coord bb-balls-placed))        (setq bb-balls-placed (delete coord bb-balls-placed))
332        (bb-update-board "-"))        (bb-update-board "-"))
333       (t       (t
334        (setq bb-balls-placed (cons coord bb-balls-placed))        (setq bb-balls-placed (cons coord bb-balls-placed))
335        (bb-update-board "O")))))        (bb-update-board (propertize "O" 'help-echo "Placed ball"))))))
336    
337  (defun bb-trace-ray (x y)  (defun bb-trace-ray (x y)
338    (let ((result (bb-trace-ray-2    (let ((result (bb-trace-ray-2
# Line 332  a reflection." Line 349  a reflection."
349                    (t 0)))))                    (t 0)))))
350      (cond      (cond
351       ((eq result 'hit)       ((eq result 'hit)
352        (bb-update-board "H")        (bb-update-board (propertize "H" 'help-echo "Hit"))
353        (setq bb-score (1+ bb-score)))        (setq bb-score (1+ bb-score)))
354       ((equal result (cons x y))       ((equal result (cons x y))
355        (bb-update-board "R")        (bb-update-board (propertize "R" 'help-echo "Reflection"))
356        (setq bb-score (1+ bb-score)))        (setq bb-score (1+ bb-score)))
357       (t       (t
358        (setq bb-detour-count (1+ bb-detour-count))        (setq bb-detour-count (1+ bb-detour-count))
359        (bb-update-board (format "%d" bb-detour-count))        (bb-update-board (propertize (format "%d" bb-detour-count)
360                                       'help-echo "Detour"))
361        (save-excursion        (save-excursion
362          (bb-goto result)          (bb-goto result)
363          (bb-update-board (format "%d" bb-detour-count)))          (bb-update-board (propertize (format "%d" bb-detour-count)
364                                         'help-echo "Detour")))
365        (setq bb-score (+ bb-score 2))))))        (setq bb-score (+ bb-score 2))))))
366    
367  (defun bb-trace-ray-2 (first x dx y dy)  (defun bb-trace-ray-2 (first x dx y dy)
# Line 350  a reflection." Line 369  a reflection."
369     ((and (not first)     ((and (not first)
370           (bb-outside-box x y))           (bb-outside-box x y))
371      (cons x y))      (cons x y))
372     ((bb-member (cons (+ x dx) (+ y dy)) bb-board)     ((member (cons (+ x dx) (+ y dy)) bb-board)
373      'hit)      'hit)
374     ((bb-member (cons (+ x dx dy) (+ y dy dx)) bb-board)     ((member (cons (+ x dx dy) (+ y dy dx)) bb-board)
375      (bb-trace-ray-2 nil x (- dy) y (- dx)))      (bb-trace-ray-2 nil x (- dy) y (- dx)))
376     ((bb-member (cons (+ x dx (- dy)) (+ y dy (- dx))) bb-board)     ((member (cons (+ x dx (- dy)) (+ y dy (- dx))) bb-board)
377      (bb-trace-ray-2 nil x dy y dx))      (bb-trace-ray-2 nil x dy y dx))
378     (t     (t
379      (bb-trace-ray-2 nil (+ x dx) dx (+ y dy) dy))))      (bb-trace-ray-2 nil (+ x dx) dx (+ y dy) dy))))
# Line 388  a reflection." Line 407  a reflection."
407    (cond    (cond
408     ((null list-1)     ((null list-1)
409      0)      0)
410     ((bb-member (car list-1) list-2)     ((member (car list-1) list-2)
411      (bb-show-bogus-balls-2 (cdr list-1) list-2 c))      (bb-show-bogus-balls-2 (cdr list-1) list-2 c))
412     (t     (t
413      (bb-goto (car list-1))      (bb-goto (car list-1))
# Line 408  a reflection." Line 427  a reflection."
427      (insert c)      (insert c)
428      (backward-char 1)))      (backward-char 1)))
429        
 (defun bb-member (elt list)  
   "Returns non-nil if ELT is an element of LIST."  
   (eval (cons 'or (mapcar (function (lambda (x) (equal x elt))) list))))  
   
 (defun bb-delete (item list)  
   "Deletes ITEM from LIST and returns a copy."  
   (cond  
    ((equal item (car list)) (cdr list))  
    (t (cons (car list) (bb-delete item (cdr list))))))  
   
430  (provide 'blackbox)  (provide 'blackbox)
431    
432  ;;; blackbox.el ends here  ;;; blackbox.el ends here

Legend:
Removed from v.1.11  
changed lines
  Added in v.1.12

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26