mirror of
https://github.com/PDP-10/its.git
synced 2026-02-11 10:44:41 +00:00
415 lines
12 KiB
Plaintext
415 lines
12 KiB
Plaintext
(DECLARE (*EXPR INIT-MAZE PRINT-MAZE CHASE WINNER)
|
||
(MAPEX T)
|
||
;(NEWIO T)
|
||
(SPECIAL DEBUG NEXTCHAR BIGX LITX BIGO LITO TIME-INTERVAL
|
||
INTERGAME-DELAY XSCORE OSCORE LEAVE-FLAG MAZE)
|
||
(UNSPECIAL BIGXDIR BIGODIR LITXDIR LITODIR)
|
||
(ARRAY* (FIXNUM (MAZE 24. 80.)))
|
||
(FIXNUM X Y XSCORE OSCORE)
|
||
(FLONUM TIME-INTERVAL))
|
||
|
||
(FASLOAD STATTY FASL DSK LIBLSP)
|
||
|
||
(SETQ MAZE (ARRAY NIL FIXNUM 24. 80.))
|
||
|
||
(eval-when (compile eval load)
|
||
(defun newcopy (x) (append x nil))
|
||
|
||
(setq makeintern t)
|
||
(DEFUN MAKESYM (A)
|
||
;; FUNCTION MAKESYM MAKES UP A GENSYM OF ITS ARG
|
||
(PUTPROP A
|
||
(ADD1 (OR (GET A 'MAKESYM) 0.))
|
||
'MAKESYM)
|
||
(SETQ A (MAKNAM (APPEND (OR (GET A 'EXPLO)
|
||
(PUTPROP A
|
||
(EXPLODE A)
|
||
'EXPLO))
|
||
(EXPLODE (GET A 'MAKESYM)))))
|
||
(COND (MAKEINTERN (INTERN A)) (A)))
|
||
)
|
||
|
||
|
||
(DEFUN MAZE MACRO (X) (NCONC (NEWCOPY '(ARRAYCALL FIXNUM)) X))
|
||
|
||
(SETQ DEBUG NIL TERPRI T NEXTCHAR '(BIGO BIGX LITO LITX)
|
||
ERRLIST '((INPUT-ACTIVATE NIL) (INPUT-ECHO T))
|
||
TIME-INTERVAL .07 INTERGAME-DELAY 10. *NOPOINT T LEAVE-FLAG NIL
|
||
IBASE 10. BASE 10.)
|
||
|
||
(PROG2 (NCONC NEXTCHAR NEXTCHAR) T)
|
||
|
||
(DEFUN INIT-MAZE (LIST)
|
||
(MAPC
|
||
'(LAMBDA (EL)
|
||
(COND
|
||
((ATOM (CAR EL))
|
||
(DO ((I (CAADR EL) (1+ I)))
|
||
((= I (CADADR EL)))
|
||
(STORE (MAZE (CAR EL) I) 95.)))
|
||
(T
|
||
(DO ((I (CAAR EL) (1+ I)))
|
||
((= I (CADAR EL)))
|
||
(STORE (MAZE I (CADR EL)) 124.)))))
|
||
LIST)
|
||
(AND DEBUG
|
||
(DO ((X 0. (1+ X)))
|
||
((= X 23.) T)
|
||
(AND (NOT (ODDP X)) (STORE (MAZE X 0.) (+ 48. (REMAINDER X 10.)))))
|
||
(DO ((Y 0. (1+ Y)))
|
||
((= Y 79.))
|
||
(AND (NOT (ODDP Y)) (STORE (MAZE 0. Y) (+ 48. (REMAINDER Y 10.)))))) )
|
||
|
||
(DEFUN PRINT-MAZE ()
|
||
(CURSORPOS 'C)
|
||
(DO ((X 0. (1+ X)))
|
||
((= X 23.))
|
||
(DO ((Y 0. (1+ Y)))
|
||
((= Y 79.))
|
||
(COND
|
||
((ZEROP (MAZE X Y)))
|
||
(T (CURSORPOS X Y) (TYO (MAZE X Y)))))))
|
||
|
||
(DEFUN CHASE ()
|
||
(PROG (XSCORE OSCORE XLEFT)
|
||
(SETQ XSCORE 0. OSCORE 0.)
|
||
(INIT-MAZE
|
||
'(((6. 12.) 67.)
|
||
((14. 16.) 58.)
|
||
(11. (56. 67.))
|
||
((5. 13.) 15.)
|
||
(12. (6. 15.))
|
||
(14. (10. 18.))
|
||
((15. 19.) 10.)
|
||
(22. (15. 22.))
|
||
((15. 19.) 26.)
|
||
((6. 20.) 17.)
|
||
(4. (15. 34.))
|
||
(11. (18. 28.))
|
||
((5. 10.) 23.)
|
||
((7. 12.) 28.)
|
||
((5. 17.) 33.)
|
||
(15. (22. 30.))
|
||
((13. 16.) 24.)
|
||
((13. 17.) 44.)
|
||
(16. (34. 38.))
|
||
(16. (39. 44.))
|
||
(12. (38. 45.))
|
||
(6. (34. 41.))
|
||
(8. (38. 45.))
|
||
((4. 9.) 44.)
|
||
(10. (34. 41.))
|
||
(10. (47. 54.))
|
||
((8. 11.) 54.)
|
||
((11. 16.) 51.)
|
||
(5. (45. 52.))
|
||
(0. (0. 80.))
|
||
(22. (0. 80.))
|
||
((1. 24.) 0.)
|
||
((1. 24.) 78.)
|
||
((1. 3.) 20.)
|
||
((3. 5.) 28.)
|
||
((16. 23.) 64.)
|
||
(4. (66. 78.))
|
||
((17. 23.) 14.)
|
||
((19. 23.) 22.)
|
||
((14. 20.) 60.)
|
||
((14. 20.) 70.)
|
||
(13. (60. 71.))
|
||
((5. 10.) 65.)
|
||
(7. (1. 11.))
|
||
((9. 13.) 6.)
|
||
((8. 11.) 10.)
|
||
(15. (52. 58.))
|
||
(19. (53. 60.))
|
||
|
||
))
|
||
(PRINT-MAZE)
|
||
NEWGAME
|
||
(COND (XLEFT (SETQ XLEFT NIL)) (T (SETQ XLEFT T)))
|
||
(SETQ BIGXDIR NIL LITXDIR NIL BIGODIR NIL LITODIR NIL)
|
||
(COND
|
||
(XLEFT
|
||
(SETQ BIGX (NEWCOPY '(2. 2.)) LITX (NEWCOPY '(20. 2.))
|
||
BIGO (NEWCOPY '(2. 74.)) LITO (NEWCOPY '(20. 74.))))
|
||
(T (SETQ BIGX (NEWCOPY '(2. 74.)) LITX (NEWCOPY '(20. 74.))
|
||
BIGO (NEWCOPY '(2. 2.)) LITO (NEWCOPY '(20. 2.)))))
|
||
(SETQ ALARMCLOCK
|
||
(FUNCTION
|
||
(LAMBDA (FOO)
|
||
(SETQ NEXTCHAR (CDR NEXTCHAR))
|
||
(COND
|
||
((EQ (CAR NEXTCHAR) 'BIGX)
|
||
(CURSORPOS (CAR BIGX) (CADR BIGX))
|
||
(CURSORPOS 'F) (CURSORPOS 'X)
|
||
(COND
|
||
((NULL BIGXDIR))
|
||
((EQ BIGXDIR 'UP)
|
||
(RPLACA (CDR BIGX) (1+ (CADR BIGX)))
|
||
(AND
|
||
(OR (NOT (ZEROP (MAZE (CAR BIGX) (CADR BIGX))))
|
||
(AND (EQ (CAR BIGX) (CAR BIGO))
|
||
(EQ (CADR BIGX) (CADR BIGO))))
|
||
(RPLACA (CDR BIGX) (1- (CADR BIGX)))))
|
||
((EQ BIGXDIR 'DOWN)
|
||
(RPLACA (CDR BIGX) (1- (CADR BIGX)))
|
||
(AND
|
||
(OR (NOT (ZEROP (MAZE (CAR BIGX) (CADR BIGX))))
|
||
(AND (EQ (CAR BIGX) (CAR BIGO))
|
||
(EQ (CADR BIGX) (CADR BIGO))))
|
||
(RPLACA (CDR BIGX) (1+ (CADR BIGX)))))
|
||
((EQ BIGXDIR 'LEFT)
|
||
(RPLACA BIGX (1- (CAR BIGX)))
|
||
(AND
|
||
(OR (NOT (ZEROP (MAZE (CAR BIGX) (CADR BIGX))))
|
||
(AND (EQ (CAR BIGX) (CAR BIGO))
|
||
(EQ (CADR BIGX) (CADR BIGO))))
|
||
(RPLACA BIGX (1+ (CAR BIGX)))))
|
||
((EQ BIGXDIR 'RIGHT)
|
||
(RPLACA BIGX (1+ (CAR BIGX)))
|
||
(AND
|
||
(OR (NOT (ZEROP (MAZE (CAR BIGX) (CADR BIGX))))
|
||
(AND (EQ (CAR BIGX) (CAR BIGO))
|
||
(EQ (CADR BIGX) (CADR BIGO))))
|
||
(RPLACA BIGX (1- (CAR BIGX))))))
|
||
(CURSORPOS (CAR BIGX) (CADR BIGX))
|
||
(TYO 88.)
|
||
(AND (= (CAR BIGX) (CAR LITO)) (= (CADR BIGX) (CADR LITO))
|
||
(WINNER 'X) (SETQ LEAVE-FLAG T)))
|
||
((EQ (CAR NEXTCHAR) 'BIGO)
|
||
(CURSORPOS (CAR BIGO) (CADR BIGO))
|
||
(CURSORPOS 'F) (CURSORPOS 'X)
|
||
(COND
|
||
((NULL BIGODIR))
|
||
((EQ BIGODIR 'UP)
|
||
(RPLACA (CDR BIGO) (1+ (CADR BIGO)))
|
||
(AND
|
||
(OR (NOT (ZEROP (MAZE (CAR BIGO) (CADR BIGO))))
|
||
(AND (EQ (CAR BIGO) (CAR BIGX))
|
||
(EQ (CADR BIGO) (CADR BIGX))))
|
||
(RPLACA (CDR BIGO) (1- (CADR BIGO)))))
|
||
((EQ BIGODIR 'DOWN)
|
||
(RPLACA (CDR BIGO) (1- (CADR BIGO)))
|
||
(AND
|
||
(OR (NOT (ZEROP (MAZE (CAR BIGO) (CADR BIGO))))
|
||
(AND (EQ (CAR BIGO) (CAR BIGX))
|
||
(EQ (CADR BIGO) (CADR BIGX))))
|
||
(RPLACA (CDR BIGO) (1+ (CADR BIGO)))))
|
||
((EQ BIGODIR 'LEFT)
|
||
(RPLACA BIGO (1- (CAR BIGO)))
|
||
(AND
|
||
(OR (NOT (ZEROP (MAZE (CAR BIGO) (CADR BIGO))))
|
||
(AND (EQ (CAR BIGO) (CAR BIGX))
|
||
(EQ (CADR BIGO) (CADR BIGX))))
|
||
(RPLACA BIGO (1+ (CAR BIGO)))))
|
||
((EQ BIGODIR 'RIGHT)
|
||
(RPLACA BIGO (1+ (CAR BIGO)))
|
||
(AND
|
||
(OR (NOT (ZEROP (MAZE (CAR BIGO) (CADR BIGO))))
|
||
(AND (EQ (CAR BIGO) (CAR BIGX))
|
||
(EQ (CADR BIGO) (CADR BIGX))))
|
||
(RPLACA BIGO (1- (CAR BIGO))))))
|
||
(CURSORPOS (CAR BIGO) (CADR BIGO))
|
||
(TYO 79.)
|
||
(AND (= (CAR BIGO) (CAR LITX)) (= (CADR BIGO) (CADR LITX))
|
||
(WINNER 'O) (SETQ LEAVE-FLAG T)))
|
||
((EQ (CAR NEXTCHAR) 'LITO)
|
||
(CURSORPOS (CAR LITO) (CADR LITO))
|
||
(CURSORPOS 'F) (CURSORPOS 'X)
|
||
(COND
|
||
((NULL LITODIR))
|
||
((EQ LITODIR 'UP)
|
||
(RPLACA (CDR LITO) (1+ (CADR LITO)))
|
||
(AND
|
||
(OR (NOT (ZEROP (MAZE (CAR LITO) (CADR LITO))))
|
||
(AND (EQ (CAR LITO) (CAR LITX))
|
||
(EQ (CADR LITO) (CADR LITX))))
|
||
(RPLACA (CDR LITO) (1- (CADR LITO)))))
|
||
((EQ LITODIR 'DOWN)
|
||
(RPLACA (CDR LITO) (1- (CADR LITO)))
|
||
(AND
|
||
(OR (NOT (ZEROP (MAZE (CAR LITO) (CADR LITO))))
|
||
(AND (EQ (CAR LITO) (CAR LITX))
|
||
(EQ (CADR LITO) (CADR LITX))))
|
||
(RPLACA (CDR LITO) (1+ (CADR LITO)))))
|
||
((EQ LITODIR 'LEFT)
|
||
(RPLACA LITO (1- (CAR LITO)))
|
||
(AND
|
||
(OR (NOT (ZEROP (MAZE (CAR LITO) (CADR LITO))))
|
||
(AND (EQ (CAR LITO) (CAR LITX))
|
||
(EQ (CADR LITO) (CADR LITX))))
|
||
(RPLACA LITO (1+ (CAR LITO)))))
|
||
((EQ LITODIR 'RIGHT)
|
||
(RPLACA LITO (1+ (CAR LITO)))
|
||
(AND
|
||
(OR (NOT (ZEROP (MAZE (CAR LITO) (CADR LITO))))
|
||
(AND (EQ (CAR LITO) (CAR LITX))
|
||
(EQ (CADR LITO) (CADR LITX))))
|
||
(RPLACA LITO (1- (CAR LITO))))))
|
||
(CURSORPOS (CAR LITO) (CADR LITO))
|
||
(TYO 111.)
|
||
(AND (= (CAR BIGX) (CAR LITO)) (= (CADR BIGX) (CADR LITO))
|
||
(WINNER 'X) (SETQ LEAVE-FLAG T)))
|
||
((EQ (CAR NEXTCHAR) 'LITX)
|
||
(CURSORPOS (CAR LITX) (CADR LITX))
|
||
(CURSORPOS 'F) (CURSORPOS 'X)
|
||
(COND
|
||
((NULL LITXDIR))
|
||
((EQ LITXDIR 'UP)
|
||
(RPLACA (CDR LITX) (1+ (CADR LITX)))
|
||
(AND
|
||
(OR (NOT (ZEROP (MAZE (CAR LITX) (CADR LITX))))
|
||
(AND (EQ (CAR LITX) (CAR LITO))
|
||
(EQ (CADR LITX) (CADR LITO))))
|
||
(RPLACA (CDR LITX) (1- (CADR LITX)))))
|
||
((EQ LITXDIR 'DOWN)
|
||
(RPLACA (CDR LITX) (1- (CADR LITX)))
|
||
(AND
|
||
(OR (NOT (ZEROP (MAZE (CAR LITX) (CADR LITX))))
|
||
(AND (EQ (CAR LITX) (CAR LITO))
|
||
(EQ (CADR LITX) (CADR LITO))))
|
||
(RPLACA (CDR LITX) (1+ (CADR LITX)))))
|
||
((EQ LITXDIR 'LEFT)
|
||
(RPLACA LITX (1- (CAR LITX)))
|
||
(AND
|
||
(OR (NOT (ZEROP (MAZE (CAR LITX) (CADR LITX))))
|
||
(AND (EQ (CAR LITX) (CAR LITO))
|
||
(EQ (CADR LITX) (CADR LITO))))
|
||
(RPLACA LITX (1+ (CAR LITX)))))
|
||
((EQ LITXDIR 'RIGHT)
|
||
(RPLACA LITX (1+ (CAR LITX)))
|
||
(AND
|
||
(OR (NOT (ZEROP (MAZE (CAR LITX) (CADR LITX))))
|
||
(AND (EQ (CAR LITX) (CAR LITO))
|
||
(EQ (CADR LITX) (CADR LITO))))
|
||
(RPLACA LITX (1- (CAR LITX))))))
|
||
(CURSORPOS (CAR LITX) (CADR LITX))
|
||
(TYO 120.)
|
||
(AND (= (CAR BIGO) (CAR LITX)) (= (CADR BIGO) (CADR LITX))
|
||
(WINNER 'O) (SETQ LEAVE-FLAG T))))
|
||
(COND ((NULL LEAVE-FLAG) (ALARMCLOCK 'TIME TIME-INTERVAL))
|
||
(T (SETQ LEAVE-FLAG NIL) (SETQ ALARMCLOCK NIL))))))
|
||
(ALARMCLOCK 'TIME TIME-INTERVAL)
|
||
(INPUT-ACTIVATE T)
|
||
(INPUT-ECHO NIL)
|
||
((LAMBDA (READTABLE)
|
||
(SSTATUS MACRO 59. NIL)
|
||
(SSTATUS MACRO 39. NIL)
|
||
(MAPC '(LAMBDA (C) (SETSYNTAX C 1245184. NIL))
|
||
'(/ A S D W F G H T /; /' /{ /[ /4 /5 /6 /8 /n /
|
||
))
|
||
(DO ((CH (READ) (READ)))
|
||
(NIL)
|
||
(COND
|
||
((EQ CH '/W)
|
||
(COND ((EQ BIGXDIR 'RIGHT) (SETQ BIGXDIR NIL))
|
||
(T (SETQ BIGXDIR 'LEFT))))
|
||
((EQ CH 'A)
|
||
(COND ((EQ BIGXDIR 'UP) (SETQ BIGXDIR NIL))
|
||
(T (SETQ BIGXDIR 'DOWN))))
|
||
((EQ CH 'S)
|
||
(COND ((EQ BIGXDIR 'LEFT) (SETQ BIGXDIR NIL))
|
||
(T (SETQ BIGXDIR 'RIGHT))))
|
||
((EQ CH 'D)
|
||
(COND ((EQ BIGXDIR 'DOWN) (SETQ BIGXDIR NIL))
|
||
(T (SETQ BIGXDIR 'UP))))
|
||
((EQ CH 'T)
|
||
(COND ((EQ LITXDIR 'RIGHT) (SETQ LITXDIR NIL))
|
||
(T (SETQ LITXDIR 'LEFT))))
|
||
((EQ CH 'F)
|
||
(COND ((EQ LITXDIR 'UP) (SETQ LITXDIR NIL))
|
||
(T (SETQ LITXDIR 'DOWN))))
|
||
((EQ CH 'G)
|
||
(COND ((EQ LITXDIR 'LEFT) (SETQ LITXDIR NIL))
|
||
(T (SETQ LITXDIR 'RIGHT))))
|
||
((EQ CH 'H)
|
||
(COND ((EQ LITXDIR 'DOWN) (SETQ LITXDIR NIL))
|
||
(T (SETQ LITXDIR 'UP))))
|
||
((EQ CH '/[)
|
||
(COND ((EQ BIGODIR 'RIGHT) (SETQ BIGODIR NIL))
|
||
(T (SETQ BIGODIR 'LEFT))))
|
||
((EQ CH '/;)
|
||
(COND ((EQ BIGODIR 'UP) (SETQ BIGODIR NIL))
|
||
(T (SETQ BIGODIR 'DOWN))))
|
||
((EQ CH '/')
|
||
(COND ((EQ BIGODIR 'LEFT) (SETQ BIGODIR NIL))
|
||
(T (SETQ BIGODIR 'RIGHT))))
|
||
((EQ CH '/{)
|
||
(COND ((EQ BIGODIR 'DOWN) (SETQ BIGODIR NIL))
|
||
(T (SETQ BIGODIR 'UP))))
|
||
((EQ CH '/8)
|
||
(COND ((EQ LITODIR 'RIGHT) (SETQ LITODIR NIL))
|
||
(T (SETQ LITODIR 'LEFT))))
|
||
((EQ CH '/4)
|
||
(COND ((EQ LITODIR 'UP) (SETQ LITODIR NIL))
|
||
(T (SETQ LITODIR 'DOWN))))
|
||
((EQ CH '/5)
|
||
(COND ((EQ LITODIR 'LEFT) (SETQ LITODIR NIL))
|
||
(T (SETQ LITODIR 'RIGHT))))
|
||
((EQ CH '/6)
|
||
(COND ((EQ LITODIR 'DOWN) (SETQ LITODIR NIL))
|
||
(T (SETQ LITODIR 'UP))))
|
||
((EQ CH '/n)
|
||
(DO ((X 10. (1+ X)))
|
||
((= X 15.))
|
||
(CURSORPOS X 33.)
|
||
(DO (( Y 33. (1+ Y)))
|
||
((= Y 48.))
|
||
(TYO (COND ((ZEROP (MAZE X Y)) 32.)(T (MAZE X Y))))))
|
||
(RETURN NIL))
|
||
((EQ CH '/
|
||
)
|
||
(SETQ BIGXDIR NIL BIGODIR NIL LITXDIR NIL LITODIR NIL)
|
||
(ALARMCLOCK 'TIME -1)
|
||
(PRINT-MAZE)
|
||
(ALARMCLOCK 'TIME TIME-INTERVAL))
|
||
((EQ CH '/) (SETQ ALARMCLOCK NIL)
|
||
(INPUT-ACTIVATE NIL)
|
||
(INPUT-ECHO T)))))
|
||
(GET (*ARRAY (GENSYM) 'READTABLE T) 'ARRAY))
|
||
(GO NEWGAME)))
|
||
))))
|
||
|
||
(DEFUN WINNER (W)
|
||
(PROG ()
|
||
(CURSORPOS (CAR BIGX) (CADR BIGX)) (CURSORPOS 'F) (CURSORPOS 'X)
|
||
(CURSORPOS (CAR BIGO) (CADR BIGO)) (CURSORPOS 'F) (CURSORPOS 'X)
|
||
(CURSORPOS (CAR LITX) (CADR LITX)) (CURSORPOS 'F) (CURSORPOS 'X)
|
||
(CURSORPOS (CAR LITO) (CADR LITO)) (CURSORPOS 'F) (CURSORPOS 'X)
|
||
(MAPC '(LAMBDA (X) (CURSORPOS (CAR (EVAL X)) (CADR (EVAL X)))
|
||
(CURSORPOS 'F)
|
||
(CURSORPOS 'X))
|
||
'(BIGX BIGO LITX LITO))
|
||
(TYO 7.)
|
||
(CURSORPOS 10. 33.)
|
||
(PRINC '|**************|)
|
||
(CURSORPOS 11. 33.)
|
||
(PRINC '|* *|)
|
||
(CURSORPOS 12. 33.)
|
||
(COND
|
||
((EQ W 'X) (PRINC '|* X WINS!! *|))
|
||
(T (PRINC '|* O WINS!! *|)))
|
||
(CURSORPOS 13. 33.)
|
||
(PRINC '|* *|)
|
||
(CURSORPOS 14. 33.)
|
||
(PRINC '|**************|)
|
||
(SLEEP 5.)
|
||
(CURSORPOS 12. 37.)
|
||
(REPEAT 8. (CURSORPOS 'X))
|
||
(COND ((EQ W 'X) (SETQ XSCORE (1+ XSCORE)))
|
||
(T (SETQ OSCORE (1+ OSCORE))))
|
||
(CURSORPOS 12. 35.)
|
||
(PRINC XSCORE)
|
||
(PRINC '| |)
|
||
(CURSORPOS 12. (COND ((> OSCORE 10.) 43.) (T 44.)))
|
||
(PRINC OSCORE)
|
||
(CURSORPOS 1. 1.)
|
||
(SLEEP 5.)
|
||
(CURSORPOS 12. 34.)
|
||
(PRINC '| READY |)
|
||
(CURSORPOS 1. 1.)
|
||
(RETURN T)))
|
||
|
||
;;; (C) Bill Kornfeld, 1978
|
||
|
||
|
||
|