PDP-10.its/src/llogo/germ.147

;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;			GERMLAND			    ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(DECLARE (*FEXPR REPEAT RUNGERM)
	 (ARRAY* (NOTYPE  WHERE 1. LOOKLIKE 1. GERMARRAY 1. HEADING 1. FOODSUPPLY 1.))
	 (*EXPR GRID GRIDP HERE XCOR YCOR NORTH SOUTH EAST WEST HOME MOVE EAT WHAT FOOD
		FOODP GETSQUARE PUTSQUARE REMSQUARE PRINTSQUARE STEP OBSTRUCT DESTRUCT
		KILL GERM PRINTGRID CLEARSCREEN FILLFOOD NORTHP SOUTHP EASTP WESTP
		ACCESSIBLE RIGHT RT LEFT LT FORWARD FD BACK BK NEXT FSIDE RSIDE BSIDE
		LSIDE FRONT RIGHTSIDE REAR LEFTSIDE CORNERP EDGEP GERMDEMOS REQUEST
		OBTERN STOP END XTERPRI UNGRID WRAP NOWRAP CHECK-EDGE WRAP-CHECK-EDGE
		NO-WRAP-CHECK-EDGE TOUCH ERRBREAK )
	 ;;GLOBAL VARIABLES AND ATOMS TO BE TYPED FROM CONSOLE DECLARED SPECIAL
	 (SPECIAL :GERM :HUNGRY :GRIDSIZE OBARRAY ^Q LISPREADTABLE HORIZSCALE VERTSCALE
		  TOPLINE RESET-CURSOR PROGRAMS REPEAT-INTRO :WRAPAROUND OLD-POS)
         (SETQ FIXSW T MAPEX T)) 

(SSTATUS FEATURE GERMLAND) 

;;IF WE ARE IN LOGO WORLD, MAKE LISP FUCNTIONS USUABLE FROM LOGO

(COND ((STATUS FEATURE LLOGO)
       (READ-ONLY :GERM :GRIDSIZE)
       (SYSTEM-VARIABLE :HUNGRY :WRAPAROUND)
       (MAPC '(LAMBDA (X) (OBTERN X LOGO-OBARRAY))
	     '(WHERE GERM GRID GRIDP HERE XCOR YCOR NORTH SOUTH
	       EAST WEST HOME MOVE WHAT FOOD FOODP EAT GETSQUARE PUTSQUARE REMSQUARE
	       PRINTSQUARE STEP OBSTRUCT KILL DESTRUCT REPEAT PRINTGRID REPEAT-INTRO
	       FILLFOOD NORTHP SOUTHP EASTP WESTP RIGHT RT LEFT LT FORWARD FD BACK BK
	       NEXT FSIDE BSIDE RSIDE LSIDE FRONT RIGHTSIDE REAR LEFTSIDE ACCESSIBLE
	       EDGEP CORNERP RUNGERM GERMDEMOS Q CLEARSCREEN FOODSUPPLY HEADING TOPGERM
	       UNGRID WRAP NOWRAP BORDER OBSTACLE TOUCH NOGRID STARTGRID
               SG NG NOGERM))
       (DEFPROP REPEAT (L) PARSE)
       (DEFPROP RUNGERM (L) PARSE))
      ((DEFUN TYPEIN NIL (READ))
       (DEFUN REQUEST NIL (READ))
       (DEFUN UNITE (X LIST) (OR (MEMQ X (EVAL LIST)) (SET LIST (CONS X (EVAL LIST)))) '?)
       (SETQ LISPREADTABLE READTABLE :CONTENTS NIL)
       (DEFUN ASK NIL (MEMQ (IOG NIL (READ)) '(Y YES T OK SURE YA TRUE OUI DA YUP)))
       (DEFUN STOP NIL (RETURN NIL))
       (DEFUN END NIL (RETURN NIL))
       (DEFUN ERRBREAK (X Y) (PRINC Y) (APPLY 'BREAK (LIST X T))))) 

(SETQ BASE 10. IBASE 10. *NOPOINT T) 

;;*USER-PAGING NIL
;;; DEFINITION OF DOUBLE-QUOTE MACRO
;;; THIS MACRO MUST BE RUNNING AT COMPILER READ TIME.
;;; IT CONVERTS A DOUBLE QUOTED STRING TO
;;; A NON-INTERNED ATOM SUITABLE FOR PRINC'ING MESAGES

(DECLARE (EVAL (READ))) 

(SETSYNTAX 34.
	   'MACRO
	   (FUNCTION (LAMBDA NIL
			     (DO ((L) (C (TYI) (TYI)))
				 ((AND
				   (= C 34.)
				   (NOT
				    (=
				     (TYIPEEK)
				     34.)))
				  (MAKNAM
				   (NREVERSE L)))
				 (AND (= C 34.) (TYI))
                                 (AND (= C 13.) (= (TYIPEEK) 10.) (READCH))
				 (SETQ L (CONS C L)))))) 


(DECLARE (SPECIAL :GERM :HUNGRY :GRIDECHOLINES :SCREENSIZE))

(SETQ :GERM 1. :HUNGRY NIL RESET-CURSOR T :GRIDECHOLINES 10.
      :SCREENSIZE (CAR (STATUS TTYSIZE)))

;;*PAGE

(SSTATUS PAGEPAUSE NIL)


(DECLARE (*EXPR CREATE-ECHO-AREA) (SPECIAL :ECHOLINES)) 

(LAP CREATE-ECHO-AREA SUBR) 
(ARGS CREATE-ECHO-AREA (NIL . 1.)) 
(DEFSYM TYIC 1.)
(DEFSYM TYOC 2.)
(DEFSYM IMMEDIATE 512.)
(HLLOS 0. NOQUIT) 
(MOVEM A (SPECIAL :ECHOLINES)) 
(PUSH FXP TT) 
(SKIPE TT A) 
(MOVE TT 0. A) 
(*CALL 0. SET-UP-ECHO-AREA) 
;;THIS CALL ESTABLISHES AREA FOR ECHO OF TYPEIN.
(*VALUE) 
(POP FXP TT) 
(HLLZS 0 NOQUIT)
(PUSHJ P CHECKI)
(MOVE A (SPECIAL :ECHOLINES))
(POPJ P)

SET-UP-ECHO-AREA 
(SETZ) 
(SIXBIT SCML/ / ) 
;;IMMEDIATE ARG IS INPUT CHANNEL.
(0. 0. TYIC IMMEDIATE) 
;;NUMBER OF LINES IS IN A.
(SETZ 0. TT) 

NIL 

(LAP OUTPUT-TO-ECHO-AREA SUBR)
(ARGS OUTPUT-TO-ECHO-AREA (NIL . 0))
(DEFSYM TYOC 2.)
(DEFSYM IMMEDIATE 512.)
(HLLOS 0 NOQUIT)
(*OPEN TYOC REOPEN-OUTPUT) 
;;OUTPUT CHANNEL MUST BE REOPENED TO ASSURE OUTPUT GOES TO BOTTOM OF SCREEN.
(*VALUE) 
(MOVEI A 'OUTPUT-NOW-IN-ECHO-AREA) 
(HLLZS 0 NOQUIT)
(PUSHJ P CHECKI)
(POPJ P) 

REOPEN-OUTPUT 
(0. 0. (SIXBIT / / / TTY) 25.) 
;;25.  IS THE MAGIC NUMBER THAT SAYS:
;;;  1. = OUTPUT CHANNEL &
;;;  8. = OUTPUT TO ECHO AREA, IF IT EXISTS &
;;; 16. = DISPLAY MODE [LOOKS FOR CONTROL-P CODES]
(SIXBIT /.LISP/.) 
(SIXBIT OUTPUT) 

NIL 

(LAP OUTPUT-TO-MAIN-SCREEN SUBR)
(ARGS OUTPUT-TO-MAIN-SCREEN (NIL . 0))
(DEFSYM TYOC 2.)
(DEFSYM IMMEDIATE 512.)
(HLLOS 0 NOQUIT)
(*OPEN TYOC REOPEN-OUTPUT) 
(*VALUE) 
(MOVEI A 'OUTPUT-NOW-IN-MAIN-SCREEN) 
(HLLZS 0 NOQUIT)
(PUSHJ P CHECKI)
(POPJ P) 

REOPEN-OUTPUT 
(0. 0. (SIXBIT / / / TTY) 17.) 
(SIXBIT /.LISP/.) 
(SIXBIT OUTPUT) 

NIL 


(DEFUN ECHOLINES (BOTTOM-LINES)
       (CREATE-ECHO-AREA BOTTOM-LINES)
       (OUTPUT-TO-ECHO-AREA)
       (CURSORPOS 'C)
       '?) 



;;THE STANDARD LISP CURSORPOS FUNCTION WON'T DO 
;;FOR SPLIT-SCREEN HACKERY. THE SYSTEM MAINTAINS TWO
;;CURSORS, AND LISP IGNORES THE ECHO OUTPUT CURSOR.

(LAP ECHO-CURSORPOS SUBR)
(ARGS ECHO-CURSORPOS (NIL . 0))
(DEFSYM TYIC 1)
(DEFSYM IMMEDIATE 512.)
(DEFSYM RESULT 1024.)
(*CALL 0 READ-CURSOR-POSITION)
(*VALUE)
(HLLOS 0 NOQUIT)
(PUSH FXP TT)
(PUSH FXP D)
(PUSH FXP F)
(HRRZ TT F)
(JSP T FXCONS)
(MOVE B A)
(HLRZ TT F)
(JSP T FXCONS)
(CALL 2 (FUNCTION CONS))
(POP FXP F)
(POP FXP D)
(POP FXP TT)
(HLLZS 0 NOQUIT)
(PUSHJ P CHECKI)
(POPJ P)

READ-CURSOR-POSITION
(SETZ)
(SIXBIT RCPOS/ )
(0 0 1. IMMEDIATE)
(0 0 D RESULT)
(SETZ 0 F RESULT)
NIL 

;;; TOPGERM ATTEMPTS TO SET UP A CONVENIENT ENVIRONMENT FOR
;;; DEBUGGING GERM PROGRAMS. IT ALLOWS THE USER TO INTERRACT
;;; WITH LLOGO IN A MORE OR LESS NORMAL WAY, BUT
;;; ATTEMPTS TO INSURE THAT THE DISPLAY OF THE GERMLAND
;;; GRID WILL NOT BE INTERFERED WITH.

(DEFUN STARTGRID NIL 
       (ECHOLINES :GRIDECHOLINES)
       (PRINTGRID)
        '?) 
(DEFPROP TOPGERM STARTGRID EXPR)
(DEFPROP SG STARTGRID EXPR)

(DEFUN UNGRID NIL (ECHOLINES NIL) '?) 
(DEFPROP NOGRID UNGRID EXPR)
(DEFPROP NOGERM UNGRID EXPR)
(DEFPROP NG UNGRID EXPR)



(DEFUN LEGALPOS (F X) 
       ;;ERROR IN FN F IF X NOT LEGALPOS.
       (OR
	(AND (NUMBERP (CAR X)) (NUMBERP (CADR X)) (GRIDP X) X)
	(ERRBREAK
	 F
	 '"POSITION MUST BE WITHIN BOUNDARIES OF GRID"))) 

(ARRAY WHERE T 10.) 

;;THIS HOLDS POSITION OF EACH GERM

(ARRAY LOOKLIKE T 10.) 

;;THIS HOLDS WHAT THEY LOOK LIKE ON THE SCREEN.

(FILLARRAY 'LOOKLIKE '(* @ & % ? + $ = /! :)) 

(ARRAY FOODSUPPLY T 10.) 

;;THIS HOLDS THE FOOD SUPPLY FOR EACH GERM

(ARRAY HEADING T 10.) 

;; HOLDS THE CURRENT HEADING OF EACH GERM.

(DEFUN GRID (N) 
       ;;INITIALIZE GERMLAND GRID TO N BY N
       (OR (FIXP N)
	   (ERRBREAK 'GRID
		     '"INPUT MUST BE AN INTEGER"))
       (COND ((> N (- :SCREENSIZE 5.))
	      (ERRBREAK 'GRID '"GRID SIZE TOO BIG"))
	     ((< N 1.)
	      (ERRBREAK 'GRID
			'"GRID SIZE MUST BE AT LEAST 1."))
	     ;;MUST FIT ON SCREEN
	     ((ARRAY GERMARRAY T N N)
	      (COND ((< N (LSH (- :SCREENSIZE 5.) -2.)) 
                     (SETQ HORIZSCALE 8. VERTSCALE 4.))
		    ((< N (LSH (- :SCREENSIZE 5.) -1.))
                     (SETQ HORIZSCALE 4. VERTSCALE 2.))
                    ((SETQ HORIZSCALE 2. VERTSCALE 1.)))
              (SETQ :GRIDSIZE N
                    :GRIDECHOLINES (- :SCREENSIZE (+ (* VERTSCALE N) 2.)))
	      ;;ELEMENTS OF GERMARRAY WILL BE RPLACA/D INTO, SO MUST BE SET TO SEPERATE
	      ;;CONSINGS.
              (CREATE-ECHO-AREA :GRIDECHOLINES)
	      (DO I
		  0.
		  (1+ I)
		  (= I N)
		  (DO J 0. (1+ J) (= J N) (STORE (GERMARRAY I J) (LIST NIL))))
	      (FILLARRAY 'FOODSUPPLY '(0.))
	      (FILLARRAY 'HEADING '(0.))
	      N))) 

;;GLOBAL VARIABLE CONTAINING GRID SIZE

(DEFUN GRIDP (POSITION) 
       ;;RETURNS T IFF <POSITION> WITHIN GRID BOUNDS
       (AND (> (CAR POSITION) -1.)
	    (< (CAR POSITION) :GRIDSIZE)
	    (> (CADR POSITION) -1.)
	    (< (CADR POSITION) :GRIDSIZE))) 

;;*PAGE

;;; ROUTINES FOR DIRECTION REMEMBERING GERM COMMANDS
;;; RIGHT---CHANGE HEADING

(DEFUN RIGHT (N) 
       (OR (NUMBERP N)
	   (ERRBREAK 'RIGHT
		     '"INPUT TO RIGHT MUST BE A NUMBER"))
       (OR (ZEROP (\ N 90.))
	   (ERRBREAK 'RIGHT
		     '"INPUT MUST BE MULTIPLE OF 90"))
       (SETQ N (\ (+ N (HEADING :GERM)) 360.))
       (AND (MINUSP N) (SETQ N (+ N 360.)))
       (STORE (HEADING :GERM) N)) 

(PUTPROP 'RT 'RIGHT 'EXPR) 

(DEFUN LEFT (N) (RIGHT (MINUS N))) 

(PUTPROP 'LT 'LEFT 'EXPR) 

;;; FORWARD---MOVE

(DEFUN FORWARD (N) 
       (OR (NUMBERP N)
	   (ERRBREAK 'FORWARD
		     '"INPUT TO FORWARD MUST BE A NUMBER"))
       (DO ((I 1. (1+ I))
	    (HEAD (COND ((> N 0.) (HEADING :GERM))
			((SETQ N (- N)) (+ (HEADING :GERM) 180.)))))
	   ((> I N) '?)
	   (MOVE (NEXT HEAD)))) 

(PUTPROP 'FD 'FORWARD 'EXPR) 

(DEFUN BACK (N) (FORWARD (- N))) 

(PUTPROP 'BK 'BACK 'EXPR) 

;;; NEXT---NEXT SQUARE IN A GIVEN HEADING

(DEFUN NEXT (HEADING) 
       (OR (FIXP HEADING)
	   (ERRBREAK 'NEXT
		     '"INPUT MUST BE A NUMBER"))
       (SETQ HEADING (\ HEADING 360.))
       (AND (MINUSP HEADING) (SETQ HEADING (+ HEADING 360.)))
       (COND ((ZEROP HEADING) (NORTH))
	     ((= HEADING 90.) (EAST))
	     ((= HEADING 180.) (SOUTH))
	     ((= HEADING 270.) (WEST)))) 

(DEFUN FRONT NIL (NEXT (HEADING :GERM))) 

;;RETURN SQUARE FACING ANY SIDE

(DEFUN RIGHTSIDE NIL (NEXT (+ (HEADING :GERM) 90.))) 

(DEFUN REAR NIL (NEXT (+ (HEADING :GERM) 180.))) 

(DEFUN LEFTSIDE NIL (NEXT (+ (HEADING :GERM) 270.))) 

(PUTPROP 'FSIDE 'FRONT 'EXPR) 

(PUTPROP 'RSIDE 'RIGHTSIDE 'EXPR) 

(PUTPROP 'BSIDE 'REAR 'EXPR) 

(PUTPROP 'LSIDE 'LEFTSIDE 'EXPR) 

(DEFUN HERE NIL (WHERE :GERM)) 

;;POSITION OF CURRENT GERM

(DEFUN XCOR NIL (CAR (HERE))) 

;;X-COORDINATE LEFT TO RIGHT

(DEFUN YCOR NIL (CADR (HERE))) 

;;Y-COORDINATE BOTTOM TO TOP

(DEFUN WRAP NIL (DEFPROP CHECK-EDGE WRAP-CHECK-EDGE EXPR) (SETQ :WRAPAROUND T)) 

(DEFUN NOWRAP NIL (DEFPROP CHECK-EDGE NO-WRAP-CHECK-EDGE EXPR) (SETQ :WRAPAROUND NIL)) 

(NOWRAP) 

;;*PAGE

;;; RETURN THE SQUARE IN THE SPECIFIED DIRECTION FROM
;;; (HERE). IF THIS GOES BEYOND BOARD EDGE, RETURN 'CROSSBORDER IN NORMAL
;;; MODE, OR WRAPAROUND IN WRAPAROUND MODE.

(DEFUN NORTH NIL (CHECK-EDGE (LIST (XCOR) (1+ (YCOR))))) 

(DEFUN SOUTH NIL (CHECK-EDGE (LIST (XCOR) (1- (YCOR))))) 

(DEFUN EAST NIL (CHECK-EDGE (LIST (1+ (XCOR)) (YCOR)))) 

(DEFUN WEST NIL (CHECK-EDGE (LIST (1- (XCOR)) (YCOR)))) 

(DEFUN NO-WRAP-CHECK-EDGE (POS) (COND ((GRIDP POS) POS) ('BORDER))) 

(DEFUN WRAP-CHECK-EDGE (POS) 
       (MAPCAR '(LAMBDA (X) (COND ((< X 0.) (+ :GRIDSIZE X))
				  ((> X (1- :GRIDSIZE)) (- X :GRIDSIZE))
				  (X)))
	       POS)) 

(DEFUN HOME NIL (MOVE '(0. 0.))) 

;;*PAGE


(DEFUN LISTP MACRO (CALL) 
       (RPLACA CALL 'NOT)
       (RPLACD CALL (LIST (CONS 'ATOM (CDR CALL))))
       CALL)

;;; MOVE CURRENT GERM TO <PLACE>.
;;; GENERATES ERROR MESSAGE IF ILLEGAL

(DEFUN MOVE (PLACE) 
       (AND PLACE (LEGALPOS 'MOVE PLACE))
       (COND ((OR (ATOM PLACE) (NOT (GRIDP PLACE)) (GETSQUARE PLACE 'OBSTACLE))
	      (ERRBREAK 'MOVE
			'"ATTEMPT TO MOVE TO ILLEGAL POSITION"))
	     ((OUTPUT-TO-MAIN-SCREEN)
              (NOINTERRUPT T)
              (REMSQUARE (HERE) 'INHABITANT)
              (PRINTSQUARE (HERE))
              ;;OUT WITH THE OLD GERM
              (STORE (WHERE :GERM) PLACE)
              (COND ((GETSQUARE PLACE 'INHABITANT)
                     (KILL (GETSQUARE PLACE 'INHABITANT))
                     (OUTPUT-TO-MAIN-SCREEN)
                     (NOINTERRUPT T)))
              (PUTSQUARE (HERE) :GERM 'INHABITANT)
              (PRINTSQUARE PLACE)
              (OUTPUT-TO-ECHO-AREA)
              (NOINTERRUPT NIL)))
       '?) 

;;IN WITH THE NEW

(DEFUN TOUCH (POS) 
       (OR (AND (ATOM POS) POS)
	   (AND (NOT (GRIDP POS)) 'BORDER)
	   (GETSQUARE POS 'OBSTACLE))) 

(DEFUN STEP (HEADING) 
       ;;ACCEPTS NUMERICAL ARG FOR MOVING GERM
       (MOVE (NEXT HEADING))) 

(DEFUN WHAT (PLACE) 
       ;;ALL INFO AT <PLACE>
       (LEGALPOS 'WHAT PLACE)
       (CDR (GERMARRAY (CAR PLACE) (CADR PLACE)))) 

(DEFUN FOOD (PLACE) (OR (ONUMBERP (GETSQUARE PLACE 'FOOD)) 0.)) 

;;NUMBER OF FOOD PARTICLES AT <PLACE>

(DEFUN ONUMBERP (N) (AND (NUMBERP N) N)) 

(DEFUN EAT (MORSELS) 
       ;;REMOVE <MORSELS> FROM FOOD SUPPLY AT (HERE)
       (OR (NUMBERP MORSELS)
	   (ERRBREAK 'EAT
		     '"INPUT MUST BE AN INTEGER"))
       (COND ((> MORSELS (FOOD (HERE)))
	      (ERRBREAK 'EAT
			'"YOU TRIED TO EAT TOO MUCH"))
	     ((PUTSQUARE (HERE) (- (FOOD (HERE)) MORSELS) 'FOOD)))
       ;;INCREASE THE GERM'S FOOD SUPPLY BY WHAT HE JUST ATE.
       (STORE (FOODSUPPLY :GERM) (+ MORSELS (FOODSUPPLY :GERM)))) 

(DEFUN FOODP (PLACE) 
       (AND (GETSQUARE PLACE 'FOOD) (> (GETSQUARE PLACE 'FOOD) 0.))) 

(DEFUN GETSQUARE (PLACE IND) 
       ;;PROPERTY STORAGE AND RETRIEVAL FUNCTIONS
       (AND (LISTP PLACE)
	    (LEGALPOS 'GETSQUARE PLACE)
	    (GET (APPLY 'GERMARRAY PLACE) IND))) 

(DEFUN PUTSQUARE (PLACE THING IND) 
       (AND (LISTP PLACE)
	    (LEGALPOS 'PUTSQUARE PLACE)
	    (PUTPROP (APPLY 'GERMARRAY PLACE) THING IND))) 

(DEFUN REMSQUARE (PLACE IND) 
       (AND (LISTP PLACE)
	    (LEGALPOS 'REMSQUARE PLACE)
	    (REMPROP (APPLY 'GERMARRAY PLACE) IND))) 

;;(CURSORPOS <X> <Y> ) MOVES THE CURSOR TO XTH LINE [FROM TOP], YTH COLUMN GERMLAND
;;COORDINATES ARE LEFT-TO-RIGHT, BOTTOM-TO-TOP. 

(DEFUN PRINTSQUARE (PLACE) 
       ;;PRINTS ONE SQUARE OF THE GRID.
       (CURSORPOS (TIMES (- :GRIDSIZE (CADR PLACE)) VERTSCALE)
		  (TIMES HORIZSCALE (CAR PLACE)))
       (CURSORPOS 'K)
       ;;OBSTRUCTED SQUARES ARE X'S, FOOD IS NUMBERS, EMPTY SQUARE IS A POINT
       (COND ((GETSQUARE PLACE 'INHABITANT)
	      (PRINC (LOOKLIKE (GETSQUARE PLACE 'INHABITANT))))
	     ((GETSQUARE PLACE 'OBSTACLE) (PRINC 'X))
	     ((FOODP PLACE) (PRINC (FOOD PLACE)))
	     ((PRINC '/.))))

(DEFUN OBSTRUCT (POSITION) (PUTSQUARE POSITION 'OBSTACLE 'OBSTACLE)) 

;;PLACE AN OBSTACLE AT <POSITION>. NOTHING CAN BE MOVED THERE.

(DEFUN DESTRUCT (POSITION) (REMSQUARE POSITION 'OBSTACLE)) 

;;REMOVE OBSTACLE AT POSITION

(DEFUN KILL (GERM) 
       (NOINTERRUPT T)
       (OUTPUT-TO-MAIN-SCREEN)
       (CURSORPOS 0. 0.)
       (PRINC '" GERM ")
       (PRINC GERM)
       (PRINC '" IS DEAD- R. I. P.")
       (REMSQUARE (WHERE GERM) 'INHABITANT)
       (PRINTSQUARE (WHERE GERM))
       (OUTPUT-TO-ECHO-AREA)
       (NOINTERRUPT NIL)
       GERM)

(DEFUN REPEAT FEXPR (LPROGRAMS) 
       ;;PROGRAM CONTROL FUNCTION ATTACHES NTH ARG TO NTH GERM, EXECUTES EACH PROGRAM
       ;;ONCE PER CYCLE AND REPEATS.  IF USER TYPES A SPACE, DOES 1 GENERATION.  IF HE
       ;;TYPES A NUMBER, DOES THAT MANY GENERATIONS.  Q STOPS REPEAT.
       (PROG (TYPED)
	     (OR (AND LPROGRAMS (SETQ PROGRAMS LPROGRAMS))
		 PROGRAMS
		 (ERRBREAK 'REPEAT
			   '"NO PROGRAMS TO REPEAT"))
             (CURSORPOS 'C)
	AGAIN(DO ((CYCLES (COND ((AND (PRINC 'REPEAT>/ )
				      (= (TYIPEEK) 32.))
				 (READCH)
                                 (TERPRI)
				 1.)
				((MEMQ (TYIPEEK) '(1. 8. 13. 28.)) (READCH) 0.)
				((MEMQ (TYIPEEK) '(81. 113.))
				 (READCH) (AND (= (TYIPEEK) 13.) (READCH))
				 (RETURN (ASCII 0.)))
				((AND (SETQ TYPED (TYPEIN))
                                      (ONUMBERP TYPED)))
                                ((ERRBREAK 
                                  'REPEAT 
                                  '"REPEAT ACCEPTS ONLY SPACE, NUMBER, OR Q AS INPUT")))
			  (SUB1 CYCLES)))
		 ((ZEROP CYCLES))
		 (DO ((:GERM 1. (1+ :GERM))
		      (CONTROL (OR LPROGRAMS PROGRAMS) (CDR CONTROL)))
		     ((NULL CONTROL))
		     (EVAL (CAR CONTROL))
		     (AND :HUNGRY
			  (COND ((ZEROP (FOODSUPPLY :GERM)) (KILL :GERM))
				((STORE (FOODSUPPLY :GERM) (1- (FOODSUPPLY :GERM))))))))
	     (GO AGAIN))) 

(DEFUN GERM (NUMBER PLACE) 
       ;;INITIALIZE GERM <NUMBER> AT <PLACE> TO LOOK LIKE <APPEARANCE> [ONE CHARACTER]
       (REMSQUARE (WHERE NUMBER) 'INHABITANT)
       (PUTSQUARE PLACE NUMBER 'INHABITANT)
       (STORE (WHERE NUMBER) PLACE)
       (SETQ :GERM NUMBER)) 

(DEFUN PRINTGRID NIL 
       ;;DISPLAY GRID
       (NOINTERRUPT T)
       (OUTPUT-TO-MAIN-SCREEN)
       (CLEARSCREEN)
       (DO ((J (SUB1 :GRIDSIZE) (SUB1 J)) (RESET-CURSOR NIL))
	   ((MINUSP J))
	   (DO I 0. (ADD1 I) (> I (SUB1 :GRIDSIZE)) (PRINTSQUARE (LIST I J))))
       (OUTPUT-TO-ECHO-AREA)
       (NOINTERRUPT NIL)
       (ASCII 0.)) 

(DEFUN CLEARSCREEN NIL (CURSORPOS 'C)) 

;;BLANK DISPLAY SCREEN

(SSTATUS INTERRUPT 14. '(LAMBDA (USELESS) (PRINTGRID) '?)) 

;;CONTROL-\ TYPED BY USER WILL REDISPLAY THE GRID USEFUL FOR RECOVERING FROM DATAPOINT
;;MALFUNCTION

(DEFUN FILLFOOD (N) 
       ;;FILL WORLD WITH N PARTICLES OF FOOD PER SQUARE
       (OR (NUMBERP N)
	   (ERRBREAK 'FILLFOOD
		     '"INPUT MUST BE NUMBER OF FOOD PARTICLES"))
       (DO J
	   (SUB1 :GRIDSIZE)
	   (SUB1 J)
	   (MINUSP J)
	   (DO I
	       0.
	       (ADD1 I)
	       (> I (SUB1 :GRIDSIZE))
	       (PUTSQUARE (LIST I J) N 'FOOD)))
       N) 

(DEFUN NORTHP (G) (> (CADR (WHERE G)) (CADR (WHERE :GERM)))) 

(DEFUN SOUTHP (G) (< (CADR (WHERE G)) (CADR (WHERE :GERM)))) 

(DEFUN EASTP (G) (> (CAR (WHERE G)) (CAR (WHERE :GERM)))) 

(DEFUN WESTP (G) (< (CAR (WHERE G)) (CAR (WHERE :GERM)))) 

;;THESE RETURN T IF <G> IS NORTH/SOUTH/EAST/WEST/ OF :GERM

(DEFUN ACCESSIBLE (SQUARE WHO) 
       (LEGALPOS 'ACCESSIBLE SQUARE)
       (AND (MEMBER (MAPCAR '- (WHERE WHO) SQUARE)
		    '((1. 0.) (0. 1.) (-1. 0.) (0. -1.)))
	    T)) 

(DEFUN EDGEP (PLACE) 
       (LEGALPOS 'EDGEP PLACE)
       (NOT (APPLY 'AND
		   (MAPCAR 'GRIDP
			   (LIST (LIST (CAR PLACE) (ADD1 (CADR PLACE)))
				 (LIST (ADD1 (CAR PLACE)) (CADR PLACE))
				 (LIST (CAR PLACE) (SUB1 (CADR PLACE)))
				 (LIST (SUB1 (CAR PLACE)) (CADR PLACE))))))) 

(DEFUN CORNERP (PLACE) 
       (LEGALPOS 'CORNERP PLACE)
       (< 1.
	  (APPLY '+
		 (MAPCAR '(LAMBDA (X) (COND ((GRIDP X) 0.) (1.)))
			 (LIST (LIST (CAR PLACE) (ADD1 (CADR PLACE)))
			       (LIST (ADD1 (CAR PLACE)) (CADR PLACE))
			       (LIST (CAR PLACE) (SUB1 (CADR PLACE)))
			       (LIST (SUB1 (CAR PLACE)) (CADR PLACE))))))) 

;;* PAGE


(DEFUN RUNGERM FEXPR (LPROGRAMS) 
       (PROG (HELP :GERM TYPED) 
	     (AND LPROGRAMS
		  (PRINTGRID)
		  (APPLY 'REPEAT LPROGRAMS)
		  (RETURN (ASCII 0.)))
	     (SETQ :GERM 1. PROGRAMS NIL)
	     (CLEARSCREEN)
	     (PRINC
	      '"WELCOME TO GERMLAND!!!
DO YOU NEED HELP? ")
	     (SETQ HELP (ASK))
	     (PRINC
	      '"
WHAT SIZE GRID WOULD YOU LIKE? (TYPE A NUMBER) ")
	     (GRID (TYPEIN))
	     (PRINC
	      '"
NOW, LET'S PUT SOME GERMS IN GERMLAND. ")
	BIRTH(GERM
	      :GERM
	      (AND
	       (PRINC
		'"
WHAT SQUARE SHOULD THE GERM START OUT ON? ")
	       (OR
		(NOT HELP)
		(PRINC
		 '"
(A SQUARE IS A SENTENCE (<X> <Y>) WHERE <X> IS THE NUMBER
 OF SQUARES FROM THE LEFT AND <Y> IS THE NUMBER OF
 SQUARES FROM THE BOTTOM) "))
	       (LEGALPOS 'RUNGERM (REQUEST))))
	     (PRINC '" THIS GERM WILL LOOK LIKE: ")
	     (PRINC (LOOKLIKE :GERM))
	     (PRINC '"
WHAT SHOULD THIS GERM'S PROGRAM BE? ")
	     (SETQ TYPED
		   (REQUEST)
		   PROGRAMS
		   (CONS (COND ((ATOM TYPED) (LIST TYPED)) (TYPED)) PROGRAMS))
	     (OR (GETL (CAAR PROGRAMS) '(EXPR FEXPR SUBR FSUBR MACRO LSUBR))
		 (ERRBREAK 'RUNGERM
			   (LIST (CAAR PROGRAMS)
				 '" IS NOT DEFINED")))
	     (AND (< :GERM 8.)
		  (PRINC '"
SHALL WE ADD ANOTHER GERM? ")
		  (ASK)
		  (SETQ :GERM (ADD1 :GERM))
		  (GO BIRTH))
	     (PRINC '"
SHOULD THE GERMS BE HUNGRY? ")
	     (AND
	      HELP
	      (PRINC
	       '"
(HUNGRY GERMS MUST EAT 1 MORSEL OF FOOD FOR EACH TURN OR THEY DIE)"))
	     (SETQ :HUNGRY (ASK))
	     (AND
	      :HUNGRY
	      (PROG NIL 
		    (PRINC
		     '"
THEN YOU MUST FILL SOME SQUARES WITH FOOD.")
		    (COND
		     (HELP
		      (PRINC
		       '"
TYPE A NUMBER TO FILL ALL THE SQUARES OF GERMLAND
WITH THAT MANY MORSELS OF FOOD. (TYPE 0 IF
YOU DON'T WANT THIS TO HAPPEN) ? "))
		     ((PRINC '"
HOW MANY PARTICLES OF FOOD DO YOU WANT ON EACH SQUARE? (TYPE A NUMBER)  ")))	    
                    (FILLFOOD (TYPEIN))
		    (PRINC
		     '"DO YOU WANT TO ADD MORE FOOD TO SPECIFIC SQUARES?")
		    (OR (ASK) (GO FED))
	       FEED (PRINC
		     '"TYPE THE AMOUNT OF FOOD TO ADD (OR 0 IF YOU ARE DONE): ")
		    (SETQ TYPED (TYPEIN))
		    (AND (ZEROP TYPED) (GO FED))
		    (PRINC
		     '"TYPE A LIST OF SQUARES TO ADD THIS FOOD TO: ")
		    (MAPC '(LAMBDA (X) (PUTSQUARE X TYPED 'FOOD)) (REQUEST))
		    (GO FEED)
	       FED  (RETURN NIL)))
	     (COND
	      (HELP
	       (PRINC
		'"
TYPE A LIST OF SQUARES WHICH YOU WANT TO BE OBSTRUCTED? "))
	      ((PRINC '"
OBSTRUCTIONS? ")))
	     (MAPC 'OBSTRUCT (REQUEST))
	RUNNIT
	     (PRINC
	      '"
OKAY, WE'RE READY TO START. SHALL WE BEGIN? ")
	     (SETQ PROGRAMS (REVERSE PROGRAMS))
	     (AND (ASK) (STARTGRID) (REPEAT))
	     (RETURN (ASCII 0.)))) 

;;* PAGE

;;; GERMDEMOS IMPLEMENTS THE STANDARDIZED FORMAT FOR GERM DEMOS
;;; THE DEMOS ARE IN THE FILE AI:LLOGO;DEMOS >
;;; THE FORMAT FOR A DEMO IS:
;;; NAME OF DEMO, STRING TERMINATED BY ALT-MODE,
;;; SERIES OF THINGS TO BE READ-EVAL-PRINTED, NIL.
;;; TWO NILS END THE FILE. NOTE THAT THE FILE IS TO BE READ WITH
;;; THE LISP READTABLE, BUT THE LOGO OBARRAY, SINCE THE FILE IS IN
;;; LISP FORMAT, BUT THE DEMO NAMES MUST  BE ACCESSIBLE FROM LOGO.

(DEFUN GERMDEMOS NIL 
       (PROG (^Q READTABLE REPEAT-INTRO) 
	     (UREAD DEMOS GERM DSK LLOGO)
	     (CLEARSCREEN)
	     (SETQ 
	      ^Q
	      T
	      READTABLE
	      LISPREADTABLE
	      REPEAT-INTRO
	      '"
TYPE A SPACE TO DO ONE GENERATION, OR A NUMBER TO DO THAT
MANY GENERATIONS.
IF THE BOARD GETS MESSED UP, HIT CONTROL-\.
TYPE Q TO STOP.
(TYPE SPACE TO START)")
             (NOGRID)
             (SSTATUS PAGEPAUSE T)
	     (PRINC
	      '"
GERMLAND IS A GRID OF SQUARES ON WHICH MAY LIVE UP
TO 10 GERMS. SQUARES MAY ALSO CONTAIN FOOD FOR THEM TO
EAT OR OBSTACLES WHICH PREVENT THEM FROM MOVING.
WITH EACH GERM YOU ASSOCIATE A FIXED PROGRAM, WHICH IT REPEATS
ONCE EACH GENERATION UNTIL IT DIES.
SEE THE LLOGO MANUAL (AI MEMO 307) FOR PRIMITIVES TO USE IN WRITING
GERM PROGRAMS, AND LOGO WORKING PAPER 7 FOR MORE INFO.")
	     (DO ((NAME (READ) (READ)) (EVAL?))
		 ((EQ NAME NIL))
		 (TERPRI)
		 (PRINC '"DO YOU WANT TO SEE THE ")
		 (PRINC NAME)
		 (PRINC '" DEMO? ")
		 (SETQ EVAL? (ASK))
		 (AND EVAL? (CLEARSCREEN))
		 (DO ((C (TYI) (TYI))) ((= C 27.)) (AND EVAL? (NOT (= C 10.)) (TYO C)))
		 (DO ((FORM (READ) (READ)))
		     ((NULL FORM))
		     (AND EVAL? ((LAMBDA (^Q) (EVAL FORM)) NIL)))
                 (NOGRID)
                 (SSTATUS PAGEPAUSE T)))
       (SSTATUS PAGEPAUSE NIL)
       (PRINC
	'"
OKAY, NOW IT'S YOUR TURN. WHEN YOU FINISH WRITING YOUR GERM,
SET UP A GRID USING RUNGERM, AND TRY IT OUT.
HAVE FUN!
")     '?) 

(PROG NIL 
      (GRID 3.)
      (GERM 1. '(0. 0.))
      (STARTGRID)
      (PRINC
       '"
WELCOME TO GERMLAND.
CALL GERMDEMOS TO SEE DEMOSTRATION PROGRAMS,
CALL RUNGERM TO REINITIALIZE GRID.
")      (RETURN '?))