* vc/diff.el (diff-sentinel): Doc fix (Bug#7682).
[emacs.git] / lisp / play / tetris.el
blobb6613f7a548721ba9b1c3b9972127140957fb493
1 ;;; tetris.el --- implementation of Tetris for Emacs
3 ;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
4 ;; 2009, 2010, 2011 Free Software Foundation, Inc.
6 ;; Author: Glynn Clements <glynn@sensei.co.uk>
7 ;; Version: 2.01
8 ;; Created: 1997-08-13
9 ;; Keywords: games
11 ;; This file is part of GNU Emacs.
13 ;; GNU Emacs is free software: you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation, either version 3 of the License, or
16 ;; (at your option) any later version.
18 ;; GNU Emacs is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
26 ;;; Commentary:
28 ;;; Code:
30 (eval-when-compile
31 (require 'cl))
33 (require 'gamegrid)
35 ;; ;;;;;;;;;;;;; customization variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
37 (defgroup tetris nil
38 "Play a game of Tetris."
39 :prefix "tetris-"
40 :group 'games)
42 (defcustom tetris-use-glyphs t
43 "Non-nil means use glyphs when available."
44 :group 'tetris
45 :type 'boolean)
47 (defcustom tetris-use-color t
48 "Non-nil means use color when available."
49 :group 'tetris
50 :type 'boolean)
52 (defcustom tetris-draw-border-with-glyphs t
53 "Non-nil means draw a border even when using glyphs."
54 :group 'tetris
55 :type 'boolean)
57 (defcustom tetris-default-tick-period 0.3
58 "The default time taken for a shape to drop one row."
59 :group 'tetris
60 :type 'number)
62 (defcustom tetris-update-speed-function
63 'tetris-default-update-speed-function
64 "Function run whenever the Tetris score changes.
65 Called with two arguments: (SHAPES ROWS)
66 SHAPES is the number of shapes which have been dropped.
67 ROWS is the number of rows which have been completed.
69 If the return value is a number, it is used as the timer period."
70 :group 'tetris
71 :type 'function)
73 (defcustom tetris-mode-hook nil
74 "Hook run upon starting Tetris."
75 :group 'tetris
76 :type 'hook)
78 (defcustom tetris-tty-colors
79 ["blue" "white" "yellow" "magenta" "cyan" "green" "red"]
80 "Vector of colors of the various shapes in text mode."
81 :group 'tetris
82 :type (let ((names `("Shape 1" "Shape 2" "Shape 3"
83 "Shape 4" "Shape 5" "Shape 6" "Shape 7"))
84 (result nil))
85 (while names
86 (add-to-list 'result
87 (cons 'choice
88 (cons :tag
89 (cons (car names)
90 (mapcar (lambda (color)
91 (list 'const color))
92 (defined-colors)))))
94 (setq names (cdr names)))
95 result))
97 (defcustom tetris-x-colors
98 [[0 0 1] [0.7 0 1] [1 1 0] [1 0 1] [0 1 1] [0 1 0] [1 0 0]]
99 "Vector of colors of the various shapes."
100 :group 'tetris
101 :type 'sexp)
103 (defcustom tetris-buffer-name "*Tetris*"
104 "Name used for Tetris buffer."
105 :group 'tetris
106 :type 'string)
108 (defcustom tetris-buffer-width 30
109 "Width of used portion of buffer."
110 :group 'tetris
111 :type 'number)
113 (defcustom tetris-buffer-height 22
114 "Height of used portion of buffer."
115 :group 'tetris
116 :type 'number)
118 (defcustom tetris-width 10
119 "Width of playing area."
120 :group 'tetris
121 :type 'number)
123 (defcustom tetris-height 20
124 "Height of playing area."
125 :group 'tetris
126 :type 'number)
128 (defcustom tetris-top-left-x 3
129 "X position of top left of playing area."
130 :group 'tetris
131 :type 'number)
133 (defcustom tetris-top-left-y 1
134 "Y position of top left of playing area."
135 :group 'tetris
136 :type 'number)
138 (defvar tetris-next-x (+ (* 2 tetris-top-left-x) tetris-width)
139 "X position of next shape.")
141 (defvar tetris-next-y tetris-top-left-y
142 "Y position of next shape.")
144 (defvar tetris-score-x tetris-next-x
145 "X position of score.")
147 (defvar tetris-score-y (+ tetris-next-y 6)
148 "Y position of score.")
150 ;; It is not safe to put this in /tmp.
151 ;; Someone could make a symlink in /tmp
152 ;; pointing to a file you don't want to clobber.
153 (defvar tetris-score-file "tetris-scores"
154 ;; anybody with a well-connected server want to host this?
155 ;(defvar tetris-score-file "/anonymous@ftp.pgt.com:/pub/cgw/tetris-scores"
156 "File for holding high scores.")
158 ;; ;;;;;;;;;;;;; display options ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
160 (defvar tetris-blank-options
161 '(((glyph colorize)
162 (t ?\040))
163 ((color-x color-x)
164 (mono-x grid-x)
165 (color-tty color-tty))
166 (((glyph color-x) [0 0 0])
167 (color-tty "black"))))
169 (defvar tetris-cell-options
170 '(((glyph colorize)
171 (emacs-tty ?O)
172 (t ?\040))
173 ((color-x color-x)
174 (mono-x mono-x)
175 (color-tty color-tty)
176 (mono-tty mono-tty))
177 ;; color information is taken from tetris-x-colors and tetris-tty-colors
180 (defvar tetris-border-options
181 '(((glyph colorize)
182 (t ?\+))
183 ((color-x color-x)
184 (mono-x grid-x)
185 (color-tty color-tty))
186 (((glyph color-x) [0.5 0.5 0.5])
187 (color-tty "white"))))
189 (defvar tetris-space-options
190 '(((t ?\040))
192 nil))
194 ;; ;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
196 (defconst tetris-shapes
197 [[[[0 0] [1 0] [0 1] [1 1]]]
199 [[[0 0] [1 0] [2 0] [2 1]]
200 [[1 -1] [1 0] [1 1] [0 1]]
201 [[0 -1] [0 0] [1 0] [2 0]]
202 [[1 -1] [2 -1] [1 0] [1 1]]]
204 [[[0 0] [1 0] [2 0] [0 1]]
205 [[0 -1] [1 -1] [1 0] [1 1]]
206 [[2 -1] [0 0] [1 0] [2 0]]
207 [[1 -1] [1 0] [1 1] [2 1]]]
209 [[[0 0] [1 0] [1 1] [2 1]]
210 [[1 0] [0 1] [1 1] [0 2]]]
212 [[[1 0] [2 0] [0 1] [1 1]]
213 [[0 0] [0 1] [1 1] [1 2]]]
215 [[[1 0] [0 1] [1 1] [2 1]]
216 [[1 0] [1 1] [2 1] [1 2]]
217 [[0 1] [1 1] [2 1] [1 2]]
218 [[1 0] [0 1] [1 1] [1 2]]]
220 [[[0 0] [1 0] [2 0] [3 0]]
221 [[1 -1] [1 0] [1 1] [1 2]]]]
222 "Each shape is described by a vector that contains the coordinates of
223 each one of its four blocks.")
225 ;;the scoring rules were taken from "xtetris". Blocks score differently
226 ;;depending on their rotation
228 (defconst tetris-shape-scores
229 [[6] [6 7 6 7] [6 7 6 7] [6 7] [6 7] [5 5 6 5] [5 8]] )
231 (defconst tetris-shape-dimensions
232 [[2 2] [3 2] [3 2] [3 2] [3 2] [3 2] [4 1]])
234 (defconst tetris-blank 7)
236 (defconst tetris-border 8)
238 (defconst tetris-space 9)
240 (defun tetris-default-update-speed-function (shapes rows)
241 (/ 20.0 (+ 50.0 rows)))
243 ;; ;;;;;;;;;;;;; variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
245 (defvar tetris-shape 0)
246 (defvar tetris-rot 0)
247 (defvar tetris-next-shape 0)
248 (defvar tetris-n-shapes 0)
249 (defvar tetris-n-rows 0)
250 (defvar tetris-score 0)
251 (defvar tetris-pos-x 0)
252 (defvar tetris-pos-y 0)
253 (defvar tetris-paused nil)
255 (make-variable-buffer-local 'tetris-shape)
256 (make-variable-buffer-local 'tetris-rot)
257 (make-variable-buffer-local 'tetris-next-shape)
258 (make-variable-buffer-local 'tetris-n-shapes)
259 (make-variable-buffer-local 'tetris-n-rows)
260 (make-variable-buffer-local 'tetris-score)
261 (make-variable-buffer-local 'tetris-pos-x)
262 (make-variable-buffer-local 'tetris-pos-y)
263 (make-variable-buffer-local 'tetris-paused)
265 ;; ;;;;;;;;;;;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
267 (defvar tetris-mode-map
268 (let ((map (make-sparse-keymap 'tetris-mode-map)))
269 (define-key map "n" 'tetris-start-game)
270 (define-key map "q" 'tetris-end-game)
271 (define-key map "p" 'tetris-pause-game)
273 (define-key map " " 'tetris-move-bottom)
274 (define-key map [left] 'tetris-move-left)
275 (define-key map [right] 'tetris-move-right)
276 (define-key map [up] 'tetris-rotate-prev)
277 (define-key map [down] 'tetris-rotate-next)
278 map))
280 (defvar tetris-null-map
281 (let ((map (make-sparse-keymap 'tetris-null-map)))
282 (define-key map "n" 'tetris-start-game)
283 map))
285 ;; ;;;;;;;;;;;;;;;; game functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
287 (defun tetris-display-options ()
288 (let ((options (make-vector 256 nil)))
289 (loop for c from 0 to 255 do
290 (aset options c
291 (cond ((= c tetris-blank)
292 tetris-blank-options)
293 ((and (>= c 0) (<= c 6))
294 (append
295 tetris-cell-options
296 `((((glyph color-x) ,(aref tetris-x-colors c))
297 (color-tty ,(aref tetris-tty-colors c))
298 (t nil)))))
299 ((= c tetris-border)
300 tetris-border-options)
301 ((= c tetris-space)
302 tetris-space-options)
304 '(nil nil nil)))))
305 options))
307 (defun tetris-get-tick-period ()
308 (if (boundp 'tetris-update-speed-function)
309 (let ((period (apply tetris-update-speed-function
310 tetris-n-shapes
311 tetris-n-rows nil)))
312 (and (numberp period) period))))
314 (defun tetris-get-shape-cell (block)
315 (aref (aref (aref tetris-shapes
316 tetris-shape) tetris-rot)
317 block))
319 (defun tetris-shape-width ()
320 (aref (aref tetris-shape-dimensions tetris-shape) 0))
322 (defun tetris-shape-rotations ()
323 (length (aref tetris-shapes tetris-shape)))
325 (defun tetris-draw-score ()
326 (let ((strings (vector (format "Shapes: %05d" tetris-n-shapes)
327 (format "Rows: %05d" tetris-n-rows)
328 (format "Score: %05d" tetris-score))))
329 (loop for y from 0 to 2 do
330 (let* ((string (aref strings y))
331 (len (length string)))
332 (loop for x from 0 to (1- len) do
333 (gamegrid-set-cell (+ tetris-score-x x)
334 (+ tetris-score-y y)
335 (aref string x)))))))
337 (defun tetris-update-score ()
338 (tetris-draw-score)
339 (let ((period (tetris-get-tick-period)))
340 (if period (gamegrid-set-timer period))))
342 (defun tetris-new-shape ()
343 (setq tetris-shape tetris-next-shape)
344 (setq tetris-rot 0)
345 (setq tetris-next-shape (random 7))
346 (setq tetris-pos-x (/ (- tetris-width (tetris-shape-width)) 2))
347 (setq tetris-pos-y 0)
348 (if (tetris-test-shape)
349 (tetris-end-game)
350 (tetris-draw-shape)
351 (tetris-draw-next-shape)
352 (tetris-update-score)))
354 (defun tetris-draw-next-shape ()
355 (loop for x from 0 to 3 do
356 (loop for y from 0 to 3 do
357 (gamegrid-set-cell (+ tetris-next-x x)
358 (+ tetris-next-y y)
359 tetris-blank)))
360 (loop for i from 0 to 3 do
361 (let ((tetris-shape tetris-next-shape)
362 (tetris-rot 0))
363 (gamegrid-set-cell (+ tetris-next-x
364 (aref (tetris-get-shape-cell i) 0))
365 (+ tetris-next-y
366 (aref (tetris-get-shape-cell i) 1))
367 tetris-shape))))
369 (defun tetris-draw-shape ()
370 (loop for i from 0 to 3 do
371 (let ((c (tetris-get-shape-cell i)))
372 (gamegrid-set-cell (+ tetris-top-left-x
373 tetris-pos-x
374 (aref c 0))
375 (+ tetris-top-left-y
376 tetris-pos-y
377 (aref c 1))
378 tetris-shape))))
380 (defun tetris-erase-shape ()
381 (loop for i from 0 to 3 do
382 (let ((c (tetris-get-shape-cell i)))
383 (gamegrid-set-cell (+ tetris-top-left-x
384 tetris-pos-x
385 (aref c 0))
386 (+ tetris-top-left-y
387 tetris-pos-y
388 (aref c 1))
389 tetris-blank))))
391 (defun tetris-test-shape ()
392 (let ((hit nil))
393 (loop for i from 0 to 3 do
394 (unless hit
395 (setq hit
396 (let* ((c (tetris-get-shape-cell i))
397 (xx (+ tetris-pos-x
398 (aref c 0)))
399 (yy (+ tetris-pos-y
400 (aref c 1))))
401 (or (>= xx tetris-width)
402 (>= yy tetris-height)
403 (/= (gamegrid-get-cell
404 (+ xx tetris-top-left-x)
405 (+ yy tetris-top-left-y))
406 tetris-blank))))))
407 hit))
409 (defun tetris-full-row (y)
410 (let ((full t))
411 (loop for x from 0 to (1- tetris-width) do
412 (if (= (gamegrid-get-cell (+ tetris-top-left-x x)
413 (+ tetris-top-left-y y))
414 tetris-blank)
415 (setq full nil)))
416 full))
418 (defun tetris-shift-row (y)
419 (if (= y 0)
420 (loop for x from 0 to (1- tetris-width) do
421 (gamegrid-set-cell (+ tetris-top-left-x x)
422 (+ tetris-top-left-y y)
423 tetris-blank))
424 (loop for x from 0 to (1- tetris-width) do
425 (let ((c (gamegrid-get-cell (+ tetris-top-left-x x)
426 (+ tetris-top-left-y y -1))))
427 (gamegrid-set-cell (+ tetris-top-left-x x)
428 (+ tetris-top-left-y y)
429 c)))))
431 (defun tetris-shift-down ()
432 (loop for y0 from 0 to (1- tetris-height) do
433 (if (tetris-full-row y0)
434 (progn (setq tetris-n-rows (1+ tetris-n-rows))
435 (loop for y from y0 downto 0 do
436 (tetris-shift-row y))))))
438 (defun tetris-draw-border-p ()
439 (or (not (eq gamegrid-display-mode 'glyph))
440 tetris-draw-border-with-glyphs))
442 (defun tetris-init-buffer ()
443 (gamegrid-init-buffer tetris-buffer-width
444 tetris-buffer-height
445 tetris-space)
446 (let ((buffer-read-only nil))
447 (if (tetris-draw-border-p)
448 (loop for y from -1 to tetris-height do
449 (loop for x from -1 to tetris-width do
450 (gamegrid-set-cell (+ tetris-top-left-x x)
451 (+ tetris-top-left-y y)
452 tetris-border))))
453 (loop for y from 0 to (1- tetris-height) do
454 (loop for x from 0 to (1- tetris-width) do
455 (gamegrid-set-cell (+ tetris-top-left-x x)
456 (+ tetris-top-left-y y)
457 tetris-blank)))
458 (if (tetris-draw-border-p)
459 (loop for y from -1 to 4 do
460 (loop for x from -1 to 4 do
461 (gamegrid-set-cell (+ tetris-next-x x)
462 (+ tetris-next-y y)
463 tetris-border))))))
465 (defun tetris-reset-game ()
466 (gamegrid-kill-timer)
467 (tetris-init-buffer)
468 (setq tetris-next-shape (random 7))
469 (setq tetris-shape 0
470 tetris-rot 0
471 tetris-pos-x 0
472 tetris-pos-y 0
473 tetris-n-shapes 0
474 tetris-n-rows 0
475 tetris-score 0
476 tetris-paused nil)
477 (tetris-new-shape))
479 (defun tetris-shape-done ()
480 (tetris-shift-down)
481 (setq tetris-n-shapes (1+ tetris-n-shapes))
482 (setq tetris-score
483 (+ tetris-score
484 (aref (aref tetris-shape-scores tetris-shape) tetris-rot)))
485 (tetris-update-score)
486 (tetris-new-shape))
488 (defun tetris-update-game (tetris-buffer)
489 "Called on each clock tick.
490 Drops the shape one square, testing for collision."
491 (if (and (not tetris-paused)
492 (eq (current-buffer) tetris-buffer))
493 (let (hit)
494 (tetris-erase-shape)
495 (setq tetris-pos-y (1+ tetris-pos-y))
496 (setq hit (tetris-test-shape))
497 (if hit
498 (setq tetris-pos-y (1- tetris-pos-y)))
499 (tetris-draw-shape)
500 (if hit
501 (tetris-shape-done)))))
503 (defun tetris-move-bottom ()
504 "Drop the shape to the bottom of the playing area."
505 (interactive)
506 (unless tetris-paused
507 (let ((hit nil))
508 (tetris-erase-shape)
509 (while (not hit)
510 (setq tetris-pos-y (1+ tetris-pos-y))
511 (setq hit (tetris-test-shape)))
512 (setq tetris-pos-y (1- tetris-pos-y))
513 (tetris-draw-shape)
514 (tetris-shape-done))))
516 (defun tetris-move-left ()
517 "Move the shape one square to the left."
518 (interactive)
519 (unless tetris-paused
520 (tetris-erase-shape)
521 (setq tetris-pos-x (1- tetris-pos-x))
522 (if (tetris-test-shape)
523 (setq tetris-pos-x (1+ tetris-pos-x)))
524 (tetris-draw-shape)))
526 (defun tetris-move-right ()
527 "Move the shape one square to the right."
528 (interactive)
529 (unless tetris-paused
530 (tetris-erase-shape)
531 (setq tetris-pos-x (1+ tetris-pos-x))
532 (if (tetris-test-shape)
533 (setq tetris-pos-x (1- tetris-pos-x)))
534 (tetris-draw-shape)))
536 (defun tetris-rotate-prev ()
537 "Rotate the shape clockwise."
538 (interactive)
539 (unless tetris-paused
540 (tetris-erase-shape)
541 (setq tetris-rot (% (+ 1 tetris-rot)
542 (tetris-shape-rotations)))
543 (if (tetris-test-shape)
544 (setq tetris-rot (% (+ 3 tetris-rot)
545 (tetris-shape-rotations))))
546 (tetris-draw-shape)))
548 (defun tetris-rotate-next ()
549 "Rotate the shape anticlockwise."
550 (interactive)
551 (unless tetris-paused
552 (tetris-erase-shape)
553 (setq tetris-rot (% (+ 3 tetris-rot)
554 (tetris-shape-rotations)))
555 (if (tetris-test-shape)
556 (setq tetris-rot (% (+ 1 tetris-rot)
557 (tetris-shape-rotations))))
558 (tetris-draw-shape)))
560 (defun tetris-end-game ()
561 "Terminate the current game."
562 (interactive)
563 (gamegrid-kill-timer)
564 (use-local-map tetris-null-map)
565 (gamegrid-add-score tetris-score-file tetris-score))
567 (defun tetris-start-game ()
568 "Start a new game of Tetris."
569 (interactive)
570 (tetris-reset-game)
571 (use-local-map tetris-mode-map)
572 (let ((period (or (tetris-get-tick-period)
573 tetris-default-tick-period)))
574 (gamegrid-start-timer period 'tetris-update-game)))
576 (defun tetris-pause-game ()
577 "Pause (or resume) the current game."
578 (interactive)
579 (setq tetris-paused (not tetris-paused))
580 (message (and tetris-paused "Game paused (press p to resume)")))
582 (defun tetris-active-p ()
583 (eq (current-local-map) tetris-mode-map))
585 (put 'tetris-mode 'mode-class 'special)
587 (define-derived-mode tetris-mode nil "Tetris"
588 "A mode for playing Tetris."
590 (add-hook 'kill-buffer-hook 'gamegrid-kill-timer nil t)
592 (use-local-map tetris-null-map)
594 (unless (featurep 'emacs)
595 (setq mode-popup-menu
596 '("Tetris Commands"
597 ["Start new game" tetris-start-game]
598 ["End game" tetris-end-game
599 (tetris-active-p)]
600 ["Pause" tetris-pause-game
601 (and (tetris-active-p) (not tetris-paused))]
602 ["Resume" tetris-pause-game
603 (and (tetris-active-p) tetris-paused)])))
605 (setq show-trailing-whitespace nil)
607 (setq gamegrid-use-glyphs tetris-use-glyphs)
608 (setq gamegrid-use-color tetris-use-color)
610 (gamegrid-init (tetris-display-options)))
612 ;;;###autoload
613 (defun tetris ()
614 "Play the Tetris game.
615 Shapes drop from the top of the screen, and the user has to move and
616 rotate the shape to fit in with those at the bottom of the screen so
617 as to form complete rows.
619 tetris-mode keybindings:
620 \\<tetris-mode-map>
621 \\[tetris-start-game] Starts a new game of Tetris
622 \\[tetris-end-game] Terminates the current game
623 \\[tetris-pause-game] Pauses (or resumes) the current game
624 \\[tetris-move-left] Moves the shape one square to the left
625 \\[tetris-move-right] Moves the shape one square to the right
626 \\[tetris-rotate-prev] Rotates the shape clockwise
627 \\[tetris-rotate-next] Rotates the shape anticlockwise
628 \\[tetris-move-bottom] Drops the shape to the bottom of the playing area
631 (interactive)
633 (select-window (or (get-buffer-window tetris-buffer-name)
634 (selected-window)))
635 (switch-to-buffer tetris-buffer-name)
636 (gamegrid-kill-timer)
637 (tetris-mode)
638 (tetris-start-game))
640 (random t)
642 (provide 'tetris)
644 ;;; tetris.el ends here