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

   1 ;;; pong.el --- classical implementation of pong
   2
   3 ;; Copyright 1999, 2000, 2001 by Free Software Foundation, Inc.
   4
   5 ;; Author: Benjamin Drieu <bdrieu@april.org>
   6 ;; Keywords: games
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; This is an implementation of the classical game pong.
  28
  29 ;;; Code:
  30
  31 (eval-when-compile (require 'cl))
  32
  33 (require 'gamegrid)
  34
  35 ;;; Customization
  36
  37 (defgroup pong nil
  38   "Emacs-Lisp implementation of the classical game pong."
  39   :tag "Pong"
  40   :group 'games)
  41
  42 (defcustom pong-buffer-name "*Pong*"
  43   "*Name of the buffer used to play."
  44   :group 'pong
  45   :type '(string))
  46
  47 (defcustom pong-width 50
  48   "*Width of the playfield."
  49   :group 'pong
  50   :type '(integer))
  51
  52 (defcustom pong-height (min 30 (- (frame-height) 6))
  53   "*Height of the playfield."
  54   :group 'pong
  55   :type '(integer))
  56
  57 (defcustom pong-bat-width 3
  58   "*Width of the bats for pong."
  59   :group 'pong
  60   :type '(integer))
  61
  62 (defcustom pong-blank-color "black"
  63   "*Color used for background."
  64   :group 'pong
  65   :type 'color)
  66
  67 (defcustom pong-bat-color "yellow"
  68   "*Color used for bats."
  69   :group 'pong
  70   :type 'color)
  71
  72 (defcustom pong-ball-color "red"
  73   "*Color used for the ball."
  74   :group 'pong
  75   :type 'color)
  76
  77 (defcustom pong-border-color "white"
  78   "*Color used for pong balls."
  79   :group 'pong
  80   :type 'color)
  81
  82 (defcustom pong-left-key "4"
  83   "*Alternate key to press for bat 1 to go up (primary one is [left])."
  84   :group 'pong
  85   :type '(restricted-sexp :match-alternatives (stringp vectorp)))
  86
  87 (defcustom pong-right-key "6"
  88   "*Alternate key to press for bat 1 to go down (primary one is [right])."
  89   :group 'pong
  90   :type '(restricted-sexp :match-alternatives (stringp vectorp)))
  91
  92 (defcustom pong-up-key "8"
  93   "*Alternate key to press for bat 2 to go up (primary one is [up])."
  94   :group 'pong
  95   :type '(restricted-sexp :match-alternatives (stringp vectorp)))
  96
  97 (defcustom pong-down-key "2"
  98   "*Alternate key to press for bat 2 to go down (primary one is [down])."
  99   :group 'pong
 100   :type '(restricted-sexp :match-alternatives (stringp vectorp)))
 101
 102 (defcustom pong-quit-key "q"
 103   "*Key to press to quit pong."
 104   :group 'pong
 105   :type '(restricted-sexp :match-alternatives (stringp vectorp)))
 106
 107 (defcustom pong-pause-key "p"
 108   "Key to press to pause pong."
 109   :group 'pong
 110   :type '(restricted-sexp :match-alternatives (stringp vectorp)))
 111
 112 (defcustom pong-resume-key "p"
 113   "*Key to press to resume pong."
 114   :group 'pong
 115   :type '(restricted-sexp :match-alternatives (stringp vectorp)))
 116
 117 (defcustom pong-timer-delay 0.1
 118   "*Time to wait between every cycle."
 119   :group 'pong
 120   :type 'number)
 121
 122
 123 ;;; This is black magic.  Define colors used
 124
 125 (defvar pong-blank-options
 126   '(((glyph colorize)
 127      (t ?\040))
 128     ((color-x color-x)
 129      (mono-x grid-x)
 130      (color-tty color-tty))
 131     (((glyph color-x) [0 0 0])
 132      (color-tty pong-blank-color))))
 133
 134 (defvar pong-bat-options
 135   '(((glyph colorize)
 136      (emacs-tty ?O)
 137      (t ?\040))
 138     ((color-x color-x)
 139      (mono-x mono-x)
 140      (color-tty color-tty)
 141      (mono-tty mono-tty))
 142     (((glyph color-x) [1 1 0])
 143      (color-tty pong-bat-color))))
 144
 145 (defvar pong-ball-options
 146   '(((glyph colorize)
 147      (t ?\*))
 148     ((color-x color-x)
 149      (mono-x grid-x)
 150      (color-tty color-tty))
 151     (((glyph color-x) [1 0 0])
 152      (color-tty pong-ball-color))))
 153
 154 (defvar pong-border-options
 155   '(((glyph colorize)
 156      (t ?\+))
 157     ((color-x color-x)
 158      (mono-x grid-x))
 159     ;; The colors used to be [0.5 0.5 0.5], but that produces a black
 160     ;; color on 8-color tty's, which would make the border invisible.
 161     ;; 0.51 produces white on such tty's, and at the same time has
 162     ;; almost no effect on X and similar displays.
 163     (((glyph color-x) [0.51 0.51 0.51])
 164      (color-tty pong-border-color))))
 165
 166 (defconst pong-blank    0)
 167 (defconst pong-bat      1)
 168 (defconst pong-ball     2)
 169 (defconst pong-border   3)
 170
 171
 172 ;;; Determine initial positions for bats and ball
 173
 174 (defvar pong-xx nil
 175   "Horizontal speed of the ball.")
 176
 177 (defvar pong-yy nil
 178   "Vertical speed of the ball.")
 179
 180 (defvar pong-x nil
 181   "Horizontal position of the ball.")
 182
 183 (defvar pong-y nil
 184   "Vertical position of the ball.")
 185
 186 (defvar pong-bat-player1 nil
 187   "Vertical position of bat 1.")
 188
 189 (defvar pong-bat-player2 nil
 190   "Vertical position of bat 2.")
 191
 192 (defvar pong-score-player1 nil)
 193 (defvar pong-score-player2 nil)
 194
 195 ;;; Initialize maps
 196
 197 (defvar pong-mode-map
 198   (make-sparse-keymap 'pong-mode-map) "Modemap for pong-mode.")
 199
 200 (defvar pong-null-map
 201   (make-sparse-keymap 'pong-null-map) "Null map for pong-mode.")
 202
 203 (define-key pong-mode-map [left]         'pong-move-left)
 204 (define-key pong-mode-map [right]        'pong-move-right)
 205 (define-key pong-mode-map [up]           'pong-move-up)
 206 (define-key pong-mode-map [down]         'pong-move-down)
 207 (define-key pong-mode-map pong-left-key  'pong-move-left)
 208 (define-key pong-mode-map pong-right-key 'pong-move-right)
 209 (define-key pong-mode-map pong-up-key    'pong-move-up)
 210 (define-key pong-mode-map pong-down-key  'pong-move-down)
 211 (define-key pong-mode-map pong-quit-key  'pong-quit)
 212 (define-key pong-mode-map pong-pause-key 'pong-pause)
 213
 214
 215 ;;; Fun stuff -- The code
 216
 217 (defun pong-display-options ()
 218   "Computes display options (required by gamegrid for colors)."
 219   (let ((options (make-vector 256 nil)))
 220     (loop for c from 0 to 255 do
 221       (aset options c
 222             (cond ((= c pong-blank)
 223                    pong-blank-options)
 224                   ((= c pong-bat)
 225                    pong-bat-options)
 226                   ((= c pong-ball)
 227                    pong-ball-options)
 228                   ((= c pong-border)
 229                    pong-border-options)
 230                   (t
 231                    '(nil nil nil)))))
 232     options))
 233
 234
 235
 236 (defun pong-init-buffer ()
 237   "Initialize pong buffer and draw stuff thanks to gamegrid library."
 238   (interactive)
 239   (get-buffer-create pong-buffer-name)
 240   (switch-to-buffer pong-buffer-name)
 241   (use-local-map pong-mode-map)
 242
 243   (setq gamegrid-use-glyphs t)
 244   (setq gamegrid-use-color t)
 245   (gamegrid-init (pong-display-options))
 246
 247   (gamegrid-init-buffer pong-width
 248                         (+ 2 pong-height)
 249                         1)
 250
 251   (let ((buffer-read-only nil))
 252     (loop for y from 0 to (1- pong-height) do
 253           (loop for x from 0 to (1- pong-width) do
 254                 (gamegrid-set-cell x y pong-border)))
 255     (loop for y from 1 to (- pong-height 2) do
 256           (loop for x from 1 to (- pong-width 2) do
 257                 (gamegrid-set-cell x y pong-blank))))
 258
 259   (loop for y from pong-bat-player1 to (1- (+ pong-bat-player1 pong-bat-width)) do
 260         (gamegrid-set-cell 2 y pong-bat))
 261   (loop for y from pong-bat-player2 to (1- (+ pong-bat-player2 pong-bat-width)) do
 262         (gamegrid-set-cell (- pong-width 3) y pong-bat)))
 263
 264
 265
 266 (defun pong-move-left ()
 267   "Move bat 2 up.
 268 This is called left for historical reasons, since in some pong
 269 implementations you move with left/right paddle."
 270   (interactive)
 271   (if (> pong-bat-player1 1)
 272       (and
 273        (setq pong-bat-player1 (1- pong-bat-player1))
 274        (pong-update-bat 2 pong-bat-player1))))
 275
 276
 277
 278 (defun pong-move-right ()
 279   "Move bat 2 up."
 280   (interactive)
 281   (if (< (+ pong-bat-player1 pong-bat-width) (1- pong-height))
 282       (and
 283        (setq pong-bat-player1 (1+ pong-bat-player1))
 284        (pong-update-bat 2 pong-bat-player1))))
 285
 286
 287
 288 (defun pong-move-up ()
 289   "Move bat 2 up."
 290   (interactive)
 291   (if (> pong-bat-player2 1)
 292       (and
 293        (setq pong-bat-player2 (1- pong-bat-player2))
 294        (pong-update-bat (- pong-width 3) pong-bat-player2))))
 295
 296
 297
 298 (defun pong-move-down ()
 299   "Move bat 2 down."
 300   (interactive)
 301   (if (< (+ pong-bat-player2 pong-bat-width) (1- pong-height))
 302       (and
 303        (setq pong-bat-player2 (1+ pong-bat-player2))
 304        (pong-update-bat (- pong-width 3) pong-bat-player2))))
 305
 306
 307
 308 (defun pong-update-bat (x y)
 309   "Move a bat (suppress a cell and draw another one on the other side)."
 310
 311   (cond
 312    ((string-equal (buffer-name (current-buffer)) pong-buffer-name)
 313     (gamegrid-set-cell x y pong-bat)
 314     (gamegrid-set-cell x (1- (+ y pong-bat-width)) pong-bat)
 315     (if (> y 1)
 316         (gamegrid-set-cell x (1- y) pong-blank))
 317     (if (< (+ y pong-bat-width) (1- pong-height))
 318         (gamegrid-set-cell x (+ y pong-bat-width) pong-blank)))))
 319
 320
 321
 322 (defun pong-init ()
 323   "Initialize a game."
 324
 325   (define-key pong-mode-map pong-pause-key 'pong-pause)
 326
 327   (add-hook 'kill-buffer-hook 'pong-quit nil t)
 328
 329   ;; Initialization of some variables
 330   (setq pong-bat-player1 (1+ (/ (- pong-height pong-bat-width) 2)))
 331   (setq pong-bat-player2 pong-bat-player1)
 332   (setq pong-xx -1)
 333   (setq pong-yy 0)
 334   (setq pong-x (/ pong-width 2))
 335   (setq pong-y (/ pong-height 2))
 336
 337   (pong-init-buffer)
 338   (gamegrid-kill-timer)
 339   (gamegrid-start-timer pong-timer-delay 'pong-update-game)
 340   (pong-update-score))
 341
 342
 343
 344 (defun pong-update-game (pong-buffer)
 345   "\"Main\" function for pong.
 346 It is called every pong-cycle-delay seconds and
 347 updates ball and bats positions.  It is responsible of collision
 348 detection and checks if a player scores."
 349   (if (not (eq (current-buffer) pong-buffer))
 350       (pong-pause)
 351
 352     (let ((old-x pong-x)
 353           (old-y pong-y))
 354
 355       (setq pong-x (+ pong-x pong-xx))
 356       (setq pong-y (+ pong-y pong-yy))
 357
 358       (if (and (> old-y 0)
 359                (< old-y (- pong-height 1)))
 360           (gamegrid-set-cell old-x old-y pong-blank))
 361
 362       (if (and (> pong-y 0)
 363                (< pong-y (- pong-height 1)))
 364           (gamegrid-set-cell pong-x pong-y pong-ball))
 365
 366       (cond
 367        ((or (= pong-x 3) (= pong-x 2))
 368         (if (and (>= pong-y pong-bat-player1)
 369                  (< pong-y (+ pong-bat-player1 pong-bat-width)))
 370             (and
 371              (setq pong-yy (+ pong-yy
 372                               (cond
 373                                ((= pong-y pong-bat-player1) -1)
 374                                ((= pong-y (1+ pong-bat-player1)) 0)
 375                                (t 1))))
 376              (setq pong-xx (- pong-xx)))))
 377
 378        ((or (= pong-x (- pong-width 4)) (= pong-x (- pong-width 3)))
 379         (if (and (>= pong-y pong-bat-player2)
 380                  (< pong-y (+ pong-bat-player2 pong-bat-width)))
 381             (and
 382              (setq pong-yy (+ pong-yy
 383                               (cond
 384                                ((= pong-y pong-bat-player2) -1)
 385                                ((= pong-y (1+ pong-bat-player2)) 0)
 386                                (t 1))))
 387              (setq pong-xx (- pong-xx)))))
 388
 389        ((<= pong-y 1)
 390         (setq pong-yy (- pong-yy)))
 391
 392        ((>= pong-y (- pong-height 2))
 393         (setq pong-yy (- pong-yy)))
 394
 395        ((< pong-x 1)
 396         (setq pong-score-player2 (1+ pong-score-player2))
 397         (pong-init))
 398
 399        ((>= pong-x (- pong-width 1))
 400         (setq pong-score-player1 (1+ pong-score-player1))
 401         (pong-init))))))
 402
 403
 404
 405 (defun pong-update-score ()
 406   "Update score and print it on bottom of the game grid."
 407   (let* ((string (format "Score:  %d / %d" pong-score-player1 pong-score-player2))
 408          (len (length string)))
 409     (loop for x from 0 to (1- len) do
 410           (if (string-equal (buffer-name (current-buffer)) pong-buffer-name)
 411               (gamegrid-set-cell x
 412                                  pong-height
 413                                  (aref string x))))))
 414
 415
 416
 417 (defun pong-pause ()
 418   "Pause the game."
 419   (interactive)
 420   (gamegrid-kill-timer)
 421   ;; Oooohhh ugly.  I don't know why, gamegrid-kill-timer don't do the
 422   ;; jobs it is made for.  So I have to do it "by hand".  Anyway, next
 423   ;; line is harmless.
 424   (cancel-function-timers 'pong-update-game)
 425   (define-key pong-mode-map pong-resume-key 'pong-resume))
 426
 427
 428
 429 (defun pong-resume ()
 430   "Resume a paused game."
 431   (interactive)
 432   (define-key pong-mode-map pong-pause-key 'pong-pause)
 433   (gamegrid-start-timer pong-timer-delay 'pong-update-game))
 434
 435
 436
 437 (defun pong-quit ()
 438   "Quit the game and kill the pong buffer."
 439   (interactive)
 440   (gamegrid-kill-timer)
 441   ;; Be sure not to draw things in another buffer and wait for some
 442   ;; time.
 443   (run-with-timer pong-timer-delay nil 'kill-buffer pong-buffer-name))
 444
 445
 446
 447 ;;;###autoload
 448 (defun pong ()
 449   "Play pong and waste time.
 450 This is an implementation of the classical game pong.
 451 Move left and right bats and try to bounce the ball to your opponent.
 452
 453 pong-mode keybindings:\\<pong-mode-map>
 454
 455 \\{pong-mode-map}"
 456   (interactive)
 457   (setq pong-score-player1 0)
 458   (setq pong-score-player2 0)
 459   (pong-init))
 460
 461
 462
 463 (provide 'pong)
 464
 465 ;;; pong.el ends here