lisp/play/pong.el

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