![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to blackbox.el CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp|
Return to blackbox.el CVS log | Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp |
1.1 root 1: ; Blackbox game in Emacs Lisp
2:
3: ; by F. Thomas May
4: ; [email protected]
5:
6: (defvar blackbox-mode-map nil "")
7:
8: (if blackbox-mode-map
9: ()
10: (setq blackbox-mode-map (make-keymap))
11: (suppress-keymap blackbox-mode-map t)
12: (define-key blackbox-mode-map "\C-f" 'bb-right)
13: (define-key blackbox-mode-map "\C-b" 'bb-left)
14: (define-key blackbox-mode-map "\C-p" 'bb-up)
15: (define-key blackbox-mode-map "\C-n" 'bb-down)
16: (define-key blackbox-mode-map "\C-e" 'bb-eol)
17: (define-key blackbox-mode-map "\C-a" 'bb-bol)
18: (define-key blackbox-mode-map " " 'bb-romp)
19: (define-key blackbox-mode-map "\C-m" 'bb-done))
20:
21:
22: ;; Blackbox mode is suitable only for specially formatted data.
23: (put 'blackbox-mode 'mode-class 'special)
24:
25: (defun blackbox-mode ()
26: "Major mode for playing blackbox.
27:
28: SPC -- send in a ray from point, or toggle a ball
29: RET -- end game and get score
30:
31: Precisely,\\{blackbox-mode-map}"
32: (interactive)
33: (kill-all-local-variables)
34: (use-local-map blackbox-mode-map)
35: (setq truncate-lines t)
36: (setq major-mode 'blackbox-mode)
37: (setq mode-name "Blackbox"))
38:
39: (defun blackbox (num)
40: "Play blackbox. Arg is number of balls."
41: (interactive "P")
42: (switch-to-buffer "*Blackbox*")
43: (blackbox-mode)
44: (setq buffer-read-only t)
45: (buffer-flush-undo (current-buffer))
46: (setq bb-board (bb-init-board (or num 4)))
47: (setq bb-balls-placed nil)
48: (setq bb-x -1)
49: (setq bb-y -1)
50: (setq bb-score 0)
51: (setq bb-detour-count 0)
52: (bb-insert-board)
53: (bb-goto (cons bb-x bb-y)))
54:
55: (defun bb-init-board (num-balls)
56: (random t)
57: (let (board pos)
58: (while (>= (setq num-balls (1- num-balls)) 0)
59: (while
60: (progn
61: (setq pos (cons (logand (random) 7) (logand (random) 7)))
62: (bb-member pos board)))
63: (setq board (cons pos board)))
64: board))
65:
66: (defun bb-insert-board ()
67: (let (i (buffer-read-only nil))
68: (erase-buffer)
69: (insert " \n")
70: (setq i 8)
71: (while (>= (setq i (1- i)) 0)
72: (insert " - - - - - - - - \n"))
73: (insert " \n")))
74:
75: (defun bb-right ()
76: (interactive)
77: (if (= bb-x 8)
78: ()
79: (forward-char 2)
80: (setq bb-x (1+ bb-x))))
81:
82: (defun bb-left ()
83: (interactive)
84: (if (= bb-x -1)
85: ()
86: (backward-char 2)
87: (setq bb-x (1- bb-x))))
88:
89: (defun bb-up ()
90: (interactive)
91: (if (= bb-y -1)
92: ()
93: (previous-line 1)
94: (setq bb-y (1- bb-y))))
95:
96: (defun bb-down ()
97: (interactive)
98: (if (= bb-y 8)
99: ()
100: (next-line 1)
101: (setq bb-y (1+ bb-y))))
102:
103: (defun bb-eol ()
104: (interactive)
105: (setq bb-x 8)
106: (bb-goto (cons bb-x bb-y)))
107:
108: (defun bb-bol ()
109: (interactive)
110: (setq bb-x -1)
111: (bb-goto (cons bb-x bb-y)))
112:
113: (defun bb-romp ()
114: (interactive)
115: (cond
116: ((and
117: (or (= bb-x -1) (= bb-x 8))
118: (or (= bb-y -1) (= bb-y 8))))
119: ((bb-outside-box bb-x bb-y)
120: (bb-trace-ray bb-x bb-y))
121: (t
122: (bb-place-ball bb-x bb-y))))
123:
124: (defun bb-place-ball (x y)
125: (let ((coord (cons x y)))
126: (cond
127: ((bb-member coord bb-balls-placed)
128: (setq bb-balls-placed (bb-delete coord bb-balls-placed))
129: (bb-update-board "-"))
130: (t
131: (setq bb-balls-placed (cons coord bb-balls-placed))
132: (bb-update-board "O")))))
133:
134: (defun bb-trace-ray (x y)
135: (let ((result (bb-trace-ray-2
136: t
137: x
138: (cond
139: ((= x -1) 1)
140: ((= x 8) -1)
141: (t 0))
142: y
143: (cond
144: ((= y -1) 1)
145: ((= y 8) -1)
146: (t 0)))))
147: (cond
148: ((eq result 'hit)
149: (bb-update-board "H")
150: (setq bb-score (1+ bb-score)))
151: ((equal result (cons x y))
152: (bb-update-board "R")
153: (setq bb-score (1+ bb-score)))
154: (t
155: (setq bb-detour-count (1+ bb-detour-count))
156: (bb-update-board (format "%d" bb-detour-count))
157: (save-excursion
158: (bb-goto result)
159: (bb-update-board (format "%d" bb-detour-count)))
160: (setq bb-score (+ bb-score 2))))))
161:
162: (defun bb-trace-ray-2 (first x dx y dy)
163: (cond
164: ((and (not first)
165: (bb-outside-box x y))
166: (cons x y))
167: ((bb-member (cons (+ x dx) (+ y dy)) bb-board)
168: 'hit)
169: ((bb-member (cons (+ x dx dy) (+ y dy dx)) bb-board)
170: (bb-trace-ray-2 nil x (- dy) y (- dx)))
171: ((bb-member (cons (+ x dx (- dy)) (+ y dy (- dx))) bb-board)
172: (bb-trace-ray-2 nil x dy y dx))
173: (t
174: (bb-trace-ray-2 nil (+ x dx) dx (+ y dy) dy))))
175:
176: (defun bb-done ()
177: (interactive)
178: (let (bogus-balls)
179: (if (not (= (length bb-balls-placed) (length bb-board)))
180: (message "Spud! You have only %d balls in the box."
181: (length bb-balls-placed))
182: (setq bogus-balls (bb-show-bogus-balls bb-balls-placed bb-board))
183: (if (= bogus-balls 0)
184: (message "Right! Your score is %d." bb-score)
185: (setq bb-score (+ bb-score (* 5 bogus-balls)))
186: (message "Veg! You missed %d balls. Your score is %d."
187: bogus-balls bb-score))
188: (bb-goto '(-1 . -1)))))
189:
190: (defun bb-show-bogus-balls (balls-placed board)
191: (bb-show-bogus-balls-2 balls-placed board "x")
192: (bb-show-bogus-balls-2 board balls-placed "o"))
193:
194: (defun bb-show-bogus-balls-2 (list-1 list-2 c)
195: (cond
196: ((null list-1)
197: 0)
198: ((bb-member (car list-1) list-2)
199: (bb-show-bogus-balls-2 (cdr list-1) list-2 c))
200: (t
201: (bb-goto (car list-1))
202: (bb-update-board c)
203: (1+ (bb-show-bogus-balls-2 (cdr list-1) list-2 c)))))
204:
205: (defun bb-outside-box (x y)
206: (or (= x -1) (= x 8) (= y -1) (= y 8)))
207:
208: (defun bb-goto (pos)
209: (goto-char (+ (* (car pos) 2) (* (cdr pos) 22) 26)))
210:
211: (defun bb-update-board (c)
212: (let ((buffer-read-only nil))
213: (backward-char (1- (length c)))
214: (delete-char (length c))
215: (insert c)
216: (backward-char 1)))
217:
218: (defun bb-member (elt list)
219: "Returns non-nil if ELT is an element of LIST. Comparison done with equal."
220: (eval (cons 'or (mapcar (function (lambda (x) (equal x elt))) list))))
221:
222: (defun bb-delete (item list)
223: "Deletes ITEM from LIST and returns a copy."
224: (cond
225: ((equal item (car list)) (cdr list))
226: (t (cons (car list) (bb-delete item (cdr list))))))
227:
228:
229:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.