;;; -*-LISP-*-
;;;
;;; Copyright (C) 2002 Donald Fisk
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program 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 this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; The original Tetris was written by Alexey Pajitnov, Dmitry Pavlovsky
;;;; and Vadim Gerasimov This implementation is independent of it, based
;;;; on a specification I arrived at through playing the game often. It
;;;; is written in Maclisp for ITS.
;;;;
;;;; To run it, start Maclisp (lisp) and then type (tetris) at the prompt.
;;;; (rotation x y) contains the coordinates that the tile at (x . y) is
;;;; rotated to, relative to the top left corner of the 4x4 grid containing
;;;; the tile.
(array rotation t 4 4)
(defun init-rotation ()
(do ((x 0 (1+ x)))
((= x 4))
(do ((y 0 (1+ y)))
((= y 4))
(store (rotation x y) (cons (- 3 y) x)))))
;;;; *current-shape* (i.e. the one currently falling) is a list of the
;;;; coordinates of its tiles. *x* and *y* are the coordinates of the top
;;;; left corner of the 4x4 grid the shape is in. The grid is useful when
;;;; calculating the initial position of the shape, and when rotating it.
(defvar +num-columns+ 10.)
(defvar +num-rows+ 22.)
(defvar *shapes* '(((0 . 1) (1 . 1) (2 . 1) (3 . 1))
((0 . 1) (1 . 1) (2 . 1) (1 . 2))
((0 . 1) (1 . 1) (2 . 1) (2 . 2))
((0 . 1) (1 . 1) (1 . 2) (2 . 2))
((1 . 1) (2 . 1) (1 . 2) (2 . 2))
((2 . 1) (3 . 1) (1 . 2) (2 . 2))
((2 . 1) (0 . 2) (1 . 2) (2 . 2))))
(defvar *current-shape*)
(defvar *next-shape*)
(defvar *x*)
(defvar *y*)
(defvar +grid-x+ 10.)
(defvar +grid-y+ 5)
(defvar *score*)
(defvar *game-over*)
;;;; *heap* initially stores the positions of imaginary tiles at the
;;;; perimeter of the rectangle the shapes fall in. During the game,
;;;; new tiles are added to heap when shapes land, and tiles are deleted
;;;; from heap when rows are completely filled.
(defvar *heap*)
(defun init-heap ()
(setf *heap* '())
;; Push on tiles to mark the perimeter of the grid. The y coord of
;; the last tile pushed = +num-rows+. We can use this to tell which tiles
;; fell and which tiles are perimeter markers.
(do ((y 0 (1+ y)))
((= y +num-rows+))
(push (cons -1 y) *heap*)
(push (cons +num-columns+ y) *heap*))
(do ((x 0 (1+ x)))
((= x +num-columns+))
(push (cons x +num-rows+) *heap*)))
(defun make-random-shape ()
(mapcar #'(lambda (tile)
(cons (+ *x* (car tile))
(+ *y* (cdr tile))))
(nth (random 7) *shapes*)))
(defun get-next-shape ()
(setf *x* 3 *y* 0)
(if (boundp '*next-shape*)
(clear-shape (mapcar #'(lambda (tile)
(cons (car tile) (- (cdr tile) 5)))
*next-shape*))
(setf *next-shape* (make-random-shape)))
(setf *current-shape* *next-shape* *next-shape* (make-random-shape))
(cursorpos 0 (* 2 +grid-x+))
(princ "Next:")
(draw-shape (mapcar #'(lambda (tile)
(cons (car tile) (- (cdr tile) 5)))
*next-shape*)))
;;; Tries to move shape one column left (x-move = -1), one column right
;;; (x-move = 1) or one row down (y-move = 1).
;;; Returns NIL on failure.
(defun move-shape (x-move y-move)
;; First, compute the new positions of the tiles.
(let ((new-shape (mapcar #'(lambda (tile)
(cons (+ x-move (car tile))
(+ y-move (cdr tile))))
*current-shape*)))
;; See if any new positions are on the heap.
(do ((tiles new-shape (cdr tiles)))
((or (null tiles)
;; New tile position already on heap?
(member (car tiles) *heap*))
(if (null tiles)
;; No new tile positions on heap -- move it (and return
;; new value of *y*).
(setf *current-shape* new-shape
*x* (+ x-move *x*) *y* (+ y-move *y*))
;; Fail -- do nothing and return NIL.
NIL)))))
;;; Tries to rotate shape. Returns NIL on failure.
(defun rotate-shape ()
(let ((new-shape (mapcar #'(lambda (tile)
;; Nasty, but might as well reuse lambda var.
(setf tile
(rotation (- (car tile) *x*)
(- (cdr tile) *y*)))
(cons (+ (car tile) *x*)
(+ (cdr tile) *y*)))
*current-shape*)))
;; See if any new positions are on the heap.
(do ((tiles new-shape (cdr tiles)))
((or (null tiles)
;; New tile position already on heap?
(member (car tiles) *heap*))
(if (null tiles)
;; No tile positions on heap -- return new value of
;; *current-shape*.
(setf *current-shape* new-shape)
;; Fail -- do nothing and return NIL.
NIL)))))
(defun draw-tile (tile)
;; Draw new position.
(cursorpos (+ +grid-y+ (cdr tile))
(* 2 (+ +grid-x+ (car tile))))
(princ '[]))
(defun draw-shape (shape) (mapc #'draw-tile shape))
(defun clear-shape (shape)
;; Clear previous positions if it can drop.
(mapc #'(lambda (tile)
(cursorpos (+ +grid-y+ (cdr tile))
(* 2 (+ +grid-x+ (car tile))))
(princ '| |))
shape))
(defun remove-duplicates (x)
(cond ((null x) x)
((member (car x) (cdr x)) (remove-duplicates (cdr x)))
(T (cons (car x) (remove-duplicates (cdr x))))))
(defun remove-whole-rows ()
;; Get the rows *current-shape* helped to fill.
(do ((rows (remove-duplicates (mapcar #'cdr *current-shape*))
(cdr rows))
(max-row 0))
((null rows)
;; Redraw heap. First clear down to max-row.
(do ((row 0 (1+ row)))
((> row max-row))
(cursorpos (+ +grid-y+ row) (* 2 +grid-x+))
(princ " "))
;; Now redraw the tiles down to max-row.
(do ((heap *heap* (cdr heap)))
((= (cdar heap) +num-rows+))
(if (<= (cdar heap) max-row)
(draw-tile (car heap)))))
(do ((heap *heap* (cdr heap))
(count 0))
((= (cdar heap) +num-rows+) ;From here on, it's
(if (= count +num-columns+) ; perimeter.
;; Row full. Update score.
(progn (setf *score* (1+ *score*))
;; Output new score at top of screen.
(cursorpos 0 0)
(format t "Score: ~a" *score*)
;; Update max row.
(setf max-row (max max-row (car rows)))
(do ((heap *heap* (cdr heap)))
((= (cdar heap) +num-rows+))
(cond ((< (cdar heap) (car rows))
;; Shift tile down a row.
(setf (cdar heap) (1+ (cdar heap))))
((= (cdar heap) (car rows))
;; Delete tile.
(setf *heap* (delq (car heap) *heap*)))))
;; Go through (cdr rows), shifting down rows above
;; (car rows).
(do ((remaining-rows (cdr rows) (cdr remaining-rows)))
((null remaining-rows))
(if (< (car remaining-rows) (car rows))
(setf (car remaining-rows)
(1+ (car remaining-rows))))))))
(if (= (cdar heap) (car rows))
;; Heap tile was in row.
(setf count (1+ count))))))
(defun redraw-shape ()
(clear-shape *current-shape*)
;; Always lower shape one line.
(if (null (move-shape 0 1))
;; Add shape to heap if it can't drop any further.
(progn (mapc #'(lambda (tile) (push tile *heap*))
*current-shape*)
;; Redraw the old shape.
(draw-shape *current-shape*)
(remove-whole-rows)
(if (zerop *y*)
(setf *game-over* T)
;; Create a new shape.
(get-next-shape))))
;; Listen for luser specified actions.
(do ((char-to-read-p (listen) (listen))
(key))
((zerop char-to-read-p))
(setf key (readch))
;; These are not easy to locate and delete from screen, so use
;; unobtrusive ones.
(cond ((eq key '/,) (move-shape -1 0)) ;Left 1.
((eq key '/.) (move-shape 1 0)) ;Right 1.
((eq key '/`)
;; Lower shape.
(do ()
((null (move-shape 0 1)))))
((eq key '/') (rotate-shape))))
(draw-shape *current-shape*))
(defun draw-perimeter ()
(cursorpos (1- +grid-y+) (1- (* 2 +grid-x+)))
(princ "+--------------------+")
(do ((line +grid-y+ (1+ line)))
((= line (+ +grid-y+ +num-rows+))
(cursorpos line (1- (* 2 +grid-x+)))
(princ "+--------------------+"))
(cursorpos line (1- (* 2 +grid-x+)))
(princ "| |")))
(defun tetris ()
(sleep 3.0)
(cursorpos 'c) ;Clear screen.
(format t "To move left, press ,~%~%")
(format t "To move right, press .~%~%")
(format t "To rotate, press '~%~%")
(format t "To drop onto the heap, press `~%~%")
(sleep 3.0)
;; (format t "Type any key to start the game.")
;; (readch)
(cursorpos 'c) ;Clear screen.
(draw-perimeter)
(init-heap)
(init-rotation)
(setf *score* 0 *game-over* NIL)
;; Output new score at top of screen.
(cursorpos 0 0)
(format t "Score: ~a" *score*)
(get-next-shape)
(do ()
(*game-over* (update-scores *score*) (quit))
(redraw-shape)
(sleep 0.2)))
(defun update-scores (score)
(let* ((f (open '(tetris scores) 'in))
;;Read old hall of fame.
(scores (read f)))
(close f)
(setf scores
(sort (cons (list score
(status uname)
(status dow)
(status date)
(status daytime))
scores)
#'(lambda (row1 row2) (> (car row1) (car row2)))))
(if (> (length scores) 10)
;; Remove lowest score.
(rplacd (nthcdr 9 scores) '()))
(cursorpos 'c)
(format t "Hall of Fame~%")
(mapc #'(lambda (line)
(let* ((score (car line))
(uname (cadr line))
(dow (caddr line))
(date (cadddr line))
(daytime (car (cddddr line))))
(format t
"~a ~a ~a ~a//~a//~a~a ~a:~a:~a~%"
score uname dow
(+ 2000. (car date))
(nth (1- (cadr date))
'(jan feb mar apr may jun
jul aug sep oct nov dec))
(caddr date)
(nth (remainder (caddr date) 10)
'("th" "st" "nd" "rd" "th"
"th" "th" "th" "th" "th"))
(car daytime) (cadr daytime) (caddr daytime))))
scores)
;; Save new hall of fame,
(setf f (open '(tetris scores) 'out))
(print scores f)
(close f)))