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