code.delx.au - gnu-emacs/blob - lisp/play/snake.el

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