230 lines
5.7 KiB
EmacsLisp
230 lines
5.7 KiB
EmacsLisp
; Blackbox game in Emacs Lisp
|
|
|
|
; by F. Thomas May
|
|
; uw-nsr!uw-warp!tom@beaver.cs.washington.edu
|
|
|
|
(defvar blackbox-mode-map nil "")
|
|
|
|
(if blackbox-mode-map
|
|
()
|
|
(setq blackbox-mode-map (make-keymap))
|
|
(suppress-keymap blackbox-mode-map t)
|
|
(define-key blackbox-mode-map "\C-f" 'bb-right)
|
|
(define-key blackbox-mode-map "\C-b" 'bb-left)
|
|
(define-key blackbox-mode-map "\C-p" 'bb-up)
|
|
(define-key blackbox-mode-map "\C-n" 'bb-down)
|
|
(define-key blackbox-mode-map "\C-e" 'bb-eol)
|
|
(define-key blackbox-mode-map "\C-a" 'bb-bol)
|
|
(define-key blackbox-mode-map " " 'bb-romp)
|
|
(define-key blackbox-mode-map "\C-m" 'bb-done))
|
|
|
|
|
|
;; Blackbox mode is suitable only for specially formatted data.
|
|
(put 'blackbox-mode 'mode-class 'special)
|
|
|
|
(defun blackbox-mode ()
|
|
"Major mode for playing blackbox.
|
|
|
|
SPC -- send in a ray from point, or toggle a ball
|
|
RET -- end game and get score
|
|
|
|
Precisely,\\{blackbox-mode-map}"
|
|
(interactive)
|
|
(kill-all-local-variables)
|
|
(use-local-map blackbox-mode-map)
|
|
(setq truncate-lines t)
|
|
(setq major-mode 'blackbox-mode)
|
|
(setq mode-name "Blackbox"))
|
|
|
|
(defun blackbox (num)
|
|
"Play blackbox. Arg is number of balls."
|
|
(interactive "P")
|
|
(switch-to-buffer "*Blackbox*")
|
|
(blackbox-mode)
|
|
(setq buffer-read-only t)
|
|
(buffer-flush-undo (current-buffer))
|
|
(setq bb-board (bb-init-board (or num 4)))
|
|
(setq bb-balls-placed nil)
|
|
(setq bb-x -1)
|
|
(setq bb-y -1)
|
|
(setq bb-score 0)
|
|
(setq bb-detour-count 0)
|
|
(bb-insert-board)
|
|
(bb-goto (cons bb-x bb-y)))
|
|
|
|
(defun bb-init-board (num-balls)
|
|
(random t)
|
|
(let (board pos)
|
|
(while (>= (setq num-balls (1- num-balls)) 0)
|
|
(while
|
|
(progn
|
|
(setq pos (cons (logand (random) 7) (logand (random) 7)))
|
|
(bb-member pos board)))
|
|
(setq board (cons pos board)))
|
|
board))
|
|
|
|
(defun bb-insert-board ()
|
|
(let (i (buffer-read-only nil))
|
|
(erase-buffer)
|
|
(insert " \n")
|
|
(setq i 8)
|
|
(while (>= (setq i (1- i)) 0)
|
|
(insert " - - - - - - - - \n"))
|
|
(insert " \n")))
|
|
|
|
(defun bb-right ()
|
|
(interactive)
|
|
(if (= bb-x 8)
|
|
()
|
|
(forward-char 2)
|
|
(setq bb-x (1+ bb-x))))
|
|
|
|
(defun bb-left ()
|
|
(interactive)
|
|
(if (= bb-x -1)
|
|
()
|
|
(backward-char 2)
|
|
(setq bb-x (1- bb-x))))
|
|
|
|
(defun bb-up ()
|
|
(interactive)
|
|
(if (= bb-y -1)
|
|
()
|
|
(previous-line 1)
|
|
(setq bb-y (1- bb-y))))
|
|
|
|
(defun bb-down ()
|
|
(interactive)
|
|
(if (= bb-y 8)
|
|
()
|
|
(next-line 1)
|
|
(setq bb-y (1+ bb-y))))
|
|
|
|
(defun bb-eol ()
|
|
(interactive)
|
|
(setq bb-x 8)
|
|
(bb-goto (cons bb-x bb-y)))
|
|
|
|
(defun bb-bol ()
|
|
(interactive)
|
|
(setq bb-x -1)
|
|
(bb-goto (cons bb-x bb-y)))
|
|
|
|
(defun bb-romp ()
|
|
(interactive)
|
|
(cond
|
|
((and
|
|
(or (= bb-x -1) (= bb-x 8))
|
|
(or (= bb-y -1) (= bb-y 8))))
|
|
((bb-outside-box bb-x bb-y)
|
|
(bb-trace-ray bb-x bb-y))
|
|
(t
|
|
(bb-place-ball bb-x bb-y))))
|
|
|
|
(defun bb-place-ball (x y)
|
|
(let ((coord (cons x y)))
|
|
(cond
|
|
((bb-member coord bb-balls-placed)
|
|
(setq bb-balls-placed (bb-delete coord bb-balls-placed))
|
|
(bb-update-board "-"))
|
|
(t
|
|
(setq bb-balls-placed (cons coord bb-balls-placed))
|
|
(bb-update-board "O")))))
|
|
|
|
(defun bb-trace-ray (x y)
|
|
(let ((result (bb-trace-ray-2
|
|
t
|
|
x
|
|
(cond
|
|
((= x -1) 1)
|
|
((= x 8) -1)
|
|
(t 0))
|
|
y
|
|
(cond
|
|
((= y -1) 1)
|
|
((= y 8) -1)
|
|
(t 0)))))
|
|
(cond
|
|
((eq result 'hit)
|
|
(bb-update-board "H")
|
|
(setq bb-score (1+ bb-score)))
|
|
((equal result (cons x y))
|
|
(bb-update-board "R")
|
|
(setq bb-score (1+ bb-score)))
|
|
(t
|
|
(setq bb-detour-count (1+ bb-detour-count))
|
|
(bb-update-board (format "%d" bb-detour-count))
|
|
(save-excursion
|
|
(bb-goto result)
|
|
(bb-update-board (format "%d" bb-detour-count)))
|
|
(setq bb-score (+ bb-score 2))))))
|
|
|
|
(defun bb-trace-ray-2 (first x dx y dy)
|
|
(cond
|
|
((and (not first)
|
|
(bb-outside-box x y))
|
|
(cons x y))
|
|
((bb-member (cons (+ x dx) (+ y dy)) bb-board)
|
|
'hit)
|
|
((bb-member (cons (+ x dx dy) (+ y dy dx)) bb-board)
|
|
(bb-trace-ray-2 nil x (- dy) y (- dx)))
|
|
((bb-member (cons (+ x dx (- dy)) (+ y dy (- dx))) bb-board)
|
|
(bb-trace-ray-2 nil x dy y dx))
|
|
(t
|
|
(bb-trace-ray-2 nil (+ x dx) dx (+ y dy) dy))))
|
|
|
|
(defun bb-done ()
|
|
(interactive)
|
|
(let (bogus-balls)
|
|
(if (not (= (length bb-balls-placed) (length bb-board)))
|
|
(message "Spud! You have only %d balls in the box."
|
|
(length bb-balls-placed))
|
|
(setq bogus-balls (bb-show-bogus-balls bb-balls-placed bb-board))
|
|
(if (= bogus-balls 0)
|
|
(message "Right! Your score is %d." bb-score)
|
|
(setq bb-score (+ bb-score (* 5 bogus-balls)))
|
|
(message "Veg! You missed %d balls. Your score is %d."
|
|
bogus-balls bb-score))
|
|
(bb-goto '(-1 . -1)))))
|
|
|
|
(defun bb-show-bogus-balls (balls-placed board)
|
|
(bb-show-bogus-balls-2 balls-placed board "x")
|
|
(bb-show-bogus-balls-2 board balls-placed "o"))
|
|
|
|
(defun bb-show-bogus-balls-2 (list-1 list-2 c)
|
|
(cond
|
|
((null list-1)
|
|
0)
|
|
((bb-member (car list-1) list-2)
|
|
(bb-show-bogus-balls-2 (cdr list-1) list-2 c))
|
|
(t
|
|
(bb-goto (car list-1))
|
|
(bb-update-board c)
|
|
(1+ (bb-show-bogus-balls-2 (cdr list-1) list-2 c)))))
|
|
|
|
(defun bb-outside-box (x y)
|
|
(or (= x -1) (= x 8) (= y -1) (= y 8)))
|
|
|
|
(defun bb-goto (pos)
|
|
(goto-char (+ (* (car pos) 2) (* (cdr pos) 22) 26)))
|
|
|
|
(defun bb-update-board (c)
|
|
(let ((buffer-read-only nil))
|
|
(backward-char (1- (length c)))
|
|
(delete-char (length c))
|
|
(insert c)
|
|
(backward-char 1)))
|
|
|
|
(defun bb-member (elt list)
|
|
"Returns non-nil if ELT is an element of LIST. Comparison done with equal."
|
|
(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))))))
|
|
|
|
|
|
|