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

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