| 1 | ;;; snake.el --- implementation of Snake for Emacs |
| 2 | |
| 3 | ;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, |
| 4 | ;; 2006, 2007, 2008 Free Software Foundation, Inc. |
| 5 | |
| 6 | ;; Author: Glynn Clements <glynn@sensei.co.uk> |
| 7 | ;; Created: 1997-09-10 |
| 8 | ;; Keywords: games |
| 9 | |
| 10 | ;; This file is part of GNU Emacs. |
| 11 | |
| 12 | ;; GNU Emacs is free software; you can redistribute it and/or modify |
| 13 | ;; it under the terms of the GNU General Public License as published by |
| 14 | ;; the Free Software Foundation; either version 3, or (at your option) |
| 15 | ;; any later version. |
| 16 | |
| 17 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 20 | ;; GNU General Public License for more details. |
| 21 | |
| 22 | ;; You should have received a copy of the GNU General Public License |
| 23 | ;; along with GNU Emacs; see the file COPYING. If not, write to the |
| 24 | ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
| 25 | ;; Boston, MA 02110-1301, USA. |
| 26 | |
| 27 | ;;; Commentary: |
| 28 | |
| 29 | ;;; Code: |
| 30 | |
| 31 | (eval-when-compile |
| 32 | (require 'cl)) |
| 33 | |
| 34 | (require 'gamegrid) |
| 35 | |
| 36 | ;; ;;;;;;;;;;;;; customization variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 37 | |
| 38 | (defvar snake-use-glyphs-flag t |
| 39 | "Non-nil means use glyphs when available.") |
| 40 | |
| 41 | (defvar snake-use-color-flag t |
| 42 | "Non-nil means use color when available.") |
| 43 | |
| 44 | (defvar snake-buffer-name "*Snake*" |
| 45 | "Name used for Snake buffer.") |
| 46 | |
| 47 | (defvar snake-buffer-width 30 |
| 48 | "Width of used portion of buffer.") |
| 49 | |
| 50 | (defvar snake-buffer-height 22 |
| 51 | "Height of used portion of buffer.") |
| 52 | |
| 53 | (defvar snake-width 30 |
| 54 | "Width of playing area.") |
| 55 | |
| 56 | (defvar snake-height 20 |
| 57 | "Height of playing area.") |
| 58 | |
| 59 | (defvar snake-initial-length 5 |
| 60 | "Initial length of snake.") |
| 61 | |
| 62 | (defvar snake-initial-x 10 |
| 63 | "Initial X position of snake.") |
| 64 | |
| 65 | (defvar snake-initial-y 10 |
| 66 | "Initial Y position of snake.") |
| 67 | |
| 68 | (defvar snake-initial-velocity-x 1 |
| 69 | "Initial X velocity of snake.") |
| 70 | |
| 71 | (defvar snake-initial-velocity-y 0 |
| 72 | "Initial Y velocity of snake.") |
| 73 | |
| 74 | (defvar snake-tick-period 0.2 |
| 75 | "The default time taken for the snake to advance one square.") |
| 76 | |
| 77 | (defvar snake-mode-hook nil |
| 78 | "Hook run upon starting Snake.") |
| 79 | |
| 80 | (defvar snake-score-x 0 |
| 81 | "X position of score.") |
| 82 | |
| 83 | (defvar snake-score-y snake-height |
| 84 | "Y position of score.") |
| 85 | |
| 86 | ;; It is not safe to put this in /tmp. |
| 87 | ;; Someone could make a symlink in /tmp |
| 88 | ;; pointing to a file you don't want to clobber. |
| 89 | (defvar snake-score-file "snake-scores" |
| 90 | "File for holding high scores.") |
| 91 | |
| 92 | ;; ;;;;;;;;;;;;; display options ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 93 | |
| 94 | (defvar snake-blank-options |
| 95 | '(((glyph colorize) |
| 96 | (t ?\040)) |
| 97 | ((color-x color-x) |
| 98 | (mono-x grid-x) |
| 99 | (color-tty color-tty)) |
| 100 | (((glyph color-x) [0 0 0]) |
| 101 | (color-tty "black")))) |
| 102 | |
| 103 | (defvar snake-snake-options |
| 104 | '(((glyph colorize) |
| 105 | (emacs-tty ?O) |
| 106 | (t ?\040)) |
| 107 | ((color-x color-x) |
| 108 | (mono-x mono-x) |
| 109 | (color-tty color-tty) |
| 110 | (mono-tty mono-tty)) |
| 111 | (((glyph color-x) [1 1 0]) |
| 112 | (color-tty "yellow")))) |
| 113 | |
| 114 | (defvar snake-dot-options |
| 115 | '(((glyph colorize) |
| 116 | (t ?\*)) |
| 117 | ((color-x color-x) |
| 118 | (mono-x grid-x) |
| 119 | (color-tty color-tty)) |
| 120 | (((glyph color-x) [1 0 0]) |
| 121 | (color-tty "red")))) |
| 122 | |
| 123 | (defvar snake-border-options |
| 124 | '(((glyph colorize) |
| 125 | (t ?\+)) |
| 126 | ((color-x color-x) |
| 127 | (mono-x grid-x) |
| 128 | (color-tty color-tty)) |
| 129 | (((glyph color-x) [0.5 0.5 0.5]) |
| 130 | (color-tty "white")))) |
| 131 | |
| 132 | (defvar snake-space-options |
| 133 | '(((t ?\040)) |
| 134 | nil |
| 135 | nil)) |
| 136 | |
| 137 | ;; ;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 138 | |
| 139 | (defconst snake-blank 0) |
| 140 | (defconst snake-snake 1) |
| 141 | (defconst snake-dot 2) |
| 142 | (defconst snake-border 3) |
| 143 | (defconst snake-space 4) |
| 144 | |
| 145 | ;; ;;;;;;;;;;;;; variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 146 | |
| 147 | (defvar snake-length 0) |
| 148 | (defvar snake-velocity-x 1) |
| 149 | (defvar snake-velocity-y 0) |
| 150 | (defvar snake-positions nil) |
| 151 | (defvar snake-cycle 0) |
| 152 | (defvar snake-score 0) |
| 153 | (defvar snake-paused nil) |
| 154 | (defvar snake-moved-p nil) |
| 155 | (defvar snake-velocity-queue nil |
| 156 | "This queue stores the velocities requested too quickly by user. |
| 157 | They will take effect one at a time at each clock-interval. |
| 158 | This is necessary for proper behavior. |
| 159 | |
| 160 | For instance, if you are moving right, you press up and then left, you |
| 161 | want the snake to move up just once before starting to move left. If |
| 162 | we implemented all your keystrokes immediately, the snake would |
| 163 | effectively never move up. Thus, we need to move it up for one turn |
| 164 | and then start moving it leftwards.") |
| 165 | |
| 166 | |
| 167 | (make-variable-buffer-local 'snake-length) |
| 168 | (make-variable-buffer-local 'snake-velocity-x) |
| 169 | (make-variable-buffer-local 'snake-velocity-y) |
| 170 | (make-variable-buffer-local 'snake-positions) |
| 171 | (make-variable-buffer-local 'snake-cycle) |
| 172 | (make-variable-buffer-local 'snake-score) |
| 173 | (make-variable-buffer-local 'snake-paused) |
| 174 | (make-variable-buffer-local 'snake-moved-p) |
| 175 | (make-variable-buffer-local 'snake-velocity-queue) |
| 176 | |
| 177 | ;; ;;;;;;;;;;;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 178 | |
| 179 | (defvar snake-mode-map |
| 180 | (make-sparse-keymap 'snake-mode-map)) |
| 181 | |
| 182 | (define-key snake-mode-map "n" 'snake-start-game) |
| 183 | (define-key snake-mode-map "q" 'snake-end-game) |
| 184 | (define-key snake-mode-map "p" 'snake-pause-game) |
| 185 | |
| 186 | (define-key snake-mode-map [left] 'snake-move-left) |
| 187 | (define-key snake-mode-map [right] 'snake-move-right) |
| 188 | (define-key snake-mode-map [up] 'snake-move-up) |
| 189 | (define-key snake-mode-map [down] 'snake-move-down) |
| 190 | |
| 191 | (defvar snake-null-map |
| 192 | (make-sparse-keymap 'snake-null-map)) |
| 193 | |
| 194 | (define-key snake-null-map "n" 'snake-start-game) |
| 195 | |
| 196 | ;; ;;;;;;;;;;;;;;;; game functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 197 | |
| 198 | (defun snake-display-options () |
| 199 | (let ((options (make-vector 256 nil))) |
| 200 | (loop for c from 0 to 255 do |
| 201 | (aset options c |
| 202 | (cond ((= c snake-blank) |
| 203 | snake-blank-options) |
| 204 | ((= c snake-snake) |
| 205 | snake-snake-options) |
| 206 | ((= c snake-dot) |
| 207 | snake-dot-options) |
| 208 | ((= c snake-border) |
| 209 | snake-border-options) |
| 210 | ((= c snake-space) |
| 211 | snake-space-options) |
| 212 | (t |
| 213 | '(nil nil nil))))) |
| 214 | options)) |
| 215 | |
| 216 | (defun snake-update-score () |
| 217 | (let* ((string (format "Score: %05d" snake-score)) |
| 218 | (len (length string))) |
| 219 | (loop for x from 0 to (1- len) do |
| 220 | (gamegrid-set-cell (+ snake-score-x x) |
| 221 | snake-score-y |
| 222 | (aref string x))))) |
| 223 | |
| 224 | (defun snake-init-buffer () |
| 225 | (gamegrid-init-buffer snake-buffer-width |
| 226 | snake-buffer-height |
| 227 | snake-space) |
| 228 | (let ((buffer-read-only nil)) |
| 229 | (loop for y from 0 to (1- snake-height) do |
| 230 | (loop for x from 0 to (1- snake-width) do |
| 231 | (gamegrid-set-cell x y snake-border))) |
| 232 | (loop for y from 1 to (- snake-height 2) do |
| 233 | (loop for x from 1 to (- snake-width 2) do |
| 234 | (gamegrid-set-cell x y snake-blank))))) |
| 235 | |
| 236 | (defun snake-reset-game () |
| 237 | (gamegrid-kill-timer) |
| 238 | (snake-init-buffer) |
| 239 | (setq snake-length snake-initial-length |
| 240 | snake-velocity-x snake-initial-velocity-x |
| 241 | snake-velocity-y snake-initial-velocity-y |
| 242 | snake-positions nil |
| 243 | snake-cycle 1 |
| 244 | snake-score 0 |
| 245 | snake-paused nil |
| 246 | snake-moved-p nil |
| 247 | snake-velocity-queue nil) |
| 248 | (let ((x snake-initial-x) |
| 249 | (y snake-initial-y)) |
| 250 | (dotimes (i snake-length) |
| 251 | (gamegrid-set-cell x y snake-snake) |
| 252 | (setq snake-positions (cons (vector x y) snake-positions)) |
| 253 | (incf x snake-velocity-x) |
| 254 | (incf y snake-velocity-y))) |
| 255 | (snake-update-score)) |
| 256 | |
| 257 | (defun snake-update-game (snake-buffer) |
| 258 | "Called on each clock tick. |
| 259 | Advances the snake one square, testing for collision. |
| 260 | Argument SNAKE-BUFFER is the name of the buffer." |
| 261 | (when (and (not snake-paused) |
| 262 | (eq (current-buffer) snake-buffer)) |
| 263 | (snake-update-velocity) |
| 264 | (let* ((pos (car snake-positions)) |
| 265 | (x (+ (aref pos 0) snake-velocity-x)) |
| 266 | (y (+ (aref pos 1) snake-velocity-y)) |
| 267 | (c (gamegrid-get-cell x y))) |
| 268 | (if (or (= c snake-border) |
| 269 | (= c snake-snake)) |
| 270 | (snake-end-game) |
| 271 | (cond ((= c snake-dot) |
| 272 | (incf snake-length) |
| 273 | (incf snake-score) |
| 274 | (snake-update-score)) |
| 275 | (t |
| 276 | (let* ((last-cons (nthcdr (- snake-length 2) |
| 277 | snake-positions)) |
| 278 | (tail-pos (cadr last-cons)) |
| 279 | (x0 (aref tail-pos 0)) |
| 280 | (y0 (aref tail-pos 1))) |
| 281 | (gamegrid-set-cell x0 y0 |
| 282 | (if (= (% snake-cycle 5) 0) |
| 283 | snake-dot |
| 284 | snake-blank)) |
| 285 | (incf snake-cycle) |
| 286 | (setcdr last-cons nil)))) |
| 287 | (gamegrid-set-cell x y snake-snake) |
| 288 | (setq snake-positions |
| 289 | (cons (vector x y) snake-positions)) |
| 290 | (setq snake-moved-p nil))))) |
| 291 | |
| 292 | (defun snake-update-velocity () |
| 293 | (unless snake-moved-p |
| 294 | (if snake-velocity-queue |
| 295 | (let ((new-vel (car (last snake-velocity-queue)))) |
| 296 | (setq snake-velocity-x (car new-vel) |
| 297 | snake-velocity-y (cadr new-vel)) |
| 298 | (setq snake-velocity-queue |
| 299 | (nreverse (cdr (nreverse snake-velocity-queue)))))) |
| 300 | (setq snake-moved-p t))) |
| 301 | |
| 302 | (defun snake-final-x-velocity () |
| 303 | (or (caar snake-velocity-queue) |
| 304 | snake-velocity-x)) |
| 305 | |
| 306 | (defun snake-final-y-velocity () |
| 307 | (or (cadr (car snake-velocity-queue)) |
| 308 | snake-velocity-y)) |
| 309 | |
| 310 | (defun snake-move-left () |
| 311 | "Make the snake move left." |
| 312 | (interactive) |
| 313 | (when (zerop (snake-final-x-velocity)) |
| 314 | (push '(-1 0) snake-velocity-queue))) |
| 315 | |
| 316 | (defun snake-move-right () |
| 317 | "Make the snake move right." |
| 318 | (interactive) |
| 319 | (when (zerop (snake-final-x-velocity)) |
| 320 | (push '(1 0) snake-velocity-queue))) |
| 321 | |
| 322 | (defun snake-move-up () |
| 323 | "Make the snake move up." |
| 324 | (interactive) |
| 325 | (when (zerop (snake-final-y-velocity)) |
| 326 | (push '(0 -1) snake-velocity-queue))) |
| 327 | |
| 328 | (defun snake-move-down () |
| 329 | "Make the snake move down." |
| 330 | (interactive) |
| 331 | (when (zerop (snake-final-y-velocity)) |
| 332 | (push '(0 1) snake-velocity-queue))) |
| 333 | |
| 334 | (defun snake-end-game () |
| 335 | "Terminate the current game." |
| 336 | (interactive) |
| 337 | (gamegrid-kill-timer) |
| 338 | (use-local-map snake-null-map) |
| 339 | (gamegrid-add-score snake-score-file snake-score)) |
| 340 | |
| 341 | (defun snake-start-game () |
| 342 | "Start a new game of Snake." |
| 343 | (interactive) |
| 344 | (snake-reset-game) |
| 345 | (use-local-map snake-mode-map) |
| 346 | (gamegrid-start-timer snake-tick-period 'snake-update-game)) |
| 347 | |
| 348 | (defun snake-pause-game () |
| 349 | "Pause (or resume) the current game." |
| 350 | (interactive) |
| 351 | (setq snake-paused (not snake-paused)) |
| 352 | (message (and snake-paused "Game paused (press p to resume)"))) |
| 353 | |
| 354 | (defun snake-active-p () |
| 355 | (eq (current-local-map) snake-mode-map)) |
| 356 | |
| 357 | (put 'snake-mode 'mode-class 'special) |
| 358 | |
| 359 | (defun snake-mode () |
| 360 | "A mode for playing Snake. |
| 361 | |
| 362 | Snake mode keybindings: |
| 363 | \\{snake-mode-map} |
| 364 | " |
| 365 | (kill-all-local-variables) |
| 366 | |
| 367 | (add-hook 'kill-buffer-hook 'gamegrid-kill-timer nil t) |
| 368 | |
| 369 | (use-local-map snake-null-map) |
| 370 | |
| 371 | (setq major-mode 'snake-mode) |
| 372 | (setq mode-name "Snake") |
| 373 | |
| 374 | (unless (featurep 'emacs) |
| 375 | (setq mode-popup-menu |
| 376 | '("Snake Commands" |
| 377 | ["Start new game" snake-start-game] |
| 378 | ["End game" snake-end-game |
| 379 | (snake-active-p)] |
| 380 | ["Pause" snake-pause-game |
| 381 | (and (snake-active-p) (not snake-paused))] |
| 382 | ["Resume" snake-pause-game |
| 383 | (and (snake-active-p) snake-paused)]))) |
| 384 | |
| 385 | (setq gamegrid-use-glyphs snake-use-glyphs-flag) |
| 386 | (setq gamegrid-use-color snake-use-color-flag) |
| 387 | |
| 388 | (gamegrid-init (snake-display-options)) |
| 389 | |
| 390 | (run-mode-hooks 'snake-mode-hook)) |
| 391 | |
| 392 | ;;;###autoload |
| 393 | (defun snake () |
| 394 | "Play the Snake game. |
| 395 | Move the snake around without colliding with its tail or with the border. |
| 396 | |
| 397 | Eating dots causes the snake to get longer. |
| 398 | |
| 399 | Snake mode keybindings: |
| 400 | \\<snake-mode-map> |
| 401 | \\[snake-start-game] Starts a new game of Snake |
| 402 | \\[snake-end-game] Terminates the current game |
| 403 | \\[snake-pause-game] Pauses (or resumes) the current game |
| 404 | \\[snake-move-left] Makes the snake move left |
| 405 | \\[snake-move-right] Makes the snake move right |
| 406 | \\[snake-move-up] Makes the snake move up |
| 407 | \\[snake-move-down] Makes the snake move down" |
| 408 | (interactive) |
| 409 | |
| 410 | (switch-to-buffer snake-buffer-name) |
| 411 | (gamegrid-kill-timer) |
| 412 | (snake-mode) |
| 413 | (snake-start-game)) |
| 414 | |
| 415 | (provide 'snake) |
| 416 | |
| 417 | ;; arch-tag: 512ffc92-cfac-4287-9a4e-92890701a5c8 |
| 418 | ;;; snake.el ends here |