;;; -*-LISP-*-
;;;
;;; Copyright (C) 2002, 2003 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 game (tetris) was written 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 was originally written in Maclisp for ITS.

;;;; (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.

;;;; To run ITSter, enter (itster) at the 'eval> ' prompt and ' '
;;;; in the canvas which opens, each time you want to play.   When
;;;; you want to exit, enter 'q' in the canvas.

(setf ROTATION (makeVector 4 0))
(doTimes (i 4) (setf (aref ROTATION i) (makeVector 4 0)))

(defun initRotation ()
  (do ((x 0 (add1 x)))
      ((= x 4))
    (do ((y 0 (add1 y)))
	((= y 4))
      (setf (aref ROTATION x y) (vector (- 3 y) x)))))

(setf 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))))
     
;;;; 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.

(setf EVENT_QUEUE '())


(setf GRID_X 10)
(setf GRID_Y 5)
(setf NUM_COLUMNS 10)
(setf NUM_ROWS 22)
(setf CURRENT_SHAPE _)
(setf NEXT_SHAPE _)
(setf X 0)
(setf Y 0)
(setf SCORE) 0
(setf TILE_SIZE 10)
(setf ITSTER_SCORES '())

;;;; 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.

(setf HEAP '())

(defun initHeap ()
  (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 (add1 y)))
      ((= y NUM_ROWS))
    (push (vector -1 y) HEAP)
    (push (vector NUM_COLUMNS y) HEAP))
  (do ((x 0 (add1 x)))
      ((= x NUM_COLUMNS))
    (push (vector x NUM_ROWS) HEAP)))

(defun makeRandomShape ()
  (map1 (lambda (tile)
	  (vector (+ X (xCoord tile))
		  (+ Y (yCoord tile))))
	(aref SHAPES (random 7))))

(defun printNextShape ()
  (drawText (getWindow CANVAS) (getGC CANVAS)
	    (* TILE_SIZE GRID_X) TILE_SIZE WHITE "Next:" HELVETICA12)
  (drawShape (map1 (lambda (tile)
		     (vector (xCoord tile)
			     (- (yCoord tile) 5)))
		   NEXT_SHAPE)))

(defun getNewCurrentShape ()
  (setf X 3)
  (setf Y 0)
  (if (eq NEXT_SHAPE _)
      (setf NEXT_SHAPE (makeRandomShape))
    (clearShape (map1 (lambda (tile)
			(vector (xCoord tile)
				(- (yCoord tile) 5)))
		      NEXT_SHAPE)))
  (setf CURRENT_SHAPE NEXT_SHAPE)
  (setf NEXT_SHAPE (makeRandomShape))
  (printNextShape)
  FALSE) ;Return FALSE to indicate success.

;;; Tries to move shape one column left (xMove = -1), one column right
;;; (xMove = 1) or one row down (yMove = 1).
;;; Returns TRUE on failure, FALSE on success (sic).
(defun moveShape (xMove yMove)
  ;; First, compute the new positions of the tiles.
  (let ((newShape (map1 (lambda (tile)
			  (vector (+ xMove (xCoord tile))
				  (+ yMove (yCoord tile))))
			CURRENT_SHAPE)))
    ;; See if any new positions are on the heap.
    (do ((tiles newShape (cdr tiles)))
	((or (null tiles)
	     ;; New tile position already on heap?
	     (not (null (memberIf (lambda (tile) (equal (car tiles) tile))
				  HEAP))))
	 (if (null tiles)
	     ;; No new tile positions on heap -- move it and return FALSE.
	     (progn (clearShape CURRENT_SHAPE)
		    (setf CURRENT_SHAPE newShape)
		    (incf X xMove)
		    (incf Y yMove)
		    (drawShape CURRENT_SHAPE)
		    FALSE)
	     ;; Fail -- do nothing and return TRUE.
	     TRUE)))))

;;; Tries to rotate shape.   Returns TRUE on failure.
(defun rotateShape ()
  (let ((newShape (map1 (lambda (tile)
			  ;; Nasty, but might as well reuse lambda var.
			  (setf tile
				(aref ROTATION
				      (- (xCoord tile) X)
				      (- (yCoord tile) Y)))
			  (vector (+ (xCoord tile) X)
				  (+ (yCoord tile) Y)))
			CURRENT_SHAPE)))
    ;; See if any new positions are on the heap.
    (do ((tiles newShape (cdr tiles)))
	((or (null tiles)
	     ;; New tile position already on heap?
	     (not (null (memberIf (lambda (tile) (equal (car tiles) tile))
		       HEAP))))
	 (if (null tiles)
	     ;; No tile positions on heap -- assign to CURRENT_SHAPE
	     ;; and return FALSE.
	     (progn (clearShape CURRENT_SHAPE)
		    (setf CURRENT_SHAPE newShape)
		    (drawShape CURRENT_SHAPE)
		    FALSE)
	   ;; Fail -- do nothing and return TRUE.
	   TRUE)))))

(defun drawTile (tile)
  ;; Draw new position.
  (drawRectangle (getWindow CANVAS) (getGC CANVAS)
		 (* TILE_SIZE (+ GRID_X (xCoord tile)))
		 (* TILE_SIZE (+ GRID_Y (yCoord tile)))
		 TILE_SIZE TILE_SIZE
		 YELLOW _))

(defun drawShape (shape)
  (mapc drawTile shape))

(defun clearShape (shape)
  ;; Clear previous positions if it can drop.
  (mapc (lambda (tile)
	  (let ((x (* TILE_SIZE (+ GRID_X (xCoord tile))))
		(y (* TILE_SIZE (+ GRID_Y (yCoord tile)))))
	    (clearArea (getWindow CANVAS) x y TILE_SIZE TILE_SIZE)))
	shape))

(defun incScore ()
  (clearArea (getWindow CANVAS)
	     0
	     (- TILE_SIZE (fontAscent HELVETICA12))
	     (textWidth HELVETICA12 (concat "Score: " SCORE))
	     (+ (fontAscent HELVETICA12) (fontDescent HELVETICA12)))
  (setf SCORE (add1 SCORE))
  ;; Output new score at top of screen.
  (drawText (getWindow CANVAS) (getGC CANVAS)
	    0 TILE_SIZE WHITE
	    (concat "Score: " SCORE) HELVETICA12))

(defun removeWholeRows ()
  ;; Get the rows CURRENT_SHAPE helped to fill.
  (do ((rows (removeDuplicates (map1 yCoord CURRENT_SHAPE))
	     (cdr rows))
       (maxRow 0))
      ((null rows)
       ;; Redraw heap.   First clear down to maxRow.
       (do ((row 0 (add1 row)))
	   ((> row maxRow))
	   (clearArea (getWindow CANVAS)
		      (* TILE_SIZE GRID_X)
		      (* TILE_SIZE (+ GRID_Y row))
		      (* TILE_SIZE 10)
		      TILE_SIZE))
       ;; Now redraw the tiles down to maxRow.
       (do ((heap HEAP (cdr heap)))
	   ((= (yCoord (car heap)) NUM_ROWS))
	   (when (<= (yCoord (car heap)) maxRow)
	     (drawTile (car heap)))))
      (do ((heap HEAP (cdr heap))
	   (count 0))
	  ((= (yCoord (car heap)) NUM_ROWS)	;From here on, it's
	   (when (= count NUM_COLUMNS)	; perimeter.
	     ;; Row full.   Update score.
	     (incScore)
	     ;; Update max row.
	     (setf maxRow (max maxRow (car rows)))
	     (do ((heap HEAP (cdr heap)))
		 ((= (yCoord (car heap)) NUM_ROWS))
		 (cond ((< (yCoord (car heap)) (car rows))
			;; Shift tile down a row.
			(setf (yCoord (car heap))
			      (add1 (yCoord (car heap)))))
		       ((= (yCoord (car heap)) (car rows))
			;; Delete tile.
			(setf HEAP (delete (car heap) HEAP)))
		       (TRUE)))
	     ;; Go through (cdr rows), shifting down rows above
	     ;; (car rows).
	     (do ((remainingRows (cdr rows) (cdr remainingRows)))
		 ((null remainingRows))
		 (when (< (car remainingRows) (car rows))
		   (setf (car remainingRows)
			 (add1 (car remainingRows)))))))
	  (when (= (yCoord (car heap)) (car rows))
	    ;; Heap tile was in row.
	    (setf count (add1 count))))))

(defun refresh ()
  (cursorpos 'c)					;Clear screen.
  (draw-perimeter)
  (do ((heap HEAP (cdr heap)))
      ((= (cdar heap) NUM_ROWS))
    (drawTile (car heap)))
  (drawText (getWindow CANVAS) (getGC CANVAS)
	    0 TILE_SIZE WHITE
	    (concat "Score: " SCORE) HELVETICA12))

(defun drawPerimeter ()
  (drawRectangle (getWindow CANVAS) (getGC CANVAS)
		 (sub1 (* TILE_SIZE GRID_X))
		 (sub1 (* TILE_SIZE GRID_Y))
		 (add1 (* TILE_SIZE NUM_COLUMNS))
		 (add1 (* TILE_SIZE NUM_ROWS))
		 _ WHITE))

(defun itster ()
  (setf CANVAS (new 'Canvas 'title "ITSter" 'fillColor BLUE))
  (initRotation)
  (setBehavior CANVAS KEY_EVENT
	       (lambda ((c Canvas) (event Array))
		 (cond ((<= LEFT_ARROW (eventKeySym event) DOWN_ARROW)
			(setf EVENT_QUEUE
			      (nconc EVENT_QUEUE
				     (list (eventKeySym event)))))
		       ((or (eq (eventChar event) \ ) ;Start
			    (eq (eventChar event) \q)) ;Quit
			(setf EVENT_QUEUE
			      (nconc EVENT_QUEUE
				     (list (eventChar event)))))
		       (TRUE FALSE))))
  ;; Wait until the luser types a space.
  (do ((event (pop EVENT_QUEUE) (pop EVENT_QUEUE)))
      ((eq event \q)
       (write TTY "You wimp!" $)
       (destroyCanvas (getWindow CANVAS) (getGC CANVAS)))
      (when (eq event \ )
	(clearArea (getWindow CANVAS)
		   0 0 (getWidth CANVAS) (getHeight CANVAS))
	(initHeap)
	(setf SCORE 0)
	;; Output new score at top of screen.
	(drawText (getWindow CANVAS) (getGC CANVAS)
		  0 TILE_SIZE WHITE
		  (concat "Score: " SCORE) HELVETICA12)
	(drawPerimeter)
	(getNewCurrentShape)
	(do ()
	    ((do ()
		 ((moveShape 0 1)
		  ;; Shape has landed on something.   Merge it with the heap.
		  (mapc (lambda (tile) (push tile HEAP))
			CURRENT_SHAPE)
		  ;; Redraw the old shape.
		  (drawShape CURRENT_SHAPE)
		  (removeWholeRows)
		  (if (zerop Y)
		      TRUE		;Game over!
		    ;; Create a new shape.
		    (getNewCurrentShape)))
		 (mapc (lambda (event)
			 (cond ((eq event LEFT_ARROW) (moveShape -1 0))
			       ((eq event UP_ARROW) (rotateShape))
			       ((eq event RIGHT_ARROW) (moveShape 1 0))
			       ((eq event DOWN_ARROW)
				(do ()
				    ;; Exit when moveShape fails
				    ;; and returns TRUE.
				    ((moveShape 0 1))))
			       (TRUE)))
		       EVENT_QUEUE)
		 (setf EVENT_QUEUE '())
		 (sleep 0.2))))
	(updateScores))))

(defun updateScores ()
  (setf ITSTER_SCORES
	(sort (cons (list SCORE (eval 'LOGNAME ENV) (date))
		    ITSTER_SCORES)
	      (lambda (row1 row2) (> (car row1) (car row2)))))
  (when (> (length ITSTER_SCORES) 10)
      ;; Remove lowest score.
      (rplacd (nthCdr 9 ITSTER_SCORES) '()))
  (write TTY "ITSter Hall of Fame" $ "===================" $)
  (mapc (lambda (line)
	  (write TTY (car line) > (cadr line) > (caddr line) $))
	ITSTER_SCORES))