1;;; pong.el --- classical implementation of pong
2
3;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
4;;   2005, 2006, 2007 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 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
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.
266This is called left for historical reasons, since in some pong
267implementations 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.
344It is called every pong-cycle-delay seconds and
345updates ball and bats positions.  It is responsible of collision
346detection 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.
448This is an implementation of the classical game pong.
449Move left and right bats and try to bounce the ball to your opponent.
450
451pong-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
465