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 |
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) |
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 |
|
|
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 |
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) |
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)))) |
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)) |
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 |