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

   1 ;;; snake.el --- implementation of Snake for Emacs
   2
   3 ;; Copyright (C) 1997 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 t
  38   "Non-nil means use glyphs when available.")
  39
  40 (defvar snake-use-color 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 (defvar snake-score-file "/tmp/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     (((glyph color-x) [0.5 0.5 0.5])
 125      (color-tty "white"))))
 126
 127 (defvar snake-space-options
 128   '(((t ?\040))
 129     nil
 130     nil))
 131
 132 ;; ;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 133
 134 (defconst snake-blank   0)
 135 (defconst snake-snake   1)
 136 (defconst snake-dot     2)
 137 (defconst snake-border  3)
 138 (defconst snake-space   4)
 139
 140 ;; ;;;;;;;;;;;;; variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 141
 142 (defvar snake-length 0)
 143 (defvar snake-velocity-x 1)
 144 (defvar snake-velocity-y 0)
 145 (defvar snake-positions nil)
 146 (defvar snake-cycle 0)
 147 (defvar snake-score 0)
 148 (defvar snake-paused nil)
 149
 150 (make-variable-buffer-local 'snake-length)
 151 (make-variable-buffer-local 'snake-velocity-x)
 152 (make-variable-buffer-local 'snake-velocity-y)
 153 (make-variable-buffer-local 'snake-positions)
 154 (make-variable-buffer-local 'snake-cycle)
 155 (make-variable-buffer-local 'snake-score)
 156 (make-variable-buffer-local 'snake-paused)
 157
 158 ;; ;;;;;;;;;;;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 159
 160 (defvar snake-mode-map
 161   (make-sparse-keymap 'snake-mode-map))
 162
 163 (define-key snake-mode-map "n"          'snake-start-game)
 164 (define-key snake-mode-map "q"          'snake-end-game)
 165 (define-key snake-mode-map "p"          'snake-pause-game)
 166
 167 (define-key snake-mode-map [left]       'snake-move-left)
 168 (define-key snake-mode-map [right]      'snake-move-right)
 169 (define-key snake-mode-map [up]         'snake-move-up)
 170 (define-key snake-mode-map [down]       'snake-move-down)
 171
 172 (defvar snake-null-map
 173   (make-sparse-keymap 'snake-null-map))
 174
 175 (define-key snake-null-map "n"          'snake-start-game)
 176
 177 ;; ;;;;;;;;;;;;;;;; game functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 178
 179 (defun snake-display-options ()
 180   (let ((options (make-vector 256 nil)))
 181     (loop for c from 0 to 255 do
 182       (aset options c
 183             (cond ((= c snake-blank)
 184                    snake-blank-options)
 185                   ((= c snake-snake)
 186                    snake-snake-options)
 187                   ((= c snake-dot)
 188                    snake-dot-options)
 189                   ((= c snake-border)
 190                    snake-border-options)
 191                   ((= c snake-space)
 192                    snake-space-options)
 193                   (t
 194                    '(nil nil nil)))))
 195     options))
 196
 197 (defun snake-update-score ()
 198   (let* ((string (format "Score:  %05d" snake-score))
 199          (len (length string)))
 200     (loop for x from 0 to (1- len) do
 201       (gamegrid-set-cell (+ snake-score-x x)
 202                          snake-score-y
 203                          (aref string x)))))
 204
 205 (defun snake-init-buffer ()
 206   (gamegrid-init-buffer snake-buffer-width
 207                         snake-buffer-height
 208                         snake-space)
 209   (let ((buffer-read-only nil))
 210     (loop for y from 0 to (1- snake-height) do
 211           (loop for x from 0 to (1- snake-width) do
 212                 (gamegrid-set-cell x y snake-border)))
 213     (loop for y from 1 to (- snake-height 2) do
 214           (loop for x from 1 to (- snake-width 2) do
 215                 (gamegrid-set-cell x y snake-blank)))))
 216
 217 (defun snake-reset-game ()
 218   (gamegrid-kill-timer)
 219   (snake-init-buffer)
 220   (setq snake-length            snake-initial-length
 221         snake-velocity-x        snake-initial-velocity-x
 222         snake-velocity-y        snake-initial-velocity-y
 223         snake-positions         nil
 224         snake-cycle             1
 225         snake-score             0
 226         snake-paused            nil)
 227   (let ((x snake-initial-x)
 228         (y snake-initial-y))
 229     (dotimes (i snake-length)
 230       (gamegrid-set-cell x y snake-snake)
 231       (setq snake-positions (cons (vector x y) snake-positions))
 232       (incf x snake-velocity-x)
 233       (incf y snake-velocity-y)))
 234   (snake-update-score))
 235
 236 (defun snake-update-game (snake-buffer)
 237   "Called on each clock tick.
 238 Advances the snake one square, testing for collision."
 239   (if (and (not snake-paused)
 240            (eq (current-buffer) snake-buffer))
 241       (let* ((pos (car snake-positions))
 242              (x (+ (aref pos 0) snake-velocity-x))
 243              (y (+ (aref pos 1) snake-velocity-y))
 244              (c (gamegrid-get-cell x y)))
 245         (if (or (= c snake-border)
 246                 (= c snake-snake))
 247             (snake-end-game)
 248           (cond ((= c snake-dot)
 249                  (incf snake-length)
 250                  (incf snake-score)
 251                  (snake-update-score))
 252                 (t
 253                  (let* ((last-cons (nthcdr (- snake-length 2)
 254                                            snake-positions))
 255                         (tail-pos (cadr last-cons))
 256                         (x0 (aref tail-pos 0))
 257                         (y0 (aref tail-pos 1)))
 258                    (gamegrid-set-cell x0 y0
 259                                       (if (= (% snake-cycle 5) 0)
 260                                           snake-dot
 261                                         snake-blank))
 262                    (incf snake-cycle)
 263                    (setcdr last-cons nil))))
 264           (gamegrid-set-cell x y snake-snake)
 265           (setq snake-positions
 266                 (cons (vector x y) snake-positions))))))
 267
 268 (defun snake-move-left ()
 269   "Makes the snake move left"
 270   (interactive)
 271   (unless (= snake-velocity-x 1)
 272     (setq snake-velocity-x -1
 273           snake-velocity-y 0)))
 274
 275 (defun snake-move-right ()
 276   "Makes the snake move right"
 277   (interactive)
 278   (unless (= snake-velocity-x -1)
 279     (setq snake-velocity-x 1
 280           snake-velocity-y 0)))
 281
 282 (defun snake-move-up ()
 283   "Makes the snake move up"
 284   (interactive)
 285   (unless (= snake-velocity-y 1)
 286     (setq snake-velocity-x 0
 287           snake-velocity-y -1)))
 288
 289 (defun snake-move-down ()
 290   "Makes the snake move down"
 291   (interactive)
 292   (unless (= snake-velocity-y -1)
 293     (setq snake-velocity-x 0
 294           snake-velocity-y 1)))
 295
 296 (defun snake-end-game ()
 297   "Terminates the current game"
 298   (interactive)
 299   (gamegrid-kill-timer)
 300   (use-local-map snake-null-map)
 301   (gamegrid-add-score snake-score-file snake-score))
 302
 303 (defun snake-start-game ()
 304   "Starts a new game of Snake"
 305   (interactive)
 306   (snake-reset-game)
 307   (use-local-map snake-mode-map)
 308   (gamegrid-start-timer snake-tick-period 'snake-update-game))
 309
 310 (defun snake-pause-game ()
 311   "Pauses (or resumes) the current game"
 312   (interactive)
 313   (setq snake-paused (not snake-paused))
 314   (message (and snake-paused "Game paused (press p to resume)")))
 315
 316 (defun snake-active-p ()
 317   (eq (current-local-map) snake-mode-map))
 318
 319 (put 'snake-mode 'mode-class 'special)
 320
 321 (defun snake-mode ()
 322   "A mode for playing Snake.
 323
 324 snake-mode keybindings:
 325    \\{snake-mode-map}
 326 "
 327   (kill-all-local-variables)
 328
 329   (make-local-hook 'kill-buffer-hook)
 330   (add-hook 'kill-buffer-hook 'gamegrid-kill-timer nil t)
 331
 332   (use-local-map snake-null-map)
 333
 334   (setq major-mode 'snake-mode)
 335   (setq mode-name "Snake")
 336
 337   (setq mode-popup-menu
 338         '("Snake Commands"
 339           ["Start new game"     snake-start-game]
 340           ["End game"           snake-end-game
 341            (snake-active-p)]
 342           ["Pause"              snake-pause-game
 343            (and (snake-active-p) (not snake-paused))]
 344           ["Resume"             snake-pause-game
 345            (and (snake-active-p) snake-paused)]))
 346
 347   (setq gamegrid-use-glyphs snake-use-glyphs)
 348   (setq gamegrid-use-color snake-use-color)
 349
 350   (gamegrid-init (snake-display-options))
 351
 352   (run-hooks 'snake-mode-hook))
 353
 354 ;;;###autoload
 355 (defun snake ()
 356   "Play the Snake game.
 357 Move the snake around without colliding with its tail or with the border.
 358
 359 Eating dots causes the snake to get longer.
 360
 361 snake-mode keybindings:
 362    \\<snake-mode-map>
 363 \\[snake-start-game]    Starts a new game of Snake
 364 \\[snake-end-game]      Terminates the current game
 365 \\[snake-pause-game]    Pauses (or resumes) the current game
 366 \\[snake-move-left]     Makes the snake move left
 367 \\[snake-move-right]    Makes the snake move right
 368 \\[snake-move-up]       Makes the snake move up
 369 \\[snake-move-down]     Makes the snake move down
 370
 371 "
 372   (interactive)
 373
 374   (switch-to-buffer snake-buffer-name)
 375   (gamegrid-kill-timer)
 376   (snake-mode)
 377   (snake-start-game))
 378
 379 (provide 'snake)
 380
 381 ;;; snake.el ends here