lisp/play/snake.el

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