lisp/play/pong.el

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