Mercurial > hg > xemacs-beta

comparison lisp/games/tetris.el @ 185:3d6bfa290dbd r20-3b19

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b19
author cvs
date Mon, 13 Aug 2007 09:55:28 +0200
parents
children b405438285a2
comparison
equal deleted inserted replaced
184:bcd2674570bf 185:3d6bfa290dbd
1 ;;; tetris.el -- Implementation of Tetris for Emacs.
2
3 ;; Copyright (C) 1997 Glynn Clements <glynn@sensei.co.uk>
4
5 ;; Author: Glynn Clements <glynn@sensei.co.uk>
6 ;; Version: 1.7
7 ;; Created: 1997-08-13
8 ;; Keywords: games
9
10 ;; This file is part of XEmacs.
11
12 ;; XEmacs is free software; you can redistribute it and/or modify it
13 ;; under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2 of the License, or
15 ;; (at your option) any later version.
16
17 ;; XEmacs is distributed in the hope that it will be useful, but
18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 ;; General Public License for more details.
21
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with XEmacs; see the file COPYING. If not, write to the Free
24 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
25 ;; 02111-1307, USA.
26
27 ;;; Synched up with: Not synched.
28
29 ;;; Commentary:
30
31 ;; Modified: 1997-08-17, added tetris-move-bottom
32 ;; Modified: 1997-08-22, changed setting of display table for compatibility
33 ;; with XEmacs 19.15
34 ;; Modified: 1997-08-23, changed setting of display table for TTY compatibility
35 ;; Modified: 1997-08-24, various changes for FSF Emacs compatibility
36 ;; Modified: 1997-08-25
37 ;; modified existing docstrings, added new docstrings
38 ;; L now rotates the same way as T and mirror-L
39 ;; now adds tetris-end-game to buffer-local value of kill-buffer-hook
40 ;; Modified: 1997-08-26, miscellaneous bugfixes
41 ;; Modified: 1997-08-27
42 ;; added color support for non-glyph mode
43 ;; added tetris-mode-hook
44 ;; added tetris-update-speed-function
45 ;; URL: ftp://sensei.co.uk/misc/tetris.el.gz
46 ;; Tested with XEmacs 20.3-beta and Emacs 19.34
47 ;; Reported to work with XEmacs 19.15 and 20.2
48
49 (eval-when-compile
50 (require 'cl))
51
52 ;; ;;;;;;;;;;;;; customization variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
53
54 (defvar tetris-use-glyphs t
55 "Non-nil means use glyphs when available")
56
57 (defvar tetris-use-color t
58 "Non-nil means use color when available")
59
60 (defvar tetris-draw-border-with-glyphs t
61 "Non-nil means draw a border even when using glyphs")
62
63 (defvar tetris-font "-*-courier-medium-r-*-*-*-140-100-75-*-*-iso8859-*"
64 "Name of the font used for tetris in X mode")
65
66 (defvar tetris-default-tick-period 0.3
67 "The default time taken for a shape to drop one row")
68
69 (defvar tetris-update-speed-function
70 'tetris-default-update-speed-function
71 "Function run whenever the Tetris score changes
72 Called with two arguments: (SHAPES ROWS)
73 SHAPES is the number of shapes which have been dropped
74 ROWS is the number of rows which have been completed
75
76 If the return value is a number, it is used as the timer period")
77
78 (defvar tetris-mode-hook nil
79 "Hook run upon starting Tetris")
80
81 ;; ;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
82
83 (defconst tetris-buffer-name "*Tetris*"
84 "Name used for Tetris buffer")
85
86 (defconst tetris-space-char [?\040]
87 "Character vector used for a space")
88
89 (defconst tetris-block-char [?\040]
90 "Character vector for a full square in text mode")
91
92 (defconst tetris-emacs-block-char [?O]
93 "Character vector for a full square in text mode under Emacs")
94
95 (defconst tetris-border-char [?\+]
96 "Character vector for a border square in text mode")
97
98 (defconst tetris-buffer-width 25
99 "Width of used portion of buffer")
100
101 (defconst tetris-buffer-height 25
102 "Height of used portion of buffer")
103
104 (defconst tetris-width 10
105 "Width of playing area")
106
107 (defconst tetris-height 20
108 "Height of playing area")
109
110 (defconst tetris-top-left-x 3
111 "X position of top left of playing area")
112
113 (defconst tetris-top-left-y 1
114 "Y position of top left of playing area")
115
116 (defconst tetris-next-x (+ (* 2 tetris-top-left-x) tetris-width)
117 "X position of next shape")
118
119 (defconst tetris-next-y tetris-top-left-y
120 "Y position of next shape")
121
122 (defconst tetris-score-x tetris-top-left-x
123 "X position of score")
124
125 (defconst tetris-score-y (+ tetris-top-left-y tetris-height 2)
126 "Y position of score")
127
128 (defconst tetris-blank 0)
129
130 (defconst tetris-space ?\.)
131
132 (defconst tetris-border ?\*)
133
134 (defconst tetris-shapes
135 [[[[1 1 0 0] [1 1 0 0] [1 1 0 0] [1 1 0 0]]
136 [[1 1 0 0] [1 1 0 0] [1 1 0 0] [1 1 0 0]]
137 [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]
138 [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
139
140 [[[2 2 2 0] [0 2 0 0] [2 0 0 0] [2 2 0 0]]
141 [[0 0 2 0] [0 2 0 0] [2 2 2 0] [2 0 0 0]]
142 [[0 0 0 0] [2 2 0 0] [0 0 0 0] [2 0 0 0]]
143 [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
144
145 [[[3 3 3 0] [3 3 0 0] [0 0 3 0] [3 0 0 0]]
146 [[3 0 0 0] [0 3 0 0] [3 3 3 0] [3 0 0 0]]
147 [[0 0 0 0] [0 3 0 0] [0 0 0 0] [3 3 0 0]]
148 [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
149
150 [[[4 4 0 0] [0 4 0 0] [4 4 0 0] [0 4 0 0]]
151 [[0 4 4 0] [4 4 0 0] [0 4 4 0] [4 4 0 0]]
152 [[0 0 0 0] [4 0 0 0] [0 0 0 0] [4 0 0 0]]
153 [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
154
155 [[[0 5 5 0] [5 0 0 0] [0 5 5 0] [5 0 0 0]]
156 [[5 5 0 0] [5 5 0 0] [5 5 0 0] [5 5 0 0]]
157 [[0 0 0 0] [0 5 0 0] [0 0 0 0] [0 5 0 0]]
158 [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
159
160 [[[0 6 0 0] [6 0 0 0] [6 6 6 0] [0 6 0 0]]
161 [[6 6 6 0] [6 6 0 0] [0 6 0 0] [6 6 0 0]]
162 [[0 0 0 0] [6 0 0 0] [0 0 0 0] [0 6 0 0]]
163 [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
164
165 [[[7 7 7 7] [7 0 0 0] [7 7 7 7] [7 0 0 0]]
166 [[0 0 0 0] [7 0 0 0] [0 0 0 0] [7 0 0 0]]
167 [[0 0 0 0] [7 0 0 0] [0 0 0 0] [7 0 0 0]]
168 [[0 0 0 0] [7 0 0 0] [0 0 0 0] [7 0 0 0]]]])
169
170 (defconst tetris-shape-dimensions
171 [[2 2] [3 2] [3 2] [3 2] [3 2] [3 2] [4 1]])
172
173 (defconst tetris-text-colors
174 ["black" "blue" "white" "yellow"
175 "magenta" "cyan" "green" "red"]
176 "Vector of colors of the various shapes in text mode
177 Element 0 is the background color")
178
179 (defconst tetris-colors
180 [[0 0 0] [0 0 1] [0.7 0 1] [1 1 0]
181 [1 0 1] [0 1 1] [0 1 0] [1 0 0]
182 [0.5 0.5 0.5]]
183 "Vector of colors of the various shapes
184 Element 0 is the background color
185 Element 8 is the border color")
186
187 (defconst tetris-xpm "\
188 /* XPM */
189 static char *noname[] = {
190 /* width height ncolors chars_per_pixel */
191 \"16 16 3 1\",
192 /* colors */
193 \"+ s col1\",
194 \". s col2\",
195 \"- s col3\",
196 /* pixels */
197 \"---------------+\",
198 \"--------------++\",
199 \"--............++\",
200 \"--............++\",
201 \"--............++\",
202 \"--............++\",
203 \"--............++\",
204 \"--............++\",
205 \"--............++\",
206 \"--............++\",
207 \"--............++\",
208 \"--............++\",
209 \"--............++\",
210 \"--............++\",
211 \"-+++++++++++++++\",
212 \"++++++++++++++++\"
213 };
214 "
215 "XPM format image used for each square")
216
217 (defun tetris-default-update-speed-function (shapes rows)
218 (/ 20.0 (+ 50.0 rows)))
219
220 ;; ;;;;;;;;;;;;; variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
221
222 (defvar tetris-faces (make-vector 256 nil))
223
224 (defvar tetris-buffer-start 1)
225
226 (defvar tetris-display-mode nil)
227
228 (defvar tetris-shape 0)
229 (defvar tetris-rot 0)
230 (defvar tetris-next-shape 0)
231 (defvar tetris-n-shapes 0)
232 (defvar tetris-n-rows 0)
233 (defvar tetris-pos-x 0)
234 (defvar tetris-pos-y 0)
235
236 (defvar tetris-timer nil)
237
238 (defvar tetris-display-table nil)
239
240 ;; ;;;;;;;;;;;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
241
242 (defvar tetris-mode-map
243 (make-sparse-keymap 'tetris-mode-map))
244
245 (define-key tetris-mode-map "n" 'tetris-start-game)
246 (define-key tetris-mode-map "q" 'tetris-end-game)
247
248 (define-key tetris-mode-map " " 'tetris-move-bottom)
249 (define-key tetris-mode-map [left] 'tetris-move-left)
250 (define-key tetris-mode-map [right] 'tetris-move-right)
251 (define-key tetris-mode-map [up] 'tetris-rotate-prev)
252 (define-key tetris-mode-map [down] 'tetris-rotate-next)
253
254 (defvar tetris-null-map
255 (make-sparse-keymap 'tetris-null-map))
256
257 (define-key tetris-null-map "n" 'tetris-start-game)
258
259 ;; ;;;;;;;;;;;;;;;; timer functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
260
261 (defun tetris-start-timer (period)
262 (setq tetris-timer
263 (if (featurep 'itimer)
264 (start-itimer
265 "Tetris"
266 'tetris-update-game period period
267 nil t (current-buffer))
268 (run-with-timer
269 period period
270 'tetris-update-game (current-buffer)))))
271
272 (defun tetris-set-timer (delay)
273 (if tetris-timer
274 (if (featurep 'itimer)
275 (set-itimer-restart tetris-timer delay)
276 (timer-set-time tetris-timer
277 (list (aref tetris-timer 1)
278 (aref tetris-timer 2)
279 (aref tetris-timer 3))
280 delay))))
281
282 (defun tetris-kill-timer ()
283 (if tetris-timer
284 (if (featurep 'itimer)
285 (delete-itimer tetris-timer)
286 (timer-set-time tetris-timer '(0 0 0) nil)))
287 (setq tetris-timer nil))
288
289 ;; ;;;;;;;;;;;;; display functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
290
291 (defun tetris-color (col shade)
292 (let* ((vec (aref tetris-colors col))
293 (v (floor (* shade 255)))
294 (r (* v (aref vec 0)))
295 (g (* v (aref vec 1)))
296 (b (* v (aref vec 2))))
297 (format "#%02x%02x%02x" r g b)))
298
299 (defun tetris-set-font (face)
300 (if tetris-font
301 (condition-case nil
302 (set-face-font face tetris-font)
303 ('error nil))))
304
305 (defun tetris-setup-face (face color)
306 (set-face-foreground face color)
307 (set-face-background face color)
308 (tetris-set-font face)
309 (condition-case nil
310 (set-face-background-pixmap face [nothing]) ;; XEmacs
311 ('error nil))
312 (condition-case nil
313 (set-face-background-pixmap face nil) ;; Emacs
314 ('error nil)))
315
316 (defun tetris-make-mono-tty-face ()
317 (let ((face (make-face 'tetris-mono-tty-face)))
318 (condition-case nil
319 (set-face-property face 'reverse t)
320 ('error nil))
321 face))
322
323 (defun tetris-make-color-tty-face (c)
324 (let* ((name (intern (format "tetris-color-tty-face-%d" c)))
325 (face (make-face name)))
326 (tetris-setup-face face (aref tetris-text-colors c))
327 face))
328
329 (defun tetris-make-x-border-face ()
330 (let ((face (make-face 'tetris-x-border-face)))
331 (tetris-set-font face)
332 face))
333
334 (defun tetris-make-mono-x-face ()
335 (let ((face (make-face 'tetris-mono-x-face))
336 (color (face-foreground 'default)))
337 (if (null color)
338 (setq color
339 (cdr-safe (assq 'foreground-color (frame-parameters)))))
340 (tetris-setup-face face color)
341 face))
342
343 (defun tetris-make-color-x-face (c)
344 (let* ((name (intern (format "tetris-color-x-face-%d" c)))
345 (face (make-face name)))
346 (tetris-setup-face face (tetris-color c 1.0))
347 face))
348
349 (defun tetris-make-mono-tty-faces ()
350 (let ((face (tetris-make-mono-tty-face)))
351 (loop for c from 0 to 255 do
352 (aset tetris-faces c
353 (cond
354 ((or (= c 0) (> c 7))
355 'default)
356 (t
357 face))))))
358
359 (defun tetris-make-color-tty-faces ()
360 (loop for c from 0 to 255 do
361 (aset tetris-faces c
362 (cond
363 ((> c 7)
364 'default)
365 (t
366 (tetris-make-color-tty-face c))))))
367
368 (defun tetris-make-mono-x-faces ()
369 (let ((face (tetris-make-mono-x-face))
370 (face2 (tetris-make-x-border-face)))
371 (loop for c from 0 to 255 do
372 (aset tetris-faces c
373 (cond
374 ((or (= c 0) (= c tetris-border))
375 face2)
376 ((> c 7)
377 'default)
378 (t
379 face))))))
380
381 (defun tetris-make-color-x-faces ()
382 (loop for c from 0 to 255 do
383 (aset tetris-faces c
384 (cond
385 ((= c tetris-border)
386 (tetris-make-x-border-face))
387 ((> c 7)
388 'default)
389 (t
390 (tetris-make-color-x-face c))))))
391
392 (defun tetris-make-glyph (index)
393 (make-glyph
394 (vector
395 'xpm
396 :data tetris-xpm
397 :color-symbols (list
398 (cons "col1" (tetris-color index 0.6))
399 (cons "col2" (tetris-color index 0.8))
400 (cons "col3" (tetris-color index 1.0))))))
401
402 (defun tetris-make-display-table ()
403 (setq tetris-display-table (make-display-table))
404 (aset tetris-display-table tetris-space tetris-space-char)
405 (case tetris-display-mode
406 ('glyph
407 (aset tetris-display-table tetris-border (tetris-make-glyph 8))
408 (aset tetris-display-table tetris-blank (tetris-make-glyph 0)))
409 (otherwise
410 (aset tetris-display-table tetris-border tetris-border-char)
411 (aset tetris-display-table tetris-blank tetris-space-char)))
412 (loop for i from 1 to 7 do
413 (aset tetris-display-table
414 (+ tetris-blank i)
415 (case tetris-display-mode
416 ('glyph
417 (tetris-make-glyph i))
418 ('emacs-tty
419 tetris-emacs-block-char)
420 (otherwise
421 tetris-block-char)))))
422
423 (defun tetris-color-display-p ()
424 (if (fboundp 'device-class)
425 (eq (device-class (selected-device)) 'color)
426 (eq (cdr-safe (assq 'display-type (frame-parameters))) 'color)))
427
428 (defun tetris-display-type ()
429 (cond ((and tetris-use-glyphs (eq window-system 'x) (featurep 'xpm))
430 'glyph)
431 ((and tetris-use-color (eq window-system 'x) (tetris-color-display-p))
432 'color-x)
433 ((eq window-system 'x)
434 'mono-x)
435 ((and tetris-use-color (tetris-color-display-p))
436 'color-tty)
437 (t
438 (if (fboundp 'set-face-property)
439 'mono-tty
440 'emacs-tty))))
441
442 (defun tetris-initialize-display ()
443 (setq tetris-display-mode (tetris-display-type))
444 (tetris-make-display-table)
445 (case tetris-display-mode
446 ('mono-tty
447 (tetris-make-mono-tty-faces))
448 ('color-tty
449 (tetris-make-color-tty-faces))
450 ('mono-x
451 (tetris-make-mono-x-faces))
452 ('color-x
453 (tetris-make-color-x-faces))))
454
455 (defun tetris-set-display-table ()
456 (if (fboundp 'specifierp)
457 (add-spec-to-specifier current-display-table
458 tetris-display-table
459 (current-buffer)
460 nil 'remove-locale)
461 (setq buffer-display-table tetris-display-table)))
462
463 (defun tetris-hide-cursor ()
464 (if (fboundp 'specifierp)
465 (set-specifier text-cursor-visible-p nil (current-buffer))))
466
467 (defun tetris-draw-border-p ()
468 (or (not (eq tetris-display-mode 'glyph))
469 tetris-draw-border-with-glyphs))
470
471 (defun tetris-set-color (c)
472 (unless (eq tetris-display-mode 'glyph)
473 (put-text-property
474 (1- (point)) (point) 'face (aref tetris-faces c))))
475
476 ;; ;;;;;;;;;;;;;;;; game functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
477
478 (defun tetris-get-tick-period ()
479 (if (boundp 'tetris-update-speed-function)
480 (let ((period (apply tetris-update-speed-function
481 tetris-n-shapes
482 tetris-n-rows nil)))
483 (and (numberp period) period))))
484
485 (defun tetris-cell-offset (x y)
486 (+ tetris-buffer-start
487 (* (1+ tetris-buffer-width) y)
488 x))
489
490 (defun tetris-get-cell (x y)
491 (char-after (tetris-cell-offset x y)))
492
493 (defun tetris-set-cell (x y c)
494 (save-excursion
495 (let ((buffer-read-only nil))
496 (goto-char (tetris-cell-offset x y))
497 (delete-char 1)
498 (insert-char c 1)
499 (tetris-set-color c))))
500
501 (defun tetris-get-shape-cell (x y)
502 (aref
503 (aref
504 (aref
505 (aref tetris-shapes tetris-shape)
506 y)
507 tetris-rot)
508 x))
509
510 (defun tetris-shape-width ()
511 (aref (aref tetris-shape-dimensions tetris-shape)
512 (% tetris-rot 2)))
513
514 (defun tetris-shape-height ()
515 (aref (aref tetris-shape-dimensions tetris-shape)
516 (- 1 (% tetris-rot 2))))
517
518 (defun tetris-draw-score ()
519 (let ((strings (vector
520 (format "Shapes: %05d" tetris-n-shapes)
521 (format "Rows: %05d" tetris-n-rows))))
522 (loop for y from 0 to 1 do
523 (let* ((string (aref strings y))
524 (len (length string)))
525 (loop for x from 0 to (1- len) do
526 (tetris-set-cell
527 (+ tetris-score-x x)
528 (+ tetris-score-y y)
529 (aref string x)))))))
530
531 (defun tetris-update-score ()
532 (tetris-draw-score)
533 (let ((period (tetris-get-tick-period)))
534 (if period (tetris-set-timer period))))
535
536 (defun tetris-new-shape ()
537 (setq tetris-shape tetris-next-shape)
538 (setq tetris-rot 0)
539 (setq tetris-next-shape (random 7))
540 (setq tetris-pos-x (random (- tetris-width (tetris-shape-width))))
541 (setq tetris-pos-y 0)
542 (setq tetris-n-shapes (1+ tetris-n-shapes))
543 (tetris-draw-next-shape)
544 (tetris-update-score))
545
546 (defun tetris-draw-next-shape ()
547 (loop for y from 0 to 3 do
548 (loop for x from 0 to 3 do
549 (tetris-set-cell
550 (+ tetris-next-x x)
551 (+ tetris-next-y y)
552 (let ((tetris-shape tetris-next-shape)
553 (tetris-rot 0))
554 (tetris-get-shape-cell x y))))))
555
556 (defun tetris-draw-shape ()
557 (loop for y from 0 to (1- (tetris-shape-height)) do
558 (loop for x from 0 to (1- (tetris-shape-width)) do
559 (let ((c (tetris-get-shape-cell x y)))
560 (if (/= c tetris-blank)
561 (tetris-set-cell
562 (+ tetris-top-left-x tetris-pos-x x)
563 (+ tetris-top-left-y tetris-pos-y y)
564 c))))))
565
566 (defun tetris-erase-shape ()
567 (loop for y from 0 to (1- (tetris-shape-height)) do
568 (loop for x from 0 to (1- (tetris-shape-width)) do
569 (let ((c (tetris-get-shape-cell x y)))
570 (if (/= c tetris-blank)
571 (tetris-set-cell
572 (+ tetris-top-left-x tetris-pos-x x)
573 (+ tetris-top-left-y tetris-pos-y y)
574 tetris-blank))))))
575
576 (defun tetris-test-shape ()
577 (let ((hit nil))
578 (loop for y from 0 to (1- (tetris-shape-height)) do
579 (loop for x from 0 to (1- (tetris-shape-width)) do
580 (unless hit
581 (setq hit
582 (let ((c (tetris-get-shape-cell x y))
583 (xx (+ tetris-pos-x x))
584 (yy (+ tetris-pos-y y)))
585 (and (/= c tetris-blank)
586 (or (>= xx tetris-width)
587 (>= yy tetris-height)
588 (/= (tetris-get-cell
589 (+ tetris-top-left-x xx)
590 (+ tetris-top-left-y yy))
591 tetris-blank))))))))
592 hit))
593
594 (defun tetris-full-row (y)
595 (let ((full t))
596 (loop for x from 0 to (1- tetris-width) do
597 (if (= (tetris-get-cell
598 (+ tetris-top-left-x x)
599 (+ tetris-top-left-y y))
600 tetris-blank)
601 (setq full nil)))
602 full))
603
604 (defun tetris-shift-row (y)
605 (loop for x from 0 to (1- tetris-width) do
606 (let ((c (tetris-get-cell
607 (+ tetris-top-left-x x)
608 (+ tetris-top-left-y y -1))))
609 (tetris-set-cell
610 (+ tetris-top-left-x x)
611 (+ tetris-top-left-y y)
612 c))))
613
614 (defun tetris-shift-down ()
615 (loop for y0 from (1- tetris-height) downto 0 do
616 (if (tetris-full-row y0)
617 (progn
618 (setq tetris-n-rows (1+ tetris-n-rows))
619 (tetris-update-score)
620 (loop for y from y0 downto 1 do
621 (tetris-shift-row y))))))
622
623 (defun tetris-init-buffer ()
624 (let ((line (concat
625 (make-string tetris-buffer-width tetris-space)
626 "\n"))
627 (buffer-read-only nil))
628 (erase-buffer)
629 (setq tetris-buffer-start (point))
630 (dotimes (i tetris-buffer-height)
631 (insert-string line))
632 (if (tetris-draw-border-p)
633 (loop for y from -1 to tetris-height do
634 (loop for x from -1 to tetris-width do
635 (tetris-set-cell
636 (+ tetris-top-left-x x)
637 (+ tetris-top-left-y y)
638 tetris-border))))
639 (loop for y from 0 to (1- tetris-height) do
640 (loop for x from 0 to (1- tetris-width) do
641 (tetris-set-cell
642 (+ tetris-top-left-x x)
643 (+ tetris-top-left-y y)
644 tetris-blank)))
645 (if (tetris-draw-border-p)
646 (loop for y from -1 to 4 do
647 (loop for x from -1 to 4 do
648 (tetris-set-cell
649 (+ tetris-next-x x)
650 (+ tetris-next-y y)
651 tetris-border))))))
652
653 (defun tetris-reset-game ()
654 (tetris-kill-timer)
655 (tetris-init-buffer)
656 (setq tetris-next-shape (random 7))
657 (setq tetris-shape 0
658 tetris-rot 0
659 tetris-n-shapes 0
660 tetris-n-rows 0
661 tetris-pos-x 0
662 tetris-pos-y 0)
663 (tetris-new-shape)
664 (tetris-draw-shape))
665
666 (defun tetris-shape-done ()
667 (tetris-shift-down)
668 (tetris-new-shape)
669 (if (tetris-test-shape)
670 (progn
671 (tetris-end-game))
672 (tetris-draw-shape)))
673
674 (defun tetris-update-game (tetris-buffer)
675 "Called on each clock tick.
676 Drops the shape one square, testing for collision."
677 (if (eq (current-buffer) tetris-buffer)
678 (let (hit)
679 (tetris-erase-shape)
680 (setq tetris-pos-y (1+ tetris-pos-y))
681 (setq hit (tetris-test-shape))
682 (if hit
683 (setq tetris-pos-y (1- tetris-pos-y)))
684 (tetris-draw-shape)
685 (if hit
686 (tetris-shape-done)))))
687
688 (defun tetris-move-bottom ()
689 "Drops the shape to the bottom of the playing area"
690 (interactive)
691 (let ((hit nil))
692 (tetris-erase-shape)
693 (while (not hit)
694 (setq tetris-pos-y (1+ tetris-pos-y))
695 (setq hit (tetris-test-shape)))
696 (setq tetris-pos-y (1- tetris-pos-y))
697 (tetris-draw-shape)
698 (tetris-shape-done)))
699
700 (defun tetris-move-left ()
701 "Moves the shape one square to the left"
702 (interactive)
703 (unless (= tetris-pos-x 0)
704 (tetris-erase-shape)
705 (setq tetris-pos-x (1- tetris-pos-x))
706 (if (tetris-test-shape)
707 (setq tetris-pos-x (1+ tetris-pos-x)))
708 (tetris-draw-shape)))
709
710 (defun tetris-move-right ()
711 "Moves the shape one square to the right"
712 (interactive)
713 (unless (= (+ tetris-pos-x (tetris-shape-width))
714 tetris-width)
715 (tetris-erase-shape)
716 (setq tetris-pos-x (1+ tetris-pos-x))
717 (if (tetris-test-shape)
718 (setq tetris-pos-x (1- tetris-pos-x)))
719 (tetris-draw-shape)))
720
721 (defun tetris-rotate-prev ()
722 "Rotates the shape clockwise"
723 (interactive)
724 (tetris-erase-shape)
725 (setq tetris-rot (% (+ 1 tetris-rot) 4))
726 (if (tetris-test-shape)
727 (setq tetris-rot (% (+ 3 tetris-rot) 4)))
728 (tetris-draw-shape))
729
730 (defun tetris-rotate-next ()
731 "Rotates the shape anticlockwise"
732 (interactive)
733 (tetris-erase-shape)
734 (setq tetris-rot (% (+ 3 tetris-rot) 4))
735 (if (tetris-test-shape)
736 (setq tetris-rot (% (+ 1 tetris-rot) 4)))
737 (tetris-draw-shape))
738
739 (defun tetris-end-game ()
740 "Terminates the current game"
741 (interactive)
742 (tetris-kill-timer)
743 (use-local-map tetris-null-map))
744
745 (defun tetris-start-game ()
746 "Starts a new game of Tetris"
747 (interactive)
748 (tetris-reset-game)
749 (use-local-map tetris-mode-map)
750 (let ((period (or (tetris-get-tick-period)
751 tetris-default-tick-period)))
752 (tetris-start-timer period)))
753
754 (put 'tetris-mode 'mode-class 'special)
755
756 (defun tetris-mode ()
757 "A mode for playing Tetris.
758
759 tetris-mode keybindings:
760 \\{tetris-mode-map}
761 "
762 (kill-all-local-variables)
763
764 (make-local-hook 'kill-buffer-hook)
765 (add-hook 'kill-buffer-hook 'tetris-end-game nil t)
766
767 (make-local-variable 'tetris-display-mode)
768 (make-local-variable 'tetris-display-table)
769 (make-local-variable 'tetris-faces)
770 (make-local-variable 'tetris-timer)
771 (make-local-variable 'tetris-buffer-start)
772 (make-local-variable 'tetris-shape)
773 (make-local-variable 'tetris-rot)
774 (make-local-variable 'tetris-next-shape)
775 (make-local-variable 'tetris-n-shapes)
776 (make-local-variable 'tetris-n-rows)
777 (make-local-variable 'tetris-pos-x)
778 (make-local-variable 'tetris-pos-y)
779
780 (use-local-map tetris-null-map)
781
782 (setq buffer-read-only t)
783 (setq truncate-lines 't)
784 (setq major-mode 'tetris-mode)
785 (setq mode-name "Tetris")
786
787 (buffer-disable-undo (current-buffer))
788
789 (tetris-initialize-display)
790 (tetris-set-display-table)
791 (tetris-hide-cursor)
792
793 (run-hooks 'tetris-mode-hook))
794
795 (defun tetris ()
796 "Tetris
797
798 Shapes drop from the top of the screen, and the user has to move and
799 rotate the shape to fit in with those at the bottom of the screen so
800 as to form complete rows.
801
802 tetris-mode keybindings:
803 \\<tetris-mode-map>
804 \\[tetris-start-game] Starts a new game of Tetris
805 \\[tetris-end-game] Terminates the current game
806 \\[tetris-move-left] Moves the shape one square to the left
807 \\[tetris-move-right] Moves the shape one square to the right
808 \\[tetris-rotate-prev] Rotates the shape clockwise
809 \\[tetris-rotate-next] Rotates the shape anticlockwise
810 \\[tetris-move-bottom] Drops the shape to the bottom of the playing area
811
812 "
813 (interactive)
814
815 (switch-to-buffer tetris-buffer-name)
816 (tetris-kill-timer)
817 (tetris-mode)
818 (tetris-start-game))
819
820 (provide 'tetris)
821
822 ;;; tetris.el ends here
823