[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,
;;   2009, 2010, 2011, 2012  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 of the License, 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.  If not, see <http://www.gnu.org/licenses/>.

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