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 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 2, 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