lisp/play/snake.el

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