cgit.sxemacs.org Git - packages/blob - xemacs-packages/games/tetris.el

   1 ;;; tetris.el -- Implementation of Tetris for Emacs.
   2
   3 ;; Copyright (C) 1998 Free Software Foundation, Inc.
   4
   5 ;; Author: Glynn Clements <glynn@gclements.plus.com>
   6 ;; Version: 2.03
   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 ;; Modified: 1997-09-09, changed layout to work in a 22 line window
  46 ;; Modified: 1997-09-10, exported display handling to gamegrid.el
  47 ;; Modified: 1997-09-12
  48 ;;      fixed tetris-shift-down to deal with multiple rows correctly
  49 ;; Modified: 1998-01-05  (cgw) added pause, score, high score file
  50 ;; Modified: 1998-05-28
  51 ;;      Make new shapes appear at the centre of the top edge
  52 ;;      Test whether the next shape can be placed before replacing it
  53 ;;      Make tetris-shift-down clear the top row
  54 ;;      Added popup menu
  55 ;; Modified: 1998-06-23, copyright assigned to FSF
  56 ;; Modified: 2003-06-14
  57 ;;      update email address, remove URL
  58 ;;      various changes from David Costanzo <david_costanzo@yahoo.com>
  59
  60 ;; Tested with XEmacs 20.3/4/5, 21.4.13 and Emacs 19.34
  61
  62 (eval-when-compile
  63   (require 'cl))
  64
  65 (require 'gamegrid)
  66
  67 ;; ;;;;;;;;;;;;; customization variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  68
  69 (defvar tetris-use-glyphs t
  70   "Non-nil means use glyphs when available")
  71
  72 (defvar tetris-use-color t
  73   "Non-nil means use color when available")
  74
  75 (defvar tetris-draw-border-with-glyphs t
  76   "Non-nil means draw a border even when using glyphs")
  77
  78 (defvar tetris-default-tick-period 0.3
  79   "The default time taken for a shape to drop one row")
  80
  81 (defvar tetris-clear-wait-tick-period 0.5
  82   "The default time taken to clear a full row.")
  83
  84 (defvar tetris-update-speed-function
  85   'tetris-default-update-speed-function
  86   "Function run whenever the Tetris score changes
  87 Called with two arguments: (SHAPES ROWS)
  88 SHAPES is the number of shapes which have been dropped
  89 ROWS is the number of rows which have been completed
  90
  91 If the return value is a number, it is used as the timer period")
  92
  93 (defvar tetris-mode-hook nil
  94   "Hook run upon starting Tetris")
  95
  96 (defvar tetris-tty-colors
  97   [nil "blue" "white" "yellow" "magenta" "cyan" "green" "red"]
  98   "Vector of colors of the various shapes in text mode
  99 Element 0 is ignored")
 100
 101 (defvar tetris-x-colors
 102   [nil [0 0 1] [0.7 0 1] [1 1 0] [1 0 1] [0 1 1] [0 1 0] [1 0 0]]
 103   "Vector of colors of the various shapes
 104 Element 0 is ignored")
 105
 106 (defvar tetris-buffer-name "*Tetris*"
 107   "Name used for Tetris buffer")
 108
 109 (defvar tetris-buffer-width 30
 110   "Width of used portion of buffer")
 111
 112 (defvar tetris-buffer-height 22
 113   "Height of used portion of buffer")
 114
 115 (defvar tetris-width 10
 116   "Width of playing area")
 117
 118 (defvar tetris-height 20
 119   "Height of playing area")
 120
 121 (defvar tetris-top-left-x 3
 122   "X position of top left of playing area")
 123
 124 (defvar tetris-top-left-y 1
 125   "Y position of top left of playing area")
 126
 127 (defvar tetris-next-x (+ (* 2 tetris-top-left-x) tetris-width)
 128   "X position of next shape")
 129
 130 (defvar tetris-next-y tetris-top-left-y
 131   "Y position of next shape")
 132
 133 (defvar tetris-score-x tetris-next-x
 134   "X position of score")
 135
 136 (defvar tetris-score-y (+ tetris-next-y 6)
 137   "Y position of score")
 138
 139 (defvar tetris-score-file
 140   (expand-file-name "tetris-scores" user-init-directory)
 141 ;; anybody with a well-connected server want to host this?
 142 ;(defvar tetris-score-file "/anonymous@ftp.pgt.com:/pub/cgw/tetris-scores"
 143   "File for holding high scores")
 144
 145 ;; ;;;;;;;;;;;;; display options ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 146
 147 (defvar tetris-border-options
 148   '(((glyph colorize)
 149      (t ?\+))
 150     ((color-x color-x)
 151      (mono-x grid-x)
 152      (t nil))
 153     (((glyph color-x) [0.5 0.5 0.5])
 154      (t nil))))
 155
 156 (defvar tetris-blank-options
 157   '(((glyph colorize)
 158      (t ?\040))
 159     ((color-x color-x)
 160      (mono-x grid-x)
 161      (color-tty color-tty)
 162      (t nil))
 163     (((glyph color-x) [0 0 0])
 164      (color-tty "black")
 165      (t nil))))
 166
 167 (defvar tetris-clearing-options
 168   '(((glyph colorize)
 169      (t ?\*))
 170     ((color-x color-x)
 171      (mono-x grid-x)
 172      (t nil))
 173     (((glyph color-x) [1.0 1.0 1.0])
 174      (color-tty "white")
 175      (t nil))))
 176
 177 (defvar tetris-cell-options
 178   '(((glyph colorize)
 179      (emacs-tty ?O)
 180      (t ?\040))
 181     ((color-x color-x)
 182      (mono-x mono-x)
 183      (color-tty color-tty)
 184      (mono-tty mono-tty)
 185      (t nil))
 186     ;; color information is taken from tetris-x-colors and tetris-tty-colors
 187     ))
 188
 189 (defvar tetris-space-options
 190   '(((t ?\040))
 191     nil
 192     nil))
 193
 194 ;; ;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 195
 196 (defconst tetris-shapes
 197   [[[[1 1 0 0] [1 1 0 0] [1 1 0 0] [1 1 0 0]]
 198     [[1 1 0 0] [1 1 0 0] [1 1 0 0] [1 1 0 0]]
 199     [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]
 200     [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
 201
 202    [[[2 2 2 0] [0 2 0 0] [2 0 0 0] [2 2 0 0]]
 203     [[0 0 2 0] [0 2 0 0] [2 2 2 0] [2 0 0 0]]
 204     [[0 0 0 0] [2 2 0 0] [0 0 0 0] [2 0 0 0]]
 205     [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
 206
 207    [[[3 3 3 0] [3 3 0 0] [0 0 3 0] [3 0 0 0]]
 208     [[3 0 0 0] [0 3 0 0] [3 3 3 0] [3 0 0 0]]
 209     [[0 0 0 0] [0 3 0 0] [0 0 0 0] [3 3 0 0]]
 210     [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
 211
 212    [[[4 4 0 0] [0 4 0 0] [4 4 0 0] [0 4 0 0]]
 213     [[0 4 4 0] [4 4 0 0] [0 4 4 0] [4 4 0 0]]
 214     [[0 0 0 0] [4 0 0 0] [0 0 0 0] [4 0 0 0]]
 215     [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
 216
 217    [[[0 5 5 0] [5 0 0 0] [0 5 5 0] [5 0 0 0]]
 218     [[5 5 0 0] [5 5 0 0] [5 5 0 0] [5 5 0 0]]
 219     [[0 0 0 0] [0 5 0 0] [0 0 0 0] [0 5 0 0]]
 220     [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
 221
 222    [[[0 6 0 0] [0 6 0 0] [0 0 0 0] [0 6 0 0]]
 223     [[6 6 6 0] [0 6 6 0] [6 6 6 0] [6 6 0 0]]
 224     [[0 0 0 0] [0 6 0 0] [0 6 0 0] [0 6 0 0]]
 225     [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
 226
 227    [[[7 7 7 7] [0 7 0 0] [7 7 7 7] [0 7 0 0]]
 228     [[0 0 0 0] [0 7 0 0] [0 0 0 0] [0 7 0 0]]
 229     [[0 0 0 0] [0 7 0 0] [0 0 0 0] [0 7 0 0]]
 230     [[0 0 0 0] [0 7 0 0] [0 0 0 0] [0 7 0 0]]]])
 231
 232 ;;the scoring rules were taken from "xtetris".  Blocks score differently
 233 ;;depending on their rotation
 234
 235 (defconst tetris-shape-scores
 236   [ [6 6 6 6] [6 7 6 7] [6 7 6 7] [6 7 6 7] [6 7 6 7] [5 5 6 5] [5 8 5 8]] )
 237
 238 (defconst tetris-shape-dimensions
 239   [[2 2] [3 2] [3 2] [3 2] [3 2] [3 2] [4 1]])
 240
 241 (defconst tetris-blank 0)
 242
 243 (defconst tetris-border 8)
 244
 245 (defconst tetris-space 9)
 246
 247 (defconst tetris-clearing 11)
 248
 249 ;;; Game states
 250 (defconst tetris-state-playing       0)
 251 (defconst tetris-state-clearing      1)
 252 (defconst tetris-state-clearing-wait 2)
 253
 254 (defun tetris-default-update-speed-function (shapes rows)
 255   (/ 20.0 (+ 50.0 rows)))
 256
 257 ;; ;;;;;;;;;;;;; variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 258
 259 (defvar tetris-shape 0)
 260 (defvar tetris-rot 0)
 261 (defvar tetris-next-shape 0)
 262 (defvar tetris-n-shapes 0)
 263 (defvar tetris-n-rows 0)
 264 (defvar tetris-score 0)
 265 (defvar tetris-pos-x 0)
 266 (defvar tetris-pos-y 0)
 267 (defvar tetris-paused nil)
 268 (defvar tetris-state  tetris-state-playing)
 269 (defvar tetris-shapes-bounding-boxes nil)
 270
 271 (make-variable-buffer-local 'tetris-shape)
 272 (make-variable-buffer-local 'tetris-rot)
 273 (make-variable-buffer-local 'tetris-next-shape)
 274 (make-variable-buffer-local 'tetris-n-shapes)
 275 (make-variable-buffer-local 'tetris-n-rows)
 276 (make-variable-buffer-local 'tetris-score)
 277 (make-variable-buffer-local 'tetris-pos-x)
 278 (make-variable-buffer-local 'tetris-pos-y)
 279 (make-variable-buffer-local 'tetris-paused)
 280
 281 ;; ;;;;;;;;;;;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 282
 283 (defvar tetris-mode-map
 284   (make-sparse-keymap 'tetris-mode-map))
 285
 286 (define-key tetris-mode-map "n"         'tetris-start-game)
 287 (define-key tetris-mode-map "q"         'tetris-end-game)
 288 (define-key tetris-mode-map "p"         'tetris-pause-game)
 289
 290 (define-key tetris-mode-map " "         'tetris-move-bottom)
 291 (define-key tetris-mode-map [left]      'tetris-move-left)
 292 (define-key tetris-mode-map [right]     'tetris-move-right)
 293 (define-key tetris-mode-map [up]        'tetris-rotate-prev)
 294 (define-key tetris-mode-map [down]      'tetris-rotate-next)
 295
 296 (defvar tetris-null-map
 297   (make-sparse-keymap 'tetris-null-map))
 298
 299 (define-key tetris-null-map "n"         'tetris-start-game)
 300
 301 ;; ;;;;;;;;;;;;;;;; game functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 302
 303 (defun tetris-display-options ()
 304   (let ((options (make-vector 256 nil)))
 305     (loop for c from 0 to 255 do
 306       (aset options c
 307             (cond ((= c tetris-blank)
 308                     tetris-blank-options)
 309                   ((and (>= c 1) (<= c 7))
 310                    (append
 311                     tetris-cell-options
 312                     `((((glyph color-x) ,(aref tetris-x-colors c))
 313                        (color-tty ,(aref tetris-tty-colors c))
 314                        (t nil)))))
 315                    ((= c tetris-border)
 316                     tetris-border-options)
 317                    ((= c tetris-space)
 318                     tetris-space-options)
 319                    ((= c tetris-clearing)
 320                     tetris-clearing-options)
 321                   (t
 322                    '(nil nil nil)))))
 323     options))
 324
 325 (defun tetris-get-tick-period ()
 326   (if (boundp 'tetris-update-speed-function)
 327       (let ((period (apply tetris-update-speed-function
 328                            tetris-n-shapes
 329                            tetris-n-rows nil)))
 330         (and (numberp period) period))))
 331
 332 (defun tetris-shape-rotation-get-cell (shape rotation x y)
 333   (aref (aref (aref (aref tetris-shapes
 334                           shape)
 335                     y)
 336               rotation)
 337         x))
 338
 339 (defun tetris-get-shape-cell (x y)
 340   (tetris-shape-rotation-get-cell tetris-shape tetris-rot x y))
 341
 342 (defun tetris-shape-width (shape rotation)
 343   (aref (aref tetris-shape-dimensions shape)
 344         (% rotation 2)))
 345
 346 (defun tetris-shape-height (shape rotation)
 347   (aref (aref tetris-shape-dimensions shape)
 348         (- 1 (% rotation 2))))
 349
 350 (defun tetris-draw-score ()
 351   (let ((strings (vector (format "Shapes: %05d" tetris-n-shapes)
 352                          (format "Rows:   %05d" tetris-n-rows)
 353                          (format "Score:  %05d" tetris-score))))
 354     (loop for y from 0 to 2 do
 355           (let* ((string (aref strings y))
 356                  (len (length string)))
 357             (loop for x from 0 to (1- len) do
 358                   (gamegrid-set-cell (+ tetris-score-x x)
 359                                      (+ tetris-score-y y)
 360                                      (aref string x)))))))
 361
 362
 363 (defun tetris-shape-min-x (shape rotation)
 364   (tetris-bounding-box-min-x (aref (aref tetris-shapes-bounding-boxes
 365                                             shape)
 366                                       rotation)))
 367
 368 (defun tetris-shape-max-x (shape rotation)
 369   (tetris-bounding-box-max-x (aref (aref tetris-shapes-bounding-boxes
 370                                             shape)
 371                                       rotation)))
 372
 373 (defun tetris-shape-min-y (shape rotation)
 374   (tetris-bounding-box-min-y (aref (aref tetris-shapes-bounding-boxes
 375                                             shape)
 376                                       rotation)))
 377
 378 (defun tetris-shape-max-y (shape rotation)
 379   (tetris-bounding-box-max-y (aref (aref tetris-shapes-bounding-boxes
 380                                             shape)
 381                                       rotation)))
 382
 383 ;; Structure for a 2D bounding box.
 384 (defstruct (tetris-bounding-box)
 385   (min-x 0)
 386   (min-y 0)
 387   (max-x 3)
 388   (max-y 3))
 389
 390
 391 ;; Adds a new point to the bounding box, adjusting the min and max values
 392 ;; for x and y necessary
 393 (defun tetris-bounding-box-add-point (box x y)
 394   (if (< x (tetris-bounding-box-min-x box)) ; new min-x
 395       (setf (tetris-bounding-box-min-x box) x))
 396   (if (< y (tetris-bounding-box-min-y box)) ; new min-y
 397       (setf (tetris-bounding-box-min-y box) y))
 398   (if (> x (tetris-bounding-box-max-x box)) ; new max-x
 399       (setf (tetris-bounding-box-max-x box) x))
 400   (if (> y (tetris-bounding-box-max-y box)) ; new min-y
 401       (setf (tetris-bounding-box-max-y box) y)))
 402
 403 ;; Computes the bounding boxes for all shape/rotation pairs.
 404 ;; Returns the result as a 2D array of tetris-bounding-box structures,
 405 ;; where the first dimensions is keyed by the shape index and the second
 406 ;; dimension is keyed by the rotation.
 407 (defun tetris-bounding-box-compute-all ()
 408
 409   ; create the structure
 410   (let ((bounding-boxes (make-vector 7 nil)))
 411     (loop for current-shape from 0 to 6 do
 412       (setf (aref bounding-boxes current-shape) (make-vector 4 nil))
 413       (loop for current-rotation from 0 to 3 do
 414         (let ((bounding-box (make-tetris-bounding-box :min-x 3
 415                                                          :min-y 3
 416                                                          :max-x 0
 417                                                          :max-y 0)))
 418
 419           (setf (aref (aref bounding-boxes
 420                             current-shape)
 421                       current-rotation)
 422                 bounding-box))))
 423
 424   ; fill in the values
 425   (loop for current-shape from 0 to 6 do
 426       (loop for current-rotation from 0 to 3 do
 427         (loop for x from 0 to 3 do
 428             (loop for y from 0 to 3 do
 429               (if (/= tetris-space
 430                       (tetris-shape-rotation-get-cell current-shape current-rotation x y))
 431                   (tetris-bounding-box-add-point (aref (aref bounding-boxes
 432                                                                 current-shape)
 433                                                           current-rotation)
 434                                                     x
 435                                                     y))))))
 436   bounding-boxes))
 437
 438
 439 (defun tetris-update-score ()
 440   (tetris-draw-score)
 441   (let ((period (tetris-get-tick-period)))
 442     (if period (gamegrid-set-timer period))))
 443
 444 (defun tetris-new-shape ()
 445   (setq tetris-shape tetris-next-shape)
 446   (setq tetris-rot 0)
 447   (setq tetris-next-shape (random 7))
 448   (setq tetris-pos-x (/ (- tetris-width (tetris-shape-width tetris-shape
 449                                                             tetris-rot))
 450                         2))
 451   (setq tetris-pos-y 0)
 452   (if (tetris-test-shape)
 453       (tetris-end-game)
 454     (tetris-draw-shape))
 455   (tetris-draw-next-shape)
 456   (tetris-update-score))
 457
 458 (defun tetris-draw-next-shape ()
 459   (loop for y from 0 to 3 do
 460         (loop for x from 0 to 3 do
 461               (gamegrid-set-cell (+ tetris-next-x x)
 462                                  (+ tetris-next-y y)
 463                                  (let ((tetris-shape tetris-next-shape)
 464                                        (tetris-rot 0))
 465                                    (tetris-get-shape-cell x y))))))
 466
 467 (defun tetris-draw-shape ()
 468   (let ((min-x (tetris-shape-min-x tetris-shape tetris-rot))
 469         (min-y (tetris-shape-min-y tetris-shape tetris-rot))
 470         (max-x (tetris-shape-max-x tetris-shape tetris-rot))
 471         (max-y (tetris-shape-max-y tetris-shape tetris-rot)))
 472     (loop for y from min-y to max-y do
 473         (loop for x from min-x to max-x do
 474               (let ((c (tetris-get-shape-cell x y)))
 475                 (if (/= c tetris-blank)
 476                     (gamegrid-set-cell (+ tetris-top-left-x
 477                                           tetris-pos-x
 478                                           x)
 479                                        (+ tetris-top-left-y
 480                                           tetris-pos-y
 481                                           y)
 482                                        c)))))))
 483
 484 (defun tetris-erase-shape ()
 485   (let ((min-x (tetris-shape-min-x tetris-shape tetris-rot))
 486         (min-y (tetris-shape-min-y tetris-shape tetris-rot))
 487         (max-x (tetris-shape-max-x tetris-shape tetris-rot))
 488         (max-y (tetris-shape-max-y tetris-shape tetris-rot)))
 489     (loop for y from min-y to max-y do
 490         (loop for x from min-x to max-x do
 491               (let ((c (tetris-get-shape-cell x y))
 492                     (px (+ tetris-top-left-x tetris-pos-x x))
 493                     (py (+ tetris-top-left-y tetris-pos-y y)))
 494                 (if (/= c tetris-blank)
 495                     (gamegrid-set-cell px py tetris-blank)))))))
 496
 497 (defun tetris-test-shape ()
 498   (let ((min-x (tetris-shape-min-x tetris-shape tetris-rot))
 499         (min-y (tetris-shape-min-y tetris-shape tetris-rot))
 500         (max-x (tetris-shape-max-x tetris-shape tetris-rot))
 501         (max-y (tetris-shape-max-y tetris-shape tetris-rot)))
 502     (let ((hit nil))
 503        (loop for y from min-y to max-y do
 504             (loop for x from min-x to max-x do
 505                 (unless hit
 506                   (setq hit
 507                         (let* ((c (tetris-get-shape-cell x y))
 508                               (xx (+ tetris-pos-x x))
 509                               (yy (+ tetris-pos-y y))
 510                               (px (+ tetris-top-left-x xx))
 511                               (py (+ tetris-top-left-y yy)))
 512                           (and (/= c tetris-blank)
 513                                (or (>= xx tetris-width)
 514                                    (>= yy tetris-height)
 515                                    (/= (gamegrid-get-cell px py)
 516                                        tetris-blank))))))))
 517     hit)))
 518
 519 (defun tetris-full-rows ()
 520   (let (full-rows)
 521     (loop for y from 0 to (1- tetris-height) do
 522       (if (tetris-full-row y)
 523           (push y full-rows)))
 524     full-rows))
 525
 526 (defun tetris-mark-rows-for-clearing (rows)
 527   (dolist (row-y rows)
 528     (loop for x from 0 to (1- tetris-width) do
 529       (gamegrid-set-cell (+ tetris-top-left-x x)
 530                          (+ tetris-top-left-y row-y)
 531                          tetris-clearing)
 532       )))
 533
 534 (defun tetris-full-row (y)
 535   (let ((full t))
 536     (loop for x from 0 to (1- tetris-width) do
 537           (if (= (gamegrid-get-cell (+ tetris-top-left-x x)
 538                                     (+ tetris-top-left-y y))
 539                  tetris-blank)
 540               (setq full nil)))
 541     full))
 542
 543 (defun tetris-shift-row (y)
 544   (if (= y 0)
 545       (loop for x from 0 to (1- tetris-width) do
 546         (gamegrid-set-cell (+ tetris-top-left-x x)
 547                            (+ tetris-top-left-y y)
 548                            tetris-blank))
 549   (loop for x from 0 to (1- tetris-width) do
 550         (let ((c (gamegrid-get-cell (+ tetris-top-left-x x)
 551                                     (+ tetris-top-left-y y -1))))
 552           (gamegrid-set-cell (+ tetris-top-left-x x)
 553                              (+ tetris-top-left-y y)
 554                            c)))))
 555
 556 (defun tetris-shift-down ()
 557   (loop for y0 from 0 to (1- tetris-height) do
 558         (if (tetris-full-row y0)
 559             (progn (setq tetris-n-rows (1+ tetris-n-rows))
 560                    (loop for y from y0 downto 0 do
 561                          (tetris-shift-row y))))))
 562
 563 (defun tetris-draw-border-p ()
 564   (or (not (eq gamegrid-display-mode 'glyph))
 565       tetris-draw-border-with-glyphs))
 566
 567 (defun tetris-init-buffer ()
 568   (gamegrid-init-buffer tetris-buffer-width
 569                         tetris-buffer-height
 570                         tetris-space)
 571   (let ((buffer-read-only nil))
 572     (if (tetris-draw-border-p)
 573         (loop for y from -1 to tetris-height do
 574               (loop for x from -1 to tetris-width do
 575                     (gamegrid-set-cell (+ tetris-top-left-x x)
 576                                        (+ tetris-top-left-y y)
 577                                        tetris-border))))
 578     (loop for y from 0 to (1- tetris-height) do
 579           (loop for x from 0 to (1- tetris-width) do
 580                 (gamegrid-set-cell (+ tetris-top-left-x x)
 581                                    (+ tetris-top-left-y y)
 582                                    tetris-blank)))
 583     (if (tetris-draw-border-p)
 584         (loop for y from -1 to 4 do
 585               (loop for x from -1 to 4 do
 586                     (gamegrid-set-cell (+ tetris-next-x x)
 587                                        (+ tetris-next-y y)
 588                                        tetris-border))))))
 589
 590 (defun tetris-reset-game ()
 591   (gamegrid-kill-timer)
 592   (tetris-init-buffer)
 593   (setq tetris-next-shape (random 7))
 594   (setq tetris-shape    0
 595         tetris-rot      0
 596         tetris-pos-x    0
 597         tetris-pos-y    0
 598         tetris-n-shapes 0
 599         tetris-n-rows   0
 600         tetris-score    0
 601         tetris-paused   nil
 602         tetris-state    tetris-state-playing)
 603   (tetris-new-shape))
 604
 605 (defun tetris-shape-done ()
 606   (let ((full-rows (tetris-full-rows)))
 607
 608     ;; Update the score while the shape still exists
 609     (setq tetris-n-shapes (1+ tetris-n-shapes))
 610     (setq tetris-score
 611           (+ tetris-score
 612              (aref (aref tetris-shape-scores tetris-shape) tetris-rot)))
 613     (tetris-update-score)
 614
 615     (if full-rows
 616         ;; state transition to clear the full rows
 617         (progn
 618           (setq tetris-state tetris-state-clearing-wait)
 619           (setq tetris-shape nil))
 620       ;; drop the next shape
 621       (tetris-new-shape))))
 622
 623 (defun tetris-update-game (tetris-buffer)
 624   "Called on each clock tick.
 625 Drops the shape one square, testing for collision."
 626   (if (eq (current-buffer) tetris-buffer)
 627       (cond
 628         ((eq tetris-state tetris-state-playing) ; The game is playing
 629          (if (not tetris-paused)
 630              (let (hit)
 631                (tetris-erase-shape)
 632                (setq tetris-pos-y (1+ tetris-pos-y))
 633                (setq hit (tetris-test-shape))
 634                (if hit
 635                    (setq tetris-pos-y (1- tetris-pos-y)))
 636                (tetris-draw-shape)
 637                (if hit
 638                    (tetris-shape-done)))))
 639
 640
 641          ((eq tetris-state tetris-state-clearing-wait) ; The game is marking a full row
 642           (tetris-mark-rows-for-clearing (tetris-full-rows))
 643           (setq tetris-state tetris-state-clearing)
 644
 645           ; Show the marked rows for a peroid of time that is
 646           ; independent of current game speed.
 647           (gamegrid-set-timer tetris-clear-wait-tick-period))
 648
 649
 650          ((eq tetris-state tetris-state-clearing) ; The game is clearing a full row
 651
 652           (tetris-shift-down)
 653           (tetris-new-shape)
 654
 655           ; Restore the tick period back to game-speed
 656           (let ((period (tetris-get-tick-period)))
 657             (if period
 658                 (gamegrid-set-timer period)
 659                 (gamegrid-set-timer tetris-default-tick-period)))
 660
 661           (setq tetris-state tetris-state-playing)))))
 662
 663
 664 (defun tetris-move-bottom ()
 665   "Drops the shape to the bottom of the playing area"
 666   (interactive)
 667   (if (eq tetris-state tetris-state-playing)
 668       (let ((hit nil))
 669         (tetris-erase-shape)
 670         (while (not hit)
 671           (setq tetris-pos-y (1+ tetris-pos-y))
 672           (setq hit (tetris-test-shape)))
 673         (setq tetris-pos-y (1- tetris-pos-y))
 674         (tetris-draw-shape)
 675         (tetris-shape-done))))
 676
 677 (defun tetris-move-left ()
 678   "Moves the shape one square to the left"
 679   (interactive)
 680   (if (eq tetris-state tetris-state-playing)
 681       (progn
 682         (tetris-erase-shape)
 683         (setq tetris-pos-x (1- tetris-pos-x))
 684         (if (tetris-test-shape)
 685             (setq tetris-pos-x (1+ tetris-pos-x)))
 686         (tetris-draw-shape))))
 687
 688 (defun tetris-move-right ()
 689   "Moves the shape one square to the right"
 690   (interactive)
 691   (if (eq tetris-state tetris-state-playing)
 692       (progn
 693         (tetris-erase-shape)
 694         (setq tetris-pos-x (1+ tetris-pos-x))
 695         (if (tetris-test-shape)
 696             (setq tetris-pos-x (1- tetris-pos-x)))
 697         (tetris-draw-shape))))
 698
 699 (defun tetris-rotate-prev ()
 700   "Rotates the shape clockwise"
 701   (interactive)
 702   (if (eq tetris-state tetris-state-playing)
 703       (progn
 704         (tetris-erase-shape)
 705         (setq tetris-rot (% (+ 1 tetris-rot) 4))
 706         (if (tetris-test-shape)
 707             (setq tetris-rot (% (+ 3 tetris-rot) 4)))
 708         (tetris-draw-shape))))
 709
 710 (defun tetris-rotate-next ()
 711   "Rotates the shape anticlockwise"
 712   (interactive)
 713   (if (eq tetris-state tetris-state-playing)
 714       (progn
 715         (tetris-erase-shape)
 716         (setq tetris-rot (% (+ 3 tetris-rot) 4))
 717         (if (tetris-test-shape)
 718             (setq tetris-rot (% (+ 1 tetris-rot) 4)))
 719         (tetris-draw-shape))))
 720
 721 (defun tetris-end-game ()
 722   "Terminates the current game"
 723   (interactive)
 724   (gamegrid-kill-timer)
 725   (use-local-map tetris-null-map)
 726   (gamegrid-add-score tetris-score-file tetris-score))
 727
 728 (defun tetris-start-game ()
 729   "Starts a new game of Tetris"
 730   (interactive)
 731   (tetris-reset-game)
 732   (use-local-map tetris-mode-map)
 733   (let ((period (or (tetris-get-tick-period)
 734                     tetris-default-tick-period)))
 735     (gamegrid-start-timer period 'tetris-update-game)))
 736
 737 (defun tetris-pause-game ()
 738   "Pauses (or resumes) the current game"
 739   (interactive)
 740   (setq tetris-paused (not tetris-paused))
 741   (message (and tetris-paused "Game paused (press p to resume)")))
 742
 743 (defun tetris-active-p ()
 744   (eq (current-local-map) tetris-mode-map))
 745
 746 (put 'tetris-mode 'mode-class 'special)
 747
 748 (defun tetris-mode ()
 749   "A mode for playing Tetris.
 750
 751 tetris-mode keybindings:
 752    \\{tetris-mode-map}
 753 "
 754   (kill-all-local-variables)
 755
 756   (make-local-hook 'kill-buffer-hook)
 757   (add-hook 'kill-buffer-hook 'gamegrid-kill-timer nil t)
 758
 759   (use-local-map tetris-null-map)
 760
 761   (setq major-mode 'tetris-mode)
 762   (setq mode-name "Tetris")
 763
 764   (setq mode-popup-menu
 765         '("Tetris Commands"
 766           ["Start new game"     tetris-start-game]
 767           ["End game"           tetris-end-game
 768            (tetris-active-p)]
 769           ["Pause"              tetris-pause-game
 770            (and (tetris-active-p) (not tetris-paused))]
 771           ["Resume"             tetris-pause-game
 772            (and (tetris-active-p) tetris-paused)]))
 773
 774   (setq gamegrid-use-glyphs tetris-use-glyphs)
 775   (setq gamegrid-use-color tetris-use-color)
 776
 777   ;; Precompute the bounding boxes for known each shape/rotation pair
 778   (setq tetris-shapes-bounding-boxes (tetris-bounding-box-compute-all))
 779
 780   (gamegrid-init (tetris-display-options))
 781
 782   (run-hooks 'tetris-mode-hook))
 783
 784 ;;;###autoload
 785 (defun tetris ()
 786   "Tetris
 787
 788 Shapes drop from the top of the screen, and the user has to move and
 789 rotate the shape to fit in with those at the bottom of the screen so
 790 as to form complete rows.
 791
 792 tetris-mode keybindings:
 793    \\<tetris-mode-map>
 794 \\[tetris-start-game]   Starts a new game of Tetris
 795 \\[tetris-end-game]     Terminates the current game
 796 \\[tetris-pause-game]   Pauses (or resumes) the current game
 797 \\[tetris-move-left]    Moves the shape one square to the left
 798 \\[tetris-move-right]   Moves the shape one square to the right
 799 \\[tetris-rotate-prev]  Rotates the shape clockwise
 800 \\[tetris-rotate-next]  Rotates the shape anticlockwise
 801 \\[tetris-move-bottom]  Drops the shape to the bottom of the playing area
 802
 803 "
 804   (interactive)
 805
 806   (switch-to-buffer tetris-buffer-name)
 807   (gamegrid-kill-timer)
 808   (tetris-mode)
 809   (tetris-start-game))
 810
 811 (provide 'tetris)
 812
 813 ;;; tetris.el ends here
 814