[bpt/emacs.git] / lisp / play / tetris.el

;;; tetris.el --- implementation of Tetris for Emacs

;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005,
;;   2006, 2007, 2008 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 3, 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;;; Code:

(eval-when-compile
  (require 'cl))

(require 'gamegrid)

;; ;;;;;;;;;;;;; customization variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgroup tetris nil
  "Play a game of tetris."
  :prefix "tetris-"
  :group 'games)

(defcustom tetris-use-glyphs t
  "*Non-nil means use glyphs when available."
  :group 'tetris
  :type 'boolean)

(defcustom tetris-use-color t
  "*Non-nil means use color when available."
  :group 'tetris
  :type 'boolean)

(defcustom tetris-draw-border-with-glyphs t
  "*Non-nil means draw a border even when using glyphs."
  :group 'tetris
  :type 'boolean)

(defcustom tetris-default-tick-period 0.3
  "*The default time taken for a shape to drop one row."
  :group 'tetris
  :type 'number)

(defcustom 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."
  :group 'tetris
  :type 'function)

(defcustom tetris-mode-hook nil
  "Hook run upon starting Tetris."
  :group 'tetris
  :type 'hook)

(defcustom 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."
  :group 'tetris
  :type (let ((names `("Shape 1" "Shape 2" "Shape 3"
		       "Shape 4" "Shape 5" "Shape 6" "Shape 7"))
	      (result `(vector (const nil))))
	  (while names
	    (add-to-list 'result
			 (cons 'choice
			       (cons :tag
				     (cons (car names)
					   (mapcar (lambda (color)
						     (list 'const color))
						   (defined-colors)))))
			 t)
	    (setq names (cdr names)))
	  result))

(defcustom 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."
  :group 'tetris
  :type 'sexp)

(defcustom tetris-buffer-name "*Tetris*"
  "Name used for Tetris buffer."
  :group 'tetris
  :type 'string)

(defcustom tetris-buffer-width 30
  "Width of used portion of buffer."
  :group 'tetris
  :type 'number)

(defcustom tetris-buffer-height 22
  "Height of used portion of buffer."
  :group 'tetris
  :type 'number)

(defcustom tetris-width 10
  "Width of playing area."
  :group 'tetris
  :type 'number)

(defcustom tetris-height 20
  "Height of playing area."
  :group 'tetris
  :type 'number)

(defcustom tetris-top-left-x 3
  "X position of top left of playing area."
  :group 'tetris
  :type 'number)

(defcustom tetris-top-left-y 1
  "Y position of top left of playing area."
  :group 'tetris
  :type 'number)

(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.")

;; It is not safe to put this in /tmp.
;; Someone could make a symlink in /tmp
;; pointing to a file you don't want to clobber.
(defvar tetris-score-file "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-blank-options
  '(((glyph colorize)
     (t ?\040))
    ((color-x color-x)
     (mono-x grid-x)
     (color-tty color-tty))
    (((glyph color-x) [0 0 0])
     (color-tty "black"))))

(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))
    ;; color information is taken from tetris-x-colors and tetris-tty-colors
    ))

(defvar tetris-border-options
  '(((glyph colorize)
     (t ?\+))
    ((color-x color-x)
     (mono-x grid-x)
     (color-tty color-tty))
    (((glyph color-x) [0.5 0.5 0.5])
     (color-tty "white"))))

(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)
  (if (not tetris-paused)
      (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 (or (= tetris-pos-x 0)
              tetris-paused)
    (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 (or (= (+ tetris-pos-x (tetris-shape-width))
                 tetris-width)
              tetris-paused)
    (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)
  (if (not tetris-paused)
      (progn (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)
  (if (not tetris-paused)
      (progn
        (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)

  (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")

  (unless (featurep 'emacs)
    (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-mode-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))

(random t)

(provide 'tetris)

;; arch-tag: fb780d53-3ff0-49f0-8e19-f7f13cf2d49e
;;; tetris.el ends here
Commit	Line	Data
6e44da43	1	;;; tetris.el --- implementation of Tetris for Emacs
3d4ae13e	2
f2e3589a	3	;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005,
2f043267	4	;; 2006, 2007, 2008 Free Software Foundation, Inc.
3d4ae13e RS	5
	6	;; Author: Glynn Clements <glynn@sensei.co.uk>
	7	;; Version: 2.01
	8	;; Created: 1997-08-13
	9	;; Keywords: games
	10
	11	;; This file is part of GNU Emacs.
	12
	13	;; GNU Emacs is free software; you can redistribute it and/or modify
	14	;; it under the terms of the GNU General Public License as published by
5a9dffec	15	;; the Free Software Foundation; either version 3, or (at your option)
3d4ae13e RS	16	;; any later version.
	17
	18	;; GNU Emacs is distributed in the hope that it will be useful,
	19	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	20	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	21	;; GNU General Public License for more details.
	22
	23	;; You should have received a copy of the GNU General Public License
	24	;; along with GNU Emacs; see the file COPYING. If not, write to the
3a35cf56 LK	25	;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
3a35cf56 LK	26	;; Boston, MA 02110-1301, USA.
3d4ae13e RS	27
	28	;;; Commentary:
	29
6e44da43 PJ	30	;;; Code:
6e44da43 PJ	31
3d4ae13e RS	32	(eval-when-compile
	33	(require 'cl))
	34
	35	(require 'gamegrid)
	36
	37	;; ;;;;;;;;;;;;; customization variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	38
67ec1c1a RS	39	(defgroup tetris nil
	40	"Play a game of tetris."
	41	:prefix "tetris-"
	42	:group 'games)
	43
	44	(defcustom tetris-use-glyphs t
	45	"*Non-nil means use glyphs when available."
	46	:group 'tetris
	47	:type 'boolean)
	48
	49	(defcustom tetris-use-color t
	50	"*Non-nil means use color when available."
	51	:group 'tetris
	52	:type 'boolean)
	53
	54	(defcustom tetris-draw-border-with-glyphs t
	55	"*Non-nil means draw a border even when using glyphs."
	56	:group 'tetris
	57	:type 'boolean)
	58
	59	(defcustom tetris-default-tick-period 0.3
	60	"*The default time taken for a shape to drop one row."
	61	:group 'tetris
	62	:type 'number)
	63
	64	(defcustom tetris-update-speed-function
3d4ae13e RS	65	'tetris-default-update-speed-function
	66	"Function run whenever the Tetris score changes
	67	Called with two arguments: (SHAPES ROWS)
	68	SHAPES is the number of shapes which have been dropped
	69	ROWS is the number of rows which have been completed
	70
67ec1c1a RS	71	If the return value is a number, it is used as the timer period."
	72	:group 'tetris
	73	:type 'function)
3d4ae13e	74
67ec1c1a RS	75	(defcustom tetris-mode-hook nil
	76	"Hook run upon starting Tetris."
	77	:group 'tetris
	78	:type 'hook)
3d4ae13e	79
67ec1c1a	80	(defcustom tetris-tty-colors
3d4ae13e RS	81	[nil "blue" "white" "yellow" "magenta" "cyan" "green" "red"]
3d4ae13e RS	82	"Vector of colors of the various shapes in text mode
67ec1c1a RS	83	Element 0 is ignored."
	84	:group 'tetris
	85	:type (let ((names `("Shape 1" "Shape 2" "Shape 3"
	86	"Shape 4" "Shape 5" "Shape 6" "Shape 7"))
	87	(result `(vector (const nil))))
	88	(while names
adcce7d5 SS	89	(add-to-list 'result
	90	(cons 'choice
	91	(cons :tag
	92	(cons (car names)
67ec1c1a RS	93	(mapcar (lambda (color)
	94	(list 'const color))
	95	(defined-colors)))))
	96	t)
	97	(setq names (cdr names)))
	98	result))
	99
	100	(defcustom tetris-x-colors
3d4ae13e RS	101	[nil [0 0 1] [0.7 0 1] [1 1 0] [1 0 1] [0 1 1] [0 1 0] [1 0 0]]
3d4ae13e RS	102	"Vector of colors of the various shapes
67ec1c1a RS	103	Element 0 is ignored."
	104	:group 'tetris
	105	:type 'sexp)
	106
	107	(defcustom tetris-buffer-name "Tetris"
	108	"Name used for Tetris buffer."
	109	:group 'tetris
	110	:type 'string)
	111
	112	(defcustom tetris-buffer-width 30
	113	"Width of used portion of buffer."
	114	:group 'tetris
	115	:type 'number)
	116
	117	(defcustom tetris-buffer-height 22
	118	"Height of used portion of buffer."
	119	:group 'tetris
	120	:type 'number)
	121
	122	(defcustom tetris-width 10
	123	"Width of playing area."
	124	:group 'tetris
	125	:type 'number)
	126
	127	(defcustom tetris-height 20
	128	"Height of playing area."
	129	:group 'tetris
	130	:type 'number)
	131
	132	(defcustom tetris-top-left-x 3
	133	"X position of top left of playing area."
	134	:group 'tetris
	135	:type 'number)
	136
	137	(defcustom tetris-top-left-y 1
	138	"Y position of top left of playing area."
	139	:group 'tetris
	140	:type 'number)
3d4ae13e RS	141
	142	(defvar tetris-next-x (+ (* 2 tetris-top-left-x) tetris-width)
	143	"X position of next shape.")
	144
	145	(defvar tetris-next-y tetris-top-left-y
	146	"Y position of next shape.")
	147
	148	(defvar tetris-score-x tetris-next-x
	149	"X position of score.")
	150
	151	(defvar tetris-score-y (+ tetris-next-y 6)
	152	"Y position of score.")
	153
9caf26fe	154	;; It is not safe to put this in /tmp.
adcce7d5	155	;; Someone could make a symlink in /tmp
9caf26fe	156	;; pointing to a file you don't want to clobber.
76f1b321	157	(defvar tetris-score-file "tetris-scores"
3d4ae13e RS	158	;; anybody with a well-connected server want to host this?
	159	;(defvar tetris-score-file "/anonymous@ftp.pgt.com:/pub/cgw/tetris-scores"
	160	"File for holding high scores.")
	161
	162	;; ;;;;;;;;;;;;; display options ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	163
3d4ae13e RS	164	(defvar tetris-blank-options
	165	'(((glyph colorize)
	166	(t ?\040))
	167	((color-x color-x)
	168	(mono-x grid-x)
ba8cb9c5	169	(color-tty color-tty))
3d4ae13e	170	(((glyph color-x) [0 0 0])
ba8cb9c5	171	(color-tty "black"))))
3d4ae13e RS	172
	173	(defvar tetris-cell-options
	174	'(((glyph colorize)
	175	(emacs-tty ?O)
	176	(t ?\040))
	177	((color-x color-x)
	178	(mono-x mono-x)
	179	(color-tty color-tty)
ba8cb9c5	180	(mono-tty mono-tty))
3d4ae13e RS	181	;; color information is taken from tetris-x-colors and tetris-tty-colors
	182	))
	183
ba8cb9c5 FP	184	(defvar tetris-border-options
	185	'(((glyph colorize)
	186	(t ?\+))
	187	((color-x color-x)
	188	(mono-x grid-x)
	189	(color-tty color-tty))
	190	(((glyph color-x) [0.5 0.5 0.5])
	191	(color-tty "white"))))
	192
3d4ae13e RS	193	(defvar tetris-space-options
	194	'(((t ?\040))
	195	nil
	196	nil))
	197
	198	;; ;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	199
	200	(defconst tetris-shapes
	201	[[[[1 1 0 0] [1 1 0 0] [1 1 0 0] [1 1 0 0]]
	202	[[1 1 0 0] [1 1 0 0] [1 1 0 0] [1 1 0 0]]
	203	[[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]
	204	[[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
	205
	206	[[[2 2 2 0] [0 2 0 0] [2 0 0 0] [2 2 0 0]]
	207	[[0 0 2 0] [0 2 0 0] [2 2 2 0] [2 0 0 0]]
	208	[[0 0 0 0] [2 2 0 0] [0 0 0 0] [2 0 0 0]]
	209	[[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
	210
	211	[[[3 3 3 0] [3 3 0 0] [0 0 3 0] [3 0 0 0]]
	212	[[3 0 0 0] [0 3 0 0] [3 3 3 0] [3 0 0 0]]
	213	[[0 0 0 0] [0 3 0 0] [0 0 0 0] [3 3 0 0]]
	214	[[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
	215
	216	[[[4 4 0 0] [0 4 0 0] [4 4 0 0] [0 4 0 0]]
	217	[[0 4 4 0] [4 4 0 0] [0 4 4 0] [4 4 0 0]]
	218	[[0 0 0 0] [4 0 0 0] [0 0 0 0] [4 0 0 0]]
	219	[[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
	220
	221	[[[0 5 5 0] [5 0 0 0] [0 5 5 0] [5 0 0 0]]
	222	[[5 5 0 0] [5 5 0 0] [5 5 0 0] [5 5 0 0]]
	223	[[0 0 0 0] [0 5 0 0] [0 0 0 0] [0 5 0 0]]
	224	[[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
	225
	226	[[[0 6 0 0] [6 0 0 0] [6 6 6 0] [0 6 0 0]]
	227	[[6 6 6 0] [6 6 0 0] [0 6 0 0] [6 6 0 0]]
	228	[[0 0 0 0] [6 0 0 0] [0 0 0 0] [0 6 0 0]]
	229	[[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
	230
	231	[[[7 7 7 7] [7 0 0 0] [7 7 7 7] [7 0 0 0]]
	232	[[0 0 0 0] [7 0 0 0] [0 0 0 0] [7 0 0 0]]
	233	[[0 0 0 0] [7 0 0 0] [0 0 0 0] [7 0 0 0]]
	234	[[0 0 0 0] [7 0 0 0] [0 0 0 0] [7 0 0 0]]]])
	235
adcce7d5	236	;;the scoring rules were taken from "xtetris". Blocks score differently
3d4ae13e RS	237	;;depending on their rotation
3d4ae13e RS	238
adcce7d5	239	(defconst tetris-shape-scores
3d4ae13e RS	240	[ [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]] )
	241
	242	(defconst tetris-shape-dimensions
	243	[[2 2] [3 2] [3 2] [3 2] [3 2] [3 2] [4 1]])
	244
	245	(defconst tetris-blank 0)
	246
	247	(defconst tetris-border 8)
	248
	249	(defconst tetris-space 9)
	250
	251	(defun tetris-default-update-speed-function (shapes rows)
	252	(/ 20.0 (+ 50.0 rows)))
	253
	254	;; ;;;;;;;;;;;;; variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	255
	256	(defvar tetris-shape 0)
	257	(defvar tetris-rot 0)
	258	(defvar tetris-next-shape 0)
	259	(defvar tetris-n-shapes 0)
	260	(defvar tetris-n-rows 0)
	261	(defvar tetris-score 0)
	262	(defvar tetris-pos-x 0)
	263	(defvar tetris-pos-y 0)
	264	(defvar tetris-paused nil)
	265
	266	(make-variable-buffer-local 'tetris-shape)
	267	(make-variable-buffer-local 'tetris-rot)
	268	(make-variable-buffer-local 'tetris-next-shape)
	269	(make-variable-buffer-local 'tetris-n-shapes)
	270	(make-variable-buffer-local 'tetris-n-rows)
	271	(make-variable-buffer-local 'tetris-score)
	272	(make-variable-buffer-local 'tetris-pos-x)
	273	(make-variable-buffer-local 'tetris-pos-y)
	274	(make-variable-buffer-local 'tetris-paused)
	275
	276	;; ;;;;;;;;;;;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	277
	278	(defvar tetris-mode-map
	279	(make-sparse-keymap 'tetris-mode-map))
	280
	281	(define-key tetris-mode-map "n" 'tetris-start-game)
	282	(define-key tetris-mode-map "q" 'tetris-end-game)
	283	(define-key tetris-mode-map "p" 'tetris-pause-game)
	284
	285	(define-key tetris-mode-map " " 'tetris-move-bottom)
	286	(define-key tetris-mode-map [left] 'tetris-move-left)
	287	(define-key tetris-mode-map [right] 'tetris-move-right)
	288	(define-key tetris-mode-map [up] 'tetris-rotate-prev)
	289	(define-key tetris-mode-map [down] 'tetris-rotate-next)
	290
	291	(defvar tetris-null-map
	292	(make-sparse-keymap 'tetris-null-map))
	293
	294	(define-key tetris-null-map "n" 'tetris-start-game)
	295
	296	;; ;;;;;;;;;;;;;;;; game functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	297
	298	(defun tetris-display-options ()
	299	(let ((options (make-vector 256 nil)))
	300	(loop for c from 0 to 255 do
	301	(aset options c
	302	(cond ((= c tetris-blank)
	303	tetris-blank-options)
304	((and (>= c 1) (<= c 7))
305	(append
306	tetris-cell-options
307	`((((glyph color-x) ,(aref tetris-x-colors c))
308	(color-tty ,(aref tetris-tty-colors c))
309	(t nil)))))
310	((= c tetris-border)
311	tetris-border-options)
312	((= c tetris-space)
313	tetris-space-options)
314	(t
315	'(nil nil nil)))))
316	options))
317
318	(defun tetris-get-tick-period ()
319	(if (boundp 'tetris-update-speed-function)
320	(let ((period (apply tetris-update-speed-function
321	tetris-n-shapes
322	tetris-n-rows nil)))
323	(and (numberp period) period))))
324
325	(defun tetris-get-shape-cell (x y)
326	(aref (aref (aref (aref tetris-shapes
327	tetris-shape)
328	y)
329	tetris-rot)
330	x))
331
332	(defun tetris-shape-width ()
333	(aref (aref tetris-shape-dimensions tetris-shape)
334	(% tetris-rot 2)))
335
336	(defun tetris-shape-height ()
337	(aref (aref tetris-shape-dimensions tetris-shape)
338	(- 1 (% tetris-rot 2))))
339
340	(defun tetris-draw-score ()
341	(let ((strings (vector (format "Shapes: %05d" tetris-n-shapes)
342	(format "Rows: %05d" tetris-n-rows)
343	(format "Score: %05d" tetris-score))))
344	(loop for y from 0 to 2 do
345	(let* ((string (aref strings y))
346	(len (length string)))
347	(loop for x from 0 to (1- len) do
348	(gamegrid-set-cell (+ tetris-score-x x)
349	(+ tetris-score-y y)
350	(aref string x)))))))
351
352	(defun tetris-update-score ()
353	(tetris-draw-score)
354	(let ((period (tetris-get-tick-period)))
355	(if period (gamegrid-set-timer period))))
356
357	(defun tetris-new-shape ()
358	(setq tetris-shape tetris-next-shape)
359	(setq tetris-rot 0)
360	(setq tetris-next-shape (random 7))
361	(setq tetris-pos-x (/ (- tetris-width (tetris-shape-width)) 2))
362	(setq tetris-pos-y 0)
363	(if (tetris-test-shape)
364	(tetris-end-game)
d46b9408 CY	365	(tetris-draw-shape)
	366	(tetris-draw-next-shape)
	367	(tetris-update-score)))
3d4ae13e RS	368
	369	(defun tetris-draw-next-shape ()
	370	(loop for y from 0 to 3 do
	371	(loop for x from 0 to 3 do
	372	(gamegrid-set-cell (+ tetris-next-x x)
	373	(+ tetris-next-y y)
	374	(let ((tetris-shape tetris-next-shape)
	375	(tetris-rot 0))
	376	(tetris-get-shape-cell x y))))))
	377
	378	(defun tetris-draw-shape ()
	379	(loop for y from 0 to (1- (tetris-shape-height)) do
	380	(loop for x from 0 to (1- (tetris-shape-width)) do
	381	(let ((c (tetris-get-shape-cell x y)))
	382	(if (/= c tetris-blank)
	383	(gamegrid-set-cell (+ tetris-top-left-x
	384	tetris-pos-x
	385	x)
	386	(+ tetris-top-left-y
	387	tetris-pos-y
	388	y)
	389	c))))))
	390
	391	(defun tetris-erase-shape ()
	392	(loop for y from 0 to (1- (tetris-shape-height)) do
	393	(loop for x from 0 to (1- (tetris-shape-width)) do
	394	(let ((c (tetris-get-shape-cell x y))
	395	(px (+ tetris-top-left-x tetris-pos-x x))
	396	(py (+ tetris-top-left-y tetris-pos-y y)))
	397	(if (/= c tetris-blank)
	398	(gamegrid-set-cell px py tetris-blank))))))
	399
	400	(defun tetris-test-shape ()
	401	(let ((hit nil))
	402	(loop for y from 0 to (1- (tetris-shape-height)) do
	403	(loop for x from 0 to (1- (tetris-shape-width)) do
	404	(unless hit
	405	(setq hit
	406	(let* ((c (tetris-get-shape-cell x y))
	407	(xx (+ tetris-pos-x x))
	408	(yy (+ tetris-pos-y y))
	409	(px (+ tetris-top-left-x xx))
	410	(py (+ tetris-top-left-y yy)))
	411	(and (/= c tetris-blank)
	412	(or (>= xx tetris-width)
	413	(>= yy tetris-height)
	414	(/= (gamegrid-get-cell px py)
	415	tetris-blank))))))))
	416	hit))
	417
	418	(defun tetris-full-row (y)
	419	(let ((full t))
	420	(loop for x from 0 to (1- tetris-width) do
	421	(if (= (gamegrid-get-cell (+ tetris-top-left-x x)
	422	(+ tetris-top-left-y y))
	423	tetris-blank)
	424	(setq full nil)))
	425	full))
	426
	427	(defun tetris-shift-row (y)
	428	(if (= y 0)
	429	(loop for x from 0 to (1- tetris-width) do
	430	(gamegrid-set-cell (+ tetris-top-left-x x)
	431	(+ tetris-top-left-y y)
432	tetris-blank))
433	(loop for x from 0 to (1- tetris-width) do
434	(let ((c (gamegrid-get-cell (+ tetris-top-left-x x)
435	(+ tetris-top-left-y y -1))))
436	(gamegrid-set-cell (+ tetris-top-left-x x)
437	(+ tetris-top-left-y y)
438	c)))))
439
440	(defun tetris-shift-down ()
441	(loop for y0 from 0 to (1- tetris-height) do
442	(if (tetris-full-row y0)
443	(progn (setq tetris-n-rows (1+ tetris-n-rows))
444	(loop for y from y0 downto 0 do
445	(tetris-shift-row y))))))
446
447	(defun tetris-draw-border-p ()
448	(or (not (eq gamegrid-display-mode 'glyph))
449	tetris-draw-border-with-glyphs))
450
451	(defun tetris-init-buffer ()
452	(gamegrid-init-buffer tetris-buffer-width
453	tetris-buffer-height
454	tetris-space)
455	(let ((buffer-read-only nil))
456	(if (tetris-draw-border-p)
457	(loop for y from -1 to tetris-height do
458	(loop for x from -1 to tetris-width do
459	(gamegrid-set-cell (+ tetris-top-left-x x)
460	(+ tetris-top-left-y y)
461	tetris-border))))
462	(loop for y from 0 to (1- tetris-height) do
463	(loop for x from 0 to (1- tetris-width) do
464	(gamegrid-set-cell (+ tetris-top-left-x x)
465	(+ tetris-top-left-y y)
466	tetris-blank)))
467	(if (tetris-draw-border-p)
468	(loop for y from -1 to 4 do
469	(loop for x from -1 to 4 do
470	(gamegrid-set-cell (+ tetris-next-x x)
471	(+ tetris-next-y y)
472	tetris-border))))))
473
474	(defun tetris-reset-game ()
475	(gamegrid-kill-timer)
476	(tetris-init-buffer)
477	(setq tetris-next-shape (random 7))
478	(setq tetris-shape 0
479	tetris-rot 0
480	tetris-pos-x 0
481	tetris-pos-y 0
482	tetris-n-shapes 0
483	tetris-n-rows 0
484	tetris-score 0
485	tetris-paused nil)
486	(tetris-new-shape))
487
488	(defun tetris-shape-done ()
489	(tetris-shift-down)
490	(setq tetris-n-shapes (1+ tetris-n-shapes))
491	(setq tetris-score
adcce7d5	492	(+ tetris-score
3d4ae13e RS	493	(aref (aref tetris-shape-scores tetris-shape) tetris-rot)))
	494	(tetris-update-score)
	495	(tetris-new-shape))
	496
	497	(defun tetris-update-game (tetris-buffer)
	498	"Called on each clock tick.
	499	Drops the shape one square, testing for collision."
	500	(if (and (not tetris-paused)
	501	(eq (current-buffer) tetris-buffer))
	502	(let (hit)
	503	(tetris-erase-shape)
	504	(setq tetris-pos-y (1+ tetris-pos-y))
	505	(setq hit (tetris-test-shape))
	506	(if hit
	507	(setq tetris-pos-y (1- tetris-pos-y)))
	508	(tetris-draw-shape)
	509	(if hit
	510	(tetris-shape-done)))))
	511
	512	(defun tetris-move-bottom ()
	513	"Drops the shape to the bottom of the playing area"
	514	(interactive)
297a6dca EZ	515	(if (not tetris-paused)
	516	(let ((hit nil))
	517	(tetris-erase-shape)
	518	(while (not hit)
	519	(setq tetris-pos-y (1+ tetris-pos-y))
	520	(setq hit (tetris-test-shape)))
	521	(setq tetris-pos-y (1- tetris-pos-y))
	522	(tetris-draw-shape)
	523	(tetris-shape-done))))
3d4ae13e RS	524
	525	(defun tetris-move-left ()
	526	"Moves the shape one square to the left"
	527	(interactive)
297a6dca EZ	528	(unless (or (= tetris-pos-x 0)
297a6dca EZ	529	tetris-paused)
3d4ae13e RS	530	(tetris-erase-shape)
	531	(setq tetris-pos-x (1- tetris-pos-x))
	532	(if (tetris-test-shape)
	533	(setq tetris-pos-x (1+ tetris-pos-x)))
	534	(tetris-draw-shape)))
	535
	536	(defun tetris-move-right ()
	537	"Moves the shape one square to the right"
	538	(interactive)
297a6dca EZ	539	(unless (or (= (+ tetris-pos-x (tetris-shape-width))
	540	tetris-width)
	541	tetris-paused)
3d4ae13e RS	542	(tetris-erase-shape)
	543	(setq tetris-pos-x (1+ tetris-pos-x))
	544	(if (tetris-test-shape)
	545	(setq tetris-pos-x (1- tetris-pos-x)))
	546	(tetris-draw-shape)))
	547
	548	(defun tetris-rotate-prev ()
	549	"Rotates the shape clockwise"
	550	(interactive)
297a6dca EZ	551	(if (not tetris-paused)
	552	(progn (tetris-erase-shape)
	553	(setq tetris-rot (% (+ 1 tetris-rot) 4))
	554	(if (tetris-test-shape)
	555	(setq tetris-rot (% (+ 3 tetris-rot) 4)))
	556	(tetris-draw-shape))))
3d4ae13e RS	557
	558	(defun tetris-rotate-next ()
	559	"Rotates the shape anticlockwise"
	560	(interactive)
297a6dca EZ	561	(if (not tetris-paused)
	562	(progn
	563	(tetris-erase-shape)
	564	(setq tetris-rot (% (+ 3 tetris-rot) 4))
	565	(if (tetris-test-shape)
	566	(setq tetris-rot (% (+ 1 tetris-rot) 4)))
	567	(tetris-draw-shape))))
3d4ae13e RS	568
	569	(defun tetris-end-game ()
	570	"Terminates the current game"
	571	(interactive)
	572	(gamegrid-kill-timer)
	573	(use-local-map tetris-null-map)
	574	(gamegrid-add-score tetris-score-file tetris-score))
	575
	576	(defun tetris-start-game ()
	577	"Starts a new game of Tetris"
	578	(interactive)
	579	(tetris-reset-game)
	580	(use-local-map tetris-mode-map)
	581	(let ((period (or (tetris-get-tick-period)
	582	tetris-default-tick-period)))
	583	(gamegrid-start-timer period 'tetris-update-game)))
	584
	585	(defun tetris-pause-game ()
	586	"Pauses (or resumes) the current game"
	587	(interactive)
	588	(setq tetris-paused (not tetris-paused))
	589	(message (and tetris-paused "Game paused (press p to resume)")))
	590
	591	(defun tetris-active-p ()
	592	(eq (current-local-map) tetris-mode-map))
	593
	594	(put 'tetris-mode 'mode-class 'special)
	595
	596	(defun tetris-mode ()
	597	"A mode for playing Tetris.
	598
	599	tetris-mode keybindings:
	600	\\{tetris-mode-map}
	601	"
	602	(kill-all-local-variables)
	603
3d4ae13e RS	604	(add-hook 'kill-buffer-hook 'gamegrid-kill-timer nil t)
	605
	606	(use-local-map tetris-null-map)
	607
	608	(setq major-mode 'tetris-mode)
	609	(setq mode-name "Tetris")
	610
2b632b16 RS	611	(unless (featurep 'emacs)
	612	(setq mode-popup-menu
	613	'("Tetris Commands"
	614	["Start new game" tetris-start-game]
	615	["End game" tetris-end-game
	616	(tetris-active-p)]
	617	["Pause" tetris-pause-game
	618	(and (tetris-active-p) (not tetris-paused))]
	619	["Resume" tetris-pause-game
	620	(and (tetris-active-p) tetris-paused)])))
3d4ae13e RS	621
	622	(setq gamegrid-use-glyphs tetris-use-glyphs)
	623	(setq gamegrid-use-color tetris-use-color)
	624
	625	(gamegrid-init (tetris-display-options))
	626
c83c9654	627	(run-mode-hooks 'tetris-mode-hook))
3d4ae13e RS	628
	629	;;;###autoload
	630	(defun tetris ()
	631	"Play the Tetris game.
	632	Shapes drop from the top of the screen, and the user has to move and
	633	rotate the shape to fit in with those at the bottom of the screen so
	634	as to form complete rows.
	635
	636	tetris-mode keybindings:
	637	\\<tetris-mode-map>
	638	\\[tetris-start-game] Starts a new game of Tetris
	639	\\[tetris-end-game] Terminates the current game
	640	\\[tetris-pause-game] Pauses (or resumes) the current game
	641	\\[tetris-move-left] Moves the shape one square to the left
	642	\\[tetris-move-right] Moves the shape one square to the right
	643	\\[tetris-rotate-prev] Rotates the shape clockwise
	644	\\[tetris-rotate-next] Rotates the shape anticlockwise
	645	\\[tetris-move-bottom] Drops the shape to the bottom of the playing area
	646
	647	"
	648	(interactive)
	649
	650	(switch-to-buffer tetris-buffer-name)
	651	(gamegrid-kill-timer)
	652	(tetris-mode)
	653	(tetris-start-game))
	654
d2fe6685 GM	655	(random t)
d2fe6685 GM	656
3d4ae13e RS	657	(provide 'tetris)
3d4ae13e RS	658
cbee283d	659	;; arch-tag: fb780d53-3ff0-49f0-8e19-f7f13cf2d49e
3d4ae13e	660	;;; tetris.el ends here