--- /dev/null
+;;; 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)
--- /dev/null
+;;; 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
projects / emacs.git / commitdiff