|
185
|
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
|
