![[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.