diff --git a/src/llogo/define.1 b/src/llogo/define.1 new file mode 100644 index 00000000..982739fb --- /dev/null +++ b/src/llogo/define.1 @@ -0,0 +1,445 @@ + +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; 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))) + \ No newline at end of file diff --git a/src/llogo/error.1 b/src/llogo/error.1 new file mode 100644 index 00000000..3b56708c --- /dev/null +++ b/src/llogo/error.1 @@ -0,0 +1,776 @@ +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; 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.")] + \ No newline at end of file diff --git a/src/llogo/germ.1 b/src/llogo/germ.1 new file mode 100644 index 00000000..e776093b --- /dev/null +++ b/src/llogo/germ.1 @@ -0,0 +1,815 @@ +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; 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 '?)) + + diff --git a/src/llogo/hang.1 b/src/llogo/hang.1 new file mode 100644 index 00000000..362a291f --- /dev/null +++ b/src/llogo/hang.1 @@ -0,0 +1,167 @@ +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 + diff --git a/src/llogo/llogo.lisp b/src/llogo/llogo.lisp deleted file mode 100644 index 7243f7f8..00000000 --- a/src/llogo/llogo.lisp +++ /dev/null @@ -1,12480 +0,0 @@ - -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; 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 - diff --git a/src/llogo/loader.1 b/src/llogo/loader.1 new file mode 100644 index 00000000..3bc84884 --- /dev/null +++ b/src/llogo/loader.1 @@ -0,0 +1,197 @@ + + +(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)) + \ No newline at end of file diff --git a/src/llogo/music.1 b/src/llogo/music.1 new file mode 100644 index 00000000..e3cc323e --- /dev/null +++ b/src/llogo/music.1 @@ -0,0 +1,342 @@ + + +;;; 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) + diff --git a/src/llogo/parser.1 b/src/llogo/parser.1 new file mode 100644 index 00000000..dbd5bc7e --- /dev/null +++ b/src/llogo/parser.1 @@ -0,0 +1,579 @@ +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; 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))))))))) + \ No newline at end of file diff --git a/src/llogo/primit.1 b/src/llogo/primit.1 new file mode 100644 index 00000000..49a04bbd --- /dev/null +++ b/src/llogo/primit.1 @@ -0,0 +1,1089 @@ + +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; 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 + + \ No newline at end of file diff --git a/src/llogo/print.1 b/src/llogo/print.1 new file mode 100644 index 00000000..6fb63852 --- /dev/null +++ b/src/llogo/print.1 @@ -0,0 +1,332 @@ +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; 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) + \ No newline at end of file diff --git a/src/llogo/reader.1 b/src/llogo/reader.1 new file mode 100644 index 00000000..d902669e --- /dev/null +++ b/src/llogo/reader.1 @@ -0,0 +1,611 @@ +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; 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 + + \ No newline at end of file diff --git a/src/llogo/setup.1 b/src/llogo/setup.1 new file mode 100644 index 00000000..dde55d25 --- /dev/null +++ b/src/llogo/setup.1 @@ -0,0 +1,386 @@ +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; 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"))] + \ No newline at end of file diff --git a/src/llogo/turtle.465 b/src/llogo/turtle.465 new file mode 100644 index 00000000..9dbd1fe3 --- /dev/null +++ b/src/llogo/turtle.465 @@ -0,0 +1,698 @@ + +;;; 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 '?))) + \ No newline at end of file diff --git a/src/llogo/tvrtle.1 b/src/llogo/tvrtle.1 new file mode 100644 index 00000000..82f34a37 --- /dev/null +++ b/src/llogo/tvrtle.1 @@ -0,0 +1,5249 @@ +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; 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) + + + + + + diff --git a/src/llogo/unedit.1 b/src/llogo/unedit.1 new file mode 100644 index 00000000..d12edb81 --- /dev/null +++ b/src/llogo/unedit.1 @@ -0,0 +1,798 @@ +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; 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 + + \ No newline at end of file