;;; tetris.el --- play the game of Tetris

;; Author: Eric Fischer <enf@pobox.com>
;; Created: October, 1997
;; Keywords: games

;; This program is in the public domain.

;;;;
;;;; Tetris constants and initial settings
;;;;

;;; These are the keys that you can use to maneuver the game pieces as
;;; they fall.  It's a shame these can't be bound to commands so this
;;; could be completely event-driven, but run-at-time can only schedule
;;; events with a granularity of one second and the pieces need to fall
;;; more often than that, so we have to use sit-for and input-pending-p
;;; to watch for keys instead.

(defvar tetris-left-keys 
  (list (string-to-char "j") (string-to-char "4") 'left  'kp-left)
  "*The keys that move the tetris piece to the left")
(defvar tetris-right-keys 
  (list (string-to-char "l") (string-to-char "6") 'right 'kp-right)
  "*The keys that move the tetris piece to the right")
(defvar tetris-rotate-keys 
  (list (string-to-char "k") (string-to-char "8") 'up    'kp-up)
  "*The keys that rotate the tetris piece")
(defvar tetris-drop-keys 
  (list (string-to-char " ") (string-to-char "2") 'down  'kp-down)
  "*The keys that make the tetris piece fall immediately")
(defvar tetris-quit-keys
  (list (string-to-char "q"))
  "*The keys that end a tetris game immediately")

;;; the size of the game board and the location of the preview of the 
;;; next block.

(defvar tetris-width 10      "*The width of the tetris board")
(defvar tetris-height 20     "*The height of the tetris board")
(defvar tetris-next-width 6  "*The width of the next-block preview")
(defvar tetris-next-loc -4   "*Horiz. offset of the preview from the board")

(defvar tetris-h-offset)
(defvar tetris-v-offset)

;;; the characters the game board is constructed out of.

(defvar tetris-box-chars "=="    "*The appearance of the tetris board")
(defvar tetris-piece-chars "[]"  "*The appearance of the tetris pieces")

;;; If we have color, we can color the backgrounds of the pieces and
;;; border to make them look nicer.  I'm only setting the backgrounds,
;;; even though it might be better to have solid blocks rather than
;;; blocks with punctuation marks over them, because if some other
;;; process on the same display has grabbed all the colors these might
;;; end up being all black or all white and therefore indistinguishable
;;; from the window background

(if (or (> emacs-major-version 19)
	(and (= emacs-major-version 19)
	     (> emacs-minor-version 33)))
    (progn
      (set-face-background (make-face 'tetris-red-face)    "red")
      (set-face-background (make-face 'tetris-blue-face)   "blue")
      (set-face-background (make-face 'tetris-green-face)  "green")
      (set-face-background (make-face 'tetris-yellow-face) "yellow")
      (set-face-background (make-face 'tetris-orange-face) "orange")
      (set-face-background (make-face 'tetris-purple-face) "purple")
      (set-face-background (make-face 'tetris-pink-face)   "pink")
      (set-face-background (make-face 'tetris-box-face)    "black")))

;;; the game pieces themselves: their (unused) names, colors, and
;;; the blocks they're comprised of.

(defvar tetris-pieces
      '(("block"        tetris-red-face    (0 . 0)  (1 . 0) (0 . 1) (1 . 1))
	("big stick"    tetris-blue-face   (-1 . 0) (0 . 0) (1 . 0) (2 . 0))
	("right-L"      tetris-green-face  (0 . -1) (0 . 0) (0 . 1) (1 . 1))
	("left-L"       tetris-purple-face (0 . -1) (0 . 0) (0 . 1) (-1 . 1))
	("left-thingy"  tetris-orange-face (-1 . 0) (0 . 0) (0 . 1) (1 . 1))
	("right-thingy" tetris-pink-face   (-1 . 1) (0 . 1) (0 . 0) (1 . 0))
	("T"            tetris-yellow-face (-1 . 1) (0 . 1) (0 . 0) (1 . 1))))

;;; Timing constants, in thousandths of a second.  If the drop-time is
;;; set to 1000 or greater, this will break the calculation of how much
;;; time is left after a keystroke before the block should drop, which
;;; does its math modulo 1000.

(defvar tetris-initial-drop-time 450  "*Milliseconds before a piece falls")
(defvar tetris-remove-line-time 200   "*Milliseconds to watch a row collapse")

;; Each time a line is filled, tetris-drop-time is decreased by the
;; tetris-speedup-increment until it gets to the tetris-speed-threshhold,
;; which is fast enough that's pretty impossible to play.

(defvar tetris-speedup-increment 5    "*Milliseconds faster after each row")
(defvar tetris-speed-threshhold 30    "*Minimum sane value for drop-time")

;;; Keep the high scores in this file

(defvar tetris-score-file "/tmp/tetris.scores"
  "*The tetris high-score file")

(defvar tetris-want-to-quit)

;;;;
;;;; The Tetris game itself
;;;;

;;; switch to and clear the *Tetris* buffer, and make sure it's large
;;; enough for the game board to fit; initialize the random number
;;; generator and scores; and play the game until the board is full.

;;;###autoload
(defun tetris ()
  "Play the game of Tetris"
  (interactive)
  (switch-to-buffer "*Tetris*")
  (delete-other-windows)
  (setq buffer-read-only nil)
  (buffer-disable-undo (current-buffer))
  (erase-buffer)
  (tetris-check-big-enough)
  (random t)
  (tetris-draw-board)
  (setq tetris-score-points 0)
  (setq tetris-score-rows 0)
  (setq tetris-drop-time tetris-initial-drop-time)
  (setq tetris-want-to-quit nil)
  (tetris-score-report "Tetris")
  (let ((tetris-this-piece (tetris-choose-piece))
	(tetris-next-piece (tetris-choose-piece)))
    (while (tetris-play-round 
	    tetris-this-piece (/ tetris-width 2) 0 tetris-next-piece)
      (setq tetris-this-piece tetris-next-piece)
      (setq tetris-next-piece (tetris-choose-piece))))
  (setq buffer-read-only t)
  (goto-line 1)
  (beginning-of-line)
  (tetris-do-high-scores)
  (tetris-score-report "Game Over"))

;;; main loop: until the piece has hit bottom, watch for keystrokes (and
;;; manipulate the piece appropriately if any are detected) until the timer
;;; has run out and it's time for the piece to fall.
  
(defun tetris-play-round (piece h v next)
  (tetris-draw-piece next tetris-next-loc 3)
  (cond ((tetris-could-draw piece h v)
	 (setq tetris-remaining-drop-time tetris-drop-time)
	 (while 
	     (and
	      (not tetris-want-to-quit)
	      (progn
		(tetris-draw-piece piece h v)
		(beginning-of-line)
		(let ((then (current-time))
		      (check (sit-for 0 tetris-remaining-drop-time)))
		  (tetris-erase-piece piece h v)
		  (cond (check (cond ((tetris-could-draw piece h (1+ v))
				      (setq v (1+ v))
				      (setq tetris-score-points 
					    (1+ tetris-score-points))
				      (setq tetris-remaining-drop-time 
					    tetris-drop-time)
				      t)
				     (t nil)))
			(t (while (input-pending-p)
			     (let ((key (read-event)))
			       (cond ((and (memq key tetris-left-keys)
					   (tetris-could-draw piece (1- h) v))
				      (setq h (1- h)))
				     ((and (memq key tetris-right-keys)
					   (tetris-could-draw piece (1+ h) v))
				      (setq h (1+ h)))
				     ((and (memq key tetris-rotate-keys)
					   (tetris-could-draw
					    (tetris-rotate piece) h v))
				      (setq piece (tetris-rotate piece)))
				     ((memq key tetris-drop-keys)
				      (while (tetris-could-draw piece h (1+ v))
					(setq tetris-score-points 
					      (+ 2 tetris-score-points))
					(setq v (1+ v))))
				     ((memq key tetris-quit-keys)
				      (setq tetris-want-to-quit t)))))
			   
			   ;; it's a shame sit-for doesn't return the amount of
			   ;; time remaining when it exits prematurely.
			   ;; Instead, we have to calculate the amount of time 
			   ;; we need to continue to wait based on how much 
			   ;; time we actually did spend waiting.
			   
			   (setq tetris-remaining-drop-time
				 (- tetris-remaining-drop-time
				    (% (- (+ 1000 
					     (/ (nth 2 (current-time)) 1000))
					  (/ (nth 2 then) 1000)) 1000)))
			   t))))))
	 (tetris-erase-piece next tetris-next-loc 3)
	 (tetris-draw-piece piece h v)
	 (tetris-check-finished-rows)
	 (tetris-score-report "Tetris")
	 t)
	(t nil)))
  
;;; check if the window is large enough for a Tetris board

(defun tetris-check-big-enough ()
  (let ((tetris-rows (+ tetris-height 2))
	(tetris-cols (+ 1 (* 2 (+ tetris-width tetris-next-width)) 4)))
    (if (< (window-height) tetris-rows)
	(error "window isn't tall enough (needs %d more lines)" 
	       (- tetris-rows (window-height))))
    (if (< (window-width) tetris-cols)
	(error "window isn't wide enough (needs %d more columns)" 
	       (- tetris-cols (window-width))))
    (setq tetris-h-offset 
	  (+ (/ (- (window-width) tetris-cols) 2) (* 2 tetris-next-width)))
    (setq tetris-v-offset (/ (- (window-height) tetris-rows) 2))))

;;; report the score when a piece hits bottom or the game ends

(defun tetris-score-report (str)
  (message (format "%s  Score: %d  Rows: %d" 
	    str tetris-score-points tetris-score-rows)))

;;;;
;;;; Manipulation of game pieces
;;;;

;;; given a piece, return a new piece with all the coordinates rotated
;;; 90 degrees to the left

(defun tetris-rotate (piece)
  (cons (car piece) (cons (car (cdr piece)) 
			  (tetris-rotate-coords (cdr (cdr piece))))))

;;; do the 90 degree rotation

(defun tetris-rotate-coords (coord)
  (cond ((null coord) nil)
	(t (cons (cons (cdr (car coord)) (- 0 (car (car coord))))
		 (tetris-rotate-coords (cdr coord))))))

;;; choose randomly the next piece to drop

(defun tetris-choose-piece ()
  (nth (random (length tetris-pieces)) tetris-pieces))

;;;; 
;;;; Detection and removal of filled rows
;;;;

;;; check for rows that are completely filled.  For each one that is
;;; found, wait briefly, then remove it and insert a new blank one
;;; at the top of the board.

(defun tetris-check-finished-rows ()
  (let ((line tetris-height))
    (while (> line 0)
      (while (tetris-row-finished 0 line)
	(setq tetris-score-rows (1+ tetris-score-rows))
	(setq tetris-score-points (+ 10 tetris-score-points))
	(if (> tetris-drop-time tetris-speed-threshhold)
	    (setq tetris-drop-time 
		  (- tetris-drop-time tetris-speedup-increment)))
	(beginning-of-line)  ; tetris-row-finished moved us to the right line
	(sit-for 0 tetris-remove-line-time)
	(let ((start (point)))
	  (forward-line)
	  (kill-region start (point)))
	(tetris-move-to 0 0)
	(beginning-of-line)
	(tetris-insert-new-line))
      (setq line (1- line)))))

;;; this checks whether there is something nonblank at the location
;;; specified and all locations to the right of it.

(defun tetris-row-finished (h v)
  (cond ((< h (1+ tetris-width))
	 (tetris-move-to h v)
	 (and (not (string= (char-to-string (following-char)) " "))
	      (tetris-row-finished (1+ h) v)))
	(t t)))

;;;;
;;;; Drawing and erasing of game pieces
;;;;

;;; draw the piece at the specfied location

(defun tetris-draw-piece (piece h v)
  (tetris-draw-or-erase
   (car (cdr piece)) tetris-piece-chars (cdr (cdr piece)) h v))

;;; or erase one that's already there

(defun tetris-erase-piece (piece h v)
  (tetris-draw-or-erase 'generic "  " (cdr (cdr piece)) h v))

;;; step through the points, drawing or erasing each of them

(defun tetris-draw-or-erase (face symbol points h v)
  (while points
    (tetris-draw-at face symbol 
		    (+ h (car (car points))) (+ v (cdr (car points))))
    (setq points (cdr points))))

;;; put the symbol in the face at the location.  The check for v
;;; being greater than 0 is so we can start pieces off the top of
;;; the screen and have them move downward into the visible area.

(defun tetris-draw-at (face symbol h v)
  (cond ((> v 0)
	 (tetris-move-to h v)
	 (put-text-property (point) (+ 2 (point)) 'face 'generic)
	 (delete-char 2)
	 (insert symbol)
	 (add-text-properties (- (point) 2) (point) (list 'face face)))))

;;; determine whether it would be possible to draw the specified piece
;;; at the specified location, without actually drawing it

(defun tetris-could-draw (piece h v)
  (tetris-could-draw1 (cdr (cdr piece)) h v))

;;; for each of the points, move to its location and verify that it is
;;; in fact blank.

(defun tetris-could-draw1 (points h v)
  (cond ((null points) t)
	(t (tetris-move-to (+ h (car (car points))) 
			   (+ v (cdr (car points))))
	   (and (string= (char-to-string (following-char)) " ")
		(tetris-could-draw1 (cdr points) h v)))))

;;; move point to any specified location on the game board

(defun tetris-move-to (h v)
  (goto-line (+ v tetris-v-offset))
  (beginning-of-line)
  (forward-char (+ tetris-h-offset (* h 2))))

;;;;
;;;; Constructing the Tetris game board
;;;;

;;; draw the board, starting with an empty buffer

(defun tetris-draw-board ()
  (let ((line 0))
    (while (< line tetris-v-offset)
      (insert "\n")
      (setq line (1+ line))))
  (let ((line 0))
    (while (< line tetris-height)
      (tetris-insert-new-line)
      (setq line (1+ line))))
  (tetris-insert-multiple " " tetris-h-offset)
  (let ((here (point)))
    (tetris-insert-multiple tetris-box-chars (+ tetris-width 2))
    (add-text-properties here (point) '(face tetris-box-face))))

;;; draw an empty row (either for the initial board or to replace one
;;; that has been filled and deleted)

(defun tetris-insert-new-line ()
  (tetris-insert-multiple " " tetris-h-offset)
  (insert tetris-box-chars)
  (add-text-properties (- (point) 2) (point) '(face tetris-box-face))
  (tetris-insert-multiple "  " tetris-width)
  (insert tetris-box-chars)
  (add-text-properties (- (point) 2) (point) '(face tetris-box-face))
  (insert "\n"))

;;; insert WHAT, SPACES times.

(defun tetris-insert-multiple (what spaces)
  (while (> spaces 0)
    (insert what)
    (setq spaces (1- spaces))))

;;; Update the high-score file

(defun tetris-do-high-scores ()
  (find-file-other-window tetris-score-file)
  (goto-char (point-min))
  (insert (format "%10d %5d    %8s   %s\n" 
		  tetris-score-points 
		  tetris-score-rows
		  (user-login-name)
		  (user-full-name)))
  (sort-lines t (point-min) (point-max))
  (write-file tetris-score-file))

(provide 'tetris)