mirror of
https://github.com/PDP-10/its.git
synced 2026-01-26 20:22:22 +00:00
343 lines
11 KiB
Common Lisp
343 lines
11 KiB
Common Lisp
;;; -*-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 game 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 is written in Maclisp for ITS. To run it, start
|
||
;;;; Maclisp `:LISP' and type `(load 'itster)' and then `(itster)' 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)))))
|
||
|
||
(array shapes t 7)
|
||
|
||
(defun init-shapes ()
|
||
(store (shapes 0) '((0 . 1) (1 . 1) (2 . 1) (3 . 1)))
|
||
(store (shapes 1) '((0 . 1) (1 . 1) (2 . 1) (1 . 2)))
|
||
(store (shapes 2) '((0 . 1) (1 . 1) (2 . 1) (2 . 2)))
|
||
(store (shapes 3) '((0 . 1) (1 . 1) (1 . 2) (2 . 2)))
|
||
(store (shapes 4) '((1 . 1) (2 . 1) (1 . 2) (2 . 2)))
|
||
(store (shapes 5) '((2 . 1) (3 . 1) (1 . 2) (2 . 2)))
|
||
(store (shapes 6) '((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.
|
||
|
||
(defvar +grid-x+ 10.)
|
||
(defvar +grid-y+ 5)
|
||
(defvar +num-columns+ 10.)
|
||
(defvar +num-rows+ 22.)
|
||
(defvar *current-shape*)
|
||
(defvar *next-shape*)
|
||
(defvar *x*)
|
||
(defvar *y*)
|
||
(defvar *score*)
|
||
|
||
;;;; *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))))
|
||
(shapes (random 7))))
|
||
|
||
(defun print-next-shape ()
|
||
(cursorpos 0 (* 2 +grid-x+))
|
||
(princ "Next:")
|
||
(draw-shape (mapcar #'(lambda (tile)
|
||
(cons (car tile) (- (cdr tile) 5)))
|
||
*next-shape*)))
|
||
|
||
(defun get-new-current-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))
|
||
(print-next-shape)
|
||
*current-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))))))
|
||
|
||
;;; Lowers shape and then responds to luser specified actions.
|
||
;;; Returns NIL if the game is over (*y* = 0).
|
||
(defun redraw-shape ()
|
||
(clear-shape *current-shape*)
|
||
;; Always try to lower shape one line.
|
||
(if (or (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*)
|
||
NIL ;Fail => game over.
|
||
;; Create a new shape.
|
||
(get-new-current-shape))))
|
||
;; Still in the game. Listen for luser specified actions.
|
||
(do ((char-to-read-p (listen) (listen))
|
||
(key))
|
||
((zerop char-to-read-p)
|
||
(draw-shape *current-shape*))
|
||
(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))
|
||
((eq key '/ )
|
||
;; Useful if something overwrites screen.
|
||
(refresh))))))
|
||
|
||
(defun refresh ()
|
||
(cursorpos 'c) ;Clear screen.
|
||
(draw-perimeter)
|
||
(do ((heap *heap* (cdr heap)))
|
||
((= (cdar heap) +num-rows+))
|
||
(draw-tile (car heap)))
|
||
(cursorpos 0 0)
|
||
(format t "Score: ~a" *score*)
|
||
(print-next-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 itster ()
|
||
(setq base 10. ibase 10. *nopoint t)
|
||
(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 `~%~%")
|
||
(format t "Enter speed (if unsure, make it 5 or 10): ")
|
||
(let ((tick-length (quotient 1.0 (read))))
|
||
(cursorpos 'c) ;Clear screen.
|
||
(draw-perimeter)
|
||
(init-heap)
|
||
(init-rotation)
|
||
(init-shapes)
|
||
(setf *score* 0)
|
||
;; Output new score at top of screen.
|
||
(cursorpos 0 0)
|
||
(format t "Score: ~a" *score*)
|
||
(get-new-current-shape)
|
||
(do ()
|
||
((null (redraw-shape)) (update-scores *score*))
|
||
(sleep tick-length))))
|
||
|
||
(defun update-scores (score)
|
||
(let* ((f (open '((dsk games) itster 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 lower score.
|
||
(rplacd (nthcdr 9 scores) '()))
|
||
(cursorpos 'c) ;Clear screen.
|
||
(format t "ITSter Hall of Fame~%===================~%")
|
||
(mapc #'(lambda (line)
|
||
(let* ((score (car line))
|
||
(uname (cadr line))
|
||
(dow (caddr line))
|
||
(date (cadddr line))
|
||
(day (caddr date))
|
||
(daytime (car (cddddr line))))
|
||
(format t
|
||
"~a ~a ~a ~a~a ~a, ~a ~a:~a:~a~%"
|
||
score uname dow
|
||
day
|
||
(if (member day '(11. 12. 13.))
|
||
"th"
|
||
(nth (remainder day 10.)
|
||
'("th" "st" "nd" "rd" "th"
|
||
"th" "th" "th" "th" "th")))
|
||
(nth (1- (cadr date))
|
||
'(Jan Feb Mar Apr May Jun
|
||
Jul Aug Sep Oct Nov Dec))
|
||
(+ 2000. (car date))
|
||
(car daytime) (cadr daytime) (caddr daytime))))
|
||
scores)
|
||
;; Save new hall of fame.
|
||
(setf f (open '((dsk games) itster scores) 'out))
|
||
(print scores f)
|
||
(close f)))
|