diff --git a/Makefile b/Makefile index 8b73bc34..cac29e6d 100644 --- a/Makefile +++ b/Makefile @@ -11,7 +11,7 @@ SRC = system syseng sysen1 sysen2 sysen3 sysnet kshack dragon channa \ jim jm jpg macrak maxdoc maxsrc mrg munfas paulw reh rlb rlb% share \ tensor transl wgd zz graphs lmlib pratt quux scheme gsb ejs mudsys \ draw wl taa tj6 budd sharem ucode rvb kldcp math as imsrc gls demo \ - macsym lmcons dmcg hack agb + macsym lmcons dmcg hack hibou agb DOC = info _info_ sysdoc sysnet syshst kshack _teco_ emacs emacs1 c kcc \ chprog sail draw wl pc tj6 share _glpr_ _xgpr_ inquir mudman system \ xfont maxout ucode moon acount alan channa fonts games graphs humor \ diff --git a/build/lisp.tcl b/build/lisp.tcl index 1b47ee5e..9a821641 100644 --- a/build/lisp.tcl +++ b/build/lisp.tcl @@ -883,6 +883,12 @@ respond "_" "games;_chase\r" respond "_" "\032" type ":kill\r" +# ITSter +respond "*" "complr\r" +respond "_" "games;_hibou;itster\r" +respond "_" "\032" +type ":kill\r" + # Kermit respond "*" ":link math;defset fasl,lisp;\r" respond "*" ":complr\r" diff --git a/doc/games.md b/doc/games.md index e15aaea5..9be690c0 100644 --- a/doc/games.md +++ b/doc/games.md @@ -14,6 +14,11 @@ type one of: Checkers program by Alan Baisley. To play, type `:games;ckr`. +### ITSter + +Donald Fisk wrote this implementation of a classic puzzle game for ITS +in 2002. To play, type `:q games;itster (init)`. + ### Jotto Two players, one of which is the computer, competes in first guessing diff --git a/doc/programs.md b/doc/programs.md index 883555b2..c6f9ed85 100644 --- a/doc/programs.md +++ b/doc/programs.md @@ -109,6 +109,7 @@ - INQUPD, processes INQUIR change requests. - INSTAL, install executables on other ITS machines. - ITSDEV, ITS device server. +- ITSTER, Donald Fisk's block-stacking puzzle game. - JEDGAR, counter spying tool. - JOBS, list jobs by category. - JOTTO, word-guessing game. diff --git a/src/games/itster.(init) b/src/games/itster.(init) new file mode 100644 index 00000000..d57ae0b6 --- /dev/null +++ b/src/games/itster.(init) @@ -0,0 +1,5 @@ +(comment) + +(progn + (load '((dsk games) itster fasl)) + (itster)) diff --git a/src/hibou/itster.186 b/src/hibou/itster.186 new file mode 100644 index 00000000..050aefde --- /dev/null +++ b/src/hibou/itster.186 @@ -0,0 +1,341 @@ +;;; -*-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 () + (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 '(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 '(itster scores) 'out)) + (print scores f) + (close f)))