;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;			DEFINE > 			    ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;THIS FILE IS INTENDED FOR:
;;;	DEFINING LLOGO PRIMITIVES
;;;	READING IN DECLARATIONS AND MACROS FOR COMPILING PIECES OF LLOGO.
;;;
;; IT CONTAINS DEFINITIONS OF READMACROS, COMPILER-EXPANDED MACROS, DEFINITION OF
;;DEFINE FUNCTION.  NOTE THAT THIS FILE ITSELF MUST BE READ INTO COMPILER TO COMPILE
;;IT.  NOTHING IN THIS FILE WILL BE PRESENT IN COMPILED LLOGO, EXCEPT THAT DEFINE
;;FUNCTION WILL BE AUTOLOADED.

(DECLARE (SPECIAL SYNSTAX TTYNOTES DEFINE-MACRO-INDEX)
	 (MACROS T)
	 (GENPREFIX DEFINE-)
	 (COND ((STATUS FEATURE DEFINE))
	       ((AND (OR (STATUS FEATURE ITS) (STATUS FEATURE DEC10))
		     (ERRSET (FASLOAD DEFINE FASL AI LLOGO))))
	       ((AND (STATUS FEATURE MULTICS)
		     (ERRSET (LOAD "DEFINE.LISP"))))
	       ((IOG NIL (PRINT '(DEFINE MUST BE READ INTO COMPILER)))))) 

(DECLARE (READ)) 

(AND (STATUS FEATURE ITS)
     (OR (STATUS FEATURE NCOMPLR) (STATUS FEATURE COMPLR))
     ;;READING IN TO COMPILER INTERPRETIVELY TO COMPILE ITSELF, MUST CHANGE OBARRAY
     ;;AND READTABLE SO DEFINITIONS OF READMACROS, ETC.  WILL WIND UP ON CORRECT
     ;;ONES.
     (SETQ OBARRAY COBARRAY READTABLE CREADTABLE)) 

(SSTATUS FEATURE DEFINE) 

(*RSET T) 

(SETQ CAR T CDR T NO-VALUE '?) 

;;TO SET CONDITIONAL READ IN SWITCHES WHILE COMPILING, TYPE CONTROL-G AT COMPLR,
;;(SETQ <SWITCH> <VALUE>) THEN (MAKLAP) TO RETURN TO COMPILER COMMAND LEVEL.  IN
;;COMPILERS >= VERSION 489, A "&" IS REQUIRED BEFORE THE SETQ TO SET THE VARIABLES
;;ON THE RIGHT OBARRAY.

(COND ((BOUNDP 'THIS-SYSTEM)
       (SETQ ITS (EQ THIS-SYSTEM 'ITS) DEC10 (EQ THIS-SYSTEM 'DEC10)))
      ((SETQ ITS (STATUS FEATURE ITS) DEC10 (STATUS FEATURE DEC10)))) 

;;THIS-SYSTEM IS A VARIABLE DENOTING THE CURRENT IMPLEMENTATION.  IF NOT PREVIOUSLY
;;SET, DEDUCED FROM (STATUS FEATURES).  ATOM "MULTICS" HAS CAPITAL "M", SO REPLACE
;;WITH SMALL.

(SETQ MULTICS (AND (NOT ITS) (NOT DEC10))) 

;;CLOGO VS.  11LOGO COMPATIBILITY SWITCH.  [11LOGO DEFAULT]

(COND ((BOUNDP 'CLOGO) (SETQ /11LOGO (NOT CLOGO)))
      ((BOUNDP '/11LOGO) (SETQ CLOGO (NOT /11LOGO)))
      ((SETQ /11LOGO T CLOGO NIL))) 

(OR (BOUNDP ':CAREFUL) (SETQ :CAREFUL T)) 

(OR (BOUNDP 'BIBOP) (SETQ BIBOP ITS)) 

(SETQ COMPILING (OR (STATUS FEATURE COMPLR)
		    ;;VARIOUS INCARNATIONS OF THE LISP COMPILER ARE NAMED
		    ;;DIFFERENTLY.
		    (STATUS FEATURE NCOMPLR)
		    (STATUS FEATURE COMPILER))) 

;;READ-TIME SWITCH FOR IMPLEMENTATION-DEPENDENT CODE.  OPEN BRACKET IS DEFINED TO BE
;;A READMACRO [ON LISP READTABLE ONLY] WHICH PICKS UP THE NEXT OBJECT, AND EVALUATES
;;IT.  IF IT EVALUATES TO NON-NIL, BRACKETS DISAPPEAR.  IF IN THE WRONG SYSTEM,
;;EVERYTHING IS DISCARDED UP TO THE NEXT CLOSE BRACKET.  EXAMPLE:
;;;	[MULTICS <CODE GOOD ONLY IN MULTICS>]
;;;	[(OR ITS DEC10) <CODE GOOD IN EITHER ITS OR DEC10, NOT MULTICS>]

(SETQ SYNSTAX NIL GENSYM (GENSYM)) 

;;TO ALLOW NESTING OF SQUARE-BRACKET MACROS, A STACK OF SYNTAX PROPERTIES FOR
;;CLOSE-BRACKET IS KEPT, CHANGED WHEN AN OPEN BRACKET IS ENCOUNTERED, RESTORED WHEN
;;A CLOSE-BRACKET IS MET. 

(DEFUN OPEN-BRACKET-MACRO NIL 
       (SETQ SYNSTAX (CONS (STATUS MACRO 93.) SYNSTAX))
       (COND ((EVAL (READ))
	      (SETSYNTAX 93. 'SPLICING 'RESTORE-CLOSE-BRACKET-SYNTAX))
	     ((SETSYNTAX 93. 'MACRO 'CLOSE-BRACKET-MACRO)
	      ;;IN THE WRONG SYSTEM, GOBBLE AND DISCARD EVERYTHING TILL THE NEXT
	      ;;CLOSE BRACKET.  SYNTAX OF CLOSE-BRACKET MUST BE CHANGED TO MAKE IT
	      ;;REAPPEAR.
	      (DO ((STUFF (READ) (READ)))
		  ((EQ STUFF GENSYM) (RESTORE-CLOSE-BRACKET-SYNTAX)))))
       NIL) 

(SETSYNTAX 91. 'SPLICING 'OPEN-BRACKET-MACRO) 

(DEFUN RESTORE-CLOSE-BRACKET-SYNTAX NIL 
       (SETSYNTAX 93. (OR (CADAR SYNSTAX) 'MACRO) (CAAR SYNSTAX))
       (SETQ SYNSTAX (CDR SYNSTAX))
       NIL) 

(DEFUN CLOSE-BRACKET-MACRO NIL GENSYM) 

(SETSYNTAX 93. 'MACRO 'CLOSE-BRACKET-MACRO) 

;;DOUBLE-QUOTE IS DEFINED ON THE LISP READTABLE TO BE A PL/1-TYPE STRING-QUOTING
;;MACRO.  IN THE MULTICS IMPLEMENTATION, STRINGS ARE IMPLEMENTED DIRECTLY.

[(OR ITS DEC10) (DEFUN DOUBLE-QUOTE-MACRO NIL 
		       (DO ((CHARLIST) (CHARNUM (TYI) (TYI)))
			   ((AND (= CHARNUM 34.) (NOT (= (TYIPEEK) 34.)))
			    (MAKNAM (NREVERSE CHARLIST)))
			   (AND (= CHARNUM 34.) (TYI))
			   (SETQ CHARLIST (CONS CHARNUM CHARLIST)))) 
		(SETSYNTAX 34. 'MACRO 'DOUBLE-QUOTE-MACRO)] 

;;NOTE THAT THE DOUBLE-QUOTE MACRO DOES NOT INTERN THE ATOM CREATED.  END OF
;;READMACRO CHARACTER DEFINITIONS.
;;*PAGE

;; COMPILER DECLARATIONS AND MACROS.

(AND COMPILING
     ;;OPEN CODE MAP'S, FLUSH KLUDGY EXPR-HASH FEATURE, NO FUNCTIONAL VARIABLES.
     (SETQ MAPEX T EXPR-HASH NIL NFUNVARS T)
     (*FEXPR DEFINE DUMP ERASE IF IFFALSE IFTRUE LISPBREAK LOGOBREAK LOGO-EDIT
	     LOAD-IF-WANTED LOGIN PRINTOUTFILE PRINTOUTINDEX PRINTOUTTITLE PRINTOUT
	     READFILE REMGRIND REMTRACE SAVE TO TRACE UNTRACE USE WRITE)
     (*LEXPR DPRINTL EXIT ERRBREAK LOCATE-ERROR LOGOREAD LOGO-PRINT LOGO-RANDOM
	     ATOMIZE PARSELINE ROUNDOFF SENTENCE TYPE WORD WRITELIST)
     (*EXPR ABB1 ADDLINE ABBREVIATIONP ASK ALLOCATOR BIND-ACTIVATE-LISP
	    BIND-ACTIVATE-LOGO CONTROL-N CONTROL-P CONTROL-R CONTROL-S DATE DAYTIME
	    DEFAULT-FUNCTION DELEET DPRINC DPRINT DTERPRI EDITINIT1 EDIT-LINE
	    ERASELINE ERRORFRAME EVALS EXPUNGE ERASEPRIM FILESPEC FUNCTION-PROP
	    GETLINE HOW-TO-PARSE-INPUTS HOMCHECK INIT LINE LISP LOGO LOGOPRINC MAKE
	    MAKLOGONAM NUMBER? OBTERN OUTPUT PARSE PASS2 PASS2-ERROR PRINTOUTLINES
	    PRINTOUTNAMES PRINTOUTPROCEDURES PRINTOUTTITLES PRIMITIVEP PROCEDUREP
	    REPAIR-LINE REQUEST REMSNAP REREAD-ERROR SCREENSIZE SET- SYNONYMIZE
	    SYMBOLP TOP-LEVEL TRACE? TRACED? UNITE UNPARSE-FORM
	    UNPARSE-FUNCTION-NAME UNTRACE1 UNPARSE-LOGO-LINE VARIABLEP VERSION)
     (SPECIAL :BURIED :CAREFUL :COMPILED :CONTENTS :EDITMODE :EMPTYW :ERRBREAK
	      :HISTORY :INFIX :LISPBREAK :NAMES :PARENBALANCE :PI :REDEFINE
	      :SCREENSIZE :SHOW :SNAPS :TEXT :TEXTXHOME :TEXTYHOME :WRAP ? ABB
	      ATOM-GOBBLER BAD-FORM CAR-FORM CDR-FORM CLOCK CLOGO CTRL-E CONTROL-K
	      CONTROL-L CTRL-P CTRL-R CTRL-S DEFAULT-PRECEDENCE DEFAULT-TURTLE
	      DEFINE-DEFPROP DEFINE-HOMCHECK DEFINE-OBTERN DEFINE-SYNONYMIZE
	      DEF-IND-RPLACA DEF-PROP-RPLACA DEF-SYM-RPLACA DPRINC DTERPRI
	      EDIT? EDITED EDITTITLE
	      EDL EDT EOF EOL EOL* ERRBREAK ERRLIST ERRS EXIT FIRST FLAG FN FNNAME
	      FULL GENSYM HOM HOMCHECK HOMCHECK-RPLACA INFIX INPUT-LIST INPUTS
	      INSERTLINE-NUMBER LAST-LINE LINE LISP LISP-OBARRAY LISP-OBDIM
	      LISPPRINT LISP-READTABLE LISPREADTABLE LOGO-OBARRAY LOGOREAD
	      LOGO-READTABLE LOGOREADTABLE MERGESTATUS NEXT-TAG NOUUO NO-VALUE
	      NULL-LINE NUMBER OBARRAY OBTERN-RPLACA OLD-LINE OLDPARSE PARSE
	      PARSED-FORM /11LOGO PASS2-LINE PI-OVER-180 PROG PROMPTER PROP
	      READTABLE REQUEST? REREAD-ERROR? RIGHT-ASSOCIATIVE SAIL STACK-TYPE SYN
	      SYN-NEW-RPLACA SYN-OLD-RPLACA TESTFLAG THIS-FORM THIS-FORM-INDEX
	      THIS-LINE THIS-LINE-INDEX THIS-VALUE-INDEX TITLE TOP-LINE TOKENLINE
	      TOL TOPARSE TTY TYPE UNPARSE UNPARSED-LINE UNARY-MINUS UP? WORD ^Q *
	      + -)
     (FIXNUM ABOVE ARGINDEX ARGS ARG-COUNT CHARNUM CHRCT DEFAULT-PRECEDENCE
	     DIRECTION ENV FORM-INDEX FRAME-NUMBER HOWMANY HOW-MANY-ARGS I J
	     LINE-INDEX LINEL LISP-OBDIM NEWLINEL POSITION (PRECEDENCE)
	     ROUND-FIXNUM-VARIABLE ROUND-PLACES STACK-POINTER 
             THIS-FORM-INDEX THIS-LINE-INDEX
	     THIS-VALUE-INDEX TYIPEEKED TTY VALUE-INDEX)
     (ARRAY* (NOTYPE VALUE-HISTORY 1.)
	     (NOTYPE FORM-HISTORY 1.)
	     (NOTYPE LINE-HISTORY 1.)
	     (NOTYPE DEFINEARRAY-TYPE 1.))
     (FLONUM (\$ FLONUM FLONUM) :PI PI-OVER-180 UNROUNDED TEN-TO-PLACES)
     (NOTYPE (PARSE-EXPR-ARGS FIXNUM))) 

;;*PAGE

;;;			DEFINING LLOGO PRIMITIVES
;;;FORMAT - (DEFINE FN (11LOGO ...)   (ABB ...) (SYN ...) (PARSE ...) (UNPARSE ...)
;; (FASLOAD ...) DEFINITION)
;;;
;;;(ABB ABB1 ABB2....) THIS CLAUSE SPECIFIES ABBREVIATIONS FOR THE FUNCTION BEING
;;DEFINED.
;;;(SYN GOLDEN-OLDIE) SAYS THAT THE FUNCTION IS TO BE DEFINED TO BE A SYNONYM OF
;;GOLDEN-OLDIE.
;;;(PARSE PARSE-PROPERTY) (UNPARSE UNPARSE-PROPERTY)
;;; ARE DECLARATIONS TO THE PARSER/UNPARSER TO SPECIFY HOW THE
;;; CALLS TO THE FUNCTION BEING DEFINED ARE TO BE PARSED/UNPARSED.
;;;(FASLOAD <FILE NAME>) -- FN IS DEFINED TO BE A MACRO WHICH WILL
;;;     FASLOAD IN THE SPECIFIED FILE WHICH SHOULD DEFINE THE FN.
;;;;	DEFINITION CONSISTS OF INPUTS AND BODY AS FOR A "DEFUN".

(DEFUN ACCEPT-ADVICE (ADVICE) 
       ;;SLICE OFF ADVICE CLAUSES.
       (DO NIL
	   ((OR (NULL ADVICE)
		(ATOM (CADR ADVICE))
		(NOT (MEMQ (CAADR ADVICE) '(ABB SYN PARSE UNPARSE FASLOAD)))))
	   (SET (CAADR ADVICE) (CDADR ADVICE))
	   (RPLACD ADVICE (CDDR ADVICE)))) 

;;INITIALIZATION OF FORMS NEEDED BY DEFINE FUNCTION.  THESE VARIABLES ARE KEPT
;;AROUND SO THAT DEFINE FUNCTION NEEDN'T DO CONSING.

(DEFUN DEFINE-PROPERTY (SYMBOL PROPERTY INDICATOR) 
       (DEFINE-HAPPEN (LIST 'DEFPROP SYMBOL PROPERTY INDICATOR))) 

[(OR ITS DEC10) (DEFPROP DEFINE DEFINE-MACRO MACRO)] 

[MULTICS (DEFPROP COUTPUT PUT-IN-TREE EXPR)] 

(DEFUN [(OR ITS DEC10) DEFINE-MACRO 
		       FEXPR] [MULTICS DEFINE 
				       MACRO] 
       (X)
       (PROG (FN SYN ABB UNPARSE PARSE FASLOAD) 
	     (ACCEPT-ADVICE (SETQ X (CDR X)))
	     (SETQ FN (CAR X))
	     (COND ((OR FASLOAD (CDR X))
		    (DEFINE-HAPPEN (LIST 'HOMCHECK (LIST 'QUOTE FN))))
		   ((DEFINE-HAPPEN (LIST 'OBTERN
					 (LIST 'QUOTE FN)
					 'LOGO-OBARRAY))))
	     (AND PARSE (DEFINE-PROPERTY FN PARSE 'PARSE))
	     (AND UNPARSE (DEFINE-PROPERTY FN (CAR UNPARSE) 'UNPARSE))
	     (AND FASLOAD (DEFINE-PROPERTY FN FASLOAD 'AUTOLOAD))
	     (MAPC 
	      '(LAMBDA (Y) 
		(DEFINE-HAPPEN (LIST 'HOMCHECK (LIST 'QUOTE Y)))
		(DEFINE-PROPERTY Y
				 FN
				 [MULTICS 'EXPR]
				 [(OR ITS DEC10) (COND ((MEMQ (CADR X)
							      '(FEXPR MACRO))
							'FEXPR)
						       ('EXPR))]))
	      ABB)
	     (RETURN
	      (COND
	       (SYN (DEFINE-HAPPEN (LIST 'SYNONYMIZE
					 (LIST 'QUOTE FN)
					 (LIST 'QUOTE (CAR SYN))))
		    (LIST 'QUOTE (CAR SYN)))
	       ((CDR X)
		(SETQ X (CDR X))
		(COND
		 ((EQ (CAR X) 'MACRO)
		  ((LAMBDA (COMPILED-MACRO) 
			   (DEFINE-PROPERTY FN COMPILED-MACRO 'MACRO)
			   (LIST 'DEFPROP
				 COMPILED-MACRO
				 (CONS 'LAMBDA (CDR X))
				 'FEXPR))
		   (MAKNAM
		    (APPEND
		     '(D E F I N E - M A C R O -)
		     (EXPLODEC (SETQ DEFINE-MACRO-INDEX (1+ DEFINE-MACRO-INDEX)))))))
		 ((CONS 'DEFUN (CONS FN X))))))))) 

(SETQ DEFINE-MACRO-INDEX (FIX (TIME))) 

;;*PAGE 


(COND
 ((STATUS FEATURE LLOGO))
 ;;IF NOT READ INTO LLOGO, SUPPLY MISSING FUNCTIONS.
 ((DEFUN HOMCHECK (USELESS) USELESS)
  (DEFUN OBTERN (USE LESS) USE)
  (SETQ LOGO-OBARRAY NIL)
  (DEFPROP ABB1 SYNONYMIZE EXPR)
  (DEFUN SYNONYMIZE (NEW OLD) 
	 (PUTPROP NEW
		  OLD
		  [MULTICS 'EXPR]
		  [(OR ITS DEC10) (COND ((GETL OLD '(EXPR SUBR LSUBR ARRAY))
					 'EXPR)
					((GETL OLD '(FEXPR FSUBR))
					 'FEXPR)
					((ERRBREAK 'DEFINE
						   'SYNONYM/ NOT/ FOUND)))]))
  (DEFUN ERRBREAK ARGS 
	 (PRINC (ARG 2.))
	 (TERPRI)
	 (APPLY 'BREAK (LIST (ARG 1.) T))))) 

;;*PAGE

;;;IT'S MACRO TIME! 
;;CAREFUL ABOUT USING THESE MACROS IN RANDOM FORMS, AS DEFINITIONS MAY NOT BE AROUND
;;AT RUN TIME.

(DECLARE (DEFPROP DEFINE-HAPPEN COUTPUT EXPR)) 

(DEFPROP DEFINE-HAPPEN EVAL EXPR) 

(DEFINE SAVE-VERSION-NUMBER MACRO (CALL) 
	[(OR ITS DEC10) (LIST 'DEFPROP
			      (CADR CALL)
			      (CADR (STATUS UREAD))
			      'VERSION)]
	[MULTICS (LIST 'DEFPROP
		       (CADR CALL)
		       (CADDAR (ALLFILES (LIST (CADR CALL) '*)))
		       'VERSION)]) 

(SAVE-VERSION-NUMBER DEFINE) 

(DEFINE INCREMENT MACRO (CALL) 
	(RPLACA CALL 'SETQ)
	(RPLACD CALL
		(LIST (CADR CALL)
		      (CONS (COND ((NULL (CDDR CALL)) '1+) ('+))
			    (CDR CALL))))) 

(DEFINE DECREMENT MACRO (CALL) 
	(RPLACA CALL 'SETQ)
	(RPLACD CALL
		(LIST (CADR CALL)
		      (CONS (COND ((NULL (CDDR CALL)) '1-) ('-))
			    (CDR CALL))))) 

(DEFINE LET MACRO (CALL) 
	;;SYNTACTIC SUGAR FOR LOCAL LAMBDA BINDINGS.  KEEPS BOUND VARIABLE AND BOUND
	;;VALUE LEXICALLY NEAR EACH OTHER.
	((LAMBDA (BOUND-VARIABLES BOUND-VALUES) 
		 (MAPC '(LAMBDA (VARIABLE-SPEC) 
				(COND ((ATOM VARIABLE-SPEC)
				       (PUSH VARIABLE-SPEC BOUND-VARIABLES)
				       (PUSH NIL BOUND-VALUES))
				      ((PUSH (CAR VARIABLE-SPEC) BOUND-VARIABLES)
				       (PUSH (CADR VARIABLE-SPEC) BOUND-VALUES))))
		       (CADR CALL))
		 (RPLACA CALL
			 (CONS 'LAMBDA
			       (CONS (NREVERSE BOUND-VARIABLES) (CDDR CALL))))
		 (RPLACD CALL (NREVERSE BOUND-VALUES)))
	 ;;NOTICE HOW FAR AWAY VARIABLES ARE FROM VALUES!
	 NIL
	 NIL)) 

;;MACROS TO EXPAND BIT-TWIDDLING FUNCTIONS IN TERMS OF THE BOOLE FUNCTION. 
;;PRIMARILY OF USE IN CONSTRUCTING MASKS FOR SETTING BITS IN THE TV BUFFER ARRAY.

(DEFINE BITWISE-AND MACRO (CALL) (RPLACA CALL 'BOOLE)
				 (RPLACD CALL (CONS 1. (CDR CALL)))) 

(DEFINE BITWISE-OR MACRO (CALL) (RPLACA CALL 'BOOLE)
				(RPLACD CALL (CONS 7. (CDR CALL))))

(DEFINE BITWISE-NOT MACRO (CALL) 
        (RPLACA CALL 'BOOLE)
        (RPLACD CALL (CONS 6. (CONS -1. (CDR CALL)))))

(DEFINE BITWISE-XOR MACRO (CALL) (RPLACA CALL 'BOOLE) (RPLACD CALL (CONS 6. (CDR CALL))))

(DEFINE BITWISE-ANDC MACRO (CALL) (RPLACA CALL 'BOOLE) (RPLACD CALL (CONS 2. (CDR CALL))))

(DEFINE PROG1 MACRO (CALL) 
			   ;;USEFUL FOR KEEPING A VALUE AROUND MOMENTARILY AFTER
			   ;;IT'S DESTROYED BY A SIDE EFFECT, WITHOUT CREATING
			   ;;ANOTHER VARIABLE TO HOLD IT.
			   (RPLACA CALL 'PROG2)
			   (RPLACD CALL (CONS T (CDR CALL)))) 

(DEFINE ROUND MACRO (CALL) 
        (SUBST (CADR CALL) 
               'ROUND-ME  
               ;;The ROUND-FIXNUM-VARIABLE crock is just an attempt to get the
               ;;compiler to open code the FIX. In general, FIX of a flonum may
               ;;return a BIGNUM.
               '((LAMBDA (ROUND-FIXNUM-VARIABLE) ROUND-FIXNUM-VARIABLE)
                 (FIX (+$ ROUND-ME 0.5)))))

;;(CCONS 1 2 3) = (CONS 1 (CONS 2 3))

(DEFINE CCONS MACRO (X) 
	(RPLACA X 'CONS)
	(AND (CDDDR X) (RPLACD X (LIST (CADR X) (CONS 'CCONS (CDDR X)))))
	X) 

;;REPLACES (PUSH X Y) BY (SETQ Y (CONS X Y))

(DEFINE PUSH MACRO (X) 
	(RPLACA X 'SETQ)
	(RPLACD X (LIST (CADDR X) (LIST 'CONS (CADR X) (CADDR X))))) 

;;REPLACES (POP X) BY (SETQ X (CDR X))

(DEFINE POP MACRO (X) (RPLACA X 'SETQ)
		      (RPLACD X (LIST (CADR X) (LIST 'CDR (CADR X))))) 

;;END OF MACRO DEFINITIONS AND COMPILER DECLARATIONS.  CHOOSE BETWEEN INTERPRETED
;;AND COMPILED DEFINITIONS OF DEFINE.


(DEFUN COMPILED-EXPR-FUNCTION FEXPR (CALL) 
       (RPLACA CALL 'GET)
       (RPLACD CALL (LIST (LIST 'FUNCTION (CADR CALL)) ''SUBR)))

;;EXPR-FUNCTION & EXPR-CALL EXPAND INTO SUBRCALLS OF SUBR POINTERS FOR
;;EFFICIENCY, BUT INTERPRETIVELY ARE FUNCTION & FUNCALL.

(DEFUN COMPILED-EXPR-CALL FEXPR (CALL) 
       (RPLACA CALL 'SUBRCALL)
       (RPLACD CALL (CONS NIL (CDR CALL))))

(DEFUN COMPILED-EXPR-CALL-FIXNUM FEXPR (CALL)
       (RPLACA CALL 'SUBRCALL)
       (RPLACD CALL (CONS 'FIXNUM (CDR CALL))))

(DEFUN INTERPRETIVE-EXPR-FUNCTION FEXPR (CALL)
       (LET ((EXPR-FUNCTION-PROP (GETL (CADR CALL) '(SUBR EXPR-CALL-SUBR))))
            ;;A DUMMY SUBR MAY BE PUT UNDER THE PROPERTY EXPR-CALL-SUBR FOR
            ;;THE PURPOSE OF DEBUGGING INTERPRETIVELY.
            (COND ((NULL EXPR-FUNCTION-PROP) (LIST 'FUNCTION (CADR CALL)))
                  ((LIST 'QUOTE (CADR EXPR-FUNCTION-PROP))))))

(DEFUN INTERPRETIVE-EXPR-CALL FEXPR (CALL)
       (LET ((EXPR-FUNCTION (EVAL (CADR CALL))))
            (LET ((TYPE-EXPR-FUNCTION (TYPEP EXPR-FUNCTION)))
                 (COND ((EQ TYPE-EXPR-FUNCTION 'SYMBOL) 
                        (CONS 'FUNCALL (CDR CALL)))
                       ((CONS 'SUBRCALL (CONS NIL (CDR CALL))))))))

(DEFUN INTERPRETIVE-EXPR-CALL-FIXNUM FEXPR (CALL)
       (LET ((EXPR-FUNCTION (EVAL (CADR CALL))))
            (LET ((TYPE-EXPR-FUNCTION (TYPEP EXPR-FUNCTION)))
                 (COND ((EQ TYPE-EXPR-FUNCTION 'SYMBOL) 
                        (CONS 'FUNCALL (CDR CALL)))
                       ((CONS 'SUBRCALL (CONS 'FIXNUM (CDR CALL))))))))

(COND (COMPILING (DEFPROP EXPR-FUNCTION COMPILED-EXPR-FUNCTION MACRO)
                 (DEFPROP EXPR-CALL COMPILED-EXPR-CALL MACRO)
                 (DEFPROP EXPR-CALL-FIXNUM COMPILED-EXPR-CALL-FIXNUM MACRO))
      ((DEFPROP EXPR-FUNCTION INTERPRETIVE-EXPR-FUNCTION MACRO)
       (DEFPROP EXPR-CALL INTERPRETIVE-EXPR-CALL MACRO)
       (DEFPROP EXPR-CALL-FIXNUM INTERPRETIVE-EXPR-CALL-FIXNUM MACRO)))


(COND (COMPILING (DEFPROP DEFINE-HAPPEN COUTPUT EXPR))
      ;;FOR EXTRA FORMS TO BE MADE HAPPEN BY DEFINE FUNCTION, IF COMPILING, OUTPUT
      ;;THEM TO BE DONE AT RUN TIME, IF NOT COMPILING, JUST DO THEM.
      ((DEFPROP DEFINE-HAPPEN EVAL EXPR)))

;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;				SETUP >                      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;THIS FILE CONTAINS LLOGO INITIALIZATIONS, CREATION OF OBARRAY & READTABLE, SOME
;;UTILITY FUNCTIONS. 
;;;

(SSTATUS FEATURE LLOGO) 

(DECLARE (SETQ MACROS NIL)
	 ;;MACROS = T FROM DEFINE FILE.
	 (OR (STATUS FEATURE DEFINE)
	     (COND ((STATUS FEATURE ITS)
		    ;;MULTICS?
		    (FASLOAD DEFINE FASL AI LLOGO))))) 

;;FOR DEFINING NEW LLOGO PRIMITIVES, DEFINE IS DEFINED TO AUTOLOAD IN FILE
;;LLOGO;DEFINE FASL, CONTAINING A FEXPR DEFININTION OF DEFINE, PUSH, POP AND OTHER
;;ASSORTED MACROS, ALONG WITH SQUARE BRACKET AND DOUBLE QUOTE READMACROS.
;;;
;;NOTE: DEFINE MAY ONLY BE CALLED FROM LISP, NOT LOGO!
;;;

[ITS (OR (STATUS FEATURE DEFINE) (DEFPROP DEFINE (DEFINE FASL AI LLOGO) AUTOLOAD))] 

(SETQ GENSYM (GENSYM) 
      LISP-READTABLE READTABLE 
      LISPREADTABLE LISP-READTABLE 
      LOGO-READTABLE (GET [(OR ITS DEC10) (*ARRAY 'LOGO-READTABLE
						  'READTABLE)]
			  ;;MULTICS INCOMPATABILITY.
			  [MULTICS (MAKREADTABLE 'LOGO-READTABLE)]
			  'ARRAY) 
      LOGOREADTABLE LOGO-READTABLE 
      CAR T 
      CDR T 
      NO-VALUE '?) 

;;THIS PAGE SHOULD APPEAR BEFORE THE LOGO OBARRAY IS CREATED TO AVOID UNEXPECTED
;;ATOMS BEING INTERNED ON THE LISP OBARRAY BEFORE THE LOGO OBARRAY IS CREATED FROM
;;IT.  THE FOLLOWING IS A LIST OF ATOMS THAT ARE TO BE PUT ON BOTH OBARRAYS FOR
;;CONVENIENCE.  THE DUMMY MEMQ IS AN ATTEMPT TO FOOL FASLAP TO NOT THROW AWAY THE
;;LIST BEFORE READING IT.

(MEMQ NIL
      '(! /" $ /
 /  /' /( /) /; / : :PARENBALANCE :BURIED :CAREFUL :COMPILED :CONTENTS :DSCALE
	:ECHOLINES :EDITMODE :EMPTY :EMPTY :EMPTYS :EMPTYW :ERRBREAK :HEADING
	:INFIX :LISPBREAK :NAMES :NAMES :PAGE :PI :PICTURE :POLYGON :REDEFINE
	:SCREENSIZE :SHOW :SNAPS :SNAPS :TEXT :TEXTXHOME :TEXTYHOME :TSIZE :TURTLE
	:WINDOWS :WRAP :XCOR :YCOR ABB ABBREVIATION ABBREVIATIONS ABBS ALL ARG
	ARGPDL BOTH BYE COMPILED CONTENTS DOWN EDITTITLE ELSE ENTRY ENTRYCOND
	ERRBREAK EXITCOND F FALSE FASL FASL FILE GT40 HOMCHECK INDEX LEFT LINE
	LISPBREAK N NAMES NO PI-OVER-180 PARSE PARSEMACRO PRIM PRIMITIVE
	PRIMITIVES PROCEDURES READOB REMGRIND REMTRACE RIGHT SNAPS SQUARE-BRACKETS
	T34 TESTFLAG THEN TITLE TITLES TRUE UNITE UNTRACE USER-PAREN VALUE WHEREIN
	WINDOW WINDOWS WRONG Y YES /[ /] _)) 

;;SHARP-SIGN ["#"] IS MADE AN IMMEDIATE READ MACRO WHICH DOES THE NEXT READ ON THE
;;LISP OBARRAY IF PERFORMED FROM LOGO, OR LOGO OBARRAY IF DONE FROM LISP.  LISP
;;READTABLE IS ALWAYS USED. 

(DEFUN OBSWITCH NIL 
       (COND ((EQ OBARRAY LOGO-OBARRAY)
	      ((LAMBDA (OBARRAY READTABLE) (READ)) LISP-OBARRAY LISP-READTABLE))
	     (((LAMBDA (OBARRAY READTABLE) (READ)) LOGO-OBARRAY LISP-READTABLE)))) 

(COND ((GET 'LOGO-OBARRAY 'ARRAY)
       '"OBARRAYS ALREADY ESTABLISHED")
      ((PUTPROP 'LISP-OBARRAY (SETQ LISP-OBARRAY OBARRAY) 'ARRAY)
       (SET [(OR ITS DEC10) (*ARRAY 'LOGO-OBARRAY 'OBARRAY)]
	    ;;MULTICS IS BEHIND THE TIMES.
	    [MULTICS (MAKOBLIST 'LOGO-OBARRAY)]
	    (GET 'LOGO-OBARRAY 'ARRAY))
       (SETSYNTAX 35. 'MACRO 'OBSWITCH)
       [(OR ITS DEC10) (SETSYNTAX 35. 198656. NIL)]
       ((LAMBDA (READTABLE) 
		(SETSYNTAX 35. 'MACRO 'OBSWITCH)
		[(OR ITS DEC10) (SETSYNTAX 35. 198656. NIL)])
	LOGO-READTABLE))) 

;;198656.  = OCTAL 604000, STANDARD MACRO SYNTAX IS 404500; 600000 BIT MAKES A
;;SINGLE CHARACTER OBJECT.

[ITS (SETQ LISP-OBDIM (CADR (ARRAYDIMS 'OBARRAY)) 
	   LISP-OBDIM (COND ((ODDP LISP-OBDIM) LISP-OBDIM) ((- LISP-OBDIM 129.))))] 

;;;DIMENSION OF LISP OBARRAY, USED BY KNOWNP.
;;A KLUDGE HERE IS THAT IN SOME VERSIONS OF LISP, THE DIMENSION OF THE OBARRAY IS
;;THE RIGHT NUMBER TO USE, IN OTHERS IT IS THAT NUMBER LESS 129.
;;*PAGE


(SAVE-VERSION-NUMBER SETUP) 

;;*PAGE 

;;;		UTILITY FUNCTIONS
;;;
;;FIRST ARG IS MESSAGE TO BE PRINTED OUT, FOLLOWED BY FILE NAMES TO BE FASLOADED IN
;;IF USER GIVES ASSENT.

(DEFUN LOAD-IF-WANTED FEXPR (MESSAGE-FILES) 
       (PRINC (CAR MESSAGE-FILES))
       (AND (ASK)
	    (LET ((OBARRAY LISP-OBARRAY))
		 (MAPC '(LAMBDA (FILE) 
				[(OR ITS DEC10) (APPLY 'FASLOAD FILE)]
				[MULTICS (LOAD FILE)])
		       (CDR MESSAGE-FILES))))) 

;;ARGS ARE PUT TOGETHER AND MAKE ONE ATOM.  USED BY COMPILE FUNCTION.

(DEFUN ATOMIZE ARGS (MAKNAM (MAPCAN 'EXPLODEC (LISTIFY ARGS)))) 

;;FILLS IN DEFAULTS FOR FILE COMMANDS. 

(DEFUN FILESPEC (X) 
       (OR (APPLY 'AND (MAPCAR 'ATOM X))
	   (SETQ X
		 (ERRBREAK 'FILESPEC
			   (LIST X
				 '"IS NOT A FILE NAME"))))
       (COND ((NULL X) (APPEND (STATUS CRFILE) (CRUNIT)))
	     ((NOT (CDR X))
	      (APPEND X
		      '([ITS >]
			[DEC10 LGO]
			[MULTICS LOGO])
		      (CRUNIT)))
	     ((NOT (CDDR X)) (APPEND X (CRUNIT)))
	     [(OR ITS DEC10) ((NOT (CDDDR X))
			      (APPEND (LIST (CAR X) (CADR X))
				      '(DSK)
				      (CDDR X))) 
			     (X)]
	     [MULTICS ((LIST (CAR X)
			     (CADR X)
			     'DSK
			     (APPLY 'ATOMIZE
				    (COND ((EQ (CADDR X) 'DSK) (CDDDR X))
					  ((CDDR X))))))])) 

;;RETURNS LAMBDA DEF OF FN.  IGNORES TRACE.

(DEFUN TRACED? (FNNAME) 
       (PROG (TRACED DEF) 
	     (SETQ DEF (GETL FNNAME '(EXPR)))
	     (RETURN (COND ((SETQ TRACED (GETL (CDR DEF) '(EXPR)))
			    (DPRINC '";TRACED")
			    (DTERPRI)
			    (SETQ DEF (CADR TRACED)))
			   ((SETQ DEF (CADR DEF))))))) 

;;PREDICATE FOR WHETHER FN X IS CURRENTLY TRACED.  DOES NOT ERR IF TRACE PACKAGE IS
;;NOT PRESENT.

(DEFUN TRACE? (X) (AND (STATUS FEATURE TRACE) (MEMQ X (TRACE)))) 

;;UNTRACES X.  DOES NOT ERR IF TRACE PACKAGE NOT PRESENT.

(DEFUN UNTRACE1 (X) (AND (TRACE? X) (APPLY 'UNTRACE (LIST X)))) 

;;*PAGE


(DEFUN FUNCTION-PROP (ATOM) 
       (GETL ATOM '(EXPR FEXPR MACRO SUBR LSUBR FSUBR ARRAY))) 

;;THE SUBSET SUB IS SUBTRACED FROM SET.

(DEFUN SET- (SET SUB) 
       (DO ((REMOVE-ELEMENTS SUB (CDR REMOVE-ELEMENTS)))
	   ((NULL REMOVE-ELEMENTS) SET)
	   (SETQ SET (DELQ (CAR REMOVE-ELEMENTS) SET)))) 

;;NON-DESTRUCTIVE VERSION OF SET-.

(DEFUN DELEET (SET OTHER-SET) 
       (COND ((NULL SET) NIL)
	     ((MEMBER (CAR SET) OTHER-SET) (DELEET (CDR SET) OTHER-SET))
	     ((CONS (CAR SET) (DELEET (CDR SET) OTHER-SET))))) 

;;PRINTS LIST WITHOUT CONSING.  EG (WRITELIST 'SETQ 'X '/( 'CONS '/' A '/)).  NOTE
;;THAT EMBEDDED PARENS MUST BE QUOTED.  PRIN1 IS USED EXCEPT ON /(, /) AND /'.

(DEFUN WRITELIST ARGS 
       (PRINC '/()
       (DO ((I 1. (1+ I)) (P 0.))
	   ((> I ARGS)
	    (COND ((= P 0.) (PRINC '/)))
		  ((ERRBREAK 'WRITELIST
			     '" - UNBALANCED PARENTHESES"))))
	   (COND ((EQ (ARG I) '/') (PRINC '/'))
		 ((EQ (ARG I) '/() (INCREMENT P) (PRINC '/())
		 ((EQ (ARG I) '/)) (DECREMENT P) (PRINC '/)))
		 ((PRIN1 (ARG I)) (TYO 32.))))) 

;;PUSHS X ONTO LIST IF X NOT ALREADY PRESENT

(DEFUN UNITE (X LIST) 
       (LET ((UNITE-WITH (SYMEVAL LIST)))
	    (OR (MEMQ X UNITE-WITH) (SET LIST (CONS X UNITE-WITH))))
       NO-VALUE) 

;;*PAGE


(SETQ :CAREFUL T 
      ;;LIST OF COMPILED USER FUNCTIONS.
      :COMPILED NIL 
      ;;LIST OF INTERPRETIVE USER FUNCTIONS.
      :CONTENTS NIL 
      ;;LIST OF BURIED USER FUNCTIONS.
      :BURIED NIL 
      ;;LIST OF USER VARIABLES.
      :NAMES NIL 
      ;;SWITCH TO REGULATE CHECKING FOR LISP/LOGO HOMONYMS.
      HOMCHECK T) 

;;CHECKS FOR LISP/LOGO HOMONYMS.  PREVENTS OBSCURE SCREWS WHEN DEFINING NEW LOGO
;;PRIMITIVES.

(DEFUN HOMCHECK (ATOM) 
       (AND HOMCHECK
	    (IOG NIL
		 (COND ((FUNCTION-PROP ATOM)
			(PRINC (LIST '"
WARNING.."			     ATOM
				     '" HAS PROPERTY LIST "
				     (CDR ATOM)))))))
       (OBTERN ATOM LOGO-OBARRAY)) 

;;FOR LOGO FUNCTIONS WITH DIFFERENT NAMES THAN LISP FUNCTIONS WHICH PERFORM
;;IDENTICAL TASKS.

(DEFUN SYNONYMIZE (SYNONYM GOLDEN-OLDIE) 
       (LET
	((SYNPROP (FUNCTION-PROP GOLDEN-OLDIE)))
	(COND
	 (SYNPROP (PUTPROP SYNONYM (CADR SYNPROP) (CAR SYNPROP))
		  [(OR ITS DEC10) (AND (SETQ SYNPROP (ARGS GOLDEN-OLDIE))
				       (ARGS SYNONYM SYNPROP))]
		  (AND (SETQ SYNPROP (GET GOLDEN-OLDIE 'PARSE))
		       [CLOGO (OR (ATOM (CAR SYNPROP))
				  ;;;JOIN SHOULD NOT GET PARSE-CLOGO-HOMONYM
				  ;;PROPERTY OF LIST.
				  (NOT (EQ (CAAR SYNPROP)
					   'PARSE-CLOGO-HOMONYM)))]
		       (PUTPROP SYNONYM SYNPROP 'PARSE)))
	 ((ERRBREAK 'DEFINE
		    (LIST GOLDEN-OLDIE
			  '" -SYNONYM OF "
			  SYNONYM
			  '" NOT FOUND")))))) 

;;*PAGE

;;IF ATOM IS NOT ALREADY PRESENT ON THE OBARRAY OB, IT IS INTERNED.  ELSE USER IS
;;ASKED IF HE WANTS TO SUBSTITUTE IT.

(DEFUN OBTERN (ATOM OB) 
       (PROG (OBATOM) 
	     (LET
	      ((OBARRAY OB))
	      (COND
	       ((EQ ATOM (SETQ OBATOM (INTERN ATOM))) (RETURN ATOM))
	       ([(OR ITS MULTICS) (CDR OBATOM)]
		[DEC10 (AND (> (LENGTH OBATOM) 2.)
			    (OR (BOUNDP OBATOM)
				(NOT (EQ (CADR OBATOM) 'VALUE))))]
		(IOG
		 NIL
		 (PRINT OBATOM)
		 (PRINC '" HAS PROPERTY LIST ")
		 (PRINT (CDR OBATOM))
		 (PRINC
		  '"
DO YOU WANT TO GET RID OF IT? ")
		 (AND (MEMQ (READ) '(NO N NIL F FALSE WRONG NOPE))
		      (RETURN NIL)))))
	      (REMOB OBATOM)
	      (RETURN (INTERN ATOM))))) 

;;EXPR-FUNCTION AND EXPR-CALL ARE FUNCTION AND FUNCALL, EXCEPT THAT WHEN COMPILING
;;THEY ARE REPLACED BY SPEEDIER SUBRCALL FOR EFFICIENCY.

(DEFINE EXPR-FUNCTION (SYN FUNCTION)) 

(DEFINE EXPR-CALL (SYN FUNCALL)) 

(DEFINE EXPR-CALL-FIXNUM (SYN FUNCALL))

;;*PAGE

;;;
;;;
;;;		ABBREVIATIONS
;;;
;; ABBREVIATIONS ARE ACCOMPLISHED BY PUTTING THE NAME OF THE FUNCTION TO BE
;;ABBREVIATED ON THE ABBREVIATION'S PROPERTY LIST UNDER EXPR OR FEXPR INDICATORS AS
;;APPROPRIATE.  IF CALLED DIRECTLY AS A FUNCTION, THE ABBREVIATION WILL HAVE THE
;;SAME AFFECT AS THE ABBREVIATED FUNCTION. 
;;;
;; CURRENTLY ON MULTICS, ALL ABBREVIATIONS MUST BE DONE WITH EXPR PROPERTIES AND NOT
;;FEXPR PROPERTIES.  CONDITIONAL CODE WHICH HANDLES THIS INCOMPATIBILITY SHOULD
;;SOMEDAY BE REMOVED WHEN IT IS FIXED.  THERE IS ALSO CONDITIONAL CODE IN DEFINE FOR
;;THIS PURPOSE.
;;;
;;ABBREVIATES EVEN IF NEW HAS A FN PROP.

(DEFUN ABB1 (NEW OLD) 
       (PUTPROP
	NEW
	OLD
	[MULTICS 'EXPR]
	[(OR ITS DEC10) (LET
			 ((FPROP (CAR (FUNCTION-PROP OLD))))
			 (COND
			  ((MEMQ FPROP '(EXPR SUBR LSUBR)) 'EXPR)
			  ((MEMQ FPROP '(FEXPR FSUBR MACRO)) 'FEXPR)
			  ((ERRBREAK
			    'ABBREVIATE
			    (LIST
			     OLD
			     '"CAN'T BE ABBREVIATED BECAUSE IT DOESN'T HAVE A DEFINITION")))))])
       [(OR ITS DEC10) (AND (ARGS OLD) (ARGS NEW (ARGS OLD)))]
       (AND (GET OLD 'PARSE)
	    (PUTPROP NEW (GET OLD 'PARSE) 'PARSE))
       (LIST '/; OLD '" ABBREVIATED BY " NEW)) 

(DEFINE ABBREVIATE (ABB AB) (NEW OLD) 
 (AND (PRIMITIVEP NEW)
      (SETQ NEW (ERRBREAK 'ABBREVIATE
			  (LIST NEW
				'"IS USED BY LOGO"))))
 (OR
  (SYMBOLP NEW)
  (SETQ 
   NEW
   (ERRBREAK 'ABBREVIATE
	     (LIST NEW
		   '" IS NOT A VALID PROCEDURE NAME"))))
 (AND
  (EQ (GETCHAR NEW 1.) ':)
  (SETQ 
   NEW
   (ERRBREAK
    'ABBREVIATE
    (LIST
     NEW
     '" LOOKS LIKE A VARIABLE NAME- NOT A VALID PROCEDURE NAME"))))
 (AND (OR (MEMQ NEW :CONTENTS) (MEMQ NEW :COMPILED))
      (SETQ NEW (ERRBREAK 'ABBREVIATE
			  (LIST NEW
				'"IS ALREADY DEFINED."))))
 (OR (PRIMITIVEP OLD) (SETQ OLD (PROCEDUREP 'ABBREVIATE OLD)))
 (ABB1 NEW OLD)
 (LIST '/; OLD '"ABBREVIATED BY" NEW)) 

;;OLD MUST BE A LISP LOGO PRIMITIVE OR A USER FUNCTION.

[ITS (DEFINE ALLOCATOR NIL 
      (OR
       (COND
	((= TTY 5.)
	 ;;TTY=5 IFF USER IS AT A TV TERMINAL.
	 (LOAD-IF-WANTED
	  "DO YOU WANT TO USE THE TV TURTLE? "
	  (TVRTLE FASL DSK LLOGO)))
	((LOAD-IF-WANTED
	  "DO YOU WANT TO USE THE DISPLAY TURTLE? "
	  (TURTLE FASL DSK LLOGO))
	 (TYPE
	  '"DO YOU WANT TO USE THE GT40 RATHER THAN THE 340?")
	 (SETQ DEFAULT-TURTLE (COND ((ASK) 'GT40) (340.)))))
       (LOAD-IF-WANTED GERMLAND? (GERM FASL DSK LLOGO))
       (LOAD-IF-WANTED "MUSIC BOX? " (MUSIC FASL DSK LLOGO))))] 

[MULTICS (DEFINE ALLOCATOR NIL 
	  (LOAD-IF-WANTED
	   "DO YOU WANT TO USE THE MUSIC BOX? "
	   ">UDD>AP>LIB>LOGO_MUSIC"))] 

;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;              LISP LOGO READER                            ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(DECLARE (OR (STATUS FEATURE DEFINE)
	     (COND ((STATUS FEATURE ITS)
		    ;;MULTICS?
		    (FASLOAD DEFINE FASL AI LLOGO))))) 

;;; 
;;READ SYNTAX FOR LOGO, LOGO READER, EVALUATION FUNCTIONS

(SAVE-VERSION-NUMBER READER) 

(DECLARE (GENPREFIX READER)) 

;;NEITHER IN LISP NOR LOGO MODE ARE CR'S INSERTED.

(SSTATUS TERPRI T) 

;;;            LOGO READTABLE
;;;

((LAMBDA (READTABLE) (SETSYNTAX 39. 'MACRO NIL)
		     (SETSYNTAX 59. 'MACRO NIL)
		     ;;TURN OFF LISP'S SINGLE QUOTE, EXCL, AND SEMICOLON MACROS. 
		     ;;SINGLE-QUOTE HANDLED BY PASS2, SEMICOLON BY PARSER.
		     (SETSYNTAX 33. 'MACRO NIL)
		     (SETSYNTAX 34. 'MACRO NIL)
		     (SETSYNTAX 91. 'MACRO NIL)
		     (SETSYNTAX 93. 'MACRO NIL)
		     ;;TURN OFF LLOGO'S DOUBLE-QUOTE, SQUARE-BRACKET MACROS.
		     [CLOGO (SETSYNTAX 20. 'SINGLE 34.)]
		     ;;CONTROL-T CHANGED TO DOUBLE-QUOTE ON READ-IN FOR COMPATIBLITY
		     ;;WITH CLOGO. 
		     (SETSYNTAX 44. 2. NIL)
		     ;;COMMA IS EXTENDED ALPHABETIC. 
		     (SETSYNTAX 46. 128. NIL)
		     ;;PERIOD IS DECIMAL POINT ONLY, NOT CONS DOT.  LOGO EDITING
		     ;;CHARACTERS: MADE SINGLE CHARACTER OBJECTS, BUT ALSO MUST BE
		     ;;"TTY FORCE FEED" CHARACTERS TO TAKE IMMEDIATE EFFECT.
		     ;;; 197472. = OCTAL 601540 [600000 = S.C.O., 1040 = T.F.F.,
		     ;;;                             500 = SLASHIFY.]
		     ;;;
		     ;;EDITING CHARACTERS -- CONTROL-E, CONTROL-P, CONTROL-R,
		     ;;CONTROL-S.
		     [(OR ITS DEC10) (SETSYNTAX 5. 197472. NIL) 
				     (SETSYNTAX 16. 197472. NIL) 
				     (SETSYNTAX 18. 197472. NIL) 
				     (SETSYNTAX 19. 197472. NIL)]
		     ;;;
		     (MAPC '(LAMBDA (CHARACTER) (SETSYNTAX CHARACTER 'SINGLE NIL))
			   ;;MULTICS "NEWLINE" IS CONTROL-J [ASCII 10.]
			   '([MULTICS 10.]
			     [(OR ITS DEC10) 11. 
					     12. 
					     13.] [CLOGO 20.] 32. 33. 34. 36. 38.
			     39. 40. 41. 42. 43. 45. 47. 59. 60. 61. 62. 91. 92.
			     93. 94. 95. 127.))
		     ;;;DON'T PRINT EXTRA CARRAIGE RETURNS ON LINE OVERFLOW.
		     (SSTATUS TERPRI T))
 LOGO-READTABLE) 

;;; SINGLE CHARACTER OBJECTS IN LOGO ARE:
;;;	CONTROL-J <LINEFEED, IN MULTICS ONLY>, CONTROL-K <NOT IN MULTICS>, 
;;;     CONTROL-L <NOT IN MULTICS>, CONTROL-M <CARRAIGE RETURN, NOT IN MULTICS>, 
;;;     CONTROL-T, SPACE, DOUBLE-QUOTE, DOLLAR, AMPERSAND, QUOTE, LEFT-PAREN,
;;;	RIGHT-PAREN, STAR, PLUS, MINUS, SLASH, SEMICOLON, LESS, EQUAL, GREATER,
;;;	LEFT-BRACKET, BACKSLASH, RIGHT-BRACKET, UP-ARROW, UNDERSCORE, RUBOUT.
;;;		TTY ACTIVATION CHARACTERS
;;;
;;ON ITS, YOUR PROCESS ONLY WAKES UP WHEN ONE OF A GROUP OF "ACTIVATION CHARACTERS"
;;IS READ.  THESE CHARACTERS ARE DIFFERENT FOR LOGO THAN FOR LISP.

[ITS (DEFUN ACTIVATE-LISP NIL 
	    ;;LISP WAKES ON SPACE, BACKSPACE, PARENS, BRACKETS, BRACES, LF, TAB
	    ;;INTERRUPTS ON CONTROL CHARS.
	    (SSTATUS TTY 20673790994. 20707344539.)) 
     (DEFUN ACTIVATE-LOGO NIL 
	    ;;LOGO ACTIVATES ON RUBOUT, CR, SPACE, BACKSPACE, INTERRUPTS ON CONTROL
	    ;;CHARS.  SPACE NEEDED FOR GERMLAND REPEAT.
	    (SSTATUS TTY 20673790992. 20673798299.)) 
     (DEFUN RESTORE-TTY-AND-POP-ERRLIST (TTYST1 TTYST2) 
	    (APPLY 'SSTATUS (LIST 'TTY TTYST1 TTYST2))
	    (POP ERRLIST)) 
     (DEFUN BIND-ACTIVATE-LOGO NIL 
	    (LET ((OLD-TTY (STATUS TTY)))
		 (PUSH (LIST 'RESTORE-TTY-AND-POP-ERRLIST
			     (CAR OLD-TTY)
			     (CADR OLD-TTY))
		       ERRLIST))
	    (ACTIVATE-LOGO)) 
     (DEFUN BIND-ACTIVATE-LISP NIL 
	    (LET ((OLD-TTY (STATUS TTY)))
		 (PUSH (LIST 'RESTORE-TTY-AND-POP-ERRLIST
			     (CAR OLD-TTY)
			     (CADR OLD-TTY))
		       ERRLIST))
	    (ACTIVATE-LISP)) 
     (DEFUN UNBIND-ACTIVATE NIL (EVAL (CAR ERRLIST)))] 

(DEFINE LISP NIL 
		 ;;SWITCHES TO LISP MODE OF LISP-LOGO.
		 [ITS (ACTIVATE-LISP)]
		 (SSTATUS TOPLEVEL NIL)
		 (THROW '* EXIT-LOGO-TOPLEVEL)) 

;;;OBARRAY AND READTABLE UNBOUND BY EXITING TOPLEVEL.
;;;

(DEFUN LOGO NIL 
       [ITS (ACTIVATE-LOGO)]
       (SSTATUS TOPLEVEL '(TOP-LEVEL))) 

;;*PAGE

;;EVALUATION

(SETQ PROMPTER NO-VALUE LOGOREAD NIL) 

(DEFINE HISTORY (N) 
	(SETQ :HISTORY N THIS-FORM-INDEX 0. THIS-VALUE-INDEX 0. THIS-LINE-INDEX 0.)
	(ARRAY FORM-HISTORY T :HISTORY)
	(ARRAY LINE-HISTORY T :HISTORY)
	(ARRAY VALUE-HISTORY T :HISTORY)) 

(HISTORY 5.) 

(DEFINE LASTLINE (ABB ILINE) ARGS 
	(LET ((LINE-INDEX (COND ((ZEROP ARGS) 1.) ((ARG 1.)))))
	     (AND (MINUSP (SETQ LINE-INDEX (- THIS-LINE-INDEX LINE-INDEX)))
		  (INCREMENT LINE-INDEX :HISTORY))
	     (LINE-HISTORY LINE-INDEX))) 

[(OR ITS DEC10) (ARGS 'LASTLINE '(0. . 1.))] 

(DEFINE LASTFORM ARGS 
	(LET ((FORM-INDEX (COND ((ZEROP ARGS) 1.) ((ARG 1.)))))
	     (AND (MINUSP (SETQ FORM-INDEX (- THIS-FORM-INDEX FORM-INDEX)))
		  (INCREMENT FORM-INDEX :HISTORY))
	     (FORM-HISTORY FORM-INDEX))) 

[(OR ITS DEC10) (ARGS 'LASTFORM '(0. . 1.))] 

(DEFINE LASTVALUE ARGS 
	(LET ((VALUE-INDEX (COND ((ZEROP ARGS) 1.) ((ARG 1.)))))
	     (AND (MINUSP (SETQ VALUE-INDEX (- THIS-VALUE-INDEX VALUE-INDEX)))
		  (INCREMENT VALUE-INDEX :HISTORY))
	     (VALUE-HISTORY VALUE-INDEX))) 

[(OR ITS DEC10) (ARGS 'LASTVALUE '(0. . 1.))] 

(DEFINE THISFORM NIL (LASTFORM 0.)) 

(DEFINE THISLINE NIL (LASTLINE 0.)) 

(DEFUN TOP-LEVEL NIL 
       (TERPRI)
       (DPRINC PROMPTER)
       (CATCH (LET ((OBARRAY LOGO-OBARRAY) (READTABLE LOGO-READTABLE) (LOGOVALUE))
		   (DO ((LOGOREAD (LOGOREAD) (AND (DPRINC PROMPTER) (LOGOREAD))))
		       (NIL)
		       (AND (= (INCREMENT THIS-LINE-INDEX) :HISTORY)
			    (SETQ THIS-LINE-INDEX 0.))
		       (STORE (LINE-HISTORY THIS-LINE-INDEX) PASS2-LINE)
		       (MAPC 
			'(LAMBDA (LOGO-FORM) 
				 (AND (= (INCREMENT THIS-FORM-INDEX) :HISTORY)
				      (SETQ THIS-FORM-INDEX 0.))
				 (STORE (FORM-HISTORY THIS-FORM-INDEX) LOGO-FORM)
				 (AND (= (INCREMENT THIS-VALUE-INDEX) :HISTORY)
				      (SETQ THIS-VALUE-INDEX 0.))
				 (STORE (VALUE-HISTORY THIS-VALUE-INDEX)
					(SETQ LOGOVALUE (EVAL LOGO-FORM))))
			LOGOREAD)
		       (COND (LISPPRINT (DPRINT LOGOVALUE) (DTERPRI))
			     ((EQ LOGOVALUE NO-VALUE))
			     ((TYPE LOGOVALUE EOL)))))
	      EXIT-LOGO-TOPLEVEL)) 

;;TO SIMULATE LOGO FUNCTIONS WHICH DO NOT RETURN A VALUE [SINCE IN LISP EVERY FORM
;;RETURNS A VALUE] FORMS WHICH RETURN NO-VALUE DO NOT HAVE THEIR VALUES PRINTED BY
;;THE TOP LEVEL FUNCTION.  NOTE THAT LLOGO CANNOT CATCH THE ERROR OF SUCH A FORM
;;OCCURING INSIDE PARENTHESES.  FUNCTIONS RETURNING ? CAUSES TOPLEVEL TO PRINT
;;SINGLE CR BEFOR PROMPTER.  FNS RETURNING CR CAUSES TOPLEVEL TO PRINT DOUBLE CR
;;BEFORE PROPTER.  FNS RETURNING NO-VALUE CAUSE TOPLEVEL TO PRINT NO CR'S BEFORE
;;PROMPTER.

(SETQ ? (ASCII 0.)) 

;;*PAGE

;;			LOGO READER

(SETQ EOF (LIST NIL)) 

(SETQ CONTROL-K (OBTERN (ASCII 11.) LOGO-OBARRAY) 
      CONTROL-L (OBTERN (ASCII 12.) LOGO-OBARRAY) 
      CTRL-E (OBTERN (ASCII 5.) LOGO-OBARRAY) 
      CTRL-P (OBTERN (ASCII 16.) LOGO-OBARRAY) 
      CTRL-R (OBTERN (ASCII 18.) LOGO-OBARRAY) 
      CTRL-S (OBTERN (ASCII 19.) LOGO-OBARRAY)) 

[(OR DEC10 ITS) (SETQ EOL (ASCII 13.))] 

[MULTICS (SETQ EOL (ASCII 10.))] 

;;LOGO READ FUNCTION.  RETURNS A LIST OF STUFF READ BETWEEN CARRIAGE RETURNS. 
;;EVENTUALLY, MUCH OF THIS KLUDGY CODE SHOULD BE FLUSHED, IN FAVOR OF UTILIZING
;;LISP'S (SSTATUS LINMODE T) FEATURE.  HOWEVER, THERE IS A PROBLEM WITH GETTING THE
;;EDITING CONTROL CHARACTERS TO WORK CORRECTLY IN THIS MODE.
;;;
;;LOOKS AHEAD TO SEE IF FIRST CHARACTER OF LINE IS #.  IF SO, RETURNS LISP-STYLE
;;READ WITHOUT ANY PROCESSING.  WILL NOT DO SO IF FIRST CHARACTER IS SPACE, ETC.

(SETQ NULL-LINE (LIST (LIST 'QUOTE NO-VALUE))) 

(DEFUN LOGOREAD ARGS 
       (COND ((= ARGS 0.)
	      (LET ((TYIPEEKED (TYIPEEK T)))
		   (COND ((= TYIPEEKED 35.)
			  (SETQ LISPPRINT T)
			  (OR (ERRSET (READ EOF)) NULL-LINE))
			 ((= TYIPEEKED 3.) (SETQ ^Q NIL) EOF)
			 (T (SETQ LISPPRINT NIL) (PARSELINE (LINE NIL))))))
	     (T (SETQ LISPPRINT NIL) (PARSELINE (LINE (ARG 1.)))))) 

[(OR ITS DEC10) (ARGS 'LOGOREAD '(0. . 1.))] 

;;SYNTAX CATEGORIES TO DECIDE WHEN TO MERGE CHARACTERS INTO AN ATOM NAME AFTER
;;RUBOUT IS TYPED (SEE LINE).

(SETQ MERGESTATUS '(1. 2. 128. 260.)) 

;;RETURNS LIST OF SYMBOLS READ UP TO CR.

(DEFUN LINE (LINE) 
       (PROG (WORD C) 
	     [(OR ITS DEC10) (AND LINE
				  (SETQ C (NREVERSE (EXPLODEC (CAR LINE))))
				  ;;INITIALIZE RUBOUT VARIABLE.
				  (POP LINE))]
	READ (SETQ WORD (READ EOF))
	     [(OR ITS DEC10) (COND
			      ((OR (EQ WORD CONTROL-L) (EQ WORD CONTROL-K))
			       (AND ^Q (GO READ))
			       [ITS (AND 
					 ;;PROCESS ^L CLEAR SCREEN IF TYPING AT
					 ;;DATAPOINT.
					 (EQ WORD CONTROL-L)
					 (MEMBER TTY '(1. 2. 3. 5.))
					 (CURSORPOS 'C))]
			       (AND (EQ WORD CONTROL-K)
				    ;;^K => RETYPE LINE
				    (TERPRI))
			       (DPRINC PROMPTER)
			       (MAPC 'DPRINC (REVERSE LINE))
			       (MAPC 'DPRINC (REVERSE C))
			       (OR C
				   (AND LINE
					(SETQ C (NREVERSE (EXPLODEC (CAR LINE))))
					;;SET C SO THAT ^L,^K ARE NOT ATOM BREAKS
					(POP LINE)))
			       (DECREMENT CHRCT)
			       (GO READ))
			      ((EQ WORD CTRL-E) (CONTROL-N) (GO READ))
			      ;;CHECK FOR EDITING CHARS
			      ((EQ WORD CTRL-P) (CONTROL-P) (GO READ))
			      ((EQ WORD CTRL-R) (CONTROL-R) (GO READ))
			      ((EQ WORD CTRL-S) (CONTROL-S) (GO READ))) 
			     R 
			     (COND
			      ((EQ WORD '/)
			       ;;RUBOUT
			       (COND (C)
				     ((AND LINE (EQ (CAR LINE) '$))
				      ;;RUBBING OUT STRING?
				      (COND [ITS ((MEMBER TTY '(1. 2. 3. 5.))
						  (CURSORPOS 'X)
						  (INCREMENT CHRCT 3.))]
					    ((DPRINC '$)))
				      (POP LINE)
				      (INSTRING)
				      (GO READ))
				     (LINE 
					   ;;GET CHARS TO BE RUBBED
					   (SETQ C (NREVERSE (EXPLODEC (CAR LINE))))
					   (POP LINE))
				     ;;RUBOUT PAST THE BEGINNING OF LINE.
				     (T (TERPRI) (PRINC PROMPTER) (GO READ)))
			       ;;EMPTY, FORGET IT
			       (COND 
				     ;;ON DISPLAY COMSOLES, BACKSPACE AND CLEAR TO
				     ;;END OF LINE.  LOSES ON IMLACS.  THIS HACK
				     ;;DOES NOT WORK FOR RUBOUT PAST BEGINNING OF
				     ;;LINE.
				     [ITS ((MEMBER TTY '(1. 2. 3. 5.))
					   (CURSORPOS 'X)
					   (INCREMENT CHRCT 3.))]
				     ((DPRINC (CAR C))))
			       (COND ((POP C))
				     (LINE (SETQ C (NREVERSE (EXPLODEC (CAR LINE))))
					   (POP LINE)))
			       (GO READ))) 
			     (COND
			      (C
			       ;;MERGE AFTER RUBOUT
			       (COND ((AND (OR (NUMBERP WORD)
					       (MEMBER 
						(STATUS SYNTAX (GETCHARN WORD 1.))
						MERGESTATUS))
					   (OR (NUMBERP (CAR C))
					       (MEMBER 
						(STATUS SYNTAX (GETCHARN (CAR C) 1.))
						MERGESTATUS)))
				      (SETQ WORD
					    (READLIST (NCONC (NREVERSE C)
							     (EXPLODEC WORD)))))
				     ((PUSH (READLIST (NREVERSE C)) LINE)))
			       (SETQ C NIL)))]
	     (COND ((EQ EOL WORD)
		    ;;IF LINE IS COMING IN FROM A FILE, PRINT SOURCE WHEN IN CAREFUL
		    ;;MODE.		
		    (SETQ OLD-LINE (NREVERSE LINE))
		    (SETQ PASS2-LINE (PASS2 OLD-LINE))
		    (AND ^Q :CAREFUL (MAPC 'DPRINC OLD-LINE) (DTERPRI))
		    ;;COPY OF ORIGINAL LINE SAVED FOR RECOVERY OF PIECES BY EDITING
		    ;;CHARACTERS, PARSEMACROS [SEE PARSER].
		    (RETURN PASS2-LINE))
		   ((EQ WORD EOF) (RETURN EOF)))
	     (AND (EQ WORD '$) (PUSH '$ LINE) (INSTRING) (GO READ))
	     (PUSH WORD LINE)
	     (GO READ))) 

;; READ IN A QUOTED STRING.

(DEFUN INSTRING NIL 
       (PROG (CH) 
	LOOP (SETQ CH (READCH))
	     ;;;GOBBLE A CHARACTER
	     (COND ((EQ CH '$)
		    ;;;IF $, DONE
		    (PUSH CH LINE)
		    (RETURN T))
		   ((AND ^Q (EQ CH EOL) (= (TYIPEEK) 10.)) (READCH) (PUSH CH LINE))
		   ((EQ CH '/)
		    ;;;RUBOUT?
		    (COND [ITS ((MEMBER TTY '(1. 2. 3. 5.))
				(CURSORPOS 'X)
				(INCREMENT CHRCT 3.))]
			  ;;;IF DISPLAY TTY, ERASE
			  ((DPRINC (CAR LINE))))
		    ;;;ELSE REECHO
		    (COND ((EQ (CAR LINE) '$) (POP LINE) (RETURN T)))
		    ;;;IF $ RUBBED OUT, DONE
		    (POP LINE)
		    ;;;REMOVE RUBBED OUT CHAR
		    (GO LOOP)))
	     (PUSH CH LINE)
	     ;;;SAVE CHAR
	     (GO LOOP))) 

;;*PAGE

;; PASS2 IS RESPONSIBLE FOR REMOVING SPACES, HANDLING QUOTING CONVENTIONS, CREATING
;;LIST STRUCTURE, PACKAGING COMMENTS AND MAKING NEGATIVE NUMBERS FROM MINUS SIGNS.
;;; '<SEXP> --> (QUOTE <SEXP>)
;;; "<SEXP>" --> (DOUBLE-QUOTE <SEXP>)
;;; "<S1> ... <SN>" --> (DOUBLE-QUOTE (<S1> ... <SN>))
;;; "" --> NIL
;;; [] --> NIL
;;; [ <SEXP1> ... <SEXPN>] --> (SQUARE-BRACKETS (<SEXP1> ... <SEXPN>)) EXCEPT THAT
;;;       SQUARE BRACKETS INSIDE LIST STRUCTURE DO NOT HAVE SQUARE-BRACKETS
;;;	  PUT AROUND THEM. SQUARE-BRACKETS, DOUBLE-QUOTE ARE  LIKE QUOTE, EXCEPT
;;; 	PRINTER KNOWS DIFFERENCE.
;;; ! <COMMENTARY> ! --> (LOGO-COMMENT ! <COMMENTARY> !)
;;; ; <COMMENTARY>  --> (LOGO-COMMENT /; <COMMENTARY>)
;;; - <NUMBER> --> <-NUMBER>

(DEFUN PASS2 (TOKENLINE) (CATCH (UNSQUISH-LIST NIL) PASS2)) 

(SETQ :PARENBALANCE T) 

(DEFUN UNSQUISH-LIST (LOOKING-FOR) 
       (COND
	((NULL TOKENLINE)
	 (COND
	  ((EQ LOOKING-FOR '/))
	   ;;THE FLAG :PARENBALANCE TELLS WHETHER OR NOT TO CHECK FOR PARENTHESIS
	   ;;BALANCE WHEN A LINE ENDS.  TURNING IT OFF ALLOWS USER TO HAVE A
	   ;;MULTI-LINE PARENTHESIZED FORM, FOR EASIER READING [VERTICAL ALIGNMENT
	   ;;OF CONDITIONAL CLAUSES].
	   (COND (:PARENBALANCE (PASS2-ERROR '"UNMATCHED ("))
		 ((LET ((:CAREFUL (COND ((AND ^Q :CAREFUL) NIL) (:CAREFUL))))
		       ;;PREVENT RETYPEOUT OF LINE COMING IN FROM FILE.
		       (THROW (LINE (CONS '/  (NREVERSE OLD-LINE))) PASS2)))))
	  ((EQ LOOKING-FOR '/])
	   ;;A SQUARE BRACKETED LIST MAY CONTAIN A CARRIAGE RETURN.  LINE MUST BE
	   ;;CALLED AGAIN TO PICK UP REMAINDER OF LINE.  BEWARE OF CALLING PASS2
	   ;;WHEN NOT INSIDE LINE.
	   (LET ((:CAREFUL (COND ((AND ^Q :CAREFUL) NIL) (:CAREFUL))))
		(THROW (LINE (CONS EOL (NREVERSE OLD-LINE))) PASS2)))
	  ((EQ LOOKING-FOR '/")
	   (LET ((:CAREFUL (COND ((AND ^Q :CAREFUL) NIL) (:CAREFUL))))
		(THROW (LINE (CONS EOL (NREVERSE OLD-LINE))) PASS2)))
	  ((NULL LOOKING-FOR) NIL)
	  ((PASS2-ERROR '"SYSTEM BUG - UNSQUISH-LIST"))))
	((EQ (CAR TOKENLINE) '/ ) (POP TOKENLINE) (UNSQUISH-LIST LOOKING-FOR))
	((AND LOOKING-FOR (EQ (CAR TOKENLINE) LOOKING-FOR)) (POP TOKENLINE) NIL)
	((CONS (UNSQUISH LOOKING-FOR) (UNSQUISH-LIST LOOKING-FOR))))) 

(DEFUN UNSQUISH (LOOKING-FOR) 
       (LET
	((WORD (CAR TOKENLINE)))
	(OR TOKENLINE
	    (PASS2-ERROR (COND ((EQ LOOKING-FOR '/')
				'"QUOTE WHAT?")
			       ('"SYSTEM BUG - UNSQUISH"))))
	(POP TOKENLINE)
	(COND
	 ((EQ WORD '$)
	  (DO ((CH (CAR TOKENLINE) (CAR TOKENLINE)) (L))
	      ((AND (EQ CH '$)
		    (NOT (AND TOKENLINE
			      (CDR TOKENLINE)
			      (EQ (CADR TOKENLINE) '$)
			      (POP TOKENLINE))))
	       (SETQ CH (INTERN (MAKNAM (NREVERSE L))))
	       (POP TOKENLINE)
	       CH)
	      (POP TOKENLINE)
	      (PUSH CH L)))
	 ((EQ WORD '/ ) (UNSQUISH LOOKING-FOR))
	 ((MEMQ WORD '(/; !))
	  (AND (EQ WORD '!)
	       (NOT (MEMQ '! TOKENLINE))
	       (LET ((:CAREFUL (COND ((AND ^Q :CAREFUL) NIL) (:CAREFUL))))
		    (THROW (LINE (CONS EOL (NREVERSE OLD-LINE))) PASS2)))
	  ;;IF WE WERE EXPECTING ANYTHING WHEN COMMENT COMMENCED, THERE'S SOMETHING
	  ;;WRONG.
	  (PROG2 (COND ((EQ LOOKING-FOR '/')
			(PASS2-ERROR '"QUOTE WHAT?"))
		       ((EQ LOOKING-FOR '/))
			(PASS2-ERROR '"UNMATCHED ("))
		       ((EQ LOOKING-FOR '/])
			(PASS2-ERROR '"UNMATCHED ["))
		       ((EQ LOOKING-FOR '/")
			(PASS2-ERROR '"UNMATCHED """"")))
		 (CCONS 'LOGO-COMMENT WORD TOKENLINE)
		 (SETQ TOKENLINE NIL)))
	 ((EQ WORD '/') (LIST 'QUOTE (UNSQUISH '/')))
	 ((EQ WORD '/")
	  (COND ((NULL (SETQ WORD (UNSQUISH-LIST WORD))) NIL)
		(REQUEST? WORD)
		((CDR WORD) (LIST 'DOUBLE-QUOTE WORD))
		((LIST 'DOUBLE-QUOTE (CAR WORD)))))
	 ((EQ WORD '/() (UNSQUISH-LIST '/)))
	 ((EQ WORD '/))
	  (PASS2-ERROR
	   (COND
	    ((EQ LOOKING-FOR '/])
	     '"UNMATCHED RIGHT PAREN INSIDE SQUARE BRACKETS")
	    ((EQ LOOKING-FOR '/")
	     '"UNMATCHED RIGHT PAREN INSIDE DOUBLE QUOTES")
	    ('"UNMATCHED RIGHT PAREN"))))
	 ((EQ WORD '/[)
	  (COND ((NULL (SETQ WORD (UNSQUISH-LIST '/]))) NIL)
		((MEMQ LOOKING-FOR '(/] /' /")) WORD)
		(REQUEST? WORD)
		;;SPECIAL CASE CHECK.  INSIDE REQUEST, SQUARE BRACKETS ARE NOT TO
		;;HAVE OUTER LEVEL QUOTED.
		((LIST 'SQUARE-BRACKETS WORD))))
	 ((EQ WORD '/])
	  (PASS2-ERROR
	   (COND
	    ((EQ LOOKING-FOR '/))
	     '"UNMATCHED RIGHT BRACKET INSIDE PARENTHESES")
	    ((EQ LOOKING-FOR '/")
	     '"UNMATCHED RIGHT BRACKET INSIDE DOUBLE QUOTES")
	    ('"UNMATCHED RIGHT BRACKET"))))
	 ((EQ WORD '-)
	  (COND ((NUMBERP (SETQ WORD (CAR TOKENLINE))) (POP TOKENLINE) (MINUS WORD))
		('-)))
	 (WORD)))) 

(SETQ REQUEST? NIL) 

(DEFINE SQUARE-BRACKETS (SYN QUOTE)) 

(DEFINE DOUBLE-QUOTE (SYN QUOTE)) 

;;;		READING FILES

(DEFINE READFILE (ABB RF) FEXPR (FILENAME) 
 (LET ((^W ^W)
       (OBARRAY LOGO-OBARRAY)
       (READTABLE LOGO-READTABLE)
       (LISPPRINT NIL)
       (SECOND-FILE-NAME)
       ;;TURN OFF FASLOAD REDEFINITION MESSAGES IF REDEFINITION ALLOWED.
       (FASLOAD (NOT :REDEFINE)))
      (SETQ SECOND-FILE-NAME (CADR (SETQ FILENAME (FILESPEC FILENAME))))
      (COND [(OR DEC10 ITS) ((EQ SECOND-FILE-NAME 'FASL)
			     (TYPE '";FASLOADING "
				   FILENAME
				   EOL)
			     (APPLY 'FASLOAD FILENAME))]
	    [MULTICS ((EQ SECOND-FILE-NAME 'FASL)
		      (TYPE '";READING " FILENAME EOL)
		      (LOAD (CATENATE (GET_PNAME (CADDDR FILENAME))
				      ">"
				      (GET_PNAME (CAR FILENAME)))))]
	    ((EQ SECOND-FILE-NAME 'WINDOW) (APPLY 'GETWINDOWS FILENAME))
	    ((EQ SECOND-FILE-NAME 'SNAPS) (APPLY 'GETSNAPS FILENAME))
	    ((APPLY 'UREAD FILENAME)
	     (TYPE '";READING " FILENAME EOL)
	     (SETQ ^Q T ^W (OR ^W (NOT :CAREFUL)))
	     (DO ((LOGOREAD (LOGOREAD) (LOGOREAD))
		  (LOGOVALUE)
		  (PROMPTER NO-VALUE)
		  (OLD-LINE))
		 ((OR (EQ LOGOREAD EOF) (NULL ^Q)) (SETQ ^Q NIL) NO-VALUE)
		 (SETQ LOGOVALUE (EVALS LOGOREAD))
		 (OR (EQ LOGOVALUE NO-VALUE) (LOGO-PRINT LOGOVALUE))
		 (OR ^Q (RETURN NIL)))))
      NO-VALUE)) 

[CLOGO (DEFINE READ (PARSE (PARSE-CLOGO-HOMONYM READFILE L T)))] 

[CLOGO (DEFINE GET (PARSE (PARSE-CLOGO-HOMONYM READFILE 2. T)))] 

;;READ LOOP.

(DEFINE READLISP FEXPR (FILENAME) 
        (COND ((EQ (CADR (SETQ FILENAME (FILESPEC FILENAME))) 'FASL)
               (LET ((OBARRAY LISP-OBARRAY) (READTABLE LISP-READTABLE)) 
                    (APPLY 'FASLOAD FILENAME)))
              ((APPLY 'UREAD FILENAME) (READOB LOGO-OBARRAY LISP-READTABLE))))

(DEFUN READOB (OBARRAY READTABLE) 
       (DO ((R) (^Q T))
	   ((OR (NULL ^Q) (EQ (SETQ R (READ GENSYM)) GENSYM)) (TERPRI))
	   (SETQ R (EVAL R))
	   (OR (EQ R NO-VALUE) (PRINT R)))
       (SETQ ^Q NIL)
       NO-VALUE) 

;;INPUT
;;;
;;READS NEXT CHARACTER AND RETURNS ITS ASCII VALUE.				

(DEFINE TYI (PARSE 0.)) 

(DEFINE TTYP NIL (ZEROP (LISTEN))) 

;;ARG PROP OF TYI = (0 .  1), WHERE AN ARG TREATED AS EOF CHAR ALLA READ.  THUS
;;PARSE PROPERTY IS NECESSARY.  THE AMBIGUITY BETWEEN ONE WORD SENTENCES AND WORDS
;;IS RESOLVED IN FAVOR OF WORDS IN THE CLOGO VERSION.

(DEFINE REQUEST (ABB RQ) NIL 
	(AND (OR (= [(OR ITS DEC10) LINEL]
		    [MULTICS (LINEL NIL)]
		    [(OR ITS DEC10) CHRCT]
		    [MULTICS (CHRCT NIL)])
		 (= (SUB1 [(OR ITS DEC10) LINEL]
			  [MULTICS (LINEL NIL)])
		    [(OR ITS DEC10) CHRCT]
		    [MULTICS (CHRCT NIL)]))
	     (DPRINC '<))
	(LET ((OBARRAY LOGO-OBARRAY)
	      (READTABLE LOGO-READTABLE)
	      (LINE)
	      (REQUEST? T)
	      (PROMPTER '<)
	      (OLD-LINE))
	     [ITS (BIND-ACTIVATE-LOGO)]
	     (SETQ LINE (LINE NIL))
	     (PROG1 (COND ((CDR LINE) LINE)
			  ;;ONE ELEMENT TYPED.  IN 11LOGO, IF ATOM RETURN LIST OF
			  ;;ATOM. ELSE RETURN LIST TYPED.
			  [/11LOGO ((ATOM (CAR LINE)) LINE)]
			  ((CAR LINE)))
		    [/11LOGO LINE]
		    [ITS (UNBIND-ACTIVATE)]))) 

;;NO PARSING IS DONE ON THE STUFF GOBBLED BY REQUEST.  PASS2 IS DONE, SO PARENS ARE
;;CHANGED TO LIST STRUCTURE, SPACES REMOVED, UNARY-BINARY MINUS DISTINCTION IS MADE. 
;;USER CAN GET FAKED OUT BY MINUS SIGN, SINGLE-QUOTE, SQUARE BRACKETS. 
;;;

(DEFUN ASK NIL 
       ;;USER IS ASKED YES-NO QUESTION.  IT RETURNS T OR NIL.
       (IOG
	NIL
	(PROG (ANS) 
	 A    (DTERPRI)
	      (SETQ ANS (REQUEST))
	      (OR (ATOM ANS) (SETQ ANS (CAR ANS)))
	      (COND ((MEMQ ANS '(YES Y T TRUE RIGHT)) (RETURN T))
		    ((MEMQ ANS '(NO N NIL F FALSE WRONG)) (RETURN NIL))
		    ((DPRINC '";PLEASE TYPE YES OR NO. ")
		     (GO A)))))) 

(DEFINE TYPEIN NIL [/11LOGO (CAR (REQUEST))]
		   [CLOGO (LET ((RESPONSE (REQUEST)))
			       (COND ((ATOM RESPONSE) RESPONSE) ((CAR RESPONSE))))]) 

;;*PAGE


;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;			LOGO PARSER			    ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;THE FUNCTION OF THE PARSER IS TO CONVERT A LINE OF LOGO CODE TO
;;;LISP.  THE TOPLEVEL FUNCTION "PARSELINE" EXPECTS AS INPUT A LIST OF
;;;LOGO ATOMS AS, FOR EXAMPLE, ARE PRODUCED BY "LINE".  PARSELINE
;;;RETURNS THE EQUIVALENT LIST OF LISP S-EXPRESSIONS WHICH CAN THEN
;;;BE RUN BY "EVALS..
;;;
;;;THE GENERAL ATTACK IS FOR THE SPECIALISTS OF PARSE TO EXAMINE
;;;TOPARSE FOR THEIR SPECIALTY.  IF FOUND, THEY GENERATE AN 
;;;S-EXPRESSION WHICH IS PUSHED ONTO "PARSED" AND "TOPARSE" IS
;;;APPROPRIATELY PRUNED.  AN EXCEPTION TO THIS IS THAT PARSE-LOGOFN
;;;REPLACES THE PARSED EXPRESSION ONTO FIRST AND THEN TRIES 
;;;PARSE-INFIX.  THIS ALLOWS INFIX TO HAVE PRECEDENCE IN SITUATIONS
;;;OF THE FORM: "A"=B AND HEADING=360.
;;;
;;;
;;;F = COLLECT INPUTS TO END OF LINE WITHOUT PARSING
;;;L = COLLECT INPUTS TO END OF LINE PARSING
;;;NO. = FIXED NUMBER OF INPUTS		       
;;;(FNCALL) = SPECIAL PARSING FN TO BE EXECUTED.
;;;
;;;
;;FOR PROCEDURAL PARSING PROPERTIES, (GET ATOM 'PARSE) = ((PARSE-FN)), THE ENTRY
;;STATE IS THAT FIRST = FN, TOPARSE = REMAINDER OF LINE.  THE OUTPUT OF THE PARSE-FN
;;IS TO BE THE PARSED EXPR.  TOPARSE SHOULD BE POPPED IN THE PROCESS.

(DECLARE (OR (STATUS FEATURE DEFINE)
	     (COND ((STATUS FEATURE ITS)
		    ;;MULTICS?
		    (FASLOAD DEFINE FASL AI LLOGO))))) 

(SAVE-VERSION-NUMBER PARSER) 

(DECLARE (SETQ MACROS T) (GENPREFIX PARSER)) 

;;THE CATCH WILL TRAP THE RESULT OF A PARSING ERROR.  THE FUNCTION REREAD-ERROR WILL
;;TRY TO GET USER TO CORRECT THE LINE, AND WILL THROW BACK A CORRECTLY PARSED LINE. 
;;IF PARSELINE IS GIVEN A NON-NIL SECOND ARGUMENT, THEN A PARSING ERROR WILL SIMPLY
;;(ERR 'REREAD) OUT OF PARSELINE, INSTEAD OF ATTEMPTING TO RECOVER.

(DEFUN PARSELINE ARGS 
       (COND ((EQ (ARG 1.) EOF) EOF)
	     ((CATCH (DO ((PARSED NIL (CONS (PARSE NIL) PARSED))
			  (REREAD-ERROR? (AND (> ARGS 1.) (ARG 2.)))
			  (TOPARSE (APPEND (AND (NUMBERP (CAR (ARG 1.)))
						(OR (NOT :EDITMODE)
						    (EQ PROMPTER '>))
						'(INSERT-LINE))
					   (ARG 1.))))
			 ((NULL TOPARSE)
			  (COND (PARSED (NREVERSE PARSED)) (NULL-LINE))))
		     PARSELINE)))) 

[(OR ITS DEC10) (ARGS 'PARSELINE '(1. . 2.))] 

(SETQ FLAG NIL :EDITMODE T) 

[CLOGO (DEFINE PARSE-CLOGO-HOMONYM FEXPR (X) 
	(COND (:CAREFUL (AND (CDDR X)
			     (IOG NIL
				  (TYPE '"HOMONYM: REPLACING "
					FIRST
					'" BY "
					(CAR X))))
			(SETQ TOPARSE (CONS (CAR X) TOPARSE))
			(PARSE FLAG))
	      ((PARSE1 (CADR X)))))] 

;;THE PARSE FUNCTION IS SUB-STRUCTURED.  PARSE1 PARSES WITH A GIVEN PARSE PROPERTY. 
;;PROP SHOULD BE LAMBDA VARIABLE AS IT IS MODIFIED BY PARSE-PROP.

(DEFUN PARSE (FLAG) 
       (COND ((ATOM TOPARSE) (SETQ TOPARSE NIL))
	     ((LET ((FIRST (CAR TOPARSE)) (PROP))
		   (POP TOPARSE)
		   (PARSE1 (PARSE-PROP FIRST)))))) 

;;FIRST IS THE THING CURRENTLY BEING WORKED ON [I.E.  FUNCTION NAME] , TOPARSE IS
;;NOW THE REST OF THE LINE.

(DEFUN PARSE1 (PROP) 
       (SETQ FIRST (COND ((NULL PROP) (PARSE-?))
			 ((ATOM PROP) (PARSE-LOGOFN PROP))
			 ((AND (CDR PROP) (ATOM (CDR PROP)))
			  (CONS FIRST (PARSE-LEXPR-ARGS (CAR PROP) (CDR PROP))))
			 ((EVAL PROP))))
       (PARSE-INFIX)) 

;; TO ELIMINATE HOMONYMS [WORDS THAT MEAN ONE THING IN LISP, ANOTHER IN LOGO], THE
;;PARSER WILL TRANSFORM THEM INTO ALTERNATE WORDS, UNPARSER, PRINTER WILL CHANGE
;;THEM BACK.  PITFALL IN CURRENT METHOD OF HANDLING HOMONYMS: WHEN PASSING
;;FUNCTIONAL ARUGUMENTS IN CERTAIN CASES, THE PARSER DOES NOT GET A CHANCE TO DO ITS
;;THING, SO USER MAY FIND UNEXPECTED FUNCTION CALLED.  EXAMPLE: APPLY 'PRINT ..... 
;;CALLS LISP'S PRINT FN, NOT LOGO'S.

(DEFUN PARSE-SUBSTITUTE (REAL) (PARSE1 (PARSE-PROP (SETQ FIRST REAL)))) 

;;FINDS PARSE PROPERTY FOR X.  X MUST BE A PNAME TYPE ATOM.  IF PARSE-PROP GETS A
;;LIST, RETURNS NIL.  EXPLICIT PARSE PROPERTY IF INSIDE USER-PARENS USE SECOND
;;ELEMENT OF PARSE PROPERTY, IF THERE IS ONE.  ARRAY IS HANDLED AS AN EXPR OF NUMBER
;;OF DIMENSIONS ARGS.  TREAT X AS A VARIABLE IF IT'S BOUND OR FIRST LETTER IS COLON.

(DEFUN PARSE-PROP (X) 
       (COND
	((NOT (SYMBOLP X)) NIL)
	((SETQ PROP (ABBREVIATIONP X)) (PARSE-PROP (SETQ FIRST PROP)))
	((SETQ PROP (GET X 'PARSE))
	 (COND ((AND (EQ FLAG 'USER-PAREN) (CDR PROP)) (CADR PROP))
	       ((CAR PROP))))
	((HOW-TO-PARSE-INPUTS X))
	((BOUNDP X) NIL)
	((EQ (GETCHAR X 1.) ':) NIL)
	(INSERTLINE-NUMBER (THROW (NCONS (LIST 'INSERT-LINE
					       INSERTLINE-NUMBER
					       (CCONS 'PARSEMACRO
						      FIRST
						      (LIST FN INSERTLINE-NUMBER)
						      OLD-LINE)))
				  PARSELINE))
	;;X IS AN UNKNOWN FUNCTION.  IF EDITING, THROW. 
	((REREAD-ERROR
	  (LIST FIRST
		'" IS AN UNDEFINED FUNCTION "))))) 

(DEFUN HOW-TO-PARSE-INPUTS (FUNCTION) 
       ;;FIND FIRST FUNCTION PROPERTY ON PLIST OF X. 
       (LET ((GETL (FUNCTION-PROP FUNCTION)))
	    (COND ((MEMQ (CAR GETL) '(FEXPR FSUBR MACRO)) 'F)
		  ((EQ (CAR GETL) 'EXPR)
		   ;;PARSE PROPERTY OF AN EXPR IS THE NUMBER OF INPUTS.
		   (LET ((ARGLIST (CADADR GETL)))
			(COND ((AND ARGLIST (ATOM ARGLIST))
			       (PARSE-ARGS-PROP FUNCTION))
			      ((LENGTH ARGLIST)))))
		  ((MEMQ (CAR GETL) '(LSUBR SUBR)) (PARSE-ARGS-PROP FUNCTION))
		  ((EQ (CAR GETL) 'ARRAY)
		   (1- (LENGTH (ARRAYDIMS FUNCTION))))))) 

(DEFUN PARSE-ARGS-PROP (FUNCTION) 
       (LET ((ARGS-PROP (ARGS FUNCTION)))
	    (COND ((NULL ARGS-PROP) 'L)
		  ((NULL (CAR ARGS-PROP)) (CDR ARGS-PROP))
		  (ARGS-PROP)))) 

(DEFUN EOP NIL 
       (OR (NULL TOPARSE)
	   (AND (EQ (TYPEP (CAR TOPARSE)) 'LIST)
		(EQ (CAAR TOPARSE) 'LOGO-COMMENT)))) 

;;FIRST IS SET TO PARSED FN AND TOPARSE IS APPROPRIATELY POPPED.  PROP IS THE NUMBER
;;OF INPUTS.

(DEFUN PARSE-LOGOFN (PROP) 
       (CONS
	FIRST
	(COND ((EQ PROP 'F) (PARSE-FEXPR-ARGS))
	      ((EQ PROP 'L) (PARSE-LEXPR-ARGS 0. 999.))
	      ((NUMBERP PROP) (PARSE-EXPR-ARGS PROP))
	      ((REREAD-ERROR '"SYSTEM BUG - PARSE-LOGOFN"))))) 

(DEFUN PARSE-FEXPR-ARGS NIL 
       (COND ((EOP) NIL)
	     ((CONS (CAR TOPARSE) (PROG2 (POP TOPARSE) (PARSE-FEXPR-ARGS)))))) 

;;PICK UP INPUTS TO FUNCTIONS EXPECTING AN INDEFINITE NUMBER OF EVALUATED ARGUMENTS. 
;;PARSING OF ARGUMENTS MUST HALT AT INFIX OPERATOR, BECAUSE FIRST OPERAND IS MEANT
;;TO BE THE WHOLE FORM, AND INFIX OPERATOR DOES NOT BEGIN ANOTHER ARGUMENT TO THE
;;LEXPR.  EXAMPLE:
;;;	10 TEST YOUR.FAVORITE.LEXPR :ARG1 ... :ARGN = :RANDOM

(DEFUN PARSE-LEXPR-ARGS (AT-LEAST AT-MOST) 
       (COND ((OR (EOP) (GET (CAR TOPARSE) 'PARSE-INFIX))
	      (AND (PLUSP AT-LEAST)
		   (REREAD-ERROR (LIST '"TO FEW INPUTS TO "
				       (UNPARSE-FUNCTION-NAME FIRST)))))
	     ((ZEROP AT-MOST) NIL)
	     ((CONS (PARSE FIRST) (PARSE-LEXPR-ARGS (1- AT-LEAST) (1- AT-MOST)))))) 

(DEFUN PARSE-EXPR-ARGS (HOWMANY) 
       (COND ((= HOWMANY 0.) NIL)
	     ((EOP)
	      (REREAD-ERROR (LIST '"TOO FEW INPUTS TO "
				  (UNPARSE-FUNCTION-NAME FIRST))))
	     ((CONS (PARSE FIRST) (PARSE-EXPR-ARGS (1- HOWMANY)))))) 

(DEFUN PARSE-FORM-LIST NIL 
       (COND ((EOP) NIL) ((CONS (PARSE FIRST) (PARSE-FORM-LIST))))) 

;;*PAGE

;;PRECEDENCE FUNCTION ALLOWS USER TO CHANGE PRECEDENCE AS HE WISHES.  (PRECEDENCE
;;<OP>) RETURNS PRECEDENCE NUMBER OF <OP>.  (PRECEDENCE <OP> <LEVEL>) SETS
;;PRECEDENCE OF <OP> TO <LEVEL>, EITHER A NUMBER OR OPERATOR, WHICH MAKES IT SAME
;;PRECEDENCE AS 	THAT OPERATOR.  <LEVEL>= NIL MEANS LOWEST PRECEDENCE. 
;;(PRECEDENCE NIL <NUMBER>) SETS THE DEFAULT PRECEDENCE FOR IDENTIFIERS TO <NUMBER>.

(DEFINE PRECEDENCE ARGS 
	(COND ((= ARGS 1.)
	       (COND ((NULL (ARG 1.)) 0.)
		     ((GET (ARG 1.) 'INFIX-PRECEDENCE))
		     (DEFAULT-PRECEDENCE)))
	      ((ARG 1.)
	       (PUTPROP (ARG 1.)
			(COND ((NUMBERP (ARG 2.)) (ARG 2.)) ((PRECEDENCE (ARG 2.))))
			'INFIX-PRECEDENCE))
	      ((SETQ DEFAULT-PRECEDENCE (NUMBER? 'PRECEDENCE (ARG 2.)))))) 

[(OR ITS DEC10) (ARGS 'PRECEDENCE '(1. . 2.))] 

;; (ASSOCIATE <LEVEL> <WHICH-WAY>) CAUSES ALL OPERATORS OF PRECEDENCE <LEVEL> TO
;;ASSOCIATE TO RIGHT, OR LEFT, AS SPECIFIED.  DEFAULT IS LEFT ASSOCIATIVE. 
;;RIGHT-ASSOCIATIVE IS LIST OF LEVELS WHICH ARE NOT.

(DEFINE ASSOCIATE (LEVEL WHICH-WAY) 
	(SETQ LEVEL (NUMBER? 'ASSOCIATE LEVEL))
	(COND ((EQ WHICH-WAY 'RIGHT) (PUSH LEVEL RIGHT-ASSOCIATIVE))
	      ((EQ WHICH-WAY 'LEFT)
	       (SETQ RIGHT-ASSOCIATIVE (DELETE LEVEL RIGHT-ASSOCIATIVE)))
	      ((ERRBREAK 'ASSOCIATE
			 '"INPUT MUST BE RIGHT OR LEFT")))
	WHICH-WAY) 

;; (INFIX <OP> <PRECEDENCE> ) CREATES <OP> TO BE A NEW INFIX OPERATOR, OPTIONALLY
;;SPECIFYING A PRECEDENCE LEVEL.

(DEFINE INFIX ARGS 
	(PUTPROP (ARG 1.) (ARG 1.) 'PARSE-INFIX)
	(PUTPROP (ARG 1.) (ARG 1.) 'UNPARSE-INFIX)
	(PUSH (ARG 1.) :INFIX)
	(AND (= ARGS 2.)
	     (PUTPROP (ARG 1.)
		      (COND ((NUMBERP (ARG 2.)) (ARG 2.)) ((PRECEDENCE (ARG 2.))))
		      'INFIX-PRECEDENCE))
	(ARG 1.)) 

[(OR ITS DEC10) (ARGS 'INFIX '(1. . 2.))] 

;;NOPRECEDENCE MAKES EVERY INFIX OPERATOR HAVE THE SAME PRECEDENCE, AS CLOGO DOES. 
;;LOGICAL FUNCTIONS HAVE PRECEDENCE LOWER THAN DEFAULT FUNCTIONS, INFIX HIGHER.

(DEFINE NOPRECEDENCE NIL 
	(SETQ DEFAULT-PRECEDENCE 300.)
	(MAPC 
	 '(LAMBDA (OP) (PUTPROP OP (1+ DEFAULT-PRECEDENCE) 'INFIX-PRECEDENCE))
	 :INFIX)
	(MAPC '(LAMBDA (OP) (REMPROP OP 'INFIX-PRECEDENCE))
	      '(IF NOT BOTH EITHER TEST AND OR))
	NO-VALUE) 

;;THIS FUNCTION PARSES INFIX EXPRESSIONS.  ON ENTRY, FIRST IS THE FORM THAT WAS JUST
;;PARSED, TOPARSE REMAINDER OF LINE.  IF THE EXPRESSION IS INFIX, NEXT WILL BE AN
;;INFIX OPERATOR.  FLAG, THE INPUT TO PARSE, MAY BE NIL, USER-PAREN, OR A FUNCTION
;;NAME.  IF PRECEDENCE OF FLAG, IS GREATER THAN PRECEDENCE OF NEXT, INFIX EXPRESSION
;;IS OVER, RETURN FIRST.  ELSE CONTINUE PARSING SECOND INPUT TO INFIX OPERATOR. 
;;ASSOCIATIVITY IS DECIDED BY PARSING DECISION MADE WHEN PRECEDENCES ARE EQUAL.  A
;;SPECIAL KLUDGE IS NECESSARY FOR HANDLING MINUS SIGN- PASS2 CONVERTS ALL MINUS
;;SIGNS FOLLOWED BY NUMBERS TO NEGATIVE NUMBERS; RECONVERSION MAY BE NECESSARY. 

(DEFUN PARSE-INFIX NIL 
       (DO ((NEXT (CAR TOPARSE) (CAR TOPARSE))
	    (INFIX-OP (GET (CAR TOPARSE) 'PARSE-INFIX)
		      (GET (CAR TOPARSE) 'PARSE-INFIX))
	    (NEXT-LEVEL (PRECEDENCE (CAR TOPARSE)) (PRECEDENCE (CAR TOPARSE)))
	    (FLAG-LEVEL (PRECEDENCE FLAG))
	    (DASH))
	   (NIL)
	   (COND (INFIX-OP)
		 ((AND (NUMBERP NEXT)
		       (MINUSP NEXT)
		       (SETQ DASH (GET '- 'PARSE-INFIX)))
		  (SETQ INFIX-OP DASH 
			NEXT-LEVEL (PRECEDENCE '-) 
			NEXT '-)
		  (RPLACA TOPARSE (MINUS (CAR TOPARSE)))
		  (PUSH '- TOPARSE))
		 ((RETURN FIRST)))
	   (COND ((AND (NUMBERP FIRST)
		       (MINUSP FIRST)
		       (GREATERP NEXT-LEVEL (PRECEDENCE 'PREFIX-MINUS)))
		  (PUSH (MINUS FIRST) TOPARSE)
		  (SETQ FIRST (LIST 'PREFIX-MINUS
				    (PARSE 'PREFIX-MINUS))))
		 ((GREATERP NEXT-LEVEL FLAG-LEVEL) (PARSE-INFIX-LEVEL NEXT INFIX-OP))
		 ((EQUAL NEXT-LEVEL FLAG-LEVEL)
		  (COND ((MEMBER NEXT-LEVEL RIGHT-ASSOCIATIVE)
			 (PARSE-INFIX-LEVEL NEXT INFIX-OP))
			((RETURN FIRST))))
		 ((RETURN FIRST))))) 

(DEFUN PARSE-INFIX-LEVEL (NEXT INFIX-OP) 
       (POP TOPARSE)
       (AND (EOP)
	    (REREAD-ERROR (LIST '"TOO FEW INPUTS TO"
				(UNPARSE-FUNCTION-NAME NEXT))))
       (SETQ FIRST (LIST INFIX-OP FIRST (PARSE NEXT)))) 

;;INITIAL DEFAULT PRECEDENCES.  NIL & USER-PAREN HAVE PRECEDENCE 0, (PARSE NIL)
;;,(PARSE 'USER-PAREN) PICKS UP A FORM- MAXIMAL INFIX EXPRESSION.  BOOLEAN FUNCTIONS
;;ARE GIVEN LOWER PRECEDENCE THAN COMPARISON OPERATORS.  DEFAULT PRECEDENCE IS 300. 
;;INITIALLY, ONLY EXPONENTIATION AND ASSIGNMENT ARE RIGHT ASSOCIATIVE.  THESE ARE
;;THE PRECEDENCE LEVELS USED BY 11LOGO.

(MAPC '(LAMBDA (INFIX PREFIX) (PUTPROP INFIX PREFIX 'PARSE-INFIX)
			      (PUTPROP PREFIX INFIX 'UNPARSE-INFIX))
      '(+ - * // \ < > = ^ _)
      '(INFIX-PLUS INFIX-DIFFERENCE INFIX-TIMES INFIX-QUOTIENT INFIX-REMAINDER
	INFIX-LESSP INFIX-GREATERP INFIX-EQUAL INFIX-EXPT INFIX-MAKE)) 

;;THEN AND ELSE ARE CONSIDERED AS "INFIX" SO THAT THEY WILL TERMINATE PARSING OF
;;INPUTS TO LEXPR-TYPE FUNCTIONS, WHERE THE EXTENT OF A FORM ISN'T REALLY CLEARLY
;;DELINEATED.  SINCE THEY HAVE LOWER PRECEDENCE THAN ANYTHING ELSE, THEY WILL NEVER
;;REALLY BE PARSED AS INFIX.

(DEFPROP THEN THEN PARSE-INFIX) 

(DEFPROP ELSE ELSE PARSE-INFIX) 

(DEFPROP THEN 0. INFIX-PRECEDENCE) 

(DEFPROP ELSE 0. INFIX-PRECEDENCE) 

(SETQ :INFIX '(_ < > = + - * // \ PREFIX-MINUS PREFIX-PLUS ^)) 

(MAPC '(LAMBDA (OP LEVEL) (PUTPROP OP LEVEL 'INFIX-PRECEDENCE))
      :INFIX
      '(50. 200. 200. 200. 400. 400. 500. 500. 500. 600. 600. 700.)) 

(MAPC '(LAMBDA (OP LEVEL) (PUTPROP OP LEVEL 'INFIX-PRECEDENCE))
      '(NIL USER-PAREN IF BOTH NOT EITHER TEST AND OR)
      '(0. 0. 100. 100. 100. 100. 100. 100. 100.)) 

(SETQ DEFAULT-PRECEDENCE 300.) 

(SETQ RIGHT-ASSOCIATIVE '(50. 700.)) 

;;INFIX-MAKE SHOULD PROBABLY HAVE DIFFERENT PRECEDENCES FROM RIGHT AND LEFT SIDES:
;;;	:A + :B _ 17  ==> (PLUS :A (MAKE :B 17))
;;;	:A _ :B + 17  ==> (MAKE :A (PLUS :B 17))
;;;
;;USER PARENTHESIS MARKER.

(DEFINE USER-PAREN (X) X) 

(DEFUN PARSE-? NIL 
       (COND
	((AND (EQ (TYPEP FIRST) 'LIST)
	      (NOT (MEMQ (CAR FIRST)
			 '(LOGO-COMMENT QUOTE DOUBLE-QUOTE SQUARE-BRACKETS))))
	 (LIST
	  'USER-PAREN
	  (LET
	   ((TOPARSE FIRST))
	   (PROG2
	    NIL
	    (PARSE 'USER-PAREN)
	    ;;MORE THAN ONE FORM INSIDE PARENTHESES. 
	    (AND
	     TOPARSE
	     (REREAD-ERROR
	      (LIST '"TOO MUCH INSIDE PARENTHESES."
		    TOPARSE
		    '"IS EXTRA")))))))
	((AND (NUMBERP FIRST) (NULL FLAG))
	 (REREAD-ERROR (LIST '"A NUMBER ISN'T A FUNCTION"
			     FIRST)))
	(FIRST))) 

;;CONVERTS IF TO LISP "COND"

(DEFUN PARSEIF NIL 
       (PROG (TRUES FALSES) 
	     (COND ((EQ (CAR TOPARSE) 'TRUE)
		    (SETQ TOPARSE (CONS 'IFTRUE (CDR TOPARSE)))
		    (RETURN (PARSE NIL)))
		   ((EQ (CAR TOPARSE) 'FALSE)
		    (SETQ TOPARSE (CONS 'IFFALSE (CDR TOPARSE)))
		    (RETURN (PARSE NIL))))
	     (SETQ TRUES (LIST (PARSE 'IF)))
	     (AND (EQ (CAR TOPARSE) 'THEN) (POP TOPARSE))
	LOOP1(COND ((EOP) (GO DONE))
		   ((EQ (CAR TOPARSE) 'ELSE) (POP TOPARSE) (GO LOOP2)))
	     (PUSH (PARSE NIL) TRUES)
	     (GO LOOP1)
	LOOP2(COND ((EOP) (GO DONE))
		   ;;ANOTHER ELSE WILL TERMINATE PARSING OF ELSE CLAUSES.
		   ((EQ (CAR TOPARSE) 'ELSE) (GO DONE)))
	     (PUSH (PARSE NIL) FALSES)
	     (GO LOOP2)
	DONE (SETQ TRUES (NREVERSE TRUES))
	     (SETQ FALSES (NREVERSE FALSES))
	     (RETURN (COND (FALSES (LIST 'COND TRUES (CONS T FALSES)))
			   ((LIST 'COND TRUES)))))) 

(DEFUN PARSE-SETQ NIL 
       (PROG (PARSED) 
	     (AND (EOP)
		  (REREAD-ERROR '" - NO INPUTS TO SETQ"))
	     (SETQ PARSED (LIST FIRST))
	A    (AND (EOP) (RETURN (NREVERSE PARSED)))
	     (OR
	      (SYMBOLP (CAR TOPARSE))
	      (REREAD-ERROR
	       (LIST '"THE INPUT "
		     (CAR TOPARSE)
		     '" TO "
		     FIRST
		     '" WAS NOT A VALID VARIABLE NAME")))
	     (PUSH (CAR TOPARSE) PARSED)
	     ;;VARIABLE NAME
	     (POP TOPARSE)
	     (AND
	      (EOP)
	      (REREAD-ERROR
	       (LIST '" - WRONG NUMBER INPUTS TO"
		     FIRST)))
	     ;;VALUE
	     (PUSH (PARSE FIRST) PARSED)
	     (GO A))) 

(DEFUN PARSE-STORE NIL 
       ;;SPECIAL PARSING FUNCTION FOR STORE.  LISP STORE MANAGES TO GET CONFUSED BY
       ;;USER-PAREN FUNCTION TACKED ONTO ARRAY CALL ARGUMENT, EVEN THO USER-PAREN
       ;;DOES NOTHING [DON'T ASK ME WHY].  ALSO, MAKE A HALF-HEARTED ATTEMPT AT
       ;;MAKING 11LOGO-STYLE STORE WORK.
       (CONS FIRST
	     (LET ((ARRAY-CALL (PARSE 'STORE)))
		  (COND ((OR (ATOM ARRAY-CALL) (EQ (CAR ARRAY-CALL) 'QUOTE))
			 ;;11LOGO STYLE STORE.  STORE <ARRAY> <DIM1>..<DIM N>
			 ;;<VALUE>.
			 (LIST (COND ((EQ FLAG 'USER-PAREN)
				      ;;IF PARENTHESIZED, ALL BUT LAST ARGS ARE
				      ;;DIMS.
				      (DO ((DIMENSIONS NIL
						       (CONS (PARSE 'STORE)
							     DIMENSIONS)))
					  ((NULL (CDR TOPARSE))
					   (CONS ARRAY-CALL (NREVERSE DIMENSIONS)))))
				     ;;DEFAULT UNPARENTHESIZED PARSING IS 1 DIM. 
				     ;;ARRAY
				     ((LIST ARRAY-CALL (PARSE 'STORE))))
			       (PARSE 'STORE)))
			((EQ (CAR ARRAY-CALL) 'USER-PAREN)
			 ;;UNFORTUNATELY LOSES PAREN INFO HERE.  PERHAPS HAVE
			 ;;ADDITIONAL FUNCTION STORE-PAREN WHICH UNPARSES WITH
			 ;;PARENS?
			 (LIST (CADR ARRAY-CALL) (PARSE 'STORE)))
			((LIST ARRAY-CALL (PARSE 'STORE))))))) 

(DEFUN PARSE-BREAK NIL 
       (CONS FIRST
	     (AND TOPARSE
		  (CONS (CAR TOPARSE)
			(AND (POP TOPARSE)
			     (CONS (PARSE NIL) (AND TOPARSE (LIST (PARSE NIL))))))))) 

(DEFUN PARSE-DO NIL 
       (CONS FIRST
	     (LET ((VAR-SPECS (CAR TOPARSE)) (STOP-RULE (CADR TOPARSE)))
		  (COND ((AND VAR-SPECS (ATOM VAR-SPECS))
			 (PARSE-LEXPR-ARGS 4. 99999.))
			;;Old or new style DO?
			((CCONS (PARSE-VARIABLE-SPEC VAR-SPECS)
				;;Variable specs, stop rule...
				(LET ((TOPARSE STOP-RULE))
				     (PARSE-LEXPR-ARGS 0. 99999.))
				;;..and the body.
				(AND (SETQ TOPARSE (CDDR TOPARSE))
				     (PARSE-LEXPR-ARGS 0. 99999.)))))))) 

(DEFUN PARSE-VARIABLE-SPEC (VAR-SPECS) 
       (MAPCAR 
	'(LAMBDA (TOPARSE) 
	  (PROG1
	   (PARSE-LEXPR-ARGS 1. 3.)
	   (AND
	    TOPARSE
	    (REREAD-ERROR '"TOO MUCH IN DO VARIABLE LIST"))))
	VAR-SPECS)) 

;;IGNORE CARRIAGE RETURN WHICH MIGHT FIND ITS WAY INTO A FORM DUE TO MULTI-LINE
;;PARENTHESIZED FORM FEATURE.

(PUTPROP EOL '((PARSE NIL)) 'PARSE) 

(DEFUN PARSE-GO NIL 
       (AND (EQ (CAR TOPARSE) 'TO) (POP TOPARSE))
       (AND (EQ (CAR TOPARSE) 'LINE) (POP TOPARSE))
       (AND (EOP)
	    (REREAD-ERROR (LIST '"TOO FEW INPUTS TO GO")))
       (LIST FIRST (PARSE 'GO))) 

;; INSERTLINE-NUMBER IS A GLOBAL VARIABLE CHECKED BY PARSE-PROP.  IT IS SET TO LINE
;;NUMBER TO BE INSERTED.  IF AN UNDEFINED FUNCTION IS ENCOUNTERED, THROW A
;;PARSEMACRO BACK TO PARSELINE.

(SETQ INSERTLINE-NUMBER NIL) 

;;FOR LINES INSERTED BY USER CALLS TO INSERTLINE, THE FIRST THING IN THE LINE MUST
;;BE A NUMBER.  COMMENTS NOT INCLUDED BY INSERTLINE.

(DEFUN PARSE-INSERTLINE NIL 
       (LET
	((LINE-NUMBER (CAR TOPARSE)))
	(SETQ TOPARSE (CDR TOPARSE) FIRST NIL)
	(OR
	 (NUMBERP LINE-NUMBER)
	 (REREAD-ERROR
	  '"INSERTED LINE MUST BEGIN WITH NUMBER"))
	(AND
	 (BIGP LINE-NUMBER)
	 (REREAD-ERROR
	  (LIST LINE-NUMBER
		'"IS TOO BIG TO BE A LINE NUMBER")))
	(AND (EOP)
	     (REREAD-ERROR '"INSERTING EMPTY LINE? "))
	(CCONS 'INSERTLINE LINE-NUMBER (PARSE-FORM-LIST)))) 

(DEFUN PARSE-INSERT-LINE NIL 
       (LET
	((INSERTLINE-NUMBER (CAR TOPARSE)))
	(SETQ TOPARSE (CDR TOPARSE) FIRST NIL)
	(OR TOPARSE
	    (REREAD-ERROR '"NO CODE FOLLOWING LINE NUMBER?"))
	(AND
	 (BIGP INSERTLINE-NUMBER)
	 (REREAD-ERROR
	  (LIST INSERTLINE-NUMBER
		'"IS TO BIG TO BE A LINE NUMBER")))
	(NCONC (CCONS 'INSERT-LINE INSERTLINE-NUMBER (PARSE-FORM-LIST))
	       (AND TOPARSE
		    ;;(CAAR NIL) IS A NO-NO.
		    (EQ (CAAR TOPARSE) 'LOGO-COMMENT)
		    TOPARSE)))) 

;;;LINE CONTAINED A FUNCTION NAME WHICH DID NOT HAVE A DEFINITION AT COMPILE TIME. 

(DEFINE PARSEMACRO MACRO (X) 
 (LET
  ((OLD-LINE (CDDDR X))
   (PARSEMACRO-FN (CAR (CADDR X)))
   (NUMBER (CADR (CADDR X)))
   (OLD-FN FN)
   (PROMPTER '>))
  (DEFAULT-FUNCTION 'PARSEMACRO PARSEMACRO-FN)
  (LIST
   'PARSEMACRO-EVAL
   (LIST 'QUOTE
	 (COND 
	       ;;DOES FUNCTION HAVE A DEFINITION AT EXECUTION TIME? YES, REPARSE IT.
	       ((FUNCTION-PROP (CADR X))
		(EVALS (PARSELINE (PASS2 OLD-LINE)))
		((LAMBDA (THIS-LINE NEXT-TAG LAST-LINE) 
			 (GETLINE PROG NUMBER)
			 (DEFAULT-FUNCTION 'PARSEMACRO OLD-FN)
			 THIS-LINE)
		 NIL
		 NIL
		 NIL))
	       ;;NO, CAUSE ERROR. 
	       ((IOG NIL
		     (TYPE '";ERROR IN LINE "
			   NUMBER
			   '" OF "
			   PARSEMACRO-FN
			   '" - "
			   (CADR X)
			   '" IS AN UNDEFINED FUNCTION"
			   EOL)
		     ((LAMBDA (NEW-LINE) 
			      (DEFAULT-FUNCTION 'PARSEMACRO OLD-FN)
			      (TYPE '";CONTINUING EVALUATION"
				    EOL)
			      NEW-LINE)
		      (EDIT-LINE NUMBER))))))))) 

;;;     
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                   LOGO UNPARSER			    ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;

(DECLARE (OR (STATUS FEATURE DEFINE)
	     (COND ((STATUS FEATURE ITS)
		    ;;MULTICS?
		    (FASLOAD DEFINE FASL AI LLOGO))))) 

(SAVE-VERSION-NUMBER UNEDIT) 

(DECLARE (GENPREFIX UNEDIT)) 

;; ATOM-GOBBLER IS A FUNCTIONAL ARGUMENT TO THE UNPARSER WHICH GETS HANDED
;;SUCCESSIVE ATOMIC TOKENS OF THE UNPARSED LINE.  THE PRINTER USES AN ATOM-GOBBLER
;;WHICH PRINTS OUT EACH TOKEN.  FOR EDITING LINES, A LIST OF THE UNPARSED TOKENS IS
;;CONSTRUCTED. 

(DEFUN UNPARSE-LIST-OF-FORMS (ATOM-GOBBLER FORM-LIST) 
       (MAP '(LAMBDA (FORMS) (UNPARSE-FORM ATOM-GOBBLER (CAR FORMS))
			     ;;SPACES IN BETWEEN SUCCESSIVE FORMS.
			     (AND (CDR FORMS) (EXPR-CALL ATOM-GOBBLER '/ )))
	    FORM-LIST)) 

;;PRINTS OUT A LINE OF LOGO SOUCE CODE.

(DEFUN LOGOPRINC (TO-BE-PRINTED) 
       (UNPARSE-LIST-OF-FORMS (EXPR-FUNCTION DPRINC) TO-BE-PRINTED)) 

;;CALLED BY EDITOR TO RECONSTRUCT SOURCE CODE.

(DEFUN UNPARSE-LOGO-LINE (PARSED-LINE) 
       (LET ((UNPARSED-LINE))
	    (UNPARSE-LIST-OF-FORMS (EXPR-FUNCTION (LAMBDA (TOKEN) 
							  (PUSH TOKEN
								UNPARSED-LINE)))
				   PARSED-LINE)
	    (NREVERSE UNPARSED-LINE))) 

(DEFUN UNPARSE-PRINT-FORM (FORM) (UNPARSE-FORM (EXPR-FUNCTION DPRINC) FORM)) 

(DEFUN UNPARSE-EXPR-FORM NIL (UNPARSE-LIST-OF-FORMS ATOM-GOBBLER PARSED-FORM)) 


(DEFUN UNPARSE-ATOM (ATOM) 
       (COND ((= (FLATC ATOM) (FLATSIZE ATOM)) (EXPR-CALL ATOM-GOBBLER ATOM))
	     ((EXPR-CALL ATOM-GOBBLER '$)
	      (DO ((CHARNUM 1. (1+ CHARNUM)) (CHAR))
		  ((> CHARNUM (FLATC ATOM)))
		  (SETQ CHAR (GETCHAR ATOM CHARNUM))
		  (COND ((EQ CHAR '$)
			 (EXPR-CALL ATOM-GOBBLER '$)
			 (EXPR-CALL ATOM-GOBBLER '$))
			((EXPR-CALL ATOM-GOBBLER CHAR))))
	      (EXPR-CALL ATOM-GOBBLER '$)))) 

;;*PAGE

;;FIGURE OUT HOW TO UNPARSE BY FIGURING OUT HOW THE PARSER HANDLED IT.

(DEFUN UNPARSE-FORM (ATOM-GOBBLER PARSED-FORM) 
       (COND ((ATOM PARSED-FORM) (UNPARSE-ATOM PARSED-FORM))
	     ((LET ((CAR-FORM (CAR PARSED-FORM))
		    (CDR-FORM (CDR PARSED-FORM))
		    (UNPARSE-PROP))
		   (COND ((NOT (ATOM CAR-FORM))
			  (UNPARSE-LIST-OF-CONSTANTS ATOM-GOBBLER PARSED-FORM))
			 ((SETQ UNPARSE-PROP (GET CAR-FORM 'UNPARSE))
			  (EVAL UNPARSE-PROP))
			 ((SETQ UNPARSE-PROP (GET CAR-FORM 'UNPARSE-INFIX))
			  (UNPARSE-INFIX UNPARSE-PROP CDR-FORM))
			 ((AND (SETQ UNPARSE-PROP (GET CAR-FORM 'PARSE))
			       (COND ((CDR UNPARSE-PROP)
				      (UNPARSE-PARSE-PROP (CADR UNPARSE-PROP)))
				     ((UNPARSE-PARSE-PROP (CAR UNPARSE-PROP))))))
			 ((SETQ UNPARSE-PROP (HOW-TO-PARSE-INPUTS CAR-FORM))
			  (UNPARSE-PARSE-PROP UNPARSE-PROP))
			 ((UNPARSE-LIST-OF-CONSTANTS ATOM-GOBBLER PARSED-FORM))))))) 

;;WHAT CAN BE DONE ABOUT FUNCTIONS OF WHICH NOTHING IS KNOWN AT UNPARSE TIME? FOR
;;INSTANCE, THE FUNCTION MAY HAVE BEEN KNOWN AT PARSE TIME, BUT USER HAS SINCE
;;ERASED IT, READ A FILE CONTAINING CALL BUT NOT DEFINITION, ETC.  HE MAY THEN ASK
;;TO PRINT OUT OR EDIT IT, REQUIRING A DECISION ON UNPARSING.  PROBABLY THE BEST
;;THAT CAN BE DONE IS TO TREAT AS FEXPR- NOT DO FULL UNPARSING OF INPUTS.  USER MAY
;;GET FREAKED OUT, BUT UNPARSED REPRESENTATION WILL BE RE-PARSABLE.

(DEFUN UNPARSE-PARSE-PROP (PARSE-PROP) 
       (COND ((OR (NUMBERP PARSE-PROP) (EQ PARSE-PROP 'L))
	      (UNPARSE-EXPR-FORM))
	     ((EQ PARSE-PROP 'F)
	      (UNPARSE-LIST-OF-CONSTANTS ATOM-GOBBLER PARSED-FORM))
	     ((ATOM PARSE-PROP)
	      (ERRBREAK 'UNPARSE-PARSE-PROP
			(LIST '"SYSTEM BUG: "
			      CAR-FORM
			      '" HAS PARSE PROP "
			      PARSE-PROP
			      '" NEEDS UNPARSE PROP")))
	     ((AND (CDR PARSE-PROP) (ATOM (CDR PARSE-PROP))) (UNPARSE-EXPR-FORM))
	     [CLOGO ((EQ (CAR PARSE-PROP) 'PARSE-CLOGO-HOMONYM)
		     (UNPARSE-PARSE-PROP (CADDR PARSE-PROP)))]
	     ((EQ (CAR PARSE-PROP) 'PARSE-SUBSTITUTE) NIL)
	     ((ERRBREAK 'UNPARSE-PARSE-PROP
			(LIST '"SYSTEM BUG: "
			      CAR-FORM
			      '" HAS PARSE PROP "
			      PARSE-PROP
			      '" NEEDS UNPARSE PROP"))))) 

(DEFUN UNPARSE-SUBSTITUTE (FAKE-OUT) 
       (UNPARSE-FORM ATOM-GOBBLER (CONS FAKE-OUT CDR-FORM))) 

;;*PAGE

;;UNPARSING OF "CONSTANTS" [QUOTED THINGS, INPUTS TO FEXPRS] CONSISTS OF DOING:
;;; (QUOTE <SEXP>) --> '<SEXP>
;;; (SQUARE-BRACKETS (<S1> ... <SN>)) --> [<S1> ... <SN>]
;;; (DOUBLE-QUOTE <SEXP>) --> "<SEXP>"
;;; (DOUBLE-QUOTE (<S1>...<SN>)) --> "<S1> ... <SN>"
;;;AND PRINTING PARENS AROUND LISTS.

(DEFUN UNPARSE-LIST-OF-CONSTANTS (ATOM-GOBBLER PARSED-FORM) 
       (MAP '(LAMBDA (CONSTANTS) 
		     (UNPARSE-CONSTANT ATOM-GOBBLER (CAR CONSTANTS))
		     (AND (CDR CONSTANTS) (EXPR-CALL ATOM-GOBBLER '/ )))
	    PARSED-FORM)) 

(DEFUN UNPARSE-CONSTANT (ATOM-GOBBLER CONSTANT) 
       (COND ((ATOM CONSTANT) (UNPARSE-ATOM CONSTANT))
	     ((EQ (CAR CONSTANT) 'QUOTE)
	      (EXPR-CALL ATOM-GOBBLER '/')
	      (UNPARSE-CONSTANT ATOM-GOBBLER (CADR CONSTANT)))
	     ((EQ (CAR CONSTANT) 'DOUBLE-QUOTE)
	      (EXPR-CALL ATOM-GOBBLER '/")
	      (LET ((QUOTED (CADR CONSTANT)))
		   (COND ((ATOM QUOTED) (UNPARSE-ATOM QUOTED))
			 ((CDR QUOTED)
			  (UNPARSE-LIST-OF-CONSTANTS ATOM-GOBBLER QUOTED))
			 ((UNPARSE-CONSTANT ATOM-GOBBLER QUOTED))))
	      (EXPR-CALL ATOM-GOBBLER '/"))
	     ((EQ (CAR CONSTANT) 'SQUARE-BRACKETS)
	      (EXPR-CALL ATOM-GOBBLER '/[)
	      (UNPARSE-LIST-OF-CONSTANTS ATOM-GOBBLER (CADR CONSTANT))
	      (EXPR-CALL ATOM-GOBBLER '/]))
	     ((EXPR-CALL ATOM-GOBBLER '/()
	      (UNPARSE-LIST-OF-CONSTANTS ATOM-GOBBLER CONSTANT)
	      (EXPR-CALL ATOM-GOBBLER '/))))) 

(MAPC '(LAMBDA (QUOTER) (PUTPROP QUOTER '(UNPARSE-QUOTER) 'UNPARSE))
      '(QUOTE DOUBLE-QUOTE SQUARE-BRACKETS)) 

(DEFUN UNPARSE-QUOTER NIL (UNPARSE-CONSTANT ATOM-GOBBLER PARSED-FORM)) 

(DEFPROP LOGO-COMMENT (UNPARSE-COMMENT) UNPARSE) 

(DEFUN UNPARSE-COMMENT NIL 
       (DO NIL
	   ((NULL CDR-FORM))
	   (EXPR-CALL ATOM-GOBBLER (CAR CDR-FORM))
	   (POP CDR-FORM))) 

(DEFPROP USER-PAREN (UNPARSE-PAREN) UNPARSE) 

(DEFUN UNPARSE-PAREN NIL 
       (PROGN (EXPR-CALL ATOM-GOBBLER '/()
	      (UNPARSE-FORM ATOM-GOBBLER (CAR CDR-FORM))
	      (EXPR-CALL ATOM-GOBBLER '/)))) 

;;*PAGE

;;FOR ERROR MESSAGE PRINTOUTS, ETC.  CHANGE INTERNAL FUNCTION NAMES TO EXTERNAL
;;FORM.  HOMONYMS, INFIX.

(DEFUN UNPARSE-FUNCTION-NAME (PARSED-FUNCTION-NAME) 
       (COND ((GET PARSED-FUNCTION-NAME 'UNPARSE-INFIX))
	     ((LET ((UNPARSE-PROP (GET PARSED-FUNCTION-NAME 'UNPARSE)))
		   (COND ((EQ (CAR UNPARSE-PROP) 'UNPARSE-SUBSTITUTE)
			  (CADADR UNPARSE-PROP)))))
	     (PARSED-FUNCTION-NAME))) 

(DEFUN UNPARSE-INFIX (INFIX-OP ARGLIST) 
       (UNPARSE-FORM ATOM-GOBBLER (CAR ARGLIST))
       (COND ((CDR ARGLIST)
	      (EXPR-CALL ATOM-GOBBLER '/ )
	      (EXPR-CALL ATOM-GOBBLER INFIX-OP)
	      (EXPR-CALL ATOM-GOBBLER '/ )
	      (UNPARSE-INFIX INFIX-OP (CDR ARGLIST))))) 

(DEFPROP PARSEMACRO (UNPARSE-PARSEMACRO CDR-FORM) UNPARSE) 

(DEFUN UNPARSE-PARSEMACRO (OLD-LINE) 
       ;;POP OFF OLD-LINE UNTIL YOU HIT LINE NUMBER.
       (DO NIL
	   ((NUMBERP (CAR OLD-LINE))
	    (POP OLD-LINE)
	    (AND (EQ (CAR OLD-LINE) '/ ) (POP OLD-LINE))
	    (DO NIL
		((NULL OLD-LINE))
		(EXPR-CALL ATOM-GOBBLER (CAR OLD-LINE))
		(POP OLD-LINE)))
	   (POP OLD-LINE))) 

(DEFPROP COND (UNPARSE-COND CDR-FORM) UNPARSE) 

(DEFUN UNPARSE-COND (CLAUSES) 
       (EXPR-CALL ATOM-GOBBLER 'IF)
       (EXPR-CALL ATOM-GOBBLER '/ )
       (UNPARSE-FORM ATOM-GOBBLER (CAAR CLAUSES))
       (COND ((CDAR CLAUSES)
	      (EXPR-CALL ATOM-GOBBLER '/ )
	      (EXPR-CALL ATOM-GOBBLER 'THEN)
	      (EXPR-CALL ATOM-GOBBLER '/ )
	      (UNPARSE-LIST-OF-FORMS ATOM-GOBBLER (CDAR CLAUSES))))
       (COND ((CDR CLAUSES)
	      (EXPR-CALL ATOM-GOBBLER '/ )
	      (EXPR-CALL ATOM-GOBBLER 'ELSE)
	      (EXPR-CALL ATOM-GOBBLER '/ )
	      (UNPARSE-LIST-OF-FORMS ATOM-GOBBLER (CDADR CLAUSES))))) 

(DEFUN UNPARSE-DO NIL 
       (COND ((ATOM (CAR CDR-FORM)) (UNPARSE-EXPR-FORM))
	     ((MAPC '(LAMBDA (ATOM) (EXPR-CALL ATOM-GOBBLER ATOM))
		    '(DO /  /())
	      (MAP '(LAMBDA (VAR-SPEC) 
			    (EXPR-CALL ATOM-GOBBLER '/()
			    (UNPARSE-LIST-OF-FORMS ATOM-GOBBLER (CAR VAR-SPEC))
			    (EXPR-CALL ATOM-GOBBLER '/))
			    (AND (CDR VAR-SPEC) (EXPR-CALL ATOM-GOBBLER '/ )))
		   (CAR CDR-FORM))
	      (MAPC '(LAMBDA (ATOM) (EXPR-CALL ATOM-GOBBLER ATOM))
		    '(/) /  /())
	      (UNPARSE-LIST-OF-FORMS ATOM-GOBBLER (CADR CDR-FORM))
	      (EXPR-CALL ATOM-GOBBLER '/))
	      (EXPR-CALL ATOM-GOBBLER '/ )
	      (UNPARSE-LIST-OF-FORMS ATOM-GOBBLER (CDDR CDR-FORM))))) 

;; THESE ARE ONLY NECESSARY SINCE FUNCTIONS HAVE SPECIAL PARSE PROPS.

(MAPC '(LAMBDA (F) (PUTPROP F '(UNPARSE-EXPR-FORM) 'UNPARSE))
      '(INSERTLINE INSERT-LINE SETQ MAKEQ GO STORE)) 

;;*PAGE

;;			DEFINING LOGO PROCEDURES. 

(SETQ :REDEFINE NIL) 

;;INITIALLY, USER IS ASKED ABOUT ANY REDEFINITION.

(DEFINE TO FEXPR (X) 
 (AND (NOT EDT)
      :EDITMODE
      (EQ PROMPTER '>)
      (ERRBREAK 'TO
		(LIST '"YOU ARE ALREADY EDITING " FN)))
 (PROG (INPUTS COM NEW-FN) 
       (OR X
	   (AND (DEFAULT-FUNCTION 'TO NIL)
		(SETQ COM (AND (CDR TITLE) (CADR TITLE)) X (CDAR TITLE))
		(TYPE '";DEFINING " FN EOL)))
       ;;TYPE CHECK TO'S INPUTS.
       (LET ((:CONTENTS (CONS (CAR X) :CONTENTS)))
	    (SETQ NEW-FN (PROCEDUREP 'TO (CAR X)) 
		  ;;PROCEDUREP EXPECTS NEW-FN ON :CONTENTS.
		  INPUTS (CDR X)))
       ;;TO ALSO GETS CALLED WHILE EDITING TITLES.  EDT IS SET TO OLD PROCEDURE
       ;;NAME, GIVEN AS INPUT TO EDTITITLE.  CHECKED TO SEE WHAT'S APPROPRIATE FOR
       ;;EDITING TITLES.
       (AND
	(NOT :REDEFINE)
	;;:REDEFINE=T MEANS REDEFINITION WILL BE ALLOWED WITHOUT ASKING USER.
	(NOT (EQ EDT NEW-FN))
	(OR (MEMQ NEW-FN :CONTENTS) (MEMQ NEW-FN :COMPILED))
	(IOG
	 NIL
	 (TYPE
	  EOL
	  '/;
	  NEW-FN
	  '" IS ALREADY DEFINED. WOULD YOU LIKE TO REDEFINE IT?"))
	(COND ((ASK))
	      ;;ASK IF USER WANTS TO REDEFINE THE FUNCTION.  IF NOT, FROM CONSOLE,
	      ;;MERELY RETURN FROM TO.  FROM FILE, CHANGE TO DUMMY FUNCTION NAME TO
	      ;;SLURP UP LINES OF DEFINITION REMAINING.  A KLUDGE, ADMITTEDLY.
	      (^Q (LET ((DUMMY-HACK (ATOMIZE NEW-FN
					     '" NOT RE")))
		       (APPLY 'TO (LIST DUMMY-HACK))
		       (SETQ :CONTENTS (DELQ DUMMY-HACK :CONTENTS))
		       (RETURN NO-VALUE)))
	      ((RETURN (LIST '/; NEW-FN 'NOT 'REDEFINED))))
	(TYPE '";REDEFINING " NEW-FN EOL))
       (AND (CDR LOGOREAD)
	    ;;TITLE LINE COMMENT PROCESSED.
	    (EQ (CAADR LOGOREAD) 'LOGO-COMMENT)
	    (SETQ COM (CADR LOGOREAD))
	    (POP LOGOREAD))
       (COND
	((PRIMITIVEP NEW-FN)
	 (COND
	  (:REDEFINE (ERASEPRIM NEW-FN))
	  (T
	   (IOG
	    NIL
	    (TYPE
	     '/;
	     NEW-FN
	     '" IS USED BY LOGO. WOULD YOU LIKE TO REDEFINE IT?"))
	   (COND ((ASK))
		 ;;ASK IF USER WANTS TO REDEFINE THE FUNCTION.  IF NOT, FROM
		 ;;CONSOLE, MERELY RETURN FROM TO.  FROM FILE, CHANGE TO DUMMY
		 ;;FUNCTION NAME TO SLURP UP LINES OF DEFINITION REMAINING.  A
		 ;;KLUDGE, ADMITTEDLY.
		 (^Q (LET ((DUMMY-HACK (ATOMIZE NEW-FN
						'" NOT RE")))
			  (APPLY 'TO (LIST DUMMY-HACK))
			  (SETQ :CONTENTS (DELQ DUMMY-HACK :CONTENTS))
			  (RETURN NO-VALUE)))
		 ((RETURN (LIST '/; NEW-FN 'NOT 'REDEFINED))))
	   (TYPE '";REDEFINING " NEW-FN EOL)
	   (ERASEPRIM NEW-FN)))))
       ;;ARE ALL THE INPUTS TO FUNCTION BEING DEFINED KOSHER?
       (MAP '(LAMBDA (VARL) (RPLACA VARL (VARIABLEP 'TO (CAR VARL))))
	    INPUTS)
       (UNTRACE1 FN)
       (SETQ FN NEW-FN 
	     PROG (COND (EDT (EDITINIT EDT)) ((LIST 'PROG NIL '(END)))) 
	     TITLE (CONS (CCONS 'TO FN INPUTS) (AND COM (NCONS COM))) 
	     :BURIED (DELETE FN :BURIED))
       (UNITE FN ':CONTENTS)
       ;;FN ADDED TO :CONTENTS.
       (PUTPROP FN
		(COND (COM (LIST 'LAMBDA INPUTS COM PROG))
		      ((LIST 'LAMBDA INPUTS PROG)))
		'EXPR)
       (OR EDT (NOT :EDITMODE) (SETQ PROMPTER '>))
       (RETURN NO-VALUE))) 

;;; END DOES NOT HAVE TO BE TYPED TO TERMINATE EDITING OF A PROCEDURE.
;;; IF USER TYPES IT, IT JUST TYPES BACK COMFORTING MESSAGE AND CHANGES PROMPTER TO
;;? SO AS
;;; NOT TO FREAK OUT 11 LOGO & CLOGO USERS. INSIDE A PROCEDURE, RETURNS ?.

(DEFINE END (PARSE (PARSE-END)) NIL (OUTPUT NO-VALUE)) 

(DEFUN PARSE-END NIL 
       (SETQ PROMPTER NO-VALUE)
       (TYPE '/; FN '" DEFINED" EOL)) 

(DEFINE LOCAL (SYN COMMENT)) 

;;*PAGE

;;			LOGO EDITOR

(SETQ LAST-LINE NIL NEXT-TAG NIL THIS-LINE NIL FN NIL PROG NIL TITLE NIL) 

;;; FIRST INPUT TO DEFAULT-FUNCTION IS NAME OF CALLER TO BE USED IN ERROR MESSAGES
;;; IF NECESSARY. 
;;;	2ND ARG = NIL -> CHECK IF DEFAULT FUNCTION EXITS.
;;;	2ND ARG = FUNCTION NAME ->  RESET DEFAULT FUNCTION TO 
;;;		2ND ARG, IF IT IS NOT ALREADY.
;;; SETS GLOBAL VARIABLES:
;;;	FN <- CURRENT DEFAULT FUNCTION.
;;;	PROG <- POINTER TO FN'S PROG.
;;;	TITLE <- POINTER TO FN'S TITLE [AND TITLE LINE COMMENTS]

(DEFUN DEFAULT-FUNCTION (CALLER FUNCTION) 
       (COND
	(FUNCTION (OR (EQ FN FUNCTION)
		      (SETQ FN (PROCEDUREP CALLER FUNCTION) 
			    PROG (EDITINIT1 FN) 
			    TITLE (CAR PROG) 
			    PROG (CADR PROG)))
		  FN)
	(FN)
	((DEFAULT-FUNCTION
	  CALLER
	  (ERRBREAK
	   CALLER
	   '"YOU HAVEN'T SPECIFIED A PROCEDURE NAME"))))) 

;;; NOTE THAT LOGO-EDIT DOES NOTHING EXCEPT CHANGE DEFAULT FUNCTION IF
;;; GIVEN INPUT. PROMPTER CHANGED AS CONCESSION TO CLOGO & 11 LOGO USERS.

(DEFINE EDIT (PARSE (PARSE-SUBSTITUTE 'LOGO-EDIT))) 

;;EDIT OF NO ARGS USES THE DEFAULT FN.

(DEFINE LOGO-EDIT (ABB ED) (UNPARSE (UNPARSE-SUBSTITUTE 'EDIT)) FEXPR (WHAT-FUNCTION) 
	(AND :EDITMODE
	     (EQ PROMPTER '>)
	     (ERRBREAK 'LOGO-EDIT
		       (LIST '"YOU ARE ALREADY EDITING"
			     FN)))
	(DEFAULT-FUNCTION 'LOGO-EDIT (AND WHAT-FUNCTION (CAR WHAT-FUNCTION)))
	(AND :EDITMODE (SETQ PROMPTER '>))
	(LIST '/; 'EDITING FN)) 

;;RETURNS FIRST PROG OF FN

(DEFUN EDITINIT (FN) (CADR (EDITINIT1 FN))) 

(DEFUN EDITINIT1 (FN) 
       ;;CAR OF OUTPUT IS TITLE LINE + COMMENTS.  CADR OF OUTPUT IS PROG.
       (OR (MEMQ FN :CONTENTS)
	   (SETQ FN (ERRBREAK 'EDITINIT1
			      (LIST FN
				    '"NOT IN WORKSPACE"))))
       (PROG (DEF INPUTS TITLE) 
	     (SETQ DEF (TRACED? FN))
	     (SETQ INPUTS (CADR DEF) DEF (CDDR DEF))
	     (SETQ TITLE (LIST (APPEND (LIST 'TO FN) INPUTS)))
	COM  (COND ((EQ 'PROG (CAAR DEF))
		    (RETURN (CONS (NREVERSE TITLE) DEF)))
		   ((PUSH (CAR DEF) TITLE) (SETQ DEF (CDR DEF)) (GO COM))))) 

(DEFINE ERASELINE (ABB ERL) (ERASE-LINE-NUMBER) 
 (DEFAULT-FUNCTION 'ERASELINE NIL)
 (TYPE '";ERASING LINE "
       ERASE-LINE-NUMBER
       '" OF "
       FN
       EOL)
 (LET
  ((THIS-LINE) (NEXT-TAG) (LAST-LINE))
  (GETLINE PROG
	   (SETQ ERASE-LINE-NUMBER (NUMBER? 'ERASELINE ERASE-LINE-NUMBER)))
  (ERASE-LOCALS PROG THIS-LINE)
  (COND
   (THIS-LINE (RPLACD LAST-LINE NEXT-TAG) NO-VALUE)
   ((SETQ ERASE-LINE-NUMBER
	  (ERRBREAK 'ERASELINE
		    (LIST '"NO LINE NUMBERED"
			  ERASE-LINE-NUMBER
			  '" IN "
			  FN)))
    (ERASELINE ERASE-LINE-NUMBER))))) 

;;FLAG USED BY "TO".

(SETQ EDT NIL INPUT-LIST GENSYM) 

(DEFINE EDITTITLE (ABB EDT) FEXPR (OPTIONAL-FUNCTION) 
	(DEFAULT-FUNCTION 'EDITTITLE
			  (AND OPTIONAL-FUNCTION (CAR OPTIONAL-FUNCTION)))
	(EDT1 (REPAIR-LINE (UNPARSE-LOGO-LINE TITLE)))) 

(DEFINE TITLE (PARSE L) FEXPR (X) (EDT1 X)) 

(DEFUN EDT1 (LOGOREAD) 
       (LET
	((EDT FN) (INPUT-LIST (CDDAR TITLE)))
	(OR
	 (EQ (CAAR LOGOREAD) 'TO)
	 (SETQ 
	  LOGOREAD
	  (ERRBREAK
	   'EDITTITLE
	   '"EDIT TITLE - TITLE LINE MUST BEGIN WITH TO")))
	(EVAL (CAR LOGOREAD))
	(COND ((NOT (EQ EDT FN))
	       (REMPROP EDT 'EXPR)
	       (SETQ :CONTENTS (DELETE EDT :CONTENTS) :BURIED (DELETE EDT :BURIED))
	       ;;CHANGE FUNCTION NAMES IN PARSEMACROS INSIDE DEFINITION.
	       (MAPC '(LAMBDA (FORM) (COND ((ATOM FORM))
					   ((EQ (CAR FORM) 'PARSEMACRO)
					    (RPLACA (CADDR FORM) FN))))
		     PROG)
	       (TYPE '";PROCEDURE NAME CHANGED FROM "
		     EDT
		     '" TO "
		     FN
		     EOL))
	      ((NOT (EQUAL INPUT-LIST (CADR (GET FN 'EXPR))))
	       (TYPE '";INPUTS CHANGED TO "
		     (CADR (GET FN 'EXPR))
		     EOL))
	      ((TYPE '";TITLE NOT CHANGED" EOL))))) 

;;; SYNTAX: INSERTLINE <NUMBER> <FORM> <FORM> ....<FORM> <RETURN>
;;; INSERTS IN DEFAULT FUNCTION. MUST BE ONLY FORM ON LINE.
;;; NO REASON TO BE CALLED BY USER, SINCE LINE BEGINNING WITH NUMBER
;;; GETS PARSED AS INSERTLINE.
;;THE ONLY DIFFERENCE BETWEEN THESE TWO LINE INSERTING FUNCTIONS IS THAT FOR USE IN
;;USER PROCEDURES, THE LINE MUST BE COPIED.  THIS IS NOT NECESSARY FOR AUTOMATICALLY
;;INSERTED LINES.

(DEFINE INSERTLINE (ABB INL) (PARSE (PARSE-INSERTLINE)) FEXPR (NEW-LINE) 
	(APPLY 'INSERT-LINE (SUBST NIL NIL NEW-LINE))
	(LIST '";INSERTING LINE"
	      (CAR NEW-LINE)
	      'INTO
	      FN)) 

(DEFINE INSERT-LINE (PARSE (PARSE-INSERT-LINE)) FEXPR (NEW-LINE) 
	(DEFAULT-FUNCTION 'INSERT-LINE NIL)
	(LET ((THIS-LINE) (NEXT-TAG) (LAST-LINE))
	     (GETLINE PROG (CAR NEW-LINE))
	     (ADDLINE PROG NEW-LINE))
	NO-VALUE) 

;;; GETLINE SETS THINGS UP TO MODIFY PROCEDURE LINES.
;;; LAST-LINE <- PIECE OF PROG WHOSE CADR IS <TAG>, WHOSE
;;;              CAR IS LAST FORM BEFORE <TAG>.
;;; THIS-LINE <- LIST OF FORMS ON LINE NUMBER <TAG>.
;;; NEXT-TAG <- REMAINDER OF PROG STARTING WITH LINE FOLLOWING
;;;             LINE NUMBER <TAG>.
;;;
;;; EXAMPLE: IF (GET '#FOO 'EXPR) IS
;;;       (LAMBDA (:N) (PROG NIL 10 (TYPE 'F) 20 (TYPE'O)  30
;;;            (TYPE 'OBAR) (END)))
;;; THEN (GETLINE (EDITINIT '#FOO) 20)  MAKES
;;; THIS-LINE <- ((TYPE 'O))
;;;  NEXT-TAG <- (30 (TYPE 'OBAR) (END))
;;; LAST-LINE <- ((TYPE 'F) 20 (TYPE 'O) 30 (TYPE 'OBAR) (END))
;;IF NO PROG DEFINITION, NEXT-TAG <- PROG <- THIS-LINE <- NIL.  IF LINE NUMBER >
;;THAN <TAG> IS FOUND, THIS-LINE <- NIL, NEXT-TAG <- REMAINDER OF PROG STARTING WITH
;;FIRST HIGHER LINE NUMBER.  LAST-LINE IS REMAINDER OF PROG WHOSE CAR IS FORM BEFORE
;;(CAR NEXT-TAG).

(DEFUN GETLINE (PROG TAG) 
       (PROG (LINE-NO) 
	LOOP (SETQ PROG (CDR PROG) LAST-LINE PROG THIS-LINE NIL LINE-NO (CADR PROG))
	     (COND ((EQUAL LINE-NO '(END)) (POP PROG) (GO NO-LINE))
		   ((NOT (NUMBERP LINE-NO)) (GO LOOP)))
	     (POP PROG)
	     (COND ((EQUAL LINE-NO TAG)
		    (RETURN (SETQ PROG
				  (CDR PROG)
				  THIS-LINE
				  (CONS (CAR PROG) THIS-LINE)
				  PROG
				  (CDR PROG)
				  NEXT-TAG
				  (DO NIL
				      ((OR (NUMBERP (CAR PROG))
					   (EQUAL (CAR PROG) '(END)))
				       PROG)
				      (SETQ THIS-LINE (CONS (CAR PROG) THIS-LINE) 
					    PROG (CDR PROG)))
				  THIS-LINE
				  (NREVERSE THIS-LINE))))
		   ((LESSP LINE-NO TAG) (GO LOOP)))
	NO-LINE
	     (RETURN (SETQ NEXT-TAG PROG THIS-LINE NIL)))) 

;;ADDLINE REQUIRES THE GLOBAL VARIABLES THIS-LINE, NEXT-TAG, AND LAST-LINE, AS SET
;;BY GETLINE.

(DEFUN ADDLINE (PROG EDITED) 
       ;;EDITED = (NUMBER (CALL) (CALL) ...).
       (COND ((CDR EDITED)
	      (ERASE-LOCALS PROG THIS-LINE)
	      ;;IF THE LINE CONTAINED LOCAL VARIABLE DECLARATIONS, THE PROG MUST BE
	      ;;MODIFIED.
	      (MAPC 
	       '(LAMBDA (FORM) 
			(COND ((EQ (CAR FORM) 'LOCAL)
			       (MAPC 'EDIT-LOCAL (CDR FORM)))
			      ;;MAKE TESTFLAG LOCAL TO ANY PROCEDURE HARBORING A
			      ;;TEST.
			      ((EQ (CAR FORM) 'TEST)
			       (OR (MEMQ 'TESTFLAG (CADR PROG))
				   (RPLACA (CDR PROG)
					   (CONS 'TESTFLAG (CADR PROG)))))))
	       (CDR EDITED))
	      (RPLACD LAST-LINE EDITED)
	      (NCONC EDITED NEXT-TAG)))) 

(DEFUN MAKLOGONAM (VAR) 
       ;;MAKES A LOGO VARIABLE NAME OUT OF VAR.
       (LET
	((OBARRAY LOGO-OBARRAY))
	(COND
	 ((SYMBOLP VAR)
	  (COND ((EQ (GETCHAR VAR 1.) ':) VAR)
		((IMPLODE (CONS ': (EXPLODEC VAR))))))
	 ((MEMQ (CAR VAR) '(DOUBLE-QUOTE QUOTE))
	  (IMPLODE (CONS ': (EXPLODEC (CADR VAR)))))
	 ((ERRBREAK
	   'MAKLOGONAM
	   (LIST VAR
		 '" IS NOT A VALID VARIABLE NAME")))))) 

;;THE VAR IS ADDED TO THE LOCAL VARS OF PROG.  IF ALREADY PRESENT, A WARNING IS
;;ISSUED.

(DEFUN EDIT-LOCAL (VAR) 
       (SETQ VAR (MAKLOGONAM VAR))
       (COND
	((MEMQ VAR (CADR PROG))
	 (TYPE '";WARNING- "
	       VAR
	       '" IS ALREADY A LOCAL VARIABLE"
	       EOL))
	((EQ (GET VAR 'SYSTEM-VARIABLE) 'READ-ONLY)
	 (ERRBREAK
	  'LOCAL
	  (LIST
	   VAR
	   '"CAN'T BE LOCAL BECAUSE IT'S USED BY LOGO")))
	((RPLACA (CDR PROG) (CONS VAR (CADR PROG)))))) 

;;THE LOCAL VARS IF ANY OF THE OLD LINE ARE DELETED FROM THE PROG.

(DEFUN ERASE-LOCALS (PROG LINES) 
       (MAPC '(LAMBDA (X) (AND (EQ (CAR X) 'LOCAL)
			       (RPLACA (CDR PROG)
				       (SET- (CADR PROG)
					     (MAPCAR 'MAKLOGONAM (CDR X))))))
	     LINES)) 

;;*PAGE

;;BURYING A PROCEDURE MAKES IT INVISIBLE TO PRINTOUT PROCEDURES, PRINTOUT ALL, ERASE
;;PROCEDURES, ERASE ALL, PRINTOUT TITLES, COMPILE, SAVE, AND WRITE.  INTENDED FOR A
;;PACKAGE OF FUNCTIONS WHICH YOU WANT TO BE "THERE" BUT NOT CONSIDERED AS PART OF
;;YOUR WORKSPACE WHEN USING THE ABOVE FUNCTIONS.  ERASE BURY UNDOES THE EFFECT OF
;;BURY.  A LIST OF BURIED PROCEDURES IS KEPT AS :BURIED.

(DEFINE BURY FEXPR (TO-BE-BURIED) 
	(OR TO-BE-BURIED
	    (SETQ TO-BE-BURIED
		  (LIST (ERRBREAK 'BURY
				  '"BURY WHAT??"))))
	(AND (EQ (CAR TO-BE-BURIED) 'ALL) (SETQ TO-BE-BURIED :CONTENTS))
	(MAPC 'INTERNAL-BURY TO-BE-BURIED)
	(CONS '/; (APPEND TO-BE-BURIED '(BURIED)))) 

(DEFUN INTERNAL-BURY (BURY-IT) 
       (COND ((MEMQ BURY-IT :BURIED))
	     ((MEMQ BURY-IT :CONTENTS) (PUSH BURY-IT :BURIED))
	     (T (SETQ BURY-IT
		      (ERRBREAK 'BURY
				(LIST BURY-IT
				      '"NOT FOUND")))
		(INTERNAL-BURY BURY-IT)))) 

(DEFINE ERASEBURY (ABB ERB) FEXPR (UNCOVER) 
	(OR UNCOVER
	    (SETQ UNCOVER
		  (LIST (ERRBREAK 'ERASEBURY
				  '"ERASE BURY WHAT??? "))))
	(AND (EQUAL UNCOVER '(ALL)) (SETQ UNCOVER :BURIED))
	(MAPC 'INTERNAL-ERASE-BURY UNCOVER)
	(CONS '/; (APPEND UNCOVER '(NO LONGER BURIED)))) 

(DEFUN INTERNAL-ERASE-BURY (UNBURY) 
       (OR (MEMQ UNBURY :BURIED)
	   (SETQ UNBURY (ERRBREAK 'ERASEBURY
				  (LIST UNBURY
					'"NOT BURIED"))))
       (SETQ :BURIED (DELETE UNBURY :BURIED))) 

;;*PAGE

;;THE ONLY DIFFERENCE BETWEEN THESE TWO VERSIONS OF EDITLINE IS THAT FOR INTERNAL
;;USE, EDIT-LINE RETURNS PARSED LINE, FOR LOGO USER, EDITLINE DOES NOT.

(DEFINE EDITLINE (ABB EDL) (NUMBER) (EDIT-LINE NUMBER) NO-VALUE) 

;; THIS VERSION OF EDIT-LINE PROVIDES TYPE CHECKING, PRINT OUT OF OLD LINE, ETC. 
;;NOTE THAT FOR EDITING LINES, ALL THAT IS NECESSARY IS (SETQ OLD-LINE <UNPARSED
;;VERSION OF OLD LINE NUMBER>)

(DEFUN EDIT-LINE (NUMBER) 
       (DEFAULT-FUNCTION 'EDIT-LINE NIL)
       (LET
	((NUMBER (NUMBER? 'EDIT-LINE NUMBER))
	 (LAST-LINE)
	 (THIS-LINE)
	 (NEXT-TAG)
	 (PROMPTER '>))
	(GETLINE PROG NUMBER)
	(OR
	 THIS-LINE
	 (GETLINE
	  PROG
	  (SETQ NUMBER
		(ERRBREAK 'EDIT-LINE
			  (LIST '"NO LINE NUMBERED "
				NUMBER
				'" IN "
				FN)))))
	(TYPE '";EDITING LINE "
	      NUMBER
	      '" OF "
	      FN)
	(LET ((^W)
	      (^R)
	      (NEW-PARSE (REPAIR-LINE (UNPARSE-LOGO-LINE (CONS NUMBER THIS-LINE))))
	      (COPY))
	     (COND ((EQ (CAAR NEW-PARSE) 'INSERT-LINE)
		    (SETQ COPY (APPEND (CDDAR NEW-PARSE) NIL))
		    (EVALS NEW-PARSE)
		    COPY)
		   ((TYPE '";LINE MUST BEGIN WITH A NUMBER"
			  EOL)
		    (EDIT-LINE NUMBER)))))) 

;;WHAT IS THE USER'S INTENTION IN TYPING A LINE STARTING WITH A NUMBER OTHER THAN HE
;;HANDED TO EDITLINE? DOES HE EXPECT OLD LINE NUMBER TO REMAIN? CLOGO & 11LOGO
;;RETAIN OLD NUMBERED LINE.
;;;
;;;
;;REPAIR-LINE TAKES AS INPUT A LINE OF TOKENS, FOR INSTANCE, AS WOULD BE SAVED IN
;;OLD-LINE.  IT RETURNS A CORRECTLY PARSED LINE.

(DEFUN REPAIR-LINE (OLD-LINE) 
       (LET ((PROMPTER '>))
	    (DTERPRI)
	    (MAPC 'DPRINC OLD-LINE)
	    (DTERPRI)
	    (DPRINC PROMPTER)
	    (LOGOREAD))) 

;;*PAGE

;;;      LOGO EDITING CHARACTERS.
;;MAYBE A BETTER IMPLEMENTATION WOULD BE FOR THESE CHARS TO BE LINE-READMACROS WHICH
;;HAPPEN INSIDE THE LINE FUNCTION.  THIS WILL ALLOW PROPER HANDLING OF INFIX MINUS
;;AS WELL AS RUBOUT.  THE IMPLEMENTATION COULD BE THAT LINE CHECKS FOR A "LINEMACRO"
;;PROPERTY.  IF IT FINDS ONE, THEN THE APPROPRIATE ACTION HAPPENS.

[ITS (DEFUN COVER-UP NIL 
	    ;;ON DISPLAY TERMINALS, MAKE CONTROL CHARACTERS DISAPPEAR.
            (COND ((ZEROP TTY))
                  ;;PRINTING TERMINALS OR ARDS'S LOSE.
                  ((= TTY 4.))
                  (T (CURSORPOS 'X) (COND (SAIL) ((CURSORPOS 'X))))))] 

[(OR ITS DEC10) (DEFUN CONTROL-P NIL 
		       ;;CONTROL-P DELETES LAST WORD -- POPS END OF NEW LINE.
		       [ITS (COVER-UP)]
		       (AND
			LINE
			(PROG (^W) 
			 A    (COND
			       ((EQ (CAR LINE) '/ )
				(COND [ITS ((MEMBER TTY '(1. 2. 3. 5.))
					    (CURSORPOS 'X))]
				      ((DPRINC '/ )))
				(POP LINE)
				(GO A))
			       (T
				(MAPC 
				 (COND
				  [ITS ((MEMBER TTY '(1. 2. 3. 5.))
					'(LAMBDA (X) (CURSORPOS 'X)))]
				  ('DPRINC))
				 (NREVERSE (EXPLODEC (CAR LINE))))
				(POP LINE)))))) 
		(DEFUN CONTROL-N NIL 
		       ;; MOVE NEXT WORD FROM THE FRONT OF THE OLD LINE TO THE END
		       ;;OF THE NEW LINE.
		       [ITS (COVER-UP)]
		       (DO NIL
			   ((NOT (EQ (CAR OLD-LINE) '/ )) NIL)
			   (DPRINC '/ )
			   (PUSH '/  LINE)
			   (POP OLD-LINE))
		       (COND (OLD-LINE (DPRINC (CAR OLD-LINE))
				       (PUSH (CAR OLD-LINE) LINE)
				       (POP OLD-LINE)
				       (COND ((NULL OLD-LINE)
					      (DPRINC '/ )
					      (PUSH '/  LINE))
					     ((EQ (CAR OLD-LINE) '/ )
					      (POP OLD-LINE)
					      (DPRINC '/ )
					      (PUSH '/  LINE)))))) 
		(DEFUN CONTROL-R NIL 
		       ;;MOVE THE REST OF THE OLD LINE ON TO THE END OF THE NEW
		       ;;LINE.
		       (IOC T)
		       [ITS (COVER-UP)]
		       (DO NIL
			   ((NULL OLD-LINE)
			    (COND ((EQ (CAR LINE) '/ ))
				  ((DPRINC '/ ) (PUSH '/  LINE)))
			    NIL)
			   (DPRINC (CAR OLD-LINE))
			   (PUSH (CAR OLD-LINE) LINE)
			   (POP OLD-LINE))) 
		(DEFUN CONTROL-S NIL 
		       ;;POP FRONT OF THE OLD LINE.
		       [ITS (COVER-UP)]
		       (DO NIL
			   ((NOT (EQ (CAR OLD-LINE) '/ ))
			    (AND OLD-LINE (POP OLD-LINE))
			    NIL)
			   (POP OLD-LINE)))] 

;;*PAGE


;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;			LLOGO PRINTING FUNCTIONS.            ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;

(DECLARE (OR (STATUS FEATURE DEFINE)
	     (COND ((STATUS FEATURE ITS)
		    ;;MULTICS?
		    (FASLOAD DEFINE FASL AI LLOGO))))) 

(SAVE-VERSION-NUMBER PRINT) 

(DECLARE (GENPREFIX PRINT)) 

[(OR MULTICS DEC10) (DEFINE DPRINC (SYN PRINC)) 
		    (DEFINE DTERPRI (SYN TERPRI))] 

[ITS (DEFUN DPRINC (X) (SUBRCALL NIL DPRINC X))
     (DEFUN DTERPRI NIL (SUBRCALL NIL DTERPRI))
     ;;WATCH IT, THESE ARE LSUBRS IN NEWIO!
     (SETQ DPRINC (GET 'PRINC 'SUBR) DTERPRI (GET 'TERPRI 'SUBR))] 

(DEFUN DPRINT (X) (DTERPRI) (DPRIN1 X) (DPRINC '/ )) 

(DEFUN DPRIN1 (X) 
       (COND ((NUMBERP X) (DPRINC X))
             ((ATOM X) 
              (COND ((= (FLATC X) (FLATSIZE X)) (DPRINC X))
                    ((MAPC 'DPRINC (LIST '$ X '$)))))
	     ((DPRINC '/() 
              (DO ((REST-LIST X (CDR REST-LIST)))
                  ((COND ((NULL REST-LIST) (DPRINC '/)))
                         ((ATOM REST-LIST) 
                          (DPRINC '" . ") (DPRIN1 REST-LIST) (DPRINC '/)))))
                  (DPRIN1 (CAR REST-LIST))
                  (AND (CDR REST-LIST) (DPRINC '/  ))))))

(DEFUN DPRINTL ARGS 
       (DO ARG-INDEX 1. (1+ ARG-INDEX) (> ARG-INDEX ARGS) 
           (DPRINC (ARG ARG-INDEX)) (DPRINC '/ ))
       (DTERPRI)) 

(DEFUN DPRINCSP (X) (DPRINC X) (DPRINC '/ )) 

(DEFINE PRINT (PARSE (PARSE-SUBSTITUTE 'LOGO-PRINT))) 

(DEFINE LOGO-PRINT (UNPARSE (UNPARSE-SUBSTITUTE 'PRINT)) (ABB P PR) (PARSE 1. L) ARGS 
	(DO I 1. (1+ I) (> I ARGS) (TYPE (ARG I)) (DTERPRI))
	NO-VALUE) 

(DEFINE FPRINT (ABB FP) (PARSE 1. L) ARGS 
	(DO I 1. (1+ I) (> I ARGS) (DPRIN1 (ARG I)))
	?) 

(DEFINE TYPE (PARSE 1. L) ARGS (DO ((I 1. (1+ I)))
				   ((> I ARGS) NO-VALUE)
				   (COND ((ATOM (ARG I)) (DPRINC (ARG I)))
					 ((DO ((TYPE-ARG (ARG I) (CDR TYPE-ARG)))
					      ((ATOM (CDR TYPE-ARG))
					       (DPRINC (CAR TYPE-ARG))
					       (AND (CDR TYPE-ARG)
						    (DPRINC '/ /./ )
						    (DPRINC (CDR TYPE-ARG))))
					      (DPRINCSP (CAR TYPE-ARG))))))) 

(DEFINE BLANK NIL (DPRINC '/ ) NO-VALUE) 

(DEFINE CARRIAGERETURN (ABB CR) NIL (DPRINC EOL) NO-VALUE) 

(DEFINE LINEFEED NIL NIL (DPRINC (ASCII 10.)) NO-VALUE) 

[MULTICS (DEFINE PRETTY (NEWLINEL) 
		 ;;UPDATES CHRCT AND LINEL.  IDENTICAL TO "NEWLINEL" IN GRIND.
		 (CHRCT NIL (+ (CHRCT NIL) (- NEWLINEL (LINEL NIL))))
		 (LINEL NIL NEWLINEL))] 

[(OR ITS DEC10) (DEFINE PRETTY (NEWLINEL) (SETQ CHRCT (+ CHRCT (- NEWLINEL LINEL)))
					  (SETQ LINEL NEWLINEL))] 

;;THE DPRIN FNS PRINT ON DISPLAY AS WELL AS AT TTY IF :SHOW = T.  IF TRUE, THE
;;DPRINT FNS OUTPUT TO 6.

(SETQ :SHOW NIL) 

;;LISTING

(DEFINE PRINTOUT (ABB PO) FEXPR (X) 
	(COND ((NULL X) (LIST-PROCEDURE FN))
	      ((MEMQ (CAR X) '(ABBREVIATIONS ABBS)) (PRINTOUTABBREVIATIONS))
	      ((MEMQ (CAR X) '(NAMES :NAMES)) (PRINTOUTNAMES))
	      ((EQ (CAR X) 'PROCEDURES) (PRINTOUTPROCEDURES))
	      ((EQ (CAR X) 'ALL)
	       (PRINTOUTPROCEDURES)
	       (DTERPRI)
	       (PRINTOUTNAMES))
	      ((MEMQ (CAR X) '(CONTENTS :CONTENTS TITLES)) (PRINTOUTCONTENTS))
	      ((EQ (CAR X) 'TITLE) (APPLY 'PRINTOUTTITLE (CDR X)))
	      ((EQ (CAR X) 'LINE) (PRINTOUTLINE (CADR X)))
	      ((MEMQ (CAR X) '(PRIMITIVES :PRIMITIVES)) (PRINTOUTPRIMITIVES))
	      ((EQ (CAR X) 'FILE) (APPLY 'PRINTOUTFILES (CDR X)))
	      [(OR ITS MULTICS) ((MEMQ (CAR X) '(INDEX FILES))
				 (APPLY 'PRINTOUTINDEX (CDR X)))]
	      [ITS ((MEMQ (CAR X) '(SNAPS :SNAPS)) (PRINTOUTSNAPS))]
	      ((MAPC 'LIST-PROCEDURE X)))
	?) 

(DEFINE CONTENTS NIL (DELEET :CONTENTS :BURIED)) 

[CLOGO (DEFINE LIST (PARSE (PARSE-CLOGO-HOMONYM PRINTOUT L)))] 

(DEFINE PRINTOUTCONTENTS (ABB LC LISTCONTENTS POC POTS) NIL 
	(MAPC '(LAMBDA (USER-PROCEDURE) 
		       (OR (MEMQ USER-PROCEDURE :BURIED)
			   (LOGOPRINT (CAR (EDITINIT1 USER-PROCEDURE)))))
	      :CONTENTS)
	NO-VALUE) 

(DEFINE PRINTOUTSNAPS (ABB LISTSNAPS) NIL (AND :SNAPS (TYPE :SNAPS EOL)) NO-VALUE) 

(DEFINE PRINTOUTPROCEDURES (ABB LISTPROCEDURES LPR POPR) NIL 
	(MAPC '(LAMBDA (USER-PROCEDURE) (OR (MEMQ USER-PROCEDURE :BURIED)
					    (LIST-PROCEDURE USER-PROCEDURE)
					    (DTERPRI)))
	      :CONTENTS)
	?) 

(DEFINE PRINTOUTTITLE (ABB LISTTITLE POT) FEXPR (OPTFUNCTION) 
	(DEFAULT-FUNCTION 'PRINTOUTTITLE (AND OPTFUNCTION (CAR OPTFUNCTION)))
	(LOGOPRINT TITLE)
	NO-VALUE) 

(DEFINE PRINTOUTALL (ABB POA LISTALL) NIL (PRINTOUTPROCEDURES) (PRINTOUTNAMES) ?) 

(DEFINE PRINTOUTFILE (ABB POF LISTFILE) FEXPR (FILENAME) 
	;;TAKES A FILE NAME AS INPUT AND PRINTS THE FILE.
	(APPLY 'UREAD (FILESPEC FILENAME))
	(SETQ ^Q T)
	(DO ((CHARNUM (TYI -1.) (TYI -1.)))
	    ((OR (NULL ^Q) (MINUSP CHARNUM)) (SETQ ^Q NIL) (TERPRI))
	    (OR (= CHARNUM 12.) (= CHARNUM 10.) (TYO CHARNUM)))
	NO-VALUE) 

[(OR ITS MULTICS) (DEFINE PRINTOUTINDEX (ABB POI LISTINDEX LISTFILES) FEXPR (WHOSE) 
		   ;;PRINTS OUT LISTING OF FILES.
		   [ITS (APPLY 'PRINTOUTFILE
			       (APPEND '(".FILE."
					 "(DIR)")
				       WHOSE))]
		   [MULTICS (CLINE (GET_PNAME (APPLY 'ATOMIZE
						     (CONS 'LIST/ 
							   (AND WHOSE
								(CONS '/ -P/ 
								      WHOSE))))))]
		   [DEC10 (VALRET (APPLY 'ATOMIZE
					 (APPEND '("DIR ")
						 (AND WHOSE (CONS '/[ WHOSE))
						 (AND WHOSE '(/]))
						 '(/
))))]		   NO-VALUE)] 

(DEFINE PRINTOUTLINE (ABB LISTLINE LL POL) (NUMBER) 
	(DEFAULT-FUNCTION 'PRINTOUTLINE NIL)
	(COND ((GETLINE PROG (SETQ NUMBER (NUMBER? 'PRINTOUTLINE NUMBER)))
	       (TYPE '";PRINTING LINE "
		     NUMBER
		     '" OF "
		     FN
		     EOL)
	       (LOGOPRINT (CONS NUMBER THIS-LINE))
	       NO-VALUE)
	      ((SETQ NUMBER
		     (ERRBREAK 'PRINTOUTLINE
			       (LIST '"NO LINE NUMBERED "
				     NUMBER
				     '" IN "
				     FN)))
	       (PRINTOUTLINE NUMBER)))) 

;;;FOR EACH NAME ON :NAMES, PRINTOUTNAMES WRITES OUT
;;; 	MAKE "<NAME>" "<THING>"
;;;WHICH CAN BE REREAD TO RESTORE VALUES OF VARIABLES.

(DEFINE PRINTOUTNAMES (ABB LISTNAMES LN PON) NIL 
 (COND
  (:CAREFUL
   (COND (:NAMES (DTERPRI)
		 (MAPC 
		  '(LAMBDA (NAME) 
			   (AND (BOUNDP NAME)
				(DPRINC '"MAKE '")
				(DO ((CHARNUM 3. (1+ CHARNUM))
				     (CHAR (GETCHAR NAME 2.) (GETCHAR NAME CHARNUM)))
				    ((NULL CHAR) T)
				    (DPRINC CHAR))
				;;SPECIAL CASE CHECK FOR :EMPTYW IS REQUIRED, SINCE
				;;ITS PRINTED REPRESENTATION IS NOT REREADABLE.
				(COND ((EQ (SETQ NAME (SYMEVAL NAME)) :EMPTYW)
				       (TYPE '" :EMPTYW" EOL))
				      ((DPRINC '" '") (DPRIN1 NAME) (DTERPRI)))))
		  :NAMES))
	 ((IOG NIL (TYPE '";NO NAMES DEFINED" EOL)))))
  ((IOG
    NIL
    (TYPE
     '";YOU ARE NOT IN CAREFUL MODE. NO NAMES ARE SAVED."
     EOL))))
 NO-VALUE) 

;;LISTING ABBREVIATIONS AND PRIMITIVES IS ACCOMPLISHED BY EXAMINING THE OBLIST. 
;;THIS TAKES NO SPACE BUT RESULTS IN AN UNORDERED AND THEREFORE UNINFORMATIVE
;;PRINTOUT.  AN IMPROVEMENT WOULD BE TO HAVE THESE INQUIRES BE ANSWERED BY ACCESSING
;;A DSK FILE OF COMMENTARY.  THE FILE COULD BE CREATED AT COMPILE TIME.

(DEFINE PRINTOUTABBREVIATIONS (ABB LISTABBREVIATIONS) NIL 
 (TYPE '";ABBREVIATIONS:" EOL)
 ;;FILTER FOR ABBREVIATIONS.
 (OBFILTER (EXPR-FUNCTION ABBREVIATIONP)
	   (EXPR-FUNCTION (LAMBDA (AB) 
				  (TYPE AB
					'" ABBREVIATION FOR "
					(ABBREVIATIONP AB)
					EOL))))) 

(DEFINE PRINTOUTPRIMITIVES (ABB LISTPRIMITIVES) NIL 
	(TYPE 'PRIMITIVES: EOL)
	(OBFILTER (EXPR-FUNCTION (LAMBDA (X) (AND (PRIMITIVEP X)
						  (NOT (ABBREVIATIONP X)))))
		  (EXPR-FUNCTION DPRINT))) 

(DEFUN OBFILTER (*FILTER* *MESSAGE*) 
       ;;PRINTS (MESSAGE ATOM) FOR EACH ATOM ON
       (DO ((J 0. (1+ J)))
	   ((= J (CADR (ARRAYDIMS 'OBARRAY))))
	   (MAPC '(LAMBDA (ATOM) 
			  (AND (EXPR-CALL *FILTER* ATOM) (EXPR-CALL *MESSAGE* ATOM)))
		 (ARRAYCALL NIL OBARRAY J)))
       ?) 

(DEFUN LIST-PROCEDURE (FNNAME) 
       ;;PRINTS LISPIFIED USER FN AS LOGO.
       (DEFAULT-FUNCTION 'LIST-PROCEDURE FNNAME)
       (DTERPRI)
       (LOGOPRINC TITLE)
       (DO ((PROC (CDDDR PROG) (CDR PROC)) (THIS-FORM (CADDR PROG) (CAR PROC)))
	   ((NULL PROC) (TYPE EOL 'END EOL))
	   (COND ((NUMBERP THIS-FORM)
		  ;;TAG PRINTED
		  (DTERPRI)
		  (DPRINC THIS-FORM))
		 ((DPRINC '/ )
		  (UNPARSE-FORM (EXPR-FUNCTION DPRINC) THIS-FORM))))) 

;;*PAGE


(DEFUN LOGOPRINT (X) (LOGOPRINC X) (DTERPRI)) 

(DEFUN LOGOPRINSP (X) (LOGOPRINC X) (DPRINC '/ )) 

;;; THE FOLLOWING CODE INSERTS CARRAIGE RETURNS IN LONG COMMENTS
;;; LIKE THE PRETTY-PRINTER DOES. THIS CODE IS NOW UNUSUABLE DUE
;;; TO MODIFICATIONS IN THE PRINTER, BUT SIMILAR STUFF SHOULD BE
;;; WRITTEN AT SOME POINT.
;;;
;;;
;;; (DEFUN PRINT-COMMENT (FN ARGS) 
;;;        (DINDENT-TO (DIFFERENCE LINEL 20.))
;;;        (DPRINC '!)
;;;        (DSEGTEXT (CAR ARGS))
;;;        (DPRINC '!)) 
;;; 
;;;  
;;;  
;;; 
;;; (DEFUN DINDENT-TO (X) 						      
;;;SIMILAR
;;TO INDENT-TO BUT DOES NOT USE TABS
;;;        (AND (LESSP CHRCT X) (DTERPRI))				      
;;;WHICH
;;DISPLAY DOES NOT UNDERSTAND.
;;;        (PROG NIL 
;;; 	LOOP (COND ((= CHRCT X)) ((DPRINC '/ ) (GO LOOP))))) 
;;; 
;;; (DEFUN DSEGTEXT (L) 
;;;        (PROG (N) 
;;; 	     (AND (ATOM L) (RETURN (TYPE L)))			       ;GRINDS THE
;;SEGMENT L AS TEXT INTO REMAINING
;;; 	     (SETQ N CHRCT)					       ;SPACE ON
;;LINE.  SERVES TO INSERT CR'S IN
;;; 	A    (TYPE (CAR L))					       ;EXCESSIVELY
;;LONG COMMENTS.
;;; 	     (POP L)
;;; 	     (OR L (RETURN NIL))
;;; 	     (COND ((LESSP (FLATSIZE (CAR L)) (DIFFERENCE CHRCT 2.))
;;; 		    (DPRINC '/ ))
;;; 		   ((DINDENT-TO N)))
;;; 	     (GO A))) 
;;; 

(DEFINE LINEPRINT FEXPR (X) 
 [ITS (UWRITE TPL)]
 [MULTICS (UWRITE)]
 (IOG
  RW
  (PROG (CRUNIT :SHOW LINEL) 
	[(OR ITS DEC10) (SETQ LINEL 120.)]
	[MULTICS (SETQ LINEL (LINEL NIL)) 
		 (LINEL NIL 120.)]
	;;SAVE CURRENT DEVICE, DIRNAME.
	(SETQ CRUNIT (CRUNIT))
	(TYPE '";************* "
	      (STATUS UNAME)
	      '/ 
	      (OR X :EMPTYW)
	      '" *************"
	      EOL)
	(DPRINTL '/; (DAYTIME))
	(DPRINTL '/; (DATE))
	(DTERPRI)
	(PRINTOUTALL)
	[ITS (UFILE)]
	[MULTICS (LET ((DIRECTORY (GET_PNAME (CAR (NAMES (CAR OUTFILES))))))
		      (UFILE LINE_PRINT LOGO)
		      (CLINE (CATENATE "DPRINT -DELETE "
				       DIRECTORY
				       ">LINE_PRINT.LOGO "))) 
		 (LINEL NIL LINEL)]
	;;RESTORE ORIGINAL DEVICE.
	(APPLY 'CRUNIT CRUNIT)))
 NO-VALUE) 


;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;			PRIMIT >			    ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  THIS FILE CONTAINS MOST OF THE LLOGO PRIMITIVES.
;;;

(DECLARE (OR (STATUS FEATURE DEFINE)
	     (COND ((STATUS FEATURE ITS)
		    ;;MULTICS?
		    (FASLOAD DEFINE FASL AI LLOGO))))) 

(SAVE-VERSION-NUMBER PRIMIT) 

(DECLARE (GENPREFIX PRIMIT)) 

(DEFINE USE FEXPR (X) 
	;;DEFAULT USER NAME SET TO ARG.
	(APPLY 'CRUNIT
	       [(OR ITS DEC10) (CONS 'DSK X)]
	       [MULTICS (LIST 'DSK (APPLY 'ATOMIZE X))])
	NO-VALUE) 

(DEFINE DIRNAME NIL (STATUS UDIR)) 

(DEFINE LOGNAME NIL (STATUS UNAME)) 

[(OR ITS MULTICS) (DEFINE LOGOUT (ABB BYE GOODBYE) NIL 
		   (TYPE '"AND A PLEASANT DAY TO YOU!
")		   [ITS (VALRET '/U)]
		   [DEC10 (VALRET '"KJOB
")]		   [MULTICS (CLINE "LOGOUT")])] 

;;*PAGE


(DEFUN FILECHECK (X) 
       ;;CHECK IF FILE X EXISTS ON DSK.  IF SO ASKS QUESTION. 
       (COND
	[ITS ((MEMQ (CADR X) '(< >)))]
	((NOT (APPLY 'UPROBE X)))
	((AND
	  (TYPE
	   (LIST
	    '";YOU HAVE"
	    X
	    '"ALREADY. WOULD YOU LIKE TO WRITE OVER IT? "))
	  (ASK)))
	((TYPE '";OK, YOUR OLD FILE IS SAFE." EOL)
	 NIL))) 

(DEFUN FILENUM (X) (APPLY 'UREAD X) (STATUS UREAD)) 

;;SAVE IS A HOMONYM IN THE MULTICS IMPLEMENTATION ONLY.

[MULTICS (DEFINE SAVE (PARSE (PARSE-SUBSTITUTE 'LOGO-SAVE)))] 

([(OR ITS DEC10) DEFINE 
		 SAVE]
 [MULTICS DEFINE 
	  LOGO-SAVE 
	  (UNPARSE (UNPARSE-SUBSTITUTE 'SAVE))]
 FEXPR
 (X)
 (COND ((OR (DELEET :CONTENTS :BURIED) :NAMES)
	(AND (SETQ X (FILESPEC X))
	     ;;EXPAND X TO FULL FILE NAME.
	     (FILECHECK X)
	     ;;CHECK IF THE FILE X IS ALREADY ON THE DSK.
	     (APPLY 'UWRITE (CDDR X))
	     (LET ((^W T) (^R T) (FN FN) (PROG PROG) (TITLE TITLE))
		  (PRINTOUTNAMES)
		  (PRINTOUTPROCEDURES)
		  (APPLY 'UFILE X))
	     (TYPE '/; (LIST (FILENUM X) 'SAVED))
	     (DTERPRI))
	NO-VALUE)
       ('";:CONTENTS EMPTY"))) 

;;*PAGE

;;;THIS WRITE FUNCTION IS OF GENERAL LISP USE.  IT PRINTS DEFPROPS
;;FOR ALL BUT THE PNAME AND TRACE PROPERTIES FOR EVERY ATOM ON THE LIST :CONTENTS
;;;
;;WRITE OPTIMIZES SPEED WITH WHICH LOGO USER INTERPRETIVE FUNCTIONS CAN BE REREAD. 
;;THEY ARE STORED AS DEFPROP S-EXPRESSIONS.  NEITHER THE LOGO READER NOR PARSER ARE
;;NECESSARY UPON REREADING.  /AS STANDARD LISP FORMAT, THE FILES CAN BE COMPILED AS
;;WELL.

(DEFINE WRITE FEXPR (FILE) 
	;;PRINTS DEFPROPS FOR PROPERTIES OF ATOMS ON :CONTENTS.
	(SETQ FILE (FILESPEC FILE))
	;;EXPAND FILE NAME.
	(AND (FILECHECK FILE)
	     (PROG (READTABLE ^W CONTENTS FN PLIST TRACE IND PROP) 
		   (SETQ READTABLE LISP-READTABLE)
		   ;;SLASH MUST WORK TO PRESERVE TRANSPARENCY OF (READ (PRIN1 X)).
		   (SETQ ^R T ^W T)
		   (APPLY 'UWRITE (CDDR FILE))
		   (TYO 35.)
		   (PRINC '(READOB LOGO-OBARRAY LISPREADTABLE))
		   (TERPRI)
		   (SETQ CONTENTS :CONTENTS)
		   (WRITENAMES :NAMES)
	      A	   (OR CONTENTS (TERPRI) (RETURN (APPLY 'UFILE FILE)))
		   (SETQ FN (CAR CONTENTS) CONTENTS (CDR CONTENTS))
		   (AND (MEMQ FN :BURIED) (GO A))
		   (TERPRI)
		   (WRITELIST 'UNITE
			      '/'
			      FN
			      '/'
			      ':CONTENTS)
		   ;;FN ADDED TO CONTENTS IF NOT ALREADY THERE.
		   (TERPRI)
		   (SETQ PLIST (CDR FN))
		   ;;PROPERTY LIST TO BE STORED.
		   (SETQ TRACE (TRACE? FN))
		   ;;FLAG TO AVOID TRACE PROP.
	      B	   (OR PLIST (GO A))
		   ;;DONE WITH THIS ATOM
		   (SETQ IND (CAR PLIST) PROP (CADR PLIST) PLIST (CDDR PLIST))
		   (COND ((AND TRACE (MEMQ IND '(EXPR FEXPR MACRO)))
			  ;;IGNORE TRACE PROP
			  (SETQ TRACE NIL))
			 ((MEMQ IND '(SUBR FSUBR LSUBR ARGS PNAME)))
			 ;;IGNORE PNAME SUBR LSUBR AND FSUBR PROP
			 ((WRITELIST 'DEFPROP FN PROP IND)))
		   (TERPRI)
		   (GO B)))
	(TYPE '/; (FILENUM FILE) '" WRITTEN" EOL)
	NO-VALUE) 

(DEFUN WRITENAMES (NAMELIST) 
       (MAPC '(LAMBDA (NAM) 
		      (AND (BOUNDP NAM)
			   (WRITELIST 'UNITE
				      ;;UNBOUND ON EXIT
				      '/'
				      NAM
				      '/'
				      ':NAMES)
			   (WRITELIST 'SETQ
				      NAM
				      (COND ((EQ (SETQ NAM (SYMEVAL NAM)) :EMPTYW)
					     ':EMPTYW)
					    ((LIST 'QUOTE NAM))))))
	     NAMELIST)) 

;;*PAGE

;; THIS DEFINES FUNCTIONS WHICH WILL ENABLE THE LOGO USER TO COMPILE HIS OWN
;;PROCEDURES. 
;;;	?COMPILE <FILENAME>
;; WILL COMPILE ALL THE FUNCTIONS IN A USER'S WORKSPACE AS <FILENAME> FASL ON HIS
;;DIRECTORY.  THE COMPILE FUNCTION WRITES OUT A FILE .LOGO.  OUTPUT CONTAINING
;;DECLARATIONS AND DEFINITIONS OF ALL THE FUNCTIONS ON :CONTENTS.  IT IS NECESSARY
;;THAT ALL PARSEMACROS BE ELIMINATED BEFORE COMPILING SINCE IT IS IMPOSSIBLE TO
;;INSERT A RUN-TIME PARSED LINE INTO A COMPILED FUNCTION.  THEREFORE, IT IS AN ERROR
;;TO ATTEMPT TO COMPILE A FUNCTION WHICH REFERENCES A FUNCTION WHICH IS NOT DEFINED
;;IN THE USER'S WORKSPACE.  THE FILE LLOGO;DECLARE > CONTAINS DECLARATIONS FOR LLOGO
;;PRIMITIVES.
;;;
;; NOTE THAT COMPILATION OF LOGO PROCEDURES, LIKE THOSE OF LISP, IS NOT FOOLPROOF-
;;ONE IS NOT GUARANTEED THAT A PROCEUDRE THAT RUNS INTERPRETIVELY WILL BE
;;COMPILABLE, AND WILL RUN CORRECTLY WHEN COMPILED.  CAUTION MUST BE EXERCISED WITH
;;PROCEDURES THAT DEPEND HEAVILY ON MAINTAINING A DYNAMIC ENVIRONMENT- PROCEDURE
;;MODIFYING PROCEDURES, EXTENSIVE P-LIST HACKING, GLOBAL VARIABLES, WEIRD CONTROL
;;STRUCTURES, ETC.

[(OR ITS MULTICS) (PUTPROP 'COMPILE-PARSEMACRO
			   (GET 'PARSEMACRO 'MACRO)
			   'FEXPR)] 

[(OR ITS MULTICS) (DEFUN COMPILE-DEFINITION-PRINT (USER-FUNCTION) 
			 (IOG NIL (PRINT USER-FUNCTION))
			 (MAPC '(LAMBDA (FORM) 
					(AND (NOT (ATOM FORM))
					     (EQ (CAR FORM) 'PARSEMACRO)
					     (LET ((READTABLE LOGO-READTABLE))
						  (APPLY 'COMPILE-PARSEMACRO
							 FORM))))
			       (LET
				((DEFINITION
				  (CDDR
				   (OR
				    (GET USER-FUNCTION 'EXPR)
				    (ERRBREAK
				     'COMPILE
				     (LIST
				      USER-FUNCTION
				      '"DOES NOT HAVE A DEFINITION"))))))
				(COND ((EQ (CAAR DEFINITION) 'PROG)
				       (CAR DEFINITION))
				      ((CADR DEFINITION)))))
			 (PRINT (LIST 'COMPILED-FUNCTION-SETUP USER-FUNCTION))
			 (PRINT (LIST 'DEFPROP
				      USER-FUNCTION
				      (GET USER-FUNCTION 'EXPR)
				      'EXPR)))] 

;;FEXPR VERSION OF PARSEMACRO TO REPLACE PARSED LINE ONLY.  MACRO WOULD CAUSE
;;EVALUATION OF PARSED LINE.

[(OR ITS MULTICS) (DEFINE COMPILE FEXPR (ARGLIST ENV) 
		   (LET
		    ((FILENAME (CCONS (COND ((SYMBOLP (CAR ARGLIST)))
					    ((CAR (STATUS CRFILE))))
				      'FASL
				      (CRUNIT))))
		    (AND (APPLY 'UPROBE FILENAME)
			 (APPLY 'UKILL FILENAME))
		    (UWRITE)
		    (TYPE '";FUNCTIONS BEING COMPILED ARE:")
		    (LET
		     ((^W T)
		      (^R T)
		      (READTABLE LISP-READTABLE)
		      (*NOPOINT NIL)
		      (CONTENTS (DELEET :CONTENTS :BURIED)))
		     (PRINT (LIST 'DECLARE (CONS '*EXPR CONTENTS)))
		     ;;DECLARATIONS.
		     (AND (EQ (CAR (SETQ ARGLIST (EVAL (CADR ARGLIST) ENV)))
			      'DECLARE)
			  (PRINT ARGLIST))
		     [MULTICS (PRINT
			       '(DECLARE
				 (INPUSH
				  (OPENI
				   ">UDD>AP>LIB>LOGO_DECLARE.LISP"))
				 (SETQ NFUNVARS T)))]
		     (MAPC 'COMPILE-DEFINITION-PRINT CONTENTS)
		     (WRITENAMES :NAMES)
		     [ITS (PRINT '(DECLARE (UKILL ".LOGO."
						  OUTPUT))) 
			  (PRINT (LIST 'DECLARE
				       (APPEND '(UKILL DECLARE UNFASL)
					       (CRUNIT))))])
		    [ITS (UFILE ".LOGO." OUTPUT) 
			 (TERPRI) 
			 (VALRET
			  (ATOMIZE
			   '":NCOMPLR "
			   (CADR (CRUNIT))
			   '/;
			   (CAR FILENAME)
			   '" FASL_LLOGO;DECLARE >,"
			   (CADR (CRUNIT))
			   '";.LOGO. OUTPUT (FKDWVSU)
"			   (STATUS JNAME)
			   '"JP"))]
		    [MULTICS (LET
			      ((DIRECTORY (GET_PNAME (CAR (NAMES (CAR OUTFILES))))))
			      (APPLY 'UFILE
				     (LIST (CAR FILENAME) 'LISP))
			      (TERPRI)
			      (CLINE
			       (CATENATE
				">UDD>AP>LIB>LISP_COMPILER "
				DIRECTORY
				">"
				(GET_PNAME (CAR FILENAME))
				" -ALL_SPECIAL ; DELETE  "
				DIRECTORY
				">"
				(CAR FILENAME)
				".LISP ")))]
		    (COMPILATION-ALARM FILENAME))
		   NO-VALUE)] 

[(OR ITS MULTICS) (DEFUN COMPILATION-ALARM (FILENAME) 
			 (TYPE
			  '";YOUR WORKSPACE WILL BE COMPILED AS "
			  FILENAME
			  EOL
			  '";I WILL LET YOU KNOW WHEN IT'S READY."
			  EOL)
			 (SETQ ALARMCLOCK
			       (SUBST FILENAME
				      'FILENAME
				      '(LAMBDA (USELESS) 
					       (WAIT-FOR-FILE . FILENAME))))
			 (ALARMCLOCK 'TIME 60.)) 
		  (DEFUN WAIT-FOR-FILE FEXPR (FILENAME) 
			 (COND
			  ((APPLY 'UPROBE FILENAME)
			   (TYO 7.)
			   (TYPE
			    '";YOUR COMPILATION IS FINISHED."
			    EOL)
			   (SETQ ALARMCLOCK NIL))
			  ((ALARMCLOCK 'TIME 60.)))) 
		  (DEFINE COMPILED-FUNCTION-SETUP FEXPR (COMPILED-FUNCTION) 
			  (TO-:COMPILED (CAR COMPILED-FUNCTION))) 
		  (DEFUN TO-:COMPILED (COMPILED-FUNCTION) 
			 (SETQ :CONTENTS (DELQ COMPILED-FUNCTION :CONTENTS) 
			       :BURIED (DELQ COMPILED-FUNCTION :BURIED))
			 (AND (EQ FN COMPILED-FUNCTION)
			      (SETQ FN NIL PROMPTER NO-VALUE))
			 (UNITE COMPILED-FUNCTION ':COMPILED)) 
		  (DEFUN TO-:CONTENTS (INTERPRETED-FUNCTION) 
			 (SETQ :COMPILED (DELQ INTERPRETED-FUNCTION :COMPILED))
			 (UNITE INTERPRETED-FUNCTION ':CONTENTS))] 

;;FLUSHCOMPILED AND FLUSHINTERPRETED ARE USEFUL IN SWITCHING BACK AND FORTH BETWEEN
;;COMPILED AND INTERPRETED VERSIONS OF THE SAME FUNCTIONS.

[(OR ITS MULTICS) (DEFINE FLUSHCOMPILED (ABB FLC) NIL 
			  (MAPC '(LAMBDA (SUBR) 
					 (LET ((EXPR-PROP (CAR (REMPROP SUBR
									'EXPR))))
					      (AND EXPR-PROP
						   (TO-:CONTENTS SUBR)
						   (PUTPROP SUBR
							    EXPR-PROP
							    'EXPR))))
				:COMPILED)) 
		  (DEFINE FLUSHINTERPRETED (ABB FLI) NIL 
			  (MAPC '(LAMBDA (EXPR) 
					 (LET ((SUBR-PROP (CAR (REMPROP EXPR
									'SUBR))))
					      (AND SUBR-PROP
						   (TO-:COMPILED EXPR)
						   (PUTPROP EXPR
							    SUBR-PROP
							    'SUBR))))
				(DELEET :CONTENTS :BURIED)))] 

;;*PAGE

;;EVALUATION

(DEFUN EVALS EXPR (X) 
       ;;MAPS EVAL ONTO A LIST RETURNING THE VALUE OF THE LAST ELEMENT.
       (COND ((ATOM X) X)
	     ((NULL (CDR X)) (EVAL (CAR X)))
	     (T (EVAL (CAR X)) (EVALS (CDR X))))) 

;;SPECIAL SYNONYM FOR EVALS WITHIN PARSEMACRO.  USED BY ERROR HANDLER TO DETECT
;;ERRORS WITHIN PARSEMACROS.

(DEFINE PARSEMACRO-EVAL (SYN EVALS)) 

(DEFINE RUN (PARSE 1.) (X) 
 ;;LOGO EQUIVALENT OF EVAL.  IF INPUTS TO RUN FAIL TO PARSE, WILL CAUSE (ERR
 ;;'REREAD).
 (LET
  ((RESULT (ERRSET (PARSELINE (COND ((ATOM X) (LIST X)) (X)) T))))
  (COND
   ((EQ RESULT 'REREAD)
    (SETQ X
	  (ERRBREAK 'RUN
		    (LIST '" UNABLE TO PARSE INPUTS TO RUN"
			  '" INPUT WAS "
			  X)))
    (RUN X))
   ((EVALS (CAR RESULT)))))) 

[CLOGO (DEFINE DO (PARSE (PARSE-CLOGO-HOMONYM RUN L)))] 

;;*PAGE

;;CLOCKS AND TIME
;;;
;;;LOGO PRIMITIVES
;;;
;;;CLOCK 	= TIME SINCE LOGIN OR LAST RESET
;;;RESET	= RESETS CLOCK
;;;DATE		= DAY/MONTH/YEAR (AS A WORD)
;;;TIME		= HOUR/MINUTE/SECOND
;;;COMPUTE	= COMPUTATION TIME USED BY JOB
;;;WAIT		= PUTS LOGO TO SLEEP
;;;
;;;LISP PRIMITIVES
;;;
;;;TIME		= ACCESSES SYSTEM REAL-TIME CLOCK. OUTPUT IN SECONDS.
;;;		  (LOGO CLOCK WITHOUT RESETTING CAPABILITY).
;;;SETTIME	= LOGO RESET	(NO LONGER EXISTS IN LISP)
;;;DATE		= LOGO DATE	(STATUS CALL)	RETURNS (YEAR MONTH DAY)
;;;DAYTIME	= LOGO TIME	(STATUS CALL)
;;;RUNTIME	= LOGO COMPUTE	(STATUS CALL)
;;;SLEEP	= LOGO WAIT	(INPUT IN SECONDS)
;;;
;;;ALARMCLOCK  TWO TYPES OF ALARMCLOCKS ARE AVAILABLE NOW - REAL ELAPSED 
;;;    TIME, AND CPU RUNTIME USED BY JOB IN QUESTION.  FIRST ARG 
;;;    SPECIFIES WHICH TIMER TO USE, AND SECOND ARG SPECIFIES INTERVAL 
;;;    TO WAIT, EXCEPT THAT A NEGATIVE SECOND ARG MEAN SHUT OFF THAT 
;;;    TIMER.   FIRST ARG = "RUNTIME" => WAIT FOR ELAPSED  RUNTIME 
;;;    IN UNITS OF MICROSECONDS;  FIRST ARG = "TIME" => WAIT FOR ELAPSED
;;;    REALTIME IN UNITS OF SECONDS.  SECOND ARG MAY BE EITHER FIXED OR
;;;    FLOATING POINT.  VALUE RETURNED IS T  IF A TIMER WAS JUST SET, 
;;;    AND NIL IF IT WAS TURNED OFF.

(SETQ CLOCK 0.0) 

;;TIME OF LAST RESET.

(DEFINE SLEEP (ABB WAIT)) 

;;PUTS LLOGO TO SLEEP FOR ARG SECONDS.

(DEFINE RUNTIME (ABB COMPUTE)) 

;;COMPUTATION TIME IN MICROSECONDS OF LLOGO.

(DEFINE DAYTIME NIL 
		    ;;RETURNS LIST = (HOUR MIN SEC)
		    (STATUS DAYTIME)) 

(DEFINE TIME (PARSE (PARSE-SUBSTITUTE 'DAYTIME))) 

(DEFINE DATE NIL (STATUS DATE)) 

;;DATE AS (YEAR MONTH DAY).

(DEFINE RESETCLOCK NIL (SETQ CLOCK (TIME)) NO-VALUE) 

;;RESETS CLOCK TO 0.

(DEFINE CLOCK NIL (DIFFERENCE (TIME) CLOCK)) 

;;TIME SINCE LOGIN OR LAST RESET IN THIRTIETHS OF A SECOND.
;;*PAGE

;;;			ASSIGNMENT
;;;
;;LOGO INPUTS ARE PREFIXED BY : FOR CLARITY IN LLOGO ALTHOUGH LISP'S LIST STRUCTURE
;;DOES NOT REQUIRE THIS.MAKE DETECTS ATTEMPTS TO SET SYSTEM VARIABLES [SUCH ATTEMPTS
;;PRINT WARNING MESSAGE].  ALSO, VARIABLES DECLARED READ ONLY CANNOT BE SET BY MAKE.
;;A SYSTEM-VARIABLE PROPERTY FLAGS VARIABLES USED BY THE SYSTEM. SOMEDAY, THE
;;DEFINITION OF : SHOULD BE CHANGED SO THAT THE VALUE OF :FOO IS KEPT ON THE LISP
;;ATOM FOO, NOT :FOO, SO THAT MAKE WILL NOT HAVE TO DO EXPENSIVE EXPLODE/IMPLODE.

(DEFINE MAKE (ABB M) (NAME THING) 
 (COND
  ((WORDP NAME)
   (SETQ NAME (IMPLODE (CONS ': (EXPLODEC NAME))))
   (LET
    ((SYSTEM-VARIABLE-PROP (GET NAME 'SYSTEM-VARIABLE)))
    (COND
     ((NULL SYSTEM-VARIABLE-PROP))
     ((EQ SYSTEM-VARIABLE-PROP 'READ-ONLY)
      (ERRBREAK
       'MAKE
       '"YOU CAN'T CHANGE THE VALUE OF A SYSTEM VARIABLE"))
     ((EQ SYSTEM-VARIABLE-PROP 'READ-WRITE)
      (TYPE '";CHANGING A SYSTEM NAME" EOL))
     ((LISPBREAK
       '"SYSTEM BUG -- BAD SYSTEM VARIABLE PROPERTY IN MAKE")))
    (COND (:CAREFUL (UNITE NAME ':NAMES)))
    (SET NAME THING)))
  ((SETQ NAME
	 (ERRBREAK 'MAKE
		   (LIST '" - FIRST INPUT TO MAKE "
			 NAME
			 '" IS NOT A WORD")))
   (MAKE NAME THING)))) 

(DEFINE MAKEQ (ABB MQ) (PARSE (PARSE-SETQ)) FEXPR (ARGLIST ENV) 
	(DO ((THING))
	    ((NULL ARGLIST) THING)
	    (MAKE (CAR ARGLIST) (SETQ THING (EVAL (CADR ARGLIST) ENV)))
	    (SETQ ARGLIST (CDDR ARGLIST)))) 

(DEFINE INFIX-MAKE (SYN MAKE)) 

(DEFINE SETQ (PARSE (PARSE-SETQ))) 

(DEFUN SYSTEM-VARIABLE FEXPR (SYSTEM-VARIABLES) 
       (MAPC '(LAMBDA (SYSTEM-VARIABLE) (OBTERN SYSTEM-VARIABLE LOGO-OBARRAY)
					(PUTPROP SYSTEM-VARIABLE
						 'READ-WRITE
						 'SYSTEM-VARIABLE))
	     SYSTEM-VARIABLES)) 

(SYSTEM-VARIABLE :PARENBALANCE :CAREFUL :EDITMODE :ERRBREAK :LISPBREAK :REDEFINE) 

;;LLOGO SYSTEM VARIABLES WHICH CAN BE EXAMINED, BUT IF SET DIRECTLY BY USER WOULD
;;LEAVE STATE INCONSISTENT [I.E.  SOME ADDITIONAL ACTION MUST BE PERFORMED WHEN THEY
;;ARE CHANGED] ARE DECLARED READ-ONLY.  MAKE WILL REFUSE TO CHANGE THEM.  ANY
;;ATTEMPT TO DO SO WILL RESULT IN ERROR.

(DEFUN READ-ONLY FEXPR (HANDS-OFF) 
       (MAPC '(LAMBDA (READ-ONLY-VARIABLE) (OBTERN READ-ONLY-VARIABLE LOGO-OBARRAY)
					   (PUTPROP READ-ONLY-VARIABLE
						    'READ-ONLY
						    'SYSTEM-VARIABLE))
	     HANDS-OFF)) 

(READ-ONLY :BURIED
	   :COMPILED
	   :CONTENTS
	   :ECHOLINES
	   :EMPTY
	   :EMPTYS
	   :EMPTYW
	   :INFIX
	   :NAMES
	   :PI
	   :SNAPS
	   :SCREENSIZE
	   :WINDOWS) 

(DEFINE THINGP (NAME) (BOUNDP (MAKLOGONAM NAME))) 

(DEFINE THING (ABB :) (X) 
 (COND ((WORDP X) (SYMEVAL (IMPLODE (CONS ': (EXPLODEC X)))))
       ((SETQ X
	      (ERRBREAK 'THING
			(LIST '" - INPUT "
			      X
			      '" TO THING IS NOT A WORD")))
	(THING X)))) 

(DEFINE STORE (PARSE (PARSE-STORE))) 

(FILLARRAY (ARRAY DEFINEARRAY-TYPE T 3.) '(FIXNUM FLONUM T)) 

(DEFINE DEFINEARRAY (ABB DEFAR) (PARSE 3. L) ARG-COUNT 
	;;11LOGO'S ARRAY CONSTRUCTION COMMAND. 
	(APPLY '*ARRAY
	       (CCONS (ARG 1.)
		      (DEFINEARRAY-TYPE (ARG ARG-COUNT))
		      (CDR (LISTIFY (1- ARG-COUNT)))))) 

;;*PAGE

;;FIRST, BUTFIRST, LAST, BUTLAST, COUNT, SENTENCE AND WORD.
;;;MAKNAM VERSUS READLIST
;;;
;;;READLIST IS REQUIRED FOR GENERATING NUMBERS FROM STRING OF CHARACTERS.
;;;READLIST, HOWEVER, FAILS IF SINGLE CHARACTER OBJECTS ARE INCLUDED.
;;;(WORD '* 1) WILL LOSE.  TWO SOLUTIONS ARE:
;;;
;;;1. TAILOR MAKE A READTABLE FOR THESE FUNCTIONS.  ALMOST ALL
;;;CHARACTERS WOULD BE ORDINARY LETTERS EXCEPT THE DIGITS AND -.
;;;
;;;2. MAKNAM IGNORES CHARACTER SYNTAX.  IT PRODUCES A PNAME TYPE ATOM
;;;REGARDLESS OF THE CHARACTER SYNTAX.  HENCE, A READLIST COULD BE
;;;ATTEMPTED INSIDE AN ERRSET.  IF IT LOSES, THEN INTERN OF MAKNAM
;;;COULD BE USED.  THIS TAKES MORE TIME AND LESS SPACE THAN 1.
;;;(NOTE THIS STILL LOSES ON MAKING NEGATIVE NUMBERS.  THE SYNTAX
;;;OF - IS THAT OF A SCO AND NOT THE - SIGN)
;;;
;;;EXPLODEC RATHER THAN EXPLODE IS NEEDED.  MAKNAM WOULD INSERT
;;;SLASHES PRODUCED BY EXPLODE.
;;;
;;;ON THIS OBARRAY WHEN USED FROM LISP.  ALTERNATIVELY, IT COULD SIMPLY
;;;INTERN ON THE CURRENT OBARRAY.  PROBABLY WITHOUT ANY LOSSAGE.
;;;

(DEFUN LOGOREADLIST (CHARLIST) 
       ;;LOGOREADLIST USES READLIST TO SEE IF STUFF TURNS OUT TO BE A NUMBER, IF SO
       ;;USE NUMBER.  ELSE IGNORE CHAR SYNTAX AND RETURN INTERN OF MAKNAM.
       (LET ((READWORD (CAR (ERRSET (READLIST CHARLIST) NIL))))
	    (COND ((NUMBERP READWORD) READWORD) ((IMPLODE CHARLIST))))) 

(DEFINE FIRST (ABB F) (X) 
	(COND ((EMPTYP X)
	       ;;;(SETQ X ...) (FIRST X) RATHER THAN (FIRST ...) SO THAT
	       ;;;FROM INSIDE THE ERRBREAK, STACK HACKER WILL FIND THE
	       ;;;OFFENDING CALL TO FIRST.
	       (SETQ X
		     (ERRBREAK 'FIRST
			       '"FIRST OF AN EMPTY THING"))
	       (FIRST X))
	      ((NUMBERP X) (LOGOREADLIST (LIST (CAR (EXPLODEC X)))))
	      ((WORDP X) (LOGOREADLIST (LIST (GETCHAR X 1.))))
	      ((CAR X)))) 

(DEFINE BUTFIRST (ABB BF) (X) 
	(COND ((EMPTYP X)
	       (SETQ X
		     (ERRBREAK 'BUTFIRST
			       '"BUTFIRST OF AN EMPTY THING"))
	       (BUTFIRST X))
	      ((ATOM X) (LOGOREADLIST (CDR (EXPLODEC X))))
	      ((CDR X)))) 

(DEFINE LAST (PARSE (PARSE-SUBSTITUTE 'LOGO-LAST))) 

(DEFINE NTH (POSITION LIST) 
	;;THE CLASSIC NTH FUNCTION.  FINDS THE NTH ELEMENT IN A LIST. INSERT ERROR
	;;CHECKING -- BAD POSITION NUMBER, TOO SHORT LIST, ETC.
	(DO NIL ((= POSITION 1.) (CAR LIST)) (POP LIST) (DECREMENT POSITION))) 

(DEFINE LOGO-LAST (ABB LA) (UNPARSE (UNPARSE-SUBSTITUTE 'LAST)) (X) 
	(COND ((EMPTYP X)
	       (SETQ X
		     (ERRBREAK 'LOGO-LAST
			       '" LAST OF AN EMPTY THING"))
	       (LOGO-LAST X))
	      ((NUMBERP X) (LOGOREADLIST (LAST (EXPLODEC X))))
	      ;;GETCHAR LOSES ON NUMBERS.
	      ((WORDP X) (GETCHAR X (FLATC X)))
	      ((CAR (LAST X))))) 

(DEFINE BUTLAST (ABB BL) (X) 
 (COND ((EMPTYP X)
	(SETQ X
	      (ERRBREAK 'BUTLAST
			'" BUTLAST OF AN EMPTY THING"))
	(BUTLAST X))
       ((ATOM X)
	;;SPLICE OUT LAST ELEMENT FROM LIST OF CHARACTERS, THEN ATOMIZE.
	(LET ((EXPLODED-ATOM (EXPLODEC X)))
	     (RPLACA (LAST EXPLODED-ATOM) :EMPTYW)
	     (LOGOREADLIST EXPLODED-ATOM)))
       ;;ALL BUT THE LAST ELEMENT OF A LIST.
       ((MAPCON '(LAMBDA (LIST-ELEMENTS) (COND ((NULL (CDR LIST-ELEMENTS)) NIL)
					       ((LIST (CAR LIST-ELEMENTS)))))
		X)))) 

(DEFINE COUNT (X) (COND ((WORDP X) (FLATC X)) ((LENGTH X)))) 

(DEFINE JOIN (SYN LIST) (PARSE 2. L)) 

[/11LOGO (DEFINE LIST (PARSE 2. L))] 

(DEFINE FPUT (PARSE 2. L) ARGS 
	(COND ((NOT (LISTP (ARG ARGS)))
	       (SETARG ARGS
		       (ERRBREAK 'FPUT
				 (LIST '"THE LAST INPUT "
				       (ARG ARGS)
				       '" IS NOT A LIST")))
	       (APPLY 'FPUT (LISTIFY ARGS)))
	      ((DO ((I (1- ARGS) (1- I)))
		   ((= 0. I) (ARG ARGS))
		   (SETARG ARGS (CONS (ARG I) (ARG ARGS))))))) 

[(OR ITS DEC10) (ARGS 'FPUT '(2. . 77.))] 

(DEFINE LPUT (PARSE 2. L) ARGS 
	(COND ((NOT (LISTP (ARG ARGS)))
	       (SETARG ARGS
		       (ERRBREAK 'LPUT
				 (LIST '"THE LAST INPUT "
				       (ARG ARGS)
				       '" IS NOT A LIST")))
	       (APPLY 'LPUT (LISTIFY ARGS)))
	      ((APPEND (ARG ARGS) (LISTIFY (1- ARGS)))))) 

[(OR ITS DEC10) (ARGS 'LPUT '(2. . 77.))] 

(DEFINE SENTENCE (ABB S SE) (PARSE 2. L) ARGS 
	(DO ((I ARGS (1- I)) (FRAGMENT))
	    ((= I 0.) FRAGMENT)
	    (SETQ FRAGMENT (APPEND (COND ((WORDP (ARG I)) (LIST (ARG I))) ((ARG I)))
				   FRAGMENT)))) 

[(OR ITS DEC10) (ARGS 'SENTENCE '(1. . 77.))] 

(DEFUN WORD-EXPLODE (WORD) 
       (COND
	((WORDP WORD) (EXPLODEC WORD))
	((SETQ WORD
	       (ERRBREAK 'WORD
			 (LIST '"THE INPUT "
			       WORD
			       '" TO WORD WAS NOT A WORD")))
	 (WORD-EXPLODE WORD)))) 

(DEFINE WORD (ABB WD &) (PARSE 2. L) ARGS 
	(LOGOREADLIST (DO ((I ARGS (1- I)) (FRAGMENT))
			  ((= I 0.) FRAGMENT)
			  (SETQ FRAGMENT (NCONC (WORD-EXPLODE (ARG I)) FRAGMENT))))) 

[(OR ITS DEC10) (ARGS 'WORD '(2. . 77.))] 

(DEFINE CHAR (SYN ASCII)) 

(DEFINE BELL NIL (TYO 7.) NO-VALUE) 

;;*PAGE

;;ERASING PROCEDURES

(DEFUN ERASE-PROCEDURE (ERASE-IT) 
       (SETQ :CONTENTS (DELQ ERASE-IT :CONTENTS) :BURIED (DELQ ERASE-IT :BURIED))
       (AND (EQ FN ERASE-IT) (SETQ FN NIL PROMPTER NO-VALUE))
       (UNTRACE1 ERASE-IT)
       (REMPROP ERASE-IT 'EXPR)) 

(DEFINE ERASE (ABB ER) FEXPR (X) 
 (COND
  ((NULL X) NO-VALUE)
  ((MEMQ (CAR X) '(PRIM PRIMITIVE)) (ERASEPRIM (CADR X)))
  ((MEMQ (CAR X) '(ABB ABBREVIATION)) (ERASEABB (CADR X)))
  ((EQ (CAR X) 'LINE) (ERASELINE (CADR X)))
  ((EQ (CAR X) 'NAMES) (ERASENAMES))
  ((EQ (CAR X) 'NAME) (APPLY 'ERASENAME (MAKLOGONAM (CADR X))))
  ((EQ (CAR X) 'PROCEDURES) (ERASEPROCEDURES))
  ((EQ (CAR X) 'ALL) (ERASEALL))
  ((EQ (CAR X) 'TRACE) (APPLY 'ERASETRACE (CDR X)))
  ((EQ (CAR X) 'BURY) (APPLY 'ERASEBURY (CDR X)))
  ((EQ (CAR X) 'FILE) (APPLY 'ERASEFILE (CDR X)))
  ((EQ (CAR X) 'COMPILED) (APPLY 'ERASE :COMPILED))
  [ITS ((EQ (CAR X) 'WINDOWS) (APPLY 'ERASEWINDOWS NIL)) 
       ((EQ (CAR X) 'WINDOW) (APPLY 'ERASEWINDOW (CDR X)))]
  ((MAPC 
    '(LAMBDA (ERASE-IT) 
	     (COND ((MEMQ ERASE-IT :CONTENTS)
		    (ERASE-PROCEDURE ERASE-IT)
		    (TYPE '/;
			  ERASE-IT
			  '" ERASED"
			  EOL))
		   ((MEMQ ERASE-IT :COMPILED)
		    (SETQ :COMPILED (DELQ ERASE-IT :COMPILED))
		    [(OR ITS DEC10) (ARGS ERASE-IT NIL)]
		    (TYPE '/;
			  ERASE-IT
			  '" ERASED"
			  EOL)
		    (UNTRACE1 ERASE-IT)
		    (REMPROP ERASE-IT (CAR (GETL ERASE-IT '(SUBR LSUBR)))))
		   ((MEMQ ERASE-IT :NAMES) (ERASENAME ERASE-IT))
		   [ITS ((MEMQ ERASE-IT :SNAPS)
			 (REMSNAP (SYMEVAL ERASE-IT))
			 (TYPE '/;
			       ERASE-IT
			       '" ERASED"
			       EOL))]
		   ((TYPE '/;
			  ERASE-IT
			  '" NOT FOUND"
			  EOL))))
    X)
   NO-VALUE))) 

(SETQ :SNAPS NIL :WINDOWS NIL) 

(DEFUN EXPUNGE (ATOM) 
       (REMPROP ATOM
		(CAR (GETL ATOM
			   '(EXPR FEXPR MACRO SUBR LSUBR FSUBR ARRAY AUTOLOAD))))
       (MAPC '(LAMBDA (PROP) (REMPROP ATOM PROP))
	     '(PARSE UNPARSE PARSE-INFIX UNPARSE-INFIX INFIX-PRECEDENCE READ-ONLY))
       (UNTRACE1 ATOM)) 

(DEFINE ERASEPROCEDURES (ABB ERP ERPR) NIL 
	(LET ((TO-BE-ERASED (APPEND :COMPILED (DELEET :CONTENTS :BURIED))))
	     (OR TO-BE-ERASED
		 (TYPE '";ALL PROCEDURES ERASED" EOL))
	     (APPLY 'ERASE TO-BE-ERASED))
	NO-VALUE) 

(DEFUN ERASENAME (VARIABLE-NAME) 
       (COND ((GET VARIABLE-NAME 'SYSTEM-VARIABLE))
	     (T (SETQ :NAMES (DELQ VARIABLE-NAME :NAMES))
		(TYPE '/;
		      VARIABLE-NAME
		      '" ERASED"
		      EOL)
		(MAKUNBOUND VARIABLE-NAME)))) 

(DEFINE ERASENAMES (ABB ERN) NIL 
				 ;;MAKUNBOUND SETS THE VALUE PROPERTY TO THE
				 ;;SYSTEM'S UNBOUND MARKER.  REMPROP OF VALUE
				 ;;PROPERTY WOULD SCREW COMPILED CODE.  ERASE ALL
				 ;;NAMES
				 (MAPC 'ERASENAME :NAMES)
				 NO-VALUE) 

(DEFINE ERASEFILE (ABB ERF) (PARSE F) FEXPR (X) 
 (OR X
     (ERRBREAK 'ERASEFILE
	       '"NO INPUT TO ERASEFILE? "))
 [ITS (APPLY 'UREAD (COND ((CDR X) (FILESPEC X)) ((APPEND X '(<))))) 
      (SETQ X (STATUS UREAD)) 
      (APPLY 'UREAD (LIST (CAR X) '>)) 
      (COND
       ((AND
	 (EQUAL X (STATUS UREAD))
	 (TYPE
	  '/;
	  X
	  '" IS YOUR LAST COPY. WOULD YOU LIKE TO ERASE IT? ")
	 (NOT (ASK)))
	(TYPE '";NOT ERASED"))
       ((APPLY 'UKILL X)
	(TYPE '/; X '" ERASED")))]
 [(OR DEC10 MULTICS) (APPLY 'UKILL (SETQ X (FILESPEC X))) 
		     (TYPE '/; X '" ERASED" EOL)]
 ?) 

(DEFINE ERASEALL (ABB ERA) NIL (ERASENAMES) (ERASEPROCEDURES) ?) 

(DEFINE ERASEABB (Z) 
 (COND ((ABBREVIATIONP Z)
	(REMPROP Z
		 [(OR ITS DEC10) (CAR (GETL Z '(EXPR FEXPR)))]
		 [MULTICS 'EXPR])
	(LIST '/; Z '" ERASED"))
       ((SETQ Z
	      (ERRBREAK 'ERASEABB
			(LIST Z
			      '" IS NOT AN ABBREVIATION")))
	(ERASEABB Z)))) 

(DEFINE ERASEPRIM (X) 
	(COND ((PRIMITIVEP X)
	       (EXPUNGE X)
	       [ITS (ARGS X NIL)]
	       (LIST '/; X 'ERASED))
	      ((SETQ X
		     (ERRBREAK 'ERASEPRIM
			       (LIST X
				     '" IS NOT A PRIMITIVE")))
	       (ERASEPRIM X)))) 

(DEFINE ERASETRACE (ABB ERTR) FEXPR (Y) 
	(COND ((NULL Y) (SETQ Y (DEFAULT-FUNCTION 'ERASETRACE NIL)))
	      (T (SETQ Y (CAR Y))))
	(UNTRACE1 Y)
	(TYPE '";TRACE ON "
	      Y
	      '" ERASED"
	      EOL)
	?) 

;;*PAGE

;;CONTROL

(DEFINE GO (ABB GTL) (PARSE (PARSE-GO)) (SYN GO)) 

(DEFINE OUTPUT (SYN RETURN) (ABB OP)) 

;;OUTPUT IS USED IN THE FOLLOWING DEFINITION INSTEAD OF RETURN TO PLEASE THE
;;COMPILER.

(DEFINE STOP NIL (OUTPUT NO-VALUE)) 

;;IN CLOGO, TESTFLAG IS LOCAL TO THE PROCEDURE.  THUS TEST'S IN SUBS DO NOT EFFECT
;;VALUE OF TESTFLAG IN CALLING PROCEDURE.  IN LLOGO, TESTFLAG IS GLOBAL AND SUBS DO
;;EFFECT SUPERPROCEDURE.

(DEFINE TEST (X) (SETQ TESTFLAG X)) 

(DEFINE IFTRUE (ABB IFT) (PARSE L) FEXPR (X) 
	(AND TESTFLAG (NOT (EQ TESTFLAG 'FALSE)) (EVALS X))) 

(DEFINE IFFALSE (ABB IFF) (PARSE L) FEXPR (X) 
	(AND (OR (NOT TESTFLAG) (EQ TESTFLAG 'FALSE)) (EVALS X))) 

(DEFINE IF (PARSE (PARSEIF))) 

;;REPRESENTED AS COND
;;;
;;;			Iteration
;;;
;;;(DECLARE (FIXNUM ITERATIONS))
;;REPEAT forms in body a finite number of times.  First arg number of iterations.
;;Loops return the last form evaluated.

(DEFINE REPEAT (ABB RP) (PARSE L) FEXPR (ARG-LIST ENV) 
	(LET ((ITERATIONS (EVAL (CAR ARG-LIST) ENV)) (REPEAT-BODY (CDR ARG-LIST)))
	     (DO ((REPEAT-COUNT 1. (1+ REPEAT-COUNT)) (REPEAT-VALUE NO-VALUE))
		 ((> REPEAT-COUNT ITERATIONS) REPEAT-VALUE)
		 (SETQ REPEAT-VALUE (EVALUATE-BODY REPEAT-BODY ENV))))) 

(DEFUN EVALUATE-BODY (REPEAT-FORMS ENV) 
       ;;Does body evaluation for iterations.
       (DO ((REPEAT-VALUE (EVAL (CAR REPEAT-FORMS) ENV)
			  (EVAL (CAR REPEAT-FORMS) ENV)))
	   ((NULL (POP REPEAT-FORMS)) REPEAT-VALUE))) 

;;WHILE repeats its body while the first form evaluates to non-nil.

(DEFINE WHILE (PARSE L) FEXPR (ARG-LIST ENV) 
	(DO ((REPEAT-BODY (CDR ARG-LIST))
	     (STOP-CONDITION (CAR ARG-LIST))
	     (REPEAT-VALUE NO-VALUE))
	    ((NULL (EVAL STOP-CONDITION ENV)) REPEAT-VALUE)
	    (SETQ REPEAT-VALUE (EVALUATE-BODY REPEAT-BODY ENV)))) 

;;UNTIL <condition> ...  is like WHILE NOT <condition> ...

(DEFINE UNTIL (PARSE L) FEXPR (ARG-LIST ENV) 
	(DO ((REPEAT-BODY (CDR ARG-LIST))
	     (STOP-CONDITION (CAR ARG-LIST))
	     (REPEAT-VALUE NO-VALUE))
	    ((EVAL STOP-CONDITION ENV) REPEAT-VALUE)
	    (SETQ REPEAT-VALUE (EVALUATE-BODY REPEAT-BODY ENV)))) 

;;Repeat forever in infinite loop.

(DEFINE FOREVER (PARSE L) FEXPR (ARG-LIST ENV) 
	(DO NIL (NIL) (MAPC '(LAMBDA (FORM) (EVAL FORM ENV)) ARG-LIST))) 

(DEFINE DO (PARSE (PARSE-DO)) (UNPARSE (UNPARSE-DO))) 

;;Loops have zero precedence since all their args are forms to be evaluated.

(DEFPROP DO 0. INFIX-PRECEDENCE) 

(DEFPROP REPEAT 0. INFIX-PRECEDENCE) 

(DEFPROP WHILE 0. INFIX-PRECEDENCE) 

(DEFPROP UNTIL 0. INFIX-PRECEDENCE) 

(DEFPROP FOREVER 0. INFIX-PRECEDENCE) 

;;*PAGE

;;ARITHMETIC

(DEFINE ROUNDOFF (PARSE 1. L) ARGS 
	;;THE SECOND ARGUMENT IS OPTIONAL.  WHEN GIVEN IT ROUNDS OFF TO ARG2 DIGITS
	;;AFTER A DECIMAL POINT
	(COND ((FIXP (ARG 1.)) (ARG 1.))
	      ((LET ((UNROUNDED (FLOAT (ARG 1.))))
                    (COND ((= ARGS 1.) (ROUND UNROUNDED))
                          ((LET ((TEN-TO-PLACES (^$ 10.0 (FIX (ARG 2.)))))
                                (//$ (FLOAT (ROUND (*$ UNROUNDED TEN-TO-PLACES)))
                                     TEN-TO-PLACES))))))))

[(OR ITS DEC10) (ARGS 'ROUNDOFF '(1. . 2.))] 

(DEFINE RANDOM (PARSE (PARSE-SUBSTITUTE 'LOGO-RANDOM))) 

(DEFINE LOTS NIL 9999999999.) 

(DEFINE LOGO-RANDOM (PARSE 0. L) (UNPARSE (UNPARSE-SUBSTITUTE 'RANDOM)) ARGS 
	;;(RANDOM) RETURNS A RANDOM NUMBER BETWEEN 0 AND 1.  (RANDOM LOWER UPPER)
	;;RETURNS A RANDOM NUMBER INCLUSIVE BETWEEN LOWER AND UPPER.  IF BOTH ARE
	;;FIXED POINT, THEN SO IS THE RANDOM NUMBER RETURNED.  THUS (RANDOM 0 9)
	;;RETURNS A RANDOM DIGIT, WHILE (RANDOM 0.0 9) RETURNS A FLOATING POINT
	;;NUMBER BETWEEN 0.0 AND 9.0.  THE LSH GUARANTEES + CHECK FOR FIXED POINT
	;;BOUNDS
	(LET ((RANDOM (//$ (FLOAT (LSH (RANDOM) -1.)) 3.4359737E+10))) 
             (COND ((= ARGS 0.) RANDOM)
                   ((AND (FIXP (ARG 1.))
                         (FIXP (ARG 2.))
                         (FIX (PLUS (ARG 1.)
                                    (TIMES (DIFFERENCE (ARG 2.) -1. (ARG 1.)) 
                                           RANDOM)))))
                   ((PLUS (ARG 1.) (TIMES (DIFFERENCE (ARG 2.) (ARG 1.)) RANDOM))))))

[(OR ITS DEC10) (ARGS 'RANDOM '(0. . 2.))] 

(DEFINE DIFFERENCE (ABB DIFF) (PARSE 2. L)) 

(DEFINE INFIX-DIFFERENCE (SYN DIFFERENCE) (PARSE 2. L)) 

(DEFINE - (PARSE (PARSE-SUBSTITUTE 'PREFIX-MINUS))) 

(DEFINE PREFIX-MINUS (SYN MINUS) (PARSE 1.) (UNPARSE (UNPARSE-SUBSTITUTE '-))) 

(DEFINE + (PARSE (PARSE-SUBSTITUTE 'PREFIX-PLUS))) 

(DEFINE PREFIX-PLUS (SYN USER-PAREN) (UNPARSE (UNPARSE-SUBSTITUTE '+))) 

(DEFINE QUOTIENT (ABB QUO) (PARSE 2.)) 

(DEFINE INFIX-QUOTIENT (SYN QUOTIENT) (PARSE 2. L)) 

(DEFINE PLUS (ABB SUM) (PARSE 2. L)) 

(DEFINE INFIX-PLUS (SYN PLUS) (PARSE 2. L)) 

(DEFINE TIMES (ABB PRODUCT PROD) (PARSE 2. L)) 

(DEFINE INFIX-TIMES (SYN TIMES) (PARSE 2. L)) 

(DEFINE INFIX-EXPT (SYN EXPT)) 

(DEFINE MAX (ABB MAXIMUM) (PARSE 2. L)) 

(DEFINE MIN (ABB MINIMUM) (PARSE 2. L)) 

(DEFINE REMAINDER (ABB MOD)) 

(DEFINE INFIX-REMAINDER (SYN REMAINDER) (PARSE 2.)) 

;;FLONUM REMAINDER.

(DEFUN \$ (MODULAND MODULUS) 
       (-$ MODULAND (*$ MODULUS (FLOAT (FIX (//$ MODULAND MODULUS)))))) 

;;LISP'S TRIG FUNCTIONS OPERATE IN TERMS OF RADIANS, THESE USE DEGREES.

(SETQ :PI 3.1415926 PI-OVER-180 (//$ :PI 180.0)) 

(DEFINE SINE (X) (SIN (TIMES X PI-OVER-180))) 

(DEFINE COSINE (X) (COS (TIMES X PI-OVER-180))) 

(DEFINE ARCTAN (ABB ATANGENT) (X Y) (//$ (ATAN (FLOAT X) (FLOAT Y)) PI-OVER-180)) 

;;*PAGE

;;PREDICATE OPERATIONS

(DEFINE CONTENTSP (X) (MEMQ X :CONTENTS)) 

(DEFINE PRIMITIVEP (X) 
	;;(PRIMITIVEP X)=T IF X IS USED BY SYSTEM.
	(AND (NOT (MEMQ X :CONTENTS))
	     (NOT (MEMQ X :COMPILED))
	     [/11LOGO (GETL X '(EXPR FEXPR MACRO SUBR LSUBR FSUBR))]
	     [CLOGO (OR (GETL X '(EXPR FEXPR MACRO SUBR LSUBR FSUBR))
			(LET ((PARSE-PROP (GET X 'PARSE)))
			     (AND PARSE-PROP
				  (NOT (ATOM (CAR PARSE-PROP)))
				  (EQ (CAAR PARSE-PROP)
				      'PARSE-CLOGO-HOMONYM))))])) 

(DEFINE ABBREVIATIONP (ATOM) 
	(OR (LET ((EXPR-PROP (GET ATOM 'EXPR)))
		 (AND (ATOM EXPR-PROP) EXPR-PROP))
	    [(OR ITS DEC10) (LET ((FEXPR-PROP (GET ATOM 'FEXPR)))
				 (AND (ATOM FEXPR-PROP) FEXPR-PROP))])) 

(DEFINE GREATERP (ABB GP GREATER GR) (PARSE 2. L)) 

(DEFINE INFIX-GREATERP (SYN GREATERP) (PARSE 2. L)) 

(DEFINE LESSP (ABB LP LESS LE) (PARSE 2. L)) 

(DEFINE INFIX-LESSP (SYN LESSP) (PARSE 2. L)) 

(DEFINE ZEROP (ABB ZP)) 

(DEFINE NUMBERP (ABB NP)) 

(DEFINE INTEGER (ABB INT) (SYN FIX)) 

(SETQ TOL 0.01) 

(DEFINE ISABOUT (X Y) (LESSP (ABS (DIFFERENCE X Y)) TOL)) 

;;USEFUL FOR TESTING APPROXIMATE EQUALITY OF FLOATING POINT

(DEFINE EQUAL (ABB IS) (PARSE 2.)) 

(DEFINE INFIX-EQUAL (SYN EQUAL) (PARSE 2.)) 

(DEFINE WORDP (ABB WP) (X) (AND X (ATOM X))) 

;;A WORD IS A NON-NIL ATOM.

(DEFINE MEMBER (ABB MEMBERP MP)) 

;;MEMBER IS A LISP PRIMITIVE.

(DEFINE BOTH (SYN AND) (ABB B) (PARSE 2. L)) 

(DEFINE AND (PARSE 2. L)) 

(DEFINE EITHER (SYN OR) (ABB EI) (PARSE 2. L)) 

(DEFINE OR (PARSE 2. L)) 

;;EMPTY WORD AND EMPTY SENTENCE

(SETQ :EMPTYS NIL :EMPTY NIL :EMPTYW (OBTERN (ASCII 0.) LOGO-OBARRAY)) 

(DEFINE EMPTYWP (ABB EWP) (X) (EQ X :EMPTYW)) 

(DEFINE NULL (ABB EMPTYSP ESP)) 

(DEFINE EMPTYP (ABB EP) (X) (OR (NULL X) (EQ X :EMPTYW))) 

(DEFINE SENTENCEP (ABB SP) (Y) 
	(PROG NIL 
	      (AND (NULL Y) (RETURN T))
	      (AND (ATOM Y) (RETURN NIL))
	 LOOP (COND ((NULL Y) (RETURN T))
		    ((WORDP (CAR Y)) (SETQ Y (CDR Y)) (GO LOOP))
		    ((RETURN NIL))))) 

(DEFINE LISTP (X) (OR (NULL X) (EQ 'LIST (TYPEP X)))) 

;; (TYPEP NIL) = SYMBOL.

[(AND ITS CLOGO) (DEFINE DISPLAY (ABB D) (PARSE (PARSE-CLOGO-HOMONYM STARTDISPLAY
								     2.)))] 

(DEFINE LOGO-COMMENT FEXPR (COMMENT) NO-VALUE) 

;;*PAGE


;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;		ERROR > -- DEBUGGING PRIMITIVES	            ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;

(DECLARE (OR (STATUS FEATURE DEFINE)
	     (COND ((STATUS FEATURE ITS)
		    ;;MULTICS?
		    (FASLOAD DEFINE FASL AI LLOGO))))) 

(SAVE-VERSION-NUMBER ERROR) 

(DECLARE (GENPREFIX ERROR)) 

;;; TRACE, GRIND, GRINDEF AND LAP MUST HAVE SPECIAL PARSING
;;; PROPERTIES. ANY FUNCTION WHICH HAS AUTOLOAD PROPERTY
;;; MUST TELL PARSER HOW IT WANTS TO BE PARSED. THE PARSER
;;; HAS NO WAY OF KNOWING WHAT IS GOING TO HAPPEN TO A FUNCTION
;;; WHEN ITS DEFINITION IS READ IN.

(DEFINE TRACE (PARSE F)) 

(DEFINE GRINDEF (PARSE F)) 

(DEFINE GRIND (PARSE F)) 

[(OR ITS DEC10) (DEFINE LAP (PARSE F))] 

[(AND (NOT BIBOP) (NOT MULTICS)) (SETQ GC-DAEMON 'GC-DAEMON) 
				 (DEFUN GC-DAEMON (X) 
					;;GC-DAEMON SERVICE FN.  X = 3 DOTTED PAIRS
					;;WHOSE CAR IS BEFORE GC, CDR AFTER GC.  THE
					;;PAIRS ARE FOR LIST, FIX AND FLO SPACE. 
					;;CURRENTLY A MESSAGE IS PRINTED. 
					(OR
					 (> (CDDAR X) 512.)
					 (COND
					  ((< (CDDAR X) 100.)
					   ;;AVAIBLE SPACE BELOW 100.  WORDS --
					   ;;EXTREME STORAGE CRUNCH.
					   (GCTWA)
					   (TYPE
					    '";FREE SPACE VERY TIGHT. LESS THAN 100 WORDS"
					    EOL)
					   (AND
					    (STATUS FEATURE TRACE)
					    (TYPE
					     '";ERASING TRACE"
					     EOL)
					    (REMTRACE))
					   (AND
					    (OR (STATUS FEATURE GRIND)
						(STATUS FEATURE GRINDEF))
					    (TYPE
					     '";ERASING GRIND PACKAGE"
					     EOL)
					    (REMGRIND)))
					  ((< (CDDAR X) 512.)
					   ;;AVAILABLE SPACE MORE THAN 100 WORDS BUT
					   ;;LESS THAN .5 BLOCKS.
					   (GCTWA)
					   (TYPE
					    '";FREE SPACE LESS THAN HALF-BLOCK"
					    EOL)))))] 

[BIBOP (SETQ GC-OVERFLOW 'GC-OVERFLOW-HANDLER) 
       (DEFUN GC-OVERFLOW-HANDLER (X) 
	      (IOG
	       NIL
	       (TYPE EOL
		     '";YOU HAVE RUN OUT OF "
		     X
		     '" SPACE. MORE?: ")
	       ;;Ask if more memory desired.
	       (COND
		((ASK)
		 (TYPE '"; OK. (")
		 ;;If so, allocate some.
		 (ALLOC
		  (LIST
		   X
		   (LIST NIL
			 (LET ((NEW-ALLOC (+ (CDR (SASSQ X
							 '((LIST . 1400.)
							   (FIXNUM . 1400.)
							   (FLONUM . 600.)
							   (BIGNUM . 400.)
							   (SYMBOL . 400.)
							   (SAR . 100.))
							 '(LAMBDA NIL
							   '(NIL . 400.))))
					     (CADR (GET (CONS NIL (ALLOC T)) X)))))
			      (DPRINC NEW-ALLOC)
			      NEW-ALLOC)
			 NIL)))
		 (TYPE '" WORDS)" EOL))
		((ERROR '"SPACE CAN'T BE EXPANDED"
			X
			'GC-LOSSAGE))))) 
       (SETQ GC-LOSSAGE 'GC-LOSSAGE-HANDLER) 
       (DEFUN GC-LOSSAGE-HANDLER (WHAT-TYPE) 
	      (LIST
	       (ERRBREAK
		(LIST WHAT-TYPE
		      '" STORAGE CAPACITY EXCEEDED")))) 
       (SETQ PDL-OVERFLOW 'STACK-OVERFLOW-HANDLER)] 

[(OR BIBOP MULTICS) (DEFUN STACK-OVERFLOW-HANDLER (STACK-TYPE) 
			   (IOG
			    NIL
			    (TYPE
			     EOL
			     '";TOO MANY RECURSIONS. USED "
			     (STATUS PDLSIZE STACK-TYPE)
			     '" WORDS. CONTINUE ANYWAY? ")
			    (COND
			     ((ASK)
			      (TYPE '"; OK.")
			      (TERPRI)
			      (ALLOC (LIST STACK-TYPE
					   (MIN (STATUS PDLROOM STACK-TYPE)
						(+ (GET (CONS NIL (ALLOC T))
							STACK-TYPE)
						   400.)))))
			     ((ERROR
			       '"SPACE OVERFLOW. CAN'T GET ANY MORE SPACE. "
			       STACK-TYPE)))))] 

;;;   TYPE CHECKING FUNCTIONS.

(DECLARE (MACROS NIL)) 

(DEFUN SYMBOLP (X) (AND (EQ (TYPEP X) 'SYMBOL) X)) 

(DEFUN VARIABLEP (CHECKER VAR) 
       ;;USED BY EDIT, LIST TO DECIDE LEGALITY OF VARIABLE NAME. 
       (COND
	((AND (SYMBOLP VAR) (EQ (GETCHAR VAR 1.) ':)) VAR)
	((ERRBREAK
	  CHECKER
	  (LIST VAR
		'" IS NOT A VALID VARIABLE NAME"))))) 

(DEFUN NUMBER? (CHECKER NUMBER) 
       (COND ((NUMBERP NUMBER) NUMBER)
	     ((ERRBREAK CHECKER
			(LIST NUMBER
			      '" IS NOT A NUMBER"))))) 

(DEFUN PROCEDUREP (CHECKER CHECKED) 
       (COND
	((NOT (SYMBOLP CHECKED))
	 (ERRBREAK
	  CHECKER
	  (LIST CHECKED
		'" IS NOT A VALID PROCEDURE NAME")))
	((EQ (GETCHAR CHECKED 1.) ':)
	 (ERRBREAK
	  CHECKER
	  (LIST
	   CHECKED
	   '" LOOKS LIKE A VARIABLE NAME -NOT A VALID PROCEDURE NAME")))
	((ABBREVIATIONP CHECKED))
	((MEMQ CHECKED :CONTENTS) CHECKED)
	((GETL CHECKED '(SUBR FSUBR LSUBR))
	 (ERRBREAK CHECKER
		   (LIST CHECKED
			 '" IS A COMPILED FUNCTION")))
	((ERRBREAK
	  CHECKER
	  (LIST CHECKED
		'" IS NOT A DEFINED PROCEDURE "))))) 

(DEFUN REREAD-ERROR (MESSAGE) 
       ;;CAUSES MESSAGE TO BE PRINTED AND LINE REREAD.
       (IOG NIL
	    (COND (REREAD-ERROR? (ERR 'REREAD))
		  (T (TYPE '/; MESSAGE EOL)
		     (LET ((NEW-LINE (REPAIR-LINE OLD-LINE)))
			  (TYPE '";CONTINUING EVALUATION"
				EOL)
			  (THROW NEW-LINE PARSELINE)))))) 

(DEFUN PASS2-ERROR (MESSAGE) 
       ;;IN THE SAME VEIN AS REREAD-ERROR EXCEPT INTENDED TO CATCH PASS2 ERRORS. 
       ;;THROWS BACK TO PASS2 [AND LINE IF CALLED BY IT]
       (IOG NIL
	    (LET ((PROMPTER '>))
		 (TYPE '/; MESSAGE EOL)
		 (MAPC 'DPRINC OLD-LINE)
		 (DTERPRI)
		 (DPRINC PROMPTER)
		 (LET ((NEW-LINE (LINE NIL)))
		      (TYPE '";CONTINUING EVALUATION"
			    EOL)
		      (THROW NEW-LINE PASS2))))) 

;;*PAGE

;;; BREAKPOINT FUNCTIONS AND STACK HACKING
;;; :ERRBREAK = T --> LOGO BREAK POINT HAPPENS AUTOMATICALLY ON ERRORS.
;;; :LISPBREAK = T ---> LISP BREAK ON ERRORS.

(SETQ :ERRBREAK NIL :LISPBREAK NIL) 

(DEFINE DEBUG NIL (SETQ :ERRBREAK (NOT :ERRBREAK))) 

(DEFINE TOPLEVEL NIL (IOC G)) 

;;UP, DOWN, PRINTUP, PRINTDOWN ARE FOR USE INSIDE FRAMEUP BREAKS.
;;;(UP)		GOES UP TO THE NEXT FRAME ON THE STACK.
;;;(UP <NUMBER>)	GO UP <NUMBER> FRAMES.
;;;(UP <ATOM>)	GO SEARCHING UP THE STACK FOR AN INVOCATION OF <ATOM>
;;;(UP <ATOM> <NUMBER>) FIND THE <NUMBER>TH INVOCATION OF <ATOM> UP THE STACK.
;;;DOWN IS SIMILAR, EXCEPT PROCEEDS DOWN THE STACK. 
;;;DOWN IS EQUIVALENT TO (UP ... - <NUMBER>)
;;THE FUNCTIONS WORK BY THROWING A LIST BACK TO A CATCH IN FRAMEUP. 
;;;FORMAT OF LIST IS:
;;;	(<FUNCTION> <FUNCTION TO FIND> <NUMBER OF FRAMES> <1 IF UP, -1 IF DOWN>)

(DEFUN FRAMEUP-THROW (TYPE HOW-MANY-ARGS ARGLIST DIRECTION) 
       (THROW
	(CONS TYPE
	      (LET ((HOW-MANY-FRAMES (CAR (LAST ARGLIST)))
		    (FIND-FUNCTION (AND (SYMBOLP (CAR ARGLIST)) (CAR ARGLIST))))
		   (COND ((ZEROP HOW-MANY-ARGS) (LIST NIL 1. DIRECTION))
			 ((> HOW-MANY-ARGS 2.)
			  (TYPE '";TOO MANY INPUTS TO "
				TYPE
				EOL)
			  '(NIL 0. 1.))
			 ((FIXP HOW-MANY-FRAMES)
			  (LIST FIND-FUNCTION
				(ABS HOW-MANY-FRAMES)
				(COND ((MINUSP (* DIRECTION HOW-MANY-FRAMES)) -1.)
				      (1.))))
			 (FIND-FUNCTION (LIST FIND-FUNCTION 1. DIRECTION))
			 (T (TYPE '";WRONG TYPE INPUTS TO "
				  TYPE
				  EOL)
			    '(NIL 0. 1.)))))
	FRAMEUP-BREAK)) 

(DEFINE UP N (FRAMEUP-THROW 'UP N (LISTIFY N) 1.)) 

[(OR ITS DEC10) (ARGS 'UP '(0. . 2.))] 

(DEFINE DOWN N (FRAMEUP-THROW 'DOWN N (LISTIFY N) -1.)) 

[(OR ITS DEC10) (ARGS 'DOWN '(0. . 2.))] 

;;PRINTUP AND PRINTDOWN ARE LIKE UP AND DOWN, EXCEPT THAT THEY JUST PRINT OUT EVERY
;;FRAME BETWEEN THE CURRENT AND DESTINATION FRAMES RATHER THAN MOVING THE
;;BREAKPOINT.  THE BREAKPOINT IS NOT AFFECTED.

(DEFINE PRINTUP N (FRAMEUP-THROW 'PRINTUP N (LISTIFY N) 1.)) 

[(OR ITS DEC10) (ARGS 'PRINTUP '(0. . 2.))] 

(DEFINE PRINTDOWN N (FRAMEUP-THROW 'PRINTDOWN N (LISTIFY N) -1.)) 

[(OR ITS DEC10) (ARGS 'PRINTDOWN '(0. . 2.))] 

;;EXIT CAUSES THE FORM IN THE CURRENT FRAME TO RETURN WITH THE SPECIFIED VALUE. 
;;DEFAULTS TO NIL. 

(DEFINE EXIT ARGS 
	[ITS (UNBIND-ACTIVATE)]
	(THROW (LIST 'EXIT (AND (= ARGS 1.) (ARG 1.))) FRAMEUP-BREAK)) 

[(OR ITS DEC10) (ARGS 'EXIT '(0. . 1.))] 

(DEFINE CONTINUE (ABB CO P $P) ARGS 
	[ITS (UNBIND-ACTIVATE)]
	(THROW (CONS 'CONTINUE (AND (= ARGS 1.) (LIST (ARG 1.))))
	       FRAMEUP-BREAK)) 

[(OR ITS DEC10) (ARGS 'CONTINUE '(0. . 1.))] 

;;THE USER IS PUT IN A BREAKPOINT FROM WHICH HE CAN USE THE FUNCTIONS UP, DOWN, AND
;;EXIT TO MOVE THE BREAKPOINT AROUND THE STACK.  FORMAT OF A LISP FRAME IS
;;; (<EVAL OR APPLY> <STACK-POINTER> <FORM> <ENV>)
;;;FRAMEUP REQUIRES *RSET = T. 
;;;

(DEFUN FRAMEUP (CONTINUE-VALUE FRAME FRAME-PRINT BREAK-LOOP) 
       (DO ((FRAME-NUMBER 0.)
	    (FORM (CADDR FRAME))
	    (ENV (CADDDR FRAME))
	    (*RSET)
	    (NEW-FRAME)
	    ;;;TO INITIALIZE STACK POINTER, MUST LEAVE
	    ;;;ERROR OR FRAMEUP FRAMES.
	    (STACK-POINTER (CADR FRAME))
	    (CAUGHT)
	    (SECOND-CAUGHT))
	   (NIL)
	   (TYPE '";BREAKPOINT FRAME "
		 FRAME-NUMBER
		 '": ")
	   (EXPR-CALL FRAME-PRINT FORM)
	   (SETQ CAUGHT (CATCH (APPLY BREAK-LOOP NIL ENV) FRAMEUP-BREAK) 
		 ;;UNLABELLED THROWS OUT OF THIS LOOP ARE HIGHLY DISCOURAGED.
		 SECOND-CAUGHT (CADR CAUGHT))
	   (AND (EQ (CAR CAUGHT) 'EXIT) (FRETURN STACK-POINTER SECOND-CAUGHT))
	   (AND (EQ (CAR CAUGHT) 'CONTINUE)
		(RETURN (COND ((CDR CAUGHT) SECOND-CAUGHT) (CONTINUE-VALUE))))
	   (DO ((HOW-MANY-FRAMES (CADDR CAUGHT))
		;;;IF LOOKING FOR A PARTICULAR FN, COUNT-THIS-FRAME
		;;;IS TRUE ONLY FOR RELEVANT FRAMES.
		(COUNT-THIS-FRAME T)
		;;;DIRECTION = 1 IF UP, -1 IF DOWN. 
		(DIRECTION (CADDDR CAUGHT))
		(PRINTFRAMES (AND (MEMQ (CAR CAUGHT) '(PRINTUP PRINTDOWN))
				  (CONS FRAME-NUMBER FRAME))))
	       ((OR (AND COUNT-THIS-FRAME (ZEROP HOW-MANY-FRAMES))
		    ;;;GO DOWN TOO FAR??
		    (AND (MINUSP DIRECTION) (ZEROP FRAME-NUMBER))
		    ;;;GO UP TOO FAR??
		    (NULL (SETQ NEW-FRAME (EVALFRAME (* DIRECTION STACK-POINTER)))))
		(AND PRINTFRAMES
		     (SETQ FRAME-NUMBER (CAR PRINTFRAMES) 
			   FRAME (CDR PRINTFRAMES) 
			   STACK-POINTER (CADR FRAME) 
			   FORM (CADDR FRAME) 
			   ENV (CADDDR FRAME))))
	       (SETQ FRAME NEW-FRAME 
		     FRAME-NUMBER (+ FRAME-NUMBER DIRECTION) 
		     STACK-POINTER (CADR FRAME) 
		     FORM (CADDR FRAME) 
		     ENV (CADDDR FRAME) 
		     COUNT-THIS-FRAME (OR (NULL SECOND-CAUGHT)
					  (AND (NOT (ATOM FORM))
					       (EQ (CAR FORM) SECOND-CAUGHT))))
	       (AND COUNT-THIS-FRAME (DECREMENT HOW-MANY-FRAMES))
	       (AND PRINTFRAMES
		    (TYPE '";FRAME "
			  FRAME-NUMBER
			  '": ")
		    (EXPR-CALL FRAME-PRINT FORM)
		    (DTERPRI))))) 

;;IS THIS BREAK LOOP ENTIRELY CORRECT? GLS CLAIMS NOT.  ERROR KEEPS OLD VALUE OF +?

(DEFUN LISP-BREAK-LOOP FEXPR (USELESS) 
       (DO ((^W)
	    (^Q)
	    (^R)
	    (+)
	    (- -)
	    (OBARRAY LISP-OBARRAY)
	    (READTABLE LISP-READTABLE))
	   (NIL)
	   (DTERPRI)
	   (SETQ + - - (READ))
	   (COND 
		 ;;ALT-P CONTINUES WITH DEFAULT LIKE OLD BREAK.  DOLLAR-P FOR
		 ;;BENEFIT OF ALTMODE-LESS MULTICS HACKERS.
		 ((MEMQ - '($P P)) (CONTINUE))
		 ;;ALSO SIMULATE (RETURN ..) KLUDGE.
		 ((AND (NOT (ATOM -)) (EQ (CAR -) 'RETURN))
		  (CONTINUE (EVAL (CADR -))))
		 ((ERRSET (DPRINT (SETQ * (EVAL -)))))))) 

(DEFUN LOGO-BREAK-LOOP NIL 
       (DO ((^W)
	    (^Q)
	    (^R)
	    (PROMPTER '%)
	    (LOGOVALUE)
	    (OLD-LINE OLD-LINE)
	    (FN FN)
	    (PROG PROG)
	    (TITLE TITLE)
	    (REQUEST? NIL))
	   ;;REBIND ANYTHING WHICH MIGHT BE ADVERSELY AFFECTED BY A BREAKPOINT.
	   (NIL)
	   (ERRSET (SETQ LOGOVALUE (TOP-LEVEL))))) 

;;HANDLES ARG CHECKING, ETC.  FOR BOTH LISPBREAK AND LOGOBREAK.

(DEFUN BREAK-POINT (ARG-LIST ENV UP-TO FRAME-PRINT BREAK-LOOP) 
       (LET ((HOW-MANY-ARGS (LENGTH ARG-LIST)) (^W NIL) (^Q NIL) (^R NIL))
	    (COND ((> HOW-MANY-ARGS 3.)
		   (ERRBREAK UP-TO '"TOO MANY ARGS"))
		  ((AND (> HOW-MANY-ARGS 1.) (NULL (EVAL (CADR ARG-LIST) ENV)))
		   NO-VALUE)
		  (T (AND (PLUSP HOW-MANY-ARGS)
			  (TYPE EOL
				'";BREAKPOINT "
				(CAR ARG-LIST)
				EOL))
		     (FRAMEUP (AND (= HOW-MANY-ARGS 3.) (EVAL (CADDR ARG-LIST) ENV))
			      UP-TO
			      FRAME-PRINT
			      BREAK-LOOP))))) 

;;YEAH, I KNOW I'M REDEFINING BREAK.  AVOID WARNING MESSAGE.

(REMPROP 'BREAK 'FSUBR) 

(DEFINE LISPBREAK (ABB BREAK) FEXPR (ARGS ENV) 
	[ITS (BIND-ACTIVATE-LISP)]
	(BREAK-POINT ARGS
		     ENV
		     (STACK-SEARCH (EVALFRAME NIL) 'LISPBREAK)
		     (EXPR-FUNCTION DPRINC)
		     (FUNCTION LISP-BREAK-LOOP)))

(DEFPROP LISPBREAK ((PARSE-BREAK)) PARSE) 
(DEFPROP LISPBREAK (UNPARSE-EXPR-FORM) PARSE)

(DEFINE LOGOBREAK (ABB PAUSE) FEXPR (ARGS ENV) 
	[ITS (BIND-ACTIVATE-LOGO)]
	(BREAK-POINT ARGS
		     ENV
		     (STACK-SEARCH (EVALFRAME NIL) 'LOGOBREAK)
		     (EXPR-FUNCTION UNPARSE-PRINT-FORM)
		     (FUNCTION LOGO-BREAK-LOOP)))

(DEFPROP LOGOBREAK ((PARSE-BREAK)) PARSE)
(DEFPROP LOGOBREAK (UNPARSE-EXPR-FORM) UNPARSE) 

;;*PAGE


(SSTATUS INTERRUPT 16. 'TOGGLE-WORLD) 

(DEFUN TOGGLE-WORLD (IGNORE) 
       ;;^^ SWITCHES BACK AND FORTH BETWEEN LOGO AND LISP.
       (NOINTERRUPT NIL)
       (COND ((EQ OBARRAY LISP-OBARRAY)
	      [ITS (DO I (LISTEN) (1- I) (= I 0.) (TYI))]
	      (LOGO)
	      ;;ERR FORCES BACK TO TOP LEVEL.
	      (ERR))
	     (T (TYPE '* EOL)
		[ITS (DO I (LISTEN) (1- I) (= I 0.) (TYI))]
		(LISP)))) 

(SSTATUS INTERR 1. 'CONTROL-H-BREAK) 

(DEFUN CONTROL-H-BREAK (^H) 
       ;;^H ENTERS A LISP BREAK FROM EITHER LOGO OR LISP.
       (NOINTERRUPT NIL)
       [ITS (BIND-ACTIVATE-LISP)]
       (BREAK-POINT '(CONTROL-H)
		    NIL
		    (STACK-SEARCH (EVALFRAME NIL) 'CONTROL-H-BREAK)
		    (EXPR-FUNCTION DPRINC)
		    'LISP-BREAK-LOOP)) 

(SSTATUS INTERRUPT 2. 'CONTROL-A-BREAK) 

(DEFUN CONTROL-A-BREAK (USELESS) 
       ;;CONTROL-A ENTERS A LOGO BREAK.
       (NOINTERRUPT NIL)
       [ITS (BIND-ACTIVATE-LOGO)]
       (BREAK-POINT '(CONTROL-A)
		    NIL
		    (STACK-SEARCH (EVALFRAME NIL) 'CONTROL-A-BREAK)
		    (EXPR-FUNCTION UNPARSE-PRINT-FORM)
		    'LOGO-BREAK-LOOP)) 

(DEFUN STACK-SEARCH (START-FRAME LOOKING-FOR) 
       ;;FINDS THE FIRST CALL TO LOOKING-FOR ON THE STACK SEARCHING UPWARD FROM
       ;;START-FRAME USING EVALFRAME.
       (DO ((THIS-FRAME START-FRAME (EVALFRAME STACK-POINTER))
	    (STACK-POINTER (CADR START-FRAME) (CADR THIS-FRAME)))
	   ((OR (NULL THIS-FRAME) (EQ (CAADDR THIS-FRAME) LOOKING-FOR)) THIS-FRAME))) 

(DEFUN STACK-HACK (START-FRAME MESSAGE) 
       ;;SEARCHES STACK FOR BAD FORM, USER FUNCTION, LINE NUMBER. PRINTS ERROR
       ;;MESSAGES.
       (COND ((EQ (CAR (CADDR START-FRAME)) 'ERRBREAK)
	      ;;DON'T USE FRAME WITH CALL TO ERRBREAK FUNCTION.
	      (SETQ START-FRAME (EVALFRAME (CADR START-FRAME)))))
       (DO
	((PROG-FRAME (STACK-SEARCH START-FRAME 'PROG)
		     ;;SEARCH FOR FRAME CONTAINING PROG.
		     (STACK-SEARCH ABOVE-PROG 'PROG))
	 (ABOVE-PROG)
	 (USER-FUNCTION))
	((COND
	  ((NULL PROG-FRAME))
	  ((MEMQ 
	    (SETQ USER-FUNCTION
		  (CAADDR (SETQ ABOVE-PROG (EVALFRAME (CADR PROG-FRAME)))))
	    :CONTENTS)
	   ;;LOGO USER FUNCTIONS DISTINGUISHED BY BEING MEMQ :CONTENTS. FRAME
	   ;;IMMEDIATELY BENEATH LOGO USER FUNCTION IS ALWAYS A PROG.
	   (LET ((BAD-LINE-NUMBER (ERROR-LINE-NUMBER PROG-FRAME))
		 (PROG)
		 (THIS-LINE)
		 (NEXT-TAG)
		 (LAST-LINE))
		(TYPE '";ERROR IN LINE "
		      BAD-LINE-NUMBER
		      '" OF "
		      USER-FUNCTION
		      '": ")
		(MAPC '(LAMBDA (BAD-LINE-FORM) (UNPARSE-PRINT-FORM BAD-LINE-FORM)
					       (DPRINC '/ ))
		      (GETLINE (CADDR PROG-FRAME) BAD-LINE-NUMBER))
		(TERPRI)
		T)))
	 (TYPE '";COULDN'T EVALUATE ")
	 (UNPARSE-PRINT-FORM (CADDR START-FRAME))
	 (TYPE EOL '";BECAUSE " MESSAGE)
	 (OR :ERRBREAK :LISPBREAK (ERR 'ERRBREAK))
	 ;;NO BREAKPOINT, CAUSE ERROR BACK TO TOP LEVEL.
	 (DTERPRI)
	 (BREAK-POINT NIL
		      NIL
		      START-FRAME
		      (COND (:ERRBREAK (EXPR-FUNCTION UNPARSE-PRINT-FORM))
			    ((EXPR-FUNCTION DPRINC)))
		      (COND (:ERRBREAK 'LOGO-BREAK-LOOP)
			    ('LISP-BREAK-LOOP)))))) 

(DEFUN ERROR-LINE-NUMBER (PROG-FRAME) 
       ;;RETURNS THE LINE NUMBER CONTAINING THE FORM WHICH CAUSED THE ERROR IN THE
       ;;LOGO USER FUNCTION CONTAINED IN PROG-FRAME.
       (LET
	((LINE-FORM (CADDR (EVALFRAME (- (CADR PROG-FRAME))))))
	;;LINE-FORM IS THE FORM DIRECTLY BENEATH PROG ON STACK, THAT IS, TOP LEVEL
	;;FORM OF THE LINE.
	(COND
	 ((EQ (CAR LINE-FORM) 'PARSEMACRO) (CADR (CADDR LINE-FORM)))
	 ;;IF ERROR CAUSED WITHIN PARSEMACRO, SIMPLY EXTRACT THE LINE NUMBER FROM
	 ;;THE PARSEMACRO FORM.  SINCE PARSE CLOBBERED IN, FORM IN PROG WON'T MATCH
	 ;;FORM ON STACK ANYWAY. 
	 ((DO
	   ((REST-PROG (CDDR (CADDR PROG-FRAME)) (CDR REST-PROG))
	    (BAD-LINE-NUMBER 0.)
	    (THIS-FORM))
	   ((COND
	     ((NUMBERP (SETQ THIS-FORM (CAR REST-PROG)))
	      ;;NEXT LINE NUMBER.
	      (SETQ BAD-LINE-NUMBER THIS-FORM)
	      NIL)
	     ;;FIND THE RIGHT FORM, RETURN BAD-LINE-NUMBER.
	     ((EQ LINE-FORM THIS-FORM))
	     ((NULL REST-PROG)
	      ;;RAN OFF THE END OF THE PROG -- SOMETHING WRONG!
	      (PRINT
	       '"SYSTEM BUG -- ERROR-LINE-NUMBER COULDN'T FIND FORM")
	      ;;STANDARD ERROR BREAK WON'T DO HERE, AS THIS IS CALLED BY IT, WOULD
	      ;;LIKELY LEAD TO INFINITE RECURSION.
	      (LISP-BREAK-LOOP)))
	    BAD-LINE-NUMBER)))))) 

;;ERRBREAK A REMNANT OF OBSOLETE ERROR HANDLING CODE.

(DEFUN ERRBREAK ARGS (ERROR (ARG 2.) 'ERRBREAK 'FAIL-ACT)) 

[(OR ITS DEC10) (ARGS 'ERRBREAK '(NIL . 2.))] 

(SETQ FAIL-ACT 'FAIL-ACT) 

(DEFUN FAIL-ACT (ERRS) 
       [(OR ITS DEC10) (LOGO-ERROR)]
       [MULTICS (COND ((EQ ERRS 'ERRBREAK) (LOGO-ERROR))
		      ((LISP-ERROR (SUBSTR (CAADDR (ERRFRAME NIL)) 6.))))]) 

(DEFUN LOGO-ERROR NIL (LISP-ERROR (CAADDR (ERRFRAME NIL)))) 

(DEFUN LISP-ERROR (MESSAGE) 
       (LIST (STACK-HACK (EVALFRAME (CADR (ERRFRAME NIL))) MESSAGE))) 

(SETQ UNBND-VRBL 'UNBND-VRBL) 

(DEFUN UNBND-VRBL (UNBOUND-VARIABLE) 
       (LISP-ERROR (LIST (CAR UNBOUND-VARIABLE)
			 '"IS AN UNBOUND VARIABLE"))) 

(DEFUN UNDF-FNCTN (ERRS) 
       (LISP-ERROR (LIST (CAR ERRS)
			 '"IS AN UNDEFINED PROCEDURE"))) 

(SSTATUS INTERRUPT 5. 'UNDF-FNCTN) 

(DEFUN WRNG-TYPE-ARG (ERRS) 
       (LET
	((BAD-ARGUMENT (CAR ERRS))
	 (UNHAPPY-FUNCTION
	  (UNPARSE-FUNCTION-NAME (CAADDR (EVALFRAME (ERRORFRAME))))))
	(LISP-ERROR
	 (COND ((EQ BAD-ARGUMENT NO-VALUE)
		(LIST '"AN ARGUMENT TO"
		      UNHAPPY-FUNCTION
		      '"WAS SOMETHING THAT DIDN'T OUTPUT"))
	       ((LIST '"THE INPUT"
		      BAD-ARGUMENT
		      'TO
		      UNHAPPY-FUNCTION
		      '"IS OF THE WRONG TYPE")))))) 

(SSTATUS INTERRUPT 7. 'WRNG-TYPE-ARG) 

(DEFUN UNSEEN-GO-TAG (ERRS) 
       (LISP-ERROR
	(COND
	 ((EQ (CAR ERRS) 'FRAMEUP-BREAK)
	  '"YOU TRIED TO USE A BREAKPOINT FUNCTION BUT YOU'RE NOT IN A BREAKPOINT")
	 ((LIST (CAR ERRS) '"IS AN UNDEFINED TAG"))))) 

(SSTATUS INTERRUPT 8. 'UNSEEN-GO-TAG) 

(DEFUN ERRORFRAME NIL (AND (ERRFRAME NIL) (CADR (ERRFRAME NIL)))) 

(DEFINE ERRSET (PARSE 1. 2.)) 

;;CHANGING THE NUMBER OF INPUTS TO A FUNCTION CAN CAUSE LINES TYPED PREVIOUSLY TO
;;NOW BE INCORRECTLY PARSED.  THIS HANDLER ATTEMPTS TO RECOVER WHERE POSSIBLE BY
;;REPARSING THE LINE.  NOTE THAT ONE CAN'T WIN IN GENERAL, AS SIDE EFFECTS DURING
;;PARTIAL EXECUTION OF A LINE CANNOT BE UNDONE.  A SOMEWHAT BETTER VERSION OF THIS
;;MIGHT USE FRETURN TO RETURN THE RESULT OF A NOW-CORRECT LINE FROM A HIGHER FRAME
;;THAN THE FORM CURRENTLY UNDER EXECUTION; SAY, THE WHOLE LINE, OR THE PROG.  A MORE
;;RADICAL SOLUTION WOULD BE TO MAINTAIN A SUPERPROCEDURE TREE WHICH WOULD REPARSE
;;ALL CALLS TO A FUNCTION IF TITLE CHANGES.

(DEFUN WRONG-NO-ARGS (ERRS) 
       (LET
	((CULPRIT (CAAR ERRS)))
	;;IF LOGO USER FUNCTION CAUSED THE ERROR, TRY REPARSING, ELSE GIVE UP.
	(COND ((MEMQ CULPRIT :CONTENTS)
	       (DO ((PROG-FRAME (STACK-SEARCH (ERRFRAME NIL) 'PROG)
				;;SEARCH FOR FRAME CONTAINING PROG.
				(STACK-SEARCH ABOVE-PROG 'PROG))
		    (ABOVE-PROG)
		    (USER-FUNCTION)
		    (REPARSED-LINE))
		   ((COND ((NULL PROG-FRAME) (LISP-ERROR (WNA ERRS)))
			  ((MEMQ (SETQ USER-FUNCTION
				       (CAADDR (SETQ ABOVE-PROG
						     (EVALFRAME (CADR PROG-FRAME)))))
				 :CONTENTS)
			   (SETQ REPARSED-LINE
				 (RETRY-PARSE USER-FUNCTION
					      (CADDR PROG-FRAME)
					      (ERROR-LINE-NUMBER PROG-FRAME)))
			   T))
		    (COND (REPARSED-LINE) ((LISP-ERROR (WNA ERRS)))))))
	      ((LISP-ERROR (WNA ERRS)))))) 

(DEFUN RETRY-PARSE (REPARSED-PROCEDURE PROG BAD-LINE-NUMBER) 
       (LET
	((^W T) (NEXT-TAG NIL) (LAST-LINE NIL) (THIS-LINE NIL) (PARSED))
	;;REPARSE THE LINE.  ERRSET AS PARSE MAY GENERATE ERROR, IN WHICH CASE WE
	;;LOSE.  IF PARSE OCCURS SUCCESSFULLY, MODIFY PROCEDURE, AND RETURN THE
	;;PARSED FORMS TO TRY AGAIN.
	(SETQ 
	 PARSED
	 (ERRSET (PARSELINE (PASS2 (UNPARSE-LOGO-LINE (GETLINE PROG
							       BAD-LINE-NUMBER)))
			    ;;THE T MEANS JUST ERR IF PARSING ERROR, DON'T TRY TO
			    ;;EDIT. SEE PARSELINE, REREAD-ERROR.
			    T)
		 NIL))
	(COND ((NOT (ATOM PARSED))
	       ;;ATOM PARSED INDICATES PARSING ERROR, LIKELY TOO FEW ARGUMENTS
	       ;;STILL, SO NOT AN EDIT TITLE SCREW.
	       (SETQ ^W NIL PARSED (CAR PARSED))
	       ;;ERRSET RETURNS A LIST OF THE RESULT IF NO ERROR.
	       (TYPE '";REPARSING LINE "
		     BAD-LINE-NUMBER
		     '" OF "
		     REPARSED-PROCEDURE
		     '" AS "
		     PARSED
		     EOL)
	       (ADDLINE PROG (APPEND (CONS BAD-LINE-NUMBER PARSED) NIL))
	       ;;ADD A COPY AS LINE GETS MUNGED DURING PROCEDURE EDITING, AND MUST
	       ;;RETURN A CLEAN COPY.
	       (LIST (CONS 'PROGN PARSED)))))) 

(DEFUN WNA (ERRS) 
       ;;FIGURE OUT HOW MANY ARGUMENTS THE FUNCTION EXPECTED, AND PRINT OUT
       ;;APPROPRIATE ERROR MESSAGE.
       (LET ((CULPRIT (CAAR ERRS)) (EXPECTED NIL))
	    (COND ((SETQ EXPECTED (ARGS CULPRIT))
		   ;;ARGS PROPERTY.  LSUBR OR SUBR.
		   (CCONS (UNPARSE-FUNCTION-NAME CULPRIT)
			  '" EXPECTED "
			  (COND ((NULL (CAR EXPECTED))
				 (LIST (CDR EXPECTED)
				       '" INPUTS"))
				((LIST '" BETWEEN"
				       (CAR EXPECTED)
				       '" AND "
				       (CDR EXPECTED)
				       '" INPUTS")))))
		  ((SETQ EXPECTED (GET CULPRIT 'EXPR))
		   (LIST (UNPARSE-FUNCTION-NAME CULPRIT)
			 '" EXPECTED"
			 (LENGTH (CADR EXPECTED))
			 '" INPUTS"))
		  ;;CAN'T FIGURE OUT HOW MANY ARGUMENTS WANTED.
		  ((LIST '"WRONG NUMBER OF INPUTS TO "
			 (UNPARSE-FUNCTION-NAME CULPRIT)))))) 

(SSTATUS INTERRUPT 9. 'WRONG-NO-ARGS) 

(*RSET T) 

(SSTATUS INTERRUPT 18. 'FASLOADER) 

(DEFUN FASLOADER (FILE) 
       ;;REDEFINE AUTOMATIC FASLOADER FOR TRACE, GRIND, LAP, ETC.  TO FASLOAD STUFF
       ;;FROM THE LISP OBARRAY.  THEREFORE IT IS CALLABLE FROM LOGO.	
       ;;;
       ;;ALSO, IT'S NICE IF AUTOMATIC FASLOADER IS TRANSPARENT TO CURRENT DEFAULT
       ;;FILENAME AND DIRECTORY.
       (LET ((OBARRAY LISP-OBARRAY)
	     (READTABLE LISP-READTABLE)
	     (CRFILE (STATUS CRFILE))
	     (CRUNIT (CRUNIT)))
	    ;;READTABLE REBOUND SO THAT CHARACTER READMACROS DEFINED BY FASLOADED
	    ;;FILE WILL NOT AFFECT LOGO READTABLE.  I.E.  DOUBLE-QUOTE AND SQUARE
	    ;;BRACKET MACROS DEFINED BY FILE DEFINE >.
	    [(OR ITS DEC10) (APPLY 'FASLOAD (CDR FILE))]
	    [MULTICS (LOAD (CDR FILE))]
	    (APPLY 'CRUNIT CRUNIT)
	    (APPLY 'SSTATUS (CONS 'CRFILE CRFILE)))) 

(SSTATUS INTERRUPT 19. NIL) 

;;RSET BREAK TURNED OFF.  HENCE, EXECUTING (LISP) WILL NOT RESULT IN BREAK.  RSET
;;SERVICES ERRORS THAT REACH THE TOPLEVEL.
;;;

(DECLARE (MACROS T)) 

;;MISCELLANEOUS SYSTEM DEBUGGING FEATURES.

[ITS (DEFPROP LOAD-TECO (LISPT FASL AI /.TECO/.) AUTOLOAD) 
     (DEFPROP START-TECO (LISPT FASL AI /.TECO/.) AUTOLOAD) 
     (DEFPROP MEV (STEPMM FASL AI COMMON) AUTOLOAD) 
     (DEFUN TECO NIL (COND (TECO? (P)) ((SETQ TECO? T) (LOAD-TECO) (G)))) 
     (SETQ TECO? NIL)] 

;;;
;;THIS FUNCTION SHOULD BE USED TO REPORT BUGS IN LISP LOGO.  IT RELIEVES THE NAIVE
;;USER ABOUT HAVING TO KNOW ABOUT :BUG IN DDT.  IT WRITES A FILE BUG > ON LLOGO;
;;CONTAINING THE USER'S GRIPE.

[(OR ITS MULTICS) (DEFINE FEATURE (ABB BUG) FEXPR (COMPLAINT) 
		   (LET
		    ((^W T)
		     (^R T)
		     (CRUNIT (CRUNIT))
		     (CRFILE (STATUS CRFILE))
		     [ITS (JNAME (STATUS JNAME))])
		    (UWRITE [ITS DSK 
				 LLOGO])
		    (PRINC COMPLAINT)
		    (TERPRI)
		    (UFILE [ITS BUG 
				>]
			   [MULTICS LLOGO 
				    BUG])
		    [ITS (VALRET
			  (ATOMIZE
			   '":QMAIL BUG-LLOGO ILLOGO;BUG >"
			   EOL
			   JNAME
			   '"JP")) 
			 (UKILL BUG > DSK LLOGO)]
		    [MULTICS (CLINE
			      "MAIL LLOGO.BUG HENRY ESG;DELETE LLOGO.BUG")]
		    (APPLY 'CRUNIT CRUNIT)
		    (APPLY 'SSTATUS (CONS 'CRFILE CRFILE)))
		   '";THANK YOU FOR YOUR PATIENCE.")] 


(COMMENT NO ALLOCATION) 

(PUTPROP (CAR (STATUS UREAD)) (CADR (STATUS UREAD)) 'VERSION)

;;;LOADER > READS IN THE FN "CREATE".  (CREATE <LLOGO OR NLLOGO>) WILL
;;;READ IN THE NECESSARY FASL FILES AND DUMP THE JOB OUT AS
;;;TS NLLOGO OR TS LLOGO, ETC, ON LLOGO;. (CREATE) WILL SIMPLY
;;;PRODUCE AN INTERPRETIVE VERSION WITHOUT DUMPING.

(DECLARE (COUTPUT (READ))) 

(DEFUN HOW-BIG NIL 
       (REMPROP 'HOW-BIG 'EXPR)
       ((LAMBDA (FREE) 
		((LAMBDA (GC-DAEMON) (GCTWA) (GC))
		 (FUNCTION (LAMBDA (GC-STATISTICS) (SETQ FREE GC-STATISTICS))))
		(CONS (PAGEBPORG)
		      (MAPCAR '(LAMBDA (SPACE) 
				       (CONS (- (STATUS SPCSIZE SPACE)
						(CDDR (ASSOC SPACE FREE)))
					     (ERRSET (STATUS PURSIZE SPACE) NIL)))
			      (STATUS SPCNAMES))))
	NIL)) 

(DECLARE (COUTPUT (READ))) 

(DEFUN CREATE NIL 
       (REMPROP 'CREATE 'FEXPR)
       (REMPROP 'HOW-BIG 'EXPR)
       (*RSET T)
       ((LAMBDA (DUMP) 
		(AND (STATUS FEATURE ITS)
		     (COND ((MEMQ 'I (STATUS JCL))
			    (AND (STATUS FEATURE BIBOP)
				 (ALLOC '(LIST (25000. 30000. NIL)
					       SYMBOL
					       (3000. 5000. NIL)
					       FIXNUM
					       (4000. 8000. NIL))))
			    (MAPC 
			     '(LAMBDA (SOURCE-FILE) 
				      (APPLY 'UREAD
					     (CONS SOURCE-FILE '(> AI LLOGO)))
				      (MAPC 'PRINC
					    (LIST 'READING
						  '/ 
						  (CAR (STATUS UREAD))
						  '/ 
						  (CADR (STATUS UREAD))))
				      (TERPRI)
				      (DO ((^Q T) (FORM) (END-OF-FILE (GENSYM)))
					  ((OR (NULL ^Q)
					       (EQ END-OF-FILE
						   (SETQ FORM (READ END-OF-FILE))))
					   (SETQ ^Q NIL))
					  (EVAL FORM)))
			     (GET 'LLOGO 'FILES))
			    (DEFPROP LLOGO (INTERPRETIVE LOGO) VERSION))
			   (T (SETQ NOUUO NIL)
			      (AND (STATUS FEATURE BIBOP)
				   (SETQ PUTPROP (APPEND '(PARSE UNPARSE)
							 PUTPROP) 
					 PURE T 
					 *PURE T)
				   ;;THE VALUE OF PURE IS NUMBER OF PAGES FOR UUO
				   ;;LINKS.  THE VALUE OF PUTPROP IS A LIST OF
				   ;;INDICATORS PERMITTING PURIFICATION OF THE
				   ;;CORRESPONDING PROPERTIES.
				   (ALLOC '(LIST (10000. 20000. NIL)
						 SYMBOL
						 (2000. 3000. NIL)
						 FIXNUM
						 (3000. 5000. NIL))))
                              (COND (DUMP (NOUUO NIL) T) ((NOUUO T)))
			      (MAPC '(LAMBDA (FASL-FILE) 
					     (MAPC 'PRINC
						   (LIST '/
FASLOADING/ 						 FASL-FILE
							 '/ FASL))
					     (APPLY 'FASLOAD
						    (CONS FASL-FILE
							  '(FASL AI LLOGO))))
				    (CDR (GET 'LLOGO 'FILES)))))
		     (AND DUMP (UWRITE AI LLOGO) (IOC R)
		     (MAPC 'PRINC
			   (LIST '/
CREATING/ 			 DUMP
				 '/ ON/ 
				 (DATE)
				 '/ AT/ 
				 (DAYTIME)
				 (ASCII 13.)))
		     (MAPC '(LAMBDA (X) (PRINC X)
					(TYO 32.)
					(PRINC (GET X 'VERSION))
					(TERPRI))
			   (CONS 'LOADER (REVERSE (GET 'LLOGO 'FILES))))))
		(COND ((STATUS FEATURE BIBOP)
                       (SETQ BASE 10.)
		       (PRINC '/
GC-STATISTICS/
)		       (PRINC '/
BPS:/	)	       (PRINC (- BPORG (CAR INITIAL-SIZE) 
                                 (COND ((NUMBERP PURE) (* PURE 2048.)) (0.))))
		       (PRINC '/ WORDS/
UUO:/	)	       (PRINC (COND ((NUMBERP PURE) (* PURE 2048.)) (0.)))
		       (PRINC '/ WORDS/
)		       ((LAMBDA (FREE) 
				((LAMBDA (GC-DAEMON) (GCTWA) (GC))
				 '(LAMBDA (GC-STATISTICS) (SETQ FREE GC-STATISTICS)))
				(MAPC 
				 '(LAMBDA (SPACE OLD-SIZE) 
					  (PRINC SPACE)
					  (PRINC ':/	)
					  (PRINC (- (- (STATUS SPCSIZE SPACE)
						       (CDDR (ASSOC SPACE FREE)))
						    (CAR OLD-SIZE)))
					  (PRINC '/ IMPURE/ WORDS/ USED/
)					  (AND (CDR OLD-SIZE)
					       (PRINC '/	)
					       (PRINC (- (STATUS PURSIZE SPACE)
							 (CADR OLD-SIZE)))
					       (PRINC '/ PURE/ WORDS/ USED/
)))				 (STATUS SPCNAMES)
				 (CDR INITIAL-SIZE)))
			NIL)))
		;;UNSNAP ALL LINKS. (SSTATUS UUOLINKS)
		(MAKUNBOUND 'INITIAL-SIZE)
		(SETQ PURE NIL ^W NIL)
		(LOGO)
		(SETQ BASE 10. 
		      IBASE 10. 
		      *NOPOINT T 
		      *PURE NIL 
		      HOMCHECK NIL 
		      FASLOAD NIL)
		(TERPRI)
                (SSTATUS TOPLEVEL '(START-UP))
		(COND ((AND DUMP (STATUS FEATURE ITS))
		       (ERRSET (UFILE LLOGO > AI LLOGO) NIL)
                       (IOG NIL (PRINC 'VERSION/ NUMBER?/ )
                            (PUTPROP 'LLOGO (LIST DUMP (READ)) 'VERSION))
                       (UCLOSE)
		       (PURIFY 0. 0. 'BPORG)
		       (SUSPEND (ATOMIZE ':SYMLOD EOL ':PDUMP/ LLOGO/;TS/  DUMP EOL ':KILL/ )))
		      (DUMP (IOG NIL (PRINC 'VERSION/ NUMBER?/ )
                                     (PUTPROP 'LLOGO (LIST DUMP (READ)) 'VERSION))
			    (COND ((STATUS FEATURE DEC10) (SUSPEND))
                                  ((APPLY 'SAVE (LIST DUMP)))))
                      ((DEFPROP LLOGO (EXPERIMENTAL LLOGO) VERSION))))
	(AND (PRINC 'DO/ YOU/ WANT/ TO/ DUMP/ ON/ DSK?/ )
	     (MEMQ (IOG NIL (READ)) '(Y YES OK SURE T YA OUI))
	     (PRINC 'NAME/ /[LLOGO/,/ NLLOGO/]?/ )
	     (IOG NIL (READ))))) 

(DECLARE (COUTPUT (READ)))

(DEFUN START-UP NIL
       (REMPROP 'START-UP 'EXPR)
       (LOGO)
       (AND (STATUS FEATURE ITS) (OR (ZEROP TTY) (CURSORPOS 'C)))
       ;;CLEAR SCREEN IF AT A DISPLAY TERMINAL.
       (MAPC '(LAMBDA (X Y) (MAPC 'DPRINC (LIST X '/  Y EOL)))
		      (LIST 'LISP
			    (CAR (GET 'LLOGO 'VERSION)))
		      (LIST (STATUS LISPVERSION)
			    (CADR (GET 'LLOGO 'VERSION))))
       (AND (STATUS FEATURE ITS) (ERRSET (ALLOCATOR) NIL))
       ;; ALLOCATOR LOADS IN AUXILIARY PACKAGES IF THE USER WANTS THEM.
       (APPLY 'CRUNIT (LIST 'DSK (STATUS UDIR)))
       (SETQ SAIL (NOT (ZEROP (BOOLE 1. 536870912. (CADDR (STATUS TTY))))))
       ;;SET FLAG WHETHER TERMINAL IS IN SAIL MODE.
       ((LAMBDA (^W)
                (COND ((STATUS FEATURE ITS)
		       (OR (ERRSET (READFILE LLOGO /(INIT/)) NIL)
                             (ERRSET (AND (APPLY 'READFILE
     					       (LIST (STATUS UDIR)
						     '/.LLOGO/.
						     '/(INIT/)))
					(APPLY 'CRUNIT
					       (LIST 'DSK (STATUS UDIR))))
				   NIL)))
		      ((STATUS FEATURE DEC10) (ERRSET (READFILE INIT LGO) NIL))
		      ((ERRSET (READFILE START_UP LOGO) NIL))))
         T)
       (PRINC 'LLOGO/ LISTENING)
       '?)


(DEFPROP LLOGO (DEFINE SETUP READER PARSER UNEDIT PRINT PRIMIT ERROR) FILES) 

(AND (STATUS FEATURE BIBOP) (SETQ INITIAL-SIZE (HOW-BIG))) 

(SSTATUS TOPLEVEL '(CREATE)) 

;;;			LOGO TURTLE FUNCTIONS

(DECLARE (OR (STATUS FEATURE DEFINE) (FASLOAD DEFINE FASL AI LLOGO))) 

(SSTATUS FEATURE TURTLE) 

(DECLARE (GENPREFIX TURTLE)
	 (*FEXPR PHOTO SNAP PICTURE RESNAP)
	 (*LEXPR ERRBREAK POINT DSCALE SETHOME DISPLAY BLINK UNBLINK MOTION BRIGHT
		 SCALE RANGE BEARING TOWARDS PENSTATE)
	 (*EXPR HOME)
	 (SPECIAL :WRAP :POLYGON FLOAT-DIS :SNAP :TEXTXHOME :TEXTYHOME NEWTURTLE
		  WORLD :SNAPS :DSCALE :RAD3 :PI :TURTLE HOME :HEADING :XCOR :YCOR
		  :PICTURE :PAGE :SHOW :TSIZE :TEXT :SCREENSIZE PI-OVER-180 PLOTS)) 

(COND ((STATUS FEATURE LLOGO)
       (READ-ONLY :WRAP :XCOR :YCOR :SNAP :SNAPS :DSCALE :TURTLE :PI :HEADING 
                  :PICTURE :PAGE :SHOW :TEXT :SCREENSIZE :TSIZE :RAD3)
       (SYSTEM-VARIABLE :POLYGON))
      ((DEFUN ERRBREAK ARGS (PRINC (ARG 1.)) (APPLY 'BREAK (LIST (ARG 2.) T)))
       (DEFUN HOMCHECK (USELESS) USELESS)
       (DEFUN OBTERN (IGNORE THIS) IGNORE)
       (DEFUN TYPE ARGS 
	      (DO ((I 1. (1+ I))) ((> I ARGS) (ARG (1- I))) (PRINC (ARG I))))
       (DEFUN ASK NIL (MEMQ (READ) '(Y YES OK YUP SURE OUI DA)))
       (DEFUN FILESPEC (X) 
	      (OR (APPLY 'AND (MAPCAR 'ATOM X))
		  (SETQ X (ERRBREAK 'FILESPEC
				    (LIST X 'IS/ NOT/ A/ FILE/ NAME))))
	      (COND ((NULL X) (APPEND (STATUS CRFILE) (CRUNIT)))
		    ((NOT (CDR X)) (APPEND X '(>) (CRUNIT)))
		    ((NOT (CDDR X)) (APPEND X (CRUNIT)))
		    ((NOT (CDDDR X))
		     (APPEND (LIST (CAR X) (CADR X)) '(DSK) (CDDR X)))
		    (X))))) 

;;THE TURTLE PACKAGE IS GOING TO EAT LOTS OF FLONUM SPACE, SO IN BIBOP LISP, ASSURE
;;THAT ENOUGH WILL BE AVAILABLE.

(AND (MEMQ 'BIBOP (STATUS FEATURES))
     (ALLOC '(FLONUM (2000. 4000. NIL) FLPDL 2000.))) 

(DEFINE SINE (X) (SIN (TIMES X PI-OVER-180))) 

(DEFINE COSINE (X) (COS (TIMES X PI-OVER-180))) 

(DEFINE ARCTAN (ABB ATANGENT) (X Y) (//$ (ATAN (FLOAT X) (FLOAT Y)) PI-OVER-180)) 

(DEFUN DISPLAY-PRINC (X) 
       (AND :SHOW (DISCUSS :TEXT :TEXTXHOME :TEXTYHOME X))
       (PRINC X))

(DEFUN DISPLAY-TERPRI NIL 
       (AND :SHOW (DISCUSS :TEXT :TEXTXHOME :TEXTYHOME EOL))
       (TERPRI))


(DECLARE (READ))
(READ)
;;COMPILED BUT NOT INTERPRETIVELY.
(SETQ DPRINC (GET 'DISPLAY-PRINC 'SUBR) DTERPRI (GET 'DISPLAY-TERPRI 'SUBR))

(DECLARE (READ) (READ))
;;INTERPRETIVELY BUT NOT COMPILED. [NOUUO=T]
(DEFPROP DPRINC DISPLAY-PRINC EXPR)
(DEFPROP DTERPRI DISPLAY-TERPRI EXPR)


;;THE FREE VARIABLES ":XCOR, :YCOR" ARE NECESSARY FOR FLOATING POINT ACCURACY. 
;;;
;;*PAGE


(DEFINE STARTDISPLAY (ABB SD) ARGS 
	(REMPROP ':PICTURE 'SNAP)
	(REMPROP ':PICTURE 'ORIGINAL)
	(MAPC '(LAMBDA (SNAP) (MAKUNBOUND SNAP) (REMPROP SNAP 'SNAP))
	      :SNAPS)
	(IOC Y)
	(SETQ :SNAPS NIL 
	      NEWTURTLE NIL 
	      WORLD ':PICTURE 
	      :TURTLE 0. 
	      :SNAPS NIL 
	      :HEADING 0.0 
	      :XCOR 0.0 
	      :YCOR 0.0 
	      :SHOW NIL 
	      :TEXT NIL)
	(OR (ZEROP ARGS) (SETQ DEFAULT-TURTLE (ARG 1.)))
	(COND ((ERRSET (DISSTART1) NIL))
	      ;;IF ERROR, FLUSH SLAVE AND TRY AGAIN.
	      (T (DISFLUSH)
		 (TYPE '/;TRYING/ TO/ REGRAB/ DISPLAY/ SLAVE EOL)
		 (SETQ :TURTLE 0.)
		 (DISSTART1)))) 

(ARGS 'STARTDISPLAY '(0. . 1.)) 

(DEFUN DISSTART1 NIL 
       ;;SUBROUTINE OF DISSTART.  NO GLOBAL PURPOSE.  OPENS SLAVE OR FLUSHES CURRENT
       ;;ARRAYS, GUARANTEES ASTATE=0.  ONE DISINI TO START SLAVE, ONE TO SET
       ;;"ASTATE" MODE
       (COND ((EQ DEFAULT-TURTLE 'GT40) (DISINI 0. 'T34)) ((DISINI)))
       (DISINI 0.)
       (SETQ :PICTURE (DISCREATE (CAR HOME) (CADR HOME)))
       (SHOWTURTLE)
       (IOC F)) 

(DEFINE WIPE NIL (OR (= :TURTLE 0.) (SETQ :TURTLE (DISCOPY :TURTLE)))
		 ((LAMBDA (D) (DISFLUSH :PICTURE)
			      (SETQ :PICTURE (DISCREATE (CAR D) (CADR D)))
			      (DISALINE :PICTURE (CADDR D) (CADDDR D) 1.)
			      (DISMARK :PICTURE :TURTLE)
			      (DISET :PICTURE (CADDDR (CDDDR D))))
		  (DISCRIBE :PICTURE))
		 '?) 

(DEFINE WIPECLEAN (ABB WC) NIL 
			       ;;IN ADDITION TO WIPE HIDES ALL SNAPS
			       (WIPE)
			       (MAPC 'HIDE (MAPCAR 'EVAL :SNAPS))
			       '?) 

(DEFINE CLEARSCREEN (ABB CS) NIL (WIPECLEAN) (HOME)) 

(DEFINE NODISPLAY (ABB ND) NIL (SETQ :SHOW NIL) (DISFLUSH) '?) 

;;THE TURTLE

(DEFINE HIDETURTLE (ABB HT) NIL (COND ((NOT (= :TURTLE 0.))
				       (DISMARK :PICTURE 0.)
				       (DISFLUSH :TURTLE)
				       (SETQ :TURTLE 0.)))
				'?) 

(DEFINE SHOWTURTLE (ABB ST) NIL 
	;;:TURTLE IS 0 IF TURTLE IS NOT DISPLAYED.  ELSE IT'S THE NUMBER OF THE
	;;DISPLAY ITEM WHICH IS THE TURTLE.  :PICTURE IS THE ITEM WHICH THE TURTLE
	;;AFFECTS.  DOES NOT INCLUDE SNAPS SHOWN VIA SHOWSNAP.
	(COND ((= :TURTLE 0.)
	       (SETQ :TURTLE (DISCREATE (+ (XHOME) (XCOORD)) (+ (YHOME) (YCOORD))))
	       (DISPLAY :TURTLE NIL)
	       (COND (NEWTURTLE ((LAMBDA (:PICTURE :TURTLE :XCOR :YCOR :HEADING
					  :DSCALE :SCREENSIZE) 
					 (MAPC 'EVAL NEWTURTLE))
				 :TURTLE
				 0.
				 0.0
				 0.0
				 :HEADING
				 NIL
				 512.))
		     ((TURTLE)))
	       (DISMARK :PICTURE :TURTLE)))
	'?) 

(DEFUN TURTLE NIL 
       (PROG (H) 
	     (DISINI 3.)
	     (SETQ H (MINUS (DIFFERENCE :HEADING 90.0)))
	     (DISALINE :TURTLE (//$ :TSIZE :RAD3) H -1.)
	     (DISALINE :TURTLE :TSIZE (SETQ H (+$ H 150.0)))
	     (DISALINE :TURTLE :TSIZE (SETQ H (+$ H 120.0)))
	     (DISALINE :TURTLE :TSIZE (SETQ H (+$ H 120.0)))
	     (DISINI 0.))) 

(DEFINE HOME (ABB H) NIL (OR (= :TURTLE 0.) (DISPLAY :TURTLE NIL))
			 (DISALINE :PICTURE 0. 0. 1.)
			 (SETQ :XCOR 0.0 :YCOR 0.0)
			 (SETHEAD 0.)
			 '?) 

;;;MOVING THE TURTLE.  THE BASIC INTERFACE WITH THE DISPLAY IS "SETXY".

(DEFINE FORWARD (ABB FD) (R) (SETXY (PLUS :XCOR (TIMES R (SINE :HEADING)))
				    (PLUS :YCOR (TIMES R (COSINE :HEADING))))) 

(DEFINE BACK (ABB BK) (R) (FORWARD (MINUS R))) 

(DEFINE SETTURTLE (ABB SETT) (P) 
				 ;;(SETTURTLE '(100 100 90)) SETS THE STATE OF THE
				 ;;TURTLE TO THE POSITION '(100 100) AND HEADING 90. 
				 ;;THE HEADING IS OPTIONAL.  (SETTURTLE (HERE)) IS A
				 ;;NO-OP.
				 (SETXY (CAR P) (CADR P))
				 (AND (CDDR P) (SETHEAD (CADDR P)))) 

(DEFINE SETX (X) (SETXY X :YCOR)) 

(DEFINE SETY (Y) (SETXY :XCOR Y)) 

(DEFINE SETXY (X Y) 
	(AND (NOT :WRAP)
	     (OR (GREATERP (ABS X) :SCREENSIZE) (GREATERP (ABS Y) :SCREENSIZE))
	     (ERRBREAK 'SETXY 'TURTLE/ MOVING/ OFF/ SCREEN!))
	(SETQ :XCOR X :YCOR Y)
	(COND (:DSCALE (DISALINE :PICTURE
				 (ROUND (TIMES X :DSCALE))
				 (ROUND (TIMES Y :DSCALE))))
	      ((DISALINE :PICTURE (ROUND X) (ROUND Y))))
	'?) 

;;;TURNING THE TURTLE

(DEFINE RIGHT (ABB RT) (ANGLE) (SETHEAD (PLUS :HEADING ANGLE))) 

(DEFINE LEFT (ABB LT) (ANGLE) (SETHEAD (DIFFERENCE :HEADING ANGLE))) 

(DEFINE SETHEAD (ABB SH SETHEADING) (ANGLE) 
	;;UPDATES :HEADING AND ROTATES TURTLE.
	(SETQ :HEADING ANGLE)
	(COND ((= :TURTLE 0.)) ((HIDETURTLE) (SHOWTURTLE)))
	'?) 

(DEFINE WRAP NIL (SETQ :WRAP T) '?) 

(DEFINE NOWRAP NIL (SETQ :WRAP NIL) '?) 

;;EXAMINING THE TURTLE'S STATE

(DEFINE XHOME NIL (CAR (DISCRIBE :PICTURE))) 

;;RETURNS ABSOLUTE X SCOPE COORDINATE OF HOME

(DEFINE YHOME NIL (CADR (DISCRIBE :PICTURE))) 

(DEFINE HOMESTATE NIL (LIST (XHOME) (YHOME))) 

(DEFUN XCOORD NIL (CADDR (DISCRIBE :PICTURE))) 

;;ABSOLUTE X COORD

(DEFINE XCOR NIL (ROUND :XCOR)) 

;;SCALED X COORD

(DEFUN YCOORD NIL (CADDDR (DISCRIBE :PICTURE))) 

;;ABSOLUTE Y COORD

(DEFINE YCOR NIL (ROUND :YCOR)) 

;;SCALED Y COORD

(DEFINE HERE NIL (LIST (XCOR) (YCOR) (HEADING))) 

(DEFINE HEADING NIL 
	((LAMBDA (X) (OR (AND (MINUSP X) (+ 360. X)) X)) (\ (ROUND :HEADING) 360.))) 

;;THE PEN

(DEFINE PENDOWN (ABB PD) NIL (DISET :PICTURE -1.) '?) 

(DEFINE PENUP (ABB PU) NIL (DISET :PICTURE 1.) '?) 

(DEFINE PENSTATE ARGS (COND ((= ARGS 0.)
			     ;;(PENSTATE) = STATE OF PEN (PENSTATE <1, -1>) SETS PEN
			     ;;UP OR DOWN (PENSTATE (PENSTATE)) IS A NO-OP
			     (CADDDR (CDDDR (DISCRIBE :PICTURE))))
			    ((= ARGS 1.) (DISET :PICTURE (ARG 1.))))) 

(DEFINE PENP NIL (= (PENSTATE) -1.)) 

;;PENDOWN <=> PENSTATE = -1.  TRIG FNS
;;;
;;GLOBAL VARIABLES - FOLLOWS ANY POSSIBLE REMOBS

(SETQ :WRAP NIL 
      :DSCALE NIL 
      NEWTURTLE NIL 
      :TSIZE 30.0 
      :RAD3 1.7320508 
      :PI 3.1415926 
      PI-OVER-180 (//$ :PI 180.0) 
      :TURTLE 0. 
      ;;TURTLE = DEFAULT CROSS
      HOME '(512. 512.) 
      :SCREENSIZE 512.) 

;;MAX SCALED X,Y COORDINATE
;;*PAGE

;;THE TURTLE

(DEFINE MAKTURTLE (PARSE L) FEXPR (X) (SETQ NEWTURTLE X)
				      ;;MAKTURTLE SHOULD BE FOLLOWED BY A LOGO LINE. 
				      ;;QUOTES ARE NOT NECESSARY.  SHOWTURTLE
				      ;;INSPECTS NEWTURTLE VARIABLE TO DECIDE WHICH
				      ;;TURTLE TO SHOW.
				      (HIDETURTLE)
				      (SHOWTURTLE)) 

(DEFINE OLDTURTLE NIL (SETQ NEWTURTLE NIL) (HIDETURTLE) (SHOWTURTLE)) 

;;MOVING THE TURTLE.  THE BASIC INTERFACE WITH THE DISPLAY IS "SETXY".

(DEFINE DELX (X) (SETXY (PLUS X :XCOR) :YCOR)) 

(DEFINE DELY (Y) (SETXY :XCOR (PLUS :YCOR Y))) 

(DEFINE DELXY (X Y) (SETXY (PLUS :XCOR X) (PLUS :YCOR Y))) 

;;POINTS

(DEFINE POINT ARGS 
	(COND ((= ARGS 0.) (DISAPOINT :PICTURE (XCOORD) (YCOORD) -1.))
	      ((= ARGS 1.)
	       (DISAPOINT :PICTURE (ROUND (CAR (ARG 1.))) (ROUND (CADR (ARG 1.)))))
	      ((= ARGS 2.)
	       (DISAPOINT (ARG 1.) (ROUND (CAR (ARG 2.))) (ROUND (CADR (ARG 2.)))))
	      ((= ARGS 3.) (DISAPOINT (ARG 1.) (ROUND (ARG 2.)) (ROUND (ARG 3.)))))) 

;;EXAMINING THE TURTLE'S STATE

(DEFINE TURTLESTATE NIL (CADDDR (CDDDR (CDR (DISCRIBE :PICTURE))))) 

;;DISPLAYING TEXT

(DEFINE SHOWTEXT NIL 
		     ;;CLEARS TEXT AND DISPLAYS SUBSEQUENT PRINTING.
		     (SETQ :SHOW T)
		     (OR :TEXT (SETQ :TEXT (DISCREATE :TEXTXHOME :TEXTYHOME)))
		     '?) 

(DEFINE HIDETEXT NIL (SETQ :SHOW NIL) '?) 

(DEFINE REMTEXT NIL (ERRSET (DISFLUSH :TEXT) NIL)
		    ;;CLEARS TEXT AND TURNS OFF DISPLAY OF SUBSEQUENT TEXT OFF.
		    (SETQ :SHOW NIL :TEXT NIL)
		    '?) 

(DEFINE MARK (X) 
		 ;;PUTS TEXT AT CURRENT TURTLE POSITION.
		 ((LAMBDA (^W :SHOW :TEXT :TEXTXHOME :TEXTYHOME) (TYPE X EOL))
		  T
		  T
		  :PICTURE
		  (XCOORD)
		  (YCOORD))) 

;;POTS
;;;JOYSTICK = POTS 66 (HORIZ) AND 67 (VERTICAL). MUST BE CALIBRATED.
;;;ORDINARY POTS 0 - 3777

(DEFINE DIALS (X) (QUOTIENT (PROG2 (MPX 1. NIL)
				   ;;RETURNS VALUE OF POT X AS DECIMAL BETWEEN 0 AND
				   ;;1.  LSH USED TO ELIMINATE BAD BIT FROM IMPX.
				   (LSH (LSH (IMPX X) 1.) -1.)
				   (MPX 0. NIL))
			    2047.0)) 

;;PLOTTER FUNCTIONS.

(DEFINE NOPLOT NIL (PLOT 0.) '?) 

;;CLOSES PLOTTER

(SETQ PLOTS NIL) 

;;PROTECTION AGAINST GC.

(DEFINE PLOTTER FEXPR (A) 
 ;;WITH NO ARG, THE CURRENT DISPLAY IS PLOTTED ON A FRESH PAGE; ELSE IT IS PLOTTED
 ;;OVER THE CURRENT PAGE.  ERROR IF PLOTTER UNAVAILABLE, OTHERWISE OPENS PLOTTER. 
 ;;NEW PAGE IF NO ARG.
 (OR (ERRSET (PLOT 63.) NIL) (ERRBREAK 'PLOTTER 'PLOTTER/ UNAVAILABLE))
 (OR A (NEXTPLOT))
 (AND
  PLOTS
  (IOG
   NIL
   ;;ANSWER Y IF PLOTTER IS DONE WITH OLD PLOTS.
   (TYPE '";IS PLOTTER DONE WITH YOUR PREVIOUS PLOTTING? "
	 EOL)
   (AND (ASK) (SETQ PLOTS NIL))))
 (PLOTLIST (SETQ A (MAPCAR '(LAMBDA (X) (GET (DISGORGE X) 'ARRAY))
			   (DISLIST)))
	   '/.)
 ;;POINTS ARE PLOTTED AS "."
 (SETQ PLOTS (APPEND PLOTS A))
 ;;SAVE POINTER TO LIST OF ARRAYS WHICH THE IPL JOB IS PLOTTING TO AVOID ARRAYS
 ;;BEING GC'ED.
 '?) 

;;ANY TTY CHARACTER CAN BE USED.

(DEFINE DISPAGE NIL 
	;;DISPLAYS 7X11 PAGE OUTLINE.
	((LAMBDA (OASTATE) 
		 (SETQ :PAGE (DISCREATE) :SNAPS (PUSH ':PAGE :SNAPS))
		 (DISALINE :PAGE 0. 1023.)
		 (DISALINE :PAGE 791. 1023.)
		 (DISALINE :PAGE 791. 0.)
		 (DISALINE :PAGE 0. 0.)
		 (DISINI OASTATE))
	 (DISINI 1.))
	'?) 

;;GLOBAL STATE
;;;
;;ALL OF THE FOLLOWING COMMANDS CAN TAKE AN OPTIONAL FIRST ARGUMENT EVALUATING TO
;;SOME DISPLAY ITEM.  OTHERWISE, THEY REFER TO THE :PICTURE.

(DEFINE BLINK ARGS (COND ((= ARGS 0.) (DISBLINK :PICTURE T)) ((DISBLINK (ARG 1.) T)))
		   '?) 

(DEFINE UNBLINK ARGS 
	(COND ((= ARGS 0.) (DISBLINK :PICTURE NIL)) ((DISBLINK (ARG 1.) NIL)))
	'?) 

(DEFINE MOTION ARGS (COND ((= ARGS 0.) (DISMOTION :PICTURE -1. -1. 100.))
			  ((DISMOTION (ARG 1.) -1. -1. 100.)))) 

(DEFINE SETHOME ARGS 
	(COND ((= ARGS 0.)
	       (DISLOCATE :PICTURE (+ (XHOME) (XCOORD)) (+ (YHOME) (YCOORD)))
	       (HOME))
	      ((= ARGS 1.) ((LAMBDA (:PICTURE) (SETHOME)) (ARG 1.)))
	      ((= ARGS 2.) (DISLOCATE :PICTURE (ROUND (ARG 1.)) (ROUND (ARG 2.))))
	      ((DISLOCATE (ARG 1.) (ARG 2.) (ARG 3.))))
	'?) 

(DEFINE BRIGHT ARGS 
		    ;;;1 < BRIGHTNESS < 8
		    ;;;(BRIGHT) = BRIGHTNESS OF :PICTURE
		    ;;;(BRIGHT :SCENE) = BRIGHTNESS OF :SCENE
		    ;;;(BRIGHT :SCENE #) SETS BRIGHTNESS OF
		    ;;;:SCENE TO #.
		    (COND ((= ARGS 0.) (CADDR (CDDR (DISCRIBE :PICTURE))))
			  ((= 1. ARGS) (CADDR (CDDR (DISCRIBE (ARG 1.)))))
			  ((BSL (ARG 1.) (ARG 2.) (SCALE (ARG 1.)))))) 

(DEFINE SCALE ARGS 
		   ;;;1 < SCALE < 4
		   ;;;(SCALE) = SCALE OF :PICTURE
		   ;;;(SCALE :SCENE) = SCALE OF :SCENE
		   ;;(SCALE :SCENE #) SETS SCALE OF :SCENE TO #.
		   (COND ((= ARGS 0.) (CADDR (CDDDR (DISCRIBE :PICTURE))))
			 ((= 1. ARGS) (CADDR (CDDDR (DISCRIBE (ARG 1.)))))
			 ((BSL (ARG 1.) (BRIGHT (ARG 1.)) (ARG 2.))))) 

(DEFUN BSL (ITEM BR SCALE) 
       (DISCHANGE ITEM (DIFFERENCE BR (BRIGHT ITEM)) (DIFFERENCE SCALE (SCALE ITEM)))
       (DISET ITEM 0. (LIST BR SCALE))) 

(DEFINE DSCALE ARGS (COND ((= ARGS 0.) :DSCALE)
			  ((= 1. ARGS)
			   (OR :DSCALE (SETQ :DSCALE 1.0))
			   (SETQ :XCOR (TIMES (QUOTIENT :XCOR (ARG 1.)) :DSCALE))
			   (SETQ :YCOR (TIMES (QUOTIENT :YCOR (ARG 1.)) :DSCALE))
			   (SETQ :DSCALE (FLOAT (ARG 1.)))))) 

;;MANIPULATING SCENES

(DEFINE PHOTO (ABB SNAP) (PARSE L) 
 ;;CREATES A NEW COPY OF :PICTURE ON TOP OF THE CURRENT ONE.  THE SNAP HAS A COPY OF
 ;;THE CURRENT TURTLE, WHICH EG (PHOTO "SCENE" SQUARE 100) WILL BE MOVED AROUND AS
 ;;THE PEN POSITION OF THE SNAP MOVES. 
 FEXPR (X)
       (PROG (:SNAP NAME) 
	     (SETQ NAME (READLIST (CONS ': (EXPLODE (EVAL (CAR X))))))
	     (COND ((MEMQ NAME :SNAPS) (ERRSET (DISFLUSH (SYMEVAL NAME)) NIL))
		   ((PUSH NAME :SNAPS)))
	     (COND ((CDR X)
		    ;;IF GIVEN A LINE OF CODE, WILL PRODUCE A SNAP WITH THAT NAME
		    ;;CONTAINING RESULT OF CODE
		    (APPLY 'PICTURE (CDR X))
		    (PUTPROP NAME (GET ':SNAP 'SNAP) 'SNAP))
		   ((DISPLAY (SETQ :SNAP (DISCOPY :PICTURE)) T)
		    (OR (= :TURTLE 0.) (DISMARK :SNAP (DISCOPY :TURTLE)))
		    (PUTPROP NAME (LIST :XCOR :YCOR :HEADING) 'SNAP)))
	     (RETURN (SET NAME :SNAP)))) 

(DEFINE ENTERSNAP (PARSE 1.) FEXPR (X) 
	;;EG (SNAP "SCENE") REBINDS WORLD TO NEW SNAP.
	(APPLY 'PHOTO (LIST (CAR X) '(HIDETURTLE)))
	(SETQ X (READLIST (CONS ': (EXPLODE (EVAL (CAR X))))))
	;;X=NAME OF SNAP.
	(CHANGEWORLD X)) 

(DEFINE ENDSNAP NIL (CHANGEWORLD ':PICTURE)) 

;;RETURNS WORLD TO ORIGINAL :PICTURE

(DEFINE PICTURE (PARSE L) FEXPR (X) 
	;;:SNAP BOUND TO PICTURE
	(SETQ :SNAP (DISCREATE (XHOME) (YHOME)))
	(DISALINE :SNAP (XCOORD) (YCOORD) 1.)
	(DISET :SNAP (PENSTATE))
	((LAMBDA (:PICTURE :TURTLE :XCOR :YCOR :HEADING) 
		 ;;BIND PROTECTS STATE AGAINST ^G.
		 (OR (= :TURTLE 0.) (SETQ :TURTLE (DISCOPY :TURTLE)))
		 (DISMARK :PICTURE :TURTLE)
		 (ERRSET (MAPC 'EVAL X))
		 (SETQ :SNAP :PICTURE)
		 (PUTPROP ':SNAP (LIST :XCOR :YCOR :HEADING) 'SNAP))
	 :SNAP
	 :TURTLE
	 :XCOR
	 :YCOR
	 :HEADING)
	:SNAP) 

;;CREATE A NEW DISPLAY ITEM, BIND :SNAP TO IT, EXECUTE COMMAND LINE, SAVE (HERE) AS
;;SNAP PROPERTY OF :SNAP.  COMMANDS ONLY AFFECT :SNAP, WHICH IS A GLOBAL VARIABLE. 

(DEFINE REMSNAP (:SNAP) 
	(DISFLUSH :SNAP)
	(PROG (SNAPS SNAPNAME) 
	      (SETQ SNAPS :SNAPS)
	 LOOP (COND ((NULL SNAPS) (RETURN :SNAP))
		    ((EQUAL :SNAP (SYMEVAL (SETQ SNAPNAME (CAR :SNAPS))))
		     (REMPROP SNAPNAME 'SNAP)
		     (MAKUNBOUND SNAPNAME)
		     (SETQ :SNAPS (DELETE SNAPNAME :SNAPS))
		     (RETURN :SNAP)))
	      (POP SNAPS)
	      (GO LOOP))) 

(DEFUN CHANGEWORLD (SNAPNAME) 
       ;;EG SNAPNAME = :FOO
       (PROG (STATE) 
	     (SETQ :SNAP (COND ((AND (EQ SNAPNAME ':PICTURE)
				     (GET SNAPNAME 'ORIGINAL)))
			       ((SYMEVAL SNAPNAME))))
	     (OR (ERRSET (DISCRIBE :SNAP) NIL)
		 (ERRBREAK 'CHANGEWORLD
			   (LIST SNAPNAME 'IS/ NOT/ A/ SNAP)))
	     (AND WORLD
		  ;;REMEMBER OLD WORLD IF NAMED.
		  (NOT (NUMBERP WORLD))
		  (COND ((EQ WORLD ':PICTURE)
			 (PUTPROP ':PICTURE :PICTURE 'ORIGINAL))
			((SET WORLD :PICTURE)))
		  (PUTPROP WORLD (LIST :XCOR :YCOR :HEADING) 'SNAP))
	     (SETQ WORLD SNAPNAME 
		   :PICTURE :SNAP 
		   ;;:PICTURE NOW BECOMES :SNAP.
		   STATE (COND ((GET SNAPNAME 'SNAP))
			       ;;STATE OF :SNAP IS FOUND
			       ((LIST (COND (:DSCALE (QUOTIENT (XCOORD) :DSCALE))
					    ((XCOORD)))
				      (COND (:DSCALE (QUOTIENT (YCOORD) :DSCALE))
					    ((YCOORD)))
				      0.0))) 
		   :XCOR (CAR STATE) 
		   :YCOR (CADR STATE) 
		   :HEADING (CADDR STATE) 
		   :TURTLE (TURTLESTATE))
	     ;;TURTLE COMMANDS NOW REFER TO THE TURTLE WHICH RESIDES IN :SNAP. 
	     (RETURN :SNAP))) 

(DEFINE RESNAP (PARSE L) FEXPR (X) 
	;;E.G.  RESNAP :P1 FD 100 EXECUTES CODE WITH COPY OF TURTLE IN THAT SNAP.
	(COND ((CDR X)
	       (PROG (WORLD SNAPNAME :PICTURE :TURTLE :XCOR :YCOR :HEADING) 
		     (CHANGEWORLD (SETQ SNAPNAME (CAR X)))
		     ;;REBINDS STATE TO SNAP.
		     (ERRSET (MAPC 'EVAL (CDR X)))
		     (PUTPROP SNAPNAME (LIST :XCOR :YCOR :HEADING) 'SNAP)
		     (RETURN (SET SNAPNAME (SETQ :SNAP :PICTURE)))))
	      ((CHANGEWORLD (CAR X))))) 

(DEFINE SHOW (DNAME) 
		     ;;SHOW TRANSLATES THE SNAP TO CURRENT TURTLE POSITION AND
		     ;;DISPLAYS IT. 
		     (DISLOCATE DNAME (+ (XHOME) (XCOORD)) (+ (YHOME) (YCOORD)))
		     (DISPLAY DNAME T)) 

(DEFINE HIDE (DNAME) (DISPLAY DNAME NIL)) 

(DEFINE SHOWSNAP (X) 
	;;SHOWSNAP MAKES A COPY OF ITS INPUT, AND ITS INFERIORS, AND DISPLAYS IT AT
	;;THE CURRENT POSITION OF THE TURTLE.  COPY IS LINKED.
	(PROG (C) 
	      (SETQ C (DISCOPY (COND ((DISLIST X) (CAR (DISLIST X))) (X))))
	      (DISLOCATE C (+ (XHOME) (XCOORD)) (+ (YHOME) (YCOORD)))
	      (DISLINK X C T)
	      (DISPLAY C T)
	      (RETURN C))) 

(DEFINE HIDESNAP (X) (COND ((DISLIST X) (MAPC 'DISFLUSH (DISLIST X))))
		     (DISPLAY X NIL)) 

;;GLOBAL NAVIGATION

(DEFINE TOWARDS ARGS 
	;;DIRECTION OF A POINT RELATIVE TO TURTLE HEADING.  +0-360 DEGREES.  POINT =
	;;(X Y).
	(PROG (X Y TEMP) 
	      (COND ((= ARGS 1.) (SETQ X (CAR (ARG 1.))) (SETQ Y (CADR (ARG 1.))))
		    ((SETQ X (ARG 1.)) (SETQ Y (ARG 2.))))
	      (COND ((MINUSP (SETQ TEMP (DIFFERENCE (BEARING X Y) (HEADING))))
		     (RETURN (PLUS 360. TEMP)))
		    ((RETURN TEMP))))) 

(DEFINE BEARING ARGS 
	(PROG (X Y TEMP X1 Y1) 
	      (COND ((= ARGS 1.) (SETQ X (CAR (ARG 1.))) (SETQ Y (CADR (ARG 1.))))
		    ((SETQ X (ARG 1.)) (SETQ Y (ARG 2.))))
	      (SETQ X1 (DIFFERENCE X :XCOR) Y1 (DIFFERENCE Y :YCOR))
	      ;;;+0-360 DEGREES. POINT = (X Y)
	      ;;MADE NECESSARY SINCE (ATAN 0 0) = 45 DEGREES.
	      (AND (LESSP (ABS X1) 0.01) (LESSP (ABS Y1) 0.01) (RETURN 0.))
	      (SETQ TEMP (*$ 180.0
			     (//$ (ATAN (DIFFERENCE (FLOAT X) :XCOR)
					(DIFFERENCE (FLOAT Y) :YCOR))
				  :PI)))
	      (AND (MINUSP TEMP) (SETQ TEMP (DIFFERENCE 360. TEMP)))
	      (RETURN (OR (AND (FIXP X) (FIXP Y) (ROUND TEMP)) TEMP)))) 

(DEFINE RANGE ARGS 
	(PROG (X Y TEMP) 
	      (COND ((= ARGS 1.) (SETQ X (CAR (ARG 1.))) (SETQ Y (CADR (ARG 1.))))
		    ((SETQ X (ARG 1.)) (SETQ Y (ARG 2.))))
	      (SETQ TEMP (SQRT (PLUS (EXPT (DIFFERENCE X :XCOR) 2.)
				     (EXPT (DIFFERENCE Y :YCOR) 2.))))
	      (RETURN (OR (AND (FIXP X) (FIXP Y) (ROUND TEMP)) TEMP)))) 

;;GLOBAL VARIABLES - FOLLOWS ANY POSSIBLE REMOBS

(SETQ :SNAPS NIL) 

(SETQ :TEXTXHOME 0.) 

;;TEXT ARRAY X COORDINATE

(SETQ :TEXTYHOME 1000.) 

;;TEXT ARRAY Y COORDINATE
;;;A TURTLE SCENE CONSISTS OF ANY SUBSET OF FOLLOWING ARRAYS:
;;;	:TURTLE
;;;	:PICTURE
;;;	:TEXT
;;;	AND ANY SNAPS THAT HAVE BEEN CREATED.
;;;
;;;TO SAVE A TURTLE SCENE, 
;;:SNAPS IS A LIST OF ARRAY NAMES BUG IN SLAVE - DISGOBBLE CAUSES SLAVE TO DIE.

(DEFINE SAVESNAPS FEXPR (X) 
	(MAPC '(LAMBDA (X) (PUTPROP X
				    (GET (DISGORGE (SYMEVAL X)) 'ARRAY)
				    'ARRAY))
	      :SNAPS)
	(APPLY 'DUMPARRAYS
	       (LIST :SNAPS
		     (FILESPEC (COND ((CDR X) X) ((LIST (CAR X) 'SNAPS))))))
	(MAPC '(LAMBDA (X) (REMPROP X 'ARRAY)) :SNAPS)) 

(DEFINE GETSNAPS FEXPR (X) 
	(MAPC '(LAMBDA (Y) ((LAMBDA (:PICTURE SNAPNAM) 
				    (SETQ :PICTURE (DISGOBBLE :PICTURE))
				    (SET SNAPNAM :PICTURE)
				    (PUTPROP SNAPNAM
					     (LIST (XCOORD) (YCOORD) 0.0)
					     'SNAP)
				    (COND ((MEMQ SNAPNAM :SNAPS)
					   (TYPE '/;
						 SNAPNAM
						 '" CONFLICTS"
						 EOL))
					  ((PUSH SNAPNAM :SNAPS))))
			    (CAR Y)
			    (CADR Y)))
	      (LOADARRAYS (FILESPEC X)))) 

;;;ARC PROCEDURES

(SETQ :POLYGON 30.) 

(DEFINE ARC (RADIUS DEGREES) 
	(PROG (HT SIDE TURN SIDES CENTER) 
	      (COND ((= :TURTLE 0.)) ((SETQ HT T) (HIDETURTLE)))
	      (SETQ SIDE (TIMES 2. RADIUS (SIN (QUOTIENT :PI :POLYGON))) 
		    TURN (QUOTIENT 360.0 :POLYGON) 
		    SIDES (QUOTIENT DEGREES TURN) 
		    CENTER (HERE))
	      (PENUP)
	      (FORWARD RADIUS)
	      (RIGHT 90.)
	      (PENDOWN)
	 LOOP (COND ((LESSP SIDES 1.)
		     (RIGHT (QUOTIENT TURN 2.))
		     (FORWARD (TIMES SIDES SIDE)))
		    (T (RIGHT (QUOTIENT TURN 2.))
		       (FORWARD SIDE)
		       (RIGHT (QUOTIENT TURN 2.))
		       (SETQ SIDES (DIFFERENCE SIDES 1.))
		       (GO LOOP)))
	      (PENUP)
	      (SETXY (CAR CENTER) (CADR CENTER))
	      (SETHEAD (PLUS (CADDR CENTER) DEGREES))
	      (PENDOWN)
	      (AND HT (SHOWTURTLE))
	      (RETURN '?))) 
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;			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 AI 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 '?))
 


;;;          LLOGO MUSIC BOX PRIMITIVES
;;;								       ; SEE HARDWARE
;;MEMOS 8 AND 9.

;;*SLASHIFY #

(DECLARE (OR (STATUS FEATURE DEFINE) (FASLOAD DEFINE FASL AI LLOGO)))

(DECLARE (GENPREFIX MUSIC)
	 (SPECIAL :INSTRUMENT :NVOICES :SCALEBASE :VOICE :SAVBUF BUFFERS NEWMUSIC
		  MODMUSIC DEFAULTSCALEBASE CBUF1 CBUF2 CBUF3 CBUF4 WBUF1 WBUF2 WBUF3
		  WBUF4 CBUF WBUF ERRLIST)
	 (*FEXPR QUERY NOTIMP CHORUS4 CHORUS3 CHORUS2 CHORUS)
	 (*LEXPR ERRBREAK)
	 (*EXPR NEWMUSIC MODMUSIC)) 

;; THIS FILE WILL USE BASE 10 NUMBERS (FOLLOWED BY ".")

(SSTATUS FEATURE MUSIC) 

(COND ((STATUS FEATURE LLOGO)
       (MAPC '(LAMBDA (BOTH-OBARRAY-ATOM) (OBTERN BOTH-OBARRAY-ATOM LOGO-OBARRAY))
	     '(N O :INSTRUMENT :MAX :NVOICES :VOICE :SCALEBASE :SAVBUF LEGATO)))
      ((DEFPROP MAKE SET EXPR)
       (DEFUN HOMCHECK (USELESS) USELESS)
       (DEFUN OBTERN (IGNORE THIS) IGNORE)
       (DEFUN ERRBREAK ARGS (PRINT (ARG ARGS)) (APPLY (FUNCTION BREAK) (LIST (ARG 1.) T)))
       (DEFUN REQUEST NIL (TERPRI) (PRINC '<) (READ)))) 

[MULTICS (DECLARE (*FEXPR TURN_RAWO_ON TURN_RAWO_OFF)) 
	 (CLINE
	  "INITIATE >UDD>AP>LIB>TURN_RAWO_ON TURN_RAWO_ON TURN_RAWO_OFF") 
	 (PUTPROP 'TURN_RAWO_ON
		  (DEFSUBR "TURN_RAWO_ON"
			   "TURN_RAWO_ON"
			   0.)
		  'FSUBR) 
	 (PUTPROP 'TURN_RAWO_OFF
		  (DEFSUBR "TURN_RAWO_OFF"
			   "TURN_RAWO_OFF"
			   0.)
		  'FSUBR)] 

;;SUBROUTINES FOR TURNING ON AND OFF "RAW" OR IMAGE MODE OUTPUT.  THIS OUTPUTS CHARACTERS
;;LIKE CONTROL CHARACTERS DIRECTLY, RATHER THAN AS ORDINARY CHARACTERS PRECEDED BY
;;UPARROW [ITS] OR BACKSLASH [MULTICS].  QUITTING MUST BE DISABLED FROM INSIDE THE SYSTEM
;;CALL.

;;THE FOLLOWING LAP FUNCTIONS WILL PROBABLY NEED CHANGING
;;WHEN NEW I/O SYSTEM EXISTS ON ITS LISP.

[ITS (DECLARE (*EXPR TURN_RAWO_ON TURN_RAWO_OFF)) 
     (LAP TURN_RAWO_ON SUBR) 
     (ARGS TURN_RAWO_ON (NIL . 0.)) 
     (HLLOS 0. NOQUIT) 
     (*OPEN 2. (% SIXBIT / / %TTY)) 
     (*VALUE) 
     (HLLZS 0. NOQUIT) 
     (POPJ P) 
     NIL 
     (LAP TURN_RAWO_OFF SUBR) 
     (ARGS TURN_RAWO_OFF (NIL . 0.)) 
     (HLLOS 0. NOQUIT) 
     (*OPEN 2. (% SIXBIT / / 1TTY/.LISP/./ OUTPUT)) 
     (*VALUE) 
     (HLLZS 0. NOQUIT) 
     (POPJ P) 
     NIL 
     NIL] 

(DEFINE INITMUSIC NIL 
	;; INITIALIZE . DONT WANT SPURIOUS CR/LF ON PRINC.
	(SSTATUS TERPRI T)
	(SETQ BUFFERS '(WBUF1 WBUF2 WBUF3 WBUF4 CBUF1 CBUF2 CBUF3 CBUF4))
	(TERPRI)
	(PRINC 'YOU/ ARE/ NOW/ USING/ THE/ LLOGO/ MINIMUSIC/ SYSTEM/.)
	(COND ((EQ (QUERY / / / WHICH MUSIC BOX? (N OR O)) 'N) (NEWMUSIC))
	      ((OLDMUSIC)))
	(SETQ :SAVBUF NIL :INSTRUMENT 'LEGATO DEFAULTSCALEBASE 0.)
	(MODMUSIC NIL)
	(NVOICES 4.)) 

(DEFINE STARTMUSIC (ABB SM) NIL (QUERY TURN ON MUSIC BOX/, THEN TYPE /"OK/"/.) (PERFORM)) 

(DEFINE RESTARTMUSIC NIL (INITMUSIC) (STARTMUSIC)) 

(DEFUN WBUFS MACRO (X) '(LIST WBUF1 WBUF2 WBUF3 WBUF4)) 

(DEFUN CBUFS MACRO (X) '(LIST CBUF1 CBUF2 CBUF3 CBUF4)) 

(DEFUN VNEXT MACRO (X) 
       ;; THE NEXT THREE DEFS ALLOW SING TO TAKE PERCUSSION NOTES BY NAME; USING DRUM AND
       ;;BRUSH IS MORE EFFICIENT.
       (LIST '1+ (LIST 'REMAINDER (CADR X) ':NVOICES))) 

(DEFINE REST NIL (- -25. :SCALEBASE)) 

(DEFINE BOOM NIL (- -24. :SCALEBASE)) 

(DEFINE GRITCH NIL (- -23. :SCALEBASE)) 

(DEFINE DRUM (DLIST) 
	(MAPC (FUNCTION (LAMBDA (D) (PLAY1 '/!) (PLAY '/  (SUB1 D)))) DLIST)
	'?) 

(DEFINE BRUSH (DLIST) 
	(MAPC (FUNCTION (LAMBDA (D) (PLAY1 '/") (PLAY '/  (SUB1 D)))) DLIST)
	'?) 

(DEFUN BCNT (A B) (+ (* 25. (CAAR A)) (CAAR B))) 

(DEFINE CHORUS2 (PARSE 2.) FEXPR (X) (APPLY (FUNCTION CHORUS4) X)) 

(DEFINE CHORUS3 (PARSE 3.) FEXPR (X) (APPLY (FUNCTION CHORUS4) X)) 

(DEFINE CHORUS4 (PARSE 4.) FEXPR (X) 
	(TERPRI)
	(PRINC '/(TRY/ USING/ CHORUS/ NEXT/ TIME/ YOU/'LL/ LIKE/ IT/))
	(APPLY (FUNCTION CHORUS) X)) 

(DEFINE MBUFINIT NIL (NOTIMP MBUFINIT MBUFCLEAR)) 

(DEFINE MBUFPUT X (NOTIMP MBUFPUT PLAY)) 

(DEFINE MBUFNEXT (N) (NOTIMP MBUFNEXT ?)) 

(DEFINE MLEN (ABB :MAX) NIL (APPLY (FUNCTION MAX)
				   ;; NUMBER OF NOTES IN LARGEST BUFFER.
				   (MAPCAR (FUNCTION BCNT) (WBUFS) (CBUFS)))) 

(DEFINE VLEN (ABB MBUFCOUNT) NIL (BCNT WBUF CBUF)) 

;; NUMBER NOTES IN CURRENT BUFFER.

(DEFINE NOMUSIC NIL (NOTIMP NOMUSIC ?)) 

(DEFINE PERFORM (ABB PM) NIL (MBUFOUT) (MBUFCLEAR)) 

(DEFINE NEWMUSIC NIL 
		     ;; ASK WHICH PORT (4 IS TTY).
		     (SETQ NEWMUSIC
			   (QUERY / / / WHICH PORT IS MUSIC BOX? (1/, 2. OR 3.))
			   NEWMUSIC
			   (COND ((= NEWMUSIC 1.) 79.)
				 ;; LETTER O
				 ((= NEWMUSIC 3.) 69.)
				 ;;LETTER E
				 (74.))
			   ;; LETTER J
			   ERRLIST
			   '((TURN_RAWO_ON) (TYO 17.) (TYO 32.) (TURN_RAWO_OFF)))
		     ;;CNTRL-Q SPACE (RESTORE TTY)
		     (AND (BOUNDP ':NVOICES) (= :NVOICES 3.) (NVOICES 4.))
		     '?) 

(DEFINE OLDMUSIC NIL (SETQ NEWMUSIC NIL 
			   ERRLIST '((TURN_RAWO_ON)
				     (MAPC 'TYO
					   '(99. 103. 32. 32. 32. 32. 32. 71. 32. 65.
					     32. 32. 32. 32. 32. 32. 32. 66.))
				     (TURN_RAWO_OFF)))
		     '?) 

(DEFINE MBUFCLEAR (ABB MCLEAR) NIL (MAPC (FUNCTION STARTATTACH) BUFFERS) (VOICE 1.)) 

(DEFINE MODMUSIC (TORNIL) (COND ((SETQ MODMUSIC TORNIL) (SETQ :SCALEBASE -25.))
				((SETQ :SCALEBASE DEFAULTSCALEBASE)))) 

(DEFINE VOICES (N) (NOTIMP VOICES NVOICES)) 

(DEFUN NOTIMP FEXPR (X) 
       (ERRBREAK (CAR X)
		 (LIST '"NOT IMPLEMENTED IN LLOGO: USE"
		       (CADR X)))) 

(DEFINE VOICE (N) 
	(SETQ :VOICE N)
	(COND ((AND NEWMUSIC (= N 3.) (< :NVOICES 4.)) (NVOICES 4.))
	      ((< :NVOICES N) (NVOICES N)))
	(COND ((= N 1.) (SETQ CBUF CBUF1 WBUF WBUF1))
	      ((= N 2.) (SETQ CBUF CBUF2 WBUF WBUF2))
	      ((= N 3.) (SETQ CBUF CBUF3 WBUF WBUF3))
	      ((= N 4.) (SETQ CBUF CBUF4 WBUF WBUF4))
	      (MODMUSIC (VOICE (VNEXT (SUB1 N))))
	      ((ERRBREAK 'VOICE '"NO SUCH VOICE")))
	'?) 

(DEFINE NVOICES (N) 
 (COND ((AND NEWMUSIC (= N 3.))
	(ERRBREAK 'NVOICES
		  '"3. VOICES ILLEGAL ON NEW BOX USE 4."))
       ((AND (> N 0.) (< N 5.)) (SETQ :NVOICES N))
       (MODMUSIC (NVOICES (1+ (REMAINDER (SUB1 N) 4.))))
       ((ERRBREAK 'NVOICES '"NO SUCH VOICE")))
 (MBUFCLEAR)) 

(DEFUN CRUNCH (CBUF WBUF) 
       (COND ((CDDR CBUF) (ATTACH1 WBUF (MAKNAM (CDDR CBUF))) (STARTATTACH (CADR CBUF)))
	     (CBUF))) 

(DEFUN PLAY1 (NOTE) 
       ;; CRUNCHES A CHARACTER LIST INTO A PNAME ATOM AND PUTS IT ON A WORD LIST WHICH IS
       ;;ASSOCIATED WITH IT.  NOTE THAT (CADR LST) IS THE NAME OF THE LIST, AND (CAR LST)
       ;;HAS INTERNAL INFO (COUNT, PTR), SINCE THESE ARE "ATTACH LISTS".  NORMALLY ONE
       ;;WANTS TO SAY (SETQ CBUF (CRUNCH CBUF WBUF))! JUST THE CHAR PART REINITIALIZE
       ;;PUTS NOTE IN THE CURRENT CHAR BUF EVERY 25 CHARS, WE CRUNCH TO CONSERVE FREE
       ;;SPACE.  (ATTACH1 RETURNS THE NUMBER OF CHARS SO FAR).
       (AND (> (ATTACH1 CBUF NOTE) 24.) (SETQ CBUF (CRUNCH CBUF WBUF)))) 

(DEFUN PLAY (NOTE TIMS) (DO I 1. (1+ I) (> I TIMS) (PLAY1 NOTE))) 

(DEFINE SING (PITCH DUR) 
	(PLAY1 (SETQ PITCH (NOTECH PITCH)))
	;; PUTS THE NOTE CORRESPONDING TO THIS PITCH NUMBER INTO THE CURRENT BUFFER (SEE
	;;PLAY).  FILLS THE DURATION WITH NOTES OR BLANKS DEPENDING ON WHETHER LEGATO OR
	;;NOT.  IF DURATION AT LEAST 2 WILL LEAVE AT LEAST ONE UNIT REST BETWEEN NOTES.
	(PLAY (COND ((EQ :INSTRUMENT 'LEGATO) PITCH) ('/ )) (- DUR 2.))
	(AND (> DUR 1.) (PLAY1 '/ ))
	'?) 

(DEFINE SONG (A B) (MAPC (FUNCTION SING) A B) '?) 

(DEFINE CHORUS (PARSE L) FEXPR (COMS) 
	;;CHECK FOR WRONG NUMBER? FOR RECURSION
	(MAPC (FUNCTION (LAMBDA (X) (EVAL X) (VOICE (VNEXT :VOICE)))) COMS)
	'?) 

(DEFINE NOTE (P D) 
	;; NOT QUITE SYNONYM, 11LOGO VARIANT OF SING.
	(COND ((= P -28.) (PLAY '/  D))
	      ((= P -27.) (DRUM (LIST D)))
	      ((= P -26.) (BRUSH (LIST D)))
	      ((= P -25.)
	       (ERRBREAK 'NOTE '"NOT A VALID PITCH"))
	      ((SING (+ P 3.) D)))) 

(DEFUN NOTECH (P) 
       ;; A MUSIC BOX NOTE IS AN ASCII CHAR IN OCTAL [40, 137] A STD LOGO PITCH IS A
       ;;NUMBER IN DECIMAL [-25.,38.] (0 = MIDDLE C) :SCALEBASE SPECIFIES OFFSETS FROM
       ;;STD, RELATIVE TO MIDDLEC 0.  MODMUSIC NUMBERS FROM 0.  TO DECIMAL 63.  (IE
       ;;:SCALEBASE = -25.) MODMUSIC FEATURES "WRAPAROUND" , IE PITCH 64 = PITCH 0. 
       ;;"NOTECH" RETURNS ASCII CHARS FOR PITCHS.  140 OCTAL 37 OCTAL OCT 37 IS A NULL
       ;;CHAR.  IGNORED BY BOX.
       (COND (MODMUSIC (ASCII (+ 32. (REMAINDER P 64.))))
	     ((AND (< (SETQ P (+ P :SCALEBASE 57.)) 96.) (> P 31.)) (ASCII P))
	     ((PRINT '"NOTE OUT OF MUSIC BOX RANGE")
	      (ASCII 31.)))) 

(DEFUN STARTATTACH (LNAM) 
       ;; STARTS AN ATTACH LIST OF FORM ((CNT . PTR) LNAM) FOR USE WITH ATTACH, ATTACH1
       ;;COUNT IS THE NUMBER OF ELEMENTS IN (CDDR LST) PTR IS A PTR TO THE END OF THE
       ;;LST.
       (RPLACA (SET LNAM (LIST NIL LNAM)) (CONS 0. (CDR (EVAL LNAM))))) 

(DEFUN ATTACH1 (LST EL) 
       ;; ATTACHES ATOM EL TO LIST LST LIST MUST BE AT LEAST TWO ELEMENTS LONG.  THE
       ;;FIRST ELEMENT IS ASSUMED TO BE A DOTTED PAIR -- A COUNT OF THE ELEMENTS IN (CDDR
       ;;LST) AND A PTR TO THE END.  THE SECOND ELEMENT IS THE NAME OF THE LIST ITSELF. 
       ;;THIS INTERNAL INFO IS UPDATED BY ATTACH.  VALUE RETURNED IS THE NEW COUNT.  NEW
       ;;LISTS SHOULD BE INITIALIZED USING STARTATTACH.  (NCONS IS DEFINED AS (CONS EL
       ;;NIL)).
       (CAR (RPLACA (RPLACD (CAR LST) (CDR (RPLACD (CDAR LST) (NCONS EL))))
		    (1+ (CAAR LST))))) 

(DEFUN MLTPLX (T1 T2 T3 T4 N) 
       ;; MLTPLX 1 TO 4 ARGS (N), IGNORE REST .
       (PROG (CBUF WBUF) 
	     ;;; REBIND .
	     (COND ((< N 2.) (RETURN T1))
		   ((< N 3.) (SETQ T3 (SETQ T4 NIL)))
		   ((< N 4.) (SETQ T4 NIL)))
	     (STARTATTACH 'CBUF)
	     (STARTATTACH 'WBUF)
	TOP  (OR T1 T2 T3 T4 (PROG2 (CRUNCH CBUF WBUF) (RETURN (CDDR WBUF))))
	     (SETQ T1 (ZAP T1) T2 (ZAP T2))
	     (AND (< N 3.) (GO TOP))
	     (SETQ T3 (ZAP T3))
	     (AND (> N 3.) (SETQ T4 (ZAP T4)))
	     (GO TOP))) 

(DEFUN ZAP (TB) 
       (COND (TB (AND (GETCHAR (CAR TB) 2.)
		      (SETQ TB (NCONC (EXPLODEC (CAR TB)) (CDR TB))))
		 (PLAY1 (CAR TB))
		 (CDR TB))
	     ((PLAY1 '/ ) NIL))) 

(DEFINE MBUFOUT NIL (PLYTUN (MAKTUN))) 

(DEFINE MAKETUNE (TUN) (MAKE TUN (CONS :NVOICES (MAKTUN))) TUN) 

;; NEED TO KNOW # VOICES.

(DEFINE PLAYTUNE (TUN) ((LAMBDA (OLDV) (NVOICES (CAR TUN))
				       ;;ELSE GARBAGE
				       (PLYTUN (CDR TUN))
				       ;;WINS EVEN IF DIFFERENT M.BOX
				       (NVOICES OLDV))
			:NVOICES)
		       '?) 

;; RESTORE PREVIOUS STATE

(DEFUN MAKTUN NIL 
       (MAPC (FUNCTION CRUNCH) (CBUFS) (WBUFS))
       (MLTPLX (CDDR WBUF1) (CDDR WBUF2) (CDDR WBUF3) (CDDR WBUF4) :NVOICES)) 

(DEFUN PLYTUN (TUN) 
       ;; TUN IS PRE-MLTPLXED CHAR LIST
       (TURN_RAWO_ON)
       (COND (NEWMUSIC (TYO 17.)
		       ;; CNTRL-Q (REAL)
		       (TYO NEWMUSIC)
		       ;; PORT SELECTOR
		       (PRINC '/#0/ / / / /#)
		       (TYO (COND ((= :NVOICES 1.) 83.)
				  ;; LETTER S
				  ((= :NVOICES 2.) 34.)
				  ;; DOUBLE QUOTE
				  (48.))))
	     ;; NUMERAL 0
	     ((PRINC '/c/g/ / / / / )
	      (TYO (+ 99. :NVOICES))
	      (PRINC '/ /a/ / / / / / / )))
       (MAPC (FUNCTION PRINC) TUN)
       (COND (NEWMUSIC (TYO 17.) (TYO 32.))
	     ;; ^Q-SPACE RESTORE PORT 4 (TTY)
	     ((TYO 98.)))
       (TURN_RAWO_OFF)
       ;; LOWER B, RESTORE EXECUPORT PRINTER
       '?) 

(DEFUN QUERY FEXPR (X) 
       (TERPRI)
       (MAPC (FUNCTION (LAMBDA (Y) (PRINC Y) (TYO 32.))) X)
       ;;; 32. A SPACE
       (REQUEST)) 

(INITMUSIC) 

;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;            		Lisp Logo TV Turtle				      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;

;;; 
;;TV'S HAVE 455.  VERTICAL LINES OF 576.  DOTS EACH (262080.  BITS OUT 'O 262144). 
;;MEMORY IS ORGANIZED AS 9 64.-BIT WORDS (EQUIV TO 18.  32.-BIT WORDS) PER LINE. 
;;THE PDP10 ACCESSES HALF OF SUCH A WORD (OR TWO 16.-BIT CHUNKS) AT ONCE.  THESE 32. 
;;BITS ARE PACKED LEFT JUSTIFIED INTO THE 36.  BITS.  TVEND (OR THE LAST WORD OF THE
;;TV-MEMORY) HAS TWO FUNCTIONS: BIT 200000 WHEN ON, COMPLEMENTS THE BLACK/WHITE
;;OUTPUT.  BITS 177760 ARE A WORD-COUNTER FOR WHICH 64.-BIT WORD THE FRAME IS TO
;;START ON.  FOR WINNAGE THE NUMBER OUGHT TO BE A MULTIPLE OF 9.  CHARACTERS ARE 10. 
;;LINES HIGH AND 5 POINTS WIDE (RIGHT AND TOP JUSTIFIED).  LINE-PITCH IS 12. 
;;TV-LINES, CHARACTER-PITCH IS 6 TV-POINTS.  THATS 96.  CHRS/LINE EXACTLY AND 37. 
;;AND 11./12.  LINES (3552.  CHRS).

(DECLARE (EVAL (READ)) (EVAL (READ)))

(OR (STATUS FEATURE DEFINE) (FASLOAD DEFINE FASL AI LLOGO))

(COND ((BOUNDP 'COLOR) (SETQ BW (NOT COLOR)))
      ;;READ-TIME SWITCHES FOR COLOR OR BLACK AND WHITE SYSTEM.
      ;;TO SET SWITCHES, DO E.G., &(SETQ COLOR T) IN CONTROL-G'ED NCOMPLR.
      ((BOUNDP 'BW) (SETQ COLOR (NOT BW)))
      ((SETQ COLOR NIL BW T)))


(SSTATUS FEATURE TVRTLE) 

[COLOR (SSTATUS FEATURE COLOR)
       (SETQ COLOR T BW NIL)]

[BW (SETQ BW T COLOR NIL)]

[COLOR (DEFUN NOT-IMPLEMENTED-IN-COLOR (LOSING-FORM)
              (PRINC '/;)
              (AND LOSING-FORM (PRINC LOSING-FORM))
              (PRINC '" NOT IMPLEMENTED IN COLOR TURTLE")
              (TERPRI)
              NO-VALUE)]

[BW (DEFUN NOT-IMPLEMENTED-IN-BW (LOSING-FORM)
           (PRINC '/;)
           (AND LOSING-FORM (PRINC LOSING-FORM))
           (PRINC '" IMPLEMENTED IN COLOR TURTLE ONLY")
           (TERPRI)
           NO-VALUE)]

(DECLARE (GENPREFIX TVRTLE-)) 

(AND (STATUS FEATURE BIBOP) (ALLOC '(FLONUM (3000. 4000. NIL) FLPDL 2000.))) 

(COND
 ((STATUS FEATURE LLOGO)
  ;;PUT GLOBAL VARIABLES ON LOGO OBARRAY.
  (READ-ONLY :XCOR :YCOR :HEADING :PENSTATE :ERASERSTATE :SEETURTLE :ECHOLINES 
             :TVECHOLINES :PI :POLYGON :WRAP  :CLIP :DRAWMODE :XORSTATE :TURTLE 
             :PATTERNS :TURTLES :WINDOWS :DRAWTURTLE :ERASETURTLE :BRUSH 
             :PENCOLOR :ERASERCOLOR :PENNUMBER :ERASERNUMBER :COLORS)
  (SYSTEM-VARIABLE :OUTLINE :WINDOWOUTLINE :COLORTICK :NCOLORS)
  (MAPC '(LAMBDA (LOGO-ATOM) (OBTERN LOGO-ATOM LOGO-OBARRAY))
	'(TV IOR ANDC SETZ COMP XOR EQV SAME LOGOTURTLE 
          COLOR BLACK PALETTE WHITE RED GREEN BLUE YELLOW PURPLE MAGENTA CYAN 
          ORANGE GOLD PINK GRAY LIGHTGRAY DARKGRAY TURTLE)))
 ((DEFUN HOMCHECK (USELESS) USELESS)
  (DEFUN OBTERN (IGNORE THIS) IGNORE)
  (DEFUN SYMBOLP (MAYBE-SYMBOL) 
	 (AND MAYBE-SYMBOL (EQ (TYPEP MAYBE-SYMBOL) 'SYMBOL)))
  ;;DEFINE FUNCTIONS CALLED FROM TVRTLE, NORMALLY IN LLOGO.
  (DEFUN FILESPEC (X) 
	 (OR (APPLY 'AND (MAPCAR 'ATOM X))
	     (SETQ X
		   (ERRBREAK 'FILESPEC
			     (LIST X
				   '"IS NOT A FILE NAME"))))
	 (COND ((NULL X) (APPEND (STATUS CRFILE) (CRUNIT)))
	       ((NOT (CDR X)) (APPEND X '(>) (CRUNIT)))
	       ((NOT (CDDR X)) (APPEND X (CRUNIT)))
	       ((NOT (CDDDR X))
		(APPEND (LIST (CAR X) (CADR X)) '(DSK) (CDDR X)))
	       (X)))
  (DEFUN FUNCTION-PROP (F) 
	 (GETL F '(EXPR FEXPR MACRO SUBR LSUBR FSUBR ARRAY AUTOLOAD)))
  (SETQ LISP-OBARRAY OBARRAY LISP-READTABLE READTABLE)
  ;;SAVE/GETWINDOW REQUIRES FILESPEC.
  (DEFUN TYPE ARGS (DO ((I 1. (1+ I))) ((> I ARGS) (ARG (1- I))) (PRINC (ARG I))))
  ;;TYPE USED BY MARK, HOMCHECK, OBTERN OUTPUT BY DEFINE.
  (DEFUN ERRBREAK ARGS (PRINC (ARG 1.)) (APPLY 'BREAK (LIST (ARG 2.) T)))
  (SETQ NO-VALUE '?))) 

;;SYMBOLS MUST BE LOADED TO CALL GETCOR, SACONS.

(VALRET '" :SYMLOD
:VP
") 

;;*PAGE

;;;

(COMMENT LAP ROUTINES) 

;;;
;;THE FOLLOWING ROUTINE GETS A 10K BLOCK OF CORE RESERVED FROM LISP FOR THE TV ARRAY
;;VIA GETCOR, AND SETS UP THE ARRAY HEADER TO POINT TO IT CORRECTLY. 
;;AN ORDINARY LISP ARRAY CANNOT BE USED SINCE IT MUST BE PROTECTED FROM NORMAL ARRAY
;;RELOCATION DURING GARBAGE COLLECTION, ETC.
;;;

;;;			FORMAT OF LISP ARRAYS.
;;;
;;A LISP ARRAY HAS A TWO WORD HEADER ["SAR"], CREATED BY CALLING THE INTERNAL LISP
;;ROUTINE SACONS.  THE FIRST WORD IS CALLED THE "ASAR", SECOND THE "TTSAR". THE
;;OCTAL NUMBER PRINTED OUT IN ARRAY POINTERS IS THE ASAR, ASSEMBLING (ARRAY FOO) IN
;;LAP YIELDS POINTER TO THE TTSAR. FOR A TWO DIMENSIONAL FIXNUM ARRAY THEY ARE AS
;;FOLLOWS:
;;;
;;; ASAR: 	200 [TYPE CODE FOR FIXNUM] 
;;;             ,, <POINTER TO START OF INSTRUCTION-BLOCK>
;;; TTSAR:	100107 [WHERE 1 IS THE NUMBER OF DIMENSIONS, 
;;;		       107 IS (TT) [INDEXED BY TT]] 
;;;             ,, <POINTER TO START OF ARRAY-DATA>
;;;
;;THE BLOCK OF DATA FOR THE ARRAY IS AS FOLLOWS:
;;;
;;;		-1 [MINUS NUMBER OF DIMENSIONS] ,, <POINTER TO START OF ARRAY-DATA>
;;; INSTRUCTION-BLOCK:
;;;		PUSHJ P, CFIX1 [FOR FIXNUMS]
;;;		JSP TT, 1DIMF  [FOR 1 DIMENSIONAL ARRAYS]
;;;		<POINTER BACK TO ASAR>
;;;		<1ST DIMENSION>
;;; ARRAY-DATA: .....DATA HERE.....
;;;


(LAP SETUP-TV-ARRAY SUBR)
(ARGS SETUP-TV-ARRAY (NIL . 0))
(DEFSYM TTSAR-DATA 100107)
(DEFSYM FIXNUM-ARRAY 200)
(DEFSYM IMMEDIATE 1000)
(DEFSYM READ-WRITE-ACCESS 600000)
	(HLLOS 0 NOQUIT)
	(PUSH FXP D)
	(PUSH FXP F)
	(PUSH FXP TT)
	(MOVEI TT 12)
	(PUSHJ P GETCOR)
	(SKIPN 0 TT)
	(*VALUE)
	(ADDI TT 2000)
	(MOVEI F -5 TT)
	(HRLI F TV-ARRAY-HEADER)
	(BLT F -1 TT)
	(HRRM TT -5 TT)
	(PUSH FXP TT)
	(JSP T SACONS)
	(POP FXP TT)
	(MOVEM A -2 TT)
	(HRLI F FIXNUM-ARRAY)
	(HLLM F 0 A)
	(MOVEI F -4 TT)
	(HRRM F 0 A)
	(HRLI F TTSAR-DATA)
	(HLLM F 1 A)
	(HRRM TT 1 A)
	(MOVEM A (SPECIAL TV))
	(POP FXP TT)
	(POP FXP F)
	(POP FXP D)
	(HLLZS 0 NOQUIT)
	(PUSHJ P CHECKI)
	(POPJ P)
TV-ARRAY-HEADER
	(0 0 0 -1)
	(PUSH P CFIX1)
	(JSP TT 1DIMF)
ASAR-ADDRESS
	(0)
	(22000)
NIL 
 
(DECLARE (ARRAY* (FIXNUM (TV 9216.))))

(PUTPROP 'TV (SETUP-TV-ARRAY) 'ARRAY) 

(DECLARE (FIXNUM (READ-TV FIXNUM FIXNUM) (TV-ADDRESS FIXNUM FIXNUM))
         (NOTYPE (WRITE-TV FIXNUM FIXNUM FIXNUM)))

(DEFUN READ-TV (TV-Y TV-X) (TV (+ (* TV-Y 18.) TV-X)))

(DEFUN WRITE-TV (TV-Y TV-X NEW-CONTENTS) 
       (STORE (TV (+ (* TV-Y 18.) TV-X)) NEW-CONTENTS)
       T)

(DEFUN TV-ADDRESS (TV-Y TV-X) (+ (* TV-Y 18.) TV-X))
       

;;THE FOLLOWING LAP ROUTINE PERFORMS THE SYSTEM CALL TO MAP THE 11'S MEMORY INTO THE
;;ADDRESS SPACE OF THE TEN.  THE ADDRESS FOR THE START OF THE TV MEMORY IS THAT OF
;;THE DATA FOR THE TV ARRAY.

[BW 

(DECLARE (*EXPR TVINIT)) 


(LAP TVINIT SUBR)
(ARGS TVINIT (NIL . 0))
(DEFSYM IMMEDIATE 1000)
(DEFSYM READ-WRITE-ACCESS 600000)
	(HLLOS 0 NOQUIT)
	(PUSH FXP TT)
	(PUSH FXP D)
	(HRRZ TT (ARRAY TV))
	(LSH TT -12)
	(HRLI TT -11)
	(SETZ D)
	(*CALL 0 MAP-11-MEMORY-TO-10-ADDRESS-SPACE)
	(*VALUE)
	(MOVEI A 'TV-INITIALIZED)
	(POP FXP D)
	(POP FXP TT)
	(HLLZS 0 NOQUIT)
	(PUSHJ P CHECKI)
	(POPJ P)
MAP-11-MEMORY-TO-10-ADDRESS-SPACE
	(SETZ)
	(SIXBIT CORBLK)
	(0 0 READ-WRITE-ACCESS IMMEDIATE)
	(0 0 -1 IMMEDIATE)
	(TT)
	(0 0 -2 IMMEDIATE)
	(SETZ 0 D)
NIL 
 
;;;END OF BLACK-AND-WHITE CONDITIONAL SECTION.

]


;;THE TV ARRAY IS REALLY YOUR TV BUFFER! DOING (STORE (TV <WORD>) <BITS>)
;;ACTUALLY CAUSES THE BITS TO APPEAR ON YOUR SCREEN.  THINGS TO REMEMBER: KEEP THE
;;LAST 4 LOW ORDER BITS CLEAR, AND COORDINATES RUN TOP TO BOTTOM, LEFT TO RIGHT.


;;*PAGE

(COMMENT SPLIT SCREENERY)

;;THE FOLLOWING LAP ROUTINE CAUSES ALL LISP TTY I/O TO TAKE PLACE IN AN AREA AT THE
;;BOTTOM OF THE SCREEN.  THIS PERMITS DISPLAY HACKS TO OCCUR IN THE UPPER HALF.  IT
;;TAKES ONE ARGUMENT, THE NUMBER OF LINES TO CONSTITUTE THE DISPLAY AREA.  AN
;;ARGUMENT OF ZERO OR NIL RESTORES THE FULL SCREEN FOR OUTPUT.  THE GLOBAL VARIABLE
;;:ECHOLINES KEEPS THE LAST ARG TO ECHO-LINES, NUMBER OF LINES IN ECHO AREA, OR NIL
;;IF NONE EXISTS.

[BW (DECLARE (*EXPR CREATE-ECHO-AREA OUTPUT-TO-MAIN-SCREEN OUTPUT-TO-ECHO-AREA)
	 (SPECIAL :ECHOLINES)
	 (FIXNUM ECHO-LINES :ECHOLINES BOTTOM-LINES)
	 (*LEXPR SYSCALL)) 

(DEFUN CREATE-ECHO-AREA (ECHO-LINES) 
       (SYSCALL 0. 'SCML 1. (SETQ :ECHOLINES ECHO-LINES))
       ;;0=NO VALUES RETURNED, SCML="SET COMMAND LINES" SYSTEM CALL, 1=TTY INPUT
       ;;CHANNEL
       :ECHOLINES) 


(LAP OUTPUT-TO-ECHO-AREA SUBR)
(ARGS OUTPUT-TO-ECHO-AREA (NIL . 0))
(DEFSYM TYOC 2)
(DEFSYM IMMEDIATE 1000)
	(HLLOS 0 NOQUIT)
	(*OPEN TYOC REOPEN-OUTPUT)
	(*VALUE)
	(MOVEI A 'OUTPUT-NOW-IN-ECHO-AREA)
	(HLLZS 0 NOQUIT)
	(PUSHJ P CHECKI)
	(POPJ P)
REOPEN-OUTPUT
	(0 0 (SIXBIT / / / TTY) 31)
	(SIXBIT /.LISP/.)
	(SIXBIT OUTPUT)
NIL 
 


(LAP OUTPUT-TO-MAIN-SCREEN SUBR)
(ARGS OUTPUT-TO-MAIN-SCREEN (NIL . 0))
(DEFSYM TYOC 2)
(DEFSYM IMMEDIATE 1000)
	(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) 21)
	(SIXBIT /.LISP/.)
	(SIXBIT OUTPUT)
NIL 
 

(DEFINE ECHOLINES (BOTTOM-LINES) (CREATE-ECHO-AREA BOTTOM-LINES)
				 (OUTPUT-TO-ECHO-AREA)
				 (CURSORPOS 'C)
				 NO-VALUE) 

;;THE STANDARD LISP CURSORPOS FUNCTION WON'T DO FOR SPLIT-SCREEN HACKERY.  THE
;;SYSTEM MAINTAINS TWO CURSORS, AND LISP IGNORES THE ECHO OUTPUT CURSOR.  SINCE LISP
;;CURSORPOS GETS INCREDIBLY CONFUSED, THE LISP RUBOUT HANDLER IS SOMETIMES LESS THAN
;;OPTIMAL, AND PAGEPAUSE MODE LOSES, SO TURN IT OFF UPON ENTRY. 

(SSTATUS PAGEPAUSE NIL) 

(DECLARE (*EXPR ECHO-CURSORPOS) (FIXNUM RCPOS)) 

;;; (DEFUN ECHO-CURSORPOS NIL 
;;;        (LET ((RCPOS (CADR (SYSCALL 2. 'RCPOS 0. 1.))))
;;;		(CONS (LSH RCPOS -18.) (BITWISE-AND RCPOS 262143.))))
;;;


(LAP ECHO-CURSORPOS SUBR)
(ARGS ECHO-CURSORPOS (NIL . 0))
(DEFSYM TYIC 1)
(DEFSYM IMMEDIATE 1000)
(DEFSYM RESULT 2000)
	(*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 
 

;;*PAGE

;;;

(COMMENT DRAWMODE) 

;;;
;;THE 11 HAS A FEATURE WHEREBY ONE OF THE SIXTEEN BOOLEAN FUNCTIONS OF TWO ARGUMENTS
;;MAY BE SPECIFIED, AND ANY ATTEMPT TO WRITE INTO THE 11'S MEMORY WILL ACTUALLY
;;RESULT IN THE FUNCTION SPECIFIED OF THE WORD BEING DEPOSITED AND THE WORD ALREADY
;;THERE IN THE LOCATION.  THIS IS DONE BY PUTTING A NUMBER TO INDICATE THE DESIRED
;;FUNCTION IN THE "ALU REGISTER"; THE FIRST WORD AFTER THE 8 PAGES OF TV MEMORY. 
;;THE NUMBER IS IN THE HIGH ORDER 8 BITS OF THE WORD.

(DECLARE (SPECIAL :DRAWMODE ANDC SETZ COMP EQV SAME XOR AND SETO IOR SET)
	 (FIXNUM (DRAWMODE FIXNUM) (FLIPCOLORS FIXNUM))
	 (FIXNUM :DRAWMODE OLD-DRAWMODE ANDC SETZ COMP EQV SAME XOR AND SETO IOR
		 SET)) 

(DEFINE DRAWMODE (MODE) 
	(COND ((= :DRAWMODE MODE) MODE)
	      ((PROG1 :DRAWMODE
		      (SETQ :DRAWMODE MODE)
		      (STORE (TV 8192.)
			     (BITWISE-OR :DRAWMODE
					 (BOOLE 2. -268435456. (TV 8192.)))))))) 

;;DRAWMODE RETURNS PREVIOUS STATE FOR EASY LAMBDA-BINDING.

(SETQ ANDC 536870912. 
      SETZ 805306368. 
      COMP 1342177280. 
      XOR 1610612736. 
      EQV 2415919104. 
      SAME 2684354560. 
      AND 2952790016. 
      SETO 3221225472. 
      IOR 3758096384. 
      SET 4026531840. 
      :DRAWMODE IOR) 

(DEFUN U (X) 
       (STORE (TV 8192.)
	      (BITWISE-OR (LSH X 20.) (BOOLE 2. 32505856. (TV 8192.))))) 

;;A BIT IN THE LAST WORD OF THE TV MEMORY CONTROLS WHETHER THE SCREEN IS IN
;;DARK-ON-LIGHT MODE OR LIGHT-ON-DARK MODE.  CONTROLLABLE FROM KEYBOARD BY TYPING
;;<ESC> C, THESE FUNCTIONS ALLOW IT TO BE PROGRAM CONTROLLED.

(DEFUN FLIPCOLORS (MODE) 
       (LET ((OLD-DRAWMODE (DRAWMODE MODE)))
	    (STORE (TV 8191.) 65536.)
	    (DRAWMODE OLD-DRAWMODE))) 

(DEFINE COLORNEGATIVE (ABB CLN) NIL (FLIPCOLORS ANDC) NO-VALUE) 

(DEFINE COLORPOSITIVE (ABB CLP) NIL (FLIPCOLORS IOR) NO-VALUE) 

(DEFINE COLORSWITCH (ABB CLSW) NIL (FLIPCOLORS XOR) NO-VALUE) 

(DEFINE COLORSTATE (ABB CLST) NIL (NOT (ZEROP (BITWISE-AND (TV 8191.) 65536.))))

;;END OF BLACK AND WHITE CONDITIONAL SECTION.
]

;;*PAGE


[COLOR


(LAP TV-PAGE SUBR)
	(PUSH FXP TT)
	(HRRZ TT (ARRAY TV))
	(LSH TT -12)
	(JSP T FXCONS)
	(POP FXP TT)
	(POPJ P)
NIL 
 

;;*PAGE


(COMMENT COLOR GLOBAL INITIALIZATIONS) 

;;READ THE FOLLOWING SECTION IN OCTAL.

(DECLARE (EVAL (READ))) 

(SETQ OIBASE IBASE IBASE 8.) 

;;* (SETQ OIBASE IBASE IBASE 8. OBASE BASE BASE 8.) 
;;ABOVE LINE FOR GRIND PACKAGE...
;;;Constants for video control registers. [see BEE;CLRTST >].

(DECLARE (SPECIAL COLORD-ADDRESS VIDSW-ADDRESS COLORA-ADDRESS TVINCR-ADDRESS
		  TVINC-MASK TVRSET-MASK TVCLRW-MASK TVSEL-ADDRESS TVRCNS-MASK
		  TVRWMD-MASK TVNSH TVINOR TVXOR TVMOV :DRAWMODE IOR XOR SET MOV
		  TVRADR-ADDRESS TVWC-ADDRESS TVSHR-ADDRESS TVSHCN-ADDRESS
		  TVSHCN-MASK WORDS-PER-LINE BYTES-PER-LINE COLORA-RED-MASK TVMAP
		  TVAMAP TVMSK-ADDRESS TVRWIN-ADDRESS TVCNSL-ADDRESS TVCLR-MASK
		  ROTATE-MAGIC-CONSTANT COLORA-GREEN-MASK COLORA-BLUE-MASK
		  VIDEO-SWITCH-MAGIC-1 VIDEO-SWITCH-MAGIC-2 VIDEO-SWITCH-MAGIC-3
		  VIDEO-SWITCH-MAGIC-4 CONSOLE-MAGIC-1 CONSOLE-MAGIC-2
		  CONSOLE-MAGIC-3 CONSOLE-MAGIC-4 ELEVEN-TV-BUFFER-ORIGIN
		  TVOFLO-MASK ELEVEN-CONTROL-REGISTER-ORIGIN CONTROL-Y
		  RIGHT-HALFWORD TVWC-MASK :COLORWRITE)
	 (FIXNUM COLORD-ADDRESS VIDSW-ADDRESS COLORA-ADDRESS TVINCR-ADDRESS
		 TVINC-MASK TVRSET-MASK TVCLRW-MASK TVSEL-ADDRESS TVRCNS-MASK
		 TVRWMD-MASK TVNSH TVINOR TVXOR TVMOV :DRAWMODE IOR XOR SET MOV
		 TVRADR-ADDRESS TVWC-ADDRESS TVSHR-ADDRESS TVSHCN-ADDRESS
		 TVSHCN-MASK WORDS-PER-LINE BYTES-PER-LINE COLORA-RED-MASK TVMAP
		 TVAMAP TVMSK-ADDRESS TVRWIN-ADDRESS TVCNSL-ADDRESS TVCLR-MASK
		 ROTATE-MAGIC-CONSTANT COLORA-GREEN-MASK COLORA-BLUE-MASK
		 VIDEO-SWITCH-MAGIC-1 VIDEO-SWITCH-MAGIC-2 VIDEO-SWITCH-MAGIC-3
		 VIDEO-SWITCH-MAGIC-4 CONSOLE-MAGIC-1 CONSOLE-MAGIC-2
		 CONSOLE-MAGIC-3 CONSOLE-MAGIC-4 ELEVEN-TV-BUFFER-ORIGIN
		 TVOFLO-MASK ELEVEN-CONTROL-REGISTER-ORIGIN CONTROL-Y
		 RIGHT-HALFWORD TVWC-MASK)) 

(DEFUN INITIALIZE-COLOR-TURTLE NIL 
       (SETQ 
	     ;;Color data.
	     COLORD-ADDRESS 764102 
	     ;;Video switch.
	     VIDSW-ADDRESS 764104 
	     ;;Color address.
	     COLORA-ADDRESS 764106 
	     ;;The increment register for the tv's.
	     TVINCR-ADDRESS 764140 
	     ;;The mask for the increment. 
	     TVINC-MASK 77 
	     ;;Mask to handle overflow correctly in increment register.
	     TVOFLO-MASK 1000 
	     ;;The reset bit mask. 
	     TVRSET-MASK 100000 
	     ;;The color write bit mask.
	     TVCLRW-MASK 400 
	     ;;The console select register. 
	     TVSEL-ADDRESS 764142 
	     ;;The console number mask. 
	     TVRCNS-MASK 77 
	     ;;The regular write mode mask.
	     TVRWMD-MASK 300 
	     ;;No shift write mode. 
	     TVNSH 0 
	     ;;The inclusive or mode. 
	     TVINOR 100 
	     IOR 100 
	     ;;The xor mode. 
	     TVXOR 200 
	     XOR 200 
	     ;;The move function. 
	     TVMOV 300 
	     SET 300 
	     ;;The regular address register. 
	     :DRAWMODE SET 
	     TVRADR-ADDRESS 764144 
	     ;;The word count for the block write. 
	     TVWC-ADDRESS 764146 
	     ;;Mask for word count.
	     TVWC-MASK 777 
	     ;;The shift register.
	     TVSHR-ADDRESS 764152 
	     ;;The shift count mask. 
	     TVSHCN-MASK 17 
	     ;;The start of the 16k page (in 4k blocks). 
	     TVMAP 17400 
	     ;;The activate tvmap bit.
	     TVAMAP 20000 
	     ;;The mask register. 
	     TVMSK-ADDRESS 764154 
	     ;;The window for regular transfers. 
	     TVRWIN-ADDRESS 764160 
	     ;;The console register for the memory. 
	     TVCNSL-ADDRESS 764162 
	     ;;The color number mask.
	     TVCLR-MASK 160000 
	     RIGHT-HALFWORD 777777)
       (SETQ WORDS-PER-LINE 44 BYTES-PER-LINE 110)
       ;;More magic constants.....
       (SETQ ROTATE-MAGIC-CONSTANT 35400 
	     ;;In rotate register TVSHR indicates no rotation.
	     COLORA-RED-MASK 300 
	     COLORA-GREEN-MASK 500 
	     ;;IOR these with color map address into COLORA register to set red,
	     ;;green, blue intensities respectively.  Low order 6 bits are color
	     ;;address, next 3 are red, green, blue, where 0 indicates write.
	     COLORA-BLUE-MASK 600 
	     VIDEO-SWITCH-MAGIC-1 (+ (LSH 30 10) 0) 
	     ;;Magic constants for video switch and console register
	     ;;initializations.
	     VIDEO-SWITCH-MAGIC-2 (+ (LSH 31 10) 1) 
	     VIDEO-SWITCH-MAGIC-3 (+ (LSH 32 10) 2) 
	     VIDEO-SWITCH-MAGIC-4 (+ (LSH 33 10) 3) 
	     CONSOLE-MAGIC-1 (LSH 1 15) 
	     CONSOLE-MAGIC-2 (LSH 2 15) 
	     CONSOLE-MAGIC-3 (LSH 3 15) 
	     CONSOLE-MAGIC-4 (LSH 4 15) 
	     ;;Start of TV buffer in 11's memory in byte address.
	     ELEVEN-TV-BUFFER-ORIGIN 660000 
	     ;;Start of control registers in 11's memory in byte address.
	     ELEVEN-CONTROL-REGISTER-ORIGIN 760000)) 

;;*PAGE


(COMMENT LOW LEVEL COLOR PRIMITIVES) 

(DECLARE (FIXNUM (READ-CONTROL-REGISTER FIXNUM) CONTROL-ADDRESS BYTE-OFFSET
		 ELEVEN-WORD-OFFSET TEN-WORD-OFFSET TV-WORD)) 

(DEFUN READ-CONTROL-REGISTER (CONTROL-ADDRESS) 
       (LET ((BYTE-OFFSET (- CONTROL-ADDRESS ELEVEN-TV-BUFFER-ORIGIN)))
	    ;;Distance from TV buffer origin to target address in bytes.
	    (LET ((ELEVEN-WORD-OFFSET (LSH BYTE-OFFSET -1))
		  ;;and in 16 and 32 bit words.
		  (TEN-WORD-OFFSET (LSH BYTE-OFFSET -2)))
		 (LET ((TV-WORD (TV TEN-WORD-OFFSET)))
		      ;;16 bit word comes back embedded in 36 bit word.
		      (COND ((ODDP ELEVEN-WORD-OFFSET)
			     (BITWISE-AND RIGHT-HALFWORD (LSH TV-WORD -4)))
			    ;;Extract out the interesting piece.
			    ((LSH TV-WORD -24))))))) 

(DECLARE (NOTYPE (WRITE-CONTROL-REGISTER FIXNUM FIXNUM))
	 (FIXNUM INHIBIT WORD-SHIFT NEW-CONTENTS)) 

(DEFUN WRITE-CONTROL-REGISTER (CONTROL-ADDRESS NEW-CONTENTS) 
       (LET ((BYTE-OFFSET (- CONTROL-ADDRESS ELEVEN-TV-BUFFER-ORIGIN)))
	    ;;Distance from TV buffer origin to target address in bytes.
	    (LET ((ELEVEN-WORD-OFFSET (LSH BYTE-OFFSET -1))
		  ;;and in 16 and 32 bit words.
		  (TEN-WORD-OFFSET (LSH BYTE-OFFSET -2)))
		 (LET ((INHIBIT (COND ((ODDP ELEVEN-WORD-OFFSET) 10) (4)))
		       ;;Shift the 16 bit word to place in 36 bit word, inhibit
		       ;;writing of irrelevant word.
		       (WORD-SHIFT (COND ((ODDP ELEVEN-WORD-OFFSET) 4) (24))))
		      (STORE (TV TEN-WORD-OFFSET)
			     (BITWISE-OR (LSH NEW-CONTENTS WORD-SHIFT) INHIBIT)))))
       T) 

(DECLARE (NOTYPE WRITE-CONTROL-FIELD FIXNUM FIXNUM FIXNUM)) 

(DEFUN WRITE-CONTROL-FIELD (CONTROL-ADDRESS CONTROL-DATA CONTROL-MASK) 
       ;;Like WRITE-CONTROL-REGISTER, but only writes the field specified by the
       ;;mask, leaving the rest of the word undisturbed.
       (WRITE-CONTROL-REGISTER
	CONTROL-ADDRESS
	(BITWISE-OR (BITWISE-AND CONTROL-MASK CONTROL-DATA)
		    (BITWISE-ANDC CONTROL-MASK
				  (READ-CONTROL-REGISTER CONTROL-ADDRESS))))) 

(DEFUN CORBLK NIL 
       (SYSCALL 0 'CORBLK 0 -1 (BITWISE-OR (LSH -11 22) (TV-PAGE)))) 

(DECLARE (FIXNUM PAGE-NUMBER TV-PAGE MAGIC-CONSTANT)) 

(DEFUN MAP-TV-BUFFER NIL 
       ;;Map the 11's memory into ten's address space.  8 pages of buffer + 1 page
       ;;of control registers = 9 pages. 
       (CORBLK)
       (DO ((PAGE-NUMBER 0 (1+ PAGE-NUMBER))
	    (TV-PAGE (TV-PAGE))
	    ;;Magic constant 2nd arg to T11MP -- see ITS .CALLS....
	    (MAGIC-CONSTANT (+ (LSH 602330 22) 1777)))
	   ((= PAGE-NUMBER 11))
	   (SYSCALL 0
		    'T11MP
		    (+ TV-PAGE PAGE-NUMBER)
		    (+ MAGIC-CONSTANT (LSH (* PAGE-NUMBER 4) 22))))) 

(DECLARE (EVAL (READ))) 

(SETQ IBASE OIBASE) 

;;* (SETQ IBASE OIBASE BASE OBASE)
;;END OF OCTAL SECTION.

(DECLARE (FIXNUM (DRAWMODE FIXNUM))) 

(DEFUN TVINIT NIL 
       (INITIALIZE-COLOR-TURTLE)
       ;;Map 11's tv buffer memory and control registers into 10's address space.
       (MAP-TV-BUFFER)
       ;;Reset bit in increment register starts things out.
       (WRITE-CONTROL-REGISTER TVINCR-ADDRESS TVRSET-MASK)
       (RESET)
       (INITIALIZE-PALETTE)) 

(DEFINE RESET NIL (INITIALIZE-VIDEO-SWITCH)
		  (INITIALIZE-CONSOLE-REGISTER)
		  ;;Increment register magic bit to handle overflow correctly.
		  ;;Normally assume always no rotation.
		  (WRITE-CONTROL-REGISTER TVSHR-ADDRESS ROTATE-MAGIC-CONSTANT)
		  (WRITE-CONTROL-FIELD TVINCR-ADDRESS -1. TVOFLO-MASK)
		  ;;Choose SET draw mode.
		  (WRITE-CONTROL-FIELD TVSEL-ADDRESS SET TVRWMD-MASK)
		  (COLOR-WRITE)) 

;;CONTROL-BACKSLASH INTERRUPT CHARACTER PERFORMS RESET.  USEFUL TO RECOVER FROM
;;RESET OF 11, SYMPTOM IS SCREEN BLANKING IN ONE COLOR FOR NO APPARENT REASON.

(SSTATUS INTERRUPT 14. '(LAMBDA (USELESS) (RESET) '?)) 

(DEFUN COLOR-WRITE NIL 
       ;;Set color write mode.
       (SETQ :COLORWRITE T)
       (WRITE-CONTROL-FIELD TVINCR-ADDRESS -1. TVCLRW-MASK)
       (RESELECT-COLOR)) 

(DEFUN NO-COLOR-WRITE NIL 
       (SETQ :COLORWRITE NIL)
       (WRITE-CONTROL-FIELD TVINCR-ADDRESS 0. TVCLRW-MASK)) 

(DECLARE (SPECIAL :ERASERSTATE :PENNUMBER :ERASERNUMBER :ECHOLINES)
	 (FIXNUM :PENNUMBER :ERASERNUMBER :ECHOLINES)) 

(DEFUN RESELECT-COLOR NIL 
       (SELECT-COLOR (COND (:ERASERSTATE :ERASERNUMBER) (:PENNUMBER))))

(DEFUN INITIALIZE-VIDEO-SWITCH NIL 
       ;;Video switch initialization [see BEE;CLRTST >].
       (WRITE-CONTROL-REGISTER VIDSW-ADDRESS VIDEO-SWITCH-MAGIC-1)
       (WRITE-CONTROL-REGISTER VIDSW-ADDRESS VIDEO-SWITCH-MAGIC-2)
       (WRITE-CONTROL-REGISTER VIDSW-ADDRESS VIDEO-SWITCH-MAGIC-3)
       (WRITE-CONTROL-REGISTER VIDSW-ADDRESS VIDEO-SWITCH-MAGIC-4)) 

(DEFUN INITIALIZE-CONSOLE-REGISTER NIL 
       ;;Console register initialization [see BEE;CLRTST >].
       (WRITE-CONTROL-REGISTER TVSEL-ADDRESS 0.)
       (WRITE-CONTROL-REGISTER TVCNSL-ADDRESS CONSOLE-MAGIC-1)
       (WRITE-CONTROL-REGISTER TVSEL-ADDRESS 1.)
       (WRITE-CONTROL-REGISTER TVCNSL-ADDRESS CONSOLE-MAGIC-2)
       (WRITE-CONTROL-REGISTER TVSEL-ADDRESS 2.)
       (WRITE-CONTROL-REGISTER TVCNSL-ADDRESS CONSOLE-MAGIC-3)
       (WRITE-CONTROL-REGISTER TVSEL-ADDRESS 3.)
       (WRITE-CONTROL-REGISTER TVCNSL-ADDRESS CONSOLE-MAGIC-4)) 

(DECLARE (NOTYPE (WRITE-TV-ADDRESS FIXNUM FIXNUM))) 

(DEFUN WRITE-TV-ADDRESS (TV-ADDRESS-CONTENTS) 
       ;;Store into TV address register "TVRADR".  Sets up the address to be written
       ;;when something is stored in data register or word count register.  ADDRESS
       ;;IS IN PDP11 BYTES, NOT WORDS!
       (WRITE-CONTROL-REGISTER TVRADR-ADDRESS TV-ADDRESS-CONTENTS)
       T) 

(DECLARE (NOTYPE (WRITE-TV-DATA FIXNUM))) 

(DEFUN WRITE-TV-DATA (TV-DATA) 
       ;;Store in TV buffer memory data register "TVRWIN".  Writing of TV memory
       ;;actually occurs when this register is written.
       (WRITE-CONTROL-REGISTER TVRWIN-ADDRESS TV-DATA)
       T) 

(DECLARE (FIXNUM READ-TV-DATA)) 

(DEFUN READ-TV-DATA NIL 
       ;;Reads contents of TV buffer memory at location specified by TV address
       ;;register.
       (READ-CONTROL-REGISTER TVRWIN-ADDRESS)) 

(DECLARE (NOTYPE (WRITE-TV-WORD FIXNUM FIXNUM))) 

(DEFUN WRITE-TV-WORD (TV-ADDRESS TV-DATA) 
       ;;Writes the data at the specified address.
       (WRITE-TV-ADDRESS TV-ADDRESS)
       (WRITE-TV-DATA TV-DATA)) 

;;Rotate & mask registers provide a means of writing into arbitrary part of word.
;;Word in memory data register is rotated, and only bits not on in the mask register
;;are actually written into the word.

(DECLARE (NOTYPE (WRITE-TV-ROTATE FIXNUM))) 

(DEFUN WRITE-TV-ROTATE (ROTATE-PLACES) 
       (WRITE-CONTROL-FIELD TVSHR-ADDRESS ROTATE-PLACES TVSHCN-MASK)
       T) 

;;The convention observed by routines which write into the TV memory will be to
;;assume the rotate register zero, restore it if changed, but set up contents of
;;mask, address, and data registers before each write.

(DECLARE (NOTYPE (WRITE-TV-MASK FIXNUM))) 

(DEFUN WRITE-TV-MASK (TV-MASK) (WRITE-CONTROL-REGISTER TVMSK-ADDRESS TV-MASK) T) 

;;Write of multiple words at once.

(DECLARE (NOTYPE (WRITE-TV-WORD-COUNT FIXNUM))) 

(DEFUN WRITE-TV-WORD-COUNT (WORD-COUNT) 
       ;;When this register is written, data transfers repeatedly occur, number of
       ;;times specified by minus word count.
       (WRITE-CONTROL-REGISTER TVWC-ADDRESS WORD-COUNT)
       T) 

(DECLARE (FIXNUM (READ-TV-WORD-COUNT))) 

(DEFUN READ-TV-WORD-COUNT NIL 
       ;;Needed for checking when block word transfer is done.
       (BITWISE-AND (READ-CONTROL-REGISTER TVWC-ADDRESS) TVWC-MASK)) 

(DECLARE (NOTYPE (WRITE-TV-INCREMENT FIXNUM))) 

(DEFUN WRITE-TV-INCREMENT (INCREMENT) 
       ;;Contents added to TV address register after each write performed.  In
       ;;conjunction with word count, performs automatically loops of writing into
       ;;TV memory.
       (WRITE-CONTROL-FIELD TVINCR-ADDRESS INCREMENT TVINC-MASK)
       T) 

(DECLARE (NOTYPE (WRITE-TV-BLOCK FIXNUM FIXNUM FIXNUM FIXNUM))) 

(DEFUN WRITE-TV-BLOCK (ADDRESS CONTENTS ITERATIONS STEP) 
       ;;Writes a whole block of words in one swell foop.
       (COND ((ZEROP ITERATIONS))
	     (T (WRITE-CONTROL-FIELD TVINCR-ADDRESS STEP TVINC-MASK)
		(WRITE-TV-WORD ADDRESS CONTENTS)
		;;One word written when contents written.
		(COND ((ZEROP (DECREMENT ITERATIONS)))
		      ;;Decrease iterations by 1, if finished stop, else write rest
		      ;;in block.
		      ((WRITE-TV-WORD-COUNT (- ITERATIONS))
		       ;;Wait must be programmed in to check if block write is done. 
		       ;;Word count register goes to zero then.
		       (DO NIL ((ZEROP (READ-TV-WORD-COUNT))))))
		(WRITE-CONTROL-FIELD TVINCR-ADDRESS 0. TVINC-MASK)))) 

;;;;;;;;;;;;;;;;;;;;;;
;;;Temporarily leave this out, always be in set mode.
;;;(DEFUN DRAWMODE (MODE) 
;;;       ;;Specifies how word is actually to be written as function of word 
;;;       ;;in memory data & word previously there. Choose from:
;;;       ;;;	SET, IOR, XOR, SET-IGNORE-ROTATE-MASK
;;;       ;;Unfortunately, can't use IOR & XOR as for ordinary TVRTLE when in color
;;mode
;; ;;Have to use SET mode.
;;;       (COND ((= :DRAWMODE MODE) MODE)
;;;             ((PROG1 :DRAWMODE
;;;                     (SETQ :DRAWMODE MODE)
;;;                     (WRITE-CONTROL-FIELD TVSEL-ADDRESS MODE TVRWMD-MASK)))))
;;;
;;;;;;;;;;;;;;;;;;;;;;;;

(DEFUN DRAWMODE (MODE) 0.) 

(DECLARE (NOTYPE (WRITE-COLOR-MAP FIXNUM FIXNUM FIXNUM FIXNUM))) 

(DEFUN WRITE-COLOR-MAP (COLOR-MAP-SLOT RED GREEN BLUE) 
       ;;Defines the color in a map slot by specifying intesities for red, green and
       ;;blue components.
       (WRITE-CONTROL-REGISTER COLORD-ADDRESS RED)
       ;;Write data before address, actual write commences upon writing of address,
       ;;not data register, in opposite order from buffer transactions.
       (WRITE-CONTROL-REGISTER COLORA-ADDRESS
			       (BITWISE-OR COLORA-RED-MASK COLOR-MAP-SLOT))
       (WRITE-CONTROL-REGISTER COLORD-ADDRESS GREEN)
       (WRITE-CONTROL-REGISTER COLORA-ADDRESS
			       (BITWISE-OR COLORA-GREEN-MASK COLOR-MAP-SLOT))
       (WRITE-CONTROL-REGISTER COLORD-ADDRESS BLUE)
       (WRITE-CONTROL-REGISTER COLORA-ADDRESS
			       (BITWISE-OR COLORA-BLUE-MASK COLOR-MAP-SLOT))
       T) 

(DECLARE (NOTYPE (SELECT-COLOR FIXNUM))) 

(DEFUN SELECT-COLOR (COLOR-NUMBER) 
       ;;Makes COLOR-NUMBER of the color map the current color.
       (WRITE-CONTROL-FIELD TVSEL-ADDRESS COLOR-NUMBER TVRCNS-MASK)
       T) 

(DECLARE (NOTYPE (SELECT-TV-BUFFER FIXNUM))) 

(DEFUN SELECT-TV-BUFFER (TV-BUFFER) 
       ;;BOTH READS & WRITES APPLY TO JUST THE SELECTED TV BUFFER. [ONE BIT OUT OF
       ;;THE FOUR].  COLOR WRITE MODE MUST BE TURNED OFF, SO IT MUST EVENTUALLY BE
       ;;RESTORED TO COLOR WRITE MODE IF THIS IS USED.
       (WRITE-CONTROL-FIELD TVSEL-ADDRESS TV-BUFFER TVRCNS-MASK)
       T) 

(DECLARE (FIXNUM (ELEVEN-TV-ADDRESS FIXNUM FIXNUM) WORDS-PER-LINE BYTES-PER-LINE)
	 (SPECIAL WORDS-PER-LINE BYTES-PER-LINE)) 

(DEFUN ELEVEN-TV-ADDRESS (ADDRESS-Y ADDRESS-X) 
       ;;CONVERTS TV Y ADDRESS [VERTICAL] AND 16 BIT WORD NUMBER [HORIZONTAL] TO
       ;;PDP11 BYTE ADDRESS.
       (+ (* ADDRESS-Y BYTES-PER-LINE) (LSH ADDRESS-X 1.))) 

;;*PAGE

;;;DUMMY DEFINITIONS FOR SPLIT SCREEN HACKERY.

(DECLARE (FIXNUM (CREATE-ECHO-AREA FIXNUM)) (NOTYPE (ECHOLINES FIXNUM))) 

(DEFUN CREATE-ECHO-AREA (ECHO-LINES) 0.) 

(DEFUN OUTPUT-TO-ECHO-AREA NIL T) 

(DEFUN OUTPUT-TO-MAIN-SCREEN NIL T) 

(DEFINE ECHOLINES (BOTTOM-LINES) NO-VALUE) 

;;THE STANDARD LISP CURSORPOS FUNCTION WON'T DO FOR SPLIT-SCREEN HACKERY.  THE
;;SYSTEM MAINTAINS TWO CURSORS, AND LISP IGNORES THE ECHO OUTPUT CURSOR.  SINCE LISP
;;CURSORPOS GETS INCREDIBLY CONFUSED, THE LISP RUBOUT HANDLER IS SOMETIMES LESS THAN
;;OPTIMAL, AND PAGEPAUSE MODE LOSES, SO TURN IT OFF UPON ENTRY. 

(SSTATUS PAGEPAUSE NIL) 

(DECLARE (*EXPR ECHO-CURSORPOS) (FIXNUM RCPOS)) 

(DEFUN ECHO-CURSORPOS NIL T) 

;;;

(DECLARE (SPECIAL :DRAWMODE ANDC SETZ COMP EQV SAME XOR AND SETO IOR SET)
	 (FIXNUM (DRAWMODE FIXNUM) (FLIPCOLORS FIXNUM))
	 (FIXNUM :DRAWMODE OLD-DRAWMODE ANDC SETZ COMP EQV SAME XOR AND SETO IOR
		 SET)) 

;;END OF COLOR CONDITIONAL SECTION.
]


;;*PAGE

;;;

(COMMENT CREATING AND SELECTING COLORS) 

;;;
;;Color represented as an atom.  Has RED, GREEN & BLUE properties for intensities of
;;respective colors, and PALETTE property which is its number in the color map, if
;;any. PALETTE contains the atoms representing the colors currently in the color
;;map.

(DECLARE (SPECIAL COLOR-BITS COLOR-MAX INTENSITY-MAX :COLORS :PENCOLOR :PENNUMBER
		  :ERASERCOLOR :ERASERNUMBER)
	 (FIXNUM COLOR-BITS COLOR-MAX :PENNUMBER :ERASERNUMBER)
	 (ARRAY* (NOTYPE (PALETTE 16.)))
	 (FLONUM INTENSITY-MAX)) 

(DECLARE (SPECIAL :COLORTICK :NCOLORS :NSLOTS)
	 (FIXNUM RANDOM-COLOR RANDOM-SLOT USELESS :NCOLORS :NSLOTS)
	 (FLONUM :COLORTICK)) 

(DEFUN INITIALIZE-PALETTE NIL 
       (SETQ COLOR-BITS 4. 
	     ;;Number of bits of color per point available.
	     COLOR-MAX (LSH 1. COLOR-BITS) 
	     ;;Number of distinct colors available.
	     INTENSITY-MAX 511.0 
	     ;;Red, green, blue colors described on a scale to this number.
	     :COLORS NIL 
	     ;;Global list of colors.
             :NCOLORS 0.
             ;;Number of colors.
	     :PENCOLOR 'WHITE
	     ;;Current color.
	     :PENNUMBER 15. 
	     ;;Current color for eraser, clearscreen.
	     :ERASERCOLOR 'BLACK 
	     :ERASERNUMBER 15.
             :COLORTICK 0.1)
       (ARRAY PALETTE T COLOR-MAX)
       (MAKECOLOR 'BLACK 0.0 0.0 0.0)
       (ERASERCOLOR 'BLACK)
       (MAKECOLOR 'WHITE 1.0 1.0 1.0)
       (MAKECOLOR 'RED 1.0 0.0 0.0)
       (MAKECOLOR 'GREEN 0.0 1.0 0.0)
       (PENCOLOR 'WHITE)
       (MAKECOLOR 'BLUE 0.0 0.0 1.0)
       (MAKECOLOR 'YELLOW 1.0 1.0 0.0)
       (MAKECOLOR 'MAGENTA 1.0 0.0 1.0)
       (MAKECOLOR 'CYAN 0.0 1.0 1.0)
       (MAKECOLOR 'PURPLE 0.5 0.0 1.0)
       (MAKECOLOR 'ORANGE 1.0 0.5 0.0)
       (MAKECOLOR 'GRAY .5 .5 .5)
       (MAKECOLOR 'DARKGRAY .25 .25 .25)
       (MAKECOLOR 'LIGHTGRAY .75 .75 .75)
       (MAKECOLOR 'GOLD  1.0 .75 0.0)
       (MAKECOLOR 'BROWN 0.3 0.2 0.0)
       (MAKECOLOR 'PINK 1.0 0.5 0.5)) 

(DEFINE MAKECOLOR (ABB MC) (COLOR-NAME RED GREEN BLUE) 
	;;Arguments are atom naming the color, and red, green, and blue intensities,
	;;as fractions between 0.0 and 1.0.
	(PUTPROP COLOR-NAME (ROUND (*$ (FLOAT RED) INTENSITY-MAX)) 'RED)
	(PUTPROP COLOR-NAME (ROUND (*$ (FLOAT GREEN) INTENSITY-MAX)) 'GREEN)
	(PUTPROP COLOR-NAME (ROUND (*$ (FLOAT BLUE) INTENSITY-MAX)) 'BLUE)
	(COND ((MEMQ COLOR-NAME :COLORS))
              (T (PUSH COLOR-NAME :COLORS) (INCREMENT :NCOLORS)))
	COLOR-NAME) 

(DEFINE ERASECOLOR (COLOR-NAME)
        (OR (GET COLOR-NAME 'RED) 
            (ERRBREAK 'ERASECOLOR (LIST COLOR-NAME '"IS NOT A COLOR")))
        (DO I 0 (1+ I) (= I 15.) 
            (AND (EQ (PALETTE I) COLOR-NAME) 
                 (ERRBREAK 'ERASECOLOR '"DON'T ERASE A COLOR ON THE PALETTE")))
        (MAPC '(LAMBDA (PROPERTY) (REMPROP COLOR-NAME PROPERTY)) 
              '(RED BLUE GREEN PALETTE))
        (DECREMENT :NCOLORS)
        (SETQ :COLORS (DELQ COLOR-NAME :COLORS))
        (LIST '/; COLOR-NAME '" ERASED")))



(DEFINE REDPART (COLOR) 
	(LET ((RED-PROP (GET COLOR 'RED)))
	     (COND (RED-PROP (//$ (FLOAT RED-PROP) INTENSITY-MAX))
		   ((ERRBREAK 'REDPART
			      (LIST COLOR
				    '"IS NOT A COLOR")))))) 

(DEFINE GREENPART (COLOR) 
	(LET ((GREEN-PROP (GET COLOR 'GREEN)))
	     (COND (GREEN-PROP (//$ (FLOAT GREEN-PROP) INTENSITY-MAX))
		   ((ERRBREAK 'GREENPART
			      (LIST COLOR
				    '"IS NOT A COLOR")))))) 

(DEFINE BLUEPART (COLOR) 
	(LET ((BLUE-PROP (GET COLOR 'BLUE)))
	     (COND (BLUE-PROP (//$ (FLOAT BLUE-PROP) INTENSITY-MAX))
		   ((ERRBREAK 'BLUEPART
			      (LIST COLOR
				    '"IS NOT A COLOR")))))) 

(DECLARE (FIXNUM COLOR-INDEX)) 

(DEFINE PENCOLOR (ABB PC COLOR) (COLOR-NAME) 
 ;;Selects a default color for the turtle to write in, etc.
 (ERASE-TURTLE)
 (COND
  ((NUMBERP COLOR-NAME)
   ;;Selected by color map number.
   (LET ((PALETTE-NAME (PALETTE COLOR-NAME)))
	(COND ((NULL PALETTE-NAME)
	       (ERRBREAK 'PENCOLOR
			 (LIST COLOR-NAME
			       '"IS NOT A COLOR NUMBER")))
	      ((SETQ :PENNUMBER COLOR-NAME :PENCOLOR PALETTE-NAME)))))
  ((GET COLOR-NAME 'RED)
   (SETQ :PENCOLOR COLOR-NAME)
   (LET ((COLOR-INDEX (INTERN-COLOR COLOR-NAME)))
	;;INTERN-COLOR returns index into color map, placing it there if not
	;;present.
	(COND ((MINUSP COLOR-INDEX)
	       ;;Color not present in color map, and more places to put it.
	       (ERRBREAK 'PENCOLOR
			 '"TOO MANY COLORS"))
	      ((SETQ :PENNUMBER COLOR-INDEX)))))
  ((ERRBREAK 'PENCOLOR
	     (LIST COLOR-NAME '"IS NOT A COLOR"))))
 [COLOR (COND (:ERASERSTATE) ((SELECT-COLOR :PENNUMBER)))]
 (DRAW-TURTLE)
 COLOR-NAME) 

(DECLARE (NOTYPE (MAKEPALETTE FIXNUM)) (FIXNUM LAST-PEN-COLOR)) 

(DEFINE PUSHPROP (ATOM PROPERTY INDICATOR) 
	;;Like PUTPROP, but previous property, if any will be restored if
	;;REMPROP'ed.
	(SETPLIST ATOM (CONS INDICATOR (CONS PROPERTY (PLIST ATOM))))) 

(DEFINE MAKEPALETTE (COLOR-INDEX COLOR-NAME) 
        (COND ((= COLOR-INDEX :PENNUMBER) (SETQ :PENCOLOR COLOR-NAME))
              ;;If the color to be changed is that of the pen or eraser,
              ;;update the global variables appropriately.
              ((= COLOR-INDEX :ERASERNUMBER) (SETQ :ERASERCOLOR COLOR-NAME)))
	(REMPROP (PALETTE COLOR-INDEX) 'PALETTE)
	;;Remove previous color number property, write into color map & palette.
	[COLOR (WRITE-COLOR-MAP COLOR-INDEX
    			        (GET COLOR-NAME 'RED)
			        (GET COLOR-NAME 'GREEN)
			        (GET COLOR-NAME 'BLUE))]
	(PUSHPROP COLOR-NAME COLOR-INDEX 'PALETTE)
	(STORE (PALETTE COLOR-INDEX) COLOR-NAME)) 

(DEFUN INTERN-COLOR (COLOR-NAME) 
       ;;Finds first position in palette with specified color. If not in the color
       ;;map, it is inserted, and the index returned. Returns -1 if color map is
       ;;full.
       (COND ((EQ COLOR-NAME :ERASERCOLOR) (1- COLOR-MAX))
	     ;;ERASERCOLOR is always the last color.
	     ((DO ((COLOR-INDEX 0. (1+ COLOR-INDEX)) (LAST-PEN-COLOR (1- COLOR-MAX)))
		  ;;Already checked eraser color, stop at last pen color.
		  ((= COLOR-INDEX LAST-PEN-COLOR) -1.)
		  (COND 
			;;Exhausted palette, couldn't insert it.
			((EQ (PALETTE COLOR-INDEX) COLOR-NAME) (RETURN COLOR-INDEX))
			;;It was already there, return index.
			((NULL (PALETTE COLOR-INDEX))
			 ;;Found a free place.
			 (MAKEPALETTE COLOR-INDEX COLOR-NAME)
			 (RETURN COLOR-INDEX))))))) 

;;There are two global default colors which the system keeps track of.  One is the
;;default color for drawing with the turtle, kept as the value of :PENCOLOR. The
;;other is a "background" color, :ERASERCOLOR.  CLEARSCREEN results in filling the
;;screen in the current background color.  The TV system also fills edges of the
;;picture with the background color.  It may also be used for eraser mode, drawing
;;in the same color as the background being supposed to erase whatever it writes
;;over.

(DEFINE ERASERCOLOR (ABB ERC ERASECOLOR) (COLOR-NAME) 
	;;Sets the background color, for CLEARSCREEN, eraser mode to the designated
	;;color.  It replaces the current background color.
	(MAKEPALETTE :ERASERNUMBER COLOR-NAME)
	COLOR-NAME) 

(DEFINE DELETECOLOR (ABB DC) (COLOR-NAME) 
 (LET
  ((PALETTE (GET COLOR-NAME 'PALETTE)))
  (COND ((EQ COLOR-NAME :PENCOLOR)
	 (ERRBREAK 'DELETECOLOR
		   '"CAN'T ERASE CURRENT PEN COLOR"))
	((EQ COLOR-NAME :ERASERCOLOR)
	 (ERRBREAK 'DELETECOLOR
		   '"CAN'T ERASE CURRENT ERASER COLOR"))
	((NULL PALETTE)
	 (ERRBREAK 'ERASECOLOR
		   (LIST COLOR-NAME
			 '"IS NOT A COLOR ON THE PALETTE")))
	(T (REMPROP COLOR-NAME 'PALETTE)
	   ;;Remove color, and mark place in palette as empty.
	   (STORE (PALETTE PALETTE) NIL)
	   ;;Store background color into color map, thereby [probably] causing stuff
	   ;;on screen in deleted color to disappear.
	   [COLOR (WRITE-COLOR-MAP PALETTE
			           (GET :ERASERCOLOR 'RED)
			           (GET :ERASERCOLOR 'GREEN)
			           (GET :ERASERCOLOR 'BLUE))])))) 

(DEFINE REPLACECOLOR (ABB RC) (OLD-COLOR NEW-COLOR) 
 ;;Changes the color map, replacing old color with new color.
 (LET
  ((PALETTE-PROPS (GETL OLD-COLOR '(PALETTE))))
  (OR
   PALETTE-PROPS
   (SETQ 
    PALETTE-PROPS
    (ERRBREAK 'REPLACECOLOR
	      (LIST OLD-COLOR
		    '"IS NOT A COLOR ON THE PALETTE"))))
  (DO ((COLOR-INDEX (CADR PALETTE-PROPS) (CADR PALETTE-PROPS)))
      ((NULL PALETTE-PROPS))
      (MAKEPALETTE COLOR-INDEX NEW-COLOR)
      (SETQ PALETTE-PROPS (GETL (CDR PALETTE-PROPS) '(PALETTE)))))
 NEW-COLOR) 

;;*PAGE



(DEFINE TWIDDLECOLOR (ABB COLORTWIDDLE) NIL 
	;;Changes colors randomly in the color map every :COLORTICK seconds by
	;;replacing a random slot with a color chosen randomly from :COLORS.
	(TWIDDLEINIT)
	(DO NIL (NIL) (TWIDDLEONCE) (SLEEP :COLORTICK))) 

;;RJL suggests this generate colors with random intensities as well.

(DEFINE RANDOMCOLOR NIL (NTH (1+ (RANDOM :NCOLORS)) :COLORS))

(DEFUN TWIDDLEINIT NIL 
       (SETQ :NSLOTS (- (LENGTH (DELQ NIL (LISTARRAY 'PALETTE))) 1.))) 

(DEFUN NTH (POSITION LIST) 
       (DO NIL ((ZEROP (DECREMENT POSITION)) (CAR LIST)) (POP LIST))) 

(DEFUN TWIDDLEONCE NIL (MAKEPALETTE (RANDOM :NSLOTS) (RANDOMCOLOR))) 

;;;
;;;(DEFUN TWIDDLEONCE NIL
;;;       (LET ((RANDOM-RED (RANDOM-BETWEEN 0. 511.))
;;;             (RANDOM-GREEN (RANDOM-BETWEEN 0. 511.))
;;;             (RANDOM-BLUE (RANDOM-BETWEEN 0. 511.))
;;;             (RANDOM-SLOT (RANDOM-BETWEEN 0 :NSLOTS)))
;;;            ;;THIS MESSES UP COLOR MAP, BUT....
;;;            (WRITE-COLOR-MAP RANDOM-SLOT RANDOM-RED RANDOM-GREEN RANDOM-BLUE)))
;;;

(DEFINE TWIDDLEREPEAT (TIMES) 
	(TWIDDLEINIT)
	(DO USELESS 0. (1+ USELESS) (= USELESS TIMES) (TWIDDLEONCE))) 


;;*PAGE

;;;

(COMMENT GLOBAL INITIALIZATIONS) 

;;;
;;;
;;;GLOBAL VARIABLES FOR DIMENSIONS OF SCREEN [ENTIRE TV TUBE],
;;AND PICTURE AREA.
;;;
;;;TV-PICTURE-TOP, TV-PICTURE-BOTTOM, TV-PICTURE-LEFT, TV-PICTURE-RIGHT
;;;  TV COORDINATES OF EDGES OF PICTURE AREA.
;;;TV-PICTURE-CENTER-X, TV-PICTURE-CENTER-Y 
;;; TV COORDINATES OF ORIGIN OF TURTLE.
;;;TV-PICTURE-SIZE-X, TV-PICTURE-SIZE-Y
;;; DIMENSIONS OF PICTURE AREA IN TV COORDINATES.
;;;TV-PICTURE-HALF-X, TV-PICTURE-HALF-Y
;;; HALF OF TV-PICTURE-SIZE-X, TV-PICTURE-SIZE-Y
;;;TURTLE-PICTURE-LEFT, TURTLE-PICTURE-RIGHT, TURTLE-PICTURE-BOTTOM,
;;TURTLE-PICTURE-TOP
;;; TURTLE COORDINATES OF EDGES OF PICTURE AREA. 
;;;TURTLE-PICTURE-SIZE-X, TURTLE-PICTURE-SIZE-Y
;;; DIMENSIONS OF PICTURE AREA IN TURTLE COORDINATES.
;;;TV-SHIFT-X, TV-SHIFT-Y
;;; DISTANCE FROM TV PICTURE CENTER TO LEFT AND BOTTOM EDGES.
;;;TV-SCREEN-CENTER-X, TV-SCREEN-CENTER-Y
;;; TV COORDINATES OF CENTER OF SCREEN.
;;;TV-SCREEN-RIGHT, TV-SCREEN-BOTTOM
;;; TV COORDINATES OF CORRESPONDING EDGES OF SCREEN. LEFT=TOP=0
;;;:TVSTEP
;;; CONVERSION FACTOR BETWEEN TURTLE AND TV COORDINATES.

(DECLARE (SPECIAL TV-SCREEN-CENTER-X TV-PICTURE-CENTER-X TURTLE-PICTURE-LEFT
		  TV-SCREEN-CENTER-Y PI-OVER-180 TV-PICTURE-HALF-X
		  TV-PICTURE-HALF-Y TURTLE-PICTURE-TOP TV-PICTURE-TOP
		  TV-PICTURE-CENTER-Y TV-PICTURE-BOTTOM :TVECHOLINES TV-SHIFT-Y
                  FLOAT-TV-SHIFT-Y TV-PICTURE-RIGHT FLOAT-TV-PICTURE-BOTTOM
                  TV-PICTURE-LEFT FLOAT-TV-PICTURE-LEFT TV-PICTURE-LEFT-FIX FIX-BITS
                  TV-PICTURE-BOTTOM-FIX TV-SHIFT-X FLOAT-TV-SHIFT-X :TVSTEP TWICE-TVSTEP
		  TURTLE-PICTURE-RIGHT TURTLE-PICTURE-BOTTOM SINE-120 COSINE-120
		  SINE-240 COSINE-240 TURTLE-RADIUS TURTLE-FRONT-X TURTLE-FRONT-Y
		  TURTLE-RIGHT-X TURTLE-RIGHT-Y TURTLE-LEFT-X TURTLE-LEFT-Y
		  :SEETURTLE TURTLE-FRONT-RADIUS-X TURTLE-FRONT-RADIUS-Y
		  TURTLE-LEFT-RADIUS-X TURTLE-LEFT-RADIUS-Y TURTLE-RIGHT-RADIUS-X
		  TURTLE-RIGHT-RADIUS-Y TV-PEN-RADIUS TV-TURTLE-FRONT-RADIUS
		  TV-TURTLE-SIDE-RADIUS TV-PICTURE-SIZE-X TV-PICTURE-SIZE-Y
                  FLOAT-TV-PICTURE-SIZE-X FLOAT-TV-PICTURE-SIZE-Y
		  TV-SCREEN-BOTTOM TV-SCREEN-RIGHT :TURTLES :TURTLE :WINDOWS 
                  TURTLE-PROPERTIES HATCH-PROPERTIES :XCOR :YCOR :HEADING)
	 (FLONUM PI-OVER-180 TURTLE-PICTURE-RIGHT TURTLE-PICTURE-TOP SINE-120
		 COSINE-120 SINE-240 COSINE-240 TURTLE-RADIUS TURTLE-FRONT-X
		 TURTLE-FRONT-Y TURTLE-LEFT-X TURTLE-LEFT-Y TURTLE-RIGHT-X
		 TURTLE-RIGHT-Y TURTLE-FRONT-RADIUS-X TURTLE-FRONT-RADIUS-Y
		 TURTLE-RIGHT-RADIUS-X TURTLE-RIGHT-RADIUS-Y TURTLE-LEFT-RADIUS-X
		 TURTLE-LEFT-RADIUS-Y TV-PEN-RADIUS TV-TURTLE-FRONT-RADIUS
		 TV-TURTLE-SIDE-RADIUS TURTLE-PICTURE-TOP TURTLE-PICTURE-RIGHT
		 TURTLE-PICTURE-LEFT TURTLE-PICTURE-BOTTOM :XCOR :YCOR :HEADING
                 FLOAT-TV-SHIFT-Y FLOAT-TV-SHIFT-X FLOAT-TV-PICTURE-LEFT
                 FLOAT-TV-PICTURE-BOTTOM FLOAT-TV-PICTURE-SIZE-X FLOAT-TV-PICTURE-SIZE-Y)
	 (FIXNUM TV-PICTURE-CENTER-X TV-SCREEN-CENTER-X TV-SCREEN-CENTER-Y
		 TV-PICTURE-TOP TV-PICTURE-HALF-X TV-PICTURE-HALF-Y TV-SHIFT-X
		 TV-SHIFT-Y TV-PICTURE-RIGHT TV-PICTURE-CENTER-Y TV-PICTURE-BOTTOM
                 TV-PICTURE-LEFT-FIX TV-PICTURE-BOTTOM-FIX FIX-BITS TV-SCREEN-RIGHT
		 :TVECHOLINES TV-PICTURE-RIGHT TV-PICTURE-LEFT TV-PICTURE-TOP
                 TV-PICTURE-SIZE-X TV-PICTURE-SIZE-Y TV-SCREEN-BOTTOM XGP-MAX))
     

(DECLARE (SPECIAL FIX-BITS MINUS-FIX-BITS UNIT-BIT FLOAT-UNIT UNIT-MASK HALF-UNIT)
         (FIXNUM FIX-BITS MINUS-FIX-BITS UNIT-BIT UNIT-MASK HALF-UNIT)
         (FLONUM FLOAT-UNIT))

(SETQ TV-SCREEN-CENTER-X 288. 
      TV-SCREEN-BOTTOM 455. 
      TV-SCREEN-RIGHT 575.
      TV-SCREEN-CENTER-Y (// TV-SCREEN-BOTTOM 2.) 
      FLOATING-POINT-TOLERANCE 1.0E-3 
      TWICE-FLOATING-POINT-TOLERANCE (*$ 2.0 FLOATING-POINT-TOLERANCE) 
      :PI 3.1415926 
      PI-OVER-180 (//$ :PI 180.0) 
      :POLYGON 30.0 
      :ECHOLINES NIL 
      SINE-120 (SIN (*$ 120.0 PI-OVER-180)) 
      COSINE-120 (COS (*$ 120.0 PI-OVER-180)) 
      SINE-240 (SIN (*$ 240.0 PI-OVER-180)) 
      COSINE-240 (COS (*$ 240.0 PI-OVER-180)) 
      TV-PEN-RADIUS 3.0 
      TV-TURTLE-FRONT-RADIUS 15.0 
      TV-TURTLE-SIDE-RADIUS 10.0 
      LESS-SUBR (GET '< 'SUBR) 
      GREATER-SUBR (GET '> 'SUBR) 
      WINDOWFRAME-BOUNDS NIL 
      VISIBLE-NUMBER 8. 
      TURTLE-PROPERTIES 23.
      ;;Changing TURTLE-PROPERTIES also requires changing declaration 
      ;;for HATCH-PROPERTY, TURTLE-PROPERTY above. 
      XGP-MAX 300.
      :WINDOWS NIL
      TV-SIZE-X-MAX 573.
      TV-SIZE-Y-MAX [COLOR 449.] [BW 415.]
      FIX-BITS 22.
      ;;Number of bits in fractional part.
      MINUS-FIX-BITS (- FIX-BITS)
      ;;Shift count for converting to ordinary integer.
      ;;One in fixed & float, mask for fractional part.
      UNIT-BIT (LSH 1. FIX-BITS)
      HALF-UNIT (LSH UNIT-BIT -1.)
      FLOAT-UNIT (FLOAT UNIT-BIT)
      UNIT-MASK (1- UNIT-BIT)
      :PENNUMBER 15. :ERASERNUMBER 15.)

(DECLARE (FLONUM CONVERSION-FACTOR TV-FACTOR-X TV-FACTOR-Y TURTLE-PICTURE-MIN
		 NEW-TURTLE-SIZE)
	 (SPECIAL TV-FACTOR-X TV-FACTOR-Y TURTLE-PICTURE-MIN TV-PICTURE-MIN)
	 (FIXNUM NEW-TV-SIZE-X NEW-TV-SIZE-Y TV-PICTURE-MIN)) 

(DECLARE (SPECIAL FLOATING-POINT-TOLERANCE TWICE-FLOATING-POINT-TOLERANCE LESS-SUBR
		  GREATER-SUBR)
	 (FLONUM FLOATING-POINT-TOLERANCE TWICE-FLOATING-POINT-TOLERANCE)
	 (SPECIAL PEN-RADIUS TURTLE-FRONT-RADIUS TURTLE-SIDE-RADIUS
		  TURTLE-PICTURE-SIZE-X TURTLE-PICTURE-SIZE-Y)
	 (FLONUM PEN-RADIUS TURTLE-FRONT-RADIUS TURTLE-SIDE-RADIUS
		 TURTLE-PICTURE-SIZE-X TURTLE-PICTURE-SIZE-Y NEW-TURTLE-SIZE-X
		 NEW-TURTLE-SIZE-Y)) 

(DECLARE (FIXNUM NEW-HOME-X NEW-HOME-Y (TV-X FLONUM) (TV-Y FLONUM))
	 (FLONUM :XCOR :YCOR TURTLE-SHIFT-X TURTLE-SHIFT-Y)
	 (SPECIAL :XCOR :YCOR)
	 (NOTYPE (SETXY$ FLONUM FLONUM))) 

(DECLARE (SPECIAL :PENSTATE :ERASERSTATE :XORSTATE :DRAWSTATE)) 

(DECLARE (SPECIAL TV-PICTURE-MIN SINE-HEADING COSINE-HEADING :DRAWTURTLE
		  :ERASETURTLE XGP-MAX HORIZONTAL VERTICAL :OUTLINE :WINDOWOUTLINE
                  :BRUSH BRUSH-INFO BRUSH-PICTURE :CLIP :PATTERNS
                  :PENCOLOR :PENNUMBER :ERASERNUMBER :ERASERCOLOR)
	 (FIXNUM TV-PICTURE-MIN XGP-MAX FROM-INDEX TO-INDEX POINT-INDEX
                 :PENNUMBER :ERASERNUMBER)
	 (FLONUM SINE-HEADING COSINE-HEADING :TVSTEP TWICE-TVSTEP)) 

(DECLARE (ARRAY* (FIXNUM (FROM-MASK 32.) (TO-MASK 32.) (POINT-MASK 32.)
                 [COLOR (ELEVEN-FROM-MASK 16.) (ELEVEN-TO-MASK 16.) 
                        (ELEVEN-POINT-MASK 16.) (ELEVEN-NOT-POINT-MASK 16.)])))

(DECLARE (ARRAY* (NOTYPE (HATCH-PROPERTY 23.) 
                         (TURTLE-PROPERTY 23.))))

(DEFUN INITIALIZE-TVRTLE-VARIABLES NIL 
       (SETQ TV-PICTURE-TOP [COLOR 2.] [BW 1.]
	     TV-PICTURE-BOTTOM 301.
             TV-PICTURE-BOTTOM-FIX (LSH TV-PICTURE-BOTTOM FIX-BITS)
             FLOAT-TV-PICTURE-BOTTOM (FLOAT TV-PICTURE-BOTTOM)
	     TV-PICTURE-LEFT 138. 
             TV-PICTURE-LEFT-FIX (LSH TV-PICTURE-LEFT FIX-BITS)
             FLOAT-TV-PICTURE-LEFT (FLOAT TV-PICTURE-LEFT)
	     TV-PICTURE-RIGHT 438. 
	     TV-PICTURE-CENTER-X 288. 
	     TV-PICTURE-CENTER-Y 151.
	     TV-SHIFT-X (- TV-PICTURE-CENTER-X TV-PICTURE-LEFT) 
             FLOAT-TV-SHIFT-X (+$ (FLOAT TV-SHIFT-X) 0.5)
	     TV-SHIFT-Y (- TV-PICTURE-BOTTOM TV-PICTURE-CENTER-Y) 
             FLOAT-TV-SHIFT-Y (+$ (FLOAT TV-SHIFT-Y) 0.5)
	     TV-PICTURE-HALF-X 150. 
	     TV-PICTURE-HALF-Y 150. 
	     TV-PICTURE-SIZE-X 301. 
             FLOAT-TV-PICTURE-SIZE-X 300.0
	     TV-PICTURE-SIZE-Y 301. 
             FLOAT-TV-PICTURE-SIZE-Y 300.0
	     TV-PICTURE-MIN 301. 
	     TV-FACTOR-X 1.0 
	     TV-FACTOR-Y 1.0 
	     TURTLE-PICTURE-MIN 1000.0 
	     :TVSTEP (//$ TURTLE-PICTURE-MIN
				(-$ (FLOAT TV-PICTURE-MIN)
				    TWICE-FLOATING-POINT-TOLERANCE))
             TWICE-TVSTEP (*$ 2.0 :TVSTEP) 
	     TURTLE-FRONT-RADIUS (*$ TV-TURTLE-FRONT-RADIUS :TVSTEP) 
	     TURTLE-SIDE-RADIUS (*$ TV-TURTLE-SIDE-RADIUS :TVSTEP) 
	     TURTLE-PICTURE-SIZE-X 1000.0 
	     TURTLE-PICTURE-SIZE-Y 1000.0 
	     TURTLE-PICTURE-TOP 500.0 
	     TURTLE-PICTURE-BOTTOM -500.0 
	     TURTLE-PICTURE-LEFT -500.0 
	     TURTLE-PICTURE-RIGHT 500.0 
	     :XCOR 0.0 
	     :YCOR 0.0 
	     :HEADING 0.0 
	     SINE-HEADING 0.0 
	     COSINE-HEADING 1.0 
	     :PENSTATE T 
	     :ERASERSTATE NIL 
	     :XORSTATE NIL 
             :DRAWSTATE T
	     :WRAP NIL 
             :CLIP NIL
	     :SEETURTLE NIL 
	     :DRAWTURTLE NIL 
	     :ERASETURTLE NIL 
	     :TURTLES '(LOGOTURTLE)
	     :TURTLE 'LOGOTURTLE 
	     :TVECHOLINES 10.
             :BRUSH NIL
             BRUSH-INFO NIL
             BRUSH-PICTURE NIL 
             :PATTERNS '(SOLID GRID CHECKER HORIZLINES VERTLINES DARKTEXTURE
                         LIGHTTEXTURE TEXTURE)
             HORIZONTAL (EXPR-FUNCTION HORIZONTAL-LINE)
             VERTICAL (EXPR-FUNCTION VERTICAL-LINE)
             :WINDOWOUTLINE [COLOR NIL] [BW T]
             :OUTLINE T)
       (FILLARRAY (ARRAY TURTLE-PROPERTY T TURTLE-PROPERTIES)
		  '(TV-PICTURE-CENTER-X TV-PICTURE-CENTER-Y :XCOR :YCOR :HEADING 
                    SINE-HEADING COSINE-HEADING :PENSTATE :ERASERSTATE 
                    :XORSTATE :DRAWSTATE :WRAP :CLIP :SEETURTLE 
                    :DRAWTURTLE :ERASETURTLE :PENCOLOR :PENNUMBER
                    :BRUSH BRUSH-INFO BRUSH-PICTURE HORIZONTAL VERTICAL))
       (FILLARRAY (ARRAY HATCH-PROPERTY T TURTLE-PROPERTIES)
		  (APPEND '(288. 152. 0.0 0.0 0.0 0.0 1.0 T NIL NIL T NIL NIL NIL NIL 
                            NIL WHITE 0. NIL NIL NIL)
                          (LIST (EXPR-FUNCTION HORIZONTAL-LINE)
                                (EXPR-FUNCTION VERTICAL-LINE))))
       (PUTPROP 'LOGOTURTLE (*ARRAY NIL T TURTLE-PROPERTIES) 'TURTLE)
       (ARRAY FROM-MASK FIXNUM 32.)
       (ARRAY TO-MASK FIXNUM 32.)
       (ARRAY POINT-MASK FIXNUM 32.)
       [COLOR (ARRAY ELEVEN-FROM-MASK FIXNUM 16.)
              (ARRAY ELEVEN-TO-MASK FIXNUM 16.)
              (ARRAY ELEVEN-POINT-MASK FIXNUM 16.)
              (ARRAY ELEVEN-NOT-POINT-MASK FIXNUM 16.)]
       (DO FROM-INDEX 0. (1+ FROM-INDEX) (= FROM-INDEX 32.)
           (STORE (FROM-MASK FROM-INDEX) (BITWISE-AND -16. (LSH -1. (- FROM-INDEX)))))
       (DO TO-INDEX 0. (1+ TO-INDEX) (= TO-INDEX 32.)
           (STORE (TO-MASK TO-INDEX) (LSH -1. (- 35. TO-INDEX))))
       (DO POINT-INDEX 0. (1+ POINT-INDEX) (= POINT-INDEX 32.)
           (STORE (POINT-MASK POINT-INDEX) (LSH 1. (- 35. POINT-INDEX))))
       [COLOR (DO FROM-INDEX 0. (1+ FROM-INDEX) (= FROM-INDEX 16.)
                 (STORE (ELEVEN-FROM-MASK FROM-INDEX) (LSH -1. (- 16. FROM-INDEX))))
              (DO TO-INDEX 0. (1+ TO-INDEX) (= TO-INDEX 16.)
                  (STORE (ELEVEN-TO-MASK TO-INDEX)  (1- (LSH 1. (- 15. TO-INDEX)))))
              (DO POINT-INDEX 0. (1+ POINT-INDEX) (= POINT-INDEX 16.)
                  (STORE (ELEVEN-POINT-MASK POINT-INDEX) (LSH 1. (- 15. POINT-INDEX)))
                  (STORE (ELEVEN-NOT-POINT-MASK POINT-INDEX) 
                         (BITWISE-NOT (ELEVEN-POINT-MASK POINT-INDEX))))]) 

;;*PAGE

;;;

(COMMENT SCALING FUNCTIONS) 

;;;

(DEFUN TURTLE-SIZE-X (NEW-TURTLE-SIZE-X) 
       (LET ((CONVERSION-FACTOR (//$ NEW-TURTLE-SIZE-X TURTLE-PICTURE-SIZE-X)))
	    (SETQ TURTLE-PICTURE-SIZE-X NEW-TURTLE-SIZE-X 
		  TURTLE-PICTURE-LEFT (*$ TURTLE-PICTURE-LEFT CONVERSION-FACTOR) 
		  TURTLE-PICTURE-RIGHT (*$ TURTLE-PICTURE-RIGHT CONVERSION-FACTOR)))) 

(DEFUN TURTLE-SIZE-Y (NEW-TURTLE-SIZE-Y) 
       (LET ((CONVERSION-FACTOR (//$ NEW-TURTLE-SIZE-Y TURTLE-PICTURE-SIZE-Y)))
	    (SETQ TURTLE-PICTURE-SIZE-Y NEW-TURTLE-SIZE-Y 
		  TURTLE-PICTURE-TOP (*$ TURTLE-PICTURE-TOP CONVERSION-FACTOR) 
		  TURTLE-PICTURE-BOTTOM (*$ TURTLE-PICTURE-BOTTOM
					    CONVERSION-FACTOR)))) 

(DEFINE TURTLESIZE ARGS 
	(COND ((ZEROP ARGS))
	      ((= ARGS 1.)
               (ERASE-TURTLE)
	       (SETQ TURTLE-PICTURE-MIN (FLOAT (ARG 1.)) 
		     :TVSTEP (//$ TURTLE-PICTURE-MIN
					(-$ (FLOAT TV-PICTURE-MIN)
					    TWICE-FLOATING-POINT-TOLERANCE)) 
                     TWICE-TVSTEP (*$ 2.0 :TVSTEP)
		     TURTLE-FRONT-RADIUS (*$ TV-TURTLE-FRONT-RADIUS :TVSTEP) 
		     TURTLE-SIDE-RADIUS (*$ TV-TURTLE-SIDE-RADIUS :TVSTEP))
	       (TURTLE-SIZE-X (*$ TURTLE-PICTURE-MIN TV-FACTOR-X))
	       (TURTLE-SIZE-Y (*$ TURTLE-PICTURE-MIN TV-FACTOR-Y))
               (DRAW-TURTLE)))
	(LIST TURTLE-PICTURE-SIZE-X TURTLE-PICTURE-SIZE-Y)) 

(ARGS 'TURTLESIZE '(0. . 1.)) 

(DEFUN TV-SETHOME (NEW-HOME-X NEW-HOME-Y) 
       (LET ((TURTLE-SHIFT-X (*$ (FLOAT (- NEW-HOME-X TV-PICTURE-CENTER-X))
				 :TVSTEP))
	     (TURTLE-SHIFT-Y (*$ (FLOAT (- TV-PICTURE-CENTER-Y NEW-HOME-Y))
				 :TVSTEP)))
	    (SETQ TV-PICTURE-CENTER-X NEW-HOME-X 
		  TV-PICTURE-CENTER-Y NEW-HOME-Y 
		  TV-SHIFT-X (- TV-PICTURE-CENTER-X TV-PICTURE-LEFT) 
                  FLOAT-TV-SHIFT-X (+$ (FLOAT TV-SHIFT-X) 0.5)
		  TV-SHIFT-Y (- TV-PICTURE-BOTTOM TV-PICTURE-CENTER-Y) 
                  FLOAT-TV-SHIFT-Y  (+$ (FLOAT TV-SHIFT-Y) 0.5)
		  TURTLE-PICTURE-RIGHT (-$ TURTLE-PICTURE-RIGHT TURTLE-SHIFT-X) 
		  TURTLE-PICTURE-LEFT (-$ TURTLE-PICTURE-LEFT TURTLE-SHIFT-X) 
		  TURTLE-PICTURE-TOP (-$ TURTLE-PICTURE-TOP TURTLE-SHIFT-Y) 
		  TURTLE-PICTURE-BOTTOM (-$ TURTLE-PICTURE-BOTTOM TURTLE-SHIFT-Y)))) 

(DEFINE SETHOME (ABB TURTLEHOME TH) ARGS 
	(ERASE-TURTLE)
	(LET ((NEW-HOME-X (COND ((ZEROP ARGS) (TV-X :XCOR))
				((= ARGS 1.) (TV-X (FLOAT (CAR (ARG 1.)))))
				((TV-X (FLOAT (ARG 1.))))))
	      (NEW-HOME-Y (COND ((ZEROP ARGS) (TV-Y :YCOR))
				((= ARGS 1.) (TV-Y (FLOAT (CAR (ARG 1.)))))
				((TV-Y (FLOAT (ARG 2.))))))
	      (:SEETURTLE NIL)
              (:DRAWSTATE NIL))
	     (TV-SETHOME NEW-HOME-X NEW-HOME-Y)
	     (SETXY$ 0.0 0.0))
	(DRAW-TURTLE)
	NO-VALUE) 

;;*PAGE


(DEFUN INTERNAL-TV-SIZE (NEW-TV-SIZE-X NEW-TV-SIZE-Y) 
       (COND ((> NEW-TV-SIZE-X NEW-TV-SIZE-Y)
	      (SETQ TV-PICTURE-MIN (1+ NEW-TV-SIZE-Y) 
		    TV-FACTOR-Y 1.0 
		    TV-FACTOR-X (//$ (FLOAT NEW-TV-SIZE-X) (FLOAT NEW-TV-SIZE-Y))))
	     ((SETQ TV-PICTURE-MIN (1+ NEW-TV-SIZE-X) 
		    TV-FACTOR-X 1.0 
		    TV-FACTOR-Y (//$ (FLOAT NEW-TV-SIZE-Y) (FLOAT NEW-TV-SIZE-X)))))
      (LET ((TV-CONVERSION-X (//$ (FLOAT NEW-TV-SIZE-X) FLOAT-TV-PICTURE-SIZE-X))
            (TV-CONVERSION-Y (//$ (FLOAT NEW-TV-SIZE-Y) FLOAT-TV-PICTURE-SIZE-Y)))
           ;;Conversion factors between old & new TV sizes for X and Y.
       (SETQ TV-PICTURE-HALF-X (LSH NEW-TV-SIZE-X -1.) 
	     TV-SHIFT-X (ROUND (*$ (FLOAT TV-SHIFT-X) TV-CONVERSION-X)) 
             FLOAT-TV-SHIFT-X (+$ (FLOAT TV-SHIFT-X) 0.5)
	     TV-PICTURE-SIZE-X (1+ NEW-TV-SIZE-X) 
             FLOAT-TV-PICTURE-SIZE-X (FLOAT NEW-TV-SIZE-X)
	     TV-PICTURE-LEFT (- TV-SCREEN-CENTER-X TV-PICTURE-HALF-X) 
             FLOAT-TV-PICTURE-LEFT (FLOAT TV-PICTURE-LEFT)
             TV-PICTURE-LEFT-FIX (LSH TV-PICTURE-LEFT FIX-BITS)
	     TV-PICTURE-RIGHT (+ TV-SCREEN-CENTER-X TV-PICTURE-HALF-X) 
	     TV-PICTURE-CENTER-X (+ TV-PICTURE-LEFT TV-SHIFT-X) 
	     TV-PICTURE-HALF-Y (LSH NEW-TV-SIZE-Y -1.) 
	     TV-SHIFT-Y (ROUND (*$ (FLOAT TV-SHIFT-Y) TV-CONVERSION-Y)) 
             FLOAT-TV-SHIFT-Y (+$ (FLOAT TV-SHIFT-Y) 0.5)
	     TV-PICTURE-SIZE-Y (1+ NEW-TV-SIZE-Y) 
             FLOAT-TV-PICTURE-SIZE-Y (FLOAT NEW-TV-SIZE-Y)
	     TV-PICTURE-BOTTOM (+ TV-PICTURE-TOP (LSH TV-PICTURE-HALF-Y 1.)) 
             TV-PICTURE-BOTTOM-FIX (LSH TV-PICTURE-BOTTOM FIX-BITS)
             FLOAT-TV-PICTURE-BOTTOM (FLOAT TV-PICTURE-BOTTOM)
	     TV-PICTURE-CENTER-Y (- TV-PICTURE-BOTTOM TV-SHIFT-Y) 
	     :TVECHOLINES (// (- TV-SCREEN-BOTTOM TV-PICTURE-BOTTOM 24.) 12.))
       ;;Update the homes of the turtles.
       (MAPC '(LAMBDA (TURTLE)
                      (COND ((EQ TURTLE :TURTLE))
                            ;;:TURTLE'S homes are spread in variables which
                            ;;have already been updated.
                            ((SETQ TURTLE (GET TURTLE 'TURTLE))
                             (STORE (ARRAYCALL T TURTLE 0.)
                                    (+ TV-SCREEN-CENTER-X
                                       (ROUND (*$ TV-CONVERSION-X 
                                                  (FLOAT (- (ARRAYCALL T TURTLE 0.)
                                                            TV-SCREEN-CENTER-X))))))
                             (STORE (ARRAYCALL T TURTLE 1.)
                                    (+ TV-PICTURE-TOP 
                                       (ROUND (*$ TV-CONVERSION-Y
                                                  (FLOAT (- (ARRAYCALL T TURTLE 1.)
                                                            TV-PICTURE-TOP)))))))))
             :TURTLES))
       (STORE (HATCH-PROPERTY 1.) (+ TV-PICTURE-TOP TV-PICTURE-HALF-Y))
       (CREATE-ECHO-AREA :TVECHOLINES))

 

(DECLARE (SPECIAL TV-SIZE-X-MAX TV-SIZE-Y-MAX) (FIXNUM TV-SIZE-X-MAX TV-SIZE-Y-MAX))

(DEFINE TVSIZE ARGS 
 (COND
  ((ZEROP ARGS))
  ((LET
    ((TV-SIZE-X (OR (ARG 1.) (1- TV-PICTURE-SIZE-X)))
     (TV-SIZE-Y (COND ((= ARGS 2.) (OR (ARG 2.) (1- TV-PICTURE-SIZE-Y)))
		      ((ARG 1.)))))
    (COND
     ((NOT (FIXP TV-SIZE-X))
      (SETQ TV-SIZE-X
	    (ERRBREAK 'TVSIZE
		      '"WRONG TYPE INPUT FOR X SIZE")))
     ((< TV-SIZE-X 30.)
      (SETQ TV-SIZE-X
	    (ERRBREAK 'TVSIZE
		      '"HORIZONTAL SIZE TOO SMALL")))
     ((> TV-SIZE-X TV-SIZE-X-MAX)
      (SETQ TV-SIZE-X
	    (ERRBREAK 'TVSIZE
		      '"HORIZONTAL SIZE TOO BIG"))))
    (COND ((NOT (FIXP TV-SIZE-Y))
	   (SETQ TV-SIZE-Y
		 (ERRBREAK 'TVSIZE
			   '"WRONG TYPE INPUT FOR Y SIZE")))
	  ((< TV-SIZE-Y 30.)
	   (SETQ TV-SIZE-Y
		 (ERRBREAK 'TVSIZE
			   '"VERTICAL SIZE TOO SMALL")))
	  ((> TV-SIZE-Y TV-SIZE-Y-MAX)
	   (SETQ TV-SIZE-Y
		 (ERRBREAK 'TVSIZE
			   '"VERTICAL SIZE TOO BIG"))))
    (INTERNAL-TV-SIZE TV-SIZE-X TV-SIZE-Y))
   (TURTLESIZE TURTLE-PICTURE-MIN)
   (CLEARSCREEN)))
 (LIST (1- TV-PICTURE-SIZE-X) (1- TV-PICTURE-SIZE-Y))) 

(ARGS 'TVSIZE '(0. . 2.))

(DECLARE (FLONUM FLOAT-SCALE-FACTOR))

(DEFINE SCALE (SCALE-FACTOR)
        ;;Changes the turtlesize without moving the turtle's place on
        ;;the screen. SCALE 2 doubles the size of subsequent drawings, etc.
        (LET ((:DRAWSTATE NIL) 
              ;;Don't draw turtle or lines during TURTLESIZE, SETXY operations.
              (:SEETURTLE NIL)
              (FLOAT-SCALE-FACTOR (FLOAT SCALE-FACTOR)))
             (TURTLESIZE (//$ TURTLE-PICTURE-MIN FLOAT-SCALE-FACTOR))
             ;;Change the turtlesize appropriately and move the turtle so its
             ;;place on the visual screen doesn't change.
             (SETXY$ (//$ :XCOR FLOAT-SCALE-FACTOR)
                     (//$ :YCOR FLOAT-SCALE-FACTOR)))) 

;;*PAGE

;;ARITHMETIC.

(DECLARE (FLONUM (\$ FLONUM FLONUM) (SINE) (COSINE) (ARCTAN) PI-OVER-180)
	 (SPECIAL PI-OVER-180) (FIXNUM FIX-MOD)) 

(DEFUN \$ (MODULAND MODULUS) 
       (LET ((FIX-MOD (FIX (//$ MODULAND MODULUS)))) 
            (-$ MODULAND (*$ MODULUS (FLOAT FIX-MOD)))))

(DEFINE SINE (DEGREES) (SIN (*$ (FLOAT DEGREES) PI-OVER-180))) 

(DEFINE COSINE (DEGREES) (COS (*$ (FLOAT DEGREES) PI-OVER-180))) 

(DEFINE ARCTAN (OPPOSITE ADJACENT) 
	(//$ (ATAN (FLOAT OPPOSITE) (FLOAT ADJACENT)) PI-OVER-180)) 

;;FUNCTIONS FOR CONVERTING BACK AND FORTH FROM TURTLE COORDINATES TO ABSOLUTE TV
;;COORDINATES.

(DECLARE (FLONUM (TURTLE-X FIXNUM)) (FIXNUM TV-XCOR)) 

(DEFUN TURTLE-X (TV-XCOR) (*$ (FLOAT (- TV-XCOR TV-PICTURE-CENTER-X)) :TVSTEP)) 

(DECLARE (FLONUM (TURTLE-Y FIXNUM)) (FIXNUM TV-YCOR)) 

(DEFUN TURTLE-Y (TV-YCOR) (*$ :TVSTEP (FLOAT (- TV-PICTURE-CENTER-Y TV-YCOR)))) 

(DECLARE (FIXNUM TV-PICTURE-SIZE-X TV-PICTURE-LEFT TV-SHIFT-X)
	 (SPECIAL TV-PICTURE-SIZE-X TV-PICTURE-LEFT TV-SHIFT-X)) 

(DECLARE (FIXNUM TV-PICTURE-SIZE-Y TV-SHIFT-Y TV-PICTURE-BOTTOM)
	 (SPECIAL TV-PICTURE-SIZE-Y TV-PICTURE-BOTTOM TV-SHIFT-Y)) 

(DECLARE (FIXNUM (TV-X FLONUM) RAW-X (TV-Y FLONUM) RAW-Y)) 

(DEFUN TV-X (TURTLE-X) 
       (LET ((RAW-X (+ (ROUND (//$ TURTLE-X :TVSTEP)) TV-SHIFT-X)))
	    ;;SCALE TO TV SIZED STEPS.
            (COND (:WRAP 
                   (COND ((MINUSP (SETQ RAW-X (\ RAW-X TV-PICTURE-SIZE-X)))
                          (INCREMENT RAW-X TV-PICTURE-SIZE-X)))))
	    ;;MOVE ZERO TO LEFT EDGE AND WRAP.
	    (+ RAW-X TV-PICTURE-LEFT))) 

(DEFUN TV-Y (TURTLE-Y) 
       (LET ((RAW-Y (+ (ROUND (//$ TURTLE-Y :TVSTEP)) TV-SHIFT-Y)))
	    ;;SCALE TO TV SIZED STEPS.
            (COND (:WRAP 
                   (COND ((MINUSP (SETQ RAW-Y (\ RAW-Y TV-PICTURE-SIZE-Y)))
                          (INCREMENT RAW-Y TV-PICTURE-SIZE-Y)))))
	    ;;MOVE ZERO TO BOTTOM. Y COORDINATES GO IN OTHER DIRECTION.
	    (- TV-PICTURE-BOTTOM RAW-Y))) 

;;*PAGE

;;;

(COMMENT SCREEN CLEARING)   

;;;

(DECLARE (SPECIAL :XCOR :YCOR :HEADING SINE-HEADING COSINE-HEADING :PENSTATE
		  :ERASERSTATE :XORSTATE TURTLE-PICTURE-RIGHT TURTLE-PICTURE-TOP
		  :TVSTEP :WRAP :SEETURTLE)
	 (FLONUM :XCOR :YCOR :HEADING SINE-HEADING COSINE-HEADING
		 TURTLE-PICTURE-RIGHT TURTLE-PICTURE-TOP :TVSTEP)) 

(DECLARE (FIXNUM I STOP J)) 

[BW 
(DEFUN TV-CLEARSCREEN NIL 
       (DO ((I 0. (1+ I))
	    (STOP (* 18. (- TV-SCREEN-BOTTOM (* :ECHOLINES 12.) 12.)))
	    (OLD-DRAWMODE (DRAWMODE SET)))
	   ((> I STOP) (DRAWMODE OLD-DRAWMODE))
           (STORE (TV I) 0.))
       (OUTPUT-TO-ECHO-AREA)
       (OUTLINE)) 

;;STARTDISPLAY IS A LEXPR FOR COMPATIBILITY WITH 340/GT40 TURTLE.

(DEFINE STARTDISPLAY (ABB SD) ARGS (TVINIT)
				   (INITIALIZE-TVRTLE-VARIABLES)
                                   (INITIALIZE-PALETTE)
				   (CURSORPOS (- (CAR (STATUS TTYSIZE)) 2.) 0.)
				   (CREATE-ECHO-AREA :TVECHOLINES)
				   (TV-CLEARSCREEN)
                                   (CURSORPOS 'C)
				   (HATCH 'LOGOTURTLE)
				   NO-VALUE) ]

(ARGS 'STARTDISPLAY '(0. . 0.)) 

(DEFINE NODISPLAY (ABB ND) NIL [BW (CREATE-ECHO-AREA 0.)] (CURSORPOS 'C) NO-VALUE) 

(DECLARE (*LEXPR HIDEWINDOW)) 

(DEFINE WIPE ARGS 
	(COND ((ZEROP ARGS) (WIPECLEAN))
	      ;;NO ARGS, CLEARS SCREEN, BUT DOESN'T MOVE TURTLE, [AS LLOGO 340 WIPE,
	      ;;11LOGO'S WIPECLEAN].  ONE ARG A WINDOW, HIDES IT AT CURRENT LOCATION
	      ;;[AS 11LOGO'S WIPE].
	      ((HIDEWINDOW (ARG 1.) :XCOR :YCOR)))
	NO-VALUE) 

[COLOR 

(DEFUN TV-CLEARSCREEN NIL 
       (WRITE-TV-MASK 0.) 
       ;;Use of block mode for CLEARSCREEN is currently
       ;;unreliable due to hardware flakiness.
       ;;;(WRITE-TV-BLOCK 0. -1. 16344. 1.)
       (DO ((I 0 (1+ I))) 
           ((= I 8192.))
           (STORE (TV I) -16.))) 

;;STARTDISPLAY IS A LEXPR FOR COMPATIBILITY WITH 340/GT40 TURTLE.

(DEFINE STARTDISPLAY (ABB SD) ARGS (INITIALIZE-TVRTLE-VARIABLES)
				   (TVINIT)
				   ;;; (CURSORPOS (- (CAR (STATUS TTYSIZE)) 2.) 0.)
				   ;;; (CREATE-ECHO-AREA :TVECHOLINES)
				   (SETQ :ECHOLINES 0.)
				   (INTERNAL-TV-SIZE TV-SIZE-X-MAX TV-SIZE-Y-MAX)
				   (TURTLESIZE TURTLE-PICTURE-MIN)
				   (SELECT-COLOR :ERASERNUMBER)
				   (TV-CLEARSCREEN)
				   (SELECT-COLOR :PENNUMBER)
				   (OUTLINE)
				   (HATCH 'LOGOTURTLE)
				   (SHOWTURTLE)
				   NO-VALUE) 

]

[BW

(DEFINE WIPECLEAN NIL
       (COND (:ECHOLINES
              (AND (ZEROP :ECHOLINES) (CREATE-ECHO-AREA :TVECHOLINES))
              (TV-CLEARSCREEN)
              (DRAW-TURTLES)))
       NO-VALUE)

(DEFINE CLEARSCREEN (ABB CS) NIL 
	(COND (:ECHOLINES (CLEAR-PALETTE) 
                          (LET ((:SEETURTLE NIL) (:DRAWSTATE NIL)) 
                               (PENCOLOR :PENCOLOR)
                               (HOME))
                          (WIPECLEAN)
			  NO-VALUE)
	      ;;FOLLOWING FOR LOSER WHO FORGOT STARTDISPLAY.
	      ((STARTDISPLAY)))) 

(DECLARE (*LEXPR MAKEWINDOW SHOWWINDOW)) 

(DEFINE SAVEDISPLAY (ABB SVD) NIL 
 ;;SINCE EXITING LISP AND GOING TO DDT RUINS, SCREEN, THIS EXITS GRACEFULLY, SAVING
 ;;AND RESTORING PICTURE.
 (MAKEWINDOW 'WHOLESCREEN)
 (VALRET '":CLEAR
: ----- YOU'RE IN DDT ------ 
")
 (TV-CLEARSCREEN)
 (SHOWWINDOW 'WHOLESCREEN)
 (ERASEWINDOW 'WHOLESCREEN)
 NO-VALUE)

;;END OF BLACK-AND-WHITE CONDITIONAL SECTION.
]

[COLOR 


(DEFINE SAVEDISPLAY  (ABB SVD) NIL (NOT-IMPLEMENTED-IN-COLOR '(SAVEDISPLAY)))

(DECLARE (*LEXPR HIDEWINDOW)) 

(DEFUN WIPECLEAN NIL 
       (SELECT-COLOR :ERASERNUMBER)
       (TV-CLEARSCREEN)
       (SELECT-COLOR :PENNUMBER)
       (OUTLINE)
       (CLEAR-PALETTE)                         
       (DRAW-TURTLES)
       (RESELECT-COLOR))
       NO-VALUE) 

;;NO ECHOLINES IN COLOR TURTLE

(DEFINE CLEARSCREEN (ABB CS) NIL 
	(COND (:ECHOLINES (RESET)
                          (WIPECLEAN)
			  ;;Whatever else to clear screen......
			  (LET ((:DRAWSTATE NIL) (:SEETURTLE NIL))
			       (PENCOLOR :PENCOLOR)
			       (HOME))
			  (RESELECT-COLOR)
			  NO-VALUE)
	      ;;FOLLOWING FOR LOSER WHO FORGOT STARTDISPLAY.
	      ((STARTDISPLAY)))) 

;;END OF COLOR CONDITIONAL SECTION.
]

(DEFUN CLEAR-PALETTE NIL
			  ;;REMOVE THE COLOR NUMBER PROPERTIES FROM COLORS BEING
			  ;;FLUSHED.
			  (DO COLOR-INDEX
			      0.
			      (1+ COLOR-INDEX)
			      (= COLOR-INDEX COLOR-MAX)
			      (AND (PALETTE COLOR-INDEX)
                                   (REMPROP (PALETTE COLOR-INDEX) 'PALETTE)))
			  ;;Now we know that nothing is on the screen in any color
			  ;;except the background, so we can mark all the slots in
			  ;;the palette as empty.
			  (FILLARRAY 'PALETTE '(NIL))
			  (ERASERCOLOR :ERASERCOLOR))


;;*PAGE

;;;

(COMMENT LINE DRAWING PROCEDURES) 

;;;

[BW

(DECLARE (NOTYPE (VERTICAL-LINE FIXNUM FIXNUM FIXNUM))	 
         (SPECIAL TV-PICTURE-TOP)
	 (FIXNUM TV-PICTURE-TOP MASK TV-ADDRESS STOP-ADDRESS)) 

;;VERTICAL-LINE EXPECTS ITS INPUT IN TV COORDINATES, LEAST Y TO GREATEST Y
;;[TOP TO BOTTOM].
;;IT TAKES ADVANTAGE OF THE KNOWLEDGE THAT IT IS TO DRAW A VERTICAL LINE, AND
;;RECYCLES THE MASK USED TO PICK OUT THE APPROPRIATE BIT.

(DEFUN VERTICAL-LINE (FROM-X FROM-Y TO-Y) 
       (DO ((MASK (POINT-MASK (BITWISE-AND FROM-X 31.)))
            (TV-ADDRESS (+ (* 18. FROM-Y) (SETQ FROM-X (LSH FROM-X -5.)))
                        (+ TV-ADDRESS 18.))
            (STOP-ADDRESS (+ (* 18. TO-Y) FROM-X)))
           ((> TV-ADDRESS STOP-ADDRESS))
	   (STORE (TV TV-ADDRESS) MASK))) 

;;;HORIZONTAL-LINE EXPECTS INPUT IN TV COORDINATES,
;;;FROM LEAST X TO GREATEST X [LEFT TO RIGHT].
;;IT TAKES ADVANTAGE OF THE SPECIAL CASE TO RAPIDLY DRAW A LINE SETTING UP TO 32
;;BITS IN PARALLEL WITH ONE STORE.

(DECLARE (NOTYPE (HORIZONTAL-LINE FIXNUM FIXNUM FIXNUM)) 
         (FIXNUM MASK STOP-MASK STOP-X)) 

(DEFUN HORIZONTAL-LINE (FROM-X FROM-Y TO-X) 
       (LET ((MASK (FROM-MASK (BITWISE-AND (PROG1 FROM-X (SETQ FROM-X (LSH FROM-X -5.)))
                                           31.)))
             (TV-ADDRESS (+ (SETQ FROM-Y (* 18. FROM-Y)) FROM-X) (1+ TV-ADDRESS))
	     (STOP-ADDRESS (+ FROM-Y (LSH TO-X -5.)))
             (STOP-MASK (TO-MASK (BITWISE-AND TO-X 31.))))
            (COND ((= TV-ADDRESS STOP-ADDRESS)
                   (STORE (TV STOP-ADDRESS) (BITWISE-AND MASK STOP-MASK)))
                  (T (STORE (TV TV-ADDRESS) MASK)
                     (DO NIL 
                         ((= (INCREMENT TV-ADDRESS) STOP-ADDRESS)
                          (STORE (TV STOP-ADDRESS) STOP-MASK))
                         (STORE (TV TV-ADDRESS) -16.)))))
       T)

(DEFINE OUTLINE NIL
        (AND :OUTLINE (LET ((OLD-DRAWMODE (DRAWMODE IOR)))
			 (TV-BOX TV-PICTURE-LEFT
				 TV-PICTURE-RIGHT
				 TV-PICTURE-BOTTOM
				 TV-PICTURE-TOP)
			 (DRAWMODE OLD-DRAWMODE)))
        NO-VALUE) 

(DECLARE (FIXNUM (TV-BOX FIXNUM FIXNUM FIXNUM FIXNUM))) 

(DEFUN TV-BOX (LEFT RIGHT BOTTOM TOP) 
       (SETQ LEFT (1- LEFT) RIGHT (1+ RIGHT))
       (HORIZONTAL-LINE LEFT (1- TOP) RIGHT)
       (HORIZONTAL-LINE LEFT (1+ BOTTOM) RIGHT)
       (VERTICAL-LINE LEFT TOP BOTTOM)
       (VERTICAL-LINE RIGHT TOP BOTTOM))

;;END OF BLACK-AND-WHITE CONDITIONAL SECTION.
] 


[COLOR 
;;;
;;These versions of horizontal and vertical line drawing procedures use the block
;;transfer mode feature of the 11logo TV system.  How much effeciency is gained by
;;doing so over repeated single writes of the memory, or use of directly writing the
;;mapped-in memory is not clear, especially in the case of horizontal lines.

(DECLARE (NOTYPE (VERTICAL-LINE FIXNUM FIXNUM)) (FIXNUM BIT-MASK BIT-X WORD-X)) 

(DEFUN VERTICAL-LINE (FROM-X FROM-Y TO-Y) 
       (LET ((WORD-X (LSH FROM-X -4.)) (BIT-X (BITWISE-AND FROM-X 15.)))
	    (LET ((BIT-MASK (ELEVEN-POINT-MASK BIT-X)))
		 (WRITE-TV-MASK (BITWISE-NOT BIT-MASK))
		 ;;Write into successive vertical words 1.  rotated to the right
		 ;;place.
		 (WRITE-TV-BLOCK (ELEVEN-TV-ADDRESS FROM-Y WORD-X)
				 BIT-MASK
				 (1+ (- TO-Y FROM-Y))
				 WORDS-PER-LINE)))) 

(DECLARE (NOTYPE (HORIZONTAL-LINE FIXNUM FIXNUM FIXNUM))
	 (FIXNUM START-WORD START-BIT STOP-WORD STOP-BIT START-MASK START-ADDRESS
		 WORD-COUNT STOP-MASK)) 

(DEFUN HORIZONTAL-LINE (FROM-X FROM-Y TO-X) 
       (LET ((START-WORD (LSH FROM-X -4.))
	     (START-BIT (BITWISE-AND FROM-X 15.))
	     (STOP-WORD (LSH TO-X -4.))
	     (STOP-BIT (BITWISE-AND TO-X 15.)))
	    (LET ((START-MASK (ELEVEN-FROM-MASK START-BIT))
		  (STOP-MASK (ELEVEN-TO-MASK STOP-BIT))
		  (WORD-COUNT (- STOP-WORD START-WORD))
		  (START-ADDRESS (ELEVEN-TV-ADDRESS FROM-Y START-WORD)))
		 (COND ((ZEROP WORD-COUNT)
			;;Entire line within one word.
			(WRITE-TV-MASK (BITWISE-OR START-MASK STOP-MASK))
			(WRITE-TV-WORD START-ADDRESS -1.))
		       ((WRITE-TV-MASK START-MASK)
			;;Write the first [partial] word.
			(WRITE-TV-WORD START-ADDRESS -1.)
			(WRITE-TV-MASK 0.)
			;;Block write all full words in between.
			(WRITE-TV-BLOCK (+ START-ADDRESS 2.) -1. (1- WORD-COUNT) 1.)
			(WRITE-TV-MASK STOP-MASK)
			;;Finish the last partial word.
			(WRITE-TV-WORD (+ START-ADDRESS (LSH WORD-COUNT 1.))
				       -1.)))))) 

(DECLARE (NOTYPE (STORE-TV-FIELD FIXNUM FIXNUM FIXNUM FIXNUM))) 

(DEFUN STORE-TV-FIELD (TV-ADDRESS WORD-DATA START-BIT STOP-BIT) 
       (COND ((< START-BIT 16.)
	      ;;WRITE THE LOW ORDER WORD.
	      (LET ((START-MASK (ELEVEN-FROM-MASK START-BIT)))
		   ;;CREATE MASK WITH ZEROS IN AREA TO BE SET.
		   (COND ((< STOP-BIT 16.)
			  ;;IF FIELD STOPS BEFORE END OF FIRST WORD.
			  (SETQ START-MASK
				(BITWISE-OR START-MASK (ELEVEN-TO-MASK STOP-BIT)))))
		   (WRITE-TV-MASK START-MASK)
		   ;;INHIBIT HIGH ORDER WORD.
		   (STORE (TV TV-ADDRESS) (BITWISE-OR WORD-DATA 4.)))))
       (COND ((> STOP-BIT 15.)
	      ;;WRITE HIGH ORDER WORD.
	      (LET ((STOP-MASK (ELEVEN-TO-MASK (- STOP-BIT 16.))))
		   (COND ((> START-BIT 15.)
			  (SETQ STOP-MASK
				(BITWISE-OR STOP-MASK 
                                            (ELEVEN-FROM-MASK (- START-BIT 16.))))))
		   (WRITE-TV-MASK STOP-MASK)
		   ;;INHIBIT LOWER ORDER WORD.
		   (STORE (TV TV-ADDRESS) (BITWISE-OR WORD-DATA 8.)))))
       T) 


(DEFINE OUTLINE NIL 
        (AND :OUTLINE 
             (TV-BOX TV-PICTURE-LEFT TV-PICTURE-RIGHT TV-PICTURE-BOTTOM TV-PICTURE-TOP))
        NO-VALUE) 

(DECLARE (FIXNUM (TV-BOX FIXNUM FIXNUM FIXNUM FIXNUM))) 

(DEFUN TV-BOX (LEFT RIGHT BOTTOM TOP) 
       (SETQ LEFT (1- LEFT) RIGHT (1+ RIGHT))
       (HORIZONTAL-LINE LEFT (1- TOP) RIGHT)
       (HORIZONTAL-LINE LEFT (- TOP 2.) RIGHT)
       ;;HORIZONTAL LINES LOOK LOTS BETTER IF THERE ARE TWO OF THEM BECAUSE OF
       ;;INTERLACE.
       (HORIZONTAL-LINE LEFT (+ BOTTOM 2.) RIGHT)
       (HORIZONTAL-LINE LEFT (1+ BOTTOM) RIGHT)
       (VERTICAL-LINE LEFT TOP BOTTOM)
       (VERTICAL-LINE RIGHT TOP BOTTOM)) 

;;END OF COLOR CONDITIONAL SECTION.
]



;;*PAGE
;;;
(COMMENT Vector drawing within display area)
;;;

(DECLARE (NOTYPE (BOUNDED-VECTOR FLONUM FLONUM FLONUM FLONUM))
	 (FLONUM CHANGE-X CHANGE-Y STEP-X STEP-Y TAN-HEADING SIGN-X$ SIGN-Y$
		 STANDARD-STEP-X STANDARD-STEP-Y)
	 (FIXNUM SIGN-X SIGN-Y TRAVEL-X TRAVEL-Y STOP-X STOP-Y)) 

(DECLARE (NOTYPE (BOUNDED-TURTLE-VECTOR FLONUM FLONUM FLONUM FLONUM)
                 (WRAP-TURTLE-VECTOR FLONUM FLONUM FLONUM FLONUM)
                 (CLIP-TURTLE-VECTOR FLONUM FLONUM FLONUM FLONUM)))


 
;;To minimize floating point computation in the inner loop of vector
;;drawing, normally floating point coordinates are converted to fixed point
;;numbers shifted so that they have a fixed size fractional part.

(DECLARE (FIXNUM (FIXIFY FLONUM) (TV-FIX-X FLONUM) (TV-FIX-Y FLONUM)))

;;Converts from float to fixed.

(DEFUN FIXIFY (FLONUM) (ROUND (*$ FLONUM FLOAT-UNIT)))

(DEFUN TV-FIX-X (TURTLE-X)
       ;;Turtle coordiates in fixed point. See code for TV-X, TV-Y.
       (FIXIFY (+$ (+$ (//$ TURTLE-X :TVSTEP) FLOAT-TV-SHIFT-X) FLOAT-TV-PICTURE-LEFT)))

(DEFUN TV-FIX-Y (TURTLE-Y)
       (FIXIFY (-$ FLOAT-TV-PICTURE-BOTTOM 
                   (+$ (//$ TURTLE-Y :TVSTEP) FLOAT-TV-SHIFT-Y))))


(DECLARE (NOTYPE (BOUNDED-VECTOR FLONUM FLONUM FLONUM FLONUM) 
                 (TVECTOR FIXNUM FIXNUM FIXNUM FIXNUM)))

(DEFUN BOUNDED-VECTOR (FROM-X FROM-Y TO-X TO-Y)
       ;;Floating point coordinates, i.e. turtle coordinates.
       (BOUNDED-VECTOR-FIX (TV-FIX-X FROM-X) 
                           (TV-FIX-Y FROM-Y) 
                           (TV-FIX-X TO-X) 
                           (TV-FIX-Y TO-Y)))

(DEFUN TVECTOR (FROM-X FROM-Y TO-X TO-Y)
       ;;Arguments in fixed point TV coordinates instead.
       (BOUNDED-VECTOR-FIX (LSH FROM-X FIX-BITS) 
                           (LSH FROM-Y FIX-BITS)
                           (LSH TO-X FIX-BITS)
                           (LSH TO-Y FIX-BITS)))

(DECLARE (NOTYPE (BOUNDED-VECTOR-FIX FIXNUM FIXNUM FIXNUM FIXNUM))
         (FIXNUM CHANGE-X-FIX CHANGE-Y-FIX ABS-CHANGE-X ABS-CHANGE-Y
                 FROM-X-FRAC FROM-Y-FRAC))

(DECLARE (NOTYPE (NEARLY-HORIZONTAL-VECTOR FIXNUM FIXNUM FIXNUM FIXNUM FLONUM FIXNUM)
                 (NEARLY-VERTICAL-VECTOR FIXNUM FIXNUM FIXNUM FIXNUM FLONUM FIXNUM)))


(DEFUN BOUNDED-VECTOR-FIX (FROM-X-FIX FROM-Y-FIX TO-X-FIX TO-Y-FIX)
       ;;Takes arguments as shifted fixed point numbers.
 (LET ((CHANGE-X-FIX (- TO-X-FIX FROM-X-FIX)) (CHANGE-Y-FIX (- TO-Y-FIX FROM-Y-FIX)))
      (LET ((ABS-CHANGE-X (ABS CHANGE-X-FIX)) (ABS-CHANGE-Y (ABS CHANGE-Y-FIX)))
           (COND ((> ABS-CHANGE-X ABS-CHANGE-Y)
                  ;;Split up cases according to whether greatest change is in
                  ;;X or Y direction. If in X, we step along Y values, drawing
                  ;;a horizontal line for each Y value.
                  (COND ((> FROM-X-FIX TO-X-FIX) 
                         ;;Exchange points to assure positive step along X. This
                         ;;means vector is drawn in same order regardless of which
                         ;;endpoint is the starting point. This aspect of it is
                         ;;mildly undesirable when system slow, may fix eventually.
                         (SETQ FROM-X-FIX (PROG1 TO-X-FIX (SETQ TO-X-FIX FROM-X-FIX))
                               FROM-Y-FIX (PROG1 TO-Y-FIX (SETQ TO-Y-FIX FROM-Y-FIX))
                               CHANGE-X-FIX (- CHANGE-X-FIX)
                               CHANGE-Y-FIX (- CHANGE-Y-FIX))))
                  (COND ((= (BITWISE-ANDC UNIT-MASK FROM-Y-FIX)
                            (BITWISE-ANDC UNIT-MASK TO-Y-FIX))
                         ;;If Y coordinates are same for both start & end point,
                         ;;The vector can be approximated as a horizontal line.
                         (EXPR-CALL HORIZONTAL (LSH FROM-X-FIX MINUS-FIX-BITS)
                                               (LSH FROM-Y-FIX MINUS-FIX-BITS)
                                               (LSH TO-X-FIX MINUS-FIX-BITS)))
                        ;;Otherwise off to general line drawer.
                        ((NEARLY-HORIZONTAL-VECTOR
                          FROM-X-FIX FROM-Y-FIX TO-X-FIX TO-Y-FIX
                          (//$ (FLOAT ABS-CHANGE-X) (FLOAT ABS-CHANGE-Y))
                          (COND ((MINUSP CHANGE-Y-FIX) -1.) (1.))))))
                 (T 
                  ;;Y case is similar....
                  (COND ((> FROM-Y-FIX TO-Y-FIX)
                         (SETQ FROM-Y-FIX (PROG1 TO-Y-FIX (SETQ TO-Y-FIX FROM-Y-FIX))
                               FROM-X-FIX (PROG1 TO-X-FIX (SETQ TO-X-FIX FROM-X-FIX))
                               CHANGE-X-FIX (- CHANGE-X-FIX)
                               CHANGE-Y-FIX (- CHANGE-Y-FIX))))
                  (COND ((= (BITWISE-ANDC UNIT-MASK FROM-X-FIX) 
                            (BITWISE-ANDC UNIT-MASK TO-X-FIX))
                         (EXPR-CALL VERTICAL (LSH FROM-X-FIX MINUS-FIX-BITS)
                                             (LSH FROM-Y-FIX MINUS-FIX-BITS)
                                             (LSH TO-Y-FIX MINUS-FIX-BITS)))
                        ((NEARLY-VERTICAL-VECTOR
                          FROM-X-FIX FROM-Y-FIX TO-X-FIX TO-Y-FIX
                          (//$ (FLOAT ABS-CHANGE-Y) (FLOAT ABS-CHANGE-X)) 
                          (COND ((MINUSP CHANGE-X-FIX) -1.) (1.))))))))))

(DEFUN NEARLY-HORIZONTAL-VECTOR (FROM-X-FIX FROM-Y-FIX TO-X-FIX TO-Y-FIX SLOPE SIGN-Y)
       ;;Vectors which are approximately horizontal [X change exceeds Y change].
       (LET ((FROM-X (LSH FROM-X-FIX MINUS-FIX-BITS))
             (FROM-Y (LSH FROM-Y-FIX MINUS-FIX-BITS))
             (TO-X (LSH TO-X-FIX MINUS-FIX-BITS))
             (TO-Y (LSH TO-Y-FIX MINUS-FIX-BITS))
             (FROM-Y-FRAC (BITWISE-AND UNIT-MASK FROM-Y-FIX)))
            ;;These four variables are TV coordinates of the endpoints.
            (LET ((PARTIAL-STEP
                   (FIXIFY (*$ SLOPE 
                               (//$ (FLOAT (COND ((MINUSP SIGN-Y) FROM-Y-FRAC)
                                                 ((- UNIT-BIT FROM-Y-FRAC))))
                                    FLOAT-UNIT)))))
                 ;;First and last steps computed separately, since involve
                 ;;fractional Y stepping.
                 (LET ((NEW-FROM-X (LSH (INCREMENT FROM-X-FIX PARTIAL-STEP)
                                        MINUS-FIX-BITS)))
                      ;;Don't go beyond bound of vector.
                      (COND ((> NEW-FROM-X TO-X) (SETQ NEW-FROM-X TO-X)))
                      ;;Draw the horizontal line.
                      (EXPR-CALL HORIZONTAL FROM-X FROM-Y NEW-FROM-X)
                      (SETQ FROM-X NEW-FROM-X)))
            (DO ((TRAVEL-Y (+ FROM-Y SIGN-Y) (+ TRAVEL-Y SIGN-Y)) 
                 (SLOPE-FIX (FIXIFY SLOPE))
                 (NEW-FROM-X))
                ;;Loop for successive additions of 1 Y step. When finished,
                ;;draw line to TO-X.
                ((= TRAVEL-Y TO-Y) (EXPR-CALL HORIZONTAL FROM-X TRAVEL-Y TO-X))
                (COND ((> (SETQ NEW-FROM-X (LSH (INCREMENT FROM-X-FIX SLOPE-FIX)
                                                MINUS-FIX-BITS))
                          TO-X)
                       (SETQ NEW-FROM-X TO-X)))
                (EXPR-CALL HORIZONTAL FROM-X TRAVEL-Y NEW-FROM-X)
                (SETQ FROM-X NEW-FROM-X))))

(DEFUN NEARLY-VERTICAL-VECTOR (FROM-X-FIX FROM-Y-FIX TO-X-FIX TO-Y-FIX SLOPE SIGN-X)
       ;;...As for NEARLY-HORIZONTAL-VECTOR.
       (LET ((FROM-X (LSH FROM-X-FIX MINUS-FIX-BITS))
             (FROM-Y (LSH FROM-Y-FIX MINUS-FIX-BITS))
             (TO-X (LSH TO-X-FIX MINUS-FIX-BITS))
             (TO-Y (LSH TO-Y-FIX MINUS-FIX-BITS))
             (FROM-X-FRAC (BITWISE-AND UNIT-MASK FROM-X-FIX)))
            (LET ((PARTIAL-STEP
                   (FIXIFY (*$ SLOPE 
                               (//$ (FLOAT (COND ((MINUSP SIGN-X) FROM-X-FRAC)
                                                 ((- UNIT-BIT FROM-X-FRAC))))
                                    FLOAT-UNIT)))))
                 (LET ((NEW-FROM-Y 
                        (LSH (INCREMENT FROM-Y-FIX PARTIAL-STEP) MINUS-FIX-BITS)))
                      (COND ((> NEW-FROM-Y TO-Y) (SETQ NEW-FROM-Y TO-Y)))
                      (EXPR-CALL VERTICAL FROM-X FROM-Y NEW-FROM-Y)
                      (SETQ FROM-Y NEW-FROM-Y)))
            (DO ((TRAVEL-X (+ FROM-X SIGN-X) (+ TRAVEL-X SIGN-X)) 
                 (SLOPE-FIX (FIXIFY SLOPE))
                 (NEW-FROM-Y))
                ((= TRAVEL-X TO-X) (EXPR-CALL VERTICAL TRAVEL-X FROM-Y TO-Y))
                (COND ((> (SETQ NEW-FROM-Y 
                                (LSH (INCREMENT FROM-Y-FIX SLOPE-FIX) MINUS-FIX-BITS))
                          TO-Y)
                       (SETQ NEW-FROM-Y TO-Y)))
                (EXPR-CALL VERTICAL TRAVEL-X FROM-Y NEW-FROM-Y)
                (SETQ FROM-Y NEW-FROM-Y))))


(DECLARE (NOTYPE OUT-OF-BOUNDS-CHECK FLONUM FLONUM))

(DEFUN OUT-OF-BOUNDS-CHECK (NEW-X$ NEW-Y$)
	 (COND
	  ((> (-$ NEW-X$ TURTLE-PICTURE-RIGHT) FLOATING-POINT-TOLERANCE)
	   (ERRBREAK
             'SETXY$
             '"TURTLE MOVED OFF THE RIGHT SIDE OF THE SCREEN")
           T)
	  ((> (-$ TURTLE-PICTURE-LEFT NEW-X$) FLOATING-POINT-TOLERANCE)
	    (ERRBREAK
	     'SETXY$
	     '"TURTLE MOVED OFF THE LEFT SIDE OF THE SCREEN")
            T)
	  ((> (-$ NEW-Y$ TURTLE-PICTURE-TOP) FLOATING-POINT-TOLERANCE)
	    (ERRBREAK
	     'SETXY$
	     '"TURTLE MOVED OFF THE TOP OF THE SCREEN")
            T)
	  ((> (-$ TURTLE-PICTURE-BOTTOM NEW-Y$) FLOATING-POINT-TOLERANCE)
	    (ERRBREAK
	     'SETXY$
	     '"TURTLE MOVED OFF THE BOTTOM OF THE SCREEN")
            T)))

(DEFUN BOUNDED-TURTLE-VECTOR (FROM-X FROM-Y TO-X TO-Y)
       ;;Called to draw a vector with turtle in NOWRAP, NOCLIP mode.
       (COND ((OUT-OF-BOUNDS-CHECK TO-X TO-Y))
             ;;If turtle tries to move out of bounds, error. Else erase turtle cursor
             ;;at old position, draw vector if necessary, show turtle.
             (T (ERASE-TURTLES) 
                (AND :DRAWSTATE (BOUNDED-VECTOR FROM-X FROM-Y TO-X TO-Y))
                (SETQ :XCOR TO-X :YCOR TO-Y)
                (DRAW-TURTLES))))

;;*PAGE

(COMMENT Wrap mode)

(DECLARE (FIXNUM (SCREEN-X FLONUM) (SCREEN-Y FLONUM) (FIXIFY-SCREEN-FRACTION-X FLONUM)
                 (FIXIFY-SCREEN-FRACTION-Y FLONUM) (FIXIFY FLONUM))
         (FLONUM (SCREEN-FRACTION-X FIXNUM FLONUM) (SCREEN-FRACTION-Y FIXNUM FLONUM)))

;;Following functions divide a floating point coordinate position into a
;;"screen" [integer multiple of screen size] and fraction of screen from the left
;;or bottom edge.

(DEFUN SCREEN-X (WRAP-X)
       ;;Translate to left edge, divide by picture area size in turtle coordinates.
       (FIX (//$ (-$ WRAP-X TURTLE-PICTURE-LEFT) TURTLE-PICTURE-SIZE-X)))

(DEFUN SCREEN-Y (WRAP-Y)
       (FIX (//$ (-$ WRAP-Y TURTLE-PICTURE-BOTTOM) TURTLE-PICTURE-SIZE-Y)))

(DEFUN SCREEN-FRACTION-X (SCREEN-X WRAP-X)
       ;;Arguments are screen, produced by SCREEN-X, and full wrap coordinate.
       (//$ (-$ (-$ WRAP-X TURTLE-PICTURE-LEFT) 
                (*$ (FLOAT SCREEN-X) TURTLE-PICTURE-SIZE-X))
            TURTLE-PICTURE-SIZE-X))

(DEFUN SCREEN-FRACTION-Y (SCREEN-Y WRAP-Y)
       (//$ (-$ (-$ WRAP-Y TURTLE-PICTURE-BOTTOM) 
                (*$ (FLOAT SCREEN-Y) TURTLE-PICTURE-SIZE-Y))
            TURTLE-PICTURE-SIZE-Y))

;;These take screen fraction, and convert into shifted fixnum TV coordinate suitable
;;for use by BOUNDED-VECTOR-FIX.

(DEFUN FIXIFY-SCREEN-FRACTION-X (SCREEN-FRACTION-X)
       (+ TV-PICTURE-LEFT-FIX (FIXIFY (*$ SCREEN-FRACTION-X FLOAT-TV-PICTURE-SIZE-X))))

(DEFUN FIXIFY-SCREEN-FRACTION-Y (SCREEN-FRACTION-Y)
       (- TV-PICTURE-BOTTOM-FIX (FIXIFY (*$ SCREEN-FRACTION-Y FLOAT-TV-PICTURE-SIZE-Y))))

;;*PAGE


(DECLARE (NOTYPE (WRAP-VECTOR FLONUM FLONUM FLONUM FLONUM)
                 (WRAP-SCREEN-VECTOR FIXNUM FLONUM FIXNUM FLONUM 
                                     FIXNUM FLONUM FIXNUM FLONUM)
                 (BOUNDED-VECTOR-FIX FIXNUM FIXNUM FIXNUM FIXNUM)
                 (BOUNDED-VECTOR-FIX-ROUND FIXNUM FIXNUM FIXNUM FIXNUM))
         (FIXNUM FROM-SCREEN-X FROM-SCREEN-Y TO-SCREEN-X TO-SCREEN-Y SIGN-Y
                 EDGE-SCREEN-X EDGE-SCREEN-Y FIX-EDGE-FRACTION)
         (FLONUM FROM-FRACTION-X FROM-FRACTION-Y TO-FRACTION-X TO-FRACTION-Y
                 EDGE-FRACTION-X EDGE-FRACTION-Y CHANGE-X CHANGE-Y FROM-EDGE-FRACTION
                 TO-EDGE-FRACTION TO-EDGE-X TO-EDGE-Y))

(DEFUN WRAP-VECTOR (FROM-X FROM-Y TO-X TO-Y)
       ;;Draws vector allowing wraparound. Argument in turtle coordnates.
       (LET ((FROM-SCREEN-X (SCREEN-X FROM-X))
	     (FROM-SCREEN-Y (SCREEN-Y FROM-Y))
	     (TO-SCREEN-X (SCREEN-X TO-X))
	     (TO-SCREEN-Y (SCREEN-Y TO-Y)))
	    (LET ((FROM-FRACTION-X (SCREEN-FRACTION-X FROM-SCREEN-X FROM-X))
		  (FROM-FRACTION-Y (SCREEN-FRACTION-Y FROM-SCREEN-Y FROM-Y))
		  (TO-FRACTION-X (SCREEN-FRACTION-X TO-SCREEN-X TO-X))
		  (TO-FRACTION-Y (SCREEN-FRACTION-Y TO-SCREEN-Y TO-Y)))
                 ;;Split up into screens and fractions of screens, then hand off
                 ;;to WRAP-SCREEN-VECTOR.
		 (WRAP-SCREEN-VECTOR FROM-SCREEN-X FROM-FRACTION-X
				     FROM-SCREEN-Y FROM-FRACTION-Y
				     TO-SCREEN-X TO-FRACTION-X
				     TO-SCREEN-Y TO-FRACTION-Y))))

(DEFUN WRAP-SCREEN-VECTOR
       (FROM-SCREEN-X FROM-FRACTION-X FROM-SCREEN-Y FROM-FRACTION-Y
        TO-SCREEN-X TO-FRACTION-X TO-SCREEN-Y TO-FRACTION-Y)
       (COND ((NOT (= FROM-SCREEN-X TO-SCREEN-X))
              ;;Vector crosses an X screen edge.
              (LET ((CHANGE-X (+$ (FLOAT (- TO-SCREEN-X FROM-SCREEN-X)) 
                                  (-$ TO-FRACTION-X FROM-FRACTION-X)))
                    (CHANGE-Y (+$ (FLOAT (- TO-SCREEN-Y FROM-SCREEN-Y))
                                  (-$ TO-FRACTION-Y FROM-FRACTION-Y))))
                   ;;[This can be done more efficiently.]
                   (LET ((TO-EDGE-X (-$ FROM-FRACTION-X))
                         (FROM-EDGE-FRACTION 0.0)
                         (TO-EDGE-FRACTION 1.0)
                         (SIGN-X -1.))
                        (AND (PLUSP CHANGE-X)
                             (SETQ SIGN-X 1.
                                   TO-EDGE-X (-$ 1.0 FROM-FRACTION-X)
                                   FROM-EDGE-FRACTION 1.0
                                   TO-EDGE-FRACTION 0.0))
                        ;;Compute X and Y coordinates to split the vector
                        ;;at the X edge.
                        (LET ((EDGE-FRACTION-Y 
                               (+$ FROM-FRACTION-Y 
                                   (*$ TO-EDGE-X (//$ CHANGE-Y CHANGE-X))))
                              (EDGE-SCREEN-Y FROM-SCREEN-Y))
                             (LET ((FIX-EDGE-FRACTION (FIX EDGE-FRACTION-Y)))
                                  (INCREMENT EDGE-SCREEN-Y FIX-EDGE-FRACTION)
                                  (SETQ EDGE-FRACTION-Y 
                                        (-$ EDGE-FRACTION-Y (FLOAT FIX-EDGE-FRACTION)))
                                  (WRAP-SCREEN-VECTOR FROM-SCREEN-X FROM-FRACTION-X 
                                                      FROM-SCREEN-Y FROM-FRACTION-Y
                                                      FROM-SCREEN-X FROM-EDGE-FRACTION
                                                      EDGE-SCREEN-Y EDGE-FRACTION-Y)
                                  ;;Draw a vector on this screen from FROM point to the 
                                  ;;edge, then continue from the edge to TO point.
                                  (WRAP-SCREEN-VECTOR (+ FROM-SCREEN-X SIGN-X) 
                                                      TO-EDGE-FRACTION 
                                                      EDGE-SCREEN-Y EDGE-FRACTION-Y 
                                                      TO-SCREEN-X TO-FRACTION-X 
                                                      TO-SCREEN-Y TO-FRACTION-Y))))))
             ((NOT (= FROM-SCREEN-Y TO-SCREEN-Y))
              (LET ((CHANGE-X (+$ (FLOAT (- TO-SCREEN-X FROM-SCREEN-X)) 
                                  (-$ TO-FRACTION-X FROM-FRACTION-X)))
                    (CHANGE-Y (+$ (FLOAT (- TO-SCREEN-Y FROM-SCREEN-Y))
                                  (-$ TO-FRACTION-Y FROM-FRACTION-Y))))
                   (LET ((TO-EDGE-Y (-$ FROM-FRACTION-Y))
                         (FROM-EDGE-FRACTION 0.0)
                         (TO-EDGE-FRACTION 1.0)
                         (SIGN-Y -1.))
                        (AND (PLUSP CHANGE-Y)
                             (SETQ SIGN-Y 1.
                                   TO-EDGE-Y (-$ 1.0 FROM-FRACTION-Y)
                                   FROM-EDGE-FRACTION 1.0
                                   TO-EDGE-FRACTION 0.0))
                        (LET ((EDGE-FRACTION-X
                               (+$ FROM-FRACTION-X
                                   (*$ TO-EDGE-Y (//$ CHANGE-X CHANGE-Y))))
                              (EDGE-SCREEN-X FROM-SCREEN-X))
                             (LET ((FIX-EDGE-FRACTION (FIX EDGE-FRACTION-X)))
                                  (INCREMENT EDGE-SCREEN-X FIX-EDGE-FRACTION)
                                  (SETQ EDGE-FRACTION-X 
                                        (-$ EDGE-FRACTION-X (FLOAT FIX-EDGE-FRACTION)))
                                  (WRAP-SCREEN-VECTOR FROM-SCREEN-X FROM-FRACTION-X 
                                                      FROM-SCREEN-Y FROM-FRACTION-Y
                                                      EDGE-SCREEN-X EDGE-FRACTION-X
                                                      FROM-SCREEN-Y FROM-EDGE-FRACTION)
                                  (WRAP-SCREEN-VECTOR EDGE-SCREEN-X EDGE-FRACTION-X
                                                      (+ FROM-SCREEN-Y SIGN-Y) 
                                                      TO-EDGE-FRACTION
                                                      TO-SCREEN-X TO-FRACTION-X 
                                                      TO-SCREEN-Y TO-FRACTION-Y))))))
             ((BOUNDED-VECTOR-FIX-ROUND (FIXIFY-SCREEN-FRACTION-X FROM-FRACTION-X)
                                        (FIXIFY-SCREEN-FRACTION-Y FROM-FRACTION-Y)
                                        (FIXIFY-SCREEN-FRACTION-X TO-FRACTION-X)
                                        (FIXIFY-SCREEN-FRACTION-Y TO-FRACTION-Y)))))

(DEFUN BOUNDED-VECTOR-FIX-ROUND (FROM-X-FIX FROM-Y-FIX TO-X-FIX TO-Y-FIX)
       ;;Increment coordinates by 1/2 so that truncation will round.
       (BOUNDED-VECTOR-FIX (+ FROM-X-FIX HALF-UNIT)
                           (+ FROM-Y-FIX HALF-UNIT)
                           (+ TO-X-FIX HALF-UNIT)
                           (+ TO-Y-FIX HALF-UNIT)))

(DEFUN WRAP-TURTLE-VECTOR (FROM-X FROM-Y TO-X TO-Y)
       (ERASE-TURTLES)
       (AND :DRAWSTATE (WRAP-VECTOR FROM-X FROM-Y TO-X TO-Y))
       (SETQ :XCOR TO-X :YCOR TO-Y)
       (DRAW-TURTLES))


(DECLARE (FIXNUM (CLIP-VISIBILITY FLONUM FLONUM)))

(DEFUN NOWRAP-NOCLIP-HERE NIL
       ;;Smashes down turtle location to fit within the boundaries of the
       ;;display area. Used in leaving WRAP and CLIP modes where HERE may
       ;;exceed legal screen boundaries.
       (ERASE-TURTLE)
       ;;Changing turtle coordinates may result in slightly moving the turtle.
       (AND (PLUSP (CLIP-VISIBILITY :XCOR :YCOR))
            (SETQ :XCOR (TURTLE-X (TV-X :XCOR)) :YCOR (TURTLE-Y (TV-Y :YCOR))))
       (DRAW-TURTLE))

(DEFINE WRAP NIL (SETQ :WRAP T :CLIP NIL) NO-VALUE) 

(DEFINE NOWRAP NIL (NOWRAP-NOCLIP-HERE) (SETQ :WRAP NIL) NO-VALUE)


;;*PAGE

;;;
(COMMENT Clip mode)
;;;
 
;;;In clip mode, display past boundaries of the screen is simply ignored.

(DECLARE (FIXNUM (CLIP-VISIBILITY FLONUM FLONUM) VISIBILITY FROM-VISIBILITY 
                 TO-VISIBILITY)
         (NOTYPE (CLIP-VECTOR FLONUM FLONUM FLONUM FLONUM)
                 (CLIP-VECTOR-VISIBILITY FLONUM FLONUM FLONUM FLONUM FIXNUM FIXNUM)
                 (CLIP-TURTLE-VECTOR FLONUM FLONUM FLONUM FLONUM)))

(DEFUN CLIP-VISIBILITY (POINT-X POINT-Y)
       (LET ((VISIBILITY 0.))
            (COND ((< POINT-X TURTLE-PICTURE-LEFT) (INCREMENT VISIBILITY 1.))
                  ((> POINT-X TURTLE-PICTURE-RIGHT) (INCREMENT VISIBILITY 2.)))
            (COND ((< POINT-Y TURTLE-PICTURE-BOTTOM) (+ VISIBILITY 4.))
                  ((> POINT-Y TURTLE-PICTURE-TOP) (+ VISIBILITY 8.))
                  (VISIBILITY))))

(DEFUN CLIP-VECTOR (FROM-X FROM-Y TO-X TO-Y)
       (CLIP-VECTOR-VISIBILITY FROM-X FROM-Y TO-X TO-Y 
                               (CLIP-VISIBILITY FROM-X FROM-Y)
                               (CLIP-VISIBILITY TO-X TO-Y)))

(DEFUN CLIP-VECTOR-VISIBILITY (FROM-X FROM-Y TO-X TO-Y FROM-VISIBILITY TO-VISIBILITY)
       (DO NIL
           ((AND (ZEROP FROM-VISIBILITY) (ZEROP TO-VISIBILITY))
            ;;Both points visible, draw line.
            (BOUNDED-VECTOR FROM-X FROM-Y TO-X TO-Y))
           (COND ((ZEROP (BITWISE-AND FROM-VISIBILITY TO-VISIBILITY)))
                 ;;Both points beyond visible bounds, reject entire line.
                 ((RETURN T)))
           (COND ((ZEROP FROM-VISIBILITY)
                  ;;Exchange points so that TO point is visible.
                  (SETQ FROM-X (PROG1 TO-X (SETQ TO-X FROM-X))
                        FROM-Y (PROG1 TO-Y (SETQ TO-Y FROM-Y))
                        FROM-VISIBILITY (PROG1 TO-VISIBILITY 
                                               (SETQ TO-VISIBILITY FROM-VISIBILITY)))))
           (COND ((ZEROP (BITWISE-AND FROM-VISIBILITY 1.)))
                 ;;Push toward left edge.
                 ((SETQ FROM-Y (+$ FROM-Y
                                   (*$ (//$ (-$ TO-Y FROM-Y) (-$ TO-X FROM-X))
                                       (-$ TURTLE-PICTURE-LEFT FROM-X)))
                        FROM-X TURTLE-PICTURE-LEFT)))
           (COND ((ZEROP (BITWISE-AND FROM-VISIBILITY 2.)))
                 ;;Push toward right edge.
                 ((SETQ FROM-Y (+$ FROM-Y
                                   (*$ (//$ (-$ TO-Y FROM-Y) (-$ TO-X FROM-X))
                                       (-$ TURTLE-PICTURE-RIGHT FROM-X)))
                        FROM-X TURTLE-PICTURE-RIGHT)))
           (COND ((ZEROP (BITWISE-AND FROM-VISIBILITY 4.)))
                 ;;Push toward top.
                 ((SETQ FROM-X (+$ FROM-X
                                   (*$ (//$ (-$ TO-X FROM-X) (-$ TO-Y FROM-Y))
                                       (-$ TURTLE-PICTURE-BOTTOM FROM-Y)))
                        FROM-Y TURTLE-PICTURE-BOTTOM)))
           (COND ((ZEROP (BITWISE-AND FROM-VISIBILITY 8.)))
                 ;;Push toward bottom.
                 ((SETQ FROM-X (+$ FROM-X
                                   (*$ (//$ (-$ TO-X FROM-X) (-$ TO-Y FROM-Y))
                                       (-$ TURTLE-PICTURE-TOP FROM-Y)))
                        FROM-Y TURTLE-PICTURE-TOP)))
           (SETQ FROM-VISIBILITY (CLIP-VISIBILITY FROM-X FROM-Y))))

(DEFUN CLIP-TURTLE-VECTOR (FROM-X FROM-Y TO-X TO-Y)
       (ERASE-TURTLES)
       (AND :DRAWSTATE (CLIP-VECTOR FROM-X FROM-Y TO-X TO-Y))
       (SETQ :XCOR TO-X :YCOR TO-Y)
       (DRAW-TURTLES))


(DEFINE CLIP NIL (SETQ :CLIP T :WRAP NIL) NO-VALUE)

(DEFINE NOCLIP NIL (NOWRAP-NOCLIP-HERE) (SETQ :CLIP NIL) NO-VALUE)
           
;;*PAGE

;;;

(COMMENT TRIANGLE TURTLE CURSOR) 

;;;
;;;
;;;
;;THE TURTLE IS DRAWN IN "XOR" MODE -- THAT IS, TRIANGLE TURTLE LINES ARE XORED IN
;;WITH PICTURE.  THIS ALLOWS ONE PROCEDURE TO CAUSE TURTLE TO APPEAR AND DISAPPEAR,
;;WITHOUT DISRUPTING PICTURE.  THE TURTLE IS THEREFORE ALWAYS VISIBLE EVEN ON
;;FILLED-IN OR SHADED BACKGROUND.  THE PEN, ERASER, AND XOR MARKERS ARE WINDOWS
;;WHICH ARE XORED IN WHEN NEEDED.

(DECLARE (SPECIAL PEN-WINDOW ERASER-WINDOW XOR-WINDOW PEN-INFO)) 

(FILLARRAY (SET (ARRAY PEN-WINDOW FIXNUM 7.) (GET 'PEN-WINDOW 'ARRAY))
	   '(-536870912. -536870912. -536870912. -536870912. -536870912. -536870912. 
             -536870912.)) 

(FILLARRAY (SET (ARRAY ERASER-WINDOW FIXNUM 7.) (GET 'ERASER-WINDOW 'ARRAY))
	   '(-536870912. -33822867456. -33822867456. -33822867456. -33822867456. 
             -33822867456. -536870912.)) 

(FILLARRAY (SET (ARRAY XOR-WINDOW FIXNUM 7.) (GET 'XOR-WINDOW 'ARRAY))
	   '(-16642998272. 27380416512. 16106127360. 6442450944. 16106127360. 
             27380416512. -16642998272. )) 

(FILLARRAY (SET (ARRAY PEN-INFO FIXNUM 8.) (GET 'PEN-INFO 'ARRAY))
           '(1. 7. 288. 151. -3. 3. -3. 3.))

(DECLARE (SPECIAL :DRAWTURTLE :ERASETURTLE)) 

;;THESE VARIABLES ALLOW USER TO SUBSTITUTE PROCEDURES FOR DRAWING AND ERASING THE
;;TURTLE MARKER.  NIL MEANS USE STANDARD SYSTEM ONES.

(DEFINE TRIANGLETURTLE NIL
        (LET ([BW (OLD-DRAWMODE (DRAWMODE XOR))])
             (STANDARD-TRIANGLE)
             (STANDARD-PEN)
             [BW (DRAWMODE OLD-DRAWMODE)]))


(DEFUN DRAW-PEN NIL 
       (COND ((NOT :SEETURTLE))
             ((AND :CLIP (PLUSP (CLIP-VISIBILITY :XCOR :YCOR))))
             (:DRAWTURTLE (INVOKE-USER-DRAW-TURTLE))
	     ((LET ([BW (OLD-DRAWMODE (DRAWMODE XOR))])
                   [COLOR (SELECT-COLOR :PENNUMBER)]
		   (STANDARD-PEN)
                   [COLOR (RESELECT-COLOR)]
		   [BW (DRAWMODE OLD-DRAWMODE)])))) 

(DEFUN ERASE-PEN NIL 
       (COND ((NOT :SEETURTLE))
             ((AND :CLIP (PLUSP (CLIP-VISIBILITY :XCOR :YCOR))))
             (:ERASETURTLE (INVOKE-USER-ERASE-TURTLE))
	     ((LET ([BW (OLD-DRAWMODE (DRAWMODE XOR))])
                   [COLOR (SELECT-COLOR :ERASERNUMBER)]
		   (STANDARD-PEN)
                   [COLOR (RESELECT-COLOR)]
		   [BW (DRAWMODE OLD-DRAWMODE)])))) 

(DEFUN STANDARD-PEN NIL 
       (COND (:PENSTATE (TURTLE-WINDOW PEN-WINDOW))
	     (:ERASERSTATE (TURTLE-WINDOW ERASER-WINDOW))
	     (:XORSTATE (TURTLE-WINDOW XOR-WINDOW)))) 

(DECLARE (FIXNUM TV-XCOR TV-YCOR)
	 (NOTYPE (DISPLAYWINDOW-STORE NOTYPE NOTYPE FIXNUM FIXNUM FIXNUM FIXNUM))) 

(DEFUN TURTLE-WINDOW (MARKER-WINDOW) 
       (LET ((TV-XCOR (TV-X :XCOR)) (TV-YCOR (TV-Y :YCOR)))
	    (DISPLAYWINDOW-STORE PEN-INFO
                                 MARKER-WINDOW
				 (- TV-YCOR 3.)
				 (+ TV-YCOR 3.)
				 (- TV-XCOR 3.)
				 (+ TV-XCOR 3.)))) 

(DEFUN INVOKE-USER-DRAW-TURTLE NIL 
       (LET ((:XCOR :XCOR)
	     (:YCOR :YCOR)
	     (:HEADING :HEADING)
	     (SINE-HEADING SINE-HEADING)
	     (COSINE-HEADING COSINE-HEADING)
	     (:SEETURTLE NIL)
	     (:PENSTATE :PENSTATE)
	     (:ERASERSTATE :ERASERSTATE)
	     (:XORSTATE :XORSTATE)
             (:DRAWSTATE :DRAWSTATE))
	    (EVAL :DRAWTURTLE))
       ;;User function may screw up drawmode, color.
       [COLOR (RESELECT-COLOR)]
       [BW (DRAWMODE (COND (:ERASERSTATE ANDC) (:XORSTATE XOR) (IOR)))]) 

(DEFUN INVOKE-USER-ERASE-TURTLE NIL 
       (LET ((:XCOR :XCOR)
	     (:YCOR :YCOR)
	     (:HEADING :HEADING)
	     (SINE-HEADING SINE-HEADING)
	     (COSINE-HEADING COSINE-HEADING)
	     (:SEETURTLE NIL)
	     (:PENSTATE :PENSTATE)
	     (:ERASERSTATE :ERASERSTATE)
	     (:XORSTATE :XORSTATE)
             (:DRAWSTATE :DRAWSTATE))
	    (EVAL :ERASETURTLE))
       [COLOR (RESELECT-COLOR)]
       [BW (DRAWMODE (COND (:ERASERSTATE ANDC) (:XORSTATE XOR) (IOR)))]) 

(DEFUN DRAW-TRIANGLE NIL 
       (COND ((NOT :SEETURTLE))
             ((AND :CLIP (PLUSP (CLIP-VISIBILITY :XCOR :YCOR))))
             (:DRAWTURTLE (INVOKE-USER-DRAW-TURTLE))
	     ((LET ([BW (OLD-DRAWMODE (DRAWMODE XOR))])
                   [COLOR (SELECT-COLOR :PENNUMBER)]
		   (STANDARD-TRIANGLE)
                   [COLOR (RESELECT-COLOR)]
		   [BW (DRAWMODE OLD-DRAWMODE)])))) 

(DEFUN ERASE-TRIANGLE NIL 
       (COND ((NOT :SEETURTLE))
             ((AND :CLIP (PLUSP (CLIP-VISIBILITY :XCOR :YCOR))))
             (:ERASETURTLE (INVOKE-USER-ERASE-TURTLE))
	     ((LET ([BW (OLD-DRAWMODE (DRAWMODE XOR))])
                   [COLOR (SELECT-COLOR :ERASERNUMBER)]
		   (STANDARD-TRIANGLE)
                   [COLOR (RESELECT-COLOR)]
		   [BW (DRAWMODE OLD-DRAWMODE)])))) 

(DEFUN STANDARD-TRIANGLE NIL 
       (LET ((TURTLE-FRONT-RADIUS-X (*$ TURTLE-FRONT-RADIUS SINE-HEADING))
	     (TURTLE-FRONT-RADIUS-Y (*$ TURTLE-FRONT-RADIUS COSINE-HEADING))
	     (TURTLE-RIGHT-RADIUS-X (*$ TURTLE-SIDE-RADIUS
					(+$ (*$ SINE-HEADING COSINE-120)
					    (*$ SINE-120 COSINE-HEADING))))
	     (TURTLE-RIGHT-RADIUS-Y (*$ TURTLE-SIDE-RADIUS
					(-$ (*$ COSINE-HEADING COSINE-120)
					    (*$ SINE-HEADING SINE-120))))
	     (TURTLE-LEFT-RADIUS-X (*$ TURTLE-SIDE-RADIUS
				       (+$ (*$ SINE-HEADING COSINE-240)
					   (*$ SINE-240 COSINE-HEADING))))
	     (TURTLE-LEFT-RADIUS-Y (*$ TURTLE-SIDE-RADIUS
				       (-$ (*$ COSINE-HEADING COSINE-240)
					   (*$ SINE-HEADING SINE-240))))
             (HORIZONTAL (EXPR-FUNCTION HORIZONTAL-LINE))
             (VERTICAL (EXPR-FUNCTION VERTICAL-LINE)))
	    (LET ((TURTLE-FRONT-X (+$ :XCOR TURTLE-FRONT-RADIUS-X))
		  (TURTLE-FRONT-Y (+$ :YCOR TURTLE-FRONT-RADIUS-Y))
		  (TURTLE-LEFT-X (+$ :XCOR TURTLE-LEFT-RADIUS-X))
		  (TURTLE-LEFT-Y (+$ :YCOR TURTLE-LEFT-RADIUS-Y))
		  (TURTLE-RIGHT-X (+$ :XCOR TURTLE-RIGHT-RADIUS-X))
		  (TURTLE-RIGHT-Y (+$ :YCOR TURTLE-RIGHT-RADIUS-Y))
                  (:WRAP T))
		 (WRAP-VECTOR :XCOR :YCOR TURTLE-FRONT-X TURTLE-FRONT-Y)
		 (WRAP-VECTOR TURTLE-FRONT-X
			      TURTLE-FRONT-Y
			      TURTLE-LEFT-X
			      TURTLE-LEFT-Y)
		 (WRAP-VECTOR TURTLE-LEFT-X
			      TURTLE-LEFT-Y
			      TURTLE-RIGHT-X
			      TURTLE-RIGHT-Y)
		 (WRAP-VECTOR TURTLE-RIGHT-X
			      TURTLE-RIGHT-Y
			      TURTLE-FRONT-X
			      TURTLE-FRONT-Y)))) 




(DEFUN DRAW-TURTLE NIL
       (COND ((NOT :SEETURTLE))
             ;;Turtle not visible, or clipped out of boundary, return.
             ((AND :CLIP (PLUSP (CLIP-VISIBILITY :XCOR :YCOR))))
             ;;If user set up a turtle display form, use it, else default.
             (:DRAWTURTLE (INVOKE-USER-DRAW-TURTLE))
             (T [COLOR (SELECT-COLOR :PENNUMBER)]
                (TRIANGLETURTLE)
                [COLOR (RESELECT-COLOR)])))

(DEFUN ERASE-TURTLE NIL
       (COND ((NOT :SEETURTLE))
             ;;Turtle not visible, or clipped out of boundary, return.
             ((AND :CLIP (PLUSP (CLIP-VISIBILITY :XCOR :YCOR))))
             ;;If user set up a turtle display form, use it, else default.
             (:ERASETURTLE (INVOKE-USER-ERASE-TURTLE))
             (T [COLOR (SELECT-COLOR :ERASERNUMBER)]
                (TRIANGLETURTLE)
                [COLOR (RESELECT-COLOR)])))



(DECLARE (SPECIAL :DRAWTURTLE :ERASETURTLE)) 

(DEFINE SHOWTURTLE (ABB ST) NIL 
	(COND (:SEETURTLE) ((SETQ :SEETURTLE T) (DRAW-TURTLE)))
	NO-VALUE) 

(DEFINE HIDETURTLE (ABB HT) NIL (COND (:SEETURTLE (ERASE-TURTLE)))
				(SETQ :SEETURTLE NIL)
				NO-VALUE) 

(DEFUN DRAW-TURTLES NIL 
       (DRAW-TURTLE)
       (LET ((OLD-TURTLE :TURTLE))
            (MAPC '(LAMBDA (OTHER-TURTLE)
                           (COND ((EQ OTHER-TURTLE OLD-TURTLE))
                                 (T (USETURTLE OTHER-TURTLE) (DRAW-TURTLE))))
                  :TURTLES)
            (COND ((EQ :TURTLE OLD-TURTLE))
                  ((USETURTLE OLD-TURTLE)))))

(DEFUN ERASE-TURTLES NIL 
       (ERASE-TURTLE)
       (LET ((OLD-TURTLE :TURTLE))
            (MAPC '(LAMBDA (OTHER-TURTLE)
                           (COND ((EQ OTHER-TURTLE OLD-TURTLE))
                                 (T (USETURTLE OTHER-TURTLE) (ERASE-TURTLE))))
                  :TURTLES)
            (COND ((EQ :TURTLE OLD-TURTLE))
                  ((USETURTLE OLD-TURTLE)))))

(DEFINE MAKETURTLE (PARSE 2.) FEXPR (MAKETURTLE-ARGS)
 (LET ((DRAW-FORM (CAR MAKETURTLE-ARGS)) (ERASE-FORM (CADR MAKETURTLE-ARGS)))
      (ERASE-TURTLE)
      (SETQ :DRAWTURTLE DRAW-FORM :ERASETURTLE ERASE-FORM)
      (DRAW-TURTLE))
 NO-VALUE) 

;;*PAGE

;;;

(COMMENT MULTIPLE TURTLES) 

;;;

(DECLARE (SPECIAL :TURTLE :TURTLES TURTLE-PROPERTIES)
	 (FIXNUM TURTLE-PROPERTIES PROPERTY-INDEX)) 

;;SWITCHES BACK AND FORTH BETWEEN MULTIPLE TURTLES.  SETS GLOBAL VARIABLES ACCORDING
;;TO SAVED PROPERTIES ON NEW TURTLE,

(DEFINE USETURTLE (ABB UT) (TURTLE-NAME) 
	(OR (GET TURTLE-NAME 'TURTLE)
	    (SETQ TURTLE-NAME 
                  (ERRBREAK 'USETURTLE (LIST TURTLE-NAME '"IS NOT A TURTLE"))))
	(DO ((PROPERTY-INDEX 0. (1+ PROPERTY-INDEX))
	     (OLD-TURTLE (GET :TURTLE 'TURTLE))
	     (NEW-TURTLE (GET TURTLE-NAME 'TURTLE)))
	    ((= PROPERTY-INDEX TURTLE-PROPERTIES)
	     [BW (DRAWMODE (COND (:ERASERSTATE ANDC) (:XORSTATE XOR) (IOR)))]
             [COLOR (RESELECT-COLOR)]
	     (TV-SETHOME (ARRAYCALL NIL NEW-TURTLE 0.)
			 (ARRAYCALL NIL NEW-TURTLE 1.)))
	    (STORE (ARRAYCALL T OLD-TURTLE PROPERTY-INDEX)
		   (SYMEVAL (TURTLE-PROPERTY PROPERTY-INDEX)))
	    (SET (TURTLE-PROPERTY PROPERTY-INDEX)
		 (ARRAYCALL T NEW-TURTLE PROPERTY-INDEX)))
	(SETQ :TURTLE TURTLE-NAME)) 

;;HATCH CREATES A NEW TURTLE WITH THE SPECIFIED NAME.  ALL PROPERTIES OF THAT
;;PARTICULAR TURTLE ARE AS INITIALLY WHEN A STARTDISPLAY IS DONE.

(DEFINE HATCH (TURTLE-NAME) 
	(PUTPROP TURTLE-NAME
                 (FILLARRAY (*ARRAY NIL T TURTLE-PROPERTIES) 'HATCH-PROPERTY)
                 'TURTLE)
	(OR (MEMQ TURTLE-NAME :TURTLES) (PUSH TURTLE-NAME :TURTLES))
	(USETURTLE TURTLE-NAME)
	(SHOWTURTLE)
	TURTLE-NAME)

(DEFINE ERASETURTLE (TURTLE-NAME)
       (OR (GET TURTLE-NAME 'TURTLE)
           (ERRBREAK 'ERASETURTLE (LIST TURTLE-NAME '"IS NOT A TURTLE")))
       (AND (EQ :TURTLE TURTLE-NAME)
            (ERRBREAK 'ERASETURTLE '"DON'T ERASE THE CURRENT TURTLE!"))
       (SETQ :TURTLES (DELQ TURTLE-NAME :TURTLES))
       (LET ((OLD-TURTLE :TURTLE)) 
            (USETURTLE TURTLE-NAME) 
            (ERASE-TURTLE) 
            (USETURTLE OLD-TURTLE))
       (*REARRAY (GET TURTLE-NAME 'TURTLE))
       (REMPROP TURTLE-NAME 'TURTLE)
       TURTLE-NAME) 

;;*PAGE

;;;

(COMMENT BASIC TURTLE COMMANDS) 

;;;
;;;
;;THE BASIC TURTLE COMMANDS.  MANY COMMANDS WILL COME IN TWO FLAVORS.  FOR THE USER,
;;A KIND WHICH WILL ACCEPT FIXNUMS OR FLONUMS, PROVIDE ARGUMENT TYPE CHECKING, ETC.,
;;AND A SECOND INTERNAL VERSION EXPECTING FLONUMS ONLY OPTIMIZED FOR NCOMPL'ED
;;EFFICIENCY.  SUCH FLONUM-ONLY FUNCTIONS WILL HAVE THEIR NAMES SUFFIXED BY "$"	,
;;FOLLOWING THE LISP CONVENTION.

(DECLARE (FLONUM NEW-X$ NEW-Y$) (NOTYPE (SETXY$ FLONUM FLONUM))) 

(DEFUN SETXY$ (NEW-X$ NEW-Y$) 
       (COND (:WRAP (WRAP-TURTLE-VECTOR :XCOR :YCOR NEW-X$ NEW-Y$))
             (:CLIP (CLIP-TURTLE-VECTOR :XCOR :YCOR NEW-X$ NEW-Y$))
             ((BOUNDED-TURTLE-VECTOR :XCOR :YCOR NEW-X$ NEW-Y$)))) 

(DEFINE SETXY (NEW-X NEW-Y) (SETXY$ (FLOAT NEW-X) (FLOAT NEW-Y)) NO-VALUE) 

(DECLARE (FLONUM (FORWARD$ FLONUM) STEPS$)) 

(DEFUN FORWARD$ (STEPS$) 
       (SETXY$ (+$ :XCOR (*$ STEPS$ SINE-HEADING))
	       (+$ :YCOR (*$ STEPS$ COSINE-HEADING)))) 

(DEFINE FORWARD (ABB FD) (STEPS) (FORWARD$ (FLOAT STEPS)) NO-VALUE) 

(DEFINE BACK (ABB BK) (STEPS) (FORWARD$ (-$ (FLOAT STEPS))) NO-VALUE) 

(DECLARE (FLONUM NEW-HEADING$ NEW-HEADING-RADIANS) (NOTYPE (SETHEAD$ FLONUM))) 

(DEFUN SETHEAD$ (NEW-HEADING$) 
       (ERASE-TRIANGLE)
       (LET ((NEW-HEADING-RADIANS (*$ NEW-HEADING$ PI-OVER-180)))
	    (SETQ :HEADING NEW-HEADING$ 
		  SINE-HEADING (SIN NEW-HEADING-RADIANS) 
		  COSINE-HEADING (COS NEW-HEADING-RADIANS))
	    (DRAW-TRIANGLE))) 

(DEFINE SETHEAD (ABB SH SETHEADING) (NEW-HEADING) (SETHEAD$ (FLOAT NEW-HEADING))
						  NO-VALUE) 

(DECLARE (FLONUM (RIGHT$ FLONUM) TURNS$)) 

(DEFUN RIGHT$ (TURNS$) (SETHEAD$ (+$ :HEADING TURNS$))) 

(DEFINE RIGHT (ABB RT) (TURNS) (RIGHT$ (FLOAT TURNS)) NO-VALUE) 

(DEFINE LEFT (ABB LT) (TURNS) (RIGHT$ (-$ (FLOAT TURNS))) NO-VALUE) 

(DEFINE PENUP (ABB PU) NIL (AND :PENSTATE (ERASE-PEN))
			   (SETQ :PENSTATE NIL :DRAWSTATE NIL)
			   (AND :DRAWTURTLE (DRAW-TURTLE))
			   NO-VALUE) 

(DEFINE PENDOWN (ABB PD) NIL (ERASE-PEN)
			     [BW (DRAWMODE IOR)]
                             [COLOR (SELECT-COLOR :PENNUMBER)]
			     (SETQ :PENSTATE T 
                                   :ERASERSTATE NIL 
                                   :XORSTATE NIL 
                                   :DRAWSTATE 'PEN)
			     (DRAW-PEN)
			     NO-VALUE) 

;;PENP FOR COMPATIBLILITY WITH 340/GT40 TURTLE.

(DEFINE PENP NIL :PENSTATE) 

(DEFINE ERASERUP (ABB ERU) NIL (AND :ERASERSTATE (ERASE-PEN))
			       (SETQ :ERASERSTATE NIL :DRAWSTATE NIL)
                               (AND :DRAWTURTLE (DRAW-TURTLE))
                               (DRAWMODE IOR)
			       NO-VALUE) 

(DEFINE ERASERDOWN (ABB ERD) NIL (ERASE-PEN)
				 [BW (DRAWMODE ANDC)]
                                 [COLOR (SELECT-COLOR :ERASERNUMBER)]
				 (SETQ :ERASERSTATE T 
                                       :PENSTATE NIL 
                                       :XORSTATE NIL
                                       :DRAWSTATE 'ERASER)
				 (DRAW-PEN)
				 NO-VALUE) 

;;THE USER HAS THE OPTION OF USING XOR MODE IN A MANNER SIMILAR TO THE "PEN" AND THE
;;"ERASER".

[BW
(DEFINE XORDOWN (ABB XD) NIL (ERASE-PEN)
			     (DRAWMODE XOR)
			     (SETQ :XORSTATE T 
                                   :PENSTATE NIL 
                                   :ERASERSTATE NIL 
                                   :DRAWSTATE 'XOR)
			     (DRAW-PEN)
			     NO-VALUE) 

(DEFINE XORUP (ABB XU) NIL (AND :XORSTATE (ERASE-PEN))
			   (SETQ :XORSTATE NIL :DRAWSTATE NIL)
			   (AND :DRAWTURTLE (DRAW-TURTLE))
                           (DRAWMODE IOR)
			   NO-VALUE)
]


[COLOR (DEFINE XORUP NIL (NOT-IMPLEMENTED-IN-COLOR '(XORUP)))
       (DEFINE XORDOWN NIL (NOT-IMPLEMENTED-IN-COLOR '(XORDOWN)))] 

(DEFINE HOME (ABB H) NIL (ERASE-TURTLES)
			 ;;SEETURTLE HACKING HANDLED EXPLICITY SO THAT TURTLE
			 ;;APPEARANCE AND DISAPPEARANCE DOES NOT OCCUR TWICE, ONCE
			 ;;WITH SETXY, ONCE WITH SETHEAD.
			 (LET ((:SEETURTLE NIL)) (SETXY$ 0.0 0.0) (SETHEAD$ 0.0))
			 (DRAW-TURTLES)
			 NO-VALUE) 

(DEFINE SETTURTLE (ABB SETT) (P) 
				 ;;(SETTURTLE '(100 100 90)) SETS THE STATE OF THE
				 ;;TURTLE TO THE POSITION '(100 100) AND HEADING 90. 
				 ;;THE HEADING IS OPTIONAL.  (SETTURTLE (HERE)) IS A
				 ;;NO-OP.
				 (SETXY$ (FLOAT (CAR P)) (FLOAT (CADR P)))
				 (AND (CDDR P) (SETHEAD$ (FLOAT (CADDR P))))
				 NO-VALUE) 

(DEFINE SETX (X) (SETXY$ (FLOAT X) :YCOR) NO-VALUE) 

(DEFINE SETY (Y) (SETXY$ :XCOR (FLOAT Y)) NO-VALUE) 

(DECLARE (FIXNUM (XCOR) (YCOR) (HEADING) SMASHED-HEADING))

(DEFINE XCOR NIL
        (ROUND (COND ((OR :WRAP :CLIP) (TURTLE-X (TV-X :XCOR))) (:XCOR))))

(DEFINE YCOR NIL
        (ROUND (COND ((OR :WRAP :CLIP) (TURTLE-Y (TV-Y :YCOR))) (:YCOR))))

(DEFINE HEADING NIL 
	(LET ((SMASHED-HEADING (\ (ROUND :HEADING) 360.))) 
             (OR (AND (MINUSP SMASHED-HEADING) (+ 360. SMASHED-HEADING)) 
                 SMASHED-HEADING)))

(DEFINE HERE NIL (LIST (XCOR) (YCOR) (HEADING))) 

(DEFINE DELX (X) (SETXY$ (+$ (FLOAT X) :XCOR) :YCOR) NO-VALUE) 

(DEFINE DELY (Y) (SETXY$ :XCOR (+$ :YCOR (FLOAT Y))) NO-VALUE) 

(DEFINE DELXY (X Y) (SETXY$ (+$ :XCOR (FLOAT X)) (+$ :YCOR (FLOAT Y))) NO-VALUE) 

;;MARK NEEDS A CONVENIENT WAY TO ERASE TEXT FROM SCREEN.  PRINTING OF TEXT DOESN'T
;;SEEM TO BE AFFECTED BY DRAWMODE.

[BW
(DEFINE MARK (TEXT) (LET ((WHERE-I-WAS (ECHO-CURSORPOS))
                          ;;(STATUS TERPRI) MUST BE T FOR THIS TO WORK CORRECTLY.
                          ;;SO NO STRAY CR'S IN TEXT PRINTING.
                          (STATUS-TERPRI (STATUS TERPRI)))
                         (OR STATUS-TERPRI (SSTATUS TERPRI T))
			 (ERASE-TURTLES)
			 (OUTPUT-TO-MAIN-SCREEN)
			 (CURSORPOS (// (TV-Y :YCOR) 12.) (// (TV-X :XCOR) 6.))
			 ;;CLOSEST CURSOR POSITION TO TURTLE'S LOCATION ON THE
			 ;;SCREEN.
			 (TYPE TEXT)
			 (OUTPUT-TO-ECHO-AREA)
			 (CURSORPOS (CAR WHERE-I-WAS) (CDR WHERE-I-WAS))
			 (DRAW-TURTLES)
                         (OR STATUS-TERPRI (SSTATUS TERPRI NIL))
		    TEXT))]


[COLOR (DEFINE MARK (TEXT) (NOT-IMPLEMENTED-IN-COLOR (LIST 'MARK TEXT)))] 

;;*PAGE

;;;

(COMMENT POINTS AND CIRCLES) 

[BW
;;;
;;SET OR READ ANY POINT IN TV BUFFER.

(DECLARE (NOTYPE (WRITE-TV-POINT FIXNUM FIXNUM))) 

(DEFUN WRITE-TV-POINT (POINT-X POINT-Y) 
       (STORE (TV (+ (* 18. POINT-Y) (LSH POINT-X -5.))) 
              (POINT-MASK (BITWISE-AND POINT-X 31.)))
       T) 

(DECLARE (NOTYPE (READ-TV-POINT FIXNUM FIXNUM))) 

(DEFUN READ-TV-POINT (POINT-X POINT-Y) 
       (NOT (ZEROP (BITWISE-AND (POINT-MASK (BITWISE-AND POINT-X 31.)) 
                                (TV (+ (* 18. POINT-Y) (LSH POINT-X -5.)))))))

;;END OF BLACK-AND-WHITE CONDITIONAL SECTION.
] 


[COLOR

(DECLARE (FIXNUM (READ-TV-POINT-NUMBER FIXNUM FIXNUM) TV-BUFFER-INDEX
		 SIGNIFICANT-BIT POINT-TOTAL ELEVEN-WORD-X ELEVEN-MASK WRITE-WORD)
	 (NOTYPE (READ-TV-POINT FIXNUM FIXNUM)
		 (READ-TV-POINT-SINGLE FIXNUM FIXNUM)
		 (WRITE-TV-POINT FIXNUM FIXNUM))) 

;;Note: COLOR WRITE MODE must be turned OFF to read.

(DEFUN READ-TV-POINT (POINT-X POINT-Y) 
       ;;Returns atom describing color of point.  READ-TV-POINT-NUMBER returns the
       ;;bit combination corresponding to the point, indexes into palette.
       (PALETTE (READ-TV-POINT-NUMBER POINT-X POINT-Y))) 

(DEFUN READ-TV-POINT-NUMBER (POINT-X POINT-Y) 
       (DO ((TV-BUFFER-INDEX 0. (1+ TV-BUFFER-INDEX))
	    (SIGNIFICANT-BIT 1. (LSH SIGNIFICANT-BIT 1.))
	    (POINT-TOTAL 0.))
	   ((= TV-BUFFER-INDEX COLOR-BITS) POINT-TOTAL)
	   (SELECT-TV-BUFFER TV-BUFFER-INDEX)
	   (OR (READ-TV-POINT-SINGLE POINT-X POINT-Y)
               ;;Bits are inverted in TV buffer!
	       (INCREMENT POINT-TOTAL SIGNIFICANT-BIT)))) 

(DEFUN READ-TV-POINT-SINGLE (POINT-X POINT-Y) 
       ;;Ordinary point read function on a single TV buffer.
       (NOT (ZEROP (BITWISE-AND (POINT-MASK (BITWISE-AND POINT-X 31.)) 
                                (TV (+ (* 18. POINT-Y) (LSH POINT-X -5.))))))) 

(DEFUN WRITE-TV-POINT (POINT-X POINT-Y) 
       (LET ((ELEVEN-WORD-X (LSH POINT-X -4.))
	     ;;ELEVEN-WORD-X address in 16.  bit words.  Into MASK register is
	     ;;written word with only the relevant bit off.
	     (ELEVEN-MASK (ELEVEN-NOT-POINT-MASK (BITWISE-AND POINT-X 15.))))
	    (WRITE-TV-MASK ELEVEN-MASK)
	    ;;If eleven address is odd, inhibit writing of low order word. If eleven
	    ;;address even, inhibit high order word.  This conveyed by third and
	    ;;fourth bits from right in word written across ten to eleven interface.
	    (LET ((WRITE-WORD (COND ((ODDP ELEVEN-WORD-X) -8.) (-12.))))
		 ;;32 bit words twice as big as 16 bit words.
		 (STORE (TV (+ (* POINT-Y 18.) (LSH ELEVEN-WORD-X -1.))) WRITE-WORD)))
       T) 

;;Versions which use memory address & data registers to read & write points.
;;Probably losing from an efficiency standpoint.
;;; (DECLARE (FIXNUM (READ-TV-POINT-REGISTERS FIXNUM FIXNUM))
;;;          (NOTYPE (WRITE-TV-POINT-REGISTERS FIXNUM FIXNUM)))
;;; 
;;; (DEFUN READ-TV-POINT-REGISTERS (POINT-X POINT-Y)
;;;        (WRITE-TV-ADDRESS (TV-ADDRESS POINT-Y (// POINT-X 16.)))
;;;        (DO ((TV-BUFFER-INDEX 0 (1+ TV-BUFFER-INDEX))
;;;             (SIGNIFICANT-BIT 1. (LSH SIGNIFICANT-BIT 1.))
;;;             (POINT-TOTAL 0.)
;;;             (POINT-BIT-MASK (LSH 1. (- 15. (\ POINT-X 16.)))))
;;;            ((= TV-BUFFER-INDEX COLOR-BITS) 
;;;             ;;Sigh, number coming back here must be complemented because Ron
;;;             ;;decided to save a few inverters....
;;;             (BITWISE-AND 15. (BITWISE-NOT POINT-TOTAL)))
;;;            (SELECT-TV-BUFFER TV-BUFFER-INDEX)
;;;            (OR (ZEROP (BITWISE-AND (READ-TV-DATA) POINT-BIT-MASK)) 
;;;                (INCREMENT POINT-TOTAL SIGNIFICANT-BIT))))
;;; 
;;; (DEFUN WRITE-TV-POINT-REGISTERS (POINT-X POINT-Y)
;;;        (LET ((WORD-X (// POINT-X 16.)) (BIT-X (\ POINT-X 16.)))
;;;             (LET ((BIT-MASK (LSH 1. (- 15. BIT-X))))
;;;                  (WRITE-TV-MASK (BITWISE-NOT BIT-MASK))
;;;                  (WRITE-TV-WORD (TV-ADDRESS POINT-Y WORD-X) BIT-MASK)))
;;;        T)
;;;

;;;END OF COLOR CONDITIONAL SECTION.
]


;;POINT FUNCTION SLIGHTLY DIFFERENT THAN FOR 340/GT40 TURTLE PACKAGE. 
;;;
;;; ?POINT -- [NO ARGS] TURNS THE CURRENT TURTLE LOCATION ON.
;;; ?POINT <T OR NIL> -- TURNS THE CURRENT LOCATION OF THE TURTLE ON OR OFF.
;;; ?POINT <X> <Y> -- TURNS THE POINT AT (<X>, <Y>) ON
;;; ?POINT <X> <Y> <T OR NIL> -- TURNS THE POINT SPECIFIED ON OR OFF.
;;;

(DECLARE (FLONUM X-COR Y-COR)) 

[BW

(DEFINE POINT (PARSE L) ARGS 
	(LET ((X-COR :XCOR) (Y-COR :YCOR) (DARK-OR-LIGHT :DRAWMODE))
	     (COND ((ZEROP ARGS))
		   ((= ARGS 1.) (SETQ DARK-OR-LIGHT (COND ((ARG 1.) IOR) (ANDC))))
		   ((= ARGS 2.)
		    (SETQ X-COR (FLOAT (ARG 1.)) 
			  Y-COR (FLOAT (ARG 2.))))
		   ((= ARGS 3.)
		    (SETQ X-COR (FLOAT (ARG 1.)) 
			  Y-COR (FLOAT (ARG 2.)) 
			  DARK-OR-LIGHT (COND ((ARG 3.) IOR) (ANDC)))))
             (ERASE-TURTLES)
	     (LET ((OLD-DRAWMODE (DRAWMODE DARK-OR-LIGHT)))
		  (WRITE-TV-POINT (TV-X X-COR) (TV-Y Y-COR))
		  (DRAWMODE OLD-DRAWMODE))
             (DRAW-TURTLES))
	NO-VALUE) 

(DEFINE POINTSTATE (ABB PS)  ARGS 
	(LET ((X-COR :XCOR) (Y-COR :YCOR))
	     (ERASE-TURTLES)
	     (COND ((ZEROP ARGS))
		   ((= ARGS 1.)
		    (SETQ X-COR (FLOAT (CAR (ARG 1.))) 
			  Y-COR (FLOAT (CADR (ARG 1.)))))
		   ((= ARGS 2.)
		    (SETQ X-COR (FLOAT (ARG 1.)) Y-COR (FLOAT (ARG 2.)))))
	     (PROG1 (READ-TV-POINT (TV-X X-COR) (TV-Y Y-COR))
		    (DRAW-TURTLES))))

;;;END OF BLACK-AND-WHITE CONDITIONAL SECTION.
] 


[COLOR 

(DEFINE POINT (PARSE L) ARGS 
	(LET ((X-COR :XCOR) (Y-COR :YCOR))
             (ERASE-TURTLES)
	     (COND ((ZEROP ARGS))
		   ((= ARGS 1.)
		    (SELECT-COLOR (COND ((ARG 1.) :PENNUMBER) (:ERASERNUMBER))))
		   ((= ARGS 2.) (SETQ X-COR (FLOAT (ARG 1.)) Y-COR (FLOAT (ARG 2.))))
		   ((= ARGS 3.)
		    (SETQ X-COR (FLOAT (ARG 1.)) Y-COR (FLOAT (ARG 2.)))
		    (SELECT-COLOR (COND ((ARG 1.) :PENNUMBER) (:ERASERNUMBER)))))
	     (WRITE-TV-POINT (TV-X X-COR) (TV-Y Y-COR))
             (RESELECT-COLOR)
             (DRAW-TURTLES))
	NO-VALUE) 

(DEFINE POINTSTATE (ABB PS) ARGS 
	(LET ((X-COR :XCOR) (Y-COR :YCOR))
	     (ERASE-TURTLES)
	     (COND ((ZEROP ARGS))
		   ((= ARGS 1.)
		    (SETQ X-COR (FLOAT (CAR (ARG 1.))) 
			  Y-COR (FLOAT (CADR (ARG 1.)))))
		   ((= ARGS 2.)
		    (SETQ X-COR (FLOAT (ARG 1.)) Y-COR (FLOAT (ARG 2.)))))
	     (NO-COLOR-WRITE)
	     (PROG1 (READ-TV-POINT (TV-X X-COR) (TV-Y Y-COR))
		    (COLOR-WRITE)
		    (DRAW-TURTLES))))

;;;END OF COLOR CONDITIONAL SECTION.
]


 

(DECLARE (SPECIAL :POLYGON :PI)
	 (NOTYPE (ARC$ FLONUM FLONUM))
	 (FLONUM :POLYGON UNIT-CIRCLE-SIDE HALF-TURN SIDES SIDE RADIUS$ DEGREES$
		 OLD-XCOR OLD-YCOR OLD-HEADING)) 

(DEFUN ARC$ (RADIUS$ DEGREES$) 
       ;;ONE OF THESE DAYS, INCLUDE A MORE EFFICIENT ARC DRAWING PROCEDURE.
       (ERASE-TURTLES)
       ;;Turtle hidden during execution of ARC.
       (LET ((UNIT-CIRCLE-SIDE (*$ 2.0 (SIN (//$ :PI :POLYGON))))
	     (HALF-TURN (//$ 360.0 :POLYGON 2.0)))
	    (LET ((SIDE (*$ RADIUS$ UNIT-CIRCLE-SIDE))
		  (OLD-XCOR :XCOR)
		  (OLD-YCOR :YCOR)
		  (OLD-HEADING :HEADING)
		  (SINE-HEADING SINE-HEADING)
		  (COSINE-HEADING COSINE-HEADING)
		  (:DRAWSTATE NIL)
		  (:SEETURTLE NIL))
		 (FORWARD$ RADIUS$)
		 (RIGHT$ 90.0)
		 (DO ((SIDES (//$ DEGREES$ HALF-TURN 2.0) (1-$ SIDES)) 
                      (:DRAWSTATE T))
		     ((< SIDES 1.0) (RIGHT$ HALF-TURN) (FORWARD$ (*$ SIDES SIDE)))
		     (RIGHT$ HALF-TURN)
		     (FORWARD$ SIDE)
		     (RIGHT$ HALF-TURN))
		 (SETXY$ OLD-XCOR OLD-YCOR)
		 (SETHEAD$ OLD-HEADING)))
       (DRAW-TURTLES))) 

(DEFINE ARC (RADIUS DEGREES) (ARC$ (FLOAT RADIUS) (FLOAT DEGREES)) NO-VALUE) 

(DEFINE CIRCLE (RADIUS) (ARC$ (FLOAT RADIUS) 360.0) NO-VALUE) 

;;*PAGE

;;;

(COMMENT GLOBAL NAVIGATION) 

;;;

(DECLARE (*LEXPR BEARING TOWARDS RANGE)
	 (*EXPR \$)
	 (FLONUM X-COR Y-COR DELTA-X DELTA-Y ALLEGED-BEARING ALLEGED-TOWARDS
		 ALLEGED-RANGE (\$ FLONUM FLONUM))) 

(DEFINE BEARING ARGS 
	(LET ((X-COR 0.0)
	      (Y-COR 0.0)
	      (DELTA-X 0.0)
	      (DELTA-Y 0.0)
	      (ALLEGED-BEARING 0.0)
	      (RETURN-FIXNUM))
	     (COND ((= ARGS 1.)
		    (SETQ X-COR (FLOAT (CAR (ARG 1.))) 
			  Y-COR (FLOAT (CADR (ARG 1.))) 
			  RETURN-FIXNUM (AND (FIXP (CAR (ARG 1.)))
					     (FIXP (CADR (ARG 1.))))))
		   ((= ARGS 2.)
		    (SETQ X-COR (FLOAT (ARG 1.)) 
			  Y-COR (FLOAT (ARG 2.)) 
			  RETURN-FIXNUM (AND (FIXP (ARG 1.)) (FIXP (ARG 2.)))))
		   ((ERRBREAK 'BEARING
			      '"WRONG NUMBER OF INPUTS")))
	     (SETQ DELTA-X (-$ X-COR :XCOR) DELTA-Y (-$ Y-COR :YCOR))
	     (COND ((AND (< (ABS DELTA-X) FLOATING-POINT-TOLERANCE)
			 (< (ABS DELTA-Y) FLOATING-POINT-TOLERANCE)))
		   ((MINUSP (SETQ ALLEGED-BEARING
				  (QUOTIENT (ATAN DELTA-X DELTA-Y) PI-OVER-180)))
		    (SETQ ALLEGED-BEARING (-$ 360.0 ALLEGED-BEARING))))
	     (COND (RETURN-FIXNUM (\ (ROUND ALLEGED-BEARING) 360.))
		   ((\$ ALLEGED-BEARING 360.0))))) 

(DEFINE TOWARDS ARGS 
	;;DIRECTION OF A POINT RELATIVE TO TURTLE HEADING.  +0-360 DEGREES.  POINT =
	;;(X Y).
	(LET ((X-COR 0.0) (Y-COR 0.0) (RETURN-FIXNUM))
	     (COND ((= ARGS 1.)
		    (SETQ X-COR (FLOAT (CAR (ARG 1.))) 
			  Y-COR (FLOAT (CADR (ARG 1.))) 
			  RETURN-FIXNUM (AND (FIXP (CAR (ARG 1.)))
					     (FIXP (CADR (ARG 1.))))))
		   ((= ARGS 2.)
		    (SETQ X-COR (FLOAT (ARG 1.)) 
			  Y-COR (FLOAT (ARG 2.)) 
			  RETURN-FIXNUM (AND (FIXP (ARG 1.)) (FIXP (ARG 2.)))))
		   ((ERRBREAK 'TOWARDS
			      '"WRONG NUMBER OF INPUTS")))
	     (LET ((ALLEGED-TOWARDS (-$ (BEARING X-COR Y-COR) :HEADING)))
		  (COND ((MINUSP ALLEGED-TOWARDS)
			 (SETQ ALLEGED-TOWARDS (+$ 360.0 ALLEGED-TOWARDS))))
		  (COND (RETURN-FIXNUM (\ (ROUND ALLEGED-TOWARDS) 360.))
			((\$ ALLEGED-TOWARDS 360.0)))))) 

(DEFINE RANGE ARGS 
	(LET ((X-COR 0.0)
	      (Y-COR 0.0)
	      (ALLEGED-RANGE 0.0)
	      (DELTA-X 0.0)
	      (DELTA-Y 0.0)
	      (RETURN-FIXNUM))
	     (COND ((= ARGS 1.)
		    (SETQ X-COR (FLOAT (CAR (ARG 1.))) 
			  Y-COR (FLOAT (CADR (ARG 1.))) 
			  RETURN-FIXNUM (AND (FIXP (CAR (ARG 1.)))
					     (FIXP (CADR (ARG 1.))))))
		   ((= ARGS 2.)
		    (SETQ X-COR (FLOAT (ARG 1.)) 
			  Y-COR (FLOAT (ARG 2.)) 
			  RETURN-FIXNUM (AND (FIXP (ARG 1.)) (FIXP (ARG 2.)))))
		   ((ERRBREAK 'RANGE
			      '"WRONG NUMBER OF INPUTS")))
	     (SETQ DELTA-X (-$ X-COR :XCOR) 
		   DELTA-Y (-$ Y-COR :YCOR) 
		   ALLEGED-RANGE (SQRT (+$ (*$ DELTA-X DELTA-X)
					   (*$ DELTA-Y DELTA-Y))))
	     (COND (RETURN-FIXNUM (ROUND ALLEGED-RANGE)) (ALLEGED-RANGE)))) 

;;*PAGE

;;;


(COMMENT WINDOW COMMANDS) 

;;;
;;;
;;THE FOLLOWING FUNCTIONS ALLOW THE USER TO SAVE RECTANGULAR AREAS OF THE SCREEN IN
;;BIT-IMAGE ARRAYS, AND REDISPLAY SUCH ARRAYS ANYWHERE ON THE SCREEN.  ALTHOUGH
;;SOMEWHAT SPACE CONSUMING, IT ALLOWS SUPERQUICK REDISPLAY, MINIMIZING RECOMPUTATION
;;OF POINTS.  THIS MAKES IT IDEAL FOR PROGRAMS WHICH WANT TO MAKE ONLY LOCAL CHANGES
;;TO A PICTURE, BUT NEED SPEED FOR DYNAMIC UPDATING.  EXAMPLES: SHIPS IN SPACE WAR,
;;BOUNCING BALL TYPE PROGRAMS, CELLS IN LIFE GAME. 
;;;
;;NOTE THAT THESE "WINDOW"S ARE DIFFERENT FROM LLOGO'S SNAPS: WHAT YOU SEE IS
;;EXACTLY WHAT YOU GET!

(DECLARE (FIXNUM CENTER-X CENTER-Y RADIUS-X RADIUS-Y LEFT-X RIGHT-X TOP-Y BOTTOM-Y)) 

(DEFUN RECTANGLE-SPEC (CHECKER SPEC-LIST) 
       ;;HANDLES DEFAULTS FOR SPECIFYING A RECTANGULAR AREA OF THE SCREEN FOR USE
       ;;WITH THE WINDOW AND XGP COMMANDS.
       (LET ((LEFT-X TV-PICTURE-LEFT)
	     (RIGHT-X TV-PICTURE-RIGHT)
	     (TOP-Y TV-PICTURE-TOP)
	     (BOTTOM-Y TV-PICTURE-BOTTOM)
	     (CENTER-X (TV-X :XCOR))
	     (CENTER-Y (TV-Y :YCOR))
	     (RADIUS-X TV-PICTURE-HALF-X)
	     (RADIUS-Y TV-PICTURE-HALF-Y))
	    (COND ((NULL SPEC-LIST)
		   (SETQ CENTER-X (+ TV-PICTURE-LEFT TV-PICTURE-HALF-X) 
			 CENTER-Y (+ TV-PICTURE-TOP TV-PICTURE-HALF-Y)))
		  (T (COND ((CDDR SPEC-LIST)
			    (SETQ CENTER-X (TV-X (FLOAT (CAR SPEC-LIST))) 
				  CENTER-Y (TV-Y (FLOAT (CADR SPEC-LIST))) 
				  SPEC-LIST (CDDR SPEC-LIST))))
		     (SETQ RADIUS-X (ROUND (//$ (FLOAT (CAR SPEC-LIST))
						:TVSTEP)) 
			   RADIUS-Y (COND ((CDR SPEC-LIST)
					   (ROUND (//$ (FLOAT (CADR SPEC-LIST))
						       :TVSTEP)))
					  (RADIUS-X)) 
			   LEFT-X (- CENTER-X RADIUS-X) 
			   RIGHT-X (+ CENTER-X RADIUS-X) 
			   TOP-Y (- CENTER-Y RADIUS-Y) 
			   BOTTOM-Y (+ CENTER-Y RADIUS-Y))
		     (AND (OR (> RADIUS-X TV-PICTURE-HALF-X)
			      (> RADIUS-Y TV-PICTURE-HALF-Y))
			  (ERRBREAK CHECKER
				    '"AREA TOO LARGE"))))
	    ;;THE RECTANGULAR AREA SPECIFIED BY THE NUMBERS BELOW INCLUDES THE TOP,
	    ;;BOTTOM, LEFT & RIGHT MOST POINTS.
	    (LIST TOP-Y BOTTOM-Y LEFT-X RIGHT-X CENTER-X CENTER-Y))) 

;;THE DIMENSIONS ARE STORED IN THE ARRAY SO THAT GETWINDOWS CAN RECREATE A
;;TWO-DIMESIONAL ARRAY FROM THE ONE DIMENSIONAL ARRAY RETURNED BY LOADARRAYS.

(DECLARE (SPECIAL WINDOW-INFO-DIMENSION WINDOW-INFO-TAIL WINDOW-PICTURE-TAIL)
	 (FIXNUM HOME-X HOME-Y WINDOW-PICTURE-SIZE-X WINDOW-PICTURE-SIZE-Y)
	 (NOTYPE (MAKEWINDOW-STORE NOTYPE FIXNUM FIXNUM FIXNUM FIXNUM)
		 (MAKEWINDOW-ARRAY NOTYPE
				   FIXNUM
				   FIXNUM
				   FIXNUM
				   FIXNUM
				   FIXNUM
				   FIXNUM))) 



(SETQ WINDOW-INFO-TAIL '(- W I N D O W - I N F O) 
      WINDOW-PICTURE-TAIL '(- W I N D O W - P I C T U R E) 
      [COLOR WINDOW-PALETTE-TAIL '(- W I N D O W - P A L E T T E)
             RUN-COLOR-SHIFT 18.
             MINUS-RUN-COLOR-SHIFT (- RUN-COLOR-SHIFT)
             RUN-COUNTER-MASK (1- (LSH 1. RUN-COLOR-SHIFT))]
      WINDOW-INFO-DIMENSION 8.) 

(COND ((STATUS FEATURE LLOGO)
       (MAPC '(LAMBDA (ATOM) (OBTERN ATOM LOGO-OBARRAY)) 
             (APPEND WINDOW-INFO-TAIL 
                     WINDOW-PICTURE-TAIL 
                     [COLOR WINDOW-PALETTE-TAIL]))))

(DECLARE (FIXNUM LEFT-X RIGHT-X TOP-Y BOTTOM-Y TV-CENTER-X TV-CENTER-Y TV-RADIUS-X
		 TV-RADIUS-Y WINDOW-X WINDOW-Y DOWN ACROSS STOP-X START-BIT
		 STOP-BIT STOP-MASK WINDOW-BIT SOURCE BITS-WANTED START-MASK
                 START-ADDRESS STOP-ADDRESS STOP-ACROSS TV-DELTA-X TV-DELTA-Y
                 WINDOW-ADDRESS))


[COLOR 

(DECLARE (FIXNUM WINDOW-RUN-ENCODE FIXNUM FIXNUM)
         (SPECIAL RUN-COLOR-SHIFT RUN-COUNTER-MASK MINUS-RUN-COLOR-SHIFT)
         (FIXNUM RUN-COLOR-SHIFT RUN-COUNTER-MASK MINUS-RUN-COLOR-SHIFT))

(DEFUN WINDOW-RUN-ENCODE (RUN-COLOR RUN-COUNTER)
       (BITWISE-OR (LSH RUN-COLOR RUN-COLOR-SHIFT) RUN-COUNTER))]

;;*PAGE


;;;Improvements:
;;Eliminate list for temporarily holding run length codes. Instead,
;;estimate size of window picture array and store run lengths directly
;;into array. Readjust dimensions as needed, and when actual size known at end.
;;;
;;Store run lengths two to a word [4 bits color, 14 bits counter]
;;;

[COLOR

(DECLARE (NOTYPE (MAKEWINDOW-STORE-COLOR NOTYPE FIXNUM FIXNUM FIXNUM FIXNUM))
         (FIXNUM RUN-Y RUN-INDEX ONE-PLUS-RIGHT-X RUN-START NEXT-RUN-START
                 RUN-COLOR RUN-COUNTER LAST-RUN-COLOR LAST-RUN-COUNTER))

(DEFUN MAKEWINDOW-STORE-COLOR (WINDOW-PICTURE TOP-Y BOTTOM-Y LEFT-X RIGHT-X)
       (DO ((RUN-Y TOP-Y (1+ RUN-Y))
            (RUN-LIST)
            ;;List of run length codes, index is number of codes so far.
            (RUN-INDEX 0.)
            (ONE-PLUS-RIGHT-X (1+ RIGHT-X))
            (LAST-RUN-COLOR -1.)
            (LAST-RUN-COUNTER -1.))
           ((> RUN-Y BOTTOM-Y)
            (FILLARRAY (*ARRAY WINDOW-PICTURE 'FIXNUM (1+ RUN-INDEX)) 
                       (NREVERSE RUN-LIST)))
           (DO ((RUN-START LEFT-X NEXT-RUN-START)
                (NEXT-RUN-START)
                (RUN-COLOR)
                (RUN-COUNTER))
               ((> RUN-START RIGHT-X) 
                ;;Last color & counter on line remembered to merge if possible
                ;;with first on next line.
                (SETQ LAST-RUN-COLOR RUN-COLOR LAST-RUN-COUNTER RUN-COUNTER))
               (SETQ NEXT-RUN-START
                     ;;NEXT-RUN-START is first point after current run.
                     (+ RUN-START
                        (SETQ RUN-COUNTER
                              ;;Number of points in the current run.
                              (RUNAWAY-FORWARD RUN-START
                                               RUN-Y
                                               ;;Color of point starting run.
                                               (SETQ RUN-COLOR
                                                     (READ-TV-POINT-NUMBER
                                                      RUN-START
                                                      RUN-Y))))))
               (COND ((> NEXT-RUN-START ONE-PLUS-RIGHT-X)
                      ;;Run extends past the right boundary of the area.
                      (SETQ RUN-COUNTER (- ONE-PLUS-RIGHT-X RUN-START))))
               (COND ((MINUSP LAST-RUN-COLOR)
                      ;;No previous run to worry about.
                      (PUSH (WINDOW-RUN-ENCODE RUN-COLOR RUN-COUNTER) RUN-LIST)
                      (INCREMENT RUN-INDEX))
                     ((= LAST-RUN-COLOR RUN-COLOR)
                      ;;Consolidate two runs on successive lines.
                      (RPLACA RUN-LIST 
                              (WINDOW-RUN-ENCODE RUN-COLOR 
                                                 (+ RUN-COUNTER LAST-RUN-COUNTER)))
                      (SETQ LAST-RUN-COLOR -1.))
                     (T (SETQ LAST-RUN-COLOR -1.)
                        (PUSH (WINDOW-RUN-ENCODE RUN-COLOR RUN-COUNTER) RUN-LIST)
                        (INCREMENT RUN-INDEX))))))]


 

;;*PAGE



[BW 

(DEFUN MAKEWINDOW-STORE (WINDOW-ARRAY TOP-Y BOTTOM-Y LEFT-X RIGHT-X) 
       (LET ((START-BIT (PROG1 (BITWISE-AND LEFT-X 31.) (SETQ LEFT-X (LSH LEFT-X -5.))))
	     (STOP-BIT (PROG1 (BITWISE-AND RIGHT-X 31.) 
                              (SETQ RIGHT-X (LSH RIGHT-X -5.))))
             (START-ADDRESS (TV-ADDRESS TOP-Y LEFT-X))
             (TV-DELTA-Y (- BOTTOM-Y TOP-Y))
             (TV-DELTA-X (- RIGHT-X LEFT-X)))
	    (DO ((DOWN START-ADDRESS (+ DOWN 18.))
                 (STOP-ADDRESS (+ START-ADDRESS (* TV-DELTA-Y 18.)))
		 (WINDOW-ADDRESS 0. (1+ WINDOW-ADDRESS))
		 (STOP-MASK (TO-MASK STOP-BIT)))
		((> DOWN STOP-ADDRESS))
		(DO ((BITS-WANTED (- 32. START-BIT) 32.)
		     ;;BITS REMAINING IN TV WORD.
		     (WINDOW-BIT 0.)
		     ;;WORD AND BIT INDEX INTO WINDOW ARRAY.
		     (ACROSS DOWN)
                     (STOP-ACROSS (+ DOWN TV-DELTA-X))
		     ;;DAMNED PARALLEL ASSIGNMENT!
		     (SOURCE (LSH (TV DOWN) START-BIT)))
	            ((> ACROSS STOP-ACROSS))
		    ;;FOR LAST WORD, MASK OUT BITS PAST RIGHT EDGE, REVISE ESTIMATE
		    ;;OF NEEDED BITS.
		    (AND (= ACROSS STOP-ACROSS)
			 (SETQ SOURCE (BITWISE-AND SOURCE STOP-MASK) 
			       BITS-WANTED (- BITS-WANTED (- 32. STOP-BIT))))
		    ;;STASH THE TV BITS IN THE WINDOW ARRAY.
		    (STORE (ARRAYCALL FIXNUM WINDOW-ARRAY WINDOW-ADDRESS)
			   (BITWISE-OR (ARRAYCALL FIXNUM WINDOW-ARRAY WINDOW-ADDRESS)
				       (LSH SOURCE (- WINDOW-BIT))))
		    (INCREMENT WINDOW-BIT BITS-WANTED)
		    ;;TOO MANY TO FIT IN THAT WORD? USE THE NEXT ONE, TOO.
		    (COND ((> WINDOW-BIT 35.)
                           (DECREMENT WINDOW-BIT 36.)
			   (STORE (ARRAYCALL FIXNUM 
                                             WINDOW-ARRAY 
                                             (INCREMENT WINDOW-ADDRESS))
				  (LSH SOURCE (- BITS-WANTED WINDOW-BIT)))))
                    (SETQ ACROSS (1+ ACROSS) SOURCE (TV ACROSS))))))]


;;*PAGE



[COLOR (DECLARE (SPECIAL WINDOW-PALETTE-TAIL))]

(DEFUN MAKEWINDOW-ARRAY (WINDOW-NAME HOME-X HOME-Y TOP-Y BOTTOM-Y LEFT-X RIGHT-X) 
       (LET ((WINDOW-INFO (MAKNAM (NCONC (EXPLODEC WINDOW-NAME) WINDOW-INFO-TAIL)))
	     (WINDOW-PICTURE (MAKNAM (NCONC (EXPLODEC WINDOW-NAME) WINDOW-PICTURE-TAIL)))
             [COLOR 
              (WINDOW-PALETTE (MAKNAM (NCONC (EXPLODEC WINDOW-NAME) WINDOW-PALETTE-TAIL)))])
	    (COND ((MINUSP TOP-Y)
		   ;;EMPTY WINDOWS ARE MARKED BY HAVING THE FIRST WORD OF INFO ARRAY
		   ;;0.
		   (*ARRAY WINDOW-INFO 'FIXNUM 1.)
		   (*ARRAY WINDOW-PICTURE 'FIXNUM 1.)
                   [COLOR (*ARRAY WINDOW-PALETTE 'FIXNUM 1.)])
		  ((LET ((WINDOW-PICTURE-SIZE-X (1+ (// (- RIGHT-X LEFT-X) 36.)))
			 (WINDOW-PICTURE-SIZE-Y (1+ (- BOTTOM-Y TOP-Y))))
			(*ARRAY WINDOW-INFO 'FIXNUM WINDOW-INFO-DIMENSION)
			[BW (*ARRAY WINDOW-PICTURE
				'FIXNUM
                                (* WINDOW-PICTURE-SIZE-Y WINDOW-PICTURE-SIZE-X))]
			;;LEFT, RIGHT, TOP AND BOTTOM RELATIVE TO HOME, SO THAT EASY
			;;TO COMPUTE NEW ONES WHEN MOVED TO NEW HOME.
                        [COLOR 
                        (FILLARRAY (*ARRAY WINDOW-PALETTE T 16.)
                                   'PALETTE)]
			(FILLARRAY WINDOW-INFO
				   (LIST WINDOW-PICTURE-SIZE-X
					 WINDOW-PICTURE-SIZE-Y
					 HOME-X
					 HOME-Y
					 (- TOP-Y HOME-Y)
					 (- BOTTOM-Y HOME-Y)
					 (- LEFT-X HOME-X)
					 (- RIGHT-X HOME-X)))
			[BW (MAKEWINDOW-STORE (GET WINDOW-PICTURE 'ARRAY)
					  TOP-Y
					  BOTTOM-Y
					  LEFT-X
					  RIGHT-X)]
                        [COLOR 
                         (MAKEWINDOW-STORE-COLOR WINDOW-PICTURE
                                                 TOP-Y
                                                 BOTTOM-Y
                                                 LEFT-X
                                                 RIGHT-X)])))
	    ;;THE WINDOW PROPERTY OF ATOM IS LIST OF THE TWO ARRAYS.
	    (PUTPROP WINDOW-NAME 
                     (LIST WINDOW-INFO WINDOW-PICTURE [COLOR WINDOW-PALETTE]) 
                     'WINDOW)))


(DECLARE (FIXNUM (RUNAWAY-FORWARD FIXNUM FIXNUM FIXNUM)
		 (RUNAWAY-BACKWARD FIXNUM FIXNUM FIXNUM)
		 (MAKEWINDOW-VISIBLE NOTYPE
				     FIXNUM
				     FIXNUM
				     FIXNUM
				     FIXNUM
				     FIXNUM
				     FIXNUM)
		 VISIBLE-TOP VISIBLE-BOTTOM VISIBLE-RIGHT VISIBLE-LEFT
		 FIRST-VISIBLE LAST-VISIBLE)) 

;;*PAGE


(DEFUN MAKEWINDOW-VISIBLE (WINDOW-NAME TV-TOP TV-BOTTOM TV-LEFT TV-RIGHT
			   TV-CENTER-X TV-CENTER-Y) 
       ;;TAKING THE HOME AND BOUNDARIES IN TV COORDINATES, THIS COMPUTES THE EXTREMES OF
       ;;THE AREA IN WHICH CRUD IS ACTUALLY VISIBLE ON THE SCREEN, AND SAVES THE
       ;;STUFF IN THAT AREA.
       (DO ((TRAVEL-Y TV-TOP (1+ TRAVEL-Y))
	    ;;"VISIBLE" VARIABLES MARK EXTREMES OF VISIBLE AREA.  TOP, BOTTOM
	    ;;INITIALIZED TO IMPOSSIBLE VALUE, LEFT & RIGHT INITIALIZED TO EACH
	    ;;OTHER.
	    (VISIBLE-TOP -1.)
	    (VISIBLE-BOTTOM -1.)
	    (VISIBLE-RIGHT TV-LEFT)
	    (VISIBLE-LEFT TV-RIGHT)
	    (FIRST-VISIBLE)
	    ;;FIRST AND LAST VISIBLE POINTS IN A GIVEN LINE.
	    (LAST-VISIBLE))
	   ((> TRAVEL-Y TV-BOTTOM)
	    (MAKEWINDOW-ARRAY WINDOW-NAME
			      TV-CENTER-X
			      TV-CENTER-Y
			      VISIBLE-TOP
			      VISIBLE-BOTTOM
			      VISIBLE-LEFT
			      VISIBLE-RIGHT))
	   (COND ((> (SETQ FIRST-VISIBLE
			   (+ TV-LEFT (RUNAWAY-FORWARD TV-LEFT 
                                                       TRAVEL-Y 
                                                       [BW 0.] 
                                                       [COLOR :ERASERNUMBER])))
		     ;;IS WHOLE LINE CLEAR IN AREA WITHIN WINDOW BOUNDS?
		     TV-RIGHT))
		 ((SETQ VISIBLE-BOTTOM TRAVEL-Y)
		  ;;IF NOT, THIS IS THE LOWEST LINE SO FAR WITH ANYTHING ON IT.
		  (COND ((MINUSP VISIBLE-TOP)
			 ;;IF WE HAVEN'T HIT ANYTHING SO FAR IN DOWNWARD SCAN.
			 (SETQ VISIBLE-TOP TRAVEL-Y)))
		  (COND ((< FIRST-VISIBLE VISIBLE-LEFT)
			 ;;IF TO LEFT OF LEFTMOST POINT SO FAR. 
			 (SETQ VISIBLE-LEFT FIRST-VISIBLE)))
		  (COND ((> (SETQ LAST-VISIBLE
				  (- TV-RIGHT
				     (RUNAWAY-BACKWARD TV-RIGHT 
                                                       TRAVEL-Y 
                                                       [BW 0.]
                                                       [COLOR :ERASERNUMBER])))
			    VISIBLE-RIGHT)
			 (SETQ VISIBLE-RIGHT LAST-VISIBLE))))))) 


;;*PAGE



(DEFINE MAKEWINDOW (ABB MW) ARGS 
	(OR (SYMBOLP (ARG 1.))
	    (SETARG 1.
		    (ERRBREAK 'MAKEWINDOW
			      (LIST (ARG 1.)
				    '"IS NOT A VALID NAME"))))
	(INTERNAL-WINDOW (ARG 1.)
			 (RECTANGLE-SPEC 'MAKEWINDOW (LISTIFY (- 1. ARGS))))) 

(DEFUN INTERNAL-WINDOW (WINDOW-NAME RECTANGLE) 
       (COND (:WINDOWOUTLINE 
              [COLOR (SELECT-COLOR :PENNUMBER)]
              (INTERNAL-WINDOWFRAME RECTANGLE)
              [COLOR (RESELECT-COLOR)]))
       [COLOR (NO-COLOR-WRITE)]
       (APPLY 'MAKEWINDOW-VISIBLE (CONS WINDOW-NAME RECTANGLE))
       ;;ADD TO LIST OF USER NAMED WINDOWS.
       (OR (MEMQ WINDOW-NAME :WINDOWS) (PUSH WINDOW-NAME :WINDOWS))
       [COLOR (COLOR-WRITE)]
       (COND (:WINDOWOUTLINE 
              [COLOR (SELECT-COLOR :ERASERNUMBER)] 
              (INTERNAL-WINDOWFRAME RECTANGLE)
              [COLOR (RESELECT-COLOR)]))
       WINDOW-NAME) 

(ARGS 'MAKEWINDOW '(1. . 5.)) 

(DECLARE (FLONUM NEW-WINDOW-HOME-X NEW-WINDOW-HOME-Y)) 

(DEFINE WINDOWHOME (ABB WH) ARGS 
 ;;CHANGES THE CENTER LOCATION ASSOCIATED WITH A WINDOW.
 (LET
  ((WINDOW-ARRAY (COND ((MEMQ (ARG 1.) :WINDOWS)
			(GET (CAR (GET (ARG 1.) 'WINDOW)) 'ARRAY))
		       ((ERRBREAK 'WINDOWHOME
				  (LIST (ARG 1.)
					'"IS NOT A WINDOW")))))
   (NEW-WINDOW-HOME-X :XCOR)
   (NEW-WINDOW-HOME-Y :YCOR))
  (COND ((= ARGS 1.))
	((= ARGS 2.)
	 (SETQ NEW-WINDOW-HOME-X (FLOAT (CAR (ARG 2.))) 
	       NEW-WINDOW-HOME-Y (FLOAT (CADR (ARG 2.)))))
	((= ARGS 3.)
	 (SETQ NEW-WINDOW-HOME-X (FLOAT (ARG 2.)) 
	       NEW-WINDOW-HOME-Y (FLOAT (ARG 3.)))))
  (STORE (ARRAYCALL FIXNUM WINDOW-ARRAY 2.) (TV-X NEW-WINDOW-HOME-X))
  (STORE (ARRAYCALL FIXNUM WINDOW-ARRAY 3.) (TV-Y NEW-WINDOW-HOME-Y)))) 

(ARGS 'WINDOWHOME '(1. . 3.)) 

[COLOR

(DECLARE (NOTYPE (DISPLAYWINDOW-STORE NOTYPE NOTYPE FIXNUM FIXNUM FIXNUM FIXNUM)
		 (DISPLAYWINDOW-TV NOTYPE NOTYPE FIXNUM FIXNUM))
	 (FIXNUM WINDOW-START-X WINDOW-START-Y WINDOW-START-BIT START-MASK
		 INITIAL-BITS-WANTED TV-START-BIT)) 

(DECLARE (NOTYPE (STORE-IOR-TV FIXNUM FIXNUM FIXNUM))) 

(DEFUN STORE-IOR-TV (TV-ADDRESS NEW-CONTENTS) 
       (WRITE-TV-MASK (BITWISE-NOT (LSH NEW-CONTENTS -20.)))
       (STORE (TV TV-ADDRESS) -12.)
       (WRITE-TV-MASK (BITWISE-NOT (BITWISE-AND RIGHT-HALFWORD (LSH NEW-CONTENTS -4.))))
       (STORE (TV TV-ADDRESS) -8.)
       T) 

;;;END OF COLOR CONDITIONAL SECTION.
]

;;*PAGE


(DECLARE (NOTYPE (DISPLAYWINDOW-WORD FIXNUM FIXNUM FIXNUM FIXNUM FIXNUM))
         (SPECIAL DISPLAYWINDOW-TOP DISPLAYWINDOW-BOTTOM DISPLAYWINDOW-LEFT 
                  DISPLAYWINDOW-RIGHT DISPLAYWINDOW-ARRAY DISPLAYWINDOW-INCREMENT
                  DISPLAYWINDOW-LINES DISPLAYWINDOW-ADDRESS)
         (FIXNUM DISPLAYWINDOW-TOP DISPLAYWINDOW-BOTTOM DISPLAYWINDOW-LEFT 
                 DISPLAYWINDOW-RIGHT DISPLAYWINDOW-X DISPLAYWINDOW-Y DOWN 
                 WINDOW-SHIFT WINDOW-ADDRESS NEW-WINDOW-ADDRESS NEW-WINDOW-SHIFT
                 DISPLAYWINDOW-LINES DISPLAYWINDOW-INCREMENT DISPLAYWINDOW-ADDRESS))

(DEFUN DISPLAYWINDOW-WORD (WINDOW-BIT NEW-WINDOW-BIT ACROSS START-BIT MASK)
       ;;Stores a column of the TV array one word wide with picture from window.
       (COND ((< NEW-WINDOW-BIT 36.)
              ;;There are two cases. One, the TV word can come entirely from one
              ;;word of the window array.
              (DO ((DOWN ACROSS (+ DOWN 18.)) 
                   (WINDOW-ADDRESS DISPLAYWINDOW-ADDRESS 
                                   (+ WINDOW-ADDRESS DISPLAYWINDOW-INCREMENT))
                   (WINDOW-SHIFT (- WINDOW-BIT START-BIT))
                   (STOP-ADDRESS (+ ACROSS DISPLAYWINDOW-LINES)))
                  ((> DOWN STOP-ADDRESS))
                  ;;As much as possible computed outside of this inner loop
                  ;;for efficiency.
                  [BW (STORE (TV DOWN)
                         (BITWISE-AND 
                          (LSH (ARRAYCALL FIXNUM DISPLAYWINDOW-ARRAY WINDOW-ADDRESS)
                                WINDOW-SHIFT)
                          MASK))]
                  [COLOR 
                   (STORE-IOR-TV 
                    DOWN 
                    (BITWISE-AND 
                     (LSH (ARRAYCALL FIXNUM DISPLAYWINDOW-ARRAY WINDOW-ADDRESS)
                          WINDOW-SHIFT)
                     MASK))]))
             ((DO ((DOWN ACROSS (+ DOWN 18.)) 
                   (WINDOW-ADDRESS DISPLAYWINDOW-ADDRESS 
                                   (+ WINDOW-ADDRESS DISPLAYWINDOW-INCREMENT))
                   (NEW-WINDOW-ADDRESS (1+ DISPLAYWINDOW-ADDRESS)
                                 (+ NEW-WINDOW-ADDRESS DISPLAYWINDOW-INCREMENT))
                   (WINDOW-SHIFT (- WINDOW-BIT START-BIT))
                   (NEW-WINDOW-SHIFT (- WINDOW-BIT START-BIT 36.))
                   (STOP-ADDRESS (+ ACROSS DISPLAYWINDOW-LINES)))
                  ;;Here, the TV word breaks over two words of the window array.
                  ((> DOWN STOP-ADDRESS))
                  ([COLOR STORE-IOR-TV DOWN]
                   [BW STORE (TV DOWN)]
                   (BITWISE-AND 
                    (BITWISE-OR 
                     (LSH (ARRAYCALL FIXNUM DISPLAYWINDOW-ARRAY WINDOW-ADDRESS) 
                          WINDOW-SHIFT)
                     (LSH (ARRAYCALL FIXNUM DISPLAYWINDOW-ARRAY NEW-WINDOW-ADDRESS)
                          NEW-WINDOW-SHIFT))
                    MASK)))))
       T)


;;*PAGE



(DECLARE (NOTYPE (DISPLAYWINDOW-STORE NOTYPE NOTYPE FIXNUM FIXNUM FIXNUM FIXNUM))
         (FIXNUM WINDOW-START-Y WINDOW-START-X WINDOW-START-BIT START-MASK STOP-MASK
                 INITIAL-BITS-WANTED ACROSS WINDOW-X WINDOW-BIT))

(DEFUN DISPLAYWINDOW-STORE 
       (DISPLAYWINDOW-INFO DISPLAYWINDOW-ARRAY DISPLAYWINDOW-TOP DISPLAYWINDOW-BOTTOM 
        DISPLAYWINDOW-LEFT DISPLAYWINDOW-RIGHT) 
       (LET
	((DISPLAYWINDOW-Y 0.)
	 (DISPLAYWINDOW-X 0.)
	 ;;FIRST WORD AND BIT TO START IN WINDOW ARRAY.
	 (WINDOW-START-BIT 0.))
	;;IF BEYOND BOUNDS OF DISPLAY AREA, CUT OFF AT BOUNDARY.
	(AND (> DISPLAYWINDOW-BOTTOM TV-PICTURE-BOTTOM) 
             (SETQ DISPLAYWINDOW-BOTTOM TV-PICTURE-BOTTOM))
	(AND (> DISPLAYWINDOW-RIGHT TV-PICTURE-RIGHT) 
             (SETQ DISPLAYWINDOW-RIGHT TV-PICTURE-RIGHT))
	;;IF GREATER THAN MAX TV COORDINATE, JUST STOP WHEN YOU GET TO EDGE.
	(AND (< DISPLAYWINDOW-TOP TV-PICTURE-TOP)
	     (INCREMENT DISPLAYWINDOW-Y (- TV-PICTURE-TOP DISPLAYWINDOW-TOP))
             (SETQ DISPLAYWINDOW-TOP TV-PICTURE-TOP))
	;;IF LESS THAN MIN, YOU'VE GOT TO START IN THE MIDDLE OF THE WINDOW ARRAY.
	(AND (< DISPLAYWINDOW-LEFT TV-PICTURE-LEFT)
	     (SETQ DISPLAYWINDOW-X (- TV-PICTURE-LEFT DISPLAYWINDOW-LEFT) 
		   WINDOW-START-BIT (\ DISPLAYWINDOW-X 36.) 
		   DISPLAYWINDOW-X (// DISPLAYWINDOW-X 36.) 
		   DISPLAYWINDOW-LEFT TV-PICTURE-LEFT))
	(LET
	 ((DISPLAYWINDOW-INCREMENT (ARRAYCALL FIXNUM DISPLAYWINDOW-INFO 0.))
          (START-BIT (BITWISE-AND (PROG1 DISPLAYWINDOW-LEFT 
                                         (SETQ DISPLAYWINDOW-LEFT 
                                               (LSH DISPLAYWINDOW-LEFT -5.))) 31.))
	  (STOP-BIT (BITWISE-AND (PROG1 DISPLAYWINDOW-RIGHT 
                                        (SETQ DISPLAYWINDOW-RIGHT 
                                              (LSH DISPLAYWINDOW-RIGHT -5.))) 31.)))
	 (LET
	  ((START-MASK (FROM-MASK START-BIT))
	   (INITIAL-BITS-WANTED (- 32. START-BIT))
	   (STOP-MASK (TO-MASK STOP-BIT))
           (START-ADDRESS (+ (* DISPLAYWINDOW-TOP 18.) DISPLAYWINDOW-LEFT))
           (DISPLAYWINDOW-LINES (* (- DISPLAYWINDOW-BOTTOM DISPLAYWINDOW-TOP) 18.))
           (DISPLAYWINDOW-ADDRESS (+ (* DISPLAYWINDOW-Y DISPLAYWINDOW-INCREMENT)
                                     DISPLAYWINDOW-X)))
          (COND ((= DISPLAYWINDOW-LEFT DISPLAYWINDOW-RIGHT)
                 ;;Window fits entirely inside one TV word.
                 (DISPLAYWINDOW-WORD WINDOW-START-BIT 
                                     (+ WINDOW-START-BIT (- STOP-BIT START-BIT))
                                     START-ADDRESS
                                     START-BIT
                                     (BITWISE-AND START-MASK STOP-MASK)))
                ((DISPLAYWINDOW-WORD WINDOW-START-BIT
                                     (INCREMENT WINDOW-START-BIT INITIAL-BITS-WANTED)
                                     START-ADDRESS
                                     START-BIT 
                                     START-MASK)
                 ;;Do first partial word, then loop for each successive word.
                 (DO ((ACROSS (1+ START-ADDRESS) (1+ ACROSS))
                      (WINDOW-BIT WINDOW-START-BIT)
                      (STOP-ADDRESS (+ START-ADDRESS 
                                       (- DISPLAYWINDOW-RIGHT DISPLAYWINDOW-LEFT))))
                     ((= ACROSS STOP-ADDRESS)
                      (AND (> WINDOW-BIT 36.) 
                           (INCREMENT DISPLAYWINDOW-ADDRESS) 
                           (DECREMENT WINDOW-BIT 36.))
                      ;;Finally, fill the last partial word.
                      (DISPLAYWINDOW-WORD WINDOW-BIT 
                                          (+ WINDOW-BIT STOP-BIT)
                                          STOP-ADDRESS
                                          0. 
                                          STOP-MASK))
                     (COND ((> WINDOW-BIT 36.)
                            (INCREMENT DISPLAYWINDOW-ADDRESS)
                            (DECREMENT WINDOW-BIT 36.)))
                     (DISPLAYWINDOW-WORD WINDOW-BIT
                                         (INCREMENT WINDOW-BIT 32.) 
                                         ACROSS 
                                         0. 
                                         -16.))))))))
                      
 

[BW 

(DEFINE DISPLAYWINDOW (ABB DW) ARGS 
 (LET
  ((WINDOW-PROP (GET (ARG 1.) 'WINDOW)))
  (COND ((NULL WINDOW-PROP)
	 (SETQ WINDOW-PROP
	       (ERRBREAK 'DISPLAYWINDOW
			 (LIST (ARG 1.)
			       '"IS NOT A WINDOW")))))
  (LET
   ((WINDOW-INFO (GET (CAR WINDOW-PROP) 'ARRAY))
    (WINDOW-PICTURE (GET (CADR WINDOW-PROP) 'ARRAY))
    (HOME-X 0.) (HOME-Y 0.))
   (COND
    ((ZEROP (ARRAYCALL FIXNUM WINDOW-INFO 0.)))
    ;;IS WINDOW EMPTY?
    (T (COND ((= ARGS 1.)
              (SETQ HOME-X (ARRAYCALL FIXNUM WINDOW-INFO 2.)
                    HOME-Y (ARRAYCALL FIXNUM WINDOW-INFO 3.)))
             ((= ARGS 3.)
              (SETQ HOME-X (TV-X (FLOAT (ARG 2.)))
                    HOME-Y (TV-Y (FLOAT (ARG 3.)))))
             ((ERRBREAK 'DISPLAYWINDOW '"WRONG NUMBER OF ARGS TO WINDOW FUNCTION")))
       (ERASE-TURTLES)
       ;;Turtle hidden during execution of window commands.
       (DISPLAYWINDOW-TV WINDOW-INFO WINDOW-PICTURE HOME-X HOME-Y)
       (DRAW-TURTLES)))))) 

;;END OF BLACK AND WHITE CONDITIONAL SECTION.
] 

(DEFUN DISPLAYWINDOW-TV (WINDOW-INFO WINDOW-PICTURE HOME-X HOME-Y) 
       (DISPLAYWINDOW-STORE WINDOW-INFO 
                            WINDOW-PICTURE
			    (+ HOME-Y (ARRAYCALL FIXNUM WINDOW-INFO 4.))
			    (+ HOME-Y (ARRAYCALL FIXNUM WINDOW-INFO 5.))
			    (+ HOME-X (ARRAYCALL FIXNUM WINDOW-INFO 6.))
			    (+ HOME-X (ARRAYCALL FIXNUM WINDOW-INFO 7.))))



;;*PAGE



[COLOR


(DECLARE (NOTYPE (DISPLAYWINDOW-TV-COLOR NOTYPE NOTYPE NOTYPE NOTYPE FIXNUM FIXNUM)))

(DEFUN DISPLAYWINDOW-COLOR ARGS 
 (LET
  ((WINDOW-PROP (GET (ARG 2.) 'WINDOW)))
  (COND ((NULL WINDOW-PROP)
	 (SETQ WINDOW-PROP
	       (ERRBREAK 'DISPLAYWINDOW-COLOR
			 (LIST (ARG 2.)
			       '"IS NOT A WINDOW")))))
  (LET
   ((WINDOW-INFO (GET (CAR WINDOW-PROP) 'ARRAY))
    (WINDOW-PICTURE (GET (CADR WINDOW-PROP) 'ARRAY))
    (WINDOW-PALETTE (GET (CADDR WINDOW-PROP) 'ARRAY))
    (HOME-X 0.) (HOME-Y 0.))
   (COND
    ((ZEROP (ARRAYCALL FIXNUM WINDOW-INFO 0.)))
    ;;IS WINDOW EMPTY?
    (T (COND ((= ARGS 2.)
              (SETQ HOME-X (ARRAYCALL FIXNUM WINDOW-INFO 2.)
                    HOME-Y (ARRAYCALL FIXNUM WINDOW-INFO 3.)))
             ((= ARGS 4.)
              (SETQ HOME-X (TV-X (FLOAT (ARG 3.)))
                    HOME-Y (TV-Y (FLOAT (ARG 4.)))))
             ((ERRBREAK 'DISPLAYWINDOW-COLOR
                        '"WRONG NUMBER OF ARGS TO WINDOW FUNCTION")))
       (ERASE-TURTLES)
       ;;Hide the turtle during execution of window display command.
       (COND (WINDOW-PALETTE (DISPLAYWINDOW-TV-COLOR (ARG 1.) 
                                                     WINDOW-INFO
                                                     WINDOW-PICTURE 
                                                     WINDOW-PALETTE 
                                                     HOME-X 
                                                     HOME-Y))
             ;;If there is a palette, its a color window, else a black and white window.
             ((DISPLAYWINDOW-TV WINDOW-INFO WINDOW-PICTURE HOME-X HOME-Y)))
       (DRAW-TURTLES)))))) 

(DECLARE (NOTYPE (DISPLAYWINDOW-STORE-COLOR NOTYPE NOTYPE NOTYPE FIXNUM FIXNUM FIXNUM FIXNUM)))

(DEFUN DISPLAYWINDOW-TV-COLOR 
       (SHOW? WINDOW-INFO WINDOW-PICTURE WINDOW-PALETTE HOME-X HOME-Y)
       (DISPLAYWINDOW-STORE-COLOR SHOW?  
                                  WINDOW-PICTURE
                                  WINDOW-PALETTE
    			          (+ HOME-Y (ARRAYCALL FIXNUM WINDOW-INFO 4.))
			          (+ HOME-Y (ARRAYCALL FIXNUM WINDOW-INFO 5.))
			          (+ HOME-X (ARRAYCALL FIXNUM WINDOW-INFO 6.))
			          (+ HOME-X (ARRAYCALL FIXNUM WINDOW-INFO 7.))))

;;;END OF COLOR CONDITIONAL SECTION.
]


;;*PAGE


;;Should points in the current :ERASERCOLOR be saved in windows and restored
;;when redisplayed? For consistency with operation of the black and 
;;white system, and with treatment of eraser color as background, currently will
;;not redisplay points in eraser color.
;;Should HIDEWINDOW be treated as displaying all points not in the eraser color in 
;;the window in the current eraser color?


[COLOR

(DECLARE (FIXNUM (DECODE-RUN-COLOR FIXNUM) (DECODE-RUN-COUNTER FIXNUM) 
                 RUN-INDEX RUN-STOP THIS-RUN RUN-END))

(DEFUN DECODE-RUN-COLOR (THIS-RUN) (LSH THIS-RUN MINUS-RUN-COLOR-SHIFT))

(DEFUN DECODE-RUN-COUNTER (THIS-RUN) (BITWISE-AND THIS-RUN RUN-COUNTER-MASK))

(DEFUN DISPLAYWINDOW-STORE-COLOR 
       (SHOW? WINDOW-PICTURE WINDOW-PALETTE TOP-Y BOTTOM-Y LEFT-X RIGHT-X)
       ;;For SHOWWINDOW, palette from saved window. For HIDEWINDOW, :ERASERCOLOR's.
       (AND (OR (< TOP-Y TV-PICTURE-TOP)
                (> BOTTOM-Y TV-PICTURE-BOTTOM)
                (< LEFT-X TV-PICTURE-LEFT)
                (> RIGHT-X TV-PICTURE-RIGHT))
            ;;Someday handle this correctly, for now just error.
            (ERRBREAK 'DISPLAYWINDOW-STORE-COLOR 
                      '"WINDOW OUT OF BOUNDS"))
       (DO ((RUN-INDEX 0. (1+ RUN-INDEX))
            (RUN-START LEFT-X NEXT-RUN-START)
            (RUN-END)
            (NEXT-RUN-START)
            (RUN-Y TOP-Y)
            (RUN-STOP (CADR (ARRAYDIMS WINDOW-PICTURE)))
            (THIS-RUN)
            (RUN-COLOR)
            (RUN-COUNTER))
           ((= RUN-INDEX RUN-STOP))
           (SETQ THIS-RUN (ARRAYCALL FIXNUM WINDOW-PICTURE RUN-INDEX)
                 RUN-COLOR (DECODE-RUN-COLOR THIS-RUN)
                 RUN-COUNTER (DECODE-RUN-COUNTER THIS-RUN)
                 NEXT-RUN-START (+ RUN-START RUN-COUNTER)
                 RUN-END (1- NEXT-RUN-START))
           (DO NIL
               ((NOT (> NEXT-RUN-START RIGHT-X)))
               ;;Runs extending past the end of the line.
               (COND ((= RUN-COLOR :ERASERNUMBER))
                     (T (COND (SHOW? 
                               (PENCOLOR (ARRAYCALL NIL WINDOW-PALETTE RUN-COLOR))))
                        (HORIZONTAL-LINE RUN-START RUN-Y RIGHT-X)))
               (SETQ RUN-COUNTER (- RUN-COUNTER (1+ (- RIGHT-X RUN-START)))
                     RUN-START LEFT-X
                     RUN-Y (1+ RUN-Y)
                     NEXT-RUN-START (+ RUN-START RUN-COUNTER)
                     RUN-END (1- NEXT-RUN-START)))
           (COND ((ZEROP RUN-COUNTER))
                 ((= RUN-COLOR :ERASERNUMBER))
                 ;;Don't bother displaying points in current :ERASERCOLOR.
                 (T (COND (SHOW? (PENCOLOR (ARRAYCALL NIL WINDOW-PALETTE RUN-COLOR))))
                    (HORIZONTAL-LINE RUN-START RUN-Y RUN-END)))))]

 
(DECLARE (SPECIAL WINDOWFRAME-BOUNDS)) 

(DEFINE WINDOWFRAME (ABB WF) ARGS 
	;;DRAWS A BOX TO SHOW EXTENT OF RECTANGULAR AREA FOR WINDOW, XGP COMMANDS.
	(OR (AND (ZEROP ARGS) WINDOWFRAME-BOUNDS)
	    (SETQ WINDOWFRAME-BOUNDS (RECTANGLE-SPEC 'WINDOWFRAME
						     (LISTIFY ARGS))))
	(INTERNAL-WINDOWFRAME WINDOWFRAME-BOUNDS)) 

(DEFUN INTERNAL-WINDOWFRAME (RECTANGLE-SPEC) 
       (LET ((TOP-Y (CAR RECTANGLE-SPEC))
	     (BOTTOM-Y (CADR RECTANGLE-SPEC))
	     (LEFT-X (CADDR RECTANGLE-SPEC))
	     (RIGHT-X (CADDDR RECTANGLE-SPEC))
             [BW (OLD-DRAWMODE (DRAWMODE XOR))])
	    (AND (OR (< LEFT-X TV-PICTURE-LEFT)
		     (> RIGHT-X TV-PICTURE-RIGHT)
		     (< TOP-Y TV-PICTURE-TOP)
		     (> BOTTOM-Y TV-PICTURE-BOTTOM))
		 (ERRBREAK 'WINDOWFRAME
			   '"WINDOW FRAME OUT OF BOUNDS"))
	    (OR (= TOP-Y TV-PICTURE-TOP)
		(HORIZONTAL-LINE (1- LEFT-X) (1- TOP-Y) (1+ RIGHT-X)))
	    (OR (= BOTTOM-Y TV-PICTURE-BOTTOM)
		(HORIZONTAL-LINE (1- LEFT-X) (1+ BOTTOM-Y) (1+ RIGHT-X)))
	    (OR (= LEFT-X TV-PICTURE-LEFT)
		(VERTICAL-LINE (1- LEFT-X) TOP-Y BOTTOM-Y))
	    (OR (= RIGHT-X TV-PICTURE-RIGHT)
		(VERTICAL-LINE (1+ RIGHT-X) TOP-Y BOTTOM-Y))
	    [BW (DRAWMODE OLD-DRAWMODE)])
       NO-VALUE) 

(ARGS 'WINDOWFRAME '(0. . 4.)) 

;;WINDOWS CAN BE SHOWN IN VARIOUS MODES.

[BW

(DEFINE SHOWWINDOW (ABB SW) ARGS (LET ((OLD-DRAWMODE (DRAWMODE IOR)))
				      (APPLY 'DISPLAYWINDOW (LISTIFY ARGS))
				      (DRAWMODE OLD-DRAWMODE))
				 NO-VALUE) 

(DEFINE HIDEWINDOW (ABB HW) ARGS (LET ((OLD-DRAWMODE (DRAWMODE ANDC)))
				      (APPLY 'DISPLAYWINDOW (LISTIFY ARGS))
				      (DRAWMODE OLD-DRAWMODE))
				 NO-VALUE) 

(DEFINE XORWINDOW (ABB XW) ARGS (LET ((OLD-DRAWMODE (DRAWMODE XOR)))
				     (APPLY 'DISPLAYWINDOW (LISTIFY ARGS))
				     (DRAWMODE OLD-DRAWMODE))
				NO-VALUE)

;;;END OF BLACK-AND-WHITE CONDITIONAL SECTION.
] 

[COLOR

(DEFINE SHOWWINDOW (ABB SW) ARGS
        (LET ((OLD-PENCOLOR :PENCOLOR))
             (SELECT-COLOR :PENNUMBER)
             (APPLY 'DISPLAYWINDOW-COLOR (CONS T (LISTIFY ARGS)))
             (RESELECT-COLOR)
             (PENCOLOR OLD-PENCOLOR))
        NO-VALUE)

(DEFINE HIDEWINDOW (ABB HW) ARGS
        (SELECT-COLOR :ERASERNUMBER)
        (APPLY 'DISPLAYWINDOW-COLOR (CONS NIL (LISTIFY ARGS)))
        (RESELECT-COLOR)
        NO-VALUE)

(DEFINE XORWINDOW (ABB XW) ARGS 
        (NOT-IMPLEMENTED-IN-COLOR (CONS 'XORWINDOW (LISTIFY ARGS))))

(DEFINE DISPLAYWINDOW (ABB DW) ARGS 
        (APPLY (COND (:ERASERSTATE (FUNCTION HIDEWINDOW)) ((FUNCTION SHOWWINDOW)))
               (LISTIFY ARGS)))

;;;END OF COLOR CONDITIONAL SECTION.
]
 
(ARGS 'SHOWWINDOW '(1. . 4.))
(ARGS 'HIDEWINDOW '(1. . 4.))
(ARGS 'XORWINDOW '(1. . 4.)) 

(DEFINE ERASEWINDOW (ABB EW) (WINDOW-NAME) 
	(OR (MEMQ WINDOW-NAME :WINDOWS)
	    (ERRBREAK 'ERASEWINDOW
		      (LIST WINDOW-NAME
			    '"IS NOT A WINDOW")))
	(MAPC '*REARRAY (CAR (REMPROP WINDOW-NAME 'WINDOW)))
	(SETQ :WINDOWS (DELQ WINDOW-NAME :WINDOWS))
	(LIST '/; WINDOW-NAME 'ERASED))

(DEFINE FILLWINDOW (ABB FW) ARGS
        (ERASE-TURTLES)
        (LET ((RECTANGLE-SPEC (RECTANGLE-SPEC 'FILLWINDOW (LISTIFY ARGS))))
             (LET ((TOP-Y (CAR RECTANGLE-SPEC))
                   (BOTTOM-Y (CADR RECTANGLE-SPEC))
                   (LEFT-X (CADDR RECTANGLE-SPEC))
                   (RIGHT-X (CADDDR RECTANGLE-SPEC)))
                  (LET ((MASK (FROM-MASK (BITWISE-AND (PROG1 LEFT-X 
                                                             (SETQ LEFT-X 
                                                                   (LSH LEFT-X -5.)))
                                           31.)))
                        (START-X (+ (SETQ TOP-Y (* 18. TOP-Y)) LEFT-X) (1+ START-X))
                        (STOP-X (+ TOP-Y (LSH RIGHT-X -5.)))
                        (STOP-Y (+ (* 18. BOTTOM-Y) 17.))
                        (STOP-MASK (TO-MASK (BITWISE-AND RIGHT-X 31.))))
                       (COND ((= START-X STOP-X)
                              (SETQ MASK (BITWISE-AND MASK STOP-MASK))
                              (DO ((TV-ADDRESS START-X (+ TV-ADDRESS 18.)))
                                  ((> TV-ADDRESS STOP-Y))
                                  ([BW STORE (TV TV-ADDRESS)]
                                   [COLOR STORE-IOR-TV TV-ADDRESS]
                                   MASK)))
                             (T (DO ((TV-ADDRESS START-X (+ TV-ADDRESS 18.)))
                                    ((> TV-ADDRESS STOP-Y))
                                    ([BW STORE (TV TV-ADDRESS)] 
                                     [COLOR STORE-IOR-TV TV-ADDRESS]
                                     MASK))
                                (DO NIL
                                    ((= (INCREMENT START-X) STOP-X))
                                    (DO ((TV-ADDRESS START-X (+ TV-ADDRESS 18.)))
                                        ((> TV-ADDRESS STOP-Y))
                                        ([BW STORE (TV TV-ADDRESS)]
                                         [COLOR STORE-IOR-TV TV-ADDRESS]
                                         -16.)))
                                (DO ((TV-ADDRESS STOP-X (+ TV-ADDRESS 18.)))
                                    ((> TV-ADDRESS STOP-Y))
                                    ([BW STORE (TV TV-ADDRESS)]
                                     [COLOR STORE-IOR-TV TV-ADDRESS]
                                     STOP-MASK)))))))
        (DRAW-TURTLES)
        NO-VALUE)

(ARGS 'FILLWINDOW '(0. . 4))

(DEFINE ERASEWINDOWS (ABB EWS) NIL 
	(MAPC '(LAMBDA (WINDOW) 
		       (MAPC '*REARRAY (CAR (REMPROP WINDOW 'WINDOW))))
	      :WINDOWS)
	(SETQ :WINDOWS NIL)
	'";ALL WINDOWS ERASED") 

;;PRIMITIVES ACTING MORE OR LESS AS IN 11LOGO.

(DECLARE (SETPLIST 'DISPLAY NIL)
	 ;;COMPILER NEEDS TO DISABLE LISP'S STANDARD DISPLAY FUNCTION.
	 (ARGS 'DISPLAY '(NIL . 1.))) 

;;PUTS THE WINDOW AT THE CURRENT TURTLE LOCATION.

(DEFINE DISPLAY (WINDOW) (SHOWWINDOW WINDOW :XCOR :YCOR)) 

(DEFINE SNAP NIL (MAKEWINDOW (GENSYM))) 

;;*PAGE

;;;		SAVING WINDOWS ON DISK FILES
;;;

(DEFINE SAVEWINDOWS (ABB SWS) FEXPR (FILENAME) 
	(DUMPARRAYS (MAPCAN 
		     '(LAMBDA (WINDOW) (APPEND (GET WINDOW 'WINDOW) NIL))
		     :WINDOWS)
		    ;;DEFAULT SECOND FILE NAME FOR WINDOW FILES IS "WINDOW".
		    (FILESPEC (COND ((CDR FILENAME) FILENAME)
				    ((LIST (CAR FILENAME) 'WINDOW)))))
	:WINDOWS) 

;;SAVEWINDOWS AND GETWINDOWS ALLOW WINDOWS TO BE SAVED ON THE DSK IN BINARY FORMAT,
;;RELOADED. 

(DEFINE GETWINDOWS (ABB GW) FEXPR (FILENAME) 
 ;;LOADARRAYS RETURNS A LIST OF 3-LISTS, CONTAINING: GENSYMED ATOM WITH ARRAY
 ;;PROPERTY, OLD NAME OF ARRAY, SIZE.  DUMPING AND LOADING SQUASHES TWO-DIMENSIONAL
 ;;ARRAYS TO ONE DIMENSION -- TWO DIMENSIONS KEPT IN FIRST TWO ELEMENTS OF THE
 ;;ARRAY.
 (LET
  ((LOADARRAY-LIST (LOADARRAYS (FILESPEC (COND ((CDR FILENAME) FILENAME)
					       ((LIST (CAR FILENAME)
						      'WINDOW)))))))
  (COND ((SAME-SUFFIX (CADAR LOADARRAY-LIST) '-WINDOW-INFO) 
         ;;Old or new format window? 
         (GETWINDOWS-RECREATE-ARRAYS LOADARRAY-LIST))
        ((ERRBREAK 'GETWINDOWS '"OLD FORMAT WINDOW -- PLEASE RECREATE WINDOW FILE")))
  :WINDOWS))

;;Currently has feature which converts old window files to new window format.
;;Should be flushed after a while.


(DECLARE (FIXNUM SYMBOL-INDEX SUFFIX-INDEX))

(DEFUN SAME-SUFFIX (SYMBOL SUFFIX)
       (DO ((SYMBOL-INDEX (FLATC SYMBOL) (1- SYMBOL-INDEX))
            (SUFFIX-INDEX (FLATC SUFFIX) (1- SUFFIX-INDEX)))
           ((ZEROP SUFFIX-INDEX) T)
           (OR (= (GETCHARN SYMBOL SYMBOL-INDEX) (GETCHARN SUFFIX SUFFIX-INDEX))
               (RETURN NIL))))


(DEFUN GETWINDOWS-RECREATE-ARRAYS (LOADARRAY-LIST)
  (DO ((GENSYM-PICTURE) (ARRAY-PICTURE) (OLD-NAME-PICTURE) (OLD-WINDOW) (OLD-NAME-INFO)
        (ARRAY-INFO) (GENSYM-INFO) 
        [COLOR (GENSYM-PALETTE) (ARRAY-PALETTE) (OLD-NAME-PALETTE)])
      ((NULL LOADARRAY-LIST) :WINDOWS)
      (SETQ GENSYM-INFO (CAAR LOADARRAY-LIST)
            OLD-NAME-INFO (COPYSYMBOL (CADAR LOADARRAY-LIST) NIL)
            ARRAY-INFO (GET GENSYM-INFO 'ARRAY)
            GENSYM-PICTURE (CAADR LOADARRAY-LIST)
            ARRAY-PICTURE (GET GENSYM-PICTURE 'ARRAY)
            OLD-NAME-PICTURE (COPYSYMBOL (CADADR LOADARRAY-LIST) NIL))
      (SETQ 
       OLD-WINDOW
       (IMPLODE 
        (NREVERSE (CDR (MEMQ '- (CDR (MEMQ '- (NREVERSE (EXPLODEC OLD-NAME-INFO)))))))))
      (PUTPROP OLD-NAME-INFO ARRAY-INFO 'ARRAY)
      (PUTPROP OLD-NAME-PICTURE ARRAY-PICTURE 'ARRAY)
      [BW (PUTPROP OLD-WINDOW (LIST OLD-NAME-INFO OLD-NAME-PICTURE) 'WINDOW)
          (SETQ LOADARRAY-LIST (CDDR LOADARRAY-LIST))]
      [COLOR 
       (COND ((SAME-SUFFIX (SETQ OLD-NAME-PALETTE (CADR (CADDR LOADARRAY-LIST)))
                           '-WINDOW-PALETTE)
              (SETQ GENSYM-PALETTE (CAADDR LOADARRAY-LIST)
                    ARRAY-PALETTE (GET GENSYM-PALETTE 'ARRAY)
                    OLD-NAME-PALETTE (COPYSYMBOL OLD-NAME-PALETTE NIL))
              (PUTPROP OLD-NAME-PALETTE ARRAY-PALETTE 'ARRAY)
              (PUTPROP OLD-WINDOW 
                       (LIST OLD-NAME-INFO OLD-NAME-PICTURE OLD-NAME-PALETTE)
                       'WINDOW)
              (SETQ LOADARRAY-LIST (CDDDR LOADARRAY-LIST)))
             (T (PUTPROP OLD-WINDOW (LIST OLD-NAME-INFO OLD-NAME-PICTURE) 'WINDOW)
                (SETQ LOADARRAY-LIST (CDDR LOADARRAY-LIST))))]
      (OR (MEMQ OLD-WINDOW :WINDOWS) (PUSH OLD-WINDOW :WINDOWS))))



;;*PAGE

;;;

[BW

(COMMENT INVISIBLE MODE) 

;;;

(DECLARE (ARRAY* (NOTYPE VISIBLE-FUNCTIONS 1.)) (SPECIAL VISIBLE-NUMBER)) 


(FILLARRAY (ARRAY VISIBLE-FUNCTIONS T VISIBLE-NUMBER)
	   '(WRITE-TV-POINT VECTOR HORIZONTAL-LINE VERTICAL-LINE DISPLAYWINDOW 
             TV-CLEARSCREEN SHADE STARTDISPLAY)) 

(DEFINE DO-NOTHING ARGS T) 

(DEFINE INVISIBLE NIL 
	(COND ((AND (GET 'INVISIBLE 'SUBR) (NOT NOUUO))
	       ;;CAN'T REALLY WIN IN NOUUO=NIL MODE.
	       (SETQ IOR SAME XOR SAME ANDC SAME)
	       (DRAWMODE SAME))
	      ((DO ((I 0. (1+ I)))
		   ((= I VISIBLE-NUMBER) NO-VALUE)
		   (RPLACD (VISIBLE-FUNCTIONS I)
			   (CONS 'EXPR
				 (CONS 'DO-NOTHING
				       (CDR (VISIBLE-FUNCTIONS I))))))))) 

(DEFINE VISIBLE NIL 
	(COND ((= IOR SAME) (SETQ IOR 3758096384. ANDC 536870912. XOR 1610612736.))
	      ((DO ((I 0. (1+ I)))
		   ((= I VISIBLE-NUMBER))
		   (AND (EQ (GET (VISIBLE-FUNCTIONS I) 'EXPR)
			    'DO-NOTHING)
			(REMPROP (VISIBLE-FUNCTIONS I) 'EXPR)))))
	(CLEARSCREEN)
	NO-VALUE) 

;;;END OF BLACK-AND-WHITE CONDITIONAL SECTION.
] 


;;*PAGE

;;;

(COMMENT RUN LENGTH ENCODING) 

;;;

(DECLARE (FIXNUM (RUN-WORD-FORWARD FIXNUM FIXNUM FIXNUM)
		 (RUN-WORD-BACKWARD FIXNUM FIXNUM FIXNUM)
		 (RUNAWAY-FORWARD FIXNUM FIXNUM FIXNUM)
		 (RUNAWAY-BACKWARD FIXNUM FIXNUM FIXNUM))
	 (NOTYPE (NO-RUN FIXNUM FIXNUM))
	 (FIXNUM PARTIAL-WORD RUN-TYPE START-BIT STOP-BIT RUN-COUNTER START-X
		 START-Y TV-WORD FULL-WORD-RUN START-WORD DIRECTION BITS-WANTED
		 AT-MOST)) 

(DEFUN NO-RUN (PARTIAL-WORD RUN-TYPE) 
       ;;SPECIAL CASE CHECK FOR RUN LENGTH OF ZERO.  HIGH ORDER BIT OF PARTIAL-WORD
       ;;DISAGREES WITH THAT OF RUN TYPE.
       (ZEROP (BITWISE-AND -34359738368. (BOOLE 9. RUN-TYPE PARTIAL-WORD)))) 

;;RUN-WORD-FORWARD AND -BACKWARD PROCESS RUNLENGTHS IN A SINGLE WORD, FORWARD OR
;;BACKWARD STARTING AT A BIT PASSED AS ARGUMENT.  RUNAWAY-FORWARD AND -BACKWARD HAND
;;OFF THE FIRST WORD TO THE PARTIAL WORD SPECIALISTS, ZIP ALONG A WORD AT A TIME
;;UNTIL THE RUN CHANGES, THEN USE THE PARTIAL WORD HACKERS FOR THE LAST WORD.

(DEFUN RUN-WORD-FORWARD (PARTIAL-WORD START-BIT RUN-TYPE) 
       ;;RUN LENGTHS IN PART OF WORD FROM START-BIT RIGHTWARD TO LOW ORDER BIT.
       (COND ((NO-RUN (SETQ PARTIAL-WORD (LSH PARTIAL-WORD START-BIT)) RUN-TYPE) 0.)
	     ;;BOOLE 6 WITH RUN-TYPE FORCES HIGH ORDER RUN TO ZEROS.  HAULONG
	     ;;RETURNS NUMBER OF SIGNIFICANT BITS IN ARG.  AT MOST 32.  BITS OF RUN
	     ;;TO A WORD.
	     ((LET ((BITS-WANTED (- 36. (HAULONG (BOOLE 6. PARTIAL-WORD RUN-TYPE))))
		    (AT-MOST (- 32. START-BIT)))
		   (COND ((< BITS-WANTED AT-MOST) BITS-WANTED) (AT-MOST)))))) 

(DEFUN RUN-WORD-BACKWARD (PARTIAL-WORD STOP-BIT RUN-TYPE) 
       ;;RUN LENGTHS IN PART OF WORD FROM HIGH ORDER BIT RIGHTWARD TO STOP-BIT.  CAN
       ;;THIS BE DONE MORE EFFICIENTLY?
       (SETQ RUN-TYPE (BITWISE-AND RUN-TYPE -34359738368.))
       (DO ((RUN-COUNTER 0. (1+ RUN-COUNTER)))
	   ((OR (MINUSP STOP-BIT)
		;;FINISHED WORD, OR HIGH ORDER BIT CHANGES SIGNALS END OF RUN.
		(MINUSP (BOOLE 6.
			       RUN-TYPE
			       (BITWISE-AND -34359738368.
					    (LSH PARTIAL-WORD STOP-BIT)))))
	    RUN-COUNTER)
	   (DECREMENT STOP-BIT)))

[BW 

(DEFUN RUNAWAY-FORWARD (START-X START-Y RUN-TYPE) 
       (LET ((START-WORD (LSH START-X -5.)) (START-BIT (BITWISE-AND START-X 31.)))
        (LET ((TV-ADDRESS (+ (* START-Y 18.) START-WORD)))
	    (LET ((RUN-COUNTER 
                   (RUN-WORD-FORWARD (TV TV-ADDRESS) START-BIT RUN-TYPE)))
		 (COND ((< RUN-COUNTER (- 32. START-BIT)) RUN-COUNTER)
		       ;;RUN DOESN'T FILL OUT A WHOLE WORD?
		       ((= START-WORD 17.) RUN-COUNTER)
		       ;;END OF SCREEN?
		       ((DO ((FULL-WORD-RUN (COND ((ZEROP RUN-TYPE) 0.) (-16.)))
			     (TV-WORD (TV (INCREMENT TV-ADDRESS)) (TV TV-ADDRESS))
                             ;;STOP-ADDRESS IS FIRST WORD OF NEXT LINE.
                             (STOP-ADDRESS (* (1+ START-Y) 18.)))
			    ;;INCREMENT THE RUN LENGTH A WORD AT A TIME.
			    ((NOT (= TV-WORD FULL-WORD-RUN))
			     ;;ADD IN THE REMAINING PIECE OF THE LAST WORD.
			     (+ RUN-COUNTER (RUN-WORD-FORWARD TV-WORD 0. RUN-TYPE)))
                            (INCREMENT RUN-COUNTER 32.)
			    ;;REACHED THE RIGHT END OF THE SCREEN? IF SO, FINISHED.
			    (AND (= (INCREMENT TV-ADDRESS) STOP-ADDRESS) 
                                 (RETURN RUN-COUNTER))))))))) 

(DEFUN RUNAWAY-BACKWARD (START-X START-Y RUN-TYPE) 
       (LET ((START-WORD (LSH START-X -5.)) 
             (START-BIT (BITWISE-AND START-X 31.))
             (STOP-ADDRESS (* 18. START-Y)))
         (LET ((TV-ADDRESS (+ STOP-ADDRESS START-WORD)))
	    (LET ((RUN-COUNTER 
                   (RUN-WORD-BACKWARD (TV TV-ADDRESS) START-BIT RUN-TYPE)))
		 (COND ((NOT (> RUN-COUNTER START-BIT)) RUN-COUNTER)
		       ((ZEROP START-WORD) RUN-COUNTER)
		       ((DO ((FULL-WORD-RUN (COND ((ZEROP RUN-TYPE) 0.) (-16.)))
			     (TV-WORD (TV (DECREMENT TV-ADDRESS)) (TV TV-ADDRESS)))
			    ((NOT (= TV-WORD FULL-WORD-RUN))
			     (+ RUN-COUNTER
				(RUN-WORD-BACKWARD TV-WORD 31. RUN-TYPE)))
		            (INCREMENT RUN-COUNTER 32.)
			    (AND (< (DECREMENT TV-ADDRESS) STOP-ADDRESS) 
                                 (RETURN RUN-COUNTER)))))))))

 
(DECLARE (FIXNUM (FIND-RIGHT-BOUNDARY FIXNUM FIXNUM) 
                 (FIND-LEFT-BOUNDARY FIXNUM FIXNUM)))

(DEFUN FIND-RIGHT-BOUNDARY (START-X START-Y) 
       (SETQ START-X (+ START-X (RUNAWAY-FORWARD START-X START-Y 0.)))
       ;;RIGHTWARDS RUN UNTIL BOUNDARY REACHED, THEN BACK OFF.
       (COND ((> START-X TV-SCREEN-RIGHT) TV-SCREEN-RIGHT)
             ;;IF PAST THE RIGHT EDGE OF TV SCREEN.
             ((- START-X (RUNAWAY-BACKWARD START-X START-Y -1.)))))

(DEFUN FIND-LEFT-BOUNDARY (START-X START-Y) 
       (SETQ START-X (- START-X (RUNAWAY-BACKWARD START-X START-Y 0.)))
       ;;LEFTWARDS RUN UNTIL BOUNDARY, BACK OFF TO INTERIOR POINT.
       (COND ((MINUSP START-X) 0.)
             ((+ START-X (RUNAWAY-FORWARD START-X START-Y -1.)))))

;;;END OF BLACK-AND-WHITE CONDITIONAL SECTION.
] 



[COLOR 

(DECLARE (FIXNUM (RUN-WORD-FORWARD FIXNUM FIXNUM FIXNUM)
		 (RUN-WORD-BACKWARD FIXNUM FIXNUM FIXNUM)
		 (RUNAWAY-FORWARD FIXNUM FIXNUM FIXNUM)
		 (RUNAWAY-BACKWARD FIXNUM FIXNUM FIXNUM)
		 (FIND-RIGHT-BOUNDARY FIXNUM FIXNUM FIXNUM)
		 (FIND-LEFT-BOUNDARY FIXNUM FIXNUM FIXNUM)
		 (RUN-WORD-FORWARD-COLOR FIXNUM FIXNUM FIXNUM FIXNUM)
		 (RUN-WORD-BACKWARD-COLOR FIXNUM FIXNUM FIXNUM FIXNUM))
	 (NOTYPE (NO-RUN FIXNUM FIXNUM) (FULL-WORD-RUN FIXNUM FIXNUM FIXNUM))
	 (FIXNUM PARTIAL-WORD RUN-TYPE START-BIT STOP-BIT RUN-COUNTER START-X
		 WORD-X START-Y TV-WORD FULL-WORD-RUN START-WORD DIRECTION
		 BITS-WANTED AT-MOST MIN-RUN THIS-RUN GOOD-BIT COLOR-BIT
		 COLOR-BITS))

(DEFUN RUNAWAY-FORWARD (START-X START-Y RUN-COLOR) 
       ;;Color version thereof.
       (LET ((START-WORD (LSH START-X -5.)) (START-BIT (\ START-X 32.)))
	    (LET ((RUN-COUNTER (RUN-WORD-FORWARD-COLOR START-Y
						       START-WORD
						       START-BIT
						       RUN-COLOR)))
		 (COND ((< RUN-COUNTER (- 32. START-BIT)) RUN-COUNTER)
		       ;;RUN DOESN'T FILL OUT A WHOLE WORD?
		       ((= START-WORD 17.) RUN-COUNTER)
		       ;;END OF SCREEN?
		       ((DO ((WORD-X (1+ START-WORD)))
			    ((NOT (FULL-WORD-RUN START-Y WORD-X RUN-COLOR))
			     ;;Mildly inefficient as last word processed twice.
			     (+ RUN-COUNTER
				(RUN-WORD-FORWARD-COLOR START-Y
							WORD-X
							0.
							RUN-COLOR)))
			    (SETQ WORD-X (1+ WORD-X) RUN-COUNTER (+ RUN-COUNTER 32.))
			    ;;REACHED THE RIGHT END OF THE SCREEN? IF SO, FINISHED.
			    (AND (> WORD-X 17.) (RETURN RUN-COUNTER)))))))) 

(DEFUN RUNAWAY-BACKWARD (START-X START-Y RUN-COLOR) 
       (LET ((START-WORD (LSH START-X -5.)) (START-BIT (\ START-X 32.)))
	    (LET ((RUN-COUNTER (RUN-WORD-BACKWARD-COLOR START-Y
							START-WORD
							START-BIT
							RUN-COLOR)))
		 (COND ((< RUN-COUNTER (1+ START-BIT)) RUN-COUNTER)
		       ((ZEROP START-WORD) RUN-COUNTER)
		       ((DO ((WORD-X (1- START-WORD)))
			    ((NOT (FULL-WORD-RUN START-Y WORD-X RUN-COLOR))
			     (+ RUN-COUNTER
				(RUN-WORD-BACKWARD-COLOR START-Y
							 WORD-X
							 31.
							 RUN-COLOR)))
			    (SETQ WORD-X (1- WORD-X) RUN-COUNTER (+ RUN-COUNTER 32.))
			    (AND (MINUSP WORD-X) (RETURN RUN-COUNTER)))))))) 

(DECLARE (FIXNUM (RUNAWAY-FORWARD-BOUNDARY FIXNUM FIXNUM)
		 (RUNAWAY-BACKWARD-BOUNDARY FIXNUM FIXNUM))) 

(DEFUN RUNAWAY-FORWARD-BOUNDARY (START-X START-Y) 
       (RUNAWAY-FORWARD START-X START-Y (READ-TV-POINT-NUMBER START-X START-Y))) 

(DEFUN RUNAWAY-BACKWARD-BOUNDARY (START-X START-Y) 
       (RUNAWAY-BACKWARD START-X START-Y (READ-TV-POINT-NUMBER START-X START-Y))) 

(DEFUN FIND-RIGHT-BOUNDARY (START-X START-Y RUN-COLOR) 
       (SETQ START-X (+ START-X (RUNAWAY-FORWARD START-X START-Y RUN-COLOR)))
       ;;RIGHTWARDS RUN UNTIL BOUNDARY REACHED, THEN BACK OFF.
       (COND ((> START-X TV-SCREEN-RIGHT) TV-SCREEN-RIGHT)
             ((- START-X (RUNAWAY-BACKWARD-BOUNDARY START-X START-Y)))))

(DEFUN FIND-LEFT-BOUNDARY (START-X START-Y RUN-COLOR) 
       (SETQ START-X (- START-X (RUNAWAY-BACKWARD START-X START-Y RUN-COLOR)))
       ;;LEFTWARDS RUN UNTIL BOUNDARY, BACK OFF TO INTERIOR POINT.
       (COND ((MINUSP START-X) 0.)
             ((+ START-X (RUNAWAY-FORWARD-BOUNDARY START-X START-Y))))) 

(DEFUN FULL-WORD-RUN (START-Y START-X RUN-COLOR) 
       ;;Returns T if whole word at location is the right color.
       (DO ((COLOR-BIT 0. (1+ COLOR-BIT)) (TV-WORD) (GOOD-BIT))
	   ((= COLOR-BIT COLOR-BITS) T)
	   (SELECT-TV-BUFFER COLOR-BIT)
	   (SETQ TV-WORD (READ-TV START-Y START-X))
	   (COND ((ZEROP (SETQ GOOD-BIT
			       (BITWISE-AND 1. (LSH RUN-COLOR (- COLOR-BIT)))))
		  ;;If selected bit is zero, word should be -1 [remember, memory in
		  ;;complemented state], or vice versa.
		  (COND ((= TV-WORD -16.)) ((RETURN NIL))))
		 ((ZEROP TV-WORD))
		 ((RETURN NIL))))) 

(DEFUN RUN-WORD-FORWARD-COLOR (START-Y START-WORD START-BIT RUN-COLOR) 
       ;;Color version essentially takes minimum run on each of the bits.
       (DO ((MIN-RUN 32.) (THIS-RUN) (COLOR-BIT 0. (1+ COLOR-BIT)))
	   ((= COLOR-BIT COLOR-BITS) MIN-RUN)
	   (SELECT-TV-BUFFER COLOR-BIT)
	   (SETQ THIS-RUN
		 ;;Call ordinary single word run length hacker.
		 (RUN-WORD-FORWARD (BITWISE-NOT (READ-TV START-Y START-WORD))
				   ;;Remember, memory complemented!!!
				   START-BIT
				   (- (BITWISE-AND 1.
						   (LSH RUN-COLOR (- COLOR-BIT))))))
	   (COND ((< THIS-RUN MIN-RUN) (SETQ MIN-RUN THIS-RUN))))) 

(DEFUN RUN-WORD-BACKWARD-COLOR (START-Y START-WORD START-BIT RUN-COLOR) 
       ;;Color version essentially takes minimum run on each of the bits.
       (DO ((MIN-RUN 32.) (THIS-RUN) (COLOR-BIT 0. (1+ COLOR-BIT)))
	   ((= COLOR-BIT COLOR-BITS) MIN-RUN)
	   (SELECT-TV-BUFFER COLOR-BIT)
	   (SETQ THIS-RUN
		 ;;Call ordinary single word run length hacker.
		 (RUN-WORD-BACKWARD (BITWISE-NOT (READ-TV START-Y START-WORD))
				    START-BIT
				    (- (BITWISE-AND 1.
						    (LSH RUN-COLOR (- COLOR-BIT))))))
	   (COND ((< THIS-RUN MIN-RUN) (SETQ MIN-RUN THIS-RUN)))))

;;;END OF COLOR CONDITIONAL SECTION.
]
 
;;*PAGE

;;;

(COMMENT SHADING) 

;;;
;;THE SHADE PRIMITIVE SHADES IN AN AREA ENCLOSING THE TURTLE'S CURRENT LOCATION,
;;SPEICFYING A PATTERN AND OPTIONALY BOUNDARIES.  THE AREA IS BOUNDED BY PRESUMABLY
;;A CLOSED CURVE DRAWN BY THE TURTLE IN PENDOWN MODE.  A PATTERN IS SPECIFIED BY A
;;FUNCTION, WHICH GIVEN THE LOCATION TO BE SHADED, TELLS HOW TO SHADE THAT LOCATION. 
;;THE FUNCTION SHOULD ACCEPT TWO INTEGER ARGUMENTS, X [WORD] AND Y [BIT] SPECIFYING
;;A WORD IN THE TV MEMORY, AND RETURN A FIXNUM INDICATING THE STATE OF THE 32 BITS,
;;LEFT JUSTIFIED.
;;;
;;STARTING AT THE TURTLE'S LOCATION, SUCCESSIVE HORIZONTAL LINES ARE SHADED, UPWARDS
;;AND DOWNWARD, UNTIL THE ENTIRE FIGURE IS SHADED.  SINCE 32 BITS CAN BE SET AT ONCE
;;BY A SINGLE MEMORY WRITE, A HORIZONTAL SCANNING PROCESS RESULTS IN THE FASTEST
;;POSSIBLE SHADING.  SHADE-VERTICALLY INITIATES THE VERTICAL SCAN.  FOR EACH
;;HORIZONTAL LINE, STARTING AT A POINT KNOWN TO BE IN THE INTERIOR OF THE FIGURE, WE
;;SEARCH LEFT AND RIGHT UNTIL WE HIT THE BOUNDARY OF THE FIGURE.  LEFT-X AND RIGHT-X
;;ARE LAST INTERIOR POINTS BEFORE LEFT AND RIGHT BOUNDARY, RESPECTIVELY.  THE
;;PREVIOUS VALUES OF LEFT-X AND RIGHT-X FOR THE IMMEDIATELY LAST LINE SHADED ARE
;;ALWAYS KEPT AS SHADED-LEFT-X AND SHADED-RIGHT-X.  WHEN LEFT-X EXCEEDS THE LAST
;;VALUE OF SHADED-RIGHT-X, WE'VE HIT THE TOP OR BOTTOM BOUNDARY OF THE FIGURE, AND
;;VERTICAL SHADING IS TERMINATED.  THE NEXT HORIZONTAL LINE IS SHADED STARTING FROM
;;THE POINT IN THE COLUMN OF PREVIOUS LEFT-X.
;;;
;;THE SUBTLETLY IN THE PROGRAM CONSISTS OF TWO REFINEMENTS TO THE ABOVE NAIVE
;;PROCEDURE.  FIRST, WE HAVE TO BE ABLE TO SHADE "AROUND CORNERS".  THERE ARE 3
;;TYPES OF CORNERS THAT CAN OCCUR: [ASSUME SHADING IS PROCEDING UPWARD, POINTS ON
;;MARKED WITH "|".]
;;;
;;;         ||LEFT-X                RIGHT-X|||| NEW SCAN [UP]   ||
;;;         ||							||
;;;         ||SHADED-LEFT-X   ..INTERIOR...       SHADED-RIGHT-X||
;;;
;;;--------------------------------------------------------------------------------
;;ABOVE IS "S-TURN" -- NEW SCAN PROCEEDS IN SAME DIRECTION AS OLD.  BELOW ARE
;;"U-TURNS" SHADING PROCEEDS IN OPPOSITE DIRECTION.
;;;
;;;         ||LEFT-X                                         RIGHT-X||
;;;	    ||							    ||
;;;         ||SHADED-LEFT-X    SHADED-RIGHT-X||||| NEW SCAN [DOWN]  ||
;;;
;;;--------------------------------------------------------------------------------
;;;
;;;         ||LEFT-X  ..INTERIOR...                              RIGHT-X||
;;;	    ||                                                          ||
;;;         ||    NEW SCAN [DOWN]   ||||||SHADED-LEFT-X   SHADED-RIGHT-X||
;;;
;;;--------------------------------------------------------------------------------
;;;
;;EACH NEW SCAN CAUSED BY TURNING A CORNER CAUSES A RECURSIVE CALL TO
;;SHADE-VERTICALLY.  IT IS NOT NECESSARY TO DETECT THE FOURTH CASE, WHERE LEFT-X
;;INCREASES, SINCE THE SCAN IN THE NEXT LINE IS STARTED FROM LEFT-X. 
;;;
;;THE SHADING PROCESS MUST ALSO KEEP SOME INFORMATION ABOUT WHERE IT HAS BEEN.  IT
;;MUST KEEP TRACK OF WHAT AREAS HAVE ALREADY BEEN SHADED, SO THAT THE PROCESS CAN BE
;;TERMINATED WHEN SHADING AN AREA WITH HOLES, PREVENTING THE SCAN FROM CIRCLING THE
;;HOLE FOREVER.  SINCE AN ARBITRARY SHADING PATTERN MAY BE USED, NO INFORMATION ON
;;THE SCREEN CAN BE USED TO DETECT WHEN SCAN REACHES A PREVIOUSLY SHADED REGION. 
;;THE PROGRAM KEEPS TWO LISTS OF "OPEN" EDGES, WHICH MIGHT BE REACHED BY A VERTICAL
;;SCAN.  INITIALLY, AND WHEN A RECURSIVE CALL TO SHADE-VERTICALLY IS MADE, THE LAST
;;SHADED EDGE IS PUT ON THE LIST OF OPEN EDGES IN THE DIRECTION OF VERTICAL SHADING. 
;;EDGES ARE REMOVED WHEN SAFE, I.E.  WHEN THE CALL RETURNS.  THE LISTS ARE ORDERED
;;VERTICALLY, AND THE CLOSEST EDGE IS COMPUTED INITIALLY, TO SAVE SEARCHING THE
;;LIST.  AS THE VERTICAL SHADING PROCEEDS, IT IS CHECKED AGAINST THE OPPOSITE
;;DIRECTION OPEN EDGE, AND SHADING STOPS IF IT HITS. 
;;;

(DECLARE (NOTYPE (INTERNAL-SHADE NOTYPE FIXNUM FIXNUM)
		 (SHADE-HORIZONTAL-LINE FIXNUM FIXNUM FIXNUM))) 

(DECLARE (FIXNUM START-X START-Y TRAVEL-X TRAVEL-Y HORIZONTAL-DIRECTION
		 VERTICAL-DIRECTION INITIAL-LEFT-BOUNDARY INITIAL-RIGHT-BOUNDARY
		 RETURN-LEFT RETURN-RIGHT SHADED-LEFT-X SHADED-RIGHT-X MASK STOP-X
		 LEFT-X RIGHT-X SHADED-Y CLOSEST-OPEN)
	 (SPECIAL SHADING-PATTERN)) 

(DECLARE (SPECIAL PATTERN-WINDOW PATTERN-INFO 
                  PATTERN-WINDOW-SIZE-X PATTERN-WINDOW-SIZE-Y)
	 (FIXNUM (INVOKE-WINDOW-PATTERN FIXNUM FIXNUM) PATTERN-WINDOW-SIZE-X
		 PATTERN-WINDOW-SIZE-Y)
         (NOTYPE (SHADE-FUNCTION-PATTERN NOTYPE FIXNUM FIXNUM)
                 (SHADE-WINDOW-PATTERN NOTYPE FIXNUM FIXNUM)))

(DEFINE SHADE ARGS 
	(LET ([BW (OLD-DRAWMODE (DRAWMODE IOR))]
	      (TV-XCOR (TV-X :XCOR))
	      (TV-YCOR (TV-Y :YCOR))
              (PATTERN))
	     ;;TURTLE HIDDEN DURING SHADING SO AS NOT TO MESS UP SEARCH FOR
	     ;;BOUNDARIES.  WILL REAPPEAR AFTER SHADING.
	     (ERASE-TURTLES)
             [COLOR (NO-COLOR-WRITE)]
	     ;;DEFAULT SHADING PATTERN IS SOLID.
	     (COND ((ZEROP ARGS) (INTERNAL-SHADE (EXPR-FUNCTION SOLID) TV-XCOR TV-YCOR))
                   ((SETQ PATTERN (GET (ARG 1.) 'WINDOW))
		    (SHADE-WINDOW-PATTERN PATTERN TV-XCOR TV-YCOR))
                   ((SETQ PATTERN (FUNCTION-PROP (ARG 1.)))
                    (COND ((EQ (CAR PATTERN) 'SUBR) 
                           (INTERNAL-SHADE (CADR PATTERN) TV-XCOR TV-YCOR))
                          ((SHADE-FUNCTION-PATTERN (ARG 1.) TV-XCOR TV-YCOR))))
                   ((ERRBREAK 'SHADE (LIST (ARG 1.) '"IS NOT A SHADING PATTERN"))))
             [COLOR (COLOR-WRITE)]
	     (DRAW-TURTLES)
	     [BW (DRAWMODE OLD-DRAWMODE)]
	     NO-VALUE)) 

(DEFUN SHADE-WINDOW-PATTERN (WINDOW-PROP TV-XCOR TV-YCOR) 
       (LET ((PATTERN-WINDOW (GET (CADR WINDOW-PROP) 'ARRAY)))
	    (LET ((PATTERN-INFO (GET (CAR WINDOW-PROP) 'ARRAY)))
		 (LET ((PATTERN-WINDOW-SIZE-X (1+ (- (ARRAYCALL FIXNUM
								PATTERN-INFO
								7.)
						     (ARRAYCALL FIXNUM
								PATTERN-INFO
								6.))))
		       (PATTERN-WINDOW-SIZE-Y (1+ (- (ARRAYCALL FIXNUM
								PATTERN-INFO
								5.)
						     (ARRAYCALL FIXNUM
								PATTERN-INFO
								4.)))))
		      (INTERNAL-SHADE (EXPR-FUNCTION INVOKE-WINDOW-PATTERN) 
                                      TV-XCOR 
                                      TV-YCOR)))))

(DECLARE (SPECIAL FUNCTION-PATTERN) (FIXNUM (INVOKE-FUNCTION-PATTERN FIXNUM FIXNUM)))

(DEFUN SHADE-FUNCTION-PATTERN (FUNCTION-PATTERN TV-XCOR TV-YCOR)
       (INTERNAL-SHADE (EXPR-FUNCTION INVOKE-FUNCTION-PATTERN) TV-XCOR TV-YCOR))

(DEFUN INVOKE-FUNCTION-PATTERN (START-X START-Y) 
       (FUNCALL FUNCTION-PATTERN START-X START-Y))

(DECLARE (FIXNUM NEW-EDGE-Y)) 



[BW  

(DEFUN SHADE-HORIZONTAL-LINE (FROM-X FROM-Y TO-X) 
       ;;THIS IS BASICALLY THE SAME CODE AS HORIZONTAL-LINE.  I DIDN'T MERGE THEM
       ;;BECAUSE DRAWING LINES NEEDS TO HAPPEN ABSOLUTELY AS FAST AS POSSIBLE.
       (DO ((MASK (BITWISE-AND (FROM-MASK (BITWISE-AND (PROG1 FROM-X 
                                                    (SETQ FROM-X (LSH FROM-X -5.)))
					      31.))
			       (EXPR-CALL-FIXNUM SHADING-PATTERN FROM-X FROM-Y))
		  (EXPR-CALL-FIXNUM SHADING-PATTERN (INCREMENT FROM-X) FROM-Y))
            (TV-ADDRESS (+ (* 18. FROM-Y) FROM-X) (1+ TV-ADDRESS))
	    (STOP-ADDRESS (+ (* 18. FROM-Y) (LSH TO-X -5.))))
           ((= TV-ADDRESS STOP-ADDRESS)
            (STORE (TV STOP-ADDRESS) 
                   (BITWISE-AND MASK (TO-MASK (BITWISE-AND TO-X 31.))))
            T)
	   (STORE (TV TV-ADDRESS) MASK)))


(DEFUN RUNAWAY-FORWARD-BOUNDARY (START-X START-Y) (RUNAWAY-FORWARD START-X START-Y -1.))

(DEFUN RUNAWAY-BACKWARD-BOUNDARY (START-X START-Y) (RUNAWAY-BACKWARD START-X START-Y -1.))

;;;END OF BLACK-AND-WHITE CONDITIONAL SECTION.
] 


[COLOR


(DEFUN SHADE-HORIZONTAL-LINE (FROM-X FROM-Y TO-X) 
       (COLOR-WRITE)
       (LET ((START-WORD (LSH FROM-X -5.))
	     (START-BIT (BITWISE-AND FROM-X 31.))
	     (STOP-WORD (LSH TO-X -5.))
	     (STOP-BIT (BITWISE-AND TO-X 31.)))
	    (COND ((= START-WORD STOP-WORD)
		   (STORE-TV-FIELD (+ (* 18. FROM-Y) START-WORD)
				   (EXPR-CALL-FIXNUM SHADING-PATTERN
						     START-WORD
						     FROM-Y)
				   START-BIT
				   STOP-BIT))
		  (T (STORE-TV-FIELD (+ (* FROM-Y 18.) START-WORD)
				     (EXPR-CALL-FIXNUM SHADING-PATTERN
						       START-WORD
						       FROM-Y)
				     START-BIT
				     31.)
		     (WRITE-TV-MASK 0.)
		     (DO ((TV-ADDRESS (* 18. FROM-Y))
                          (WORD-X (1+ START-WORD) (1+ WORD-X)))
			 ((= WORD-X STOP-WORD)
                          (STORE-TV-FIELD 
                           (+ TV-ADDRESS STOP-WORD)
                           (EXPR-CALL-FIXNUM SHADING-PATTERN STOP-WORD FROM-Y)
                           0.
                           STOP-BIT))
			 (STORE (TV (+ TV-ADDRESS WORD-X))
				(EXPR-CALL-FIXNUM SHADING-PATTERN WORD-X FROM-Y))))))
       (NO-COLOR-WRITE))

;;;END OF COLOR CONDITIONAL SECTION.
]




(DECLARE (NOTYPE (INTERNAL-SHADE NOTYPE FIXNUM FIXNUM)
                 (SHADE-VERTICALLY FIXNUM FIXNUM FIXNUM FIXNUM NOTYPE NOTYPE 
                                   [COLOR FIXNUM])
                 (SHADE-HORIZONTAL-LINE FIXNUM FIXNUM FIXNUM))
         (FIXNUM (RUNAWAY-FORWARD-INTERIOR FIXNUM FIXNUM)
                 (RUNAWAY-BACKWARD-INTERIOR FIXNUM FIXNUM))
         (FIXNUM INITIAL-LEFT INITIAL-RIGHT VERTICAL-DIRECTION TRAVEL-Y LEFT-X RIGHT-X
                 OPEN-Y OPEN-LEFT OPEN-RIGHT INTERIOR-RIGHT INTERIOR-LEFT INTERIOR-X))

(DECLARE (EVAL (READ)))

;;Conditional switch for debugging showing visual progress of shading scans,
;;by blacking out open edges.

(OR (BOUNDP 'DEBUG-SHADE) (SETQ DEBUG-SHADE NIL))

(DEFUN INTERNAL-SHADE (SHADING-PATTERN START-X START-Y) 
       [BW (AND (READ-TV-POINT START-X START-Y)
                (ERRBREAK 'SHADE '"SHADING MUST START INSIDE A CLOSED CURVE"))]
       ;;Shade up and down from starting point. Initial point must be off.
      (LET ([COLOR (AREA-COLOR (READ-TV-POINT-NUMBER START-X START-Y))])
       (LET ((INITIAL-LEFT (FIND-LEFT-BOUNDARY START-X START-Y [COLOR AREA-COLOR]))
             ;;Boundaries from starting point.
	     (INITIAL-RIGHT (FIND-RIGHT-BOUNDARY START-X START-Y [COLOR AREA-COLOR])))
            ;;Shade the first line found.
            (SHADE-HORIZONTAL-LINE INITIAL-LEFT START-Y INITIAL-RIGHT)
            (LET ((INITIAL-EDGE (LIST START-Y INITIAL-LEFT INITIAL-RIGHT)))
                 (DO ((OPEN-SAME (LIST 'OPEN-POSITIVE INITIAL-EDGE))
                      ;;Lists of vertical scans yet to be performed, one
                      ;;of scans in the same direction as VERTICAL-DIRECTION,
                      ;;one opposite. The upward scans are ordered from top to
                      ;;bottom, the downward scans bottom to top.
                      (OPEN-OPPOSITE (LIST 'OPEN-NEGATIVE INITIAL-EDGE))
                      ;;Initial scan is in downward direction.
                      (VERTICAL-DIRECTION 1.)
                      (COMPARE-Y GREATER-SUBR)
                      (SCAN-EDGE))
                     ((COND ((NULL (CDR OPEN-SAME))
                             ;;No more scans to be done in this direction. If none
                             ;;in the other direction as well, stop. Else reverse
                             ;;directions.
                             (COND ((NULL (CDR OPEN-OPPOSITE)))
                                   (T (SETQ OPEN-OPPOSITE 
                                            (PROG1 OPEN-SAME 
                                                   (SETQ OPEN-SAME OPEN-OPPOSITE))
                                            VERTICAL-DIRECTION (- VERTICAL-DIRECTION)
                                            COMPARE-Y (COND ((EQ COMPARE-Y GREATER-SUBR)
                                                             LESS-SUBR)
                                                            (GREATER-SUBR)))
                                      NIL)))))
                     ;;Remove the edge to be scanned from the OPEN-SAME list,
                     ;;and send it off to start a vertical shading scan.
                     (SHADE-VERTICALLY (CADR (SETQ SCAN-EDGE (CADR OPEN-SAME))) 
                                       (CAR SCAN-EDGE) 
                                       (CADDR SCAN-EDGE)
                                       VERTICAL-DIRECTION  
                                       (RPLACD OPEN-SAME (CDDR OPEN-SAME))
                                       ;;Only pass along the part of the list
                                       ;;which will be past the start of the scan.
                                       (DO ((REST-OPEN OPEN-OPPOSITE (CDR REST-OPEN)))
                                           ((OR (NULL (CDR REST-OPEN))
                                                (SUBRCALL NIL COMPARE-Y 
                                                         (CAADR REST-OPEN)
                                                         (CAR SCAN-EDGE)))
                                            REST-OPEN))
                                       [COLOR AREA-COLOR]))))))


;;*PAGE


(DEFUN OPEN-INCLUDE (OPEN-EDGE OPEN-LIST)
       [DEBUG-SHADE 
        (HORIZONTAL-LINE (CADR OPEN-EDGE) (CAR OPEN-EDGE) (CADDR OPEN-EDGE))]
       (RPLACD OPEN-LIST (CONS OPEN-EDGE (CDR OPEN-LIST))))

[DEBUG-SHADE (DEFUN SHADE-OPEN (LEFT Y RIGHT)
                    (DRAWMODE ANDC)
                    (HORIZONTAL-LINE LEFT Y RIGHT)
                    (DRAWMODE IOR)
                    (SHADE-HORIZONTAL-LINE LEFT Y RIGHT))]

;;These two functions start on a point assumed to be neighboring the border, 
;;return the next point in that direction which could be in the interior of a region.



[BW (DECLARE (FIXNUM (FIND-INTERIOR-FORWARD FIXNUM FIXNUM)
                     (FIND-INTERIOR-BACKWARD FIXNUM FIXNUM)))

    (DEFUN FIND-INTERIOR-FORWARD (INTERIOR-X INTERIOR-Y)
           ;;Increment the point to get onto the border, compute run from there.
           (+ (INCREMENT INTERIOR-X) (RUNAWAY-FORWARD INTERIOR-X INTERIOR-Y -1.)))

    (DEFUN FIND-INTERIOR-BACKWARD (INTERIOR-X INTERIOR-Y)
           (- (DECREMENT INTERIOR-X) (RUNAWAY-BACKWARD INTERIOR-X INTERIOR-Y -1.)))]

[COLOR (DECLARE (FIXNUM (FIND-INTERIOR-FORWARD FIXNUM FIXNUM FIXNUM)
                        (FIND-INTERIOR-BACKWARD FIXNUM FIXNUM)
                        BORDER-COLOR))

       (DEFUN FIND-INTERIOR-FORWARD (INTERIOR-X INTERIOR-Y INTERIOR-COLOR)
              (DO ((BORDER-COLOR 
                    (READ-TV-POINT-NUMBER (INCREMENT INTERIOR-X) INTERIOR-Y)
                    ;;The color of the next border region.
                    (READ-TV-POINT-NUMBER INTERIOR-X INTERIOR-Y)))
                  ((= BORDER-COLOR INTERIOR-COLOR) INTERIOR-X)
                  ;;Stop when the color is the same as the interior.
                  (SETQ INTERIOR-X 
                        (+ INTERIOR-X (RUNAWAY-FORWARD INTERIOR-X 
                                                       INTERIOR-Y 
                                                       BORDER-COLOR)))
                  (AND (> INTERIOR-X TV-PICTURE-RIGHT) (RETURN INTERIOR-X))))

       (DEFUN FIND-INTERIOR-BACKWARD (INTERIOR-X INTERIOR-Y INTERIOR-COLOR)
              (DO ((BORDER-COLOR 
                    (READ-TV-POINT-NUMBER (DECREMENT INTERIOR-X) INTERIOR-Y)
                    (READ-TV-POINT-NUMBER INTERIOR-X INTERIOR-Y)))
                  ((= BORDER-COLOR INTERIOR-COLOR) INTERIOR-X)
                  (SETQ INTERIOR-X 
                        (- INTERIOR-X (RUNAWAY-BACKWARD INTERIOR-X 
                                                        INTERIOR-Y 
                                                        BORDER-COLOR)))
                  (AND (< INTERIOR-X TV-PICTURE-LEFT) (RETURN INTERIOR-X))))]




;;*PAGE


(DEFUN SHADE-VERTICALLY (SHADED-LEFT SHADED-Y SHADED-RIGHT VERTICAL-DIRECTION
                         OPEN-SAME OPEN-OPPOSITE [COLOR AREA-COLOR])
       ;;This function performs the vertical shading scan. The first 3 args
       ;;are a previously shaded edge from which to start. VERTICAL-DIRECTION is +1 
       ;;or -1. The OPEN variables are lists of pending vertical scans.
       [DEBUG-SHADE (SHADE-OPEN SHADED-LEFT SHADED-Y SHADED-RIGHT)]
       (DO ((TRAVEL-Y (+ SHADED-Y VERTICAL-DIRECTION))
            (STOP-Y (COND ((MINUSP VERTICAL-DIRECTION) TV-PICTURE-TOP)
                          (TV-PICTURE-BOTTOM)))
            (LEFT-X) 
            (RIGHT-X) 
            (NONE-OPEN (NULL (CDR OPEN-OPPOSITE)))
            (OPEN-Y (CAADR OPEN-OPPOSITE))
            (OPEN-LEFT (CADADR OPEN-OPPOSITE))
            (OPEN-RIGHT (CADDR (CADR OPEN-OPPOSITE)))
            (MEET-OPEN NIL)
            (INTERIOR-X))
           ;;End the scan after meeting an open edge.
           (MEET-OPEN)
           (AND (= TRAVEL-Y STOP-Y) (RETURN T))
           ;;Stop if past legal display area.
           (DO NIL
               ;;This loop checks to see if scan meets the closest open edge.
               ((COND (NONE-OPEN)
                      ;;If none exist, or haven't yet reached closest Y value, 
                      ;;answer is NO.
                      ((NOT (= TRAVEL-Y OPEN-Y)))
                      ((AND (NOT (< SHADED-LEFT OPEN-LEFT))
                            (NOT (> SHADED-LEFT OPEN-RIGHT)))
                       ;;If within X values for open edge, answer is YES.
                       (SETQ MEET-OPEN T))))
               ;;Otherwise, we met an edge to the left or right of current scan
               ;;starting point. Pop it off and run the next one around the loop.
               (COND ((SETQ NONE-OPEN (NULL (CDR (POP OPEN-OPPOSITE)))))
                     ((SETQ OPEN-Y (CAADR OPEN-OPPOSITE)
                            OPEN-LEFT (CADADR OPEN-OPPOSITE)
                            OPEN-RIGHT (CADDR (CADR OPEN-OPPOSITE))))))
           (COND (MEET-OPEN
                  ;;If we met an open edge, make the current edge the piece of
                  ;;the open edge from the start point of the scan.
                  (SETQ LEFT-X SHADED-LEFT RIGHT-X OPEN-RIGHT)
                  (COND ((> SHADED-LEFT OPEN-LEFT)
                         ;;If there's any piece of the open edge that still needs
                         ;;to be done, alter its RIGHT X component.
                         [DEBUG-SHADE
                          (SHADE-OPEN OPEN-LEFT OPEN-Y OPEN-RIGHT)
                          (HORIZONTAL-LINE OPEN-LEFT OPEN-Y (1- SHADED-LEFT))]
                         (RPLACA (CDDADR OPEN-OPPOSITE) (1- SHADED-LEFT)))
                        ;;Otherwise, just remove the whole thing.
                        (T [DEBUG-SHADE 
                            (SHADE-OPEN (CADADR OPEN-OPPOSITE)
                                        (CAADR OPEN-OPPOSITE)
                                        (CADDR (CADR OPEN-OPPOSITE)))]
                           (RPLACD OPEN-OPPOSITE (CDDR OPEN-OPPOSITE)))))
                 (T (AND (> (SETQ LEFT-X 
                                  (FIND-LEFT-BOUNDARY SHADED-LEFT 
                                                      TRAVEL-Y 
                                                      [COLOR AREA-COLOR]))
                         ;;If scan for left boundary takes you past previous right
                         ;;boundary, you've hit the top or bottom boundary, stop.
                         SHADED-RIGHT)
                        (RETURN T))
                    ;;SEARCH FOR RIGHTMOST BOUNDARY OF FIGURE.  START FROM LEFT
          	    ;;BOUNDARY, OR IF PREVOUS LEFT BOUND WAS GREATER, START FROM THAT
                    ;;SINCE AREA BETWEEN THEM HAS BEEN SEARCHED BY FIND-LEFT-BOUNDARY.
                    (SETQ RIGHT-X
         		(FIND-RIGHT-BOUNDARY (COND ((> LEFT-X SHADED-LEFT) LEFT-X)
                                                   (SHADED-LEFT))
    				             TRAVEL-Y
        				     [COLOR AREA-COLOR]))
                    ;;DO THE ACTUAL SHADING.
	            (SHADE-HORIZONTAL-LINE LEFT-X TRAVEL-Y RIGHT-X)))
                  
          ;;Check for shading around turning corners.
          (COND ((< LEFT-X SHADED-LEFT)
                 ;;Shade LEFT U-turn.
                 (COND ((< (SETQ INTERIOR-X
                                 (FIND-INTERIOR-BACKWARD SHADED-LEFT 
                                                         SHADED-Y 
                                                         [COLOR AREA-COLOR])) 
                           LEFT-X))
                       ;;If the next candidate for interior point is within
                       ;;the region, add a new open edge to scan the missing piece.
                       (T (OPEN-INCLUDE (LIST TRAVEL-Y LEFT-X INTERIOR-X) 
                                        OPEN-OPPOSITE)
                          ;;Since we added an edge, have to pop to keep in
                          ;;the same place.
                          (POP OPEN-OPPOSITE)))))
          ;;We need not check the s-turn case for left side, since the vertical
          ;;scan always crawls along the left side of the figure.
          (COND ((> RIGHT-X SHADED-RIGHT)
                 (COND ((> (SETQ INTERIOR-X 
                                 (FIND-INTERIOR-FORWARD SHADED-RIGHT 
                                                        SHADED-Y 
                                                        [COLOR AREA-COLOR]))
                           RIGHT-X))
                       (T (OPEN-INCLUDE (LIST TRAVEL-Y INTERIOR-X RIGHT-X) 
                                        OPEN-OPPOSITE)
                          (POP OPEN-OPPOSITE))))
                ((> SHADED-RIGHT RIGHT-X)
                 (COND ((> (SETQ INTERIOR-X 
                                 (FIND-INTERIOR-FORWARD RIGHT-X 
                                                        TRAVEL-Y
                                                        [COLOR AREA-COLOR]))
                           SHADED-RIGHT))
                       ((OPEN-INCLUDE (LIST SHADED-Y INTERIOR-X SHADED-RIGHT) 
                                      OPEN-SAME)))))
          (SETQ SHADED-LEFT LEFT-X 
		SHADED-RIGHT RIGHT-X 
                SHADED-Y TRAVEL-Y
		TRAVEL-Y (+ TRAVEL-Y VERTICAL-DIRECTION))))


;;*PAGE

;;;
;;;			SHADING PATTERNS
;;;
;;PREDEFINED SHADING PATTERNS.  THE USER CAN ALSO SUPPLY NEW ONES.

(DECLARE (FIXNUM (CHECKER FIXNUM FIXNUM)
		 (GRID FIXNUM FIXNUM)
		 (LIGHTGRID FIXNUM FIXNUM)
		 (HORIZLINES FIXNUM FIXNUM)
		 (VERTLINES FIXNUM FIXNUM)
		 (SOLID FIXNUM FIXNUM)
		 (TEXTURE FIXNUM FIXNUM)
		 (LIGHTTEXTURE FIXNUM FIXNUM)
		 (DARKTEXTURE FIXNUM FIXNUM))) 


(DEFINE SOLID (X Y) -16.) 

(DEFINE CHECKER (X Y) (COND ((ODDP Y) -22906492256.) (22906492240.))) 

(DEFINE GRID (X Y) (COND ((ODDP Y) -16.) (-22906492256.))) 

(DEFINE HORIZLINES (X Y) (COND ((ODDP Y) -16.) (0.))) 

(DEFINE VERTLINES (X Y) -22906492256.) 

(DEFINE TEXTURE (X Y) (BITWISE-AND -16. (RANDOM))) 

(DEFINE DARKTEXTURE (X Y) (BITWISE-AND -16. (BITWISE-OR (RANDOM) (RANDOM)))) 

(DEFINE LIGHTTEXTURE (X Y) (BITWISE-AND -16. (RANDOM) (RANDOM))) 

(DECLARE (NOTYPE (VERTICAL-SCAN NOTYPE FIXNUM FIXNUM FIXNUM))) 

(DECLARE (FIXNUM WINDOW-INDEX-X WINDOW-INDEX-Y WINDOW-LEFT-X WINDOW-TOP-Y
		 PATTERN-WINDOW-SIZE-X PATTERN-WINDOW-SIZE-Y PATTERN-WORD
		 WINDOW-INDEX-BIT WINDOW-INDEX-START-Y WINDOW-INDEX-WORD
		 BITS-RECEIVED BITS-NEEDED TO-WINDOW-SIZE-X TO-WORD-BOUNDARY)
         (FIXNUM INVOKE-WINDOW-PATTERN FIXNUM FIXNUM)) 

(DEFUN INVOKE-WINDOW-PATTERN (PATTERN-X PATTERN-Y) 
       ;;ACCESSES THE WINDOW ARRAY OF A USER SHADING PATTERN CORRECTLY SO AS TO
       ;;RETURN THE STATE OF THE 32 BITS OF THE TV WORD ACCESSED BY PATTERN-X AND
       ;;PATTERN-Y.  THE OTHER PARAMETERS ARE PECULIAR TO EACH WINDOW ARRAY, AND ARE
       ;;BOUND BY SHADE, ACCESSED GLOBALLY HERE.
       (LET ((WINDOW-INDEX-Y (\ PATTERN-Y PATTERN-WINDOW-SIZE-Y))
	     ;;CHANGE X WORD NUMBER TO BIT NUMBER.  SMASH X AND Y DOWN INTO THE
	     ;;RANGE OF THE WINDOW.
	     (WINDOW-INDEX-X (\ (LSH PATTERN-X 5.) PATTERN-WINDOW-SIZE-X)))
	    (LET ((WINDOW-INDEX-BIT (\ WINDOW-INDEX-X 36.))
		  ;;CONVERT WINDOW X TO BIT AND WORD INDICES.
		  (WINDOW-INDEX-WORD (// WINDOW-INDEX-X 36.))
		  ;;DISTANCE FROM CURRENT PLACE IN WINDOW TO RIGHT EDGE OF WINDOW.
		  (TO-WINDOW-SIZE-X (- PATTERN-WINDOW-SIZE-X WINDOW-INDEX-X)))
              (LET ((WINDOW-START (* WINDOW-INDEX-Y 
                                     (ARRAYCALL FIXNUM PATTERN-INFO 0.))))
                 (INCREMENT WINDOW-INDEX-WORD WINDOW-START)
		 (DO ((PATTERN-WORD 
                       (LSH (ARRAYCALL FIXNUM PATTERN-WINDOW WINDOW-INDEX-WORD)
                            WINDOW-INDEX-BIT)
                       ;;BUILD UP THE TV WORD BY INCLUSIVE ORING PIECES
                       ;;FROM SEVERAL WINDOW ARRAY WORDS, IF NEED BE.
                       (BITWISE-OR PATTERN-WORD
                                   (LSH 
                                    (ARRAYCALL FIXNUM PATTERN-WINDOW WINDOW-INDEX-WORD)
                                    (- BITS-RECEIVED))))
		      (BITS-RECEIVED (MIN TO-WINDOW-SIZE-X
					  (- 36. WINDOW-INDEX-BIT))
				     (+ BITS-RECEIVED WINDOW-INDEX-BIT))
		      ;;HOW MANY BITS OBTAINED SO FAR, HOW MANY MORE DESIRED, UP TO
		      ;;32.  EACH TIME WE ADD AMOUNT OF THE NEW WINDOW INDEX BIT --
		      ;;SINCE WE ALWAYS OR IN INITIAL SEGMENT OF ANOTHER WORD.
		      (BITS-NEEDED 0.)
		      ;;NUMBER OF BITS REMAINING IN THE CURRENT WORD.
		      (TO-WORD-BOUNDARY (- 36. WINDOW-INDEX-BIT)
					(- 36. WINDOW-INDEX-BIT)))
		     ((> BITS-RECEIVED 31.) (BITWISE-AND PATTERN-WORD -16.))
		     (SETQ BITS-NEEDED (- 32. BITS-RECEIVED))
		     (COND ((< TO-WINDOW-SIZE-X TO-WORD-BOUNDARY)
			    ;;REACHED RIGHT EDGE OF WINDOW IN THE CURRENT WORD,
			    ;;"WRAP AROUND" TO THE FIRST WORD IN THE WINDOW.
			    (SETQ WINDOW-INDEX-WORD WINDOW-START)
			    (COND ((< BITS-NEEDED PATTERN-WINDOW-SIZE-X)
				   ;;WILL THERE BE ENOUGH BITS IN THAT WORD TO
				   ;;SATISFY US?
				   (SETQ WINDOW-INDEX-BIT
					 BITS-NEEDED
					 TO-WINDOW-SIZE-X
					 (- PATTERN-WINDOW-SIZE-X WINDOW-INDEX-BIT)))
				  ((SETQ WINDOW-INDEX-BIT PATTERN-WINDOW-SIZE-X 
					 TO-WINDOW-SIZE-X 0.))))
			   ;;CROSS BOUNDARY OF WORD.
			   ((INCREMENT WINDOW-INDEX-WORD)
			    (SETQ WINDOW-INDEX-BIT (MIN (- TO-WINDOW-SIZE-X
							   TO-WORD-BOUNDARY)
							BITS-NEEDED) 
				  TO-WINDOW-SIZE-X (- TO-WINDOW-SIZE-X
						      WINDOW-INDEX-BIT
						      TO-WORD-BOUNDARY))))))))) 

;;*PAGE

;;;

(COMMENT XGP HARD COPY) 

;;;
;;;
;;WRITE A FILE OF CHARACTERS WHICH CAN BE PRINTED ON XGP USING SPECIAL FONTS
;;DESIGNED FOR THE PURPOSE.
;;;
;;PROBLEM: WHEN LISP TYO'S A CARRIAGE RETURN TO A FILE, IT ALSO SUPPLIES A LINE
;;FEED, WHICH CAUSES THE LINE TO END.  THIS NEEDS TO BE CORRECTED BY A LAP SUBR TO
;;OUTPUT JUST A CR.
;;;

[BW 

(DECLARE (*EXPR OUTPUT-RAW-CR-TO-DISK)) 


(LAP OUTPUT-RAW-CR-TO-DISK SUBR)
	(HLLOS 0 NOQUIT)
	(MOVEI A 15)
	(PUSHJ P UTTYO)
	(MOVEI A '15)
	(HLLZS 0 NOQUIT)
	(PUSHJ P CHECKI)
	(POPJ P)
NIL 
 

;;THE WIDTH OF THE PICTURE PRINTED IS LIMITED TO ABOUT HALF THE WITDTH OF THE
;;SCREEN, SINCE CHARACTERS CANNOT BE OUTPUT TO THE XGP FAST ENOUGH TO INSURE THAT
;;THEY ALL GET PRINTED IN TIME BEFORE THE NEXT LINE.
;;;
;; ONE WAY TO POSSIBLY GET AROUND THIS IS TO USE MULTIPLE FONTS, PERHAPS A FONT WITH
;;RUN LENGTH ENCODING.

(DECLARE (NOTYPE (INTERNAL-XGP NOTYPE NOTYPE FIXNUM NOTYPE))
	 (FIXNUM START-WORD STOP-WORD TRAVEL-X TRAVEL-Y STOP-BIT START-BIT ENV
		 LFTMAR THIS-WORD XGP-CHAR TRAVEL-WORD)
	 (SPECIAL ^R ^W *NOPOINT)) 

(DEFINE XGP FEXPR (ARGLIST ENV) 
	(XGP-DECODE-ARGS '"LLOGO;TVRTLE KST"
			 300.
			 ARGLIST
			 ENV)
	NO-VALUE) 

;;PROVIDE DEFAULTS, VARIOUS MEANS OF SPECIFYING ARGS.

(DEFUN XGP-DECODE-ARGS (FONT LFTMAR XGP-ARGLIST ENV) 
       (LET ((FILE))
	    (COND ((ATOM (CAR XGP-ARGLIST))
		   (SETQ FILE (FILESPEC (DO NIL
					    ((OR (NULL XGP-ARGLIST)
						 (NUMBERP (CAR XGP-ARGLIST)))
					     (NREVERSE FILE))
					    (PUSH (CAR XGP-ARGLIST) FILE)
					    (POP XGP-ARGLIST)))))
		  ((SETQ FILE (FILESPEC (EVAL (CAR XGP-ARGLIST) ENV)) 
			 XGP-ARGLIST (CDR XGP-ARGLIST))))
	    (INTERNAL-XGP FILE
			  FONT
			  LFTMAR
			  (RECTANGLE-SPEC 'XGP
					  (MAPCAR '(LAMBDA (RECTANGLE-ARG) 
							   (EVAL RECTANGLE-ARG ENV))
						  XGP-ARGLIST))))) 

(DECLARE (NOTYPE (XGP-TYO FIXNUM))
	 (NOTYPE (PRINT-XGP-CHARACTERS FIXNUM FIXNUM FIXNUM FIXNUM))) 

(DEFUN INTERNAL-XGP (FILE FONT LFTMAR RECTANGLE) 
       (APPLY 'UWRITE (LIST (CADDR FILE) (CADDDR FILE)))
       ;;WRITE FIRST PAGE OF XGP HEADER INFORMATION.
       (LET ((^R T)
	     (^W T)
	     (TOP-Y (CAR RECTANGLE))
	     (BOTTOM-Y (CADR RECTANGLE))
	     (LEFT-X (CADDR RECTANGLE))
	     (RIGHT-X (CADDDR RECTANGLE))
	     (*NOPOINT T))
	    (PRINC '"
;RESET
;SKIP 1
;VSP 0
;KSET ")    (PRINC FONT)
	    (PRINC '"
;LFTMAR ")  (PRINC LFTMAR)
	    (TERPRI)
	    (TYO 12.)
	    (PRINT-XGP-CHARACTERS LEFT-X RIGHT-X TOP-Y BOTTOM-Y))
       (APPLY 'UFILE FILE)) 

;;XGP printout uses a run length encoded font.  Outputs ascii characters which are
;;printed in a font consisting of runs of from 1 to 64 zeros, and 1 to 64 ones.

(SETQ RUN-MAX 64. 
      ;;Maximum run length, bit specifying type of run.
      RUN-TYPE-SHIFT 6.) 

(DECLARE (SPECIAL RUN-MAX RUN-TYPE-SHIFT)
	 (FIXNUM TRAVEL-X TRAVEL-Y NEW-TRAVEL-X RUN-TYPE RUN-LENGTH
		 RUN-LENGTH-REMAINING LINE-Y RUN-MAX RUN-TYPE-SHIFT THIS-RUN)
	 (NOTYPE (PRINT-XGP-CHARACTERS FIXNUM FIXNUM FIXNUM FIXNUM)
		 (PRINT-XGP-LINE FIXNUM FIXNUM FIXNUM)
		 (RUN-OUT FIXNUM FIXNUM)
		 (RUN-TYO FIXNUM FIXNUM))) 

(DEFUN PRINT-XGP-CHARACTERS (LEFT-X RIGHT-X TOP-Y BOTTOM-Y) 
       (DO ((TRAVEL-Y TOP-Y (1+ TRAVEL-Y)))
	   ((> TRAVEL-Y BOTTOM-Y))
	   ;;Print a line of characters, then carriage return.
	   (PRINT-XGP-LINE LEFT-X TRAVEL-Y RIGHT-X)
	   (TERPRI))) 

(DEFUN PRINT-XGP-LINE (START-X LINE-Y STOP-X) 
       ;;Prints one line of XGP characters.
       (DO ((RUN-TYPE -1. (- -1. RUN-TYPE))
	    ;;Alternate between runs of zeros & ones.
	    (THIS-RUN)
	    (TRAVEL-X START-X NEW-TRAVEL-X)
	    ;;Is this off by 1?
	    (NEW-TRAVEL-X))
	   ((> (SETQ THIS-RUN (RUNAWAY-FORWARD TRAVEL-X LINE-Y RUN-TYPE) 
		     ;;Compute run length, and end of run.
		     NEW-TRAVEL-X (+ TRAVEL-X THIS-RUN))
	       ;;Is end of run past right edge of area to print?
	       STOP-X)
	    (COND ((ZEROP RUN-TYPE))
		  ;;Output remaining run, but don't bother if zeros.
		  ((RUN-OUT RUN-TYPE (- STOP-X TRAVEL-X -1.)))))
	   ;;Output the current run.
	   (RUN-OUT RUN-TYPE THIS-RUN))) 

(DEFUN RUN-OUT (RUN-TYPE RUN-LENGTH) 
       ;;Output RUN-LENGTH bits in the specified type.  Chunks of maximum run length
       ;;successively output until exhausted.
       (DO ((RUN-LENGTH-REMAINING RUN-LENGTH (- RUN-LENGTH-REMAINING RUN-MAX)))
	   ((< RUN-LENGTH-REMAINING RUN-MAX)
	    (OR (ZEROP RUN-LENGTH-REMAINING) (RUN-TYO RUN-TYPE RUN-LENGTH-REMAINING))
	    T)
	   (RUN-TYO RUN-TYPE RUN-MAX))) 

(DEFUN RUN-TYO (RUN-TYPE RUN-LENGTH) 
       (XGP-TYO (BITWISE-OR (LSH (- RUN-TYPE) RUN-TYPE-SHIFT)
			    ;;High order bit is type of run length, lower order bits
			    ;;are run count [off by 1 from ascii value]. 
			    (1- RUN-LENGTH)))
       T) 

(DEFUN XGP-TYO (XGP-CHAR) 
       ;;WEIRD CHARACTERS MUST BE PRECEDED BY RUBOUT IN ORDER TO PRINT THE FONT'S
       ;;DEFINITION OF THE CHARACTER.  CR HANDLED SPECIALLY TO AVOID INSERTION OF
       ;;LINEFEED.
       (COND ((= XGP-CHAR 13.) (TYO 127.) (OUTPUT-RAW-CR-TO-DISK))
	     ((MEMBER XGP-CHAR '(0. 8. 9. 10. 12. 127.))
	      (TYO 127.)
	      (TYO XGP-CHAR))
	     ((TYO XGP-CHAR)))
       T) 


;;;END OF BLACK-AND-WHITE CONDITIONAL SECTION.
] 
 

;;*PAGE

;;;

(COMMENT SKETCHING) 

;;;

(DEFUN READ-EOF (EOF-VALUE)
       (LET ((READ-RESULT (READ EOF-VALUE))) 
            (COND ((NULL ^Q) EOF-VALUE) (READ-RESULT))))


(DECLARE (FLONUM SKETCH-FROM-X SKETCH-FROM-Y SKETCH-TO-X SKETCH-TO-Y END-OF-FILE))

(DEFINE READSKETCH FEXPR (SKETCH-FILE) 
	;;SLURPS SKETCH MADE ON DM'S TABLET USING PROGRAM ON HENRY;SKETCH >.
	(CLEARSCREEN)
	(HIDETURTLE)
	(PENDOWN)
	(APPLY 'UREAD SKETCH-FILE)
	(DO ((SKETCH-FROM-X) (SKETCH-FROM-Y) (SKETCH-TO-X) (SKETCH-TO-Y)
             (OBARRAY LISP-OBARRAY) (READTABLE LISP-READTABLE) (^Q T)
             (END-OF-FILE -99999.0)
             (HORIZONTAL (EXPR-FUNCTION HORIZONTAL-LINE)) 
             (VERTICAL (EXPR-FUNCTION VERTICAL-LINE)))
	    ((OR (= (SETQ SKETCH-FROM-X (READ-EOF END-OF-FILE)) END-OF-FILE)
                 (= (SETQ SKETCH-FROM-Y (READ-EOF END-OF-FILE)) END-OF-FILE)
                 (= (SETQ SKETCH-TO-X (READ-EOF END-OF-FILE)) END-OF-FILE)
                 (= (SETQ SKETCH-TO-Y (READ-EOF END-OF-FILE)) END-OF-FILE))
	     (SETQ ^Q NIL))
	    ;;SLURP FOUR POINTS AND DRAW VECTOR.
	    (BOUNDED-VECTOR SKETCH-FROM-X SKETCH-FROM-Y SKETCH-TO-X SKETCH-TO-Y))
	NO-VALUE) 

;;*PAGE


(DECLARE (SPECIAL :BRUSH BRUSH-INFO BRUSH-PICTURE)
         (FIXNUM BRUSH-X BRUSH-Y)
         (NOTYPE (HORIZONTAL-BRUSHSTROKE FIXNUM FIXNUM FIXNUM)
                 (VERTICAL-BRUSHSTROKE FIXNUM FIXNUM FIXNUM)
                 (DISPLAYWINDOW-TV NOTYPE NOTYPE FIXNUM FIXNUM)))

(DEFUN HORIZONTAL-BRUSHSTROKE (FROM-X FROM-Y TO-X)
       (DO ((BRUSH-X FROM-X (1+ BRUSH-X)))
           ((> BRUSH-X TO-X))
           (DISPLAYWINDOW-TV BRUSH-INFO BRUSH-PICTURE BRUSH-X FROM-Y)))
                             
(DEFUN VERTICAL-BRUSHSTROKE (FROM-X FROM-Y TO-Y)
       (DO ((BRUSH-Y FROM-Y (1+ BRUSH-Y)))
           ((> BRUSH-Y TO-Y))
           (DISPLAYWINDOW-TV BRUSH-INFO BRUSH-PICTURE FROM-X BRUSH-Y)))

(DEFINE BRUSH (BRUSH)
       (LET ((BRUSH-WINDOW-PROP (GET BRUSH 'WINDOW)))
            (COND (BRUSH-WINDOW-PROP
                   (SETQ :BRUSH BRUSH
                         BRUSH-INFO (GET (CAR BRUSH-WINDOW-PROP) 'ARRAY)
                         BRUSH-PICTURE (GET (CADR BRUSH-WINDOW-PROP) 'ARRAY) 
                         HORIZONTAL (EXPR-FUNCTION HORIZONTAL-BRUSHSTROKE)
                         VERTICAL (EXPR-FUNCTION VERTICAL-BRUSHSTROKE)))
                  ((ERRBREAK 'BRUSHDOWN (LIST BRUSH '"IS NOT A WINDOW")))))
       NO-VALUE)


(DEFINE NOBRUSH NIL 
       (SETQ :BRUSH NIL
             BRUSH-INFO NIL
             BRUSH-PICTURE NIL
             HORIZONTAL (EXPR-FUNCTION HORIZONTAL-LINE)
             VERTICAL (EXPR-FUNCTION VERTICAL-LINE))
       NO-VALUE)






TO HANGMAN
110 MAKE "WRONG." 1 MAKE "GUESSED" :EMPTY
120 MAKE  "WRONG" (WORD :BLANK :BLANK :BLANK :BLANK :BLANK)
130 MAKE "NUM" (RANDOM 0 :WORDMAX)
190 MAKE "WORD" THING WORD "WORD" :NUM
200 MAKE "UNDER" SETT "-" COUNT :WORD
210 MAKE "OVER" SETT :BLANK COUNT :WORD
220 PRINT WORD :SKIP :SKIP
230 TYPE :BLANK PRINT .EXPAND :UNDER
240 TEST :WRONG.>6
250 IFTRUE GO 410
260 TYPE WORD :BLANK :BLANK TYPE "YOUR GUESS?"
270 MAKE "GUESS" TYPEIN
280 TEST GREATERP COUNT :GUESS 1
290 IFTRUE GO 550
291 IF NOT ALPHP :GUESS PRINT SENTENCE :GUESS "IS NOT A LETTER. TRY AGAIN." GO 260
293 TEST CONTAINS :GUESS :GUESSED
294 IFFALSE GO 297
295 PRINT SENTENCE SENTENCE "YOU ALREADY GUESSED" WORD :GUESS " . " "TRY AGAIN."
297 MAKE "GUESSED" SENTENCE :GUESSED :GUESS
300 TEST CONTAINS :GUESS :WORD
310 IFFALSE MAKE "WRONG" WORD :WRONG :GUESS
320 IFFALSE PRINT SENTENCE SENTENCE SENTENCE :SKIP .EXPAND :OVER :WRONG SENTENCE :SKIP .EXPAND :UNDER
330 TEST CONTAINS :GUESS :WORD
340 IFFALSE MAKE "WRONG." :WRONG.+1
350 IFFALSE GO 240
360 MAKE "OVER" .RESET :WORD :GUESS :OVER
370 PRINT SENTENCE SENTENCE SENTENCE :SKIP .EXPAND :OVER :WRONG SENTENCE :SKIP .EXPAND :UNDER
380 TEST :OVER=:WORD
390 IFTRUE GO 560
400 GO 240
410 BELLS 6 PRINT SENTENCE :SKIP "YOU GOT MORE THAN 6 WRONG GUESSES. HA I WIN."
420 PRINT SENTENCE "MY WORD WAS" WORD :WORD " . "
430 STOP
550 TEST :GUESS=:WORD
560 IFTRUE TYPE "YOU BEAT ME " BELLS 4 PRINT "THAT MAKES ME SO MAD (I AM A SORE LOSER) YOU MAKE MY DIODES STEAM"
570 IFTRUE STOP
620 PRINT "WRONG GUESS, TRY AGAIN."
630 GO 260
END

TO BELLS :NUM
10 IF :NUM=0 STOP ELSE TYPE :BELL BELLS :NUM-1
END

TO SETT :K :L
10 MAKE "M" 1
20 MAKE "N" :EMPTYW
30 IF :L=:M OUTPUT WORD :N :K
40 MAKE "N" WORD :N :K
50 MAKE "M" SUM :M 1
60 GO 30
END

TO .EXPAND :.WORD.
10 MAKE "EX" :EMPTY
20 MAKE "EX" SENTENCE :EX FIRST :.WORD.
30 MAKE ".WORD." BUTFIRST :.WORD.
40 TEST EQUAL COUNT :.WORD. 1
50 IFTRUE OUTPUT SENTENCE :EX :.WORD.
60 GO 20
END

TO ALPHP :QWERT
10 OUTPUT CONTAINS :QWERT "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
END

TO CONTAINS :OPP :POO
10 IF EMPTYP :POO OUTPUT  NIL  ELSE IF :OPP=FIRST :POO OUTPUT T ELSE OUTPUT CONTAINS :OPP BUTFIRST :POO
END

TO .RESET :A :B :C
10 MAKE "OP" :EMPTYW
20 TEST EMPTYP :A
30 IFTRUE OUTPUT :OP
40 TEST EQUAL FIRST :A :B
50 IFTRUE MAKE "OP" WORD :OP :B
60 IFFALSE MAKE "OP" WORD :OP FIRST :C
65 MAKE "C" BUTFIRST :C
70 MAKE "A" BUTFIRST :A
80 GO 20
END

TO ADDWORDS
10 IF NOT NUMBERP :WORDMAX PRINT "SOMETHING WRONG" STOP
20 MAKE "D" :WORDMAX+1
30 TYPE WORD WORD "WORD" :D ":"
40 MAKE WORD "WORD" :D TYPEIN
50 IF EMPTYP THING WORD "WORD" :D MAKE "WORDMAX" DIFFERENCE :D 1 STOP ELSE MAKE "D" SUM :D 1 GO 30
END
MAKE "NUM" "12"
MAKE "WORDMAX" "16"
MAKE "WORD" "DRAWING"
MAKE "UNDER" "-------"
MAKE "WRONG." "2"
MAKE "GUESS" "W"
MAKE "GUESSED" " E R A I D N G W"
MAKE "WRONG" "E "
MAKE "OVER" "DRAWING"
MAKE "M" "7"
MAKE "N" "      "
MAKE "EX" " - - - - - -"
MAKE "OP" "DRAWING"
MAKE "D" "17"
MAKE "X" "HI"
MAKE "WORD0" "TRANSCENDENTAL"
MAKE "WORD1" "OPERATOR"
MAKE "WORD2" "MANUAL"
MAKE "WORD3" "BUTTON"
MAKE "WORD4" "RIBBON"
MAKE "WORD5" "SERVICE "
MAKE "WORD6" "CRASH"
MAKE "WORD7" "EQUIPMENT"
MAKE "WORD8" "EXPLOSION"
MAKE "WORD9" "HYPERACTIVE "
MAKE "WORD10" "ELECTRICAL"
MAKE "WORD11" "GENERATOR"
MAKE "WORD12" "DRAWING"
MAKE "WORD13" "INTELLIGENCE "
MAKE "WORD14" "ARTIFICIAL"
MAKE "WORD15" "COMPUTER"
MAKE "WORD16" "ATOMIZER"
MAKE "WORD17" "IRIDESCENT"

MAKE "BLANK" ASCII 32.
MAKE "BELL" ASCII 7
MAKE "SKIP" ASCII 13.
MAKE "A" "0"
MAKE "B" "4"
MAKE "Z" "5"
MAKE "N" "10"
MAKE "C" "6"


TO DEC
10 TYPE "ENTER NUMERATOR :"
20 MAKE "A" TYPEIN
30 TYPE "ENTER DENOMINATOR :"
40 MAKE "B" TYPEIN
50 TERPRI
110 MAKE "Z" 5
120 IF :B < :A THEN GO 140 ELSE IF :B = :A THEN GO 130
122 TYPE '$      0.$
127 GO 210
130 TERPRI
132 PRINT 1
136 TERPRI
138 STOP
140 PRINT "THIS PROGRAM ONLY EVALUATES FRACTIONS < 1"
150 STOP
210 MAKE "N" 10
220 IF :N * :A > :B THEN GO 410
230 MAKE "N" 10 * :N
240 TYPE 0
250 GO 220
410 MAKE "C" 1
420 IF :N * :A < :C * :B THEN GO 510
430 MAKE "C" :C + 1
440 GO 420
510 TYPE :C - 1
520 MAKE "A" :N * :A - (:C - 1) * :B
530 IF - :A < 0 THEN GO 550
540 TERPRI
545 STOP
550 IF :A < :B THEN GO 210 ELSE IF :A = :B THEN GO 130 ELSE GO 140
END