2 files changed, 1027 insertions, 0 deletions

diff --git a/lisp/play/gamegrid.el b/lisp/play/gamegrid.el
new file mode 100644
index 00000000000..c2320a7b8c6
--- /dev/null
+++ b/lisp/play/gamegrid.el
@@ -0,0 +1,427 @@
+;;; gamegrid.el -- Library for implementing grid-based games on Emacs
+
+;; Copyright (C) 1997, 1998 Free Software Foundation, Inc.
+
+;; Author: Glynn Clements <glynn@sensei.co.uk>
+;; Version: 1.02
+;; Created: 1997-08-13
+;; Keywords: games
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+(eval-when-compile
+  (require 'cl))
+
+;; ;;;;;;;;;;;;; buffer-local variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar gamegrid-use-glyphs t
+  "Non-nil means use glyphs when available.")
+
+(defvar gamegrid-use-color t
+  "Non-nil means use color when available.")
+
+(defvar gamegrid-font "-*-courier-medium-r-*-*-*-140-100-75-*-*-iso8859-*"
+  "Name of the font used in X mode.")
+
+(defvar gamegrid-display-options nil)
+
+(defvar gamegrid-buffer-width 0)
+(defvar gamegrid-buffer-height 0)
+(defvar gamegrid-blank 0)
+
+(defvar gamegrid-timer nil)
+
+(defvar gamegrid-display-mode nil)
+
+(defvar gamegrid-display-table)
+
+(defvar gamegrid-face-table nil)
+
+(defvar gamegrid-buffer-start 1)
+
+(defvar gamegrid-score-file-length 50
+  "Number of high scores to keep")
+
+(make-variable-buffer-local 'gamegrid-use-glyphs)
+(make-variable-buffer-local 'gamegrid-use-color)
+(make-variable-buffer-local 'gamegrid-font)
+(make-variable-buffer-local 'gamegrid-display-options)
+(make-variable-buffer-local 'gamegrid-buffer-width)
+(make-variable-buffer-local 'gamegrid-buffer-height)
+(make-variable-buffer-local 'gamegrid-blank)
+(make-variable-buffer-local 'gamegrid-timer)
+(make-variable-buffer-local 'gamegrid-display-mode)
+(make-variable-buffer-local 'gamegrid-display-table)
+(make-variable-buffer-local 'gamegrid-face-table)
+(make-variable-buffer-local 'gamegrid-buffer-start)
+(make-variable-buffer-local 'gamegrid-score-file-length)
+
+;; ;;;;;;;;;;;;; global variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar gamegrid-grid-x-face nil)
+(defvar gamegrid-mono-x-face nil)
+(defvar gamegrid-mono-tty-face nil)
+
+;; ;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defconst gamegrid-glyph-height 16)
+
+(defconst gamegrid-xpm "\
+/* XPM */
+static char *noname[] = {
+/* width height ncolors chars_per_pixel */
+\"16 16 3 1\",
+/* colors */
+\"+ s col1\",
+\". s col2\",
+\"- s col3\",
+/* pixels */
+\"---------------+\",
+\"--------------++\",
+\"--............++\",
+\"--............++\",
+\"--............++\",
+\"--............++\",
+\"--............++\",
+\"--............++\",
+\"--............++\",
+\"--............++\",
+\"--............++\",
+\"--............++\",
+\"--............++\",
+\"--............++\",
+\"-+++++++++++++++\",
+\"++++++++++++++++\"
+};
+"
+  "XPM format image used for each square")
+
+;; ;;;;;;;;;;;;;;;; miscellaneous functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defsubst gamegrid-characterp (arg)
+  (if (fboundp 'characterp)
+      (characterp arg)
+    (integerp arg)))
+
+(defsubst gamegrid-event-x (event)
+  (if (fboundp 'event-x)
+      (event-x event)
+    (car (posn-col-row (event-end event)))))
+
+(defsubst gamegrid-event-y (event)
+  (if (fboundp 'event-y)
+      (event-y event)
+    (cdr (posn-col-row (event-end event)))))
+
+;; ;;;;;;;;;;;;; display functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun gamegrid-color (color shade)
+  (let* ((v (floor (* shade 255)))
+         (r (* v (aref color 0)))
+         (g (* v (aref color 1)))
+         (b (* v (aref color 2))))
+    (format "#%02x%02x%02x" r g b)))
+
+(defun gamegrid-set-font (face)
+  (if gamegrid-font
+      (condition-case nil
+          (set-face-font face gamegrid-font)
+        ('error nil))))
+
+(defun gamegrid-setup-face (face color)
+  (set-face-foreground face color)
+  (set-face-background face color)
+  (gamegrid-set-font face)
+  (condition-case nil
+      (set-face-background-pixmap face [nothing]);; XEmacs
+    ('error nil))
+  (condition-case nil
+      (set-face-background-pixmap face nil);; Emacs
+    ('error nil)))
+
+(defun gamegrid-make-mono-tty-face ()
+  (let ((face (make-face 'gamegrid-mono-tty-face)))
+    (condition-case nil
+        (set-face-property face 'reverse t)
+      ('error nil))
+    face))
+
+(defun gamegrid-make-color-tty-face (color)
+  (let* ((hex (gamegrid-color color 1.0))
+         (name (intern (format "gamegrid-color-tty-face-%s" hex)))
+         (face (make-face name)))
+    (gamegrid-setup-face face color)
+    face))
+
+(defun gamegrid-make-grid-x-face ()
+  (let ((face (make-face 'gamegrid-x-border-face)))
+    (gamegrid-set-font face)
+    face))
+
+(defun gamegrid-make-mono-x-face ()
+  (let ((face (make-face 'gamegrid-mono-x-face))
+        (color (face-foreground 'default)))
+    (if (null color)
+        (setq color
+              (cdr-safe (assq 'foreground-color (frame-parameters)))))
+    (gamegrid-setup-face face color)
+    face))
+
+(defun gamegrid-make-color-x-face (color)
+  (let* ((hex (gamegrid-color color 1.0))
+         (name (intern (format "gamegrid-color-x-face-%s" hex)))
+         (face (make-face name)))
+    (gamegrid-setup-face face (gamegrid-color color 1.0))
+    face))
+
+(defun gamegrid-make-face (data-spec-list color-spec-list)
+  (let ((data (gamegrid-match-spec-list data-spec-list))
+        (color (gamegrid-match-spec-list color-spec-list)))
+    (case data
+      ('color-x
+       (gamegrid-make-color-x-face color))
+      ('grid-x
+       (unless gamegrid-grid-x-face
+         (setq gamegrid-grid-x-face (gamegrid-make-grid-x-face)))
+       gamegrid-grid-x-face)
+      ('mono-x
+       (unless gamegrid-mono-x-face
+         (setq gamegrid-mono-x-face (gamegrid-make-mono-x-face)))
+       gamegrid-mono-x-face)
+      ('color-tty
+       (gamegrid-make-color-tty-face color))
+      ('mono-tty
+       (unless gamegrid-mono-tty-face
+         (setq gamegrid-mono-tty-face (gamegrid-make-mono-tty-face)))
+       gamegrid-mono-tty-face))))
+
+(defun gamegrid-colorize-glyph (color)
+  (make-glyph
+   (vector
+    'xpm
+    :data gamegrid-xpm
+    :color-symbols (list (cons "col1" (gamegrid-color color 0.6))
+                         (cons "col2" (gamegrid-color color 0.8))
+                         (cons "col3" (gamegrid-color color 1.0))))))
+
+(defun gamegrid-match-spec (spec)
+  (let ((locale (car spec))
+        (value (cadr spec)))
+    (and (or (eq locale t)
+             (and (listp locale)
+                  (memq gamegrid-display-mode locale))
+             (and (symbolp locale)
+                  (eq gamegrid-display-mode locale)))
+         value)))
+
+(defun gamegrid-match-spec-list (spec-list)
+  (and spec-list
+       (or (gamegrid-match-spec (car spec-list))
+           (gamegrid-match-spec-list (cdr spec-list)))))
+
+(defun gamegrid-make-glyph (data-spec-list color-spec-list)
+  (let ((data (gamegrid-match-spec-list data-spec-list))
+        (color (gamegrid-match-spec-list color-spec-list)))
+    (cond ((gamegrid-characterp data)
+           (vector data))
+          ((eq data 'colorize)
+           (gamegrid-colorize-glyph color))
+          ((vectorp data)
+           (make-glyph data)))))
+
+(defun gamegrid-color-display-p ()
+  (if (fboundp 'device-class)
+      (eq (device-class (selected-device)) 'color)
+    (eq (cdr-safe (assq 'display-type (frame-parameters))) 'color)))
+
+(defun gamegrid-display-type ()
+  (let ((window-system-p 
+         (or (and (fboundp 'console-on-window-system-p)
+                  (console-on-window-system-p))
+             window-system)))
+  (cond ((and gamegrid-use-glyphs
+                window-system-p
+              (featurep 'xpm))
+         'glyph)
+        ((and gamegrid-use-color
+                window-system-p
+              (gamegrid-color-display-p))
+         'color-x)
+          (window-system-p
+         'mono-x)
+        ((and gamegrid-use-color
+              (gamegrid-color-display-p))
+         'color-tty)
+        ((fboundp 'set-face-property)
+         'mono-tty)
+        (t
+           'emacs-tty))))
+
+(defun gamegrid-set-display-table ()
+  (if (fboundp 'specifierp)
+      (add-spec-to-specifier current-display-table
+                             gamegrid-display-table
+                             (current-buffer)
+                             nil
+                             'remove-locale)
+    (setq buffer-display-table gamegrid-display-table)))
+
+(defun gamegrid-hide-cursor ()
+  (if (fboundp 'specifierp)
+      (set-specifier text-cursor-visible-p nil (current-buffer))))
+
+(defun gamegrid-setup-default-font ()
+  (cond ((eq gamegrid-display-mode 'glyph)
+         (let* ((font-spec (face-property 'default 'font))
+                (name (font-name font-spec))
+                (max-height nil))
+           (loop for c from 0 to 255 do
+             (let ((glyph (aref gamegrid-display-table c)))
+               (cond ((glyphp glyph)
+                      (let ((height (glyph-height glyph)))
+                        (if (or (null max-height)
+                                (< max-height height))
+                            (setq max-height height)))))))
+           (if max-height
+               (while (and (> (font-height font-spec) max-height)
+                           (setq name (x-find-smaller-font name)))
+                 (add-spec-to-specifier font-spec name (current-buffer))))))))
+
+(defun gamegrid-initialize-display ()
+  (setq gamegrid-display-mode (gamegrid-display-type))
+  (setq gamegrid-display-table (make-display-table))
+  (setq gamegrid-face-table (make-vector 256 nil))
+  (loop for c from 0 to 255 do
+    (let* ((spec (aref gamegrid-display-options c))
+           (glyph (gamegrid-make-glyph (car spec) (caddr spec)))
+           (face (gamegrid-make-face (cadr spec) (caddr spec))))
+      (aset gamegrid-face-table c face)
+      (aset gamegrid-display-table c glyph)))
+  (gamegrid-setup-default-font)
+  (gamegrid-set-display-table)
+  (gamegrid-hide-cursor))
+
+
+(defun gamegrid-set-face (c)
+  (unless (eq gamegrid-display-mode 'glyph)
+    (put-text-property (1- (point))
+                       (point)
+                       'face
+                       (aref gamegrid-face-table c))))
+
+(defun gamegrid-cell-offset (x y)
+  (+ gamegrid-buffer-start
+     (* (1+ gamegrid-buffer-width) y)
+     x))
+
+;; ;;;;;;;;;;;;;;;; grid functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun gamegrid-get-cell (x y)
+  (char-after (gamegrid-cell-offset x y)))
+
+(defun gamegrid-set-cell (x y c)
+  (save-excursion
+    (let ((buffer-read-only nil))
+      (goto-char (gamegrid-cell-offset x y))
+      (delete-char 1)
+      (insert-char c 1)
+      (gamegrid-set-face c))))
+
+(defun gamegrid-init-buffer (width height blank)
+  (setq gamegrid-buffer-width width
+        gamegrid-buffer-height height)
+  (let ((line (concat
+               (make-string width blank)
+               "\n"))
+        (buffer-read-only nil))
+    (erase-buffer)
+    (setq gamegrid-buffer-start (point))
+    (dotimes (i height)
+      (insert-string line))
+    (goto-char (point-min))))
+
+(defun gamegrid-init (options)
+  (setq buffer-read-only t
+        truncate-lines t
+        gamegrid-display-options options)
+  (buffer-disable-undo (current-buffer))
+  (gamegrid-initialize-display))
+
+;; ;;;;;;;;;;;;;;;; timer functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun gamegrid-start-timer (period func)
+  (setq gamegrid-timer
+        (if (featurep 'itimer)
+            (start-itimer "Gamegrid"
+                          func
+                          period
+                          period
+                          nil
+                          t
+                          (current-buffer))
+          (run-with-timer period
+                          period
+                          func
+                          (current-buffer)))))
+
+(defun gamegrid-set-timer (delay)
+  (if gamegrid-timer
+      (if (featurep 'itimer)
+          (set-itimer-restart gamegrid-timer delay)
+        (timer-set-time gamegrid-timer
+                        (list (aref gamegrid-timer 1)
+                              (aref gamegrid-timer 2)
+                              (aref gamegrid-timer 3))
+                        delay))))
+
+(defun gamegrid-kill-timer ()
+  (if gamegrid-timer
+      (if (featurep 'itimer)
+          (delete-itimer gamegrid-timer)
+        (timer-set-time gamegrid-timer '(0 0 0) nil)))
+  (setq gamegrid-timer nil))
+
+;; ;;;;;;;;;;;;;;; high score functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun gamegrid-add-score (file score)
+  "Add the current score to the high score file."
+  (save-excursion
+  (find-file-other-window file)
+  (setq buffer-read-only nil)
+  (goto-char (point-max))
+  (insert (format "%05d\t%s\t%s <%s>\n"
+                  score
+                  (current-time-string)
+                  (user-full-name)
+                  (cond ((fboundp 'user-mail-address)
+                         (user-mail-address))
+                        ((boundp 'user-mail-address)
+                         user-mail-address)
+                        (t ""))))
+  (sort-numeric-fields 1 (point-min) (point-max))
+    (reverse-region (point-min) (point-max))
+  (goto-line (1+ gamegrid-score-file-length))
+  (delete-region (point) (point-max))
+  (setq buffer-read-only t)
+    (save-buffer)))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(provide 'gamegrid)
diff --git a/lisp/play/tetris.el b/lisp/play/tetris.el
new file mode 100644
index 00000000000..fb390938505
--- /dev/null
+++ b/lisp/play/tetris.el
@@ -0,0 +1,600 @@
+;;; tetris.el -- Implementation of Tetris for Emacs
+
+;; Copyright (C) 1997 Free Software Foundation, Inc.
+
+;; Author: Glynn Clements <glynn@sensei.co.uk>
+;; Version: 2.01
+;; Created: 1997-08-13
+;; Keywords: games
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+(eval-when-compile
+  (require 'cl))
+
+(require 'gamegrid)
+
+;; ;;;;;;;;;;;;; customization variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar tetris-use-glyphs t
+  "Non-nil means use glyphs when available.")
+
+(defvar tetris-use-color t
+  "Non-nil means use color when available.")
+
+(defvar tetris-draw-border-with-glyphs t
+  "Non-nil means draw a border even when using glyphs.")
+
+(defvar tetris-default-tick-period 0.3
+  "The default time taken for a shape to drop one row.")
+
+(defvar tetris-update-speed-function
+  'tetris-default-update-speed-function
+  "Function run whenever the Tetris score changes
+Called with two arguments: (SHAPES ROWS)
+SHAPES is the number of shapes which have been dropped
+ROWS is the number of rows which have been completed
+
+If the return value is a number, it is used as the timer period.")
+
+(defvar tetris-mode-hook nil
+  "Hook run upon starting Tetris.")
+
+(defvar tetris-tty-colors
+  [nil "blue" "white" "yellow" "magenta" "cyan" "green" "red"]
+  "Vector of colors of the various shapes in text mode
+Element 0 is ignored.")
+
+(defvar tetris-x-colors
+  [nil [0 0 1] [0.7 0 1] [1 1 0] [1 0 1] [0 1 1] [0 1 0] [1 0 0]]
+  "Vector of colors of the various shapes
+Element 0 is ignored.")
+
+(defvar tetris-buffer-name "*Tetris*"
+  "Name used for Tetris buffer.")
+
+(defvar tetris-buffer-width 30
+  "Width of used portion of buffer.")
+
+(defvar tetris-buffer-height 22
+  "Height of used portion of buffer.")
+
+(defvar tetris-width 10
+  "Width of playing area.")
+
+(defvar tetris-height 20
+  "Height of playing area.")
+
+(defvar tetris-top-left-x 3
+  "X position of top left of playing area.")
+
+(defvar tetris-top-left-y 1
+  "Y position of top left of playing area.")
+
+(defvar tetris-next-x (+ (* 2 tetris-top-left-x) tetris-width)
+  "X position of next shape.")
+
+(defvar tetris-next-y tetris-top-left-y
+  "Y position of next shape.")
+
+(defvar tetris-score-x tetris-next-x
+  "X position of score.")
+
+(defvar tetris-score-y (+ tetris-next-y 6)
+  "Y position of score.")
+
+(defvar tetris-score-file "/tmp/tetris-scores"
+;; anybody with a well-connected server want to host this?
+;(defvar tetris-score-file "/anonymous@ftp.pgt.com:/pub/cgw/tetris-scores"
+  "File for holding high scores.")
+
+;; ;;;;;;;;;;;;; display options ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar tetris-border-options
+  '(((glyph colorize)
+     (t ?\+))
+    ((color-x color-x)
+     (mono-x grid-x)
+     (t nil))
+    (((glyph color-x) [0.5 0.5 0.5])
+     (t nil))))
+
+(defvar tetris-blank-options
+  '(((glyph colorize)
+     (t ?\040))
+    ((color-x color-x)
+     (mono-x grid-x)
+     (color-tty color-tty)
+     (t nil))
+    (((glyph color-x) [0 0 0])
+     (color-tty "black")
+     (t nil))))
+
+(defvar tetris-cell-options
+  '(((glyph colorize)
+     (emacs-tty ?O)
+     (t ?\040))
+    ((color-x color-x)
+     (mono-x mono-x)
+     (color-tty color-tty)
+     (mono-tty mono-tty)
+     (t nil))
+    ;; color information is taken from tetris-x-colors and tetris-tty-colors
+    ))
+
+(defvar tetris-space-options
+  '(((t ?\040))
+    nil
+    nil))
+
+;; ;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defconst tetris-shapes
+  [[[[1 1 0 0] [1 1 0 0] [1 1 0 0] [1 1 0 0]]
+    [[1 1 0 0] [1 1 0 0] [1 1 0 0] [1 1 0 0]]
+    [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]
+    [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
+
+   [[[2 2 2 0] [0 2 0 0] [2 0 0 0] [2 2 0 0]]
+    [[0 0 2 0] [0 2 0 0] [2 2 2 0] [2 0 0 0]]
+    [[0 0 0 0] [2 2 0 0] [0 0 0 0] [2 0 0 0]]
+    [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
+
+   [[[3 3 3 0] [3 3 0 0] [0 0 3 0] [3 0 0 0]]
+    [[3 0 0 0] [0 3 0 0] [3 3 3 0] [3 0 0 0]]
+    [[0 0 0 0] [0 3 0 0] [0 0 0 0] [3 3 0 0]]
+    [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
+
+   [[[4 4 0 0] [0 4 0 0] [4 4 0 0] [0 4 0 0]]
+    [[0 4 4 0] [4 4 0 0] [0 4 4 0] [4 4 0 0]]
+    [[0 0 0 0] [4 0 0 0] [0 0 0 0] [4 0 0 0]]
+    [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
+
+   [[[0 5 5 0] [5 0 0 0] [0 5 5 0] [5 0 0 0]]
+    [[5 5 0 0] [5 5 0 0] [5 5 0 0] [5 5 0 0]]
+    [[0 0 0 0] [0 5 0 0] [0 0 0 0] [0 5 0 0]]
+    [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
+
+   [[[0 6 0 0] [6 0 0 0] [6 6 6 0] [0 6 0 0]]
+    [[6 6 6 0] [6 6 0 0] [0 6 0 0] [6 6 0 0]]
+    [[0 0 0 0] [6 0 0 0] [0 0 0 0] [0 6 0 0]]
+    [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
+
+   [[[7 7 7 7] [7 0 0 0] [7 7 7 7] [7 0 0 0]]
+    [[0 0 0 0] [7 0 0 0] [0 0 0 0] [7 0 0 0]]
+    [[0 0 0 0] [7 0 0 0] [0 0 0 0] [7 0 0 0]]
+    [[0 0 0 0] [7 0 0 0] [0 0 0 0] [7 0 0 0]]]])
+
+;;the scoring rules were taken from "xtetris".  Blocks score differently 
+;;depending on their rotation
+
+(defconst tetris-shape-scores 
+  [ [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]] )
+
+(defconst tetris-shape-dimensions
+  [[2 2] [3 2] [3 2] [3 2] [3 2] [3 2] [4 1]])
+
+(defconst tetris-blank 0)
+
+(defconst tetris-border 8)
+
+(defconst tetris-space 9)
+
+(defun tetris-default-update-speed-function (shapes rows)
+  (/ 20.0 (+ 50.0 rows)))
+
+;; ;;;;;;;;;;;;; variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar tetris-shape 0)
+(defvar tetris-rot 0)
+(defvar tetris-next-shape 0)
+(defvar tetris-n-shapes 0)
+(defvar tetris-n-rows 0)
+(defvar tetris-score 0)
+(defvar tetris-pos-x 0)
+(defvar tetris-pos-y 0)
+(defvar tetris-paused nil)
+
+(make-variable-buffer-local 'tetris-shape)
+(make-variable-buffer-local 'tetris-rot)
+(make-variable-buffer-local 'tetris-next-shape)
+(make-variable-buffer-local 'tetris-n-shapes)
+(make-variable-buffer-local 'tetris-n-rows)
+(make-variable-buffer-local 'tetris-score)
+(make-variable-buffer-local 'tetris-pos-x)
+(make-variable-buffer-local 'tetris-pos-y)
+(make-variable-buffer-local 'tetris-paused)
+
+;; ;;;;;;;;;;;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar tetris-mode-map
+  (make-sparse-keymap 'tetris-mode-map))
+
+(define-key tetris-mode-map "n"         'tetris-start-game)
+(define-key tetris-mode-map "q"         'tetris-end-game)
+(define-key tetris-mode-map "p"         'tetris-pause-game)
+
+(define-key tetris-mode-map " "         'tetris-move-bottom)
+(define-key tetris-mode-map [left]      'tetris-move-left)
+(define-key tetris-mode-map [right]     'tetris-move-right)
+(define-key tetris-mode-map [up]        'tetris-rotate-prev)
+(define-key tetris-mode-map [down]      'tetris-rotate-next)
+
+(defvar tetris-null-map
+  (make-sparse-keymap 'tetris-null-map))
+
+(define-key tetris-null-map "n"         'tetris-start-game)
+
+;; ;;;;;;;;;;;;;;;; game functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun tetris-display-options ()
+  (let ((options (make-vector 256 nil)))
+    (loop for c from 0 to 255 do
+      (aset options c
+            (cond ((= c tetris-blank)
+                    tetris-blank-options)
+                  ((and (>= c 1) (<= c 7))
+                   (append
+                    tetris-cell-options
+                    `((((glyph color-x) ,(aref tetris-x-colors c))
+                       (color-tty ,(aref tetris-tty-colors c))
+                       (t nil)))))
+                   ((= c tetris-border)
+                    tetris-border-options)
+                   ((= c tetris-space)
+                    tetris-space-options)
+                  (t
+                   '(nil nil nil)))))
+    options))
+
+(defun tetris-get-tick-period ()
+  (if (boundp 'tetris-update-speed-function)
+      (let ((period (apply tetris-update-speed-function
+                           tetris-n-shapes
+                           tetris-n-rows nil)))
+        (and (numberp period) period))))
+
+(defun tetris-get-shape-cell (x y)
+  (aref (aref (aref (aref tetris-shapes
+                          tetris-shape)
+                    y)
+              tetris-rot)
+        x))
+
+(defun tetris-shape-width ()
+  (aref (aref tetris-shape-dimensions tetris-shape)
+        (% tetris-rot 2)))
+
+(defun tetris-shape-height ()
+  (aref (aref tetris-shape-dimensions tetris-shape)
+        (- 1 (% tetris-rot 2))))
+
+(defun tetris-draw-score ()
+  (let ((strings (vector (format "Shapes: %05d" tetris-n-shapes)
+                         (format "Rows:   %05d" tetris-n-rows)
+                         (format "Score:  %05d" tetris-score))))
+    (loop for y from 0 to 2 do
+          (let* ((string (aref strings y))
+                 (len (length string)))
+            (loop for x from 0 to (1- len) do
+                  (gamegrid-set-cell (+ tetris-score-x x)
+                                     (+ tetris-score-y y)
+                                     (aref string x)))))))
+
+(defun tetris-update-score ()
+  (tetris-draw-score)
+  (let ((period (tetris-get-tick-period)))
+    (if period (gamegrid-set-timer period))))
+
+(defun tetris-new-shape ()
+  (setq tetris-shape tetris-next-shape)
+  (setq tetris-rot 0)
+  (setq tetris-next-shape (random 7))
+  (setq tetris-pos-x (/ (- tetris-width (tetris-shape-width)) 2))
+  (setq tetris-pos-y 0)
+  (if (tetris-test-shape)
+      (tetris-end-game)
+    (tetris-draw-shape))
+  (tetris-draw-next-shape)
+  (tetris-update-score))
+
+(defun tetris-draw-next-shape ()
+  (loop for y from 0 to 3 do
+        (loop for x from 0 to 3 do
+              (gamegrid-set-cell (+ tetris-next-x x)
+                                 (+ tetris-next-y y)
+                                 (let ((tetris-shape tetris-next-shape)
+                                       (tetris-rot 0))
+                                   (tetris-get-shape-cell x y))))))
+
+(defun tetris-draw-shape ()
+  (loop for y from 0 to (1- (tetris-shape-height)) do
+        (loop for x from 0 to (1- (tetris-shape-width)) do
+              (let ((c (tetris-get-shape-cell x y)))
+                (if (/= c tetris-blank)
+                    (gamegrid-set-cell (+ tetris-top-left-x
+                                          tetris-pos-x
+                                          x)
+                                       (+ tetris-top-left-y
+                                          tetris-pos-y
+                                          y)
+                                       c))))))
+
+(defun tetris-erase-shape ()
+  (loop for y from 0 to (1- (tetris-shape-height)) do
+        (loop for x from 0 to (1- (tetris-shape-width)) do
+              (let ((c (tetris-get-shape-cell x y))
+                    (px (+ tetris-top-left-x tetris-pos-x x))
+                    (py (+ tetris-top-left-y tetris-pos-y y)))
+                (if (/= c tetris-blank)
+                    (gamegrid-set-cell px py tetris-blank))))))
+
+(defun tetris-test-shape ()
+  (let ((hit nil))
+    (loop for y from 0 to (1- (tetris-shape-height)) do
+          (loop for x from 0 to (1- (tetris-shape-width)) do
+                (unless hit
+                  (setq hit
+                        (let* ((c (tetris-get-shape-cell x y))
+                              (xx (+ tetris-pos-x x))
+                              (yy (+ tetris-pos-y y))
+                              (px (+ tetris-top-left-x xx))
+                              (py (+ tetris-top-left-y yy)))
+                          (and (/= c tetris-blank)
+                               (or (>= xx tetris-width)
+                                   (>= yy tetris-height)
+                                   (/= (gamegrid-get-cell px py)
+                                       tetris-blank))))))))
+    hit))
+
+(defun tetris-full-row (y)
+  (let ((full t))
+    (loop for x from 0 to (1- tetris-width) do
+          (if (= (gamegrid-get-cell (+ tetris-top-left-x x)
+                                    (+ tetris-top-left-y y))
+                 tetris-blank)
+              (setq full nil)))
+    full))
+
+(defun tetris-shift-row (y)
+  (if (= y 0)
+      (loop for x from 0 to (1- tetris-width) do
+        (gamegrid-set-cell (+ tetris-top-left-x x)
+                           (+ tetris-top-left-y y)
+                           tetris-blank))
+  (loop for x from 0 to (1- tetris-width) do
+        (let ((c (gamegrid-get-cell (+ tetris-top-left-x x)
+                                    (+ tetris-top-left-y y -1))))
+          (gamegrid-set-cell (+ tetris-top-left-x x)
+                             (+ tetris-top-left-y y)
+                           c)))))
+
+(defun tetris-shift-down ()
+  (loop for y0 from 0 to (1- tetris-height) do
+        (if (tetris-full-row y0)
+            (progn (setq tetris-n-rows (1+ tetris-n-rows))
+                   (loop for y from y0 downto 0 do
+                         (tetris-shift-row y))))))
+
+(defun tetris-draw-border-p ()
+  (or (not (eq gamegrid-display-mode 'glyph))
+      tetris-draw-border-with-glyphs))
+
+(defun tetris-init-buffer ()
+  (gamegrid-init-buffer tetris-buffer-width
+                        tetris-buffer-height
+                        tetris-space)
+  (let ((buffer-read-only nil))
+    (if (tetris-draw-border-p)
+        (loop for y from -1 to tetris-height do
+              (loop for x from -1 to tetris-width do
+                    (gamegrid-set-cell (+ tetris-top-left-x x)
+                                       (+ tetris-top-left-y y)
+                                       tetris-border))))
+    (loop for y from 0 to (1- tetris-height) do
+          (loop for x from 0 to (1- tetris-width) do
+                (gamegrid-set-cell (+ tetris-top-left-x x)
+                                   (+ tetris-top-left-y y)
+                                   tetris-blank)))
+    (if (tetris-draw-border-p)
+        (loop for y from -1 to 4 do
+              (loop for x from -1 to 4 do
+                    (gamegrid-set-cell (+ tetris-next-x x)
+                                       (+ tetris-next-y y)
+                                       tetris-border))))))
+
+(defun tetris-reset-game ()
+  (gamegrid-kill-timer)
+  (tetris-init-buffer)
+  (setq tetris-next-shape (random 7))
+  (setq tetris-shape    0
+        tetris-rot      0
+        tetris-pos-x    0
+        tetris-pos-y    0
+        tetris-n-shapes 0
+        tetris-n-rows   0
+        tetris-score    0
+        tetris-paused   nil)
+  (tetris-new-shape))
+
+(defun tetris-shape-done ()
+  (tetris-shift-down)
+  (setq tetris-n-shapes (1+ tetris-n-shapes))
+  (setq tetris-score
+        (+ tetris-score 
+           (aref (aref tetris-shape-scores tetris-shape) tetris-rot)))
+  (tetris-update-score)
+  (tetris-new-shape))
+
+(defun tetris-update-game (tetris-buffer)
+  "Called on each clock tick.
+Drops the shape one square, testing for collision."
+  (if (and (not tetris-paused)
+           (eq (current-buffer) tetris-buffer))
+      (let (hit)
+        (tetris-erase-shape)
+        (setq tetris-pos-y (1+ tetris-pos-y))
+        (setq hit (tetris-test-shape))
+        (if hit
+            (setq tetris-pos-y (1- tetris-pos-y)))
+        (tetris-draw-shape)
+        (if hit
+            (tetris-shape-done)))))
+
+(defun tetris-move-bottom ()
+  "Drops the shape to the bottom of the playing area"
+  (interactive)
+  (let ((hit nil))
+    (tetris-erase-shape)
+    (while (not hit)
+      (setq tetris-pos-y (1+ tetris-pos-y))
+      (setq hit (tetris-test-shape)))
+    (setq tetris-pos-y (1- tetris-pos-y))
+    (tetris-draw-shape)
+    (tetris-shape-done)))
+
+(defun tetris-move-left ()
+  "Moves the shape one square to the left"
+  (interactive)
+  (unless (= tetris-pos-x 0)
+    (tetris-erase-shape)
+    (setq tetris-pos-x (1- tetris-pos-x))
+    (if (tetris-test-shape)
+        (setq tetris-pos-x (1+ tetris-pos-x)))
+    (tetris-draw-shape)))
+
+(defun tetris-move-right ()
+  "Moves the shape one square to the right"
+  (interactive)
+  (unless (= (+ tetris-pos-x (tetris-shape-width))
+             tetris-width)
+    (tetris-erase-shape)
+    (setq tetris-pos-x (1+ tetris-pos-x))
+    (if (tetris-test-shape)
+        (setq tetris-pos-x (1- tetris-pos-x)))
+    (tetris-draw-shape)))
+
+(defun tetris-rotate-prev ()
+  "Rotates the shape clockwise"
+  (interactive)
+  (tetris-erase-shape)
+  (setq tetris-rot (% (+ 1 tetris-rot) 4))
+  (if (tetris-test-shape)
+      (setq tetris-rot (% (+ 3 tetris-rot) 4)))
+  (tetris-draw-shape))
+
+(defun tetris-rotate-next ()
+  "Rotates the shape anticlockwise"
+  (interactive)
+  (tetris-erase-shape)
+  (setq tetris-rot (% (+ 3 tetris-rot) 4))
+  (if (tetris-test-shape)
+      (setq tetris-rot (% (+ 1 tetris-rot) 4)))
+  (tetris-draw-shape))
+
+(defun tetris-end-game ()
+  "Terminates the current game"
+  (interactive)
+  (gamegrid-kill-timer)
+  (use-local-map tetris-null-map)
+  (gamegrid-add-score tetris-score-file tetris-score))
+
+(defun tetris-start-game ()
+  "Starts a new game of Tetris"
+  (interactive)
+  (tetris-reset-game)
+  (use-local-map tetris-mode-map)
+  (let ((period (or (tetris-get-tick-period)
+                    tetris-default-tick-period)))
+    (gamegrid-start-timer period 'tetris-update-game)))
+
+(defun tetris-pause-game ()
+  "Pauses (or resumes) the current game"
+  (interactive)
+  (setq tetris-paused (not tetris-paused))
+  (message (and tetris-paused "Game paused (press p to resume)")))
+
+(defun tetris-active-p ()
+  (eq (current-local-map) tetris-mode-map))
+
+(put 'tetris-mode 'mode-class 'special)
+
+(defun tetris-mode ()
+  "A mode for playing Tetris.
+
+tetris-mode keybindings:
+   \\{tetris-mode-map}
+"
+  (kill-all-local-variables)
+
+  (make-local-hook 'kill-buffer-hook)
+  (add-hook 'kill-buffer-hook 'gamegrid-kill-timer nil t)
+
+  (use-local-map tetris-null-map)
+
+  (setq major-mode 'tetris-mode)
+  (setq mode-name "Tetris")
+
+  (setq mode-popup-menu
+        '("Tetris Commands"
+          ["Start new game"     tetris-start-game]
+          ["End game"           tetris-end-game
+           (tetris-active-p)]
+          ["Pause"              tetris-pause-game
+           (and (tetris-active-p) (not tetris-paused))]
+          ["Resume"             tetris-pause-game
+           (and (tetris-active-p) tetris-paused)]))
+
+  (setq gamegrid-use-glyphs tetris-use-glyphs)
+  (setq gamegrid-use-color tetris-use-color)
+
+  (gamegrid-init (tetris-display-options))
+
+  (run-hooks 'tetris-mode-hook))
+
+;;;###autoload
+(defun tetris ()
+  "Play the Tetris game.
+Shapes drop from the top of the screen, and the user has to move and
+rotate the shape to fit in with those at the bottom of the screen so
+as to form complete rows.
+
+tetris-mode keybindings:
+   \\<tetris-mode-map>
+\\[tetris-start-game]   Starts a new game of Tetris
+\\[tetris-end-game]     Terminates the current game
+\\[tetris-pause-game]   Pauses (or resumes) the current game
+\\[tetris-move-left]    Moves the shape one square to the left
+\\[tetris-move-right]   Moves the shape one square to the right
+\\[tetris-rotate-prev]  Rotates the shape clockwise
+\\[tetris-rotate-next]  Rotates the shape anticlockwise
+\\[tetris-move-bottom]  Drops the shape to the bottom of the playing area
+
+"
+  (interactive)
+
+  (switch-to-buffer tetris-buffer-name)
+  (gamegrid-kill-timer)
+  (tetris-mode)
+  (tetris-start-game))
+
+(provide 'tetris)
+
+;;; tetris.el ends here