From 8c2a037d236c420fdf0fca01cd1d249b6f50d721 Mon Sep 17 00:00:00 2001 From: Lars Brinkhoff Date: Wed, 26 Sep 2018 10:49:47 +0200 Subject: [PATCH] llogo.lisp from Don Hopkins. --- Makefile | 2 +- src/llogo/llogo.lisp | 12480 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 12481 insertions(+), 1 deletion(-) create mode 100644 src/llogo/llogo.lisp diff --git a/Makefile b/Makefile index b333cabf..59ca29d7 100644 --- a/Makefile +++ b/Makefile @@ -26,7 +26,7 @@ SRC = syseng sysen1 sysen2 sysen3 sysnet kshack dragon channa \ draw wl taa tj6 budd sharem ucode rvb kldcp math as imsrc gls demo \ macsym lmcons dmcg hack hibou agb gt40 rug maeda ms kle aap common \ fonts zork 11logo kmp info aplogo bkph bbn pdp11 chsncp sca music1 \ - moon teach ken lmio1 + moon teach ken lmio1 llogo DOC = info _info_ sysdoc sysnet syshst kshack _teco_ emacs emacs1 c kcc \ chprog sail draw wl pc tj6 share _glpr_ _xgpr_ inquir mudman system \ xfont maxout ucode moon acount alan channa fonts games graphs humor \ diff --git a/src/llogo/llogo.lisp b/src/llogo/llogo.lisp new file mode 100644 index 00000000..7243f7f8 --- /dev/null +++ b/src/llogo/llogo.lisp @@ -0,0 +1,12480 @@ + +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; 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 ) 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 ] +;;; [(OR ITS DEC10) ] + +(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 ) -- 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 , CONTROL-K , +;;; CONTROL-L , CONTROL-M , +;;; 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. +;;; ' --> (QUOTE ) +;;; "" --> (DOUBLE-QUOTE ) +;;; " ... " --> (DOUBLE-QUOTE ( ... )) +;;; "" --> NIL +;;; [] --> NIL +;;; [ ... ] --> (SQUARE-BRACKETS ( ... )) 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. +;;; ! ! --> (LOGO-COMMENT ! !) +;;; ; --> (LOGO-COMMENT /; ) +;;; - --> <-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 +;;) RETURNS PRECEDENCE NUMBER OF . (PRECEDENCE ) SETS +;;PRECEDENCE OF TO , EITHER A NUMBER OR OPERATOR, WHICH MAKES IT SAME +;;PRECEDENCE AS THAT OPERATOR. = NIL MEANS LOWEST PRECEDENCE. +;;(PRECEDENCE NIL ) SETS THE DEFAULT PRECEDENCE FOR IDENTIFIERS TO . + +(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 ) CAUSES ALL OPERATORS OF PRECEDENCE 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 ) CREATES 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 .. + ;;. + (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 ) --> ' +;;; (SQUARE-BRACKETS ( ... )) --> [ ... ] +;;; (DOUBLE-QUOTE ) --> "" +;;; (DOUBLE-QUOTE (...)) --> " ... " +;;;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
.... +;;; 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 , WHOSE +;;; CAR IS LAST FORM BEFORE . +;;; THIS-LINE <- LIST OF FORMS ON LINE NUMBER . +;;; NEXT-TAG <- REMAINDER OF PROG STARTING WITH LINE FOLLOWING +;;; LINE NUMBER . +;;; +;;; 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 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 ) + +(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 "" "" +;;;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 +;; WILL COMPILE ALL THE FUNCTIONS IN A USER'S WORKSPACE AS 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 ... is like WHILE NOT ... + +(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 ) GO UP FRAMES. +;;;(UP ) GO SEARCHING UP THE STACK FOR AN INVOCATION OF +;;;(UP ) FIND THE TH INVOCATION OF UP THE STACK. +;;;DOWN IS SIMILAR, EXCEPT PROCEEDS DOWN THE STACK. +;;;DOWN IS EQUIVALENT TO (UP ... - ) +;;THE FUNCTIONS WORK BY THROWING A LIST BACK TO A CATCH IN FRAMEUP. +;;;FORMAT OF LIST IS: +;;; ( <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 +;;; ( ) +;;;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 ) 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 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 . +;;; 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 + (LEGALPOS 'WHAT PLACE) + (CDR (GERMARRAY (CAR PLACE) (CADR PLACE)))) + +(DEFUN FOOD (PLACE) (OR (ONUMBERP (GETSQUARE PLACE 'FOOD)) 0.)) + +;;NUMBER OF FOOD PARTICLES AT + +(DEFUN ONUMBERP (N) (AND (NUMBERP N) N)) + +(DEFUN EAT (MORSELS) + ;;REMOVE 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 ) 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 . 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 AT TO LOOK LIKE [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 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 ( ) WHERE IS THE NUMBER + OF SQUARES FROM THE LEFT AND 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] +;;; ,, +;;; TTSAR: 100107 [WHERE 1 IS THE NUMBER OF DIMENSIONS, +;;; 107 IS (TT) [INDEXED BY TT]] +;;; ,, +;;; +;;THE BLOCK OF DATA FOR THE ARRAY IS AS FOLLOWS: +;;; +;;; -1 [MINUS NUMBER OF DIMENSIONS] ,, +;;; INSTRUCTION-BLOCK: +;;; PUSHJ P, CFIX1 [FOR FIXNUMS] +;;; JSP TT, 1DIMF [FOR 1 DIMENSIONAL ARRAYS] +;;; +;;; <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 ) ) +;;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 +;; 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 -- TURNS THE CURRENT LOCATION OF THE TURTLE ON OR OFF. +;;; ?POINT -- TURNS THE POINT AT (, ) ON +;;; ?POINT -- 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 +