lisp/play/pong.el

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