More LLOGO files.

doc/llogo/demos.germ

@@ -0,0 +1,145 @@
+
+
+GOBBLE 
+THE PURPOSE IN LIFE OF THE SIMPLEST GERMS IS JUST TO EAT. 
+WE SHALL CALL THIS SPECIES THE "GOBBLERS" .  EACH SQUARE IN GERMLAND
+INITIALLY IS VERDANT WITH FOOD.  BUT WHEN A GOBBLER ARRIVES, ALL OF
+THE FOOD ON THE SQUARE IS EATEN.  THE RESULT IS A BARREN
+SQUARE AND THE EATER IS FORCED TO MOVE ON.  THE GOAL OF PROGRAMS FOR
+GOBBLERS IS TO KEEP THEM MOVING AS LONG AS THERE IS ANY FOOD LEFT IN
+GERMLAND.  THE BASIC PROBLEM GOBBLERS FACE IS GETTING TRAPPED IN A
+REGION OF NO FOOD.
+
+HERE IS A LISTING OF A SIMPLE GOBBLER PROGRAM:
+
+	    TO GOBBLE
+	    10 EAT FOOD HERE
+	    20 IF FOODP NORTH THEN MOVE NORTH STOP
+	    30 IF FOODP SOUTH THEN MOVE SOUTH STOP
+	    40 IF FOODP EAST THEN MOVE EAST STOP
+	    50 IF FOODP WEST THEN MOVE WEST STOP
+	    END
+
+
+(DEFUN GOBBLE NIL 
+       (PROG NIL 
+	10.  (EAT (FOOD (HERE)))
+	20.  (COND ((FOODP (NORTH)) (MOVE (NORTH)) (STOP)))
+	30.  (COND ((FOODP (SOUTH)) (MOVE (SOUTH)) (STOP)))
+	40.  (COND ((FOODP (EAST)) (MOVE (EAST)) (STOP)))
+	50.  (COND ((FOODP (WEST)) (MOVE (WEST)) (STOP)))
+	     (END))) 
+(PRINC REPEAT-INTRO)
+
+(UNITE 'GOBBLE ':CONTENTS)
+
+(GRID 5.) 
+
+(SETQ :HUNGRY T) 
+
+(GERM 1.  '(0. 0.)) 
+
+(FILLFOOD 1.) 
+
+(READCH) 
+
+(PRINTGRID)
+(REPEAT (GOBBLE)) 
+
+NIL 
+FANCY/ GOBBLER 
+HERE IS A SIMILAR, BUT SOMEWHAT FANCIER
+GOBBLER. IT USES THE DIRECTIONAL PRIMITIVES, AND GOES AROUND
+THE GRID, RATHER THAN UP AND DOWN. IT LOOKS LIKE THIS:
+
+
+TO XGOBBLE
+10 LOCAL 'X
+20 MAKE 'X  0
+25 EAT FOOD HERE
+30 IF FOODP FRONT THEN MOVE FRONT STOP
+40 MAKE 'X  :X + 1 IF :X = 4 THEN STOP
+50 RIGHT 90 GO 30
+END
+
+
+
+
+
+(DEFUN XGOBBLE NIL 
+       (PROG (:X) 
+	10.  (LOCAL 'X)
+	20.  (MAKE 'X 0.)
+	25.  (EAT (FOOD (HERE)))
+	30.  (COND ((FOODP (FRONT)) (MOVE (FRONT)) (STOP)))
+	40.  (MAKE 'X (INFIX-PLUS :X 1.))
+	     (COND ((INFIX-EQUAL :X 4.) (STOP)))
+	50.  (RIGHT 90.)
+	     (GO 30.)
+	     (END))) 
+(UNITE 'XGOBBLE ':CONTENTS)
+
+(PRINC REPEAT-INTRO) 
+(GRID 5.) 
+
+(SETQ :HUNGRY T) 
+
+(GERM 1.  '(0. 0.)) 
+
+(FILLFOOD 1.) 
+
+(READCH) 
+
+(PRINTGRID)
+(REPEAT (XGOBBLE)) 
+
+NIL 
+ 
+
+GOAROUND 
+THE GERMLAND GRID MAY CONTAIN OBSTACLES, WHICH
+PRINT AS X'S. A GERM CANNOT MOVE ONTO A SQUARE
+WHICH IS AN OBSTACLE, BUT IT CAN DETECT WHETHER
+THE SQUARE ON ANY PARTICULAR SIDE OF IT CONTAINS
+AN OBSTACLE. THE FOLLOWING PROGRAM DEMONSTRATES THE
+USE OF OBSTACLES: THIS GERM EXPECTS TO START OUT
+NEXT TO A COLLECTION OF OBSTACLES, WHICH IT PROCEEDS
+TO GOAROUND.
+
+TO GOAROUND
+10 TEST TOUCH LEFTSIDE
+20 IFTRUE IF TOUCH FRONT THEN RIGHT 90 GO 20
+30 IFTRUE FORWARD 1 STOP
+40 RIGHT 270 FORWARD 1
+END
+
+
+(DEFUN GOAROUND NIL 
+       (PROG NIL 
+	10.  (TEST (TOUCH (LEFTSIDE)))
+	20.  (IFTRUE (COND ((TOUCH (FRONT)) (RIGHT 90.) (GO 20.))))
+	30.  (IFTRUE (FORWARD 1.) (STOP))
+	40.  (RIGHT 270.)
+	     (FORWARD 1.)
+	     (END))) 
+(UNITE 'GOAROUND ':CONTENTS)
+(PRINC REPEAT-INTRO) 
+(GRID 5.) 
+
+(SETQ :HUNGRY NIL) 
+
+(GERM 1.  '(4. 1.)) 
+
+(MAPC 'OBSTRUCT
+      '((1. 1.) (1. 2.) (2. 2.) (2. 3.) (3. 1.) (3. 2.))) 
+
+(READCH) 
+
+(PRINTGRID)
+(REPEAT (GOAROUND)) 
+
+NIL 
+
+NIL 
+
+

src/llogo/declar.67

@@ -0,0 +1,136 @@
+
+;;THIS FILE CONTAINS DECLARATIONS FOR ALL THE LISP LOGO PRIMITIVES.
+;;GERMLAND, MUSIC BOX, TURTLE, AND TVRTLE PRIMITIVES ARE
+;;INCLUDED.
+
+(DECLARE (SETQ NFUNVARS T MUZZLED T CLOSED T MAPEX T IBASE 10.)
+         (ARRAY* (NOTYPE WHERE 1. LOOKLIKE 1. FOODSUPPLY 1.))
+         (FIXNUM REPEAT-COUNT)
+         (ARGS 'DISPLAY NIL)
+         ;;PREVENT ARG CHECK ON LLOGO'S DISPLAY WHICH MIGHT BE DIFFERENT THAN LISP'S.
+         (*FEXPR BOTH CHORUS CHORUS2 CHORUS3 CHORUS4 COMPILE
+		 DUMP EDITTITLE EITHER ENTERSNAP ERASE
+		 ERASEFILE ERASETRACE GETSNAPS GETWINDOWS IFFALSE IFTRUE
+		 INSERTLINE LINEPRINT LISPBREAK LISTFILE LISTINDEX
+		 LOGIN LOGO-EDIT LOGOBREAK MAKTURTLE MAKETURTLE
+		 PHOTO PICTURE PLOTTER PRINTOUT READFILE READLISP REPEAT RUNGERM 
+                 RESNAP SAVE
+		 SAVESNAPS SAVEWINDOWS TITLE TO USE WRITE)
+	 (*LEXPR BEARING BLINK BRIGHT DSCALE DISPLAYWINDOW EXIT ERRBREAK
+                 FILLWINDOW FPRINT FPUT HIDEWINDOW INFIX JOIN
+		 LOGO-PRINT LOGO-RANDOM LPUT MAKEWINDOW MBUFPUT MCLEAR MOTION
+		 PENSTATE POINT POINTSTATE PRECEDENCE RANGE ROUNDOFF SCALE SENTENCE
+		 SETHOME SHADE SHOWWINDOW STARTDISPLAY TOWARDS 
+                 TURTLESIZE TVSIZE TYPE UNBLINK 
+                 XORWINDOW WINDOWFRAME WINDOWHOME WIPE WORD)
+	 (*EXPR :MAX ABBREVIATE ALLOCATOR ARC ASK ATANGENT BACK
+		BELL BLANK BOOM BRUSH BUTFIRST BUTLAST
+		CARRIAGERETURN CLEARSCREEN CLOCK CONTENTS CONTENTSP
+		CONTINUE COSINE COUNT DATE DAYTIME DELX DELXY DELY
+		DIALS DIRNAME DISPAGE DRUM EDITLINE EMPTYP EMPTYWP
+		ENDSNAP ERASEABB ERASEALL ERASELINE ERASENAMES
+		ERASEPRIM ERASEPROCEDURES FIRST FORWARD
+		FRAMEUP GRITCH HEADING HERE HIDE HIDESNAP HIDETEXT
+		HIDETURTLE HOMCHECK HOME HOMESTATE INITMUSIC INTEGER ISABOUT LEFT LINE
+		LINEFEED LISP LISTABBREVIATIONS LISTALL
+		LISTCONTENTS LISTLINE LISTNAMES LISTP
+		LISTPRIMITIVES LISTPROCEDURES LISTTITLE LOGNAME
+		LOGO-LAST LOGOUT MAKETUNE MARK MBUFCLEAR
+		MBUFCOUNT MBUFINIT MBUFNEXT MBUFOUT MLEN MODMUSIC
+		NEWMUSIC NODISPLAY NOMUSIC NOPLOT NOTE NOWRAP
+		NVOICES OLDMUSIC OLDTURTLE  PARSE PARSER
+		PENDOWN PENP PENUP PERFORM PLAYTUNE PM
+		PRETTY PRIMITIVEP PUSHCONTENTS READOB REMSNAP
+		REMTEXT REQUEST RESET REST RESTARTMUSIC RIGHT RUN
+		SENTENCEP SETHEAD SETTURTLE SETX SETXY SETY SHOW
+		SHOWCLOCK SHOWSNAP SHOWTEXT SHOWTURTLE SINE SING
+		SONG STARTMUSIC  TEST THING THINGP
+		TURTLESTATE UNITE VERSION VLEN VOICE VOICES WIPE
+		WIPECLEAN WORDP WRAP XCOR XHOME YCOR YHOME) 
+
+;; SOME LLOGO PRIMITIVES MUST BE HANDLED SPECIALLY, SINCE JUST
+;;COMPILING CALLS TO THEM WILL NOT WORK. IN PARTICULAR, ANYTHING
+;;WHICH DOES A RETURN MUST BE REPLACED, AS THE PROG WILL BE GONE
+;;WHEN THE FUNCTION IS COMPILED.  NOTE THE LACK OF
+;;*EXPR DECLARATION FOR  GO. GO'S AND RETURN'S OUT OF
+;;IFTRUE'S AND IFFALSE'S WILL NOT WORK UNLESS REPLACED BY AND'S 
+;;AND OR'S WHICH COMPILER UNDERSTANDS. CALLS TO LOCAL, USER-PAREN,
+;;AND LOGO-COMMENT ARE USELESS, AND ARE DISPOSED OF. 
+
+(DEFUN END MACRO (CALL) '(RETURN '?))
+(DEFUN STOP MACRO (CALL) '(RETURN '?))
+(DEFUN IFTRUE MACRO (CALL) 
+                (RPLACA CALL 'COND)
+                (RPLACD CALL (NCONS (CONS 'TESTFLAG (CDR CALL)))))
+(DEFUN IFFALSE MACRO (CALL)
+                (RPLACA CALL 'COND)
+                (RPLACD CALL (LIST '(TESTFLAG) (CONS T (CDR CALL)))))
+(DEFUN BOTH MACRO (CALL) (RPLACA CALL 'AND))
+(DEFUN EITHER MACRO (CALL) (RPLACA CALL 'OR))
+(DEFUN OUTPUT MACRO (CALL)
+                (RPLACA CALL 'RETURN))
+(DEFUN LOCAL MACRO (CALL) NIL)
+(DEFUN LOGO-COMMENT MACRO (CALL) NIL)
+(DEFUN USER-PAREN MACRO (CALL) (CADR CALL))
+(DEFUN DOUBLE-QUOTE MACRO (CALL) (RPLACA CALL 'QUOTE))
+(DEFUN SQUARE-BRACKETS MACRO (CALL) (RPLACA CALL 'QUOTE))
+(DEFUN INFIX-PLUS MACRO (CALL) (RPLACA CALL 'PLUS))
+(DEFUN INFIX-DIFFERENCE MACRO (CALL) (RPLACA CALL 'DIFFERENCE))
+(DEFUN INFIX-TIMES MACRO (CALL) (RPLACA CALL 'TIMES))
+(DEFUN INFIX-QUOTIENT MACRO (CALL) (RPLACA CALL 'QUOTIENT))
+(DEFUN INFIX-REMAINDER MACRO (CALL) (RPLACA CALL 'REMAINDER))
+(DEFUN INFIX-EQUAL MACRO (CALL) (RPLACA CALL 'EQUAL))
+(DEFUN INFIX-LESSP MACRO (CALL) (RPLACA CALL 'LESSP))
+(DEFUN INFIX-GREATERP MACRO (CALL) (RPLACA CALL 'GREATERP))
+(DEFUN INFIX-EXPT MACRO (CALL) (RPLACA CALL 'EXPT))
+(DEFUN PREFIX-PLUS MACRO (CALL) (CADR CALL))
+(DEFUN PREFIX-MINUS MACRO (CALL) (RPLACA CALL 'MINUS))
+(DEFUN INFIX-MAKE MACRO (CALL) (RPLACA CALL 'MAKE))
+(DEFUN MAKEQ MACRO (CALL) (RPLACA CALL 'SETQ)
+                (RPLACD CALL 
+                        (CONS (IMPLODE (CONS ': (EXPLODEC (CADR CALL))))
+                              (CDDR CALL))))
+         ;;ELIMINATE THE EXPLODE THAT MAKE HAS TO DO. 
+(DEFUN MAKE MACRO (CALL)
+       (COND ((OR (ATOM (CADR CALL)) (NOT (MEMQ (CAADR CALL) '(QUOTE DOUBLE-QUOTE))))
+	      (RPLACA CALL 'SET)
+	      (RPLACD CALL
+		      (CONS (SUBST (CADR CALL)
+				   'NAME
+				   '(IMPLODE (CONS ': (EXPLODEC NAME))))
+			    (CDDR CALL))))
+	     (T (RPLACA (CDR CALL) (IMPLODE (CONS ': (EXPLODEC (CADADR CALL)))))
+		(RPLACA CALL 'SETQ))))
+
+
+;;		Compilation macros for open coding iteration loops.
+
+(DEFUN REPEAT MACRO (CALL)
+       (SUBLIS (LIST (CONS 'REPEAT-ITERATIONS (CADR CALL))
+                     (CONS 'REPEAT-BODY (NEW-BODY (CDDR CALL))))
+               '(DO ((REPEAT-COUNT 1. (1+ REPEAT-COUNT))
+                     (LOOP-VALUE '?))
+                    ((> REPEAT-COUNT REPEAT-ITERATIONS) LOOP-VALUE)
+                    . REPEAT-BODY)))
+
+(DEFUN NEW-BODY (OLD-BODY)
+       (DO ((NEW-BODY))
+           ((NULL (CDR OLD-BODY)) 
+            (NREVERSE (CONS (LIST 'SETQ 'LOOP-VALUE (CAR OLD-BODY)) NEW-BODY)))
+           (SETQ NEW-BODY (CONS (CAR OLD-BODY) NEW-BODY) OLD-BODY (CDR OLD-BODY))))
+
+(DEFUN WHILE MACRO (CALL)
+       (SUBLIS (LIST (CONS 'WHILE-CONTINUE-CONDITION (CADR CALL))
+                     (CONS 'WHILE-BODY (NEW-BODY (CDDR CALL))))
+               '(DO ((LOOP-VALUE '?)) ((NOT WHILE-CONTINUE-CONDITION) LOOP-VALUE) . WHILE-BODY)))
+
+(DEFUN UNTIL MACRO (CALL)
+       (SUBLIS (LIST (CONS 'UNTIL-STOP-CONDITION (CADR CALL))
+                     (CONS 'UNTIL-BODY (NEW-BODY (CDDR CALL))))
+               '(DO ((LOOP-VALUE '?)) (UNTIL-STOP-CONDITION LOOP-VALUE) . UNTIL-BODY)))
+
+(DEFUN FOREVER MACRO (CALL)
+       (SUBST (CDR CALL) 'FOREVER-BODY '(DO NIL (NIL) . FOREVER-BODY)))
+                       
+)
+