LMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 2 :LENGTH-IN-BYTES 1362 :AUTHOR "SAM" :CREATION-DATE 2723137372 :QFASLP NIL :LENGTH 1362 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "CIRCULATION-DIRECTORY-LISTING" :TYPE "TEXT" :VERSION 8) НННЙЙЙ LISP II COURSE MATERIALНЙЙЙ -----------------------НН DUKE: LISP2-CIRCULATION; *.*#*НН AI-PROGRAMMING-EXERCISES.TEXTН CIRCULATION-DIRECTORY-LISTING.TEXTН DEBUGGING-EXERCISES-PAGE-1.TEXTН DEFMACRO-EXERCISE-ANSWERS.LISPН DEFMACRO-EXERCISES.LISPН DEFMACRO-REQUIRED-EXERCISE.LISPН EMPTY.CHARTН FANCIER-LISPM.LISPН FORTRAN-CALL.LISPН LINE-EDITOR.LISPН LISPM.INITН LISPM.LISPН ORG.LISPН PAINT.LISPН PROCESS-BRINGUP-WINDOW.LISPН Prolog system as loaded by PROLOG-INIT.LISPН QUERIES.LISPН QUICK-STATS.LISPН RAPID-PROTOTYPING.LISPН RAPID-PROTOTYPING.LISPН RECURSIVE-DESCENT.LISPН RECURSIVE-DESCENT-EX1.LISPН RECURSIVE-DESCENT-EX2.LISPН SPACE-FLAVOR.LISPН TEACH-ZMACS.TEXTН TURTLE.LISPН TURTLE-CONSTRAINT-FRAME-KEY-TOGGLE.TEXTН TURTLE-CONSTRAINT-FRAME-TWO-CONFIG.TEXTН TURTLE-CONSTRAINT-ONE-CONFIG.LISPН TURTLE-CONSTRAINT-ONE-CONFIG-EXERCISE.LISPН TURTLE-CONSTRAINT-TWO-CONFIG.LISPН TURTLE-HACKS.LISPН TURTLE-POND.LISPН TURTLE-PROCESS.LISPН WINDOW-BRINGUP-PROCESS.LISPНН PLEASE NOTE: This education material is not specifically supported by LMI.НЙPlease call Lorin Wilde of the Education Division at (617) 682 - 0500НЙif you have any questions or comments concerning these programs.НLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 9 :LENGTH-IN-BYTES 9142 :AUTHOR "SAM" :CREATION-DATE 2722219762 :QFASLP NIL :LENGTH 9142 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "CL-INIT" :TYPE "LISP" :VERSION 1) ;;; -*- Mode:LISP; Readtable:COMMON-LISP; Base:10 -*-Н#+lispm (send *standard-output* :clear-screen)Н#-lispm (princ #\page)Н(format t "ННН (C) COPYRIGHT 1986 LISP Machine, IncorporatedН All Rights ReservedННН___________________________________________________________________________НSamuel F. Pilato~2%")НННН;;;;CL-INITН;;;Н;;; CommonLisp InitializationНН(provide 'cl-init)НННН;;;;Message at Start of LoadingНН(format t "Н Initializing a CommonLisp environment: providing for ...НН CommonLisp Readtable InitializationН Maintaining a Module RegistryН Enhancement of REQUIRE Function (REQUIRE being redefined)Н Ordered Compiling and Loading of Modules~%")НННН;;;;CommonLisp Readtable InitializationНН#+lispmН(defmacro cl-init ()Н "Set *readtable* to a copy of the standard CommonLisp readtable.Н This is undone upon logout."Н `(progn (login-forms (setq *readtable* (copy-readtable nil))) (values)))НН#-lispmН(defmacro cl-init ()Н "Set *readtable* to a copy of the standard CommonLisp readtable."Н `(progn (setq *readtable* (copy-readtable nil)) (values)))НМН;;;;Module RegistryНН(defvar *module-pathname-defaults* *default-pathname-defaults*Н "defaults for completing a pathname to a module's file")НН(defvar *module-registry* nilН "registry of modules and where to find their associated files:Н The registry is an alist where each key is a module name (as a string)Н and its associated datum is a list of pathnames to the module's files.Н Keys should be tested with STRING= .")НН(defun module-pathnames (module-name &aux pair)Н "Given the name of a module, return a list of pathnames to the module'sН files. MODULE-NAME may be a module name (as a string) or a symbol whoseН print name is the module name. If a module is not registered inН *MODULE-REGISTRY*, the module name merged withН *MODULE-PATHNAME-DEFAULTS* is listed as the sole pathname."Н (if (setq pair (assoc module-name *module-registry* :test #'string=))Н (cdr pair)Н (list (merge-pathnames module-name *module-pathname-defaults*))))НН(defmacro with-module-pathname-defaults ((pathname-defaults) &body body)Н "With *MODULE-PATHNAME-DEFAULTS* bound to PATHNAME-DEFAULTS, evaluate theН BODY."Н `(let ((*module-pathname-defaults* ,pathname-defaults)) ,@body))НН(defun register-moduleН (module-nameНЙ&optional (pathname (string module-name))НЙ&aux (module-name-string (string module-name))НЙ (pathnames (if (listp pathname) pathname (ncons pathname))))Н "Register a module so that when it is REQUIREd and its associated filesН are neither already loaded nor named in the REQUIRE call, the system canН determine which files to load.Н MODULE-NAME may be a module name (as a string) or a symbol whose printН name is the module name. PATHNAME, if present, may be a single non-NILН pathname or a list of pathnames whose files are to be loaded in order,Н left to right. If PATHNAME is not provided, the module name is takenН also to be the sole pathname to its files. All pathnames are defaultedН from *MODULE-PATHNAME-DEFAULTS* . The module name is returned."Н (setq pathnames (mapcar #'(lambda (p) (merge-pathnamesНЙЙЙЙЙ p *module-pathname-defaults*))НЙЙЙ pathnames))Н (push (cons module-name-string pathnames) *module-registry*)Н module-name-string)НН(defun register-modules (&rest module-specs)Н "See function REGISTER-MODULE . A MODULE-SPEC is either a module-nameН (string or symbol) or a list of a module-name followed by pathnames toН its associated files. A list of the module names is returned."Н (mapcar #'(lambda (spec) (if (atom spec)НЙЙЙ (register-module spec)НЙЙЙ (register-module (car spec) (cdr spec))))НЙ module-specs))НМН;;;;Extension of REQUIRE Beyond the 1986 ZetaLisp VersionНН#+lispm (defparameter *my-inhibit-fdefine-warnings* t)Н#+lispm (rotatef *my-inhibit-fdefine-warnings* inhibit-fdefine-warnings)НН(defun require (module-nameНЙЙ&optional pathnameНЙЙ&aux (module-name-string (string module-name)))Н "If the named module has not been loaded as indicated by the value ofН *MODULES*, load the appropriate file(s).Н MODULE-NAME may be a module name (as a string) or a symbol whose printН name is the module name. PATHNAME, if present, may be a single pathnameН or a list of pathnames whose files are to be loaded in order, left toН right. If PATHNAME is NIL or is not provided, we check if the module isН registered in *MODULE-REGISTRY*, and if that fails we take the moduleН name also to be the sole pathname. All unregistered pathnames areН defaulted from *MODULE-PATHNAME-DEFAULTS* before loading. We return aН list of pathnames to the files loaded."Н (unless (member module-name-string *modules* :test #'string=)Н (let ((pathnamesНЙ (if pathnameНЙ (mapcar #'(lambda (p)НЙЙЙ (merge-pathnames p *module-pathname-defaults*))НЙЙ (if (consp pathname) pathname (ncons pathname)))НЙ (module-pathnames module-name-string))))Н (mapc #'load pathnames)Н pathnames)))НН#+lispm (rotatef *my-inhibit-fdefine-warnings* inhibit-fdefine-warnings)НМН;;;;Ordered Compiling and Loading of ModulesНН(defconstant *lisp-type-pathname* (make-pathname :type "lisp"))НН(defun compile-load-module (module-name &rest keywords)Н "Compile and/or load or just probe -- as optionally restricted byН :NO-COMPILE and/or :NO-LOAD keywords -- a module's files in order.Н MODULE-NAME may be a module name (as a string) or a symbol whose printН name is the module name.Н If successful we return a list (in compile/load order) of pathnames toН the module's files. (When probing, we return each file's truename ifН found, else NIL)."Н (assert (null (set-difference keywords '(:no-compile :no-load)))НЙ (keywords) "Invalid keyword(s).")Н (let* ((pathnames (module-pathnames module-name))НЙ (compile-p (not (member :no-compile keywords)))НЙ (load-p (not (member :no-load keywords))))Н (if (or compile-p load-p)Н (dolist (pathname pathnames pathnames)НЙ(if compile-pНЙ (compile-file (merge-pathnames pathname *lisp-type-pathname*)))НЙ(if load-p (load pathname)))Н (mapcar #'probe-file pathnames))))НН(defun compile-module (module-name)Н "Compile a module. MODULE-NAME may be a module name (as a string) or aН symbol whose print name is the module name. If successful we return aН list (in compilation order) of pathnames to the module's files."Н (compile-load-module module-name :no-load))НН(defun load-module (module-name)Н "Load a module. MODULE-NAME may be a module name (as a string) or aН symbol whose print name is the module name. If successful we return aН list (in order of loading) of pathnames to the module's files."Н (compile-load-module module-name :no-compile))НН(defun probe-module (module-name)Н "Probe a module's files. MODULE-NAME may be a module name (as a string)Н or a symbol whose print name is the module name. We return a listН containing -- for each of the module's files (in compile-load order) --Н its truename if found, else NIL."Н (compile-load-module module-name :no-compile :no-load))НМН(defmacro registered-modules ()Н "Return a list of the names of registered modules, in the order in whichН they were first registered."Н `(nreverse (delete-duplicates (mapcar #'car *module-registry*)НЙЙЙЙ:test #'string=)))НН(defun compile-load-modules (&rest module-names)Н "Compile and load modules in order. Each MODULE-NAME may be a moduleН name (as a string) or a symbol whose print name is the module name. IfН no MODULE-NAMES are provided, we use (REGISTERED-MODULES).Н If successful we return a list (in compile/load order) of all componentН pathnames."Н (apply #'append (mapcar #'compile-load-moduleНЙЙЙ (or module-names (registered-modules)))))НН(defun compile-modules (&rest module-names)Н "Compile modules in order. This is similar to COMPILE-LOAD-MODULES,Н which see."Н (apply #'append (mapcar #'compile-moduleНЙЙЙ (or module-names (registered-modules)))))НН(defun load-modules (&rest module-names)Н "Load modules in order. This is similar to COMPILE-LOAD-MODULES,Н which see."Н (apply #'append (mapcar #'load-moduleНЙЙЙ (or module-names (registered-modules)))))НН(defun probe-modules (&rest module-names)Н "Probe modules in order. This is similar to COMPILE-LOAD-MODULES,Н which see."Н (apply #'append (mapcar #'probe-moduleНЙЙЙ (or module-names (registered-modules)))))НМН;;;;Messages at End of LoadingНН(format t "~% CommonLisp initialization is complete.~%")НН(format t "Н To set *readtable* to a copy of the standard CommonLisp readtable, typeН (CL-INIT) .~%")Н#+lispm (format t " This is undone upon logout.~%")ННН(format t "Н To register a module, typeН (REGISTER-MODULE module-name [pathname]) .НН To retrieve the names of modules currently registered, typeН (REGISTERED-MODULES) .НН To load a registered module -- or for that matter, often even to load aН simple UNregistered module -- just typeН (REQUIRE ) .НН Please inspect the source file for further documentation of these andН other new facilities.~2%")НLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 1 :LENGTH-IN-BYTES 508 :AUTHOR "SAM" :CREATION-DATE 2721875314 :QFASLP NIL :LENGTH 508 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "DEFINING" :TYPE "LISP" :VERSION 1) ;;; -*- Mode:LISP; Readtable:COMMON-LISP; Base:10 -*-Н#|НН (C) COPYRIGHT 1986 LISP Machine, IncorporatedН All Rights ReservedНН___________________________________________________________________________Н|#НН;;; Samuel F. PilatoНННН;;;;DEFININGНН(provide 'defining)ННН(defmacro alias (inheriting-symbol inherited-symbolНЙЙ &body (&optional doc-string))Н `(setf (symbol-function ',inheriting-symbol) ',inherited-symbolНЙ (documentation ',inheriting-symbol 'function) ,doc-string))НLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 1 :LENGTH-IN-BYTES 800 :AUTHOR "LFW" :CREATION-DATE 2673470266 :QFASLP NIL :LENGTH 800 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "EMPTY" :TYPE "CHART" :VERSION 1) ; -*- mode:LISP; package:(org) ; base: 10. -*- ННН; This file was generated by the ORG program. It contains the Н; information necessary to reconstruct a chart from scratch. Н; Н; Modify this file only if you really know what you're doing.Н; It's much better to run ORG, then load this file, modify it,Н; and save out the preferred version.НН; This is the top node:НН(setq N0608 Н (make-instance 'node Н ':pane *chart-pane Н ':opened? T Н ':attributesН '(("Name" "anonymous") ("Title" ORG:*NEEDS-FILLING-IN) ("Location" ORG:*NEEDS-FILLING-IN)) Н ':justification ':CENTER Н ':extra-width 10. Н ':vertical-separation 10. Н ':horizontal-separation 10.))НН(send *chart-pane ':set-top-node N0608)Н(send N0608 ':set-pane *chart-pane)ННН; Th-th-that's all, folks!LMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 11 :LENGTH-IN-BYTES 11110 :AUTHOR "george" :CREATION-DATE 2686608354 :QFASLP NIL :LENGTH 11110 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "FANCIER-LISPM" :TYPE "LISP" :VERSION 3) ;;;-*- Mode:LISP; Package:USER; Fonts:(MEDFNT HL12I); Patch-File:T; Base:10 -*-Н;1;; ESMITH's LispM init file.* НН;1;; WARNING FROM THE SAGE OF THE INIT FILE, The Hon. I. M. Never Donne, DOA*Н;1;;*Н;1;; It is UNWISE to EXCESSIVELY MODIFY one's LISPM environment, inasmuch*Н;1;; as one may not always be at one's HOME SITE, and may thus, sadly, be UNABLE*Н;1;; TO ACCESS the customized functions one has grown to take for granted. In*Н;1;; particular, attempting to modify the INIT file as the first action after login*Н;1;; indicates INCIPIENT "BRAIN-DAMAGE". Now, go off and eat your SPAM.*НН;1;; Define functions to facilitate initial user query which follows*Н(DEFSUBST SORRY-START-AGAIN (USER HOST)Н (LOGOUT)Н (LOGIN USER HOST))НН(DEFMACRO DEFAULT-USER-NAME ()Н `(READ-FROM-STRINGН (%P-CONTENTS-OFFSET (CDAR *DEFAULT-PATHNAME-DEFAULTS*) 3)))НН(DEFMACRO DEFAULT-USER-HOST ()Н `(%P-CONTENTS-OFFSET (CDAR (LAST *DEFAULT-PATHNAME-DEFAULTS*)) 1))НН(DEFSUBST STRING-SUBSTITUTE-ONCE (OLD-SUBSTRING NEW-SUBSTRING MAIN-STRING)Н (STRING-APPENDН (SUBSTRING MAIN-STRING 0 (STRING-SEARCH OLD-SUBSTRING MAIN-STRING))Н NEW-SUBSTRINGН (SUBSTRING MAIN-STRING (PLUS (STRING-SEARCH OLD-SUBSTRING MAIN-STRING)НЙЙ Й (LENGTH OLD-SUBSTRING))Н Й (LENGTH MAIN-STRING))))НН;1;; Offer to patch up this init file, IN ADVANCE OF loading any more of it*Н(WHEN (Y-OR-N-P "Modify LISPM.INIT ?")Н (FORMAT T (STRING-APPEND "~%Entering ZMacs to edit "НЙЙЙ (default-user-host)НЙЙЙ ": "НЙЙЙ (default-user-name)НЙЙЙ "; LISPM.LISP"))Н (FORMAT T "~%Press any key except -[Abort] to proceed ...")Н (TYI)Н (LET* ((LISPM-INIT-NAMESTRINGНЙ (STRING-APPEND (DEFAULT-USER-HOST) ": "НЙЙЙ (DEFAULT-USER-NAME) "; "НЙЙЙ "LISPM.LISP#>"))НЙ (LISPM-INIT-PATHNAME (FS:PARSE-PATHNAME LISPM-INIT-NAMESTRING)))Н (ED LISPM-INIT-PATHNAME)Н (FORMAT T (STRING-APPEND "~%Compiling changes to " LISPM-INIT-NAMESTRING))Н (COMPILE-FILE LISPM-INIT-PATHNAMEНЙЙ :OUTPUT-FILENAME (STRING-SUBSTITUTE-ONCE ".LISP"НЙЙЙЙЙЙЙ ".INIT"НЙЙЙЙЙЙЙ LISPM-INIT-NAMESTRING)НЙЙ :SET-DEFAULT-PATHNAME NIL)Н (SORRY-START-AGAIN1 *(DEFAULT-USER-NAME) (DEFAULT-USER-HOST))))НН;1;; Make local machine aware of any changes to network configuration since last boot*Н(UPDATE-SITE-CONFIGURATION-INFO)НН;1;; reader macro which causes font changes to be ignored* 1in release 1.2 and below*Н(WHEN (< (SI:GET-SYSTEM-VERSION) 95.)Н (SET-SYNTAX-MACRO-CHAR #\EPSILONН #'(LAMBDA (SPLICE STREAM &AUX (CHAR (SEND STREAM ':TYI)))НЙ(SELECTQ CHARНЙ ((#/0 #/1 #/2 #/3 #/4 #/5 #/6 #/7 #/8 #/9 #/*)НЙ (VALUES SPLICE NIL T))НЙ (:OTHERWISE (SEND STREAM ':UNTYI CHAR)НЙЙ (VALUES (INTERN (STRING #\EPSILON) NIL NIL)))))))НН;1;;Now we can use fontified comments!*НН(PUSH '(PKG-GOTO) LOGOUT-LIST)НН(MAPCAR 'LOGIN-EVALН'((SETQ ZWEI:*CHECK-UNBALANCED-PARENTHESES-WHEN-SAVING* T)Н (SETQ ZWEI:*INITIAL-MINOR-MODES* '(ZWEI:ATOM-WORD-MODE))Н (SETQ ZWEI:LISP-MODE-HOOK 'ZWEI:ELECTRIC-SHIFT-LOCK-IF-APPROPRIATE)Н (SETQ BASE 10. IBASE 10. ZWEI:BASE 10. ZWEI:IBASE 10. *NOPOINT T)Н (SETQ ZWEI:*FILE-VERSIONS-KEPT* 4 ZWEI:*KILL-INTERVAL-SMARTS* T)Н ;1;; Pretty printing* 1for release 1.2 and below*Н (DEFF PP 'GRIND-TOP-LEVEL)Н (DEFUN G (X) (GRIND-TOP-LEVEL X))Н (DEFUN TV:MAKE-IDLE-MESSAGE (MINUTES)Н (COND ((< MINUTES 60.)Н (FORMAT NIL "Goofing off for ~D minute~:P" MINUTES))Н (T (LET ((HOURS (// MINUTES 60.)))Н (IF (> HOURS 12.) (SETQ HOURS (- HOURS 12.)))Н (FORMAT NIL "User absent or asleep for ~d hr ~d min~:P"Н hours (- minutes (* 60. hours)))))))Н))НН;;; 1Make WHO-LINE DOC window readable*Н(SEND TV:WHO-LINE-DOCUMENTATION-WINDOW ':SET-FONT-MAP '(HL10B))НН;;; 1Make a selected symbol globally visible* Н(DEFUN GLOBAL (X)Н (LET* ((STRING-NAME (STRING X)) GLOBAL-ATOM)Н (SETQ GLOBAL-ATOM (INTERN STRING-NAME "GLOBAL"))Н (IF (FBOUNDP GLOBAL-ATOM)НЙNIL 1;;; it is already globalized*Н (GLOBALIZE X))))НН;1;; How big a machine do we have ?*Н(ROOM)НН;1;; Has anybody been glomming memory cards in the dark of night ?*Н(COND ((< (// (SYS:SYSTEM-COMMUNICATION-AREA SYS:%SYS-COM-MEMORY-SIZE) #o2000)НЙ 256.)Н (PRINT "Someone has raided the memory.")Н (TV:BEEP)))НН;1;;* 1the postman always rings twice ?*Н(LET ((MAILFILE (STRING-APPEND (default-user-host)НЙЙЙ ": "НЙЙЙ (default-user-name)НЙЙЙ "; mail.text")))Н (COND ((PROBEF MAILFILE)НЙ (TV:BEEP)НЙ (FORMAT T "You have mail, please use ZMAIL to read it.")НЙ (COND ((Y-OR-N-P "Look at mail? ")НЙЙ(FS:VIEWF MAILFILE)НЙЙ(COND ((YES-OR-NO-P "Delete Mail file? ")НЙЙ (FS:DELETEF MAILFILE))))))))НН;1;; Tell all about current state of software, including microcode and world loads*Н(WHEN (Y-OR-N-P "Display (microcode) bands and load patches ? ")Н (PRINT-DISK-LABEL)Н (LOAD-PATCHES ':NOSELECTIVE)Н (PRINT-SYSTEM-MODIFICATIONS))НН;1;; Predicate to facilitate "applicative iteration" using MAPCAR*Н(DEFMACRO MAKE-COPIES-OF (S-EXPR COUNT)Н `(MAKE-SEQUENCE 'LIST ,COUNT :INITIAL-ELEMENT ,S-EXPR))НН;1;; Boolean test for existance of named entry on master list of loaded systems*Н(DEFSUBST IS-LOADED-SYSTEM (SYSTEM-NAME)Н (CAR (MEMBER TНЙ (MAPCAR 'COMPARE-SYSTEM-NAMEНЙЙ SI:*SYSTEMS-LIST*НЙЙ (MAKE-COPIES-OF SYSTEM-NAME (LENGTH SI:*SYSTEMS-LIST*))))))НН(DEFSUBST COMPARE-SYSTEM-NAME (LOCATIVE SYSTEM-NAME)Н (IF (EQUAL (DATA-TYPE LOCATIVE) 'DTP-ARRAY-POINTER)Н (EQUAL (STRING SYSTEM-NAME)НЙ (STRING-UPCASE (%P-CONTENTS-OFFSET LOCATIVE 2)))Н NIL))НН;1;; Load systems which are sometimes missing in standard load*Н(UNLESS (OR (ASSOC #/K TV:*SYSTEM-KEYS*) ;1;; alternate tests for system existence*НЙ (CAR (MEMBER ':KERMIT SI:*SYSTEMS-LIST*))НЙ (IS-LOADED-SYSTEM 'KERMIT))Н (MAKE-SYSTEM 'KERMIT)) ;1;; Kermit serial file transfer utility*НН;1;; Offer to load miscellaneous simple utility packages*Н(WHEN (Y-OR-N-P "Load quick stats ?")Н (LOAD (STRING-APPEND (default-user-host)НЙЙ ": "НЙЙ (default-user-name)НЙЙ "; quick-stats")))НН;1;; Cut intimidating *"1High-Speed-Godzilla*-M1ouse*"1 down to size...*Н(SETQ TV:MOUSE-FAST-MOTION-SPEED 25.)Н(SETQ TV:MOUSE-FAST-MOTION-CROSS-SIZE 20.)Н(SETQ TV:MOUSE-FAST-MOTION-CROSS-TIME 1000.)НН;1;; set up default* 1font map, for what it is worth*Н(SEND TERMINAL-IO ':SET-FONT-MAPН '(FONTS:MEDFNB FONTS:CPTFONT FONTS:BIGFNT FONTS:5X5))Н(SEND TERMINAL-IO ':SET-CURRENT-FONT 'FONTS:MEDFNB)НН;1; Zwei (ie, ZMACS*) 1customizations.*Н(PKG-GOTO 'ZWEI)НН(PROGN 'COMPILEНН(DEFCOM COM-INDENT-SEXPН"Indent the following s-expression. Each line that starts withinН the s-expression is indented for Lisp, assuming that the lineН the current set point is on is NOT adjusted. This command willН indent the first line as well."Н ()Н (COM-INDENT-FOR-LISP)Н (LET ((BP1 (OR (BEG-LINE (POINT) 1) (BARF)))НЙ(BP2 (OR (FORWARD-SEXP (POINT)) (BARF))))Н (AND (BP-< BP1 BP2)НЙ (WITH-UNDO-SAVE ("Indent sexp" BP1 BP2 T)НЙЙЙ (INDENT-INTERVAL-FOR-LISP BP1 BP2 T))))Н DIS-TEXT)НН(DEFCOM COM-FILL-PARAGRAPH Н"Fill (or adjust) this (or next) paragraph. This is disabled inН LISP mode. Set point stays the same. A positive argument meansН to adjust rather than fill."Н ()Н (IF (EQ *MAJOR-MODE* 'LISP-MODE)Н NIL 1;;; no fill paragraph while in LISP mode*.Н (LET ((INT (PARAGRAPH-INTERVAL (POINT))))Н (FILL-INTERVAL INT NIL T (AND *NUMERIC-ARG-P* (PLUSP *NUMERIC-ARG*)))))Н DIS-TEXT)НН1;;;* 1MODIFIED Append To Buffer which completes buffer names* 1(same as regular, but* ...)Н(DEFCOM COM-PRE-APPEND-TO-BUFFERН"Append region to the specified buffer. The name of the buffer isН read from the keyboard; it is completed normally. With an argument,Н we /"prepend/" instead. Inserts the text at that buffer's point,Н but when prepending leaves the point before the inserted text."Н ()Н (REGION (BP1 BP2)НЙ (LET ((POINT) (MARK)НЙ (BUFFER (READ-BUFFER-NAMEНЙЙЙ (IF *NUMERIC-ARG-P* "Prepend to buffer:" "Append to buffer:")НЙЙЙ NIL NIL)))НЙ (COND ((EQ BUFFER *INTERVAL*)НЙЙ (BARF "That is the current buffer.")))НЙ 1;;;Try to find a window pointing to this buffer and use its point and mark*НЙ (DO ((WL *WINDOW-LIST* (CDR WL))НЙЙ(W))НЙ ((NULL WL)НЙЙ(SETQ POINT (BUFFER-SAVED-POINT BUFFER)НЙЙ MARK (BUFFER-SAVED-MARK BUFFER)))НЙ (COND ((EQ (WINDOW-INTERVAL (SETQ W (CAR WL))) BUFFER)НЙЙ (SETQ POINT (WINDOW-POINT W) MARK (WINDOW-MARK W))НЙЙ (RETURN NIL))))НЙ (MOVE-BP MARK (INSERT-INTERVAL POINT BP1 BP2 T))НЙ (OR *NUMERIC-ARG-P* (SWAP-BPS MARK POINT)) НЙ (MUST-REDISPLAY-OTHER-WINDOWS BUFFER *WINDOW* DIS-TEXT))) Н DIS-NONE)НН) 1;;; end of (PROGN 'COMPILE ...* 1formНН;;;Set up some ZMacs commands for me* (1most of these are Control-Shift or Meta-Shift).*Н(LOGIN-EVALН (set-comtab-return-undo *standard-comtab*НЙЙ '(#\ctrl-altmode com-expand-onlyНЙЙ #\super-ctrl-c com-microcompile-defunНЙ Й #\Hyper-Ctrl-D com-quick-disassembleНЙЙ #\ctrl-top-e com-evaluate-defunНЙЙ #\Super-altmode com-make-word-abbrevНН 1;;; Set up hand keys to work like arrow keys*НЙЙЙ #\hand-up com-up-real-line НЙЙЙ #\hand-down com-down-real-line НЙЙЙ #\hand-left com-backwardНЙЙЙ #\hand-right com-forwardННЙЙЙ 1;;; Make Roman keys do useful things*НЙЙЙ #\roman-i com-backward-paragraphНЙЙЙ #\roman-ii com-forward-paragraphНЙЙЙ #\roman-iii com-beginning-of-lineНЙЙЙ #\roman-iv com-end-of-lineННЙЙЙ 1;;; Make delete do rubouts*НЙЙЙ #\delete com-ruboutНЙ Н 1;;; add various EVAL, COMPILE and MICROCOMPILE options*НЙЙ #\Control-//Й com-Evaluate-RegionНЙЙЙ #\Meta-//Й com-Compile-RegionНЙЙЙ #\Control-Meta-// com-Microcompile-RegionНЙЙЙ #\Control-/`Й com-Evaluate-BufferНЙЙЙ #\Meta-/`Й com-Compile-BufferНЙЙЙ #\Control-Meta-/` com-Microcompile-BufferНЙЙЙ #\Control-{Й com-Evaluate-Buffer-Changed-SectionsНЙЙЙ #\Meta-{Й com-Compile-Buffer-Changed-SectionsНЙЙЙ #\Control-Meta-{ com-Microcompile-Buffer-Changed-SectionsНЙЙЙ #\Control-}Й com-Evaluate-Changed-SectionsНЙЙЙ #\Meta-}Й com-Compile-Changed-SectionsНЙЙЙ #\Control-Meta-} com-Microcompile-Changed-SectionsНЙЙЙ #\Control-/'Й com-Evaluate-Mini-Buffer)))НЙ Н(LOGIN-EVALНЙ (set-comtab *ZMacs-Control-X-Comtab*НЙЙ '(#/AЙЙЙcom-Pre-Append-To-Buffer)))НЙ Н(LOGIN-EVALН (setq Lisp-Mode-HookНЙ #'(lambda ()НЙ (turn-on-mode 'Electric-Shift-Lock-Mode)НЙ (turn-on-mode 'Return-Indents-Mode)НЙ (turn-on-mode 'Electric-Font-Lock-Mode))))НЙ Н(LOGIN-EVALН (setq Text-Mode-HookНЙ #'(lambda ()НЙ (turn-off-mode 'Electric-Shift-Lock-Mode)НЙ (turn-on-mode 'Any-Bracket-Mode))))НН1;;; Leave Lisp Listener in a reasonable context*Н(PKG-GOTO 'USER)НН;1;; LOGIN-EVAL this last, so that when logging out, it will be done first.*Н(LOGIN-EVAL '(ZWEI:SAVE-ALL-FILES))НLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 24 :LENGTH-IN-BYTES 23808 :AUTHOR "MDS" :CREATION-DATE 2712055842 :QFASLP NIL :LENGTH 23808 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "FORTRAN-CALL" :TYPE "LISP" :VERSION 1) #| -*- Mode:LISP; Package:(FCALL global); Fonts:(cptfontb); Base:10 -*-НН Copyright LISP Machine, Inc. 1985Н See filename "Copyright" forН licensing and release information.ННA self-contained example of how to build an interprocessorНFORTRAN-CALL library mechanism. 5/18/85 13:16:28 -George CarretteННThe goal would be to have a system such that if,ННWe define:НН(DEFINE-FORTRAN-LIBRARY "documentation"Н :executable-image "/usr/flib/streamlib"НН :subroutine (FFT (X :REAL-ARRAY)НЙЙ (Y :REAL-ARRAY)НЙЙ (N :INTEGER))НН :subroutine (IFT (X :REAL-ARRAY)НЙЙ (Y :REAL-ARRAY)НЙЙ (N :INTEGER)))НННThen:Н (GENERATE-MAIN-PROGRAM ') ==> causes a main program in "C" to be generated.Н (GENERATE-EXECUTABLE ') ==> compiles the "C" program and calls the linker.ННBefore a subroutine may be called there must be an executable program startedНup on the connected shared processor, to do this we would instantiated aНjob, duty or processing thread, whatever you want to call it.ННPrequisite to run:НН (SETQ *ABLE* (INSTANTIATE-FORTRAN-LIBRARY '))НННTo run:НН (SETQ X (MAKE-ARRAY 16 :ELEMENT-TYPE 'FLOAT))Н (SETQ Y (MAKE-ARRAY 16 :ELEMENT-TYPE 'FLOAT))НН (SEND *ABLE* :CALL "FFT" X Y 16)ННA simple :CALL such as the above would not return until the computationНon the coprocessor had completed. However, that need not be the case,Нwe could say instead:НН (SEND *ABLE* :CO-CALL "FFT" X Y 16)НН Which would return immediately. To found out when the computation isН complete and the values in the arrays X and Y are consistent we sendН a message:НН (EQ (SEND *ABLE* :STATE) :DONE) => true if the computation is complete.ННAn example of doing two things at the same time would be:НН (LET ((DONE NIL))Н (PROCESS-RUN-FUNCTION "symbolic way"Н #'(lambda ()Н (find-the-answer-using-AI-techniques X Y Z)Н (setq done t)))Н (SEND *ABLE* :CO-CALL "SOLVE9" X Y Z)Н (PROCESS-WAIT "thinking" #'(lambda () (or done (eq :done (send *able* :STATE)))))Н (if doneН (format t "The answer was found first using AI techniques")Н (format t "The answer was found first using the old FORTRAN numerical way")))НННННImplementation:Н fort.h A file of declarations shared by all files.Н fmain.c The main subroutine, which opens the syncronizing device,Н initializes pointers to shared memory, and calls fexecН for each subroutine call request.Н fexec.c This gets an opcode from shared memory, and calls fload toН get a link (dynamically or statically) to a FORTRAN subroutine.Н It then sets up an argument vector by normalizing the arglistН in shared memory by the base of shared memory in the Н user process. The linked FORTRAN subroutine is then called,Н and a shared memory location is set to zero to indicateН completion of the subroutine.Н fload.c In our example this is a static linking of an array ofН pointers to FORTRAN subroutines.Н ftable.c The dispatch table of FORTRAN subroutines.Н flib.f The fortran subroutines.ННNote: In the example we do not address the issue of interlockingН of shared memory resources such as would be needed withН multiple instantiations of fortran libraries in or acrossН lambda processors.НН|#ННН(defmacro DEFINE-FORTRAN-LIBRARY (name documentation &rest body)Н `(*define-fortran-library ',name ,documentation ',body))НН(defun *define-fortran-library (name documentation arguments)Н (when (record-source-file-name name 'define-fortran-library)Н (setf (function-documentation name 'fortran-library) documentation)Н (do ((l arguments (cddr l))НЙ (plist))НЙ((null l)НЙ (setf (get name 'fortran-library) plist))Н (ecase (car l)НЙ((:unix-filename-append :executable-image :link-table :files)НЙ (setf (getf plist (car l)) (cadr l)))НЙ(:subroutineНЙ (let ((subroutine (if (atom (cadr l)) (list (cadr l)) (cadr l))))НЙ (push subroutine (getf plist :subroutines))))))))НН(defflavor fortran-imageНЙ ((name nil) sync-stream (processor nil)НЙ eval-server-processНЙ (eval-server-output "")НЙ commandНЙ return-valuesНЙ being-calledНЙ (flushed nil)НЙ opcode-pointer)НЙ ()Н :initable-instance-variablesН :settable-instance-variables)ННН(defmethod (fortran-image :print-self) (stream &rest ignored)Н (format stream "#"НЙ name processorНЙ eval-server-output))НН(defun instantiate-fortran-library (name &optional (port-number 5))Н ;; in fact the port number should be auto incrementedН (check-arg name (fortran-libraryp name) "a fortran library")Н (let ((port (open (format nil "UNIX-STREAM-~D:" port-number)))НЙ(proc (attached-unix-host))НЙ(os (make-array 200 :fill-pointer 0 :element-type 'string-char))НЙ(command (format nil "~a //dev//ttyl~D"НЙЙЙ (send (fortran-library-pathname name :executable-image)НЙЙЙ :string-for-host)НЙЙЙ port-number)))Н (let ((obj (make-instance 'fortran-imageНЙЙЙ :name nameНЙЙЙ :sync-stream portНЙЙЙ :processor procНЙЙЙ :eval-server-output osНЙЙЙ :command command)))Н (send obj :start-process)Н (process-wait "unix startup"НЙЙ #'(lambda (x)НЙЙЙ(> (length (send x :eval-server-output))НЙЙЙ (length (send x :command))))НЙЙ obj)Н obj)))ННН(defmethod (fortran-image :start-process) ()Н (setq eval-server-processНЙ(process-run-functionНЙ (format nil "fortran library ~A" name)НЙ #'fortran-image-simple-unix-evalНЙ processorНЙ commandНЙ (make-string-output-stream eval-server-output)НЙ self)))ННН(defun fortran-image-simple-unix-eval (processor command output done)Н (simple-unix-eval processor command output)Н (send done :set-flushed t))ННН(defvar *shared-memory-type-array* ())НН(defvar *value-free-pointer* 0)НН(defun allocate-value-space ()Н ;; this is where interlocking between processors might happen.Н (or (and *shared-memory-type-array*НЙ (= (length *shared-memory-type-array*)НЙ (quotient (length si:*global-shared-memory-16*) 2)))Н (setq *shared-memory-type-array*НЙ (make-array (quotient (length si:*global-shared-memory-16*) 2))))Н (setq *value-free-pointer* 0))НН(defsetf read-value write-value)НН(defun read-value (location type)Н "Read a value and do representation conversion"Н (let ((n (dpb (aref si:*global-shared-memory-16* (1+ (ash location 1)))НЙЙ#o2020НЙЙ(aref si:*global-shared-memory-16* (ash location 1)))))Н (ecase typeН (:realН (68000-float->lispm n))Н (:integerН (signed-68000->lispm n))Н (nilН n))))НН(defun write-value (location type value)Н "Write a value of a given type into the shared location, doing representationНconversion for types of :REAL and :INTEGER."Н (let ((n (ecase typeНЙ (:realНЙ (lispm-float->68000 value))НЙ (:integerНЙ (signed-lispm->68000 value)))))Н (setf (aref si:*global-shared-memory-16* (ash location 1))НЙ (ldb #o0020 n))Н (setf (aref si:*global-shared-memory-16* (1+ (ash location 1)))НЙ (ldb #o2020 n))Н (setf (aref *Shared-memory-type-array* location) type)))НН(defun push-value (value type)Н (setf (read-value *value-free-pointer* type) value)Н (incf *value-free-pointer*))НН(defun read-known-value (location)Н (read-value location (aref *shared-memory-type-array* location)))ННН(defun dump-value-space (&optional (end (length *shared-memory-type-array*)))Н (format t "~&Location Type Value~%")Н (dotimes (j end)Н (let ((type (aref *shared-memory-type-array* j)))Н (format t "~4D ~7A ~S~%" J TYPE (read-value j type)))))НЙ НН(defmethod (fortran-image :co-call) (subroutine &rest arguments)Н (let* ((subroutines (getf (get name 'fortran-library) :subroutines))НЙ (desc (ass #'string-equal subroutine subroutines)))Н (or desc (ferror nil "No subroutine called ~A in fortran library ~A"НЙЙ subroutine name))Н (setq being-called desc)Н (let ((nargs (length arguments))НЙ (opcode (1+ (find-position-in-list desc subroutines)))НЙ (argspointer))Н (or (= nargsНЙ (length (cdr desc)))НЙ (ferror nil "Fortran subroutine ~A expects ~D argument~p, got ~D"НЙЙ subroutineНЙЙ (length (cdr desc))НЙЙ (length (cdr desc))НЙЙ nargs))Н (allocate-value-space)Н (setq opcode-pointer *value-free-pointer*)Н (push-value opcode :integer)Н (push-value nargs :integer)Н (setq argspointer *value-free-pointer*)Н (incf *value-free-pointer* nargs)Н (setq return-values nil)Н (do ((actuals arguments (cdr actuals))НЙ (formals (cdr desc) (cdr formals))НЙ (j 0 (1+ j)))НЙ ((null actuals))НЙ(let ((pointer *value-free-pointer*)НЙ (datatype (cadr (car formals)))НЙ (data (car actuals)))НЙ (if (typep data 'sequence)НЙ (push (list data datatype pointer) return-values))НЙ (setf (read-value (+ argspointer j) :integer) pointer)НЙ (ecase datatypeНЙ ((:real :integer)НЙ (push-value (if (typep data 'sequence)НЙЙЙ (elt data 0)НЙЙЙ data)НЙЙЙ datatype))НЙ ((:real-array :integer-array)НЙ (let ((element-type (cadr (assq datatype '((:real-array :real)НЙЙЙЙЙЙЙ(:integer-array :integer))))))НЙ (dotimes (k (length data))НЙЙ (push-value (elt data k) element-type)))))))Н (send sync-stream :tyo #/X)Н (send sync-stream :tyo 13)Н (send sync-stream :force-output)Н )))ННН(defmethod (fortran-image :stop) ()Н (cond ((not flushed)НЙ (send sync-stream :tyo #/S)НЙ (send sync-stream :tyo 13)НЙ (send sync-stream :force-output)НЙ (process-wait "unix to stop"НЙЙ #'(lambda (x) (send x :flushed))НЙЙ self)НЙ (close sync-stream)НЙ (setq sync-stream nil)НЙ (setq eval-server-process nil)))Н self)НН(defmethod (fortran-image :state) ()Н (if (zerop (read-value opcode-pointer :integer)) :done :computing))ННН(defmethod (fortran-image :call) (subroutine &rest arguments)Н (lexpr-send self :co-call subroutine arguments)Н (process-wait "computing" #'(lambda (x) (eq :done (send x :state))) self)Н (send self :get-return-values))НН(defmethod (fortran-image :get-return-values) ()Н (dolist (item return-values)Н (let ((sequence (car item))НЙ (pointer (caddr item)))Н (dotimes (j (length sequence))НЙ(setf (elt sequence j) (read-known-value (+ pointer j)))))))ННН(compile-flavor-methods fortran-image)ННН(defun simple-unix-eval (host command &optional (stream standard-output))Н (with-open-stream (s (chaos:open-stream hostНЙЙЙЙЙ (format nil "EVAL ~a" command)))Н (format stream "~&% ~A~%" command)Н (do ((c (send s ':tyi) (send s ':tyi)))НЙ((null c))Н (send stream ':tyoНЙ (selectq cНЙ ((#o12 #o15) #\return)НЙ (#o11 #\tab)ЙЙ НЙ (t c))))))НН(defun attached-unix-host ()Н "Returns host object for attached unix-host if it exits otherwise NIL"Н;; Relevant variable:Н;; si:*other-processors* list of structures of type SI:OTHER-PROCESSORН (dolist (op si:*other-processors*)Н (let ((host (SI:GET-HOST-FROM-ADDRESSНЙЙ (si:%processor-conf-chaos-address (si:op-proc-conf op))НЙЙ ':CHAOS)))Н (if (typep host 'fs:unix-host)НЙ (return host)))))НН;; data conversion:Н;; In the lisp environment all 68000 data is manipulated as 32 bit integers.НН(defun 68000-byteswap (integer)Н (dpb (ldb #o0010 integer)Н #o3010Н (dpb (ldb #o1010 integer)НЙ #o2010НЙ (dpb (ldb #o2010 integer)НЙЙ #o1010НЙЙ (ldb #o3010 integer)))))НН(defun signed-lispm->68000 (integer)Н (68000-byteswap integer))НН(defun signed-68000->lispm (integer)Н (let ((n (68000-byteswap integer)))Н (if (bit-test 1_31 n)НЙ(- n 1_32)Н n)))ННН(defun 68000-float->lispm (x)Н "Take 32bits, a 68000 float, and return a lisp float object"Н (// (* (expt -1 (ldb #o3701 x))НЙ (expt 2.0 (- (ldb #o3007 x) #o100))НЙ (+ (ldb #o2010 x)НЙ (ash (+ (ldb #o1010 x)НЙЙ (ash (ldb #o0010 x)НЙЙЙ 8))НЙЙ 8)))Н #o100000000))ННН(defun lispm-float->68000 (x &aux sign exp frac)Н "Take a lispmachine floating point number and return 32 bits suitable for the 68000"Н (cond ((zerop x)НЙ (return-from lispm-float->68000 0))НЙ((< x 0.0)НЙ (setq sign 1)НЙ (setq x (- x)))НЙ('elseНЙ (setq sign 0)))Н (etypecase xН (short-floatН (setq exp (+ (- (si:%short-float-exponent x) #o200) #o100))Н (setq frac (ash (si:%short-float-mantissa x)НЙЙ (- 23 16))))Н (single-floatН (setq exp (+ (- (si:%single-float-exponent x) #o2000) #o100))Н (setq frac (ash (si:%single-float-mantissa x)НЙЙ (- 23 30)))))Н (if (or (< exp 0)НЙ (> exp #o177))Н (ferror nil "Exponent too big to represent in 68000: ~S" x))Н (dpb sign #o3701Н (dpb exp #o3007НЙ (dpb (ldb #o0010 frac) #o2010НЙЙ (dpb (ldb #o1010 frac) #o1010НЙЙ (ldb #o2010 frac))))))НННН;; generation of code and linking.ННН(defun fortran-libraryp (name)Н (get name 'fortran-library))НН(defun fortran-library-pathname (name type &optional (to-host (attached-unix-host)))Н (let ((p (fortran-libraryp name)))Н (let ((l (getf p type))НЙ (a (getf p :unix-filename-append)))Н (if (and (symbolp a) (boundp a))НЙ (setq a (symeval a)))Н (cond ((atom l)НЙ (fs:parse-pathname (if a (string-append a l) l) to-host))НЙ ('elseНЙ (mapcar #'(lambda (x) (fs:parse-pathname (if a (string-append a x) x)НЙЙЙЙЙЙ to-host))НЙЙ l))))))НН(defun generate-main-program (name &aux plist subroutines)Н "generates the link table for fortran library NAME"Н (check-arg name (setq plist (fortran-libraryp name)) "a fortran library")Н (setq subroutines (mapcar #'(lambda (x)НЙЙЙЙ(if (> (length (cdr x)) 9)НЙЙЙЙ (ferror nilНЙЙЙЙЙ "Too many arguments in subroutine: ~S"НЙЙЙЙЙ x))НЙЙЙЙ(string-downcase (car x)))НЙЙЙ (getf plist :subroutines)))Н (with-open-file (s (fortran-library-pathname name :link-table)НЙЙ :out)Н (format s "~Н ~70,,,'*~Н ~%~70< * Automatically generated C code for the FORTRAN link ~;*~>~Н ~%~70< * Compiled from ~S by ~S ~;*~>~Н ~%~70< * ~A ~;*~>~Н ~%~71,,,'*< *~;//~>~Н ~%~%#include /"fort.h/"~2%~Н ~%~{int ~a();~%~}~Н ~%int (*ftable[])() = {noop,~%~{ ~a~^,~%~}};~%"НЙ nameНЙ si:user-idНЙ (time:print-current-date nil)НЙ subroutinesНЙ subroutinesНЙ )))НННН(defun generate-executable (name)Н (check-arg name (fortran-libraryp name) "a fortran library")Н (flet ((hosty (x) (send x :string-for-host)))Н (simple-unix-eval (attached-unix-host)НЙЙ (format nilНЙЙЙ "cc -o ~a ~{~a ~} ~a -lshare -lF77 -lI77"НЙЙЙ (hosty (fortran-library-pathname name :executable-image))НЙЙЙ (mapcar #'hosty (fortran-library-pathname name :files))НЙЙЙ (hosty (fortran-library-pathname name :link-table))))))НН;; the exampleНН(defvar *udir* "//usr//gjc//fort//")НН(define-fortran-library example "an example"Н :subroutine (VADD (X :real-array)НЙЙ (y :real-array)НЙЙ (z :real-array)НЙЙ (n :integer))Н :subroutine (vmult (X :real-array)НЙЙ (y :real-array)НЙЙ (z :real-array)НЙЙ (n :integer))Н :subroutine (vprint (x :real-array)НЙЙ (n :integer))Н :unix-filename-append *udir*Н :executable-image "example"Н :link-table "ftable.c"Н :files ("fmain.o" "fload.o" "fexec.o" "flib.o"))ННН(defun setup-unix-source-files (&optional (h (string-appendНЙЙЙЙЙ (send (attached-unix-host)НЙЙЙЙЙЙ :name)НЙЙЙЙЙ ":")))Н (let (ofile)Н (unwind-protectНЙ(with-open-file (s (send (si:get-source-file-name 'setup-unix-source-files )НЙЙЙЙ :new-pathname :type "LISP" :version :NEWEST))НЙ (do ((line))НЙ ((null (setq line (readline s nil))))НЙ (cond ((string-equal "Filename:" lineНЙЙЙЙ :end2 (length "Filename:"))НЙЙ (when ofileНЙЙ (close ofile)НЙЙ (setq ofile nil))НЙЙ (setq line (string-append h *udir*НЙЙЙЙЙ (string-trimНЙЙЙЙЙ '(#\space)НЙЙЙЙЙ (substring lineНЙЙЙЙЙЙЙ (length "Filename:")))))НЙЙ (print line)НЙЙ (setq ofile (open line :direction :Output)))НЙЙ ((string-equal "||#" line :end2 (length "||#"))НЙЙ (when ofileНЙЙ (close ofile)НЙЙ (setq ofile nil)))НЙЙ (ofileНЙЙ (princ line ofile)НЙЙ (terpri ofile)НЙЙ (princ ".")))))Н (and ofile (close ofile)))))НН#||ННTo run the example, create a directory /usr/gjc/fortНand put the files fmain.c, fload.c, fexec.c flib.fНin it. (You can do that by running SETUP-UNIX-SOURCE-FILES)ННThen generate ftable.c with the command (from lisp):НН (generate-main-program 'example)ННThen compile all the C programs with the commands (from unix):Н(or run the command % sh compile.sh)НН cc -c fmain.cН cc -c fload.cН cc -c fexec.cННThen compile all the fortran functions with the command (from unix):НН f77 -c flib.fННEverything may be linked together with the command (from lisp):НН (generate-executable 'example)НННThen instantiate a runnable image of the library:НН (SETQ LIB (INSTANTIATE-FORTRAN-LIBRARY 'EXAMPLE))НН (setq x '(1.0 2.0 3.0))Н (setq y '(1.0 2.0 3.0))Н (setq z '(0.0 0.0 0.0))ННН (SEND LIB :CALL "VMULT" X Y Z 3)ННThen look at Z.НННThe C and fortran code follows:ННFilename: fort.hНН/**************************************Н * Copyright LISP Machine, Inc. 1985 *Н * See filename "Copyright" for *Н * licensing and release information. *Н **************************************/ННint noop();ННint (*(fload()))();ННint (*ftable[])();ННFilename: fmain.cНН/**************************************Н * Copyright LISP Machine, Inc. 1985 *Н * See filename "Copyright" for *Н * licensing and release information. *Н **************************************/НН#include НН#include ННmain(argc,argv) int argc; char **argv;Н{ int n,chan;Н char c;Н if (argc != 2) {printf("\n%s \n",argv[0]);exit(1);}Н chan = open(argv[1],2);Н if (chan < 0) {printf("\ncouldnt open syncronizing device: %s\n",argv[1]);НЙЙЙ exit(1);}Н if (share_setup() < 0) {printf("share_setup failed");exit(1);}Н while(1)Н { n = read(chan,&c,1);Н if (n != 1) {printf("\nsyncronizing device read failed\n");exit(1);}Н if ( c == 'S') {printf("\nbeen told to stop\n");exit(1);}Н if ( c == 'X') fexec(sharebase);}}ННННFilename: fexec.c НН/**************************************Н * Copyright LISP Machine, Inc. 1985 *Н * See filename "Copyright" for *Н * licensing and release information. *Н **************************************/НН/* execute a subroutine call out of arguments passed in the heap.Н All arguments are call-by-reference, which is FORTRAN style.НН Heap format:Н Н 0 [Opcode]Н 1 [Number-Of-Arguments]Н 2 [ARG1]Н 3 [ARG2]Н ...Н 9 [ARG9]Н 10 begining of actual argument value storage heapНН*/НН#include "fort.h"Н#include ННfexec(heap) int *heap;Н { int (*func)(), v[9];Н func = fload(heap[0]);Н setargs(heap,&heap[2],v,heap[1]);НН switch (heap[1])Н { case 0: (*func)(); break;Н case 1: (*func)(v[0]); break;Н case 2: (*func)(v[0],v[1]); break;Н case 3: (*func)(v[0],v[1],v[2]); break;Н case 4: (*func)(v[0],v[1],v[2],v[3]); break;Н case 5: (*func)(v[0],v[1],v[2],v[3],v[4]); break;Н case 6: (*func)(v[0],v[1],v[2],v[3],v[4],v[5]); break;Н case 7: (*func)(v[0],v[1],v[2],v[3],v[4],v[5],v[6]); break;Н case 8: (*func)(v[0],v[1],v[2],v[3],v[4],v[5],v[6],v[7]); break;Н case 9: (*func)(v[0],v[1],v[2],v[3],v[4],v[5],v[6],v[7],v[8]); break;Н default: break;}Н heap[0] = 0;}НННsetargs(absbase,reloffsets,v,n) int *absbase, *reloffsets, **v,n;Н { int j;Н for (j = 0; Н j. No specific prompt isН;;; provided to the user.Н(defun get-command ()Н "Calls appropriate line editor functions for commands input by the user."Н (let ((command (read)))НЙ(selectq commandНЙ (q (format t "~%Editing session ended."))НЙ (i (insert) (display) (get-command))НЙ (a (begin-line) (display)(get-command))НЙ (e (end-line) (display) (get-command))НЙ (f (forward) (display) (get-command))НЙ (b (back) (display) (get-command))НЙ (d (delete-it) (display) (get-command))НЙ (otherwise (format t "Not a legal command. Try again.")НЙЙ (get-command)))))НННН;;; Function INSERT puts the user into insert mode.Н;;; Insertion before the cursor is accomplished by pushing a new elementН;;; onto *buffer1*.Н(defun insert ()Н "Inserts an atom into a line of text."Н (array-push-extend *buffer1* (read)))Н НН;;; Function BEGIN-LINE moves the cursor to the beginning of the line byН;;; transfering the active contents of *buffer1* into *buffer2*. Н(defun begin-line ()Н "Move cursor to the beginning of the current line."Н (cond ((zerop (fill-pointer *buffer1*))) ; already at beginningНЙ(t (loop for i from 0 to (sub1 (fill-pointer *buffer1*))НЙЙЙЙ do (transfer *buffer1* *buffer2*)))))Н НН;;; Function END-LINE moves the cursor to the end of the line by Н;;; transfering the active contents of *buffer2* into *buffer1*.Н(defun end-line ()Н "Move cursor to the end of the current line."Н (cond ((zerop (fill-pointer *buffer2*))) ; already at endНЙ(t (loop for i from (sub1 (fill-pointer *buffer2*)) downto 0НЙЙЙЙ do (transfer *buffer2* *buffer1*)))))ННН;;; Function FORWARD moves the cursor forward one position by transferringН;;; the top element of *buffer2* into *buffer1*.Н;;; Note the alternative test for whether already at the end of the line,Н;;; as compared to the previous function.Н(defun forward ()Н "Moves the cursor forward one position."Н (cond ((null (aref *buffer2* 0)) (beep-on-terminal)) НЙ (t (transfer *buffer2* *buffer1*)))) Н ННН;;; Function BACK moves the cursor back one position by transferring Н;;; the top element of *buffer1* into *buffer2*.Н(defun back ()Н "Moves the cursor back one position."Н (cond ((zerop (fill-pointer *buffer1*)) (beep-on-terminal)) НЙ (t (transfer *buffer1* *buffer2*))))ННН;;; Function DELETE removes the item before the cursor by popping offН;; *buffer1*. There is no provision here for yanking back this deletion.Н(defun delete-it ()Н (cond ((not (null (aref *buffer1* 0))) ; nothing to deleteНЙ (array-pop *buffer1*))НЙ(t (beep-on-terminal))))НННLMFL(:BYTE-SIZE 16 :LENGTH-IN-BLOCKS 4 :LENGTH-IN-BYTES 2048 :AUTHOR "ESMITH" :CREATION-DATE 2686576591 :QFASLP NIL :LENGTH 2048 :DIRECTORY "LISP2-CIRCULATION" :NAME "LISPM" :TYPE "INIT" :VERSION 2) h╞░s2АDАpА,АмБCOMPILE-DATADАьАESMITHьБTest Lambda CАЖА!азхFАfFА;DАpА,БCOMPILER,ВNEW-DESTINATIONSpАьАGLOBALlАTАpАBА мАSITEpАBА мАLMIАpАBА мГQFASL-SOURCE-FILE-UNIQUE-IDА1АDАpАlАFSьВMAKE-FASLOAD-PATHNAMEАDАpАBА+ьАQUOTEАмАLAMBDАBА:мАDSKАDАBА:lВLISP2-CIRCULATIONАDАBА:ьАLISPMАDАBА:мАLISPDАBА:FАpАBА мАBASEFА pАBА lБPATCH-FILEpАBА lАTАpАBА ьАFONTSАDАpАBА ьАMEDFNTpАBА ьАHL12IАpАBА ,БPACKAGEАpАBА мАUSER1АDАГАANDАDАCА<АDАpАlАSIlВGET-SYSTEM-VERSIONFА_DА├АPROGNАDА├ВSET-SYNTAX-MACRO-CHARАFАDАБFUNCTIONDА├АLAMBDADА├АSPLICE├АSTREAMГА&AUXDАГАCHARDАГАSENDBАjDАBА:pАBА мАTYIАDАБSELECTQАBАlDАDАFА0FА1FА2FА3FА4FА5FА6FА7FА8FА9FА*DА├АVALUESBАiГАNILАBА-DАpАBА lБOTHERWISEАDАBАmBАjDАBА:pАBА ьАUNTYIАBАlDАBАБDА├АINTERNDА├АSTRINGFАBАВBАВ1АDАГАCONSDАBА:DАБPKG-GOTOГБLOGOUT-LISTАNАЯBАЭ1АDА├АMAPCARDАBА:CБLOGIN-EVALDАBА:DАDАГАSETQp└мАZWEIlЕ*CHECK-UNBALANCED-PARENTHESES-WHEN-SAVING*BА-DАBАгp└BАдьВ*INITIAL-MINOR-MODES*АDАBА:DАp└BАдьБATOM-WORD-MODEDАBАгp└BАдьБLISP-MODE-HOOKDАBА:p└BАдlДELECTRIC-SHIFT-LOCK-IF-APPROPRIATEDАBАгГАBASEFА ├АIBASEАFА BА╡FА BА╖FА Б*NOPOINTBА-DАBАгp└BАдмВ*FILE-VERSIONS-KEPT*FАp└BАдьВ*KILL-INTERVAL-SMARTS*BА-DАГАDEFFCАPPDАBА:ВGRIND-TOP-LEVELАDА├АDEFUNАCАGАDАCАXАDАBА┼BА╩DАBА╚p└lАTVlВMAKE-IDLE-MESSAGEАDАБMINUTESАDАГАCONDDАDАBА]BА╤FА<DА├АFORMATBАВмГGoofing off for ~D minute~:PBА╤DАBА-DАГАLETАDАDА├АHOURSАDАCА/АBА╤FА<DАCАIFDАCА>АBА█FАDАBАгBА█DАCА-АBА█FАDАBА╓BАВlЕUser absent or asleep for ~d hr ~d min~:PАBА█DАBАхBА╤DАCА*АFА<BА█1АDАБFUNCALLАp└BА╬ьГWHO-LINE-DOCUMENTATION-WINDOWАDАBА:pАBА мБSET-FONT-MAPDАBА:DА├АHL10BА1АDАBА°ГБTERMINAL-IOАDАBА:BА№DАBА:DАpАьАFONTSА,БCPTFONTАpАBАьАMEDFNBpАBАьАBIGFNTpАBАмА5X5А1АDАBА°BАDАBА:pАBА ,ВSET-CURRENT-FONTDАBА:BА1АDАBАЪDАBА:ГАZWEI1АDА├АDEFCOMВCOM-INDENT-SEXPА,ЬIndent the following s-expression. Each line that starts withinН the s-expression is indented for Lisp, assuming that the lineН the current set point is on is NOT adjusted. This command willН indent the first line as well.АBАВDАГВCOM-INDENT-FOR-LISPАDАBА┌DАDАГАBP1АDАCАORDАБBEG-LINEDА├АPOINTАFАDАГАBARFDАГАBP2АDАBА"DАГБFORWARD-SEXPDАBА$DАBА(DАBА\DАГАBP- HOURS 12.) (SETQ HOURS (- HOURS 12.)))Н (FORMAT NIL "User absent or asleep for ~d hr ~d min~:P"Н hours (- minutes (* 60. hours)))))))Н))НН;;; 1Make WHO-LINE DOC window readable*Н(SEND TV:WHO-LINE-DOCUMENTATION-WINDOW ':SET-FONT-MAP '(HL10B))НН;1;; set up default* 1font map, for what it is worth*Н(SEND TERMINAL-IO ':SET-FONT-MAPН '(FONTS:CPTFONT FONTS:MEDFNB FONTS:BIGFNT FONTS:5X5))Н(SEND TERMINAL-IO ':SET-CURRENT-FONT 'FONTS:CPTFONT)НН;1; Zwei (ie, ZMACS*) 1customizations.*Н(PKG-GOTO 'ZWEI)НН(PROGN 'COMPILE ;1;; a typical ZMACS customization*НН(DEFCOM COM-INDENT-SEXPН"Indent the following s-expression. Each line that starts withinН the s-expression is indented for Lisp, assuming that the lineН the current set point is on is NOT adjusted. This command willН indent the first line as well."Н ()Н (COM-INDENT-FOR-LISP)Н (LET ((BP1 (OR (BEG-LINE (POINT) 1) (BARF)))НЙ(BP2 (OR (FORWARD-SEXP (POINT)) (BARF))))Н (AND (BP-< BP1 BP2)НЙ (WITH-UNDO-SAVE ("Indent sexp" BP1 BP2 T)НЙЙЙ (INDENT-INTERVAL-FOR-LISP BP1 BP2 T))))Н DIS-TEXT)НН) 1;;; end of (PROGN 'COMPILE ...* 1formНН;;;Set up some ZMacs commands for me* (1most of these are Control-Shift or Meta-Shift).*Н(LOGIN-EVALН (set-comtab-return-undo *standard-comtab*НЙЙ '(#\ctrl-altmode com-expand-onlyНЙЙ #\super-ctrl-c com-microcompile-defunНЙ Й #\Hyper-Ctrl-D com-quick-disassembleНЙЙ #\ctrl-top-e com-evaluate-defunНЙЙ #\Super-altmode com-make-word-abbrevНН 1;;; Set up hand keys to work like arrow keys*НЙЙЙ #\hand-up com-up-real-line НЙЙЙ #\hand-down com-down-real-line НЙЙЙ #\hand-left com-backwardНЙЙЙ #\hand-right com-forwardННЙЙЙ 1;;; Make Roman keys do useful things*НЙЙЙ #\roman-i com-backward-paragraphНЙЙЙ #\roman-ii com-forward-paragraphНЙЙЙ #\roman-iii com-beginning-of-lineНЙЙЙ #\roman-iv com-end-of-lineННЙЙЙ 1;;; Make delete do rubouts*НЙЙЙ #\delete com-ruboutНЙ Н 1;;; add various EVAL, COMPILE and MICROCOMPILE options*НЙЙ #\Control-//Й com-Evaluate-RegionНЙЙЙ #\Meta-//Й com-Compile-RegionНЙЙЙ #\Control-Meta-// com-Microcompile-RegionНЙЙЙ #\Control-/`Й com-Evaluate-BufferНЙЙЙ #\Meta-/`Й com-Compile-BufferНЙЙЙ #\Control-Meta-/` com-Microcompile-BufferНЙЙЙ #\Control-{Й com-Evaluate-Buffer-Changed-SectionsНЙЙЙ #\Meta-{Й com-Compile-Buffer-Changed-SectionsНЙЙЙ #\Control-Meta-{ com-Microcompile-Buffer-Changed-SectionsНЙЙЙ #\Control-}Й com-Evaluate-Changed-SectionsНЙЙЙ #\Meta-}Й com-Compile-Changed-SectionsНЙЙЙ #\Control-Meta-} com-Microcompile-Changed-SectionsНЙЙЙ #\Control-/'Й com-Evaluate-Mini-Buffer)))НЙ Н(LOGIN-EVALН (setq Lisp-Mode-HookНЙ #'(lambda ()НЙ (turn-on-mode 'Electric-Shift-Lock-Mode)НЙ (turn-on-mode 'Return-Indents-Mode)НЙ (turn-on-mode 'Electric-Font-Lock-Mode))))НЙ Н(LOGIN-EVALН (setq Text-Mode-HookНЙ #'(lambda ()НЙ (turn-off-mode 'Electric-Shift-Lock-Mode)НЙ (turn-on-mode 'Any-Bracket-Mode))))НН1;;; Leave Lisp Listener in a reasonable context*Н(PKG-GOTO 'USER)НН;1;; LOGIN-EVAL this last, so that when logging out, it will be done first.*Н(LOGIN-EVAL '(ZWEI:SAVE-ALL-FILES))НLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 4 :LENGTH-IN-BYTES 3404 :AUTHOR "SAM" :CREATION-DATE 2720492885 :QFASLP NIL :LENGTH 3404 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "LIST-PATTERNS" :TYPE "LISP" :VERSION 1) ;;; -*- Mode:LISP; Readtable:COMMON-LISP; Base:10 -*-Н#|НН (C) COPYRIGHT 1986 LISP Machine, IncorporatedН All Rights ReservedНН___________________________________________________________________________Н|#НН;;; Samuel F. PilatoНННН;;;;LIST PATTERNSН;;;Н;;; LIST PATTERNS "isa" pattern definition, as described in theН;;; PATTERN-PROCESSING module. It therefore not only PROVIDEs aН;;; LIST-PATTERNS module but also counts as -- and therefore PROVIDEs -- aН;;; PATTERN-DEFINITION module.НН(provide 'list-patterns)ЙЙЙ;LIST-PATTERNS "isa"Н(provide 'pattern-definition)ЙЙЙ; PATTERN-DEFINITION.ННН;;;;QUASI-VARIABLES AND VARIABLESНН(defmacro quasi-variable (variable-name)Н "Given a variable-name string, return a corresponding quasi-variable."Н `(intern (concatenate 'string "?" ,variable-name)))НН(defun quasi-variable-p (x)Н "Is this a quasi-variable?"Н (and (symbolp x) (char= (char (symbol-name x) 0) #\?)))НН(defmacro quasi-variable-name (quasi-variable)Н "Given a quasi-variable, return its name as a string."Н `(subseq (symbol-name ,quasi-variable) 1))ННН(defmacro make-variable (variable-name &optional plist-contents)Н "Make a pattern variable, given a variable-name string and optionally theН contents of a property-list."Н `(list* #\? ,variable-name (copy-list ,plist-contents)))НН(defun variable-p (x)Н "Is this a pattern variable?"Н (and (consp x) (eql (first x) #\?)))НН(defmacro variable-name (variable)Н "Given a pattern variable, return its name as a string."Н `(second ,variable))НМН(defmacro variable-plist (variable)Н "Given a pattern variable, return its plist contents."Н `(nthcdr 2 ,variable))НН(defmacro get-from-variable (variable key &rest other-args-to-getf)Н "Return the value of pattern variable VARIABLE's KEY property. ThisН function is SETF-able."Н `(getf (variable-plist ,variable) ,key ,@other-args-to-getf))ННН(defun make-variable-for (quasi-variable)Н "Given a quasi-variable, make a corresponding pattern variable."Н (make-variable (quasi-variable-name quasi-variable)))НН(defun copy-variable (variable &optional copy-plist-p)Н "Make a copy of a pattern variable, the copy optionally inheriting a copyН of the variable's property-list."Н (make-variable (variable-name variable)НЙЙ (if copy-plist-p (variable-plist variable))))НН(defun quasi-variable-for (variable)Н "Given a pattern variable, return a corresponding quasi-variable."Н (quasi-variable (variable-name variable)))НННН;;;;CONSTANTSНН(defmacro constant-p (pattern) `(atom ,pattern))НННН;;;;COMPOSITESНН(defun atomic-p (pattern) (or (atom pattern) (eql (first pattern) #\?)))НН(defmacro composite-p (pattern) `(not (atomic-p ,pattern)))НН(defmacro make-composite (next-component rest-of-components)Н `(cons ,next-component ,rest-of-components))НН(defmacro next-component (composite-pattern) `(car ,composite-pattern))Н(defmacro rest-of-components (composite-pattern) `(cdr ,composite-pattern))НМН;;;;MATCHING PREDICATESНН(defmacro match-constant-p (constant pattern)Н "Does CONSTANT match PATTERN? This is a symmetrical test of equality."Н `(eql ,constant ,pattern))НН;;; Sacrifice some efficiency to allow other modules to convenientlyН;;; supersede this definition.НН;(defmacro match-variable-p (variable pattern)Н; (declare (ignore variable pattern))Н; `t)НН(defun match-variable-p (variable pattern)Н (declare (ignore variable pattern))Н t)НLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 43 :LENGTH-IN-BYTES 43532 :AUTHOR "wilde" :CREATION-DATE 2694625097 :QFASLP NIL :LENGTH 43532 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "ORG" :TYPE "LISP" :VERSION 11) ;-*- Mode:LISP; Package:(ORG :USE (USER GLOBAL SYSTEM)); Fonts:CPTFONT; Base:8 -*-Н Н;; Copyright LISP Machine, Inc. 1984Н;; See filename "Copyright.text" forН;; licensing and release information.Н Н;;; ORG: Organization Chart ProgramНН;;; REVISION HISTORYН;;;Н;;; E. Smith and L. Wilde Й2/85Й Revise to work with Release 2.0Н;;; S. StrassmanЙЙ7/84Й Added additional featuresН;;; J. HendlerЙЙЙ6/84Й Modify nodes to use "FLAVORS" object class systemН;;; L. HawkinsonЙЙUnknownЙ Original VersionНН;------------------------------------------------------------------------------Н; To use this code:Н;Н; Just load this file up and type SYSTEM-O. Н;Н;------------------------------------------------------------------------------Н; Set up our global variables.Н;Н; Note the convention of beginning each one with an asterisk.Н; Also, every one has a documentation string.Н;НН(defvar *chart-frame :unboundН "frame for org process")НН(defvar *chart-pane :unboundН "org chart pane in org chart frame")НН(defvar *command-pane :unboundН "command pane in org chart frame")НН(defvar *prompt-pane :unboundН "prompt pane in org chart frame")НН(defvar *default-attributesНЙ'(("Name" "anonymous")НЙ ("Title" *needs-filling-in)НЙ ("Location" *needs-filling-in))Н "The default list of attributes a node could have.")НН(defconst *needs-filling-in "*****"Н "value for descriptor not (yet) filled in")НН(defvar *closed-width 15.Н "The width of a closed node")НН(defvar *closed-height 8.Н "The height of a closed node")НН(defconst *alu tv:alu-ior "TV algorithm for drawing characters")НН(defconst *scroll-amount 100. "Number of pixels to scroll on the scroll command")НН(defvar *file (fs:merge-pathname-defaults "foo.chart")Н "The filename to store the current chart under.")НН(defvar *default-h-separation 10)Н(defvar *default-v-separation 10)НН;------------------------------------------------------------------------------Н; NodesНН; A node has the following instance variables, which keep track of the stateН; of that node:Н;Н; opened?: A closed node exists, but is invisible. An opened node is visible.Н; attributes: A list of sublists (i.e. an "alist"). Each sublist is a list ofН; two strings: a slot (eg: "Name"), and its value (eg: "Melvin").Н; A special value is the variable *NEEDS-FILLING-IN.Н; justification One of three keywords: :CENTER, :LEFT, or :RIGHT.Н; extra-width: How much whitespace to put inside the box around the textН; (horizontally)Н; vertical-separation: How much whitespace to put beneath this node and its inferiors.Н; horizontal-separation: How much whitespace to put between each inferior.Н; above: The node above this oneН; below: A list of the nodes below this oneН; pane: The window this node draws itself onН; height: The height of this node's box in pixelsН; width: The width of this node's box in pixelsН; sub-tree-height: The height of the sub-tree including this node in pixelsН; sub-tree-width: The width of the sub-tree including this node in pixelsН; left: The left edge of this node in screen coordinatesН; top: The top edge of this node in screen coordinatesНН(defflavor nodeН ((opened? t)ЙЙЙЙ; are you visible?НЙ (attributes *default-attributes)Й; an alist of print valuesНЙ (justification ':center)ЙЙ; how to print the valuesНЙ (extra-width 10.)ЙЙЙ; extra margin in pixelsНЙ (vertical-separation *default-v-separation)НЙ (horizontal-separation *default-v-separation)НЙ (above nil)ЙЙЙЙ; the node aboveНЙ (below nil)ЙЙЙЙ; the nodes belowНЙ paneЙЙЙЙЙ; the window to draw-self onНЙ heightЙЙЙЙЙ; in pixelsНЙ widthЙЙЙЙЙ; in pixelsНЙ sub-tree-widthЙЙЙЙ; visible sub-treeНЙ sub-tree-heightЙЙЙ; visible sub-treeНЙ leftЙЙЙЙЙ; x coordinate of left edgeНЙ top)ЙЙЙЙЙ; y coordinate of top edgeНЙ()Н :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variables)НН(defmethod (node :after :init) (&rest ignore)Н (send self ':compute-dimensions))НН;------------------------------------------------------------------------------Н;Н; Node methods I: Н; How to draw nodes; including geometry computationsН;НН; This computes the height and width of a node, based on what strings goН; inside it. Note that this is independent of where on the screen the node is.Н;Н(defmethod (node :compute-dimensions) (&rest ignore)Н (cond ((not opened?)НЙ (setq width *closed-width)НЙ (setq height *closed-height)НЙ (setq sub-tree-width *closed-width)НЙ (setq sub-tree-height *closed-height))НЙ(t (setq widthНЙЙ (+ extra-widthНЙЙ (loop for attribute in attributesНЙЙЙ if (send self ':ought-to-print-attribute? attribute)НЙЙЙ maximize (send pane ':string-length (eval (second attribute))))))НЙ (setq heightНЙЙ (+ (send pane ':vsp)НЙЙ (loop for attribute in attributesНЙЙЙ if (send self ':ought-to-print-attribute? attribute)НЙЙЙ sum (+ (send pane ':vsp)НЙЙЙЙ (tv:font-char-height (send pane ':current-font)))))))))НННН; This is a recursive procedure. You call it on the topmost nodeН; which you're interested in, and all of its underlings will beН; called with the same :COMPUTE-TOTAL-DIMENSIONS message. Thus, thisН; returns the total width and total height (in pixels) of the sub-treeН; beginning with any node. Unopened cells, of course, take up no room.Н;Н; First, the node's own height and width is computed.Н; Then, all the space occupied below is computed (depth-first).Н; The value returned is a list of the entire width and the entire height.Н; Note that the width is the maximum of this node's width and Н; the width of its underlings (max width total-width)Н; The height is the sum of three things: this node's height, the verticalН; separation between layers, and the max of the underlings' heights.НН; This method makes sure everyone's HEIGHT and WIDTH are up to date.Н; The next method, :reposition-underlings, makes sure everyone'sН; TOP and LEFT are up to date.Н;Н(defmethod (node :compute-total-dimensions) (&rest ignore)Н (send self ':compute-dimensions)Н (cond ((not opened?) (list width height))НЙ((null below)НЙ (setq sub-tree-width width)НЙ (setq sub-tree-height height)НЙ (list width height))НЙ(tНЙ (loop for underling in belowНЙ for under-dim = (send underling ':compute-total-dimensions)НЙ sum (+ horizontal-separationНЙЙ (first under-dim)) into under-width НЙ maximize (second under-dim) into under-heightНЙ finally НЙ (returnНЙЙ (prognНЙЙ (setq sub-tree-width (max width (- under-width horizontal-separation)))НЙЙ (setq sub-tree-height (+ heightЙ; my heightНЙЙЙЙЙ vertical-separationЙ; height directly under meНЙЙЙЙЙ under-height))Й; my underlings' heightНЙЙ (list sub-tree-width sub-tree-height)))))))ННН; This is also a recursive procedure which makes sure everyone'sН; TOP and LEFT are ok. It does this by finding out where its underlingsН; are, and then positioning itself on top of them, in the center.Н; Note that this really has to call :COMPUTE-TOTAL-DIMENSIONS first,Н; but :COMPUTE-TOTAL-DIMENSIONS doesn't really need to call Н; :REPOSITION-UNDERLINGS in order to work. For extra credit: Why is this so?Н;Н(defmethod (node :reposition-underlings) ()Н (if (not opened?) nilН (let* ((under-widthЙЙЙЙ; the width of all my underlingsНЙ (- (loop for underling in belowНЙЙЙsumming (+ (send underling ':sub-tree-width)НЙЙЙЙ horizontal-separation))НЙЙ horizontal-separation))НЙ (under-left (- (+ left (* .5 width))Й; middle of this nodeНЙЙЙ (* .5 under-width))))Й; left edge of sub-treeНЙ(loop for underling in belowНЙ for dx first under-left then (+ dx under-sub-tree-widthНЙЙЙЙЙ horizontal-separation)НЙ for under-sub-tree-width = (send underling ':sub-tree-width)НЙ do (send underling ':set-top (+ top height vertical-separation))НЙ (send underling ':set-leftНЙЙ (- (+ dx (* .5 under-sub-tree-width))Й; center of sub-treeНЙЙ (* .5 (send underling ':width))))Й; offset of underling's widthНЙ (send underling ':reposition-underlings)))))НН; Drawing stuff.Н;Н; This is the procedure you call on the top node to get the whole treeН; drawn. It draws itself, and then each of its underlings (which, of courseН; head subtrees themselves) get drawn the same way. If you have the special Н; case that a node is "closed", you give it to the special :DRAW-CLOSED method.Н;НН(defmethod (node :draw-sub-tree) ()Н (if (not opened?) (send self ':draw-closed)Н (send self ':draw)Н (cond ((> (length below) 1)НЙ (send self ':draw-under-line)НЙ (loop for underling in belowНЙЙ do (send self ':draw-line-to underling)НЙЙ do (send underling ':draw-sub-tree)))НЙ ((= (length below) 1)НЙ (send pane ':draw-line (fix (+ left (* .5 width)))НЙЙ (fix (+ top height))НЙЙЙЙ (fix (+ left (* .5 width)))НЙЙЙЙ (fix (+ top height vertical-separation -1)))НЙ (send (car below) ':draw-sub-tree)))))НН(defmethod (node :draw-under-line) ()Н (let* ((left-node (first below))НЙ (right-node (car (last below)))НЙ (top-x (fix (+ left (* .5 width))))НЙ (top-y (fix (+ top height)))НЙ (left-x (fix (+ (send left-node ':left)НЙЙЙ (* .5 (send left-node ':width)))))НЙ (right-x (fix (+ (send right-node ':left)НЙЙЙ (* .5 (send right-node ':width)))))НЙ (bottom-y (fix (+ top-y (* .5 vertical-separation)))))Н (send pane ':draw-line top-x top-y top-x (1- bottom-y) *alu)Н (send pane ':draw-line left-x bottom-y right-x bottom-y *alu)))НН; This draws the line from superior to underling.Н; The FIXR operations convert any kind of number into an integer.Н; FIX does this by truncation, FIXR rounds off the argument. Н; This is because graphics commands can't handle floating pointН; for screen coordinates.Н;Н(defmethod (node :draw-line-to) (underling)Н (let* ((top-x (fix (+ (send underling ':left)НЙЙЙ(* .5 (send underling ':width)))))НЙ (top-y (fix (+ top height (* .5 vertical-separation))))НЙ (bottom-y (fix (- (send underling ':top) 1))))Н (send pane ':draw-line top-x top-y top-x bottom-y *alu)))ННН; This is called by :DRAW-SUB-TREE. It draws just the box and contents forН; itself, but it doesn't draw connecting lines or any of its underlings.Н; If an attribute shouldn't be printed, it doesn't get printed.Н; Notice the abstractions here. Such decisions as "How should the edgesН; be drawn?" "Should this attribute be printed?" "How should it look?"Н; are not decided here. Why did I write these as separate functions?Н;Н(defmethod (node :draw) (&aux (char-height (tv:font-char-height (send pane ':current-font))))Н (send self ':draw-edges)Н (loop for attribute in attributesНЙfor print? = (send self ':ought-to-print-attribute? attribute)НЙfor y first (+ top (send pane ':vsp))НЙ then (if print? (+ y char-height (send pane ':vsp))НЙЙ y)НЙdo (if print?НЙ (send self ':print-attribute attribute y))))НН; The box around the nodeН;Н(defmethod (node :draw-edges) ()Н (send pane ':draw-lines *aluНЙ(fix left)(fix top)НЙ(fix (+ left width)) (fix top)НЙ(fix (+ left width)) (fix (+ top height))НЙ(fix left)(fix (+ top height))НЙ(fix left)(fix top)))НН; This method defines how closed boxes draw themselves. You drawН; only its edges (which were set to be really small in :COMPUTE-DIMENSIONS Н; because this node is closed, and then color it gray.НН(defmethod (node :draw-closed) ()Н (send self ':draw-edges)Н (send pane ':bitblt *alu (fix (1- width)) (fix (1- height))НЙtv:33%-gray 0 0 (fix (1+ left)) (fix (1+ top))))ННН; Notice the way this implementation allows you to use "*****"Н; to represent the notion of needing filling-in, yet you are notН; prohibited from including your Martian employees ("*****" isН; a common Martian family name, you know) on this chart.Н; A professional programmer never has "magic" values that mightН; cause an innnocent user some grief some day.Н;Н(defmethod (node :ought-to-print-attribute?) (attribute)Н (and (cdr attribute)Н (not (eq (second attribute) '*needs-filling-in))))ННН; Notice the idiom (* .5 foo). This is used to figure out halfН; of a region, so things get centered nicely.Н;Н(defmethod (node :print-attribute) (attribute y)Н (let* ((string (eval (second attribute)))НЙ (free-space (- width (send pane ':string-length string))))Н (selectq justificationН (:center (label pane (+ left (* .5 free-space)) y string))Н (:left (label pane (+ (* .5 extra-width) left) y string))Н (:right (label pane (+ left free-space (* -.5 extra-width)) y string)))))НЙЙ НН; The following is a short-hand notation for the corrected :STRING-OUT message.Н;Н(defun label (window left top string)Н (if (or (< top 0) (< left 0)) nilН (send window ':set-cursorpos (fix left) (correct window top))Н (send window ':string-out string)))НН(defun correct (window top)Н (fix (+ topНЙ (tv:font-baseline (send window ':current-font))НЙ (- (tv:font-baseline (aref (send window ':font-map)НЙЙЙЙЙ(send window ':largest-font)))))))Н Н; The string-out message is very useful, since it's a very explicitН; way of getting typout on a screen. Some other favorite ways of printingН; include (this is by no means an exhaustive list):Н;Н; (send ':draw-char )Н; (format

. )Н; (print )Н; (princ )Н; (prin1 )Н; (send ':tyo )Н Н;------------------------------------------------------------------------------Н;Н; Node methods II:Н; Maintaining the contentsН;Н; There's several ways you may want to edit the attributes, andН; rather than bother the user with one big menu, this is an exerciseН; in menu hacking. Н;Н; In creating a menu, you must specify everything the computer cannotН; figure out for itself. For example, things you must specify include:Н;Н; What the items to choose from are; what to do when you select one of them,Н; what to do when you DON'T select one of them, what the mouse documentationН; who-line should say when you're pointing at the item, etc.Н;Н; Every menu has an which, for each item, specifiesН; just what kind of actions and items you have. For more informationН; on the different kinds of menus, consult the Window System Manual.Н;Н(defmethod (node :edit) ()НЙ (send pane ':set-current-node self)НЙ (tv:menu-choose '(("Modify Contents" :eval (send (send *chart-paneНЙЙЙЙЙЙЙЙ':current-node)НЙЙЙЙЙЙЙ ':fill-in-self)НЙЙЙ :documentation "Modify the contents of this node")НЙЙЙ ("Select Attributes" :eval (send (send *chart-paneНЙЙЙЙЙЙЙЙ ':current-node)НЙЙЙЙЙЙЙ ':select-attributes)НЙЙЙ :documentation "Remove one or more attributes of this node")НЙЙЙ ("Change Geometry" :eval (send (send *chart-paneНЙЙЙЙЙЙЙЙ':current-node)НЙЙЙЙЙЙЙ ':change-geometry)НЙЙЙ :documentation "Change the display features of this node")))НЙ (send pane ':refresh))НН; Choose-variable-values only modifies the values of variables.Н; I wanted to modify the elements of a list, so I needed to GENSYM some newН; variables. GENSYM creates a symbol that is guaranteed brand-new,Н; and I generate as many as I need to hold all the attributes. Н; Then I call up a CHOOSE-VARIABLE-VALUES on these variables, andН; put everything back when I'm finished.Н;Н(defmethod (node :fill-in-self) ()Н (let ((vars (loop for attribute in attributesНЙЙ for var = (gensym 'attribute)НЙЙ do (setf (plist var)НЙЙЙ (append (plist var)НЙЙЙЙ '(si:documentation-property (("variable"))НЙЙЙЙ special t)))НЙЙ (set var (second attribute))НЙЙ collect var))НЙ(base 10.)НЙ(ibase 10.))Н (tv:choose-variable-valuesН (loop for var in varsНЙ for attribute in attributesНЙ collecting (list varНЙЙЙ (first attribute)НЙЙЙ ':string))Н ':label "Fill in as appropriate:"Н ':near-mode '(:mouse)Н ':margin-choices '("Mouse here when done"))Н (setq attributesНЙ (loop for var in varsНЙ for attribute in attributesНЙ collecting (list (first attribute) (eval var))))))ННН; Multiple-choose menus provide columns and rows of boxes.Н; Each box can be on or off, and turning it on or off may cause other boxesН; to turn on or off. Consult the Window System Manual for more info.Н;Н; The items are labeled with strings like "Name: Mary" if a value is found,Н; and a string like "Name" if not found. Notice the use of back-quoted listsН; and commas in order to control creation of the item list.Н;Н(defmethod (node :select-attributes) ()Н (let ((selectionsНЙ (tv:multiple-chooseНЙ "This node's attributes"НЙ (loop for default-attribute in *default-attributesНЙЙ for found = (assoc (first default-attribute) attributes)НЙЙ collectingНЙЙ (if foundНЙЙ (copytree (list found (string-append (first found) ": " (second found))НЙЙЙ '((:keep t t nil nil) (:remove nil t nil nil))))НЙЙ ; if not foundНЙЙ (copytree (list default-attribute (first default-attribute)НЙЙЙ '((:keep nil t nil nil) (:remove t t nil nil))))))НЙ (copytree '((:keep " Keep " nil t t nil)НЙ (:remove " Remove " nil t t nil))))))Н (if selectionsНЙ(setq attributes (loop for item in selectionsНЙЙЙ if (eq (second item) ':keep)НЙЙЙ collect (first item))))))НН; This allow a user to modify the appearance of a box, or the separationН; of a box's underlings. This is in a different menu from the other two, Н; because the nature of the information is rather different.Н;Н(defmethod (node :change-geometry) ()Н (let* ((base 10.)НЙ (ibase 10.)НЙ (properties '(justification extra-widthНЙЙ vertical-separation horizontal-separation))НЙ (vars (loop for property in propertiesНЙЙ for var = (gensym 'prop)НЙЙ do (setf (plist property)НЙЙЙ (append (plist property)НЙЙЙЙ '(si:documentation-property (("variable"))НЙЙЙЙ special t)))НЙЙ (setf (plist var)НЙЙЙ (append (plist var)НЙЙЙЙ '(si:documentation-property (("variable"))НЙЙЙЙ special t)))НЙЙ (set var (send self ':eval-inside-yourself property))НЙЙ collect var)))Н (tv:choose-variable-valuesН (loop for var in varsНЙ for doc in '(("Justification" :choose (:center :left :right))НЙЙЙ ("Extra box width (10 is good)" :number)НЙЙЙ ("Vertical distance to underlings" :number)НЙЙЙ ("Separation between underlings" :number))НЙ collecting (cons var doc))Н ':label "All numbers are in pixels:"Н ':near-mode '(:mouse)Н ':margin-choices '("Mouse here when done"))Н (loop for property in propertiesНЙ for var in varsНЙ do (send self ':eval-inside-yourself `(setq ,property ,var)))))НН;------------------------------------------------------------------------------Н;Н; Node methods III:Н; Adding and deleting nodesННН; Yes Virginia, FIND-POSITION-IN-LIST, FIRSTN, and NTHCDR are lisp primitives!Н; Aren't you glad some nut wrote them for us?Н;Н(defmethod (node :left-siblings-of) (node)Н (if (not (memq node below)) nilН (firstn (find-position-in-list node below) below)))НН(defmethod (node :right-siblings-of) (node)Н (if (not (memq node below)) nilН (cdr (nthcdr (find-position-in-list node below) below))))НН; Create a new underlingН;Н(defmethod (node :add-below) ()Н (let ((new (make-instance 'node ':pane paneНЙЙЙ ':horizontal-separation *default-h-separationНЙЙЙ ':vertical-separation *default-v-separation)))Н (setq below (append below (list new)))Н (send new ':set-above self)Н (send new ':fill-in-self)Н (send pane ':refresh)Н (send pane ':set-current-node new)))НН; Create a new superior. Don't forget to inform the superior's superiorН; about this, and if you've made a brand-new top-node for the chart, Н; inform the chart-pane too, while you're at it.Н;Н(defmethod (node :add-above) ()Н (let ((new (make-instance 'node ':pane paneНЙЙЙ ':horizontal-separation *default-h-separationНЙЙЙ ':vertical-separation *default-v-separation)))Н (send new ':set-above above)Н (send new ':set-below (list self))Н (setq above new)Н (cond ((eq self (send pane ':top-node))Й; If a new top is createdНЙ (send pane ':set-top-node new)НЙ (send new ':fill-in-self)НЙ (send pane ':go-to-top))НЙ ((send new ':above)ЙЙЙ; Else we must inform it of a new inferiorНЙ (send (send new ':above) ':set-belowНЙЙ (append (send (send new ':above) ':left-siblings-of self)НЙЙЙ (list new)НЙЙЙ (send (send new ':above) ':right-siblings-of self)))НЙ (send new ':fill-in-self)НЙ (send pane ':refresh)НЙ (send pane ':set-current-node new)))))НН; A new siblingН;Н(defmethod (node :add-right) ()Н (if (null above)Н (beep-on-terminal)Н (let ((new (make-instance 'node ':pane paneНЙЙЙ ':horizontal-separation *default-h-separationНЙЙЙ ':vertical-separation *default-v-separation)))НЙ(send new ':set-above above)НЙ(send above ':set-belowНЙ (append (send above ':left-siblings-of self)НЙЙ (list self new)НЙЙ (send above ':right-siblings-of self)))НЙ(send new ':fill-in-self)НЙ(send pane ':refresh)НЙ(send pane ':set-current-node new))))ННН; A new siblingН;Н(defmethod (node :add-left) ()Н (if (null above)Н (beep-on-terminal)Н (let ((new (make-instance 'node ':pane paneНЙЙЙ ':horizontal-separation *default-h-separationНЙЙЙ ':vertical-separation *default-v-separation)))НЙ(send new ':set-above above)НЙ(send above ':set-belowНЙ (append (send above ':left-siblings-of self)НЙЙ (list new self)НЙЙ (send above ':right-siblings-of self)))НЙ(send new ':fill-in-self)НЙ(send pane ':refresh)НЙ(send pane ':set-current-node new))))НН(defmethod (node :remove-self) ()Н (cond ((null below)НЙ (if (null above) (beep-on-terminal)НЙ (send above ':set-below (remq self (send above ':below)))НЙ (send pane ':set-current-node above)НЙ (send pane ':refresh)))НЙ((null above)НЙ (if (< 1 (length below)) (beep-on-terminal)НЙ (send (car below) ':set-above nil)НЙ (send pane ':set-top-node (car below))НЙ (send pane ':go-to-top)))НЙ(t (send above ':set-belowНЙЙ (append (send above ':left-siblings-of self)НЙЙЙ belowНЙЙЙ (send above ':right-siblings-of self)))НЙ (loop for orphan in belowНЙЙ do (send orphan ':set-above above))НЙ (send pane ':set-current-node above)НЙ (send pane ':refresh))))НН; This keeps a node, and eliminates all subtreesН;Н(defmethod (node :remove-below) ()Н (if (null below) (beep-on-terminal)Н (setq below nil) Н (send pane ':refresh)))НН;------------------------------------------------------------------------------Н; Н; User queriesНН; This prompts the user on the prompt pane for a yes or no answer.Н; It cleans up the prompt pane when finished by sending a :REFRESH message.Н;Н(defun let-user-confirm (query-string)Н (let ((answer (fquery () query-string)))Н (send *prompt-pane ':refresh)Н answer))НН; This beeps on (and maybe flashes) the user's terminal. Н;Н(defun beep-on-terminal ()Н (send terminal-io ':beep))НН;------------------------------------------------------------------------------Н; The pane with the organization chart Н;НН(defflavor chart-paneНЙ((top-node nil)НЙ (current-node)НЙ (font 3)НЙ (largest-font 4)НЙ (smallest-font 0))НЙ(tv:list-mouse-buttons-mixin tv:truncating-window)Н (:documentationН "ORG Chart pane")Н (:default-init-plistН :font-map '(fonts:5x5 fonts:tr8 fonts:tr10 fonts:tr12 fonts:mets)Н :save-bits tН :blinker-flavor 'tv:box-blinkerН :label nil)ЙЙЙЙЙ; no window labelН :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variables)НН(defmethod (chart-pane :after :init) (&rest ignore)Н (setq top-node (make-instance 'node ':pane selfНЙЙЙ ':horizontal-separation *default-h-separationНЙЙЙ ':vertical-separation *default-v-separation))Н (setq current-node top-node)Н (send current-node ':set-top (* .1 (send self ':height)))Н (send current-node ':set-leftНЙ(- (* .5 (send self ':width)) НЙ (* .5 (send current-node ':width)))))ННН(defmethod (chart-pane :after :refresh) (&rest ignore)Н (send self ':set-current-font font)Н (send top-node ':compute-total-dimensions)Н (send top-node ':reposition-underlings)Н (send top-node ':draw-sub-tree)ЙЙ; This actually draws the whole graphН (send self ':update-blinker))НН(defmethod (chart-pane :after :set-current-node) (ignore)Н (send self ':scroll-if-necessary)Н (send self ':update-blinker))НН(defmethod (chart-pane :update-blinker) ()Н (let ((blinker (car (send self ':blinker-list))))Н (send blinker ':set-sizeНЙ (+ 5 (send current-node ':width))НЙ (+ 5 (send current-node ':height)))Н (send blinker ':set-cursorposНЙ (- (send current-node ':left) 2)НЙ (- (send current-node ':top) 2))Н (send blinker ':set-visibility t)))НН;------------------------------------------------------------------------------Н;Н; The command pane's functionsН;НН; File storage stuffН;Н(defmethod (chart-pane :save-as-file) ()Н (with-open-fileН (file (send self ':get-file-name-from-user "Save this graph into which file?") ':write)Н (format file ";-*- Mode:LISP; Package:(ORG :USE (USER GLOBAL SYSTEM)); Base:10. -*- ~3%")Н (format file "; This file was generated by the ORG program. It contains the ~%")Н (format file "; information necessary to reconstruct a chart from scratch. ~%")Н (format file "; ~%")Н (format file "; Modify this file only if you really know what you're doing.~%")Н (format file "; It's much better to run ORG, then load this file, modify it,~%")Н (format file "; and save out the preferred version.~2%")Н (format file "; This is the top node:")Н (dump-world t file (send top-node ':dump-subtree))Н (format file "~3%; That's all, folks!"))Н (format t "Done.~%"))НН(defun dump-world (top-node? stream string-tree)Н (if (null string-tree) nilН (let ((node-string (first string-tree))НЙ (symbol (second string-tree))НЙ (kids (third string-tree)))НЙ(format stream "~2%(defconst ~A ~A)" symbol node-string)НЙ(if (not top-node?) nilНЙ (format stream "~2%(send *chart-pane ':set-top-node ~A)" symbol)НЙ (format stream "~%(send ~A ':set-pane *chart-pane)" symbol))НЙ(loop for kid in kidsНЙ do (dump-world nil stream kid)НЙ do (format stream "~%(send ~A ':greet-new-inferior ~A)"НЙЙ symbol (second kid))))))НН(defmethod (node :greet-new-inferior) (node)Н (setq below (append below (list node)))Н (send node ':set-above self))ННН(defmethod (node :dump-subtree) ()Н (let ((nodename (gensym 'node)))Н (list (send self ':dump-string)НЙnodenameНЙ(loop for kid in belowНЙ collect (send kid ':dump-subtree)))))ННН(defmethod (node :dump-string) ()Н (let ((base 10.))Н (string-appendН (format nil "~% (make-instance 'node ~%")Н (format nil " ':pane *chart-pane ~%")Н (format nil " ':opened? ~S ~%" opened?)Н (format nil " ':attributes~%")Н (format nil " '~S ~%" attributes)Н (format nil " ':justification ':~S ~%" justification)Н (format nil " ':extra-width ~S ~%" extra-width)Н (format nil " ':vertical-separation ~S ~%" vertical-separation)Н (format nil " ':horizontal-separation ~S)" horizontal-separation))))ННН(defmethod (chart-pane :get-file-name-from-user) (prompt-string)Н (let ((fn (prompt-and-read `(:pathname :defaults ,*file)НЙЙЙ "~%~A (default: ~A) " prompt-string *file)))Н (setq *file (fs:merge-pathname-defaults fn))))НН(defmethod (chart-pane :restore-from-file) ()Н (cond ((fquery ()НЙ "Are you sure you want to wipe out everything and load a brand-new chart? ")НЙ (load (send self ':get-file-name-from-user "File to load"))Й НЙ (send self ':go-to-top)НЙ (format t "Done.~%"))))НН;------------------------------------------------------------------------------Н;Н; Font nonsenseН;Н(defmethod (chart-pane :make-bigger) ()Н (if (equal font largest-font)Н (beep-on-terminal)Н (setq font (1+ font))Н (send self ':set-current-font font))Н (send self ':refresh))Н Н(defmethod (chart-pane :make-smaller) ()Н (if (equal font smallest-font)Н (beep-on-terminal)Н (setq font (1- font))Н (send self ':set-current-font font))Н (send self ':refresh))НН(defmethod (chart-pane :change-parameters) ()Н (let ((base 10.)НЙ(ibase 10.))Н (tv:choose-variable-valuesН `((*closed-width "Width of a closed box (15 is good)" :number)НЙ(*closed-height "Height of a closed box (8 is good)" :number)НЙ(*default-v-separation "Default space under a node (10 is good)" :number)НЙ(*default-h-separation "Default space between nodes (10 is good)" :number)НЙ(*scroll-amount "How big a jump to make when scrolling (100 is good)" :number)НЙ(*file "The pathname of the current file" :pathname)))))НН(defmethod (chart-pane :go-to-top) ()Н (setq current-node top-node)Н (send current-node ':set-top (* .1 (send self ':height)))Н (send current-node ':set-leftНЙ(- (* .5 (send self ':width)) НЙ (* .5 (send current-node ':width))))Н (send self ':refresh))НН(defmethod (chart-pane :go-up) ()Н (let ((boss (send current-node ':above)))Н (if (null boss)НЙ(beep-on-terminal)НЙ(send self ':set-current-node boss))))НН(defmethod (chart-pane :go-down) ()Н (let ((underlings (send current-node ':below)))Н (if (or (not (send current-node ':opened?)) (null underlings))НЙ(beep-on-terminal)НЙ(send self ':set-current-node (car underlings)))))НН(defmethod (chart-pane :go-left) ()Н (let ((boss (send current-node ':above)))Н (if (null boss)НЙ(beep-on-terminal)НЙ(let ((left-kid (car (last (send boss ':left-siblings-of current-node)))))НЙ (cond ((null left-kid)НЙЙ(send self ':go-up))НЙ (tЙЙ НЙЙ(send self ':set-current-node left-kid)))))))ННН(defmethod (chart-pane :go-right) ()Н (let ((boss (send current-node ':above)))Н (if (null boss)НЙ(send self ':go-down)НЙ(let ((right-kid (car (send boss ':right-siblings-of current-node))))НЙ (cond ((and (null right-kid) (null (send current-node ':below)))НЙЙ (beep-on-terminal))НЙЙ((null right-kid)НЙЙ (send self ':go-down))НЙЙ(tЙЙ НЙЙ (send self ':set-current-node right-kid)))))))НН(defmethod (chart-pane :far-right) ()Н (let ((boss (send current-node ':above)))Н (if (null boss)НЙ(beep-on-terminal)НЙ(let ((right-kid (car (last (send boss ':right-siblings-of current-node)))))НЙ (cond ((null right-kid)НЙЙ (beep-on-terminal))НЙЙ(tЙЙ НЙЙ (send self ':set-current-node right-kid)))))))НН(defmethod (chart-pane :far-left) ()Н (let ((boss (send current-node ':above)))Н (if (null boss)НЙ(beep-on-terminal)НЙ(let ((left-kid (car (send boss ':left-siblings-of current-node))))НЙ (cond ((null left-kid)НЙЙ (beep-on-terminal))НЙЙ(tЙЙ НЙЙ (send self ':set-current-node left-kid)))))))НЙЙН; The following three methods are needed in case you :GO-DOWN or :GO-RIGHT, Н; etc. to a node which lies off the screen.Н;Н(defmethod (chart-pane :scroll-if-necessary) ()Н (if (or (send self ':fix-horizontal?)НЙ (send self ':fix-vertical?))Н (send self ':refresh)Н (send self ':update-blinker)))НН; If the node is on screen, this returns nil and nothing happens.Н; If the node lies off-screen, the top-node is moved to compensate, Н; and T is returned. Thus, :SCROLL-IF-NECESSARY will only refresh once,Н; even if we need to scroll both horizontally and vertically.Н;Н; For a discussion on the existance of the 2's and the 7's in the code, see theН; documentation for the scrolling methods (e.g. :SCROLL-UP, :SCROLL-LEFT, etc.)Н;Н(defmethod (chart-pane :fix-horizontal?) ()Н (let ((new-left (send current-node ':left))НЙ(origin-left (send top-node ':left))НЙ(right-boundary (- (send self ':width) НЙЙЙ 7 (send current-node ':width))))Н (cond ((and (>= new-left 2) (<= new-left right-boundary))НЙ nil)ЙЙЙЙЙ; OK, return nilНЙ ((< new-left 2)НЙ (send top-node ':set-left (+ origin-left (- 2 new-left)))НЙ t)ЙЙЙЙЙ; Was bad, return tНЙ (tНЙ (send top-node ':set-left (- origin-left (- new-left right-boundary)))НЙ t))))ЙЙЙЙ; Was bad, return tНН(defmethod (chart-pane :fix-vertical?) ()Н (let ((new-top (send current-node ':top))НЙ(origin-top (send top-node ':top))НЙ(bottom-boundary (- (send self ':height) НЙЙЙ 7 (send current-node ':height))))Н (cond ((and (>= new-top 2) (<= new-top bottom-boundary))НЙ nil)ЙЙЙЙЙ; OK, return nilНЙ ((< new-top 2)НЙ (send top-node ':set-top (+ origin-top (- 2 new-top)))НЙ t)ЙЙЙЙЙ; Was bad, return tНЙ (tНЙ (send top-node ':set-top (- origin-top (- new-top bottom-boundary)))НЙ t))))ЙЙЙЙ; Was bad, return tНН(defmethod (chart-pane :add-below) ()Н (send current-node ':add-below))НН(defmethod (chart-pane :add-right) ()Н (send current-node ':add-right))НН(defmethod (chart-pane :add-left) ()Н (send current-node ':add-left))НН(defmethod (chart-pane :add-above) ()Н (send current-node ':add-above)) НН(defmethod (chart-pane :open) ()Н (send current-node ':set-opened? t)Н (send self ':refresh))НН(defmethod (chart-pane :open-below) ()Н (loop for kid in (send current-node ':below)НЙdo (send kid ':set-opened? t))Н (send self ':refresh))НН(defmethod (chart-pane :close) ()Н (send current-node ':set-opened? nil)Н (send self ':refresh))НН(defmethod (chart-pane :close-below) ()Н (loop for kid in (send current-node ':below)НЙdo (send kid ':set-opened? nil))Н (send self ':refresh)) Н Н(defmethod (chart-pane :edit) ()Н (send current-node ':edit))НН(defmethod (chart-pane :make-this-top) ()Н (cond ((let-user-confirm "Are you sure you want to wipe out everything above this node? ")НЙ (setq top-node current-node)НЙ (send self ':go-to-top))НЙ(t nil)))НН(defmethod (chart-pane :remove-current) ()Н (cond ((eq current-node top-node)НЙ (beep-on-terminal))НЙ((let-user-confirm "Are you sure you want to wipe out this node? ")НЙ (send current-node ':remove-self))НЙ(t nil)))Н Н(defmethod (chart-pane :remove-below) ()Н (cond ((let-user-confirm "Are you sure you want to wipe out everybody under this node? ")НЙ (send current-node ':remove-below))НЙ(t nil)))НН; First, compute DY (the amount to move up), and HERE (where you are now).Н; By taking the MIN of the default *SCROLL-AMOUNT and our current-node'sН; position, you ensure you never move in a step large enough to takeН; your current node off the screen.Н;Н; "Why do you subtract 2?" you may ask... This ensures that you neverН; bring the current-node to a y-coordinate of less than +2, not zero.Н; Leaving it at +2 gives it a few aesthetic pixels of upper border.Н; Remember, your craftsmanship and attention to aesthetic detailН; really shows in applications programs like this.Н;Н(defmethod (chart-pane :scroll-up) ()Н (let ((dy (min *scroll-amount (- (send current-node ':top) 2)))НЙ(here (send top-node ':top)))Н (send top-node ':set-top (- here dy))Н (if (not (zerop dy)) (send self ':refresh))))НЙН; The 7 here is like the 2 above. It includes compensation for the border drawnН; around the current-node, plus the screen's blinker, which is a blinker ofН; TV:BOX-BLINKER flavor and thickness 2.Н;Н(defmethod (chart-pane :scroll-down) ()Н (let ((dy (min *scroll-amountНЙЙ (- (send self ':height) 7НЙЙ (send current-node ':top) (send current-node ':height))))НЙ(here (send top-node ':top)))Н (send top-node ':set-top (+ here dy))Н (if (not (zerop dy)) (send self ':refresh))))НН(defmethod (chart-pane :scroll-left) ()Н (let ((dx (min *scroll-amount (- (send current-node ':left) 2)))НЙ(here (send top-node ':left)))Н (send top-node ':set-left (- here dx))Н (if (not (zerop dx)) (send self ':refresh))))НН(defmethod (chart-pane :scroll-right) ()Н (let ((dx (min *scroll-amountНЙЙ (- (send self ':width) 7НЙЙ (send current-node ':left) (send current-node ':width))))НЙ(here (send top-node ':left)))Н (send top-node ':set-left (+ here dx)) Н (if (not (zerop dx)) (send self ':refresh))))ННН;------------------------------------------------------------------------------Н; The command paneН;НН(defflavor org-command-pane ()НЙ (tv:command-menu)Н :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variablesН (:documentationН "ORG Command Pane")Н (:default-init-plistН :font-map '(fonts:hl12bi)Н :columns 4Н :item-list *command-list))НН(defvar *column-1-commandsН '(("Save as File (c-S)" :save-as-fileНЙЙ"Save current organization chart in a file")НЙ ("Read from File (c-R)" :restore-from-fileНЙЙ"Restore organization chart previously saved in a file")НЙ ()НЙ ()НЙ ("Far Left (c-A)" :far-leftНЙЙ"Go to the furthest left on this level")НЙ ("Far Right (c-E)" :far-rightНЙЙ"Go to the furthest right on this level")НЙ ("Parameters (m-X)" :change-parametersНЙЙ"Change the parameters for the whole chart")НЙ ("Edit This Node (c-X)" :editНЙЙ"Edit this individual")))НН(defvar *column-2-commandsН '(("Add Below (h-N)" :add-belowНЙЙ"Add a new inferior")НЙ ("Add Left (h-B)" :add-leftНЙЙ"Add a new sibling to the left")НЙ ("Add Right (h-F)" :add-rightНЙЙ"Add a new sibling to the right")НЙ ("Add Above (h-P)" :add-aboveНЙЙ"Insert a new node above this one")НЙ ("Go Up (c-P)" :go-upН ЙЙ"Move the current node upwards")НЙ ("Go Down (c-N)" :go-downНЙЙ"Move the current node downwards")НЙ ("Go Left (c-B)" :go-leftНЙЙ"Move the current node to the left")НЙ ("Go Right (c-F)" :go-rightНЙЙ"Move the current node upwards")))НН(defvar *column-3-commandsН '(("Delete (c-D)" :remove-currentНЙЙ"Delete exactly this node. (Keep its underlings, if any)")НЙ ("Delete Below (m-D)" :remove-belowНЙЙ"Delete everything under this node")НЙ ("Go to the Top (m-<)" :go-to-topНЙЙ"Go to the top of the chart")НЙ ()НЙ ("Scroll Up (m-P)" :scroll-upНЙЙ"Move the display upwards")НЙ ("Scroll Down (m-N)" :scroll-downНЙЙ"Move the display downwards")НЙ ("Scroll Left (m-B)" :scroll-leftНЙЙ"Move the display to the left")НЙ ("Scroll Right (m-F)" :scroll-rightНЙЙ"Move the display to the right")))НН(defvar *column-4-commandsН '(("Open (c-O)" :openНЙЙ"Open up the current node")НЙ ("Open Below (m-O)" :open-belowНЙЙ"Open up the underlings")НЙ ("Close (c-C)" :closeНЙЙ"Close the current node")НЙ ("Close Below (m-C)" :close-belowНЙЙ"Close the underlings")НЙ ()НЙ ()НЙ ("Make Bigger (c->)" :make-biggerНЙЙ"Expand this chart")НЙ ("Make Smaller (c-<)" :make-smallerНЙЙ"Shrink this chart")))НН(defun select-command-items (command-column)Н (if (null command-column)Н '("" :no-select nil)Н `(,(first command-column)НЙ :eval (send *chart-pane ',(second command-column))НЙ :documentation ,(third command-column))))НН(defvar *command-listН (loop for command-column-1 in *column-1-commandsН for command-column-2 in *column-2-commandsН for command-column-3 in *column-3-commandsН for command-column-4 in *column-4-commandsНЙ collecting (select-command-items command-column-1)НЙ collecting (select-command-items command-column-2)НЙ collecting (select-command-items command-column-3)НЙ collecting (select-command-items command-column-4)))НН;;; Note that, in item-list values, ("" :no-select nil) can be used for dummyН;;; (blank) menu items.ННН;------------------------------------------------------------------------------Н;Н; The pane at the bottom of the screenН;Н(defflavor prompt-paneНЙ()НЙ(tv:pane-mixin tv:window))НН(defmethod (prompt-pane :after :refresh)(&rest ignore)Н (send self ':home-cursor))НН;------------------------------------------------------------------------------Н; Org Chart Frame: The master window with many panesН;НН(defflavor chart-frameН ()Н (tv:process-mixinЙ Н tv:bordered-constraint-frame-with-shared-io-buffer)Н :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variablesН (:documentationН "Organization Chart Program Frame")Н (:default-init-plistН :expose-p tЙЙЙЙЙЙ; expose w/o blink on instantiationН :activate-p tЙЙЙЙЙ; activate on instantiationН :save-bits ':delayedЙЙЙЙЙ; make save bits array on deexposureН :process '(org-initial-function)Н :panesЙЙЙ Н `((command-pane org-command-pane)Н (chart-pane chart-pane)Н (prompt-pane prompt-pane))Н :constraintsН '((standard-configurationН (command-pane chart-pane prompt-pane)ЙЙ; top, middle, bottomН ((command-pane :ask :pane-size))ЙЙЙ; As big as necessaryН ((prompt-pane 8 :lines))ЙЙЙЙ; 8 lines tallН ((chart-pane :even))))))ЙЙЙЙ; Whatever's left overНН; Look at the :PROCESS init-keyword above (in the defflavor).Н; This function gets run as the "initial form" of that process.Н; It gets an infinite loop running which maintains the window.Н;Н(defun org-initial-function (window)Н (send window ':loop))НН; This is org's top level loop.Н; It does all the work of getting input from the user, and doingН; something intelligent with it.Н;Н(defmethod (chart-frame :loop) ()Н (let* ((io (send self ':get-pane 'prompt-pane))НЙ (chart (send self ':get-pane 'chart-pane))НЙ (terminal-io io) НЙ (query-io io)НЙ (error-output io))Н (loop for input = (send io ':any-tyi)НЙ do (cond ((atom input)НЙЙ (selectq inputНЙЙ ((#\c-LНЙЙЙ#+LMI #\clear-screen)НЙЙ (send chart ':refresh)НЙЙ (send io ':refresh))НЙЙ (#\c-F (send chart ':go-right))НЙЙ (#\c-B (send chart ':go-left))НЙЙ (#\c-P (send chart ':go-up))НЙЙ (#\c-N (send chart ':go-down))НЙЙ (#\c-A (send chart ':far-left))НЙЙ (#\c-E (send chart ':far-right))НЙЙ (#\m-F (send chart ':scroll-right))НЙЙ (#\m-B (send chart ':scroll-left))НЙЙ (#\m-P (send chart ':scroll-up))НЙЙ (#\m-N (send chart ':scroll-down))НЙЙ (#\h-F (send chart ':add-right))НЙЙ (#\h-B (send chart ':add-left))НЙЙ (#\h-P (send chart ':add-above))НЙЙ (#\h-N (send chart ':add-below))НЙЙ (#\c-D (send chart ':remove-current))НЙЙ (#\m-D (send chart ':remove-below))НЙЙ (#\c-O (send chart ':open))НЙЙ (#\m-O (send chart ':open-below))НЙЙ (#\c-C (send chart ':close))НЙЙ (#\m-C (send chart ':close-below))НЙЙ (#\c-S (send chart ':save-as-file))НЙЙ (#\c-R (send chart ':restore-from-file))НЙЙ (#\c-> (send chart ':make-bigger))НЙЙ (#\c-< (send chart ':make-smaller))НЙЙ (#\m-< (send chart ':go-to-top))НЙЙ (#\c-X (send chart ':edit))НЙЙ (#\end (send self ':bury))НЙЙ (#\m-X (send chart ':change-parameters))))НЙЙ ((listp input)НЙЙ (selectq (car input)НЙЙ (:menuНЙЙ (send (fourth input) ':execute (second input)))НЙЙ (t (beep))))))))НН;------------------------------------------------------------------------------Н; Н; This is how you get ORG up and running in the first placeН; Notice that this function always returns the same window,Н; namely, *CHART-PANE. When you type System-O, it executesН; the function ORG, and selects whatever window is returnedН; be ORG.НН(defun org ()Н (if (and (boundp '*chart-frame)НЙ (not (eq ':unbound *chart-frame))НЙ *chart-pane)Н *chart-paneН ;elseЙ Н (setq *chart-frame (tv:make-window 'chart-frame))Н (setq *chart-pane (send *chart-frame ':get-pane 'chart-pane))Н (setq *command-pane (send *chart-frame ':get-pane 'command-pane))Н (setq *prompt-pane (send *chart-frame ':get-pane 'prompt-pane))Н *chart-pane))НН; This means you never have to type (org). Just type SYSTEM-O andН; it will find the chart-frame and display it for you.Н;Н(tv:add-system-key #\O '(org) "Organization Chart")НН; This will get printed whenever you load this fileНН(format t "~%Org loaded. Type SYSTEM-O to begin.~2%")LMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 2 :LENGTH-IN-BYTES 1859 :AUTHOR "SAM" :CREATION-DATE 2716754650 :QFASLP NIL :LENGTH 1859 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "OTHER" :TYPE "LISP" :VERSION 1) ;;; -*- Mode:LISP; Readtable:COMMON-LISP; Base:10 -*-Н#|НН (C) COPYRIGHT 1986 LISP Machine, IncorporatedН All Rights ReservedНН___________________________________________________________________________Н|#НН;;; Samuel F. PilatoННН;;;;OTHERНН(require 'pattern-processing)Н(require 'unification)Н(provide 'other)ННН(defun show-unifier-of (quasi-pattern1 quasi-pattern2НЙЙЙ&optional (substitution (make-substitution)))Н (multiple-value-bind (p1 var-pairs1) (patternize quasi-pattern1)Н (multiple-value-bind (p2 var-pairs2) (patternize quasi-pattern2)Н (let ((patterns (list p1 p2))НЙ (variable-lists (list (mapcar #'cdr var-pairs1)НЙЙЙЙ (mapcar #'cdr var-pairs2)))НЙ (s (unify? p1 p2 substitution)))НЙ(if (null s)НЙ (format t "~%none~2%")НЙ (prognНЙ (dotimes (i 2)НЙ (dolist (var (nth i variable-lists))НЙЙ(annotate-variable var (+ i 1))))НЙ (dotimes (i 2)НЙ (terpri)(terpri)НЙ (princ (express-pattern (nth i patterns)))НЙ (dolist (var (nth i variable-lists))НЙЙ(show-annotated-bindings var s))НЙ (terpri)НЙ (princ (express-annotated-patternНЙЙ (instantiate-pattern (nth i patterns) s)))НЙ (terpri))))НЙ(values)))))НМН(defun annotate-variable (variable pattern-identifier)Н (setf (get-from-variable variable 'in-pattern) pattern-identifier))НН(defun express-annotated-variable (variable)Н (format nil "~A[~D]"НЙ (variable-name variable)НЙ (get-from-variable variable 'in-pattern)))НН(defun show-annotated-bindings (variable substitution)Н (do ((p nil)) (nil)Н (format t (if (null p) "~%~5T" "~5,10T = "))Н (format t "~A" (express-annotated-pattern variable))Н (setf p (or (get-binding-pair variable substitution) (return))НЙ variable (binding-value p))))НН(defun express-annotated-pattern (pattern)Н (pattern-copy pattern #'express-annotated-variable))НLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 7 :LENGTH-IN-BYTES 6587 :AUTHOR "wilde" :CREATION-DATE 2716346243 :QFASLP NIL :LENGTH 6587 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "PAINT" :TYPE "LISP" :VERSION 2) НННННННН;;; PAINTН;;; by LMI Education DivisionННН;; Copyright (C) 1985 LISP Machine, Incorporated.НН;;; To paint on a window with the mouse, first load this file and evaluateН;;; (paint) .НН;;; Notice that the predicate screen-displays-1-bits-as-black-p is not veryН;;; portable because it is standing in for apparently absent systemН;;; (supportable) software that abstracts away from the details ofН;;; particular machines.НН(defun screen-displays-1-bits-as-black-pН (&OPTIONAL (SCREEN tv:DEFAULT-SCREEN))Н "There being apparently no Zetalisp-defined function to check whether theН display hardware currently displays a screen's 1-bits as black or asН white, this function pretends to be it. The uppercase code,Н ** (c) Copyright 1980, 1981 Massachusetts Institute of Technology **,Н is taken from the definitions in the TV package of BLACK-ON-WHITE,Н WHITE-ON-BLACK, and COMPLEMENT-BOW-MODE, which each have such code, foundН in the file LAM3:QL.WINDOW;SHWARM.LISP#339 ."Н (SELECT tv:PROCESSOR-TYPE-CODEН (SI:CADR-TYPE-CODEН (logtest 1_2 (%XBUS-READ (tv:SCREEN-CONTROL-ADDRESS SCREEN))))Н (SI:LAMBDA-TYPE-CODEН (logtest 1_4 (%NUBUS-READ TV:TV-QUAD-SLOT 4)))))ННННННМНННННН(defvar *window-video-was-reversed?* :unboundНЙ "the window's video setting as this program first found it")Н(defconst *default-to-reverse-video?* nilНЙ "whether to begin with the window's video reversed")НН(defconst *brush-shapes* '(square circle line-\ line-//)НЙ "list of brush shapes that are defined")Н(defconst *default-brush-shape* 'circle "brush shape to begin with")Н(defvar *brush-shape*ЙЙ:unbound "current brush shape")НН(defconst *default-brush-size* 16 "brush size to begin with")Н(defvar *brush-size*Й :unbound "current brush size")НН(defconst *ink-modes* '(draw erase blacken whiten blink-ink)НЙ "list of ink modes that are defined; Draw and erase generateНЙ figure and ground, respectively, as appropriate to theНЙ window's video setting. Blacken and whiten do so absolutely.НЙ Blink-ink complements what it is painted onto, and appears toНЙ blink when successive brush strokes overlap.")Н(defconst *default-ink-mode* 'draw "ink mode to begin with")Н(defvar *ink-mode*Й :unbound "current ink mode")НН(defconst *paint-menu-item-list*Н '(("Square"Й:valueЙЙsquareН ЙЙ:documentationЙ"Use a square paintbrush.")Н ("Circle"Й:valueЙЙcircleНЙ Й:documentationЙ"Use a circular paintbrush.")Н ("Line-\"Й:valueЙЙline-\Н ЙЙ:documentationЙ"Use a \ paintbrush.")Н ("Line-//"Й:valueЙЙline-//Н ЙЙ:documentationЙ"Use a // paintbrush.")Н ("BIGGER"Й:valueЙЙbiggerНЙ Й:documentationЙ"Increase size of brush.")Н ("SMALLER"Й:valueЙЙsmallerНЙ Й:documentationЙ"Decrease size of brush.")Н ("DRAW"Й:valueЙЙdrawН ЙЙ:documentationЙ"Draw as you stroke.")Н ("ERASE"Й:valueЙЙeraseН ЙЙ:documentationЙ"Erase as you stroke.")Н ("CLEAR"Й:valueЙЙclearН ЙЙ:documentationЙ"Clear the window.")Н ("COMPLEMENT IMAGE" :valueЙcomplementНЙ Й:documentationЙ"Reverse figure and ground.")Н ("BLACKEN"Й:valueЙЙblackenН ЙЙ:documentationЙ"Blacken as you stroke.")Н ("WHITEN"Й:valueЙЙwhitenН ЙЙ:documentationЙ"Whiten as you stroke.")Н ("BLINK-INK" :valueЙЙblink-inkНЙ Й:documentationЙ"Blink-ink as you stroke.")Н ("EXIT"Й:valueЙЙexitН ЙЙ:documentationЙ"Exit.")))Н(defconst *sticky-items* '(bigger smaller complement)Н "menu items that once chosen become the new default choice")НМНННННН(defun paint ()Н (initialize-window)Н (initialize-paintbrush)Н (do ((default-choice nil)Н (item-value nil)Н (item-itself))Н ((eq item-value 'exit) (restore-window) t)Н (make-dynamic-changes)Н (multiple-value (item-value item-itself)Н (tv:menu-chooseНЙ*paint-menu-item-list* "palette" '(:mouse) default-choice))Н (if (memq item-value *sticky-items*) (setq default-choice item-itself))Н (make-static-change item-value)))НН(defun initialize-window ()Н (setq *window-video-was-reversed?*НЙ(send tv:selected-window ':reverse-video-p))Н (send tv:selected-window ':set-reverse-video-pНЙ*default-to-reverse-video?*)Н (send tv:selected-window ':clear-screen))НН(defun restore-window ()Н (send tv:selected-window ':clear-screen)Н (send tv:selected-window ':set-reverse-video-pНЙ*window-video-was-reversed?*))НН(defun complement-video-of-window ()Н (send tv:selected-window ':set-reverse-video-pНЙ(not (send tv:selected-window ':reverse-video-p))))НН(defun initialize-paintbrush ()Н (setq *brush-shape*Й*default-brush-shape*НЙ*brush-size*Й*default-brush-size*НЙ*ink-mode*Й*default-ink-mode*))НН(defun make-static-change (item-value)Н (cond ((memq item-value *brush-shapes*)НЙ (setq *brush-shape* item-value))НЙ((memq item-value *ink-modes*)НЙ (setq *ink-mode* item-value))НЙ(tНЙ (selectq item-valueНЙ (biggerЙ(setq *brush-size* (* 2 *brush-size*)))НЙ (smallerЙ(if (> *brush-size* 1)НЙЙЙ (setq *brush-size* (// *brush-size* 2))))НЙ (complementЙ(complement-video-of-window))НЙ (clearЙ(send tv:selected-window ':clear-screen))))))НМНННННН(defun make-dynamic-changes ()Н (tv:with-mouse-grabbedН (setq tv:who-line-mouse-grabbed-documentationНЙ "L: Stroke the brush. M: Get menu.")Н (do* ((size-X-2 (* *brush-size* 2))НЙ (dummy (tv:mouse-wait) (tv:mouse-wait x y buttons))НЙ (x tv:mouse-x tv:mouse-x)НЙ (y tv:mouse-y tv:mouse-y)НЙ (buttons tv:mouse-last-buttons tv:mouse-last-buttons)НЙ (alu (get-alu) (get-alu)))НЙ (nil)Н (selectq buttonsНЙ(1 (selectq *brush-shape*НЙ (square (send tv:selected-window ':draw-rectangleНЙЙЙ size-X-2 size-X-2НЙЙЙ (- x *brush-size*) (- y *brush-size*) alu))НЙ (circle (send tv:selected-window ':draw-filled-in-circleНЙЙЙ x y *brush-size* alu))НЙ (line-\ (send tv:selected-window ':draw-lineНЙЙЙ (- x *brush-size*) (- y *brush-size*)НЙЙЙ (+ x *brush-size*) (+ y *brush-size*) alu))НЙ (line-// (send tv:selected-window ':draw-lineНЙЙЙ (- x *brush-size*) (+ y *brush-size*)НЙЙЙ (+ x *brush-size*) (- y *brush-size*) alu))))НЙ(2 (return))НЙ(4 nil)))))НН(defun get-alu ()Н "Given the screen's current hardware display setting, the window'sН current video setting, and the current ink mode, get appropriate aluН function."Н (selectq *ink-mode*Н (drawЙ(send tv:selected-window ':tv:char-aluf))Н (eraseЙ(send tv:selected-window ':tv:erase-aluf))Н (blackenЙ(if (screen-displays-1-bits-as-black-p)НЙЙ tv:alu-iorНЙЙ tv:alu-andca))Н (whitenЙ(if (screen-displays-1-bits-as-black-p)НЙЙ tv:alu-andcaНЙЙ tv:alu-ior))Н (blink-inkЙtv:alu-xor)))НLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 10 :LENGTH-IN-BYTES 9332 :AUTHOR "SAM" :CREATION-DATE 2716749161 :QFASLP NIL :LENGTH 9332 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "PATTERN-PROCESSING" :TYPE "LISP" :VERSION 1) ;;; -*- Mode:LISP; Readtable:COMMON-LISP; Base:10 -*-Н#|НН (C) COPYRIGHT 1986 LISP Machine, IncorporatedН All Rights ReservedНН___________________________________________________________________________Н|#НН;;; Samuel F. PilatoНННН;;;;PATTERN PROCESSINGНН(require 'pattern-definition)Н(require 'variable-substitution)Н(provide 'pattern-processing)ННН;;; Consider a PATTERN to be anything isomorphic in structure (or at leastН;;; operationally isomorphic in the way it is composed and decomposed) to aН;;; linked (and possibly nested, possibly dotted) list, except that eachН;;; ultimate (atomic) component is either a constant or a pattern variable.Н;;; That is, the operational structure of a pattern is that of a binaryН;;; external tree with variables. Н;;;Н;;; We want to treat all occurrences of the same variable within aН;;; specified (sub)pattern as identical to each other, yet distinct fromН;;; all other occurrences of variables within or outside of that pattern.Н;;; The specified pattern is the SCOPE of the variable. The most flexibleН;;; Lisp comparison predicate for this purpose is EQ, so let us require allН;;; occurrences of a pattern variable to be EQ within its scope, and not EQН;;; to any other variables -- or other patterns -- within or outside itsН;;; scope. Н;;;Н;;; To provide for facile printed representations of patterns, let aН;;; QUASI-PATTERN be a would-be pattern that contains some QUASI-VARIABLESН;;; in place of true pattern variables. All occurrences of aН;;; quasi-variable must be EQUAL within a quasi-pattern, and not EQUAL toН;;; any other quasi-variables or pattern variables within thatН;;; quasi-pattern. Then that quasi-pattern may be associated with (andН;;; converted to and from) a true pattern where each quasi-variable isН;;; converted to a pattern variable whose scope is the entire pattern.Н;;;Н;;; Two patterns match if they are EQ, or one is atomic and a matchingН;;; predicate says it matches the other, or their corresponding componentsН;;; match. The matching predicate for constants must be some symmetricalН;;; test of equality. Particular applications may introduce differentН;;; criteria.НМН;;; A module PROVIDEs a PATTERN-DEFINITION as REQUIREd above iff itН;;; provides the following functions which define patterns andН;;; quasi-patterns:Н;;;Н;;; QUASI-VARIABLE (variable-name) "Given a variable-name string,Н;;; return a correspondingН;;; quasi-variable."Н;;;Н;;; QUASI-VARIABLE-P (x) "Is this a quasi-variable?"Н;;;Н;;; QUASI-VARIABLE-NAME (quasi- "Given a quasi-variable, return itsН;;; variable) name as a string."Н;;;Н;;;Н;;; MAKE-VARIABLE (variable-name "Make a pattern variable, given aН;;; &optional variable-name string andН;;; plist-contents) optionally the contents of aН;;; property-list."Н;;;Н;;; VARIABLE-P (x) "Is this a pattern variable?"Н;;;Н;;; VARIABLE-NAME (variable) "Given a pattern variable, returnН;;; its name as a string."Н;;;Н;;; GET-FROM-VARIABLE (variable key "Return the value of patternН;;; &rest other- variable VARIABLE's KEY property.Н;;; args-to-getf) This function is SETF-able."Н;;;Н;;;Н;;; MAKE-VARIABLE-FOR (quasi- "Given a quasi-variable, make aН;;; variable) corresponding pattern variable."Н;;;Н;;; COPY-VARIABLE (variable "Make a copy of a pattern variable,Н;;; &optional the copy optionally inheriting aН;;; copy-plist-p) copy of the variable'sН;;; property-list."Н;;;Н;;; QUASI-VARIABLE-FOR (variable) "Given a pattern variable, return aН;;; corresponding quasi-variable."Н;;;Н;;;Н;;; CONSTANT-P (pattern)Н;;;Н;;; ATOMIC-P (pattern)Н;;; COMPOSITE-P (pattern)Н;;; MAKE-COMPOSITE (next-component rest-of-components)Н;;; NEXT-COMPONENT (composite-pattern)Н;;; REST-OF-COMPONENTS (composite-pattern)Н;;;Н;;; MATCH-CONSTANT-P (constant pattern) "Does CONSTANT match PATTERN?Н;;; This is a symmetrical test ofН;;; equality."Н;;; MATCH-VARIABLE-P (variable pattern)НМН;;; Functions or options of functions dealing with variable names andН;;; property lists may be omitted, but they are desirable and may beН;;; required for some applications.Н;;;Н;;; See the LIST-PATTERNS module for an example of a module which providesН;;; a PATTERN-DEFINITION.НМН(defun patternize (quasi-pattern &aux (alist nil) v)Н "Given a would-be pattern that contains quasi-variables, return aН corresponding true pattern where all quasi-variables have beenН uniquified. That is, for each quasi-variable, all occurrences of whichН must be EQUAL to each other, its corresponding pattern variable is EQ toН all -- and only -- other occurrences in the resulting pattern.Н As a second value, we return an alist of quasi-variables and theirН corresponding pattern variables."Н (labels ((variable-for (quasi-variable)НЙ (or (cdr (assoc quasi-variable alist :test #'equal))НЙЙ (prog1 (setq v (make-variable-for quasi-variable))НЙЙЙ(push (cons quasi-variable v) alist))))НЙ (copy (pat)НЙ (cond ((quasi-variable-p pat) (variable-for pat))НЙЙ ((atomic-p pat) pat)НЙЙ ((make-composite (copy (next-component pat))НЙЙЙЙ (copy (rest-of-components pat)))))))Н (values (copy quasi-pattern) (nreverse alist))))НН(defun pattern-copy (pattern substitution-function)Н "Given a pattern, return a copy where each occurrence of a variable isН replaced by the return value of a substitution-function applied to thatН occurrence."Н (labelsН ((copy (pat)НЙ (cond ((constant-p pat) pat)НЙ ((variable-p pat) (funcall substitution-function pat))НЙ ((make-composite (copy (next-component pat))НЙЙЙЙ(copy (rest-of-components pat)))))))Н (copy pattern)))НН(defun pattern-copy-variables-uniquely (pattern substitution-functionНЙЙЙЙЙ&aux (alist nil) x)Н "Given a pattern, return a copy where each variable is replaced in allН its occurrences by a single object -- the return value of aН substitution-function applied to that variable.Н As a second value, we return an alist of replaced variables and theirН replacements."Н (labels ((replacement-for (variable)НЙ (if (setq x (assoc variable alist :test #'eq))НЙ (cdr x)НЙ (prog1 (setq x (funcall substitution-function variable))НЙЙ (if (not (eq x variable))НЙЙЙ(push (cons variable x) alist))))))Н (values (pattern-copy pattern #'replacement-for) (nreverse alist))))НН(defun copy-pattern (pattern)Н "Given a pattern, return a copy with corresponding but independentН variables. As a second value, we return an alist of old variables andН their corresponding new variables."Н (pattern-copy-variables-uniquely pattern #'copy-variable))НМН(defun instantiate-pattern (pattern substitution &optional hold-the-vars-pНЙЙЙ &aux (alist nil) x)Н "Given a PATTERN, return a copy wherein any variable that is bound inН SUBSTITUTION has been recursively replaced by its value pattern, suchН that all remaining variables are unbound. Optionally, don't replace anyН variable whose ultimate value is also a variable.Н As a second value, we return an alist of replaced variables and theirН replacements."Н (labelsН ((replacement-for (variable)НЙ (if (setq x (assoc variable alist :test #'eq))НЙ (cdr x)НЙ (prog1 (setq x (instantiation-of variable))НЙЙ (if (not (eq x variable))НЙЙ (push (cons variable x) alist)))))Н (instantiation-of (variable)НЙ (setq x (get-ultimate-value variable substitution))НЙ (if (if (not hold-the-vars-p) (eq x variable) (variable-p x))НЙ variableНЙ (pattern-copy x #'replacement-for))))Н (values (pattern-copy pattern #'replacement-for) (nreverse alist))))НН(defun pattern-equal (pattern1 pattern2 &aux (alist (ncons nil)) pair)Н "Do PATTERN1 and PATTERN2 match up to a one-for-one replacement ofН variables? Truth is represented by a non-NIL alist of correspondingН variables."Н (labels ((prior-pair? (var1 var2)НЙ (dolist (pair alist nil)НЙ (when pairНЙЙ (if (or (eq var1 (car pair)) (eq var2 (cdr pair)))НЙЙ (return pair)))))НЙ (match-var-p (var pat)НЙ (when (variable-p pat)НЙ (if (setq pair (prior-pair? var pat))НЙЙ (and (eq var (car pair)) (eq pat (cdr pair)))НЙЙ (push (cons var pat) alist))))НЙ (pat= (pat1 pat2)НЙ (cond ((constant-p pat1) (match-constant-p pat1 pat2))НЙЙ ((constant-p pat2) nil)НЙЙ ((variable-p pat1) (match-var-p pat1 pat2))НЙЙ ((variable-p pat2) nil)НЙЙ ((and (pat= (next-component pat1)НЙЙЙ (next-component pat2))НЙЙЙ (pat= (rest-of-components pat1)НЙЙЙ (rest-of-components pat2)))))))Н (if (pat= pattern1 pattern2) alist)))НН(defun express-pattern (pattern)Н "Given a pattern, return a copy where each occurrence of a patternН variable is replaced by a corresponding quasi-variable."Н (pattern-copy pattern #'quasi-variable-for))НLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 2 :LENGTH-IN-BYTES 1746 :AUTHOR "SAM" :CREATION-DATE 2721878642 :QFASLP NIL :LENGTH 1746 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "PREDICATE-CALCULUS" :TYPE "LISP" :VERSION 1) ;;; -*- Mode:LISP; Readtable:COMMON-LISP; Base:10 -*-Н#|НН (C) COPYRIGHT 1986 LISP Machine, IncorporatedН All Rights ReservedНН___________________________________________________________________________Н|#НН;;; Samuel F. PilatoНННН;;;;PREDICATE CALCULUSНН(require 'defining)Н(require 'pattern-definition)Н(require 'pattern-processing)Н(provide 'predicate-calculus)НМН;;; TermsНН(defmacro make-quasi-function-term (quasi-function-symbol quasi-terms)Н `(make-composite ,quasi-function-symbol ,quasi-terms))НН(defmacro function-term-function-symbol (function-term)Н `(next-component ,function-term))НН(defmacro function-term-terms (function-term)Н `(rest-of-components ,function-term))НННН;;; Atomic FormulasНН(defmacro make-quasi-atom (quasi-predicate-symbol quasi-terms)Н `(make-composite ,quasi-predicate-symbol ,quasi-terms))НН(defmacro atom-predicate-symbol (atomic-formula)Н `(next-component ,atomic-formula))НН(defmacro atom-terms (atomic-formula)Н `(rest-of-components ,atomic-formula))НННН;;; Horn ClausesН;;;Н;;; Consider only Prolog Horn clauses, which have exactly one conclusion.НН(defmacro make-quasi-Horn-clause (quasi-head quasi-body)Н `(make-composite ,quasi-head ,quasi-body))НН(defmacro Horn-clause-head (Horn-clause)Н `(next-component ,Horn-clause))НН(defmacro Horn-clause-body (Horn-clause)Н `(rest-of-components ,Horn-clause))НННН;;; VariantsНН(alias variants? pattern-equalН "Do FORMULA1 and FORMULA2 subsume each other as patterns? That is, forН each does there exist a substitution which when applied to it -- withoutН recursion -- yields the other? If so, they match up to a one-for-oneН replacement of variables, and we return a non-NIL alist of correspondingН variables.")НLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 5 :LENGTH-IN-BYTES 4346 :AUTHOR "wilde" :CREATION-DATE 2716346292 :QFASLP NIL :LENGTH 4346 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "PROCESS-BRINGUP-WINDOW" :TYPE "LISP" :VERSION 4) ;;; -*- Mode:LISP; Package:USER; Fonts:(BIGFNT); Base:10 -*-НН; Title: ProcessesН; Subtitle: Process to bring up a windowН; File name: process-bringup-window.lisp and .qfaslНН;; Copyright (C) 1985 LISP Machine, Incorporated.НН; To demo, execute (process-make-a-window) ННН; Write a process to bring up a window.НН; First, define a simple window.Н; Notice that we have included tv:process-mixin as a componentН; flavor.ННН(defflavor simple-process-windowНЙ ()НЙ (tv:process-mixin tv:window)Н :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variablesН (:default-init-plistН :borders 2Н :label '(:top :centered :string "Simple Process Window")Н :more-p nil))НННН; Write a function to make a process with the window as aН; run reason.НН; After the process is made, we send it a :preset message.Н; :preset should be followed by a function name (the process'sН; initial function) and arguments to be passed to that function.Н; :preset sets the process's initial function and its arguments.Н; The process is then reset so that it will throw out of anyН; current computation and start itself up by applying the Н; function to the arguments. A :preset operation on a stopped Н; process will return immediately, but will not activate theН; process; hence the process will not really apply the function Н; to its arguments until it is activated later.НН; The function process-reset-and-enable resets the process,Н; then enables it.ННН(defun process-make-a-window (&aux this-process window)Н (setq this-processНЙ(make-process 'this-processНЙЙ ':run-reasonsНЙЙ (setq windowНЙЙЙ (make-instanceНЙЙЙ 'simple-process-window))))Н (send window ':activate)Н (send window ':expose)Н (send window ':select)Н (send this-process ':preset 'qix window)Н (process-reset-and-enable this-process))НННН; The initial function for this process is qix, which wasН; adapted from hacks:qix. It stops when something is typed on Н; the keyboard.Н; To get out of the window, just select another one.ННН(defun qix (streamНЙ &aux (length 100) (times nil))Н (let* ((list (make-list (1+ length)))НЙ (history (nthcdr (1- length) list)))Н (%p-store-cdr-code (cdr history) cdr-error)Н (%p-store-cdr-code history cdr-normal)Н (rplacd history list)Н (send stream ':clear-screen)Н (loop repeat lengthНЙ for h = history then (cdr h)НЙ do (setf (car h) (make-list 4)))Н (multiple-value-bind (xlim ylim)НЙ(send stream ':inside-size)Н (loop with x1 = 0НЙ and y1 = (1- ylim)НЙ and x2 = 0НЙ and y2 = (1- ylim)НЙ and dx1 = 5НЙ and dy1 = 12НЙ and dx2 = 12НЙ and dy2 = 5НЙ with temНЙ until (or (send stream ':tyi-no-hang)НЙЙ (if times (= (setq times (1- times)) 0)НЙЙЙnil))НЙ when (caar history)НЙ do (send stream ':draw-lineНЙЙ (first (car history))НЙЙ (second (car history))НЙЙ (third (car history))НЙЙ (fourth (car history))НЙЙ tv:alu-xor)НЙ do (setf (first (car history)) x1)НЙ (setf (second (car history)) y1)НЙ (setf (third (car history)) x2)НЙ (setf (fourth (car history)) y2)НЙ (setq history (cdr history))НЙ (send stream ':draw-line x1 y1 x2 y2 tv:alu-xor)НЙ (setq dx1 (1- (+ dx1 (random 3)))НЙЙ dy1 (1- (+ dy1 (random 3)))НЙЙ dx2 (1- (+ dx2 (random 3)))НЙЙ dy2 (1- (+ dy2 (random 3))))НЙ (cond ((> dx1 12) (setq dx1 12))НЙЙ ((< dx1 -12) (setq dx1 -12)))НЙ (cond ((> dy1 12) (setq dy1 12))НЙЙ ((< dy1 -12) (setq dy1 -12)))НЙ (cond ((> dx2 12) (setq dx2 12))НЙЙ ((< dx2 -12) (setq dx2 -12)))НЙ (cond ((> dy2 12) (setq dy2 12))НЙЙ ((< dy2 -12) (setq dy2 -12)))НЙ (cond ((or ( (setq tem (+ x1 dx1)) xlim)НЙЙ (minusp tem))НЙЙ (setq dx1 (- dx1))))НЙ (cond ((or ( (setq tem (+ x2 dx2)) xlim)НЙЙ (minusp tem))НЙЙ (setq dx2 (- dx2))))НЙ (cond ((or ( (setq tem (+ y1 dy1)) ylim)НЙЙ (minusp tem))НЙЙ (setq dy1 (- dy1))))НЙ (cond ((or ( (setq tem (+ y2 dy2)) ylim)НЙЙ (minusp tem))НЙЙ (setq dy2 (- dy2))))НЙ (setq x1 (+ x1 dx1)НЙЙ y1 (+ y1 dy1)НЙЙ x2 (+ x2 dx2)НЙЙ y2 (+ y2 dy2))НЙ finally (loop repeat lengthНЙЙЙ when (caar history)НЙЙЙ do (send stream ':draw-lineНЙЙЙЙ (first (car history))НЙЙЙЙ (second (car history))НЙЙЙЙ (third (car history))НЙЙЙЙ (fourth (car history))НЙЙЙЙ tv:alu-xor)НЙЙЙ do (setq history (cdr history)))))))НLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 11 :LENGTH-IN-BYTES 10438 :AUTHOR "SAM" :CREATION-DATE 2721882036 :QFASLP NIL :LENGTH 10438 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "PROLOG" :TYPE "LISP" :VERSION 1) ;;; -*- Mode:LISP; Readtable:COMMON-LISP; Base:10 -*-Н#|НН (C) COPYRIGHT 1986 LISP Machine, IncorporatedН All Rights ReservedНН___________________________________________________________________________Н|#НН;;; Samuel F. PilatoННН;;;;PROLOGНН(require 'unification)Н(require 'predicate-calculus)Н(require 'streams)Н(require 'pattern-processing)Н(provide 'Prolog)НМН;;;;Database ManagementННН(defmacro make-database () `(list* 'database nil))Н(defmacro database-contents (database) `(cdr ,database))НН(defvar *Prolog-database* (make-database)Н "current Prolog database of assertions")НН(defmacro with-database ((database) &body body)Н `(let ((*Prolog-database* ,database)) ,@body))НН(defmacro db () `(database-contents *Prolog-database*))ННН(defun clear-db () (setf (db) nil))НН(defmacro add-to-db (assertion) `(push ,assertion (db)))НН(defmacro add-in-order-to-db (assertions)Н `(dolist (assertion (reverse ,assertions)) (add-to-db assertion)))НН(defmacro delete-from-dbНЙ (assertion &key (test '#'variants?) (count nil count-provided-p))Н `(setf (db) (delete ,assertion (db) :test ,testНЙЙ ,@(if count-provided-p (list :count count)))))НН(defmacro delete-em-from-db (assertions &rest key-pairs)Н `(dolist (assertion ,assertions) (delete-from-db assertion ,@key-pairs)))НН(defmacro fetch-from-db (fetch-pattern)Н (declare (ignore fetch-pattern)) `(db))НН(defmacro probe-db (assertion-pattern &key (test '#'variants?))Н (let ((pattern (make-symbol "pattern")))Н `(let ((,pattern ,assertion-pattern))Н (remove ,pattern (fetch-from-db ,pattern) :test-not ,test))))ННН(defun assert-to-db (assertion)Н (delete-from-db assertion :count 1)Н (add-to-db assertion))НН(defun assert-in-order-to-db (assertions)Н (delete-em-from-db assertions :count 1)Н (add-in-order-to-db assertions))НН(defmacro retract-from-db (assertion)Н `(delete-from-db ,assertion :count 1))НН(defmacro retract-em-from-db (assertions)Н `(delete-em-from-db ,assertions :count 1))НН(defmacro candidate-assertions (goal) `(fetch-from-db ,goal))НМН;;;;User InterfaceННН(defmacro clear-database () `(progn (clear-db) (values)))НН(defmacro my-assert (quasi-assertion)Н `(progn (assert-to-db (patternize ',quasi-assertion)) (values)))НН(defmacro assert-em (&rest quasi-assertions)Н `(progn (assert-in-order-to-db (mapcar #'patternize ',quasi-assertions))НЙ (values)))НН(defmacro retract (quasi-assertion)Н `(progn (retract-from-db (patternize ',quasi-assertion)) (values)))НН(defmacro retract-em (&rest quasi-assertions)Н `(progn (retract-em-from-db (mapcar #'patternize ',quasi-assertions))НЙ (values)))НН(defmacro show-patterns (patterns)Н `(dolist (pattern ,patterns (values)) (print (express-pattern pattern))))НН(defmacro show-database ()Н `(show-patterns (fetch-from-db (make-variable ""))))НН(defmacro make-Horn-clause-probe (predicate-symbol)Н `(patternize (make-quasi-Horn-clauseНЙЙ (make-quasi-atom ,predicate-symbol (make-variable ""))НЙЙ (make-variable ""))))НН(defmacro probe (predicate-symbol)Н `(show-patterns (probe-db (make-Horn-clause-probe ',predicate-symbol)НЙЙЙ :test #'unify?)))НН(defmacro define-predicate (predicate-symbol &body quasi-Horn-clauses)Н `(def-predicate ',predicate-symbol ',quasi-Horn-clauses))НН(defun def-predicate (predicate-symbol quasi-Horn-clauses)Н (unless (and (symbolp predicate-symbol)НЙ (not (variable-p (patternize predicate-symbol))))Н (error "In a pattern, ~S is not a constant symbol." predicate-symbol))Н (dolist (q-H-c quasi-Horn-clauses)Н (unless (eq (atom-predicate-symbol (Horn-clause-head q-H-c))НЙЙpredicate-symbol)Н (errorНЙ"Invalid predicate symbol ~S in head of clause of predicate ~S ."НЙ(atom-predicate-symbol (Horn-clause-head q-H-c))НЙpredicate-symbol)))Н (delete-from-db (make-Horn-clause-probe predicate-symbol) :test #'unify?)Н (assert-in-order-to-db (mapcar #'patternize quasi-Horn-clauses))Н (values))НН(defmacro undefine-predicate (predicate-symbol)Н `(def-predicate ',predicate-symbol nil))НМН(defvar *trace-prolog* nil)НН(defmacro query (quasi-goal &optional (trace-p '*trace-prolog*))Н `(query-db ',quasi-goal ,trace-p))НН(defmacro express-instance (pattern substitution)Н `(express-pattern (instantiate-pattern ,pattern ,substitution t)))НН#|Н(defun query-db (quasi-goal &optional (*trace-prolog* *trace-prolog*)НЙЙ &aux (goal (patternize quasi-goal))НЙЙ (proofs (proofs-of goal)))Н (valuesН (mapcar #'(lambda (substitution) (express-instance goal substitution))НЙ proofs)Н proofs))Н|#ННН(defun query-db (quasi-goal &optional (*trace-prolog* *trace-prolog*))Н (multiple-value-bind (goal var-pairs) (patternize quasi-goal)Н (let ((vars (mapcar #'cdr var-pairs))НЙ (proofs (proofs-of goal))НЙ (quasi-replies nil))Н (if (null proofs)НЙ(format t "~%none~2%")НЙ(prognНЙ (terpri)(terpri)НЙ (dolist (proof proofs)НЙ (print (express-pattern goal))НЙ (dolist (var vars) (show-bindings var proof))НЙ (push (print (express-instance goal proof)) quasi-replies)НЙ (terpri)(terpri))НЙ (nreverse quasi-replies)))Н (values))))НН(defun show-bindings (variable substitution)Н (do ((p nil)) (nil)Н (format t (if (null p) "~%~5T" "~5,10T = "))Н (format t "~A" (express-pattern variable))Н (setf p (or (get-binding-pair variable substitution) (return))НЙ variable (binding-value p))))НН(defun proofs-of (goal)Н (catch 'proofs-ofН (prove goal (candidate-assertions goal) (make-substitution))))НМН;;;;TracingННН(defvar *proof-level* 0)Н(defvar *indent* 0)НН(defmacro with-trace ((goal assertion old-sub new-sub) &body body)Н (let ((proofs (make-symbol "proofs")))Н `(progn (prologue ,goal ,assertion ,old-sub ,new-sub)НЙ (let ((,proofs (let* ((*proof-level* (+ *proof-level* 1))НЙЙЙЙ (*indent* (* 3 *proof-level*)))НЙЙЙ ,@body)))НЙ (epilogue ,goal ,assertion ,new-sub ,proofs)НЙ ,proofs))))НН(defun prologue (goal assertion old-sub new-sub)Н (when (and new-sub *trace-prolog*)Н (format t "~%~v,0TCan prove: ~A with assertion ~A" *indent*НЙ (express-instance goal old-sub) (express-pattern assertion))Н (if (Horn-clause-body assertion)Н (format t "~%~v,0Tif can prove: ~A" *indent*НЙ (express-instance (Horn-clause-body assertion) new-sub)))))НН(defun epilogue (goal assertion new-sub proofs)Н (when new-subН (when *trace-prolog*Н (cond ((null (Horn-clause-body assertion))НЙЙЙ (format t "~%~v,0TQ.E.D." *indent*))НЙ ((null proofs) (format t "~%~v,0TDRATS!" *indent*))))Н (do ((ps proofs (rest-of-stream ps))) ((empty-stream-p ps))Н (if (or *trace-prolog* (zerop *proof-level*))НЙ(format t "~%~v,0T~A" *indent*НЙЙ(express-instance goal (next-in-stream ps))))Н (if (and (zerop *proof-level*) (not (y-or-n-p "More?")))НЙ(throw 'proofs-of proofs)))))НМН;;;;How to FailННН(defmacro fail () `nil)Н(defmacro failed-p (substitution?) `(null ,substitution?))НН(defun stream-of? (substitution?)Н (if (not (failed-p substitution?))Н (stream-of substitution?)Н (make-empty-stream)))НННН;;;;Stream-Oriented Theorem ProverННН(defun prove (goal assertions substitution)Н (cond ((null assertions) (stream-of? (fail)))НЙ((merge-streams (prove-it goal (first assertions) substitution)НЙЙЙ(prove goal (rest assertions) substitution)))))НН(defun prove-it (goal assertion substitution)Н (setq assertion (copy-pattern assertion))Н (let ((new-subНЙ (unifier? goal (Horn-clause-head assertion) substitution)))Н (with-trace (goal assertion substitution new-sub)Н (prove-anded-goals (Horn-clause-body assertion) new-sub))))НН(defun prove-anded-goals (goals substitution?)Н (cond ((null goals) (stream-of? substitution?))НЙ((failed-p substitution?) (stream-of? substitution?))НЙ((prove-anded-goals-in-ored-substitutionsНЙЙ(rest goals)НЙЙ(prove (first goals)НЙЙ (candidate-assertions (first goals))НЙЙ substitution?)))))НН(defun prove-anded-goals-in-ored-substitutions (goals substitutions)Н (cond ((or (null goals) (empty-stream-p substitutions)) substitutions)НЙ((merge-streamsНЙ (prove-anded-goals goals (next-in-stream substitutions))НЙ (prove-anded-goals-in-ored-substitutionsНЙ goals (rest-of-stream substitutions))))))НМН;;;;Initial Knowledge BaseННН(clear-database)НН(define-predicate trueН ((true)))НН(define-predicate falseН )НН(define-predicate failН )НН(define-predicate =Н ((= ?))Н ((= ?x ?x . ?more) (= ?x . ?more))Н ((=)))НН(define-predicate andН ((and))Н ((and ?first . ?rest) ?first (and . ?rest)))НН(define-predicate orН ((or ?first . ?) ?first)Н ((or ? . ?rest) (or . ?rest)))НН(define-predicate appendН ((append ()))Н ((append ?x ?x))Н ((append ?appended () ?y . ?rest)Н (append ?appended ?y . ?rest))Н ((append (?x1 . ?u) (?x1 . ?xrest) ?y . ?rest)Н (append ?u ?xrest ?y . ?rest)))НН(define-predicate reverseН ((reverse ?reversed-so-far () ?reversed-so-far))Н ((reverse ?reversed (?first . ?rest) ?reversed-so-far)Н (reverse ?reversed ?rest (?first . ?reversed-so-far)))Н ((reverse ?reversed ?x) (reverse ?reversed ?x ())))НН(define-predicate memberН ((member ?x (?x . ?)))Н ((member ?x (? . ?rest)) (member ?x ?rest)))НМН(define-predicate successorН ((successor 1 0))Н ((successor 2 1))Н ((successor 3 2))Н ((successor 4 3))Н ((successor 5 4)))НН(define-predicate <Н ((< ?x ?y) (successor ?y ?x))Н ((< ?x ?y) (successor ?y ?y-1) (< ?x ?y-1)))НН(define-predicate partitionН ((partition () () ? ()))Н ((partition (?first . ?smaller) ?bigger ?key (?first . ?rest))Н (< ?first ?key)Н (partition ?smaller ?bigger ?key ?rest))Н ((partition ?smaller (?first . ?bigger) ?key (?first . ?rest))Н (or (< ?key ?first) (= ?key ?first))Н (partition ?smaller ?bigger ?key ?rest)))НН(define-predicate quick-sortН ((quick-sort ?biggest-sorted () ?biggest-sorted))Н ((quick-sort ?sorted (?key . ?rest) ?biggest-sorted)Н (partition ?smaller ?bigger ?key ?rest)Н (quick-sort ?all>=key-sorted ?bigger ?biggest-sorted)Н (quick-sort ?sorted ?smaller (?key . ?all>=key-sorted)))Н ((quick-sort ?sorted ?unsorted) (quick-sort ?sorted ?unsorted ())))ННН(define-predicate parentН ((parent ?p ?c) (mother ?p ?c))Н ((parent ?p ?c) (father ?p ?c)))НН(define-predicate grandparentН ((grandparent ?grand ?child) (parent ?grand ?par) (parent ?par ?child)))НН(assert-emН ((grandparent gramps babe))Н ((mother alice george))Н ((father george peewee)))НН(define-predicate mortalН ((mortal ?being) (human ?being)))НН(assert-emН ((human socrates)))НLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 17 :LENGTH-IN-BYTES 16754 :AUTHOR "SAM" :CREATION-DATE 2722375354 :QFASLP NIL :LENGTH 16754 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "PROLOG" :TYPE "SESSION" :VERSION 1) ;Reading at top level.Н;Reading in base 10 in package USER with standard Zetalisp readtable.НН(login 'sam t)НTНН(load "emma:lisp2-ai;prolog-init")НLoading PEEL: LISP2-AI; PROLOG-INIT.LISP#> into package USERНLoading PEEL: LISP2-AI; CL-INIT.QFASL#> into package USERНМНННН (C) COPYRIGHT 1986 LISP Machine, IncorporatedН All Rights ReservedННН___________________________________________________________________________НSamuel F. PilatoННН Initializing a CommonLisp environment: providing for ...НН CommonLisp Readtable InitializationН Maintaining a Module RegistryН Enhancement of REQUIRE Function (REQUIRE being redefined)Н Ordered Compiling and Loading of ModulesНН CommonLisp initialization is complete.НН To set *readtable* to a copy of the standard CommonLisp readtable, typeН (CL-INIT) .Н This is undone upon logout.НН To register a module, typeН (REGISTER-MODULE module-name [pathname]) .НН To retrieve the names of modules currently registered, typeН (REGISTERED-MODULES) .НН To load a registered module -- or for that matter, often even to load aН simple UNregistered module -- just typeН (REQUIRE ) .НН Please inspect the source file for further documentation of these andН other new facilities.ННLoading PEEL: LISP2-AI; PROLOG.QFASL#> into package USERНLoading PEEL: LISP2-AI; UNIFICATION.QFASL#> into package USERНLoading PEEL: LISP2-AI; LIST-PATTERNS.QFASL#> into package USERНLoading PEEL: LISP2-AI; VARIABLE-SUBSTITUTION.QFASL#> into package USERНLoading PEEL: LISP2-AI; PREDICATE-CALCULUS.QFASL#> into package USERНLoading PEEL: LISP2-AI; DEFINING.QFASL#> into package USERНLoading PEEL: LISP2-AI; PATTERN-PROCESSING.QFASL#> into package USERНLoading PEEL: LISP2-AI; STREAMS.QFASL#> into package USERНLoading PEEL: LISP2-AI; HANOI_PROLOG.QFASL#> into package USERНLoading PEEL: LISP2-AI; OTHER.QFASL#> into package USERНН#FS::LM-PATHNAME "PEEL: LISP2-AI; PROLOG-INIT.LISP#1"НН(cl-init)Н;Reading in base 10 in package USER with #.НМН(show-unifier-of '(a b c)НЙЙ '(a b c))НН(A B C)Н(A B C)ННН(A B C)Н(A B C)НННН(show-unifier-of '(a ?x c ?y e)НЙЙ '(a b ?z d e))НН(A ?X C ?Y E)Н X[1] = BН Y[1] = DН(A B C D E)ННН(A B ?Z D E)Н Z[2] = CН(A B C D E)НННН(show-unifier-of '(near Mercedes theatre)НЙЙ '(nearby Mercedes theater))НnoneНННН(show-unifier-of '(a ?x ?x ?x)НЙЙ '(a ?y ?y ?y))НН(A ?X ?X ?X)Н X[1] = Y[2]Н(A Y[2] Y[2] Y[2])ННН(A ?Y ?Y ?Y)Н Y[2]Н(A Y[2] Y[2] Y[2])НМН(show-unifier-of '(a ?x ?x)НЙЙ '(a ?y b))НН(A ?X ?X)Н X[1] = Y[2]Й = BН(A B B)ННН(A ?Y B)Н Y[2] = BН(A B B)НННН(show-unifier-of '(a ?x ( c ?y))НЙЙ '(a (b ?z) (?w ?z)))НН(A ?X (C ?Y))Н X[1] = (B Z[2])Н Y[1] = Z[2]Н(A (B Z[2]) (C Z[2]))ННН(A (B ?Z) (?W ?Z))Н Z[2]Н W[2] = CН(A (B Z[2]) (C Z[2]))НННН(show-unifier-ofН '(implies (precipitate-on ?precipitate ?object) (wet ?object))Н '(implies (precipitate-on rain sidewalks) ?consequent))НН(IMPLIES (PRECIPITATE-ON ?PRECIPITATE ?OBJECT) (WET ?OBJECT))Н PRECIPITATE[1]Й = RAINН OBJECT[1] = SIDEWALKSН(IMPLIES (PRECIPITATE-ON RAIN SIDEWALKS) (WET SIDEWALKS))ННН(IMPLIES (PRECIPITATE-ON RAIN SIDEWALKS) ?CONSEQUENT)Н CONSEQUENT[2]Й = (WET OBJECT[1])Н(IMPLIES (PRECIPITATE-ON RAIN SIDEWALKS) (WET SIDEWALKS))НМН(show-unifier-of '(a ?x c)НЙЙ '(a b e))НnoneННН(show-unifier-of '(a ?x c ?x e)НЙЙ '(a b ?z d e))НnoneННН(show-unifier-of '(a ?x ?x)НЙЙ '(a (b ?y) ?y))НnoneННН(show-unifier-of '(a ?x ?y)НЙЙ '(a (b ?y) ?x))НН(A ?X ?Y)Н X[1] = (B Y[2])Н Y[1] = X[2]Н(A (B Y[2]) X[2])ННН(A (B ?Y) ?X)Н Y[2]Н X[2]Н(A (B Y[2]) X[2])НННН(let ((both (patternize '((a ?x ?y)НЙЙЙ (a (b ?y) ?x)) )))Н (show-unifier-of (first both) (second both)))НnoneНННН(let ((both (patternize '((?x ?y ?z)НЙЙЙ (?y ?z ?x)))))Н (show-unifier-of (first both) (second both)))НН(?X ?Y ?Z)Н(Z[NIL] Z[NIL] Z[NIL])ННН(?Y ?Z ?X)Н(Z[NIL] Z[NIL] Z[NIL])НМН(show-unifier-of '(?x (?y1 . ?yrest) ?z1 . ?zrest)НЙЙ '(a (b c d e f g ) h ))НН(?X (?Y1 . ?YREST) ?Z1 . ?ZREST)Н X[1] = AН Y1[1] = BН YREST[1] = (C D E F G)Н Z1[1] = HН ZREST[1] = NILН(A (B C D E F G) H)ННН(A (B C D E F G) H)Н(A (B C D E F G) H)НМН(show-unifier-of '(implies ?antecedent (mortal ?who))НЙЙ '(implies (human ?x) (mortal ?x )))НН(IMPLIES ?ANTECEDENT (MORTAL ?WHO))Н ANTECEDENT[1]Й = (HUMAN X[2])Н WHO[1] = X[2]Н(IMPLIES (HUMAN X[2]) (MORTAL X[2]))ННН(IMPLIES (HUMAN ?X) (MORTAL ?X))Н X[2]Н(IMPLIES (HUMAN X[2]) (MORTAL X[2]))НН(show-unifier-of '(human ?x)НЙЙ '(human Socrates))НН(HUMAN ?X)Н X[1] = SOCRATESН(HUMAN SOCRATES)ННН(HUMAN SOCRATES)Н(HUMAN SOCRATES)НННН(let* ((query (patternize '(mortal ?who)))Н (rule-in-kb (patternize '(implies (human ?x) (mortal ?x))))Н (fact-in-kb (patternize '(human Socrates)))НН (query-variable (second query))Н (antecedent (patternize '?antecedent))Н (consequent (patternize '?consequent))Н (backward-chain-patternНЙЙ (patternize `(implies ,antecedent ,consequent))))НН (setq substitution (unify? backward-chain-pattern rule-in-kb)НЙsubstitution (unify? query consequent substitution)НЙsubstitution (unify? antecedent fact-in-kb substitution))НН (terpri)Н (print (express-pattern query))Н (show-bindings query-variable substitution)Н (print (express-pattern (instantiate-pattern query substitution t)))Н (terpri)(values))НН(MORTAL ?WHO) Н ?WHO = ?XЙ = SOCRATESН(MORTAL SOCRATES) НМН(show-database)Н((HANOI ((MOVE FROM ?X TO ?Y) . ?REV-SO-FAR) ?REV-SO-FAR ?X ?Y ? 1))Н((HANOI ?REV-SOLUTION ?REV-SO-FAR ?X ?Y ?Z ?N)Н (SUCCESSOR ?N ?N-1)Н (HANOI ?S1 ?REV-SO-FAR ?X ?Z ?Y ?N-1)Н (HANOI ?S2 ?S1 ?X ?Y ?Z 1)Н (HANOI ?REV-SOLUTION ?S2 ?Z ?Y ?X ?N-1))Н((HANOI ?SOLUTION ?X ?Y ?Z ?N)Н (HANOI ?REV-SOLUTION NIL ?X ?Y ?Z ?N)Н (REVERSE ?SOLUTION ?REV-SOLUTION))Н((HUMAN SOCRATES))Н((MORTAL ?BEING) (HUMAN ?BEING))Н((GRANDPARENT GRAMPS BABE))Н((MOTHER ALICE GEORGE))Н((FATHER GEORGE PEEWEE))Н((GRANDPARENT ?GRAND ?CHILD) (PARENT ?GRAND ?PAR) (PARENT ?PAR ?CHILD))Н((PARENT ?P ?C) (MOTHER ?P ?C))Н((PARENT ?P ?C) (FATHER ?P ?C))Н((QUICK-SORT ?BIGGEST-SORTED NIL ?BIGGEST-SORTED))Н((QUICK-SORT ?SORTED (?KEY . ?REST) ?BIGGEST-SORTED)Н (PARTITION ?SMALLER ?BIGGER ?KEY ?REST)Н (QUICK-SORT ?ALL>=KEY-SORTED ?BIGGER ?BIGGEST-SORTED)Н (QUICK-SORT ?SORTED ?SMALLER (?KEY . ?ALL>=KEY-SORTED)))Н((QUICK-SORT ?SORTED ?UNSORTED) (QUICK-SORT ?SORTED ?UNSORTED NIL))Н((PARTITION NIL NIL ? NIL))Н((PARTITION (?FIRST . ?SMALLER) ?BIGGER ?KEY (?FIRST . ?REST))Н (< ?FIRST ?KEY)Н (PARTITION ?SMALLER ?BIGGER ?KEY ?REST))Н((PARTITION ?SMALLER (?FIRST . ?BIGGER) ?KEY (?FIRST . ?REST))Н (OR (< ?KEY ?FIRST) (= ?KEY ?FIRST))Н (PARTITION ?SMALLER ?BIGGER ?KEY ?REST))Н((< ?X ?Y) (SUCCESSOR ?Y ?X))Н((< ?X ?Y) (SUCCESSOR ?Y ?Y-1) (< ?X ?Y-1))Н((SUCCESSOR 1 0))Н((SUCCESSOR 2 1))Н((SUCCESSOR 3 2))Н((SUCCESSOR 4 3))Н((SUCCESSOR 5 4))Н((MEMBER ?X (?X . ?)))Н((MEMBER ?X (? . ?REST)) (MEMBER ?X ?REST))Н((REVERSE ?REVERSED-SO-FAR NIL ?REVERSED-SO-FAR))Н((REVERSE ?REVERSED (?FIRST . ?REST) ?REVERSED-SO-FAR)Н (REVERSE ?REVERSED ?REST (?FIRST . ?REVERSED-SO-FAR)))Н((REVERSE ?REVERSED ?X) (REVERSE ?REVERSED ?X NIL))Н((APPEND NIL))Н((APPEND ?X ?X))Н((APPEND ?APPENDED NIL ?Y . ?REST)Н (APPEND ?APPENDED ?Y . ?REST))Н((APPEND (?X1 . ?U) (?X1 . ?XREST) ?Y . ?REST)Н (APPEND ?U ?XREST ?Y . ?REST))НМН((OR ?FIRST . ?) ?FIRST)Н((OR ? . ?REST) (OR . ?REST))Н((AND))Н((AND ?FIRST . ?REST) ?FIRST (AND . ?REST))Н((= ?))Н((= ?X ?X . ?MORE) (= ?X . ?MORE))Н((=))Н((TRUE))НМН(query (mortal ?who))Н(MORTAL SOCRATES)НMore? (Y or N) Yes.ННН(MORTAL ?WHO) Н ?WHO = ?BEING = SOCRATESН(MORTAL SOCRATES) НННН(query (?what socrates))Н(HUMAN SOCRATES)НMore? (Y or N) Yes.Н(MORTAL SOCRATES)НMore? (Y or N) Yes.Н(= SOCRATES)НMore? (Y or N) Yes.ННН(?WHAT SOCRATES) Н ?WHAT = HUMANН(HUMAN SOCRATES) ННН(?WHAT SOCRATES) Н ?WHAT = MORTALН(MORTAL SOCRATES) ННН(?WHAT SOCRATES) Н ?WHAT = =Н(= SOCRATES) НМН(query (mortal ?who) t)НCan prove: (MORTAL ?WHO) with assertion ((MORTAL ?BEING) (HUMAN ?BEING))Нif can prove: ((HUMAN ?BEING))Н Can prove: (HUMAN ?BEING) with assertion ((HUMAN SOCRATES))Н Q.E.D.Н (HUMAN SOCRATES)Н(MORTAL SOCRATES)НMore? (Y or N) Yes.ННН(MORTAL ?WHO) Н ?WHO = ?BEING = SOCRATESН(MORTAL SOCRATES) НННН(query (?what socrates) t)НCan prove: (?WHAT SOCRATES) with assertion ((HUMAN SOCRATES))НQ.E.D.Н(HUMAN SOCRATES)НMore? (Y or N) Yes.НCan prove: (?WHAT SOCRATES) with assertion ((MORTAL ?BEING) (HUMAN ?BEING))Нif can prove: ((HUMAN SOCRATES))Н Can prove: (HUMAN SOCRATES) with assertion ((HUMAN SOCRATES))Н Q.E.D.Н (HUMAN SOCRATES)Н(MORTAL SOCRATES)НMore? (Y or N) No.ННН(?WHAT SOCRATES) Н ?WHAT = MORTALН(MORTAL SOCRATES) НМН(query (grandparent ?elder ?youth))Н(GRANDPARENT GRAMPS BABE)НMore? (Y or N) Yes.Н(GRANDPARENT ALICE PEEWEE)НMore? (Y or N) Yes.ННН(GRANDPARENT ?ELDER ?YOUTH) Н ?ELDER = GRAMPSН ?YOUTH = BABEН(GRANDPARENT GRAMPS BABE) ННН(GRANDPARENT ?ELDER ?YOUTH) Н ?ELDER = ?GRAND = ?PЙ = ALICEН ?YOUTH = ?CHILD = ?CЙ = PEEWEEН(GRANDPARENT ALICE PEEWEE) НННН(query (?relationship alice george))Н(MOTHER ALICE GEORGE)НMore? (Y or N) Yes.Н(PARENT ALICE GEORGE)НMore? (Y or N) Yes.ННН(?RELATIONSHIP ALICE GEORGE) Н ?RELATIONSHIPЙ = MOTHERН(MOTHER ALICE GEORGE) ННН(?RELATIONSHIP ALICE GEORGE) Н ?RELATIONSHIPЙ = PARENTН(PARENT ALICE GEORGE) НННН(query (?relationship alice peewee))Н(GRANDPARENT ALICE PEEWEE)НMore? (Y or N) Yes.ННН(?RELATIONSHIP ALICE PEEWEE) Н ?RELATIONSHIPЙ = GRANDPARENTН(GRANDPARENT ALICE PEEWEE) НМН(query (grandparent ?elder ?youth) t)НCan prove: (GRANDPARENT ?ELDER ?YOUTH) with assertionНЙЙЙЙЙ((GRANDPARENT GRAMPS BABE))НQ.E.D.Н(GRANDPARENT GRAMPS BABE)НMore? (Y or N) Yes.НCan prove: (GRANDPARENT ?ELDER ?YOUTH) with assertionНЙЙЙЙЙ((GRANDPARENT ?GRAND ?CHILD)НЙЙЙЙЙ (PARENT ?GRAND ?PAR)НЙЙЙЙЙ (PARENT ?PAR ?CHILD))Нif can prove: ((PARENT ?GRAND ?PAR) (PARENT ?PAR ?CHILD))Н Can prove: (PARENT ?GRAND ?PAR) with assertionНЙЙЙЙ ((PARENT ?P ?C) (MOTHER ?P ?C))Н if can prove: ((MOTHER ?P ?C))Н Can prove: (MOTHER ?P ?C) with assertion ((MOTHER ALICE GEORGE))Н Q.E.D.Н (MOTHER ALICE GEORGE)Н (PARENT ALICE GEORGE)Н Can prove: (PARENT ?GRAND ?PAR) with assertionНЙЙЙЙ ((PARENT ?P ?C) (FATHER ?P ?C))Н if can prove: ((FATHER ?P ?C))Н Can prove: (FATHER ?P ?C) with assertion ((FATHER GEORGE PEEWEE))Н Q.E.D.Н (FATHER GEORGE PEEWEE)Н (PARENT GEORGE PEEWEE)Н Can prove: (PARENT GEORGE ?CHILD) with assertionНЙЙЙЙ ((PARENT ?P ?C) (MOTHER ?P ?C))Н if can prove: ((MOTHER GEORGE ?C))Н DRATS!Н Can prove: (PARENT GEORGE ?CHILD) with assertionНЙЙЙЙ ((PARENT ?P ?C) (FATHER ?P ?C))Н if can prove: ((FATHER GEORGE ?C))Н Can prove: (FATHER GEORGE ?C) with assertion ((FATHER GEORGE PEEWEE))Н Q.E.D.Н (FATHER GEORGE PEEWEE)Н (PARENT GEORGE PEEWEE)Н Can prove: (PARENT PEEWEE ?CHILD) with assertionНЙЙЙЙ ((PARENT ?P ?C) (MOTHER ?P ?C))Н if can prove: ((MOTHER PEEWEE ?C))Н DRATS!Н Can prove: (PARENT PEEWEE ?CHILD) with assertionНЙЙЙЙ ((PARENT ?P ?C) (FATHER ?P ?C))Н if can prove: ((FATHER PEEWEE ?C))Н DRATS!Н(GRANDPARENT ALICE PEEWEE)НMore? (Y or N) No.ННН(GRANDPARENT ?ELDER ?YOUTH) Н ?ELDER = ?GRAND = ?PЙ = ALICEН ?YOUTH = ?CHILD = ?CЙ = PEEWEEН(GRANDPARENT ALICE PEEWEE) НМН(query (member 4 (8 4 2)) t)НCan prove: (MEMBER 4 (8 4 2)) with assertionНЙЙЙ ((MEMBER ?X (? . ?REST)) (MEMBER ?X ?REST))Нif can prove: ((MEMBER 4 (4 2)))Н Can prove: (MEMBER 4 (4 2)) with assertion ((MEMBER ?X (?X . ?)))Н Q.E.D.Н (MEMBER 4 (4 2))Н Can prove: (MEMBER 4 (4 2)) with assertionНЙЙЙЙ((MEMBER ?X (? . ?REST)) (MEMBER ?X ?REST))Н if can prove: ((MEMBER 4 (2)))Н Can prove: (MEMBER 4 (2)) with assertionНЙЙЙЙ ((MEMBER ?X (? . ?REST)) (MEMBER ?X ?REST))Н if can prove: ((MEMBER 4 NIL))Н DRATS!Н DRATS!Н(MEMBER 4 (8 4 2))НMore? (Y or N) Yes.ННН(MEMBER 4 (8 4 2)) Н(MEMBER 4 (8 4 2)) НННН(query (member 3 (8 4 2)) t)НCan prove: (MEMBER 3 (8 4 2)) with assertionНЙЙЙ ((MEMBER ?X (? . ?REST)) (MEMBER ?X ?REST))Нif can prove: ((MEMBER 3 (4 2)))Н Can prove: (MEMBER 3 (4 2)) with assertionНЙЙЙЙ((MEMBER ?X (? . ?REST)) (MEMBER ?X ?REST))Н if can prove: ((MEMBER 3 (2)))Н Can prove: (MEMBER 3 (2)) with assertionНЙЙЙЙ ((MEMBER ?X (? . ?REST)) (MEMBER ?X ?REST))Н if can prove: ((MEMBER 3 NIL))Н DRATS!Н DRATS!НDRATS!НnoneНМН(query (member ?any (8 4 2)))Н(MEMBER 8 (8 4 2))НMore? (Y or N) Yes.Н(MEMBER 4 (8 4 2))НMore? (Y or N) Yes.Н(MEMBER 2 (8 4 2))НMore? (Y or N) Yes.ННН(MEMBER ?ANY (8 4 2)) Н ?ANY = ?XЙ = 8Н(MEMBER 8 (8 4 2)) ННН(MEMBER ?ANY (8 4 2)) Н ?ANY = ?XЙ = ?XЙ = 4Н(MEMBER 4 (8 4 2)) ННН(MEMBER ?ANY (8 4 2)) Н ?ANY = ?XЙ = ?XЙ = ?X = 2Н(MEMBER 2 (8 4 2)) НННН(query (member 3 (?a ?b ?c)))Н(MEMBER 3 (3 ?B ?C))НMore? (Y or N) Yes.Н(MEMBER 3 (?A 3 ?C))НMore? (Y or N) Yes.Н(MEMBER 3 (?A ?B 3))НMore? (Y or N) Yes.ННН(MEMBER 3 (?A ?B ?C)) Н ?AЙ = 3Н ?BН ?CН(MEMBER 3 (3 ?B ?C)) ННН(MEMBER 3 (?A ?B ?C)) Н ?AЙ = ?Н ?BЙ = 3Н ?CН(MEMBER 3 (?A 3 ?C)) ННН(MEMBER 3 (?A ?B ?C)) Н ?AЙ = ?Н ?BЙ = ?Н ?CЙ = 3Н(MEMBER 3 (?A ?B 3)) НМН(query (member 3 ?any) t)НCan prove: (MEMBER 3 ?ANY) with assertion ((MEMBER ?X (?X . ?)))НQ.E.D.Н(MEMBER 3 (3 . ?))НMore? (Y or N) Yes.НCan prove: (MEMBER 3 ?ANY) with assertionНЙЙЙ ((MEMBER ?X (? . ?REST)) (MEMBER ?X ?REST))Нif can prove: ((MEMBER 3 ?REST))Н Can prove: (MEMBER 3 ?REST) with assertion ((MEMBER ?X (?X . ?)))Н Q.E.D.Н (MEMBER 3 (3 . ?))Н Can prove: (MEMBER 3 ?REST) with assertionНЙЙЙЙ((MEMBER ?X (? . ?REST)) (MEMBER ?X ?REST))Н if can prove: ((MEMBER 3 ?REST))Н Can prove: (MEMBER 3 ?REST) with assertion ((MEMBER ?X (?X . ?)))Н Q.E.D.Н (MEMBER 3 (3 . ?))Н Can prove: (MEMBER 3 ?REST) with assertionНЙЙЙЙ ((MEMBER ?X (? . ?REST)) (MEMBER ?X ?REST))Н if can prove: ((MEMBER 3 ?REST)) . . .НН; [aborted]НН;Back to top level.НМН(query (append ?result (a b) (c)) t)НCan prove: (APPEND ?RESULT (A B) (C)) with assertionНЙЙЙЙ ((APPENDНЙЙЙЙЙ (?X1 . ?U)НЙЙЙЙЙ (?X1 . ?XREST) ?Y . ?REST)НЙЙЙЙЙ(APPEND ?U ?XREST ?Y . ?REST))Нif can prove: ((APPEND ?U (B) (C)))Н Can prove: (APPEND ?U (B) (C)) with assertionНЙЙЙЙ ((APPENDНЙЙЙЙ (?X1 . ?U)НЙЙЙЙ (?X1 . ?XREST) ?Y . ?REST)НЙЙЙЙ (APPEND ?U ?XREST ?Y . ?REST))Н if can prove: ((APPEND ?U NIL (C)))Н Can prove: (APPEND ?U NIL (C)) with assertionНЙЙЙЙ ((APPEND ?APPENDED NIL ?Y . ?REST)НЙЙЙЙ (APPEND ?APPENDED ?Y . ?REST))Н if can prove: ((APPEND ?APPENDED (C)))НЙ Can prove: (APPEND ?APPENDED (C)) with assertion ((APPEND ?X ?X))НЙ Q.E.D.НЙ (APPEND (C) (C))Н (APPEND (C) NIL (C))Н (APPEND (B C) (B) (C))Н(APPEND (A B C) (A B) (C))НMore? (Y or N) Yes.ННН(APPEND ?RESULT (A B) (C)) Н ?RESULT = (?X1 . ?U)Н(APPEND (A B C) (A B) (C)) НННН(query (append (a b c) (a b) ?what))Н(APPEND (A B C) (A B) (C))НMore? (Y or N) Yes.ННН(APPEND (A B C) (A B) ?WHAT) Н ?WHAT = ?YЙ = ?YЙ = ?Y = (C)Н(APPEND (A B C) (A B) (C)) НННН(query (append (a b c) ?what (c)))Н(APPEND (A B C) (A B) (C))НMore? (Y or N) Yes.ННН(APPEND (A B C) ?WHAT (C)) Н ?WHAT = (?X1 . ?XREST)Н(APPEND (A B C) (A B) (C)) НМН(query (hanoi ?solution a b c 1))Н(HANOI ((MOVE FROM A TO B)) A B C 1)НMore? (Y or N) Yes.ННН(HANOI ?SOLUTION A B C 1) Н ?SOLUTION = ?SOLUTIONЙ = ?REVERSEDЙ = ?REVERSEDНЙЙ= ?REVERSED-SO-FAR = (?FIRST . ?REVERSED-SO-FAR)Н(HANOI ((MOVE FROM A TO B)) A B C 1) ННН(query (hanoi ?solution peg-a peg-b peg-c 4))Н(HANOI ((MOVE FROM PEG-A TO PEG-C)НЙ(MOVE FROM PEG-A TO PEG-B)НЙ(MOVE FROM PEG-C TO PEG-B)НЙ(MOVE FROM PEG-A TO PEG-C)НЙ(MOVE FROM PEG-B TO PEG-A)НЙ(MOVE FROM PEG-B TO PEG-C)НЙ(MOVE FROM PEG-A TO PEG-C)НЙ(MOVE FROM PEG-A TO PEG-B)НЙ(MOVE FROM PEG-C TO PEG-B)НЙ(MOVE FROM PEG-C TO PEG-A)НЙ(MOVE FROM PEG-B TO PEG-A)НЙ(MOVE FROM PEG-C TO PEG-B)НЙ(MOVE FROM PEG-A TO PEG-C)НЙ(MOVE FROM PEG-A TO PEG-B)НЙ(MOVE FROM PEG-C TO PEG-B))Н PEG-AН PEG-BН PEG-CН 4)НMore? (Y or N) Yes.ННН(HANOI ?SOLUTION PEG-A PEG-B PEG-C 4) Н ?SOLUTION = ?SOLUTION = ?REVERSED = ?REVERSED . . .НЙЙ= ?REVERSED-SO-FAR = (?FIRST . ?REVERSED-SO-FAR)Н(HANOI ((MOVE FROM PEG-A TO PEG-C)НЙ. . .НЙ(MOVE FROM PEG-C TO PEG-B))Н PEG-AН PEG-BН PEG-CН 4)НН(logout)НTН;Reading in base 10 in package USER with standard Zetalisp readtable.НLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 1 :LENGTH-IN-BYTES 724 :AUTHOR "SAM" :CREATION-DATE 2725553148 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "PROLOG-INIT" :TYPE "LISP" :VERSION 1) ;;; -*- Mode:LISP; Readtable:COMMON-LISP; Base:10 -*-Н#|НН (C) COPYRIGHT 1986 LISP Machine, IncorporatedН All Rights ReservedНН___________________________________________________________________________Н|#НН;;; Samuel F. PilatoНННН;;;;PROLOG-INITНН(require 'cl-init "duke:lisp2-circulation;cl-init")ННН(with-module-pathname-defaults ("duke: lisp2-circulation;")Н (apply #'register-modulesНЙ '(НЙ definingНЙ streamsНЙ variable-substitutionНЙ list-patternsНЙ (pattern-definition list-patterns)НЙ pattern-processingНЙ unificationНЙ predicate-calculusНЙ PrologНЙ Hanoi_PrologНЙ otherНЙ )))НН;(compile-load-modules)НН(require 'Prolog)Н(require 'Hanoi_Prolog)Н(require 'other)НLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 3 :LENGTH-IN-BYTES 2802 :AUTHOR "wilde" :CREATION-DATE 2716346322 :QFASLP NIL :LENGTH 2802 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "QUERIES" :TYPE "LISP" :VERSION 2) ; -*- mode: lisp ; fonts: (medfnb) ;ibase: 10.;base:10. -*-НН; a quick testНН;; Copyright (C) 1985 LISP Machine, Incorporated.НН(defun quiz ()Н (cond ((not (y-or-n-p "Are you ready to start?")) nil)НЙ(t (run-quiz))))НН; Getting info from the userН(defunp run-quiz (&aux name ans)Н ;prompt and read is a simple to use function (p. 385)Н (setq name (prompt-and-read ':string "~%What is your name? "))Н ; a little more interesting use of prompt and readН (quest-satisfied)Н ; now let's explore using FQUERY Н (format t "~% Here are some questions for you: ")Н ; first, we use it in a simple wayН (setq ans Н (fqueryН '(:type :readlineН :choices ((nil "Blue")(nil "Red")(nil "other")(t "I don't know")))Н "What is your favorite color?"))Н (cond (ans (Format t "~% aaaaagggghhhh (it appears you've been killed")НЙ (return 'dead))) ;EXIT FROM FUNCTION!!Н ; a little more complex choice listН (setq ansН (fqueryН '(:type :tyi ;this would be the default, I'm making it explicit Н :choicesН (((t "choice 1") #/a #/1)НЙ ((t "choice 2") #/b #/2)НЙ ((nil "choice 3") #/c #/3)))Н " Where are Lisp machines made:Н a) MassachusettsН b) The West CoastН c) They are not made, they are born.~%"))Н (cond (ans (Format t "~% Gotcha on that one -- correct answer was cН ~% (appears you are dead)")НЙ (return 'Dead))) ;EXIT FROM FUNCTION!!Н ;using the optionН (setq ansН (fqueryН '(:type :tyiН :list-choices nil ;don't list the choicesН :help-function quiz-help-functionН :choicesН (((nil 1) #/1)((nil 2) #/2)((correct 3) #/3)((joke 4) #/4)))Н "Who was the first president (Hit HELP key for more info):Н 1) Lincoln 2) JeffersonН 3) Washington 4) Hendler~%"))Н (cond ((not ans)(format t "~% sorry (appears you flunk)")НЙЙ (return 'Flunk)) ;EXIT FROM FUNCTIONНЙ((eq ans 'correct)(format t "Close enough -- you pass")НЙЙЙ (return 'Pass));EXIT FROM FUNCTIONНЙ((eq ans 'joke)(format t "~%Flattery will get you everywhere")НЙЙ (return 'WIN))) ;EXIT FROM FUNCTIONН) НН(defun quest-satisfied (&aux response)Н (setq responseН (prompt-and-read ':eval-sexp-or-endНЙ Й "~%What is your quest?(Enter a lisp form to evaluate) "))Н (cond ((not response)НЙ (format t "~% aww - you gotta have some quest")НЙ (quest-satisfied))НЙ((memq response '(find-grail find-the-grail find-the-holy-grail))НЙ (format t "'~% This ain't Monty Python -- try again")НЙ (quest-satisfied))НЙ(t "That's a nice quest")))НН(defun quiz-help-function (stream &rest ignore)Н (format streamНЙ "~%This is a serious question pertaining to American history.")Н (format streamН "~% (However, feel free to answer flippantly)"))НLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 4 :LENGTH-IN-BYTES 3535 :AUTHOR "ESMITH" :CREATION-DATE 2685049776 :QFASLP NIL :LENGTH 3535 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "QUICK-STATS" :TYPE "LISP" :VERSION 9) (DEFMACRO DEFAULT-USER-NAME ()Н `(READ-FROM-STRINGН (%P-CONTENTS-OFFSET (CDAR *DEFAULT-PATHNAME-DEFAULTS*) 3)))НН(DEFMACRO DEFAULT-USER-HOST ()Н `(%P-CONTENTS-OFFSET (CDAR (LAST *DEFAULT-PATHNAME-DEFAULTS*)) 1))НН(DEFMACRO MAKE-COPIES-OF (S-EXPR COUNT)Н `(MAKE-SEQUENCE 'LIST ,COUNT :INITIAL-ELEMENT ,S-EXPR))НН(DEFSUBST INTERLEAVE (LIST-A LIST-B)Н (LET* ((LEN-A (LENGTH LIST-A))НЙ (LEN-B (LENGTH LIST-B))НЙ (TWIST (> LEN-A LEN-B)) ;;; clockwise or counterclockwiseНЙ (REMAINDER (IF TWISTНЙЙЙ(NTHCDR LEN-B LIST-A)НЙЙ (NTHCDR LEN-A LIST-B)))НЙ (NESTED-LIST-B (MAPCAR 'CONSНЙЙЙЙLIST-BНЙЙЙЙ(MAKE-COPIES-OF 'NIL (IF TWISTНЙЙЙЙЙЙЙ LEN-BНЙЙЙЙЙЙ LEN-A))))НЙ (ADJUSTED-LIST-A (IF TWISTНЙЙЙ LIST-AНЙЙЙ (FIRSTN LEN-B LIST-A)))НЙ (PAIRS-LIST (MAPCAR 'CONS ADJUSTED-LIST-A NESTED-LIST-B))НЙ (ANSWER (LOOP FOR ENTRY IN PAIRS-LISTНЙЙ WITH RESULT DOНЙЙ (SETQ RESULT (APPEND RESULT ENTRY))НЙЙ FINALLY (RETURN RESULT))))Н (APPEND ANSWER REMAINDER)))НН(DEFMACRO READ-NAME (I)Н `(PROGN (FORMAT T "~%name ~S> " ,I)НЙ (READ-DELIMITED-STRING '(#\END #\RETURN #\LINEFEED))))НН(DEFMACRO READ-SCORE (I)Н `(PROGN (FORMAT T "~%score ~S> " ,I)НЙ (READ)))НН(DEFUN ENTER-SCORES ()Н (FORMAT T "~%To terminate name strings, use END, RETURN or LINEFEED")Н (FORMAT T "~%SPACE may also be used to terminate scores (but not name strings)")Н (LET* ((USER-INPUT (DO* ((I 1 (1+ I))НЙЙЙ (CURRENT-NAME (READ-NAME I) (READ-NAME I))НЙЙЙ (ESCAPE-STRING (STRING-UPCASE CURRENT-NAME)НЙЙЙЙЙ (STRING-UPCASE CURRENT-NAME))НЙЙЙ (TERMINATION-CONDITIONНЙЙЙ (OR (EQUAL ESCAPE-STRING "BYE")НЙЙЙЙ (EQUAL ESCAPE-STRING "END")НЙЙЙЙ (EQUAL ESCAPE-STRING "EXIT")НЙЙЙЙ (EQUAL ESCAPE-STRING "QUIT")НЙЙЙЙ (EQUAL ESCAPE-STRING "STOP"))НЙЙЙ (OR (EQUAL ESCAPE-STRING "BYE")НЙЙЙЙ (EQUAL ESCAPE-STRING "END")НЙЙЙЙ (EQUAL ESCAPE-STRING "EXIT")НЙЙЙЙ (EQUAL ESCAPE-STRING "QUIT")НЙЙЙЙ (EQUAL ESCAPE-STRING "STOP")))НЙЙЙ (CURRENT-SCORE (READ-SCORE I)НЙЙЙЙЙ (IF TERMINATION-CONDITIONНЙЙЙЙЙ -1НЙЙЙЙЙ (READ-SCORE I)))НЙЙЙ (TERMINATION-CONDITION (OR TERMINATION-CONDITIONНЙЙЙЙЙЙ (< CURRENT-SCORE 0))НЙЙЙЙЙЙ (OR TERMINATION-CONDITIONНЙЙЙЙЙЙ (< CURRENT-SCORE 0)))НЙЙЙ (NAMES (LIST CURRENT-NAME)НЙЙЙЙ (APPEND NAMES (LIST CURRENT-NAME)))НЙЙЙ (SCORES (LIST CURRENT-SCORE)НЙЙЙЙ (APPEND SCORES (LIST CURRENT-SCORE))))НЙЙЙ (TERMINATION-CONDITIONНЙЙЙ (LIST NAMES SCORES)))))Н USER-INPUT))НЙ Н(DEFVAR ANALYSED-SCORES '(0 0))НН(DECLARE (SPECIAL ANALYSED-SCORES))НН(DEFUN ANALYSE-SCORES ()Н (LET* ((INPUT (ENTER-SCORES))НЙ (NAMES (BUTLAST (CAR INPUT)))НЙ (SCORES (MAPCAR 'FLOAT (BUTLAST (CADR INPUT))))НЙ (N (LENGTH SCORES))НЙ (GRAND-TOTAL (APPLY 'PLUS SCORES))НЙ (MEAN (QUOTIENT (APPLY 'PLUS SCORES) N))НЙ (STD-DEV (SQRTНЙЙ (QUOTIENT (APPLY 'PLUSНЙЙЙЙ (LET ((MEAN-DIFFSНЙЙЙЙЙ (MAPCAR 'DIFFERENCEНЙЙЙЙЙЙ (MAKE-COPIES-OF MEAN N)НЙЙЙЙЙЙ SCORES)))НЙЙЙЙ (MAPCAR 'TIMESНЙЙЙЙЙ MEAN-DIFFSНЙЙЙЙЙ MEAN-DIFFS)))НЙЙЙ N)))НЙ (DTSTRING (FORMAT NIL "~\datime\"))НЙ (DATESTRING (SUBSTRING DTSTRING 0 (STRING-SEARCH " " DTSTRING)))НЙ (QS-FILENAME (STRING-APPEND (DEFAULT-USER-HOST) ": "НЙЙЙ(DEFAULT-USER-NAME) "; QS-SCORES-"НЙЙЙDATESTRINGНЙЙЙ".TEXT")))Н (WITH-OPEN-FILE (TERMINAL-IO QS-FILENAME :DIRECTION :OUTPUT)Н (LOOP FOR ENTRY-PAIR ON (INTERLEAVE NAMES SCORES) BY 'CDDR DOНЙ (FORMAT T "~%~S ~S" (CAR ENTRY-PAIR) (CADR ENTRY-PAIR)))Н (FORMAT T "~%~%Mean: ~S, Standard Deviation: ~S" MEAN STD-DEV))Н (VIEWF QS-FILENAME)Н (SETQ ANALYSED-SCORES (LIST MEAN STD-DEV))))ННLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 23 :LENGTH-IN-BYTES 23464 :AUTHOR "ESMITH" :CREATION-DATE 2695333713 :QFASLP NIL :LENGTH 23464 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "RAPID-PROTOTYPING" :TYPE "LISP" :VERSION 7) ;;; LISP Programming LABН;;; Rapid PrototypingН;;; Page 1ННН;;; -*- Mode:LISP; Package:USER; Fonts:(CPTFONT) -*-НН;;; Developed by Linda M. ChurchmanН;;; Revised by J. Elliott SmithН;;; Copyright (C) Lisp Machine Inc. 1984, 1985ННН;;; This exercise is a demonstration of rapid software developmentН;;; using ZetaLISP on an LMI Lambda LISP Machine.ННН;;; To begin our rapid prototyping example, let's draw a few itemsН;;; on a window. Our first attempt draws several instances of oneН;;; type of graphic figure. We can do this by writing a function Н;;; that uses a DO {loop} form to request graphics operations thatН;;; draw circles on a specified window. *TERMINAL-IO* is a globalН;;; variable that the LISP system binds to the input/output streamН;;; associated with the currently selected window.ННН;;; After we see whether this function works, we can easily thinkН;;; of other more interesting things to have it do.ННН;;; This exercise assumes that you start in a LISP Listener window.Н;;; If you are already in an editor buffer, ignore the beginningН;;; instructions and start by typing the function into the buffer.НН;;; Log in by typing Н;;;Н;;; (LOGIN 'your-login-name T)Н;;;Н;;; and switch to an Editor Buffer by typing -E.Н;;;Н;;; When entering a function, the left parenthesis which delimitsН;;; the function should be in the column zero. Type each line asН;;; shown below. To get automatic indentation of succeeding lines,Н;;; depress the key at the end of each typed line. If youН;;; forget to do that, and type instead, don't panic; theН;;; key repositions the cursor on the current line.ННН;;; As you are typing, you can move the TEXT cursor from place toН;;; place on the screen by positioning the MOUSE cursor where you Н;;; want to go, and clicking left once.ННН;;; NOTE: This exercise performs better if "MORE Processing" isН;;; disabled before you start. If it isn't, drawing on the windowН;;; will stop whenever the randomly selected graphics cursor comesН;;; too near the bottom of the window. The LISP system will waitН;;; for you to type a space before continuing.НН;;; To turn off "MORE Processing", type -1 MННМ;;; LISP Programming LABН;;; Rapid PrototypingН;;; Page 2ННН;;; Next, to the editor, type in the following function:ННН(DEFUN DRF ()Н (SEND *TERMINAL-IO* ':CLEAR-SCREEN)Н (DOTIMES (I 10)Н (SEND *TERMINAL-IO* ':DRAW-CIRCLEНЙ (RANDOM 600)НЙ (RANDOM 700)НЙ (RANDOM 100))))ННН;;; As you type, depress the key to terminate each line,Н;;; instead of the key, and the ZMACS editor will indentН;;; your function properly. ZMACS also checks whether parenthesesН;;; are balanced {matched}. You can visually confirm that parensН;;; are correctly nested by looking for a blinking left paren eachН;;; time you type a right parenthesis. {In fact, the correspondingН;;; paren blinks whenever the text cursor is directly to the rightН;;; of any existing right parenthesis.}ННН;;; With the cursor positioned inside of or immmediately after the Н;;; function you have just entered, type either Control-Shift-C orН;;; Hyper-Control-C to compile the function. The two commands areН;;; equivalent, and have identical effect {both are implemented byН;;; a call to COM-COMPILE-REGION.} If typed exactly as above, theН;;; function will compile properly.НН;;; After the function is compiled, a confirmation message appearsН;;; in the "mini-buffer" area at the bottom of the buffer window.Н;;; Also, while the function is being compiled, the message on theН;;; center bottom of the screen says Run instead of Keyboard.ННН;;; Return to the LISP Listener by typing - L and test yourН;;; function by entering:ННН(DRF)ННМ;;; LISP Programming LABН;;; Rapid PrototypingН;;; Page 3ННН;;; Our first attempt works, but it isn't very interesting. Also,Н;;; it is annoying to have to change windows each time we want toН;;; try a new version of the function, so we will change the sizeН;;; of the editor buffer, and then create another LISP Listener inН;;; a separate another window on the same display.ННН;;; The following instructions explain how to restructure an editorН;;; buffer, and create a LISP Listener above it.НН;;; Click double-right on the mouse to obtain the system menu.НН;;; Clicking left on Edit Screen gets another menu of things to do. НН;;; A left click left on Reshape causes a cross-in-a-circle mouseН;;; cursor to appear. It is used to select the window to reshape.Н;;; Click left to choose the current editor buffer.НН;;; Look in the top left corner of the editor for the mouse cursorН;;; in the shape of a left corner.НН;;; Move the mouse cursor about 3/4 of the way down the screen, onН;;; the left, and click left.НН;;; Now look at the bottom right edge of the editor buffer. A rightН;;; bottom corner mouse cursor should be there. Leave it where itН;;; is, and click right.НН;;; Your editor buffer should now reshape, and the Edit Screen menuН;;; will reappear.НН;;; Click left on Create to obtain a menu of window types.НН;;; Click left on Lisp; the mouse cursor again becomes a left corner.НН;;; Move the corner to the top left of the screen, and click right.НН;;; Look in the bottom right corner of the screen for a right cornerН;;; mouse cursor. Move it just above and to the right of the ZMACSН;;; window. Click right.НН;;; A LISP Listener window forms, and the Edit Screen menu reappears.НН;;; Click left on Exit. The menu will go away.НН;;; Click left on the editor buffer to get the function to redisplay.НННМ;;; LISP Programming LABН;;; Rapid PrototypingН;;; Page 4ННН;;; Another way to create a working window setup uses facilitiesН;;; available through the system menu. In a LISP Listener, clickН;;; right to get the system menu. Click left in the system menu,Н;;; on "Split Screen" {under "Windows}. This gives you a menu inН;;; which you can select kinds of windows to include in your splitН;;; screen. НН;;; Click successively on "Lisp", "Edit", and "Do it".НН;;; To save this configuration, click right for a system menu, andН;;; then click left on "Layouts". You will get a menu which givesН;;; you at least two choices. НН;;; If you click left on "Save This", you will be asked for a nameН;;; to reference the screen configuration. The configuration willН;;; be bound to a system key if a single character is entered; forН;;; example, if you use, say, 9, you can access that configurationН;;; by typing -9. After you name a configuration, you can Н;;; also access it through the system menu, by clicking left onН;;; "Layouts", then clicking left on the symbol you supplied.НННН;;; Now, with the editor buffer on the bottom of the screen, and aН;;; LISP Listener on the top of the screen, development continues.Н;;; Change the function in the editor, compile it, then test it inН;;; LISP Listener. Subsequent program development can in this wayН;;; proceed quickly and naturally.НН;;; To improve the function, let's change it to continue drawingН;;; figures indefinitely until you type a character on the terminal.Н;;; The way to do that is to change the DOTIMES to a DO {loop} formН;;; that keeps on going until you type on the keyboard. Note thatН;;; in order to stop this function, you must type on the keyboardН;;; while the LISP Listener has control, so that the character goesН;;; into the Lisp listener's input buffer. Change the function to Н;;; look as follows {the change is on the third line}:НН(DEFUN DRF ()Н (SEND *TERMINAL-IO* ':CLEAR-SCREEN)Н (DO () ((SEND *TERMINAL-IO* ':TYI-NO-HANG) 'DONE)Н (SEND *TERMINAL-IO* ':DRAW-CIRCLEНЙ (RANDOM 600)НЙ (RANDOM 700)НЙ (RANDOM 100))))ННМ;;; LISP Programming LABН;;; Rapid PrototypingН;;; Page 5ННН;;; After you compile the changed function with Control-Shift-C,Н;;; test it by moving the mouse cursor to the LISP Listener at theН;;; top of the screen, clicking left, and typing Control-C to makeН;;; the function reappear. Note that the final right parenthesis Н;;; is already there. To evaluate the function, enter a carriageН;;; return, or hit , and re-enter the closing ")".ННН;;; The function now looks better, so let's develop it further.ННН;;; Click left on the editor buffer to transfer control. Each timeН;;; you transfer between ZMACS and the LISP Listener, you have toН;;; click left on the window you are transferring to. I assume inН;;; the remainder of these instructions that you have done so when Н;;; necessary.ННН;;; It would be nice to specify which window to do the drawing in.НН;;; We can do this by typingНН;;; -X,НН;;; then {to a mini-buffer} the words "Replace String" {withoutН;;; the double quotes}, followed by a carriage return.НН;;; Next, enter "*TERMINAL-IO*" followed with a carriage return,Н;;; then "W" followed by a carriage return.НН;;; The other thing we need to do is specify that W be a parameterН;;; of our function. To do this, insert W within the parentheses,Н;;; (), that follow the function name.ННН;;; We also want to be able to specify an area to draw the figuresН;;; based on the size of the window we are putting them in, ratherН;;; than explicitly specifying the numbers. To do this, define twoН;;; local variables MAX-X-SIZE and MAX-Y-SIZE inside a let, thenН;;; substitute MAX-X-SIZE and MAX-Y-SIZE for the constants "600" &Н;;; "700", respectively. As you can see, we've inserted three newН;;; lines after the first, changed the second and third lines fromН;;; the bottom, and added a right parenthesis on the last line.ННМ;;; LISP Programming LABН;;; Rapid PrototypingН;;; Page 6ННН;;; When you are making changes to a function that may change itsН;;; proper indentation, it is important to check the new indenting Н;;; to see if the results are what you intended. НН;;; With the cursor inside the function you want to check, typeН;;; Control-Meta-H to mark it as a region, which is underlinedН;;; along with any text {comments} immediately preceeding it. ThenН;;; type Control-Meta-\ to re-indent the entire function.НН;;; Use this technique whenever necessary as you make changes.Н Н(DEFUN DRF (W)Н (SEND W ':CLEAR-SCREEN)Н (LET ((MAX-X-SIZE (SEND W ':INSIDE-WIDTH))НЙ(MAX-Y-SIZE (SEND W ':INSIDE-HEIGHT)))Н (DO () ((SEND W ':TYI-NO-HANG) 'DONE)Н (SEND W ':DRAW-CIRCLEНЙ (RANDOM MAX-X-SIZE)НЙ (RANDOM MAX-Y-SIZE)НЙ (RANDOM 100)))))НН;;; Compile and test again as above. But wait, we have an error,Н;;; which informs us that we have only zero arguments. What did weН;;; forget? Maybe the debugger will help us.НН;;; When asked if you want to enter the debugger, answer by typingН;;; the single letter Y. This tells us that we needed to specify Н;;; the new parameter W, the window in which we wish to draw. TheН;;; debugger gives us the option of resuming function executionН;;; {type the following things to the prompt arrow}:НН;;; {on the upper right of the keyboard}, thenН;;; *TERMINAL-IO*, followed by a carriage return.НН;;; If you decide to use the window based debugger to gain furtherН;;; insight into the problem, type Control-Meta-W, which producesН;;; the window based debugger screen.НН;;; Quoting from the Window System Manual, page 171:НН;;; "The debugger window is divided into six panes. At the Н;;; bottom is a Lisp-listener-like window, which ordinarily Н;;; provides a read-eval-print-loop similar to the regular Н;;; keyboard debugger.... НН;;; "At the top is a display of the disassembled or ground Н;;; code for the currently selected stack frame.... НН;;; "It has a scroll-bar....НН;;; "Next are the args and locals windows, side by side, Н;;; displaying the names and values of the arguments to the Н;;; current stack frame and its local variables....НН;;; "Next is the stack window, which displays in a pseudo-list Н;;; format the functions and arguments on the stack....Н;;; Below this, and above the Lisp window, is the command Н;;; menu for the debugger window...."ННМ;;; LISP Programming LABН;;; Rapid PrototypingН;;; Page 7ННН;;; Put the mouse cursor on Proceed, and click left. You will be Н;;; asked to supply a value for the variable w. Type *TERMINAL-IO*Н;;; and a , then just wait. The window based debugger will Н;;; exit to the LISP Listener and then execute the function {whichН;;; should work this time}.НННН;;; The latest results are much better, reminiscent of New Year'sН;;; Eve, but the display is getting a little busy, so let's clearН;;; the screen periodically, and write a string on the window. WeН;;; want the capability to do either circles or repetitions of aН;;; string. The changes are on the first line, the line after theН;;; DO form, and another 2 lines at the end of the function. ThereН;;; should be 3 right parentheses on the right side of the latestН;;; addition.НН;;; Notice the optional arguments:НН;;; (DRF *TERMINAL-IO*) draws both circles and the string "Linda"Н;;; on the current Lisp listener;НН;;; (DRF *TERMINAL-IO* T NIL) draws just circles;НН;;; (DRF *TERMINAL-IO* NIL T) draws just the string "Linda";НН;;; (DRF *TERMINAL-IO* T T "George") draws circles and the stringН;;; "George"; and so on.НН;;; Try different combinations while practising to see what happens.ННН;;; The function now looks as follows: НН(DEFUN DRFН (W &OPTIONAL (DRAW-CIRCLES T) (DRAW-STRINGS T)НЙ(OUT-STRING "LINDA"))Н (SEND W ':CLEAR-SCREEN)Н (LET ((MAX-X-SIZE (SEND W ':INSIDE-WIDTH))НЙ(MAX-Y-SIZE (SEND W ':INSIDE-HEIGHT)))Н (DO () ((SEND W ':TYI-NO-HANG) 'DONE)Н (WHEN (< (RANDOM 100) 1) (SEND W ':CLEAR-SCREEN))Н (WHEN DRAW-CIRCLESНЙ(SEND W ':DRAW-CIRCLEНЙ (RANDOM MAX-X-SIZE)НЙ (RANDOM MAX-Y-SIZE)НЙ (RANDOM 100)))Н (WHEN DRAW-STRINGSНЙ(SEND W ':STRING-OUT OUT-STRING))НЙ)))НН;;; Again, compile the function. This time, to test it, type theН;;; entire function call to the Lisp listener, as follows:НН(DRF *TERMINAL-IO*)ННМ;;; LISP Programming LABН;;; Rapid PrototypingН;;; Page 8ННН;;; That's interesting, but let's make the string jump around onН;;; the screen, too. We can do so by changing the cursor positionН;;; each time we print the string. Let's also print the stringН;;; in a larger font. Add two lines after the second line in theН;;; function. Add three new lines directly after the statementН;;; "(when draw-strings".Н Н;;; Now the function looks like this:НН(DEFUN DRFН (W &OPTIONAL (DRAW-CIRCLES T) (DRAW-STRINGS T)НЙ(OUT-STRING "LINDA"))Н (SEND W ':CLEAR-SCREEN)Н (SEND W ':SET-FONT-MAP '(FONTS:BIGFNT FONTS:CPTFONT))Н (SEND W ':SET-CURRENT-FONT 'FONTS:BIGFNT)Н (LET ((MAX-X-SIZE (SEND W ':INSIDE-WIDTH))НЙ(MAX-Y-SIZE (SEND W ':INSIDE-HEIGHT)))Н (DO () ((SEND W ':TYI-NO-HANG) 'DONE)Н (WHEN (< (RANDOM 100) 1) (SEND W ':CLEAR-SCREEN))Н (WHEN DRAW-CIRCLESНЙ(SEND W ':DRAW-CIRCLEНЙ (RANDOM MAX-X-SIZE)НЙ (RANDOM MAX-Y-SIZE)НЙ (RANDOM 100)))Н (WHEN DRAW-STRINGSНЙ(SEND W ':SET-CURSORPOSНЙ (RANDOM MAX-X-SIZE)НЙ (RANDOM MAX-Y-SIZE))НЙ(SEND W ':STRING-OUT OUT-STRING))НЙ)))НН;;; Compile {hit Hyper-Control-C} and test again {hit Control-C Н;;; in the LISP Listener}.ННН;;; That is much more interesting. The function is getting a bitН;;; large however, so let's separate it into three functions, andН;;; make the "done" appear at the bottom of the screen. НН;;; In order to take out sections of code, place the mouse cursorН;;; at the left edge of the first line you want to take out. WithН;;; the left button held down, move the mouse cursor to the lastН;;; line you want to take out. The section of code should now beН;;; underlined. Without moving the mouse cursor, release the leftН;;; button. The code should stay underlined. НН;;; Type Control-W to delete the code from the original function.Н;;; The code is now on the kill ring. Move the mouse cursor toН;;; the new position for the code. Click the left button once. Н;;; Type Control-Y to put the code back into the buffer.НН;;; Then you have to check all of the parens to make them balanceН;;; in both the new function and the old. Do this for both DRAW-Н;;; CIRCLES and DRAW-STRINGS. Remember to put in function callsН;;; where the code used to be. Note that the DRAW-STRINGS is notН;;; called correctly. This is deliberate, to provide practice atН;;; making and fixing another error. The code now looks like:ННМ;;; LISP Programming LABН;;; Rapid PrototypingН;;; Page 9ННН(DEFUN DRAW-CIRCLES (W MAX-X-SIZE MAX-Y-SIZE)Н Й(SEND W ':DRAW-CIRCLEНЙ (RANDOM MAX-X-SIZE)НЙ (RANDOM MAX-Y-SIZE)НЙ (RANDOM 100)))ННН(DEFUN DRAW-STRINGS (W OUT-STRING MAX-X-SIZE MAX-Y-SIZE)НЙ(SEND W ':SET-CURSORPOSНЙ (RANDOM MAX-X-SIZE)НЙ (RANDOMНЙЙ(- MAX-Y-SIZE (* (SEND W ':LINE-HEIGHT) 2))))НЙ(SEND W ':STRING-OUT OUT-STRING))ННН(DEFUN DRFН (W &OPTIONAL (DRAW-CIRCLES T) (DRAW-STRINGS T)НЙ(OUT-STRING "LINDA"))Н (SEND W ':CLEAR-SCREEN)Н (SEND W ':SET-FONT-MAP '(FONTS:BIGFNT FONTS:CPTFONT))Н (SEND W ':SET-CURRENT-FONT 'FONTS:BIGFNT)Н (LET ((MAX-X-SIZE (SEND W ':INSIDE-WIDTH))НЙ(MAX-Y-SIZE (SEND W ':INSIDE-HEIGHT)))Н (DO () ((SEND W ':TYI-NO-HANG) 'DONE)Н (WHEN (< (RANDOM 100) 1)НЙ(SEND W ':CLEAR-SCREEN))Н (WHEN DRAW-CIRCLESНЙ(DRAW-CIRCLES W MAX-X-SIZE MAX-Y-SIZE))Н (WHEN DRAW-STRINGSНЙ(DRAW-STRINGS W MAX-X-SIZE MAX-Y-SIZE)))))НННН;;; Compile each of the new functions by putting the cursor inside,Н;;; then typing Control-Shift-C. While compiling DRF, we get theН;;; message that OUT-STRING is bound but never used. Here we canН;;; look at the function, and remember where we used OUT-STRING.Н;;; The logical place to examine is the code we removed and put inН;;; new functions. The function DRAW-STRINGS has more argumentsН;;; than we have supplied, so we fix that function call. We might Н;;; also go to the LISP Listener and call DRF, then get the errorН;;; that we supplied only three arguments where we needed four andН;;; go back to the code in the editor buffer to fix it. After weН;;; fix the code by adding the required parameter, in the correctН;;; position, to the call to DRAW-STRINGS, drf looks like:НННМ;;; LISP Programming LABН;;; Rapid PrototypingН;;; Page 10ННН(DEFUN DRFН (W &OPTIONAL (DRAW-CIRCLES T) (DRAW-STRINGS T)НЙ(OUT-STRING "LINDA"))Н (SEND W ':CLEAR-SCREEN)Н (SEND W ':SET-FONT-MAP '(FONTS:BIGFNT FONTS:CPTFONT))Н (SEND W ':SET-CURRENT-FONT 'FONTS:BIGFNT)Н (LET ((MAX-X-SIZE (SEND W ':INSIDE-WIDTH))НЙ(MAX-Y-SIZE (SEND W ':INSIDE-HEIGHT)))Н (DO () ((SEND W ':TYI-NO-HANG) 'DONE)Н (WHEN (< (RANDOM 100) 1)НЙ(SEND W ':CLEAR-SCREEN))Н (WHEN DRAW-CIRCLESНЙ(DRAW-CIRCLES W MAX-X-SIZE MAX-Y-SIZE))Н (WHEN DRAW-STRINGSНЙ(DRAW-STRINGS W OUT-STRING MAX-X-SIZE MAX-Y-SIZE)))))ННННН;;; This time it compiles all right, and tests all right.ННН;;; Now change the function to draw just circles, but to draw them Н;;; smaller and smaller, until they reach some minimum size. YouН;;; can make a new function from the existing functions by copyingН;;; and combining them, and modifying their behavior.НННН(DEFUN DRAW-RECURSIVE-CIRCLESН (W MAX-X-SIZE MAX-Y-SIZE FIGURE-SIZE)Н (COND ((< FIGURE-SIZE 1) 'DONE)НЙ(TНЙ (SEND W ':DRAW-CIRCLEНЙ (RANDOM MAX-X-SIZE)НЙ (RANDOM MAX-Y-SIZE)НЙ FIGURE-SIZE)НЙ (DRAW-RECURSIVE-CIRCLES W MAX-X-SIZE MAX-Y-SIZEНЙЙЙЙ (- FIGURE-SIZE 2)))))НН НН(DEFUN DRAW-RECURSIVELY (W FIGURE-SIZE)Н (SEND W ':CLEAR-SCREEN)Н (SEND W ':SET-FONT-MAP '(FONTS:BIGFNT FONTS:CPTFONT))Н (SEND W ':SET-CURRENT-FONT 'FONTS:BIGFNT)Н (LET ((MAX-X-SIZE (SEND W ':INSIDE-WIDTH))НЙ(MAX-Y-SIZE (SEND W ':INSIDE-HEIGHT))НЙ(BASE 10))Н (DRAW-RECURSIVE-CIRCLESН W MAX-X-SIZE MAX-Y-SIZE FIGURE-SIZE)))НННМ;;; LISP Programming LABН;;; Rapid PrototypingН;;; Page 11ННН;;; Unfortunately, this doesn't look much different than before,Н;;; probably because the circles are randomly drawn on the screen.Н;;; Try making them draw with the same center point, as follows:ННН(DEFUN DRAW-RECURSIVE-CIRCLESН (W MAX-X-SIZE MAX-Y-SIZE FIGURE-SIZE)Н Й(COND ((< FIGURE-SIZE 1) 'DONE)НЙ (TНЙ (SEND W ':DRAW-CIRCLEНЙЙ (// MAX-X-SIZE 2)НЙЙ (// MAX-Y-SIZE 2)НЙЙ FIGURE-SIZE)НЙ (DRAW-RECURSIVE-CIRCLESНЙЙ W MAX-X-SIZE MAX-Y-SIZE (- FIGURE-SIZE 2)))))ННН;;; This function illustrates recursion nicely. In order to seeН;;; the recursive action of the function, make a new window forН;;; drawing in. Do this by executing the following:ННН(SETQ FOO (MAKE-INSTANCE 'TV:WINDOW ':EDGES-FROM ':MOUSE))ННН;;; This makes a window, with edges defined via mouse clicks {lookН;;; for a left hand, and then a right hand corner mouse blinker}.Н;;; Position the window so that it covers the editor buffer, butН;;; not the Lisp Listener. ExecuteННН(SEND FOO ':EXPOSE)НН(TRACE DRAW-RECURSIVE-CIRCLES)НН(DRAW-RECURISVELY FOO 150)ННН;;; Every time DRAW-RECURSIVE-CIRCLES is executed, the call withН;;; its arguments are shown in the Lisp Listener, and a circle isН;;; drawn on the window foo. If you get a message that the PDL hasН;;; overflown, don't worry about it. Just hit . When youН;;; get tired of watching all the recursion, just hit . YouН;;; can also try more sophisticated tracing by going to the systemН;;; menu, clicking left on "Trace", typing DRAW-RECURSIVE-CIRCLESН;;; followed by a , then trying actions like "Break Before"Н;;; or "Break On". These options allow you to examine environmentsН;;; within each call to the function, then continue via .Н НН;;; When you are done with the demo, typeНН;;; -1 MНН;;; to turn "MORE Processing" back on.ННLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 3 :LENGTH-IN-BYTES 2933 :AUTHOR "wilde" :CREATION-DATE 2716346362 :QFASLP NIL :LENGTH 2933 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "SPACE-FLAVOR" :TYPE "LISP" :VERSION 4) НННННН;;; Flavor demos modified from "Lisp Machine Programming" by James M. TurnerН;; Copyright (C) 1985 LISP Machine, Incorporated.ННН;;; Define a flavor for the class of SPACE-OBJECTН(defflavor space-objectНЙ ((x-pos 0) (y-pos 0) (z-pos 0)НЙ (x-vel 0) (y-vel 0) (z-vel 0)НЙ (mass 0))Н ()Н :settable-instance-variablesН :gettable-instance-variablesН :inittable-instance-variables)Н;;; These keywords will create a group of machine-definedН;;; methods for getting, setting, and initializing Н;;; instance variables.ННН;;; Define a flavor for the class of SPACE-SHIP, which is built onН;;; the flavor SPACE-OBJECTН(defflavor space-shipНЙ ((x-thrust 0) (y-thrust 0) (z-thrust 0) (fuel 0) ship-name)НЙ (space-object)Н :settable-instance-variablesНЙ :gettable-instance-variablesНЙ :inittable-instance-variables)ННН;;; Inside a method, each instance variable is bound toН;;; its symbol name. Therefore, a variable such asН;;; X-POS can be used in the :MOVE method for SPACE-OBJECT.Н;;; It will have whatever value the particular instance hadН;;; when it was called. In addition, if the value is Н;;; changed here, the instance value is changed also.НН(defmethod (space-object :move) (time-fraction)Н (setq x-pos (+ x-pos (* x-vel time-fraction))НЙy-pos (+ y-pos (* y-vel time-fraction))НЙz-pos (+ z-pos (* z-vel time-fraction))))НН(defmethod (space-ship :before :move) (time-fraction)Н (if (plusp fuel)Н (setq x-vel (+ x-vel (* x-thrust time-fraction))НЙ y-vel (+ y-vel (* y-thrust time-fraction))НЙ z-vel (+ z-vel (* z-thrust time-fraction))НЙ fuel (- fuel (* mass (+ x-thrust y-thrust z-thrust))))))НН(defmethod (space-ship :after :move) (ignore)Н (format t "~%The Space Ship ~A is now at universal space position ~D:~D:~DНIts velocity is ~D:~D:~DНIts thrust is ~D:~D:~DНYou've got ~D units of fuel left~%"НЙ ship-name x-pos y-pos z-pos x-vel y-vel z-velНЙ x-thrust y-thrust z-thrust fuel))НМННННН;;; :INIT is a special method, defined by VANILLA FLAVOR.Н;;; It can be used with an :AFTER modifier to make methodsН;;; act on an instance immediately after it is created.Н(defmethod (space-ship :after :init) (&rest ignore)Н (if (not (variable-boundp ship-name))Н (setq ship-name "Name Me")))НН;;; Defining a new PRINT-SELF method will overwrite the Н;;; standard method provided in VANILLA FLAVOR for Н;;; printing the name of SPACE-SHIPН(defmethod (space-ship :print-self) (&rest ignore)Н (format t "#" ship-name))ННН(defflavor transport-mixinНЙ ((passengers 0) base-mass)НЙ ()Н (:required-flavors space-ship)Н :settable-instance-variablesН :inittable-instance-variables)НН(defmethod (transport-mixin :after :init) (&rest ignore)Н (setq base-mass mass))ННН(defmethod (transport-mixin :before :move) (&rest ignore)Н (setq mass (+ base-mass (* passengers 180.))))НН(defflavor space-linerНЙ ()НЙ (transport-mixin space-ship))ННLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 3 :LENGTH-IN-BYTES 2882 :AUTHOR "wilde" :CREATION-DATE 2725308345 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "SPACE-FLAVORS" :TYPE "LISP" :VERSION 1) НННННН;;; Flavor demos modified from "Lisp Machine Programming" by James M. TurnerНН;;; Define a flavor for the class of SPACE-OBJECTН(defflavor space-objectНЙ ((x-pos 0) (y-pos 0) (z-pos 0)НЙ (x-vel 0) (y-vel 0) (z-vel 0)НЙ (mass 0))Н ()Н :settable-instance-variablesН :gettable-instance-variablesН :inittable-instance-variables)Н;;; These keywords will create a group of machine-definedН;;; methods for getting, setting, and initializing Н;;; instance variables.ННН;;; Define a flavor for the class of SPACE-SHIP, which is built onН;;; the flavor SPACE-OBJECTН(defflavor space-shipНЙ ((x-thrust 0) (y-thrust 0) (z-thrust 0) (fuel 0) ship-name)НЙ (space-object)Н :settable-instance-variablesНЙ :gettable-instance-variablesНЙ :inittable-instance-variables)ННН;;; Inside a method, each instance variable is bound toН;;; its symbol name. Therefore, a variable such asН;;; X-POS can be used in the :MOVE method for SPACE-OBJECT.Н;;; It will have whatever value the particular instance hadН;;; when it was called. In addition, if the value is Н;;; changed here, the instance value is changed also.НН(defmethod (space-object :move) (time-fraction)Н (setq x-pos (+ x-pos (* x-vel time-fraction))НЙy-pos (+ y-pos (* y-vel time-fraction))НЙz-pos (+ z-pos (* z-vel time-fraction))))НН(defmethod (space-ship :before :move) (time-fraction)Н (if (plusp fuel)Н (setq x-vel (+ x-vel (* x-thrust time-fraction))НЙ y-vel (+ y-vel (* y-thrust time-fraction))НЙ z-vel (+ z-vel (* z-thrust time-fraction))НЙ fuel (- fuel (* mass (+ x-thrust y-thrust z-thrust))))))НН(defmethod (space-ship :after :move) (ignore)Н (format t "~%The Space Ship ~A is now at universal space position ~D:~D:~DНIts velocity is ~D:~D:~DНIts thrust is ~D:~D:~DНYou've got ~D units of fuel left~%"НЙ ship-name x-pos y-pos z-pos x-vel y-vel z-velНЙ x-thrust y-thrust z-thrust fuel))НМННННН;;; :INIT is a special method, defined by VANILLA FLAVOR.Н;;; It can be used with an :AFTER modifier to make methodsН;;; act on an instance immediately after it is created.Н(defmethod (space-ship :after :init) (&rest ignore)Н (if (not (variable-boundp ship-name))Н (setq ship-name "Name Me")))НН;;; Defining a new PRINT-SELF method will overwrite the Н;;; standard method provided in VANILLA FLAVOR for Н;;; printing the name of SPACE-SHIPН(defmethod (space-ship :print-self) (&rest ignore)Н (format t "#" ship-name))ННН(defflavor transport-mixinНЙ ((passengers 0) base-mass)НЙ ()Н (:required-flavors space-ship)Н :settable-instance-variablesН :inittable-instance-variables)НН(defmethod (transport-mixin :after :init) (&rest ignore)Н (setq base-mass mass))ННН(defmethod (transport-mixin :before :move) (&rest ignore)Н (setq mass (+ base-mass (* passengers 180.))))НН(defflavor space-linerНЙ ()НЙ (transport-mixin space-ship))ННLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 1 :LENGTH-IN-BYTES 792 :AUTHOR "SAM" :CREATION-DATE 2716748991 :QFASLP NIL :LENGTH 792 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "STREAMS" :TYPE "LISP" :VERSION 1) ;;; -*- Mode:LISP; Readtable:COMMON-LISP; Base:10 -*-Н#|НН (C) COPYRIGHT 1986 LISP Machine, IncorporatedН All Rights ReservedНН___________________________________________________________________________Н|#НН;;; Samuel F. PilatoНННН;;;;STREAMSНН(provide 'streams)ННН(defmacro make-empty-stream () `nil)Н(defmacro empty-stream-p (stream) `(null ,stream))Н(defmacro cons-stream (next rest) `(cons ,next ,rest))Н(defmacro next-in-stream (stream) `(car ,stream))Н(defmacro rest-of-stream (stream) `(cdr ,stream))НН(defmacro stream-of (element) `(cons-stream ,element (make-empty-stream)))НН(defun merge-streams (stream1 stream2)Н (if (empty-stream-p stream1)Н stream2Н (cons-stream (next-in-stream stream1)НЙЙ (merge-streams stream2 (rest-of-stream stream1)))))НLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 37 :LENGTH-IN-BYTES 37660 :AUTHOR "ngl" :CREATION-DATE 2659445493 :QFASLP NIL :LENGTH 37660 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "TEACH-ZMACS" :TYPE "TEXT" :VERSION 1) -*- Mode:Fundamental; Fonts:(HL12 HL12B HL12BI CPTFONT) -*-ННYou are looking at the ZMacs tutorial. Comments on this document should beНsent to Mark Dulcey at LMI.ННZMacs is the editor used on the Lisp Machine. It is based on ZWEI, an editingНsubsystem. Certain other programs on the Lisp Machine, such as ZMail andНConverse, also use ZWEI. When you are editing text in these programs, it willНbe with the same commands documented here. They also have other commandsНof their own. Lisp Listeners have a 2rubout handler* which implements someНsimple editing commands which are like ZMacs commands; type 1Help* in a LispНListener to find out exactly what is available there.ННZMacs commands generally involve the 1Control* key or the 1Meta* key. Rather thanНwrite out 1Meta* or 1Control* each time we want you to prefix a character, we'll useНthe following abbreviations:ННЙ1C-2char**Йmeans hold the 1Control* key while typing the character 2char*.НЙЙЙThus, 1C-F* would be: hold the 1Control* key and type 1F*. Do not НЙЙЙhold down the1 Shift* key. (Having 1Caps Lock* down is OK.)Н Й1M-2char**Йmeans hold the 1Meta* key down while typing 2char*.НЙ1C-M-2char**Йmeans hold both the 1Control* key and the 1Meta* key down whileНЙЙЙtyping 2char*.НЙ1C-Sh-2char**Йmeans hold both the 1Control* key and the 1Shift* key down whileНЙЙЙtyping 2char*.ННImportant note: if you must exit at some point, you can use the 1System* key toНtake you elsewhere. 1System* 1E* will get you back here. If you leave this tutorialНand return to it in another session, 1System E* followed by 1M-X* 1Teach ZMacs* willНreload the tutorial. (This will load the same private copy that you used last time;Нif you saved any changes to it, those changes will still be there.)ННThe characters "1>>*" at the left margin indicate directions for you to try using aНcommand.ННThe first thing that you need to know is how to move around from place to placeНin the file. 1C-V *moves you forward to the next screen of text. 1M-V* takes youНback to the previous screen.НН1>>*ЙNow type 1C-V* (1Next Screen*) to move to the next screen.НЙ(go ahead, do it by depressing the 1Control* key and 1V* together). Then typeНЙ1M-V *to get back here.ННFrom now on, you'll be expected to do this whenever you finish reading theНscreen.ННNote that there is an overlap when going from screen to screen; this providesНsome continuity when moving through the file.ННН2SUMMARY*ННThe following commands are useful for viewing screenfuls:ННЙ1C-V*ЙMove forward one screenfulНЙ1M-V*ЙMove backward one screenfulНЙ1C-L*ЙClear screen and redisplay everything putting the textНЙЙnear the cursor at the center. НН1>>*ЙFind the cursor and remember what text is near it.НЙThen type a 1C-L*.НЙFind the cursor again and see what text is near it now.ННН2BASIC CURSOR CONTROL*ННGetting from screenful to screenful is useful, but how do you reposition yourselfНwithin a given screen to a specific place? There are several ways you can doНthis. One way (not the best, but the most basic) is to use the commandsНprevious, backward, forward and next. As you can imagine these commandsН(which are given to ZMacs as 1C-P*, 1C-B*, 1C-F*, and 1C-N* respectively) move theНcursor from where it currently is to a new place in the given direction. Here, in aНmore graphical form are the commands:Н НЙЙЙ Previous line, 1C-P*НЙЙЙЙ :НЙЙЙЙ :Н Backward, 1C-B* .... Current cursor position .... Forward, 1C-F*НЙЙЙЙ :НЙЙЙЙ :НЙЙЙ Next line, 1C-N*ННYou'll probably find it easy to think of these by letter. 1P* for previous, 1N* forНnext, 1B* for backward and 1F* for forward. These are the basic cursor positioningНcommands and you'll be using them ALL the time so it would be of great benefit ifНyou learn them now.НН1>>*ЙDo a few 1C-N*'s to bring the cursor down to this line.НН1>>*ЙMove into the line with 1C-F*'s and then up with 1C-P*'s.НЙSee what 1C-P* does when the cursor is in the middle of the line.ННLines are separated by a 1Return* character.НН1>>*ЙTry to 1C-B* at the beginning of a line. Do a few more 1C-B*'s.НЙThen do 1C-F*'s back to the end of the line and beyond.ННWhen you go off the top or bottom of the screen, the text beyond the edge isНshifted onto the screen so that your instructions can be carried out while keepingНthe cursor on the screen.НН1>>*ЙTry to move the cursor off the bottom of the screen with 1C-N* andНЙsee what happens.ННIf moving by characters is too slow, you can move by words. 1M-F* movesНforward a word and 1M-B* moves back a word.НН4>>*ЙType a few 1M-F*'s and 1M-B*'s. Intersperse them with 1C-F*'s and 1C-B*'s.ННNotice the parallel between 1C-F* and 1C-B* on the one hand, and 1M-F* and 1M-B* onНthe other hand. Very often 1Meta* characters are used for operations related toНEnglish text whereas 1Control* characters operate on the basic textual units thatНare independent of what you are editing (characters, lines, etc). There is a similarНparallel between lines and sentences: 1C-A* and 1C-E* move to the beginning or endНof a line, and 1M-A* and 1M-E* move to the beginning or end of a sentence.НН1>>*ЙTry a couple of 1C-A*'s, and then a couple of 1C-E*'s.НЙTry a couple of 1M-A*'s, and then a couple of 1M-E*'s.ННSee how repeated 1C-A*'s do nothing, but repeated 1M-A*'s keep moving farther. DoНyou think that this is right?ННTwo other simple cursor motion commands are 1M-<*, which moves to theНbeginning of the file, and 1M->*, which moves to the end of the file. You probablyНdon't need to try them, since finding this spot again will be boring.ННThe location of the cursor in the text is also called "point". To paraphrase, theНcursor shows on the screen where point is located in the text.ННHere is a summary of simple moving operations including the word and sentenceНmoving commands:ННЙ1C-F*ЙMove forward a characterНЙ1C-B*ЙMove backward a characterННЙ1M-F*ЙMove forward a wordНЙ1M-B*ЙMove backward a wordННЙ1C-N*ЙMove to next lineНЙ1C-P*ЙMove to previous lineННЙ1C-A*ЙMove to beginning of lineНЙ1C-E*ЙMove to end of lineННЙ1M-A*ЙMove back to beginning of sentenceНЙ1M-E*ЙMove forward to end of sentenceННЙ1M-<*ЙGo to beginning of fileНЙ1M->*ЙGo to end of fileНН1>>*ЙTry all of these commands now a few times for practice.НЙSince the last two will take you away from this screen,НЙyou can come back here with 1M-V*'s and 1C-V*'s. These areНЙthe most often used commands.ННLike all other commands in ZMacs, these commands can be given arguments whichНcause them to be executed repeatedly. The way you give a command a repeatНcount is by holding down the 1Control* key, the 1Meta* key, or both, while typingНdigits; then type the command.ННFor instance, 1C-8* 1C-F* moves forward eight characters.НЙН1>>*ЙTry giving a suitable argument to 1C-N* or 1C-P* to come as closeЙНЙas you can to this line in one jump.ННTwo exceptions to this is the screen moving commands, 1C-V* and 1M-V*. WhenНgiven an argument, they scroll the screen up or down by that many lines, ratherНthan screenfuls.НН1>>*ЙTry typing 1C-8* 1C-V* now.ННDid it scroll the screen up by 8 lines? If you would like to scroll it down you canНgive an argument to 1M-V*.ННAnother exception is the redisplay comand 1C-L*. When given an argument, itНcauses the line where the cursor is located to be displayed that many lines fromНthe top of the screen.НН1>>*ЙMove the cursor to this line, then try try typing 1C-0 C-L*. This lineНЙshould move to the top of the screen.НН2WHEN ZMacs IS HUNG*ННIf ZMacs gets into an infinite (or simply very long) computation which you don'tНwant to finish, you can stop it safely by typing 1C-Abort*. You can also useН1C-Abort* to discard a numeric argument or the beginning of a command that youНdon't want to finish. (If the long computation was a Fill command or some similarНcommand which moves text around in the buffer, the buffer may be left partiallyНmodified.)Н3 Н1>>**ЙType 1C-100* to make a numeric arg of 100, then type 1C-Abort*.НЙNow type 1C-F*. How many characters does it move?ННН2INSERTING AND DELETING*ННIf you want to type text, just do it. Characters which you can see, such as 1A*, 17*,Н1**, etc. are taken by ZMacs as text and inserted immediately. Type 1Return* toНinsert a line separator.ННYou can delete the last character you typed by typing 1Rubout*. 1Rubout* is a keyНon the keyboard.1 *More generally, 1Rubout* deletes the character immediately beforeНthe current cursor position. (The Delete key doesn't delete anything. In fact, itНdoesn't do anything at all!)НН1>>*ЙDo this now, type a few characters and then delete themНЙby typing 1Rubout* a few times. Don't worry about this fileНЙbeing changed; you won't affect the master tutorial. This is justНЙa copy of it.НН1>>*ЙNow start typing text until you reach the right margin, and keepНЙtyping. When a line of text gets too big for one line on theНЙscreen, the line of text is "continued" onto a second screen line.НЙThe exclamation mark at the right margin indicates a line which hasНЙbeen continued.НН1>>*ЙUse 1Rubout*s to delete the text until the line fits on one screenНЙline again. The continuation line goes away.НН1>>*ЙMove the cursor to the beginning of a line and type 1Rubout*. ThisНЙdeletes the line separator before the line and merges the line ontoНЙthe previous line. The resulting line may be too long to fit, inНЙwhich case it has a continuation line.НН1>>*ЙType 1Return* to insert the separator again.ННRemember that most ZMacs commands can be given a repeat count; Note thatНthis includes characters which insert themselves.НН1>>*ЙTry that now -- type 1C-8* 1** and see what happens.ННYou've now learned the most basic way of typing something in ZMacs andНcorrecting errors. You can delete by words or lines as well. Here is a summaryНof the delete operations:ННЙ1Rubout*ЙЙdelete the character just before the cursorНЙ1C-D*ЙЙdelete the next character after the cursorННЙ1M-Rubout*Йkill the word immediately before the cursorНЙ1M-D*ЙЙkill the next word after the cursorННЙ1C-K*ЙЙkill from the cursor position to end of lineНЙ1M-K*ЙЙkill to the end of the current sentenceННNotice that 1Rubout* and 1C-D* vs 1M-Rubout* and 1M-D* extend the parallel started byН1C-F* and 1M-F* (well, 1Rubout* isn't 2really* a control character, but let's not worryНabout that). 1C-K* and 1M-K* are like 1C-E* and 1M-E*, sort of, in that lines areНopposite sentences.ННNow suppose you kill something, and then you decide that you want to get itНback? Well, whenever you kill something bigger than a character, ZMacs saves itНfor you. To yank it back, use 1C-Y*. Note that you don't have to be in the sameНplace to do 1C-Y*; This is a good way to move text around. Also note that theНdifference between 2Killing* and 2Deleting* something is that 2Killed* things can beНyanked back, and 2Deleted* things cannot. (However, 2anything* can be undone;Нsee the section 2Undoing changes*) Generally, the commands that can destroy aНlot of text save it, while the ones that attack only one character, or nothing butНblank lines and spaces, do not save.ННFor instance, type 1C-N* a couple times to postion the cursor at some line on thisНscreen.НН1>>*ЙDo this now, move the cursor and kill that line with 1C-K*.ННNote that a single 1C-K* kills the contents of the line, and a second 1C-K* kills theНline itself, and make all the other lines move up. If you give 1C-K* a repeat count,Нit kills that many lines AND their contents.ННThe text that has just disappeared is saved so that you can retrieve it. ToНretrieve the last killed text and put it where the cursor currently is, type 1C-Y*.НН1>>*ЙTry it; type 1C-Y* to yank the text back.ННThink of 1C-Y* as if you were yanking something back that someone took awayНfrom you. Notice that if you do several 1C-K*'s in a row the text that is killed isНall saved together so that one C1-Y *will yank all of the lines.НН1>>*ЙDo this now, type 1C-K* several times.ННNow to retrieve that killed text:НН1>>*ЙType 1C-Y*. Then move the cursor down a few lines and type 1C-Y*НЙagain. You now see how to copy some text.ННWhat do you do if you have some text you want to yank back, and then you killНsomething else? 1C-Y* would yank the more recent kill. But the previous text isНnot lost. You can get back to it using the 1M-Y* command. After you have doneН1C-Y* to get the most recent kill, typing 1M-Y* replaces that yanked text with theНprevious kill. Typing 1M-Y* again and again brings in earlier and earlier kills. WhenНyou have reached the text you are looking for, you can just go away and leave itНthere. If you are using System 98 or greater, all kills made diring an entireНsession are permanently recorded; in earlier system versions, only the mostНrecent 8 kills are retained.НЙН1>>*ЙKill a line, move around, kill another line. Then do 1C-Y* to get backНЙthe second killed line. Then do 1M-Y* and it will be replaced by theНЙfirst killed line. Do more 1M-Y*'s and see what you get. Keep doingНЙthem until the second kill line comes back, and then a few more. IfНЙyou like, you can try giving 1M-Y* positive and negative arguments.ННН2THE MOUSE*ННThe 2Mouse *(the little white or beige box with three buttons on top which isНconnected to your keyboard or monitor by a cable) can be used to performНvarious functions in ZMacs.ННThe 2Mouse Cursor* tells you where the mouse is currently pointing. It is anНarrow which points North-North-East while ZMacs is running. If you move theНmouse, the pointer moves around the screen. Also, if you point the mouse at aНcharacter (rather than at empty screen), the character is 2highlighted* byНsurrounding it with a box.НН1>>*ЙRoll the mouse around. Watch the mouse cursor move around the screen,НЙand how characters are highlighted when you point at them.ННYou can move the position of the cursor by clicking the left mouse button once.НThe cursor moves to wherever the mouse cursor is. Clicking the left buttonНtwice rapidly performs the inverse operation; the mouse cursor moves to meetНthe cursor.НН1>>*ЙTry moving around the cursor and the mouse cursor with mouse clicks.ННThe mouse can also be used to 2scroll* the text in your buffer (the same thingНthat comands like 1C-V* do). If you move the mouse to the upper right corner ofНthe screen, you will notice that the mouse cursor changes to a fat arrow. RollingНthe mouse toward the top of the screen here will let you see more text at theНtop of the screen. Similarly, moving the mouse to the lower right corner will letНyou see more text at the bottom.НН1>>*ЙMove the text around a bit with the mouse now.ННMoving the mouse to the left side of the screen allows various other sorts ofНscrolling. The mouse cursor will change to a fat double-ended arrow to indicateНthis. Clicking the left button will move the line pointed at to the top of theНscreen. Clicking the right button will move the line which is at the top of theНscreen to the location where the mouse cursor is. Note that a left click willНundo the effect of a right click, and vice versa, if you do not move the mouseН(and you did not reach the beginning or the end of the buffer).НН1>>*ЙMove up and down the screen with left-side clicks.ННН2UNDOING CHANGES*ННSometimes you may make a change to a file that you decide you really don't likeНafter all. Or perhaps you accidentally typed an unfamiliar command, and youНdon't know what it was! All is not lost; you can easily 2undo* your change to yourНtext. The command 1C-Sh-U* (1Quick Undo*) will remove the most recent change youНmade to the buffer, restoring it to its previous state. The cursor is also movedНto the position of the undone change, so you can see what it was. (Any numberНof characters inserted and/or deleted without moving the cursor are considered aНsingle change. Certain other simple changes are also combined.) All the changesНyou made since the last time you saved the file are remembered; typing moreН1C-Sh-U* commands will undo changes in reverse order until no more are left.ННIf you undo a change, and decide you really liked the changed version better, allНis 2still* not lost! You can 2redo* any changes you previously undid with theНcommand 1C-Sh-R* (1Quick Redo*); this puts your change back into the buffer. IfНyou don't like it after all, you can always undo it again.ННThere are also extended commands available for undoing and redoing. The 1M-XНUndo* command will tell what it is about to undo, and ask whether you want toНundo it or not. Similarly, the 1M-X Redo* command will tell you what it is about toНredo. (I find it easier to just go ahead and undo the change quickly and look atНthe new state; it's easy to redo it if you don't like that.)НН1>>*ЙMake some changes to this buffer. Undo and redo them.ННН2FILES*ННIn order to make the text you edit permanent, you must put it in a file.НOtherwise, it will go away when your invocation of ZMacs goes away. You putНyour editing in a file by 2finding* the file. What finding means is that you see theНcontents of the file in your ZMacs; and, loosely speaking, what you are editing isНthe file itself. However, the changes still don't become permanent until you 2save*Нthe file. This is so you can have control to avoid leaving a half-changed fileНaround when you don't want to. If you are using a host which supports versionНnumbers for files (such as the Lisp Machine File System, the LMFILE system, ITS,НTOPS-20, or VAX-VMS), saving will create a new version of your file; theНoriginal will still be intact until you delete it. ННIf you look near the botton of the screen you will see a line that starts withН"ZMACS (Fundamental) TEACH-ZMACS.TEXT ; LAM1:" (if youНare logged in to LAM1. (The form of the name may be different if you are loggedНin to a different host.) This is the name of your own copy of the text of theНZMacs tutorial; the file you are now looking at. Whatever file you find, that file'sНname will appear in that precise spot.ННThe commands for finding and saving files are unlike the other commands youНhave learned in that they consist of two characters. They both start with theНcharacter 1Control-X*. There is a whole series of commands that start withН1Control-X*; many of them have to do with files, buffers, and related things, and allНof them consist of 1Control-X* followed by some other character. (Control-XНcommands will be written in the form 1C-X Q* in the rest of this document.)ННAnother thing about the command for finding a file is that you have to say whatНfile name you want. We say the command "reads an argument from the terminal"Н(in this case, the argument is the name of the file). After you type theНcommandННЙ1C-X* 1C-F*ЙFind FileННZMacs will ask you for the file name. You should end the name with the ReturnНkey. This command will read the file into its own new buffer. (If you use Find FileНon a file which is already in your ZMacs, you will simply be switched to thatНbuffer; the file is not read in again.) After this command, you will see theНcontents of the file in your ZMacs. You can edit the contents. When you wishНto make the changes permanent, issue the commandННЙ1C-X C-S*ЙSave FileННThe file will be saved. If the host file system supports version numbers, a newНversion of the file will be created. When the operation is finished, ZMacsНprints the name and version saved. You should save fairly often, so that you willНnot lose very much work if your Lisp Machine should crash. (If the hostНcomputer crashes, you can simply wait for it to work again, then retry the save.)ННЙ1C-X C-W*ЙWrite FileННThis causes the buffer to be written out to a file, like Save File does. TheНdifference is that you will be asked for a name to write it under. This lets youНput your new text in a different place from the original. (This is especiallyНuseful if your host does not support version numbers!) The buffer will also beНrenamed to the new file name, so any subsequent Save File commands will alsoНoutput to the new file.Н НTo make a new file, just find it "as if" it already existed. Then start typing inНthe text. When you ask to save the file, ZMacs will really create the file withНthe text that you have inserted. From then on, you can consider yourself to beНediting an already existing file.НН1>>*ЙTry finding a new file now. (The name will depend on which host you areНЙlogged into.) Put some text into it, and save it. When you are done, you canНЙcome back here with 1C-M-L*. (More generally, 1C-M-L* returns you to theНЙbuffer you were editing most recently before the current one.)ННН2EXTENDING THE COMMAND SET*ННThere are many, many more ZMacs commands than could possibly be putНon all the control and meta characters. ZMacs gets around this withНthe 1X* (2eXtend*) command. This comes in two flavors:ННЙ1C-X*ЙCharacter 2eXtend*. Followed by one character.НЙ1M-X*ЙNamed command 2eXtend*. Followed by a long name.ННThese are commands that are generally useful but used less than the commandsНyou have already learned about. You have already seen two of them: the fileНcommands 1C-X* 1C-F* to Find and 1C-X* 1C-S* to Save. ННThere are many 1C-X* commands. The ones you need immediately are:ННЙ1C-X* 1C-F*ЙЙFind file.НЙ1C-X* 1C-S*ЙЙSave file.НЙ1C-X C-W*ЙЙWrite file.ННNamed extended commands are commands which are used even lessНfrequently, or commands which are used only in certain modes. TheseНcommands are usually called 2functions*. An example is the functionН1Replace String*, which globally replaces one string with another. WhenНyou type 1M-X*, ZMacs prompts you at the bottom of the screen withН1M-X* and you should type the name of the function you wish to call; inНthis case, 1Replace String*. Just type "1REPL*" and ZMacs willНcomplete the name. You will be prompted for the string to replace; type itНfollowed by 1Return*. Then you will be prompted for the new string; type itНfollowed by 1Return*.НН1>>*ЙMove the cursor to the blank line two lines below this one.НЙThen type 1M-X* 1replchangedaltered*.ННNotice how this line has changed: you've replaced the word 1changed* with 1altered*Нwherever it occurs after the cursor.ННН2MODE LINE*ННIf ZMacs sees that you are typing commands slowly it shows them to you at theНbottom of the screen in an area called the echo area. The echo area containsНthe bottom three lines of the screen. The line immediately above them is calledНthe 2mode line*. The mode line says something likeННЙZMACS (Modename) Filename (ver) Font: A (fontname) 3 **ННYou already know what the filename means -- it is the file you have found.1 *TheНstar at the very end of the mode line means that you have made changes to theНtext. Right after you find or save a file, there is no star.ННThe font information is displayed only if the file you are editing contains moreНthan one font. It tells what the current 2default font* is. See the section onН2Using multiple fonts* for more information on this.ННThe arrows just before the star at the end of the mode line indicate whetherНthere is more text in the buffer above and below the current screen. If theНup-arrow appears, there is more text before the current screen. If theНdown-arrow appears, there is more text after the current screen. If both appear,Нthere is more both before and after; if neither appears, the present screen is allНthere is.НН1>>*ЙMove the the beginning and the end of this buffer; watch the "more text"НЙindicators change.ННThe part of the mode line inside the first set ofparentheses is to tell you whatНmodes you are in. (The default mode is Lisp, unless the type field in the fileНname causes a different default to be used; for example, any filename with a typeНof 2TEXT* will be edited in Text Mode by default if it has no attributes list.НHowever, a file may specify which mode it likes in an Attributes List. ThisНappears as the first line of the file. This file specifies Fundamental mode.) It isНan example of a 2major mode*. There are several major modes in ZMacs forНediting different languages and text, such as LISP mode, Text mode, etc. At anyНtime one and only one major mode is active, and its name can always be found inНthe mode line just where "Fundamental" is now. Each major mode makes a fewНcommands behave differently. For example, there are commands for creatingНcomments in a program, and since each programming language has a different ideaНof what a comment should look like, each major mode has to insert commentsНdifferently. Each major mode is the name of an extended command, which is howНyou get into the mode. For example, 1M-X Lisp* 1Mode* is how to get into LispНmode.ННIf you are going to edit English language text, you should use Text mode.НН1>>*ЙType 1M-X Text Mode* to get to Text mode. Notice how the mode line changes.ННDon't worry, none of the commands you have learned changes ZMacs in anyНgreat way. Major modes are usually like that: commands don't change intoНcompletely unrelated things, but they work a little bit differently. Lisp Mode addsНcommands appropriate to editing Lisp programs. Text Mode causes underscoreН(3_*) and quote (') characters to be considered part of words.ННMajor modes are called major because there are also 2minor modes*. They areНcalled minor because they aren't alternatives to the major modes, just minorНmodifications of them. Each minor mode can be turned on or off by itself,Нregardless of what major mode you are in, and regardless of the other minorНmodes. So you can use no minor modes, or one minor mode, or anyНcombination of several minor modes.ННOne minor mode which is very useful, especially for editing English text, is AutoНFill mode. When this mode is on, ZMacs breaks the line in between wordsНautomatically whenever the line gets too long. You can turn this mode on byНdoing 1M-X Auto Fill Mode*. When the mode is on, you can turn it off by doingН1M-X Auto Fill Mode*. If the mode is off, this function turns it on, and if the modeНis on, this function turns it off. This is called 2toggling*.НН1>>*ЙType 1M-X Auto Fill Mode* now. Then insert a line of "asdf "НЙover again until you see it divide into two lines. You must put inНЙspaces between them because Auto Fill breaks lines only at spaces.НЙNotice that "Fill" appears in the mode line in addition to the nameНЙof the major mode, not instead of it.ННThe margin is usually set at 576 pixels (dots on the screen), but you can changeНit with the 1C-X* 1F* command. You move the cursor where you want the fill columnНto be, then type 1C-X* 1F*. You can also give 1C-X* a numeric argument. If it lessНthan 200., it specifies the fill column in characters. An argument >= 200. specifiesНa fill column in pixels. НН1>>*ЙMove the cursor to column 20 (or thereabouts) and type 1C-X F*. Then typeНЙsome lines and watch ZMacs fill them.НН1>>*ЙSet the fill column back to its original value by typing 1C-X F* with an argumentНЙof 1576*.ННН2SEARCHING*ННZMacs can do 2searches* for strings (these are groups of contiguous charactersНor words) either forward through the file or backward through it. To search forНthe string means that you are trying to locate it somewhere in the file and haveНZMacs show you where the occurrences of the string exist. This type ofНsearch is somewhat different from what you may be familiar with. It is a searchНthat is performed as you type in the thing to search for. The command toНinitiate a search is 1C-S* for forward search, and 1C-R* for reverse search. 2BUTНWAIT!* Don't do them now. When you type 1C-S* you'll notice that the stringН"I-search" appears as a prompt in the echo area. This tells you that ZMacs is inНwhat is called an 2incremental search* waiting for you to type the thing thatНyou want to search for. 1Altmode* terminates a search.НЙН1>>*ЙNow type 1C-S* to start a search. 2Slowly*, one letter at a time, type the wordНЙ1cursor*, pausing after you type each character to notice what happens to theНЙcursor.НН1>>*ЙType 1C-S* to find the next occurrence of 1cursor*.НН1>>*ЙNow type 1Rubout* four times and see how the cursor moves.НН1>>*ЙType 1Altmode* to terminate the search.ННDid you see what happened? ZMacs, in an incremental search, tries to go toНthe occurrence of the string that you've typed out so far. To go to the nextНoccurrence of 'cursor' just type 1C-S* again. If no such occurrence exists ZMacsНbeeps and tells you that it is a failing search.ННIf you are in the middle of an incremental search and type 1Rubout*, you'll noticeНthat the last character in the search string is erased and the search backs up toНthe last place of the search. For instance, suppose you currently have typedН1cu* and you see that your cursor is at the first occurrence of 1cu*. If you nowНtype 1Rubout*, the 1u* on the search line is erased and you'll be repositioned in theНtext to the occurrence of 1c* where the search took you before you typed the 1u*.НThis provides a useful means for backing up while you are searching.ННIf you are in the middle of a search and happen to type a control characterН(other than a 1C-S* or 1C-R*, which tell ZMacs to search for the next occurrenceНof the string, or a 1C-Q*, which can be used to input certain 1Top* and 1Greek*Нcharacters for compatibility with certain other systems), the search isНterminated, and the character is executed. 1Abort* will simply end the search, likeН1Altmode*.ННThe 1C-S* starts a search that looks for any occurrence of the search stringН2after* the current cursor position. But what if you want to search forНsomething earlier in the text? To do this, type 1C-R* for Reverse search.НEverything that applies to 1C-S* applies to 1C-R* except that the direction of theНsearch is reversed.ННН2GETTING MORE HELP*ННIn this tutorial we have tried to supply just enough information toНget you started using ZMacs. There is so much available in ZMacs thatНit would be impossible to explain it all here. However, you may wantНto learn more about ZMacs since it has numerous desirable featuresНthat you don't know about yet. ZMacs has a great deal of internalНdocumentation. All of these commands can be accessed through the 1Help*Нcharacter.ННTo use the 2Help* features, type 1Help*, and then a character saying what kind ofНhelp you want. If you are 2really* lost, type 1Help* 1Help* and ZMacs will tell youНwhat kinds of help it can give. If you have typed the 1Help* character and decideНyou don't want any help, just type 1Abort* to abort.ННThe most basic Help feature is 1Help* C. Type 1Help*, a 1C*, and a commandНcharacter, and ZMacs prints a description of the command. When you areНfinished reading it, type a 1Space* or an= 1Abort** to bring your text back on theНscreen.НН>>ЙType 1Help* 1C* 1Control-P*. When you are finished reading the output,НЙtype a 1Space*. The message should be something likeН1 *НЙControl-P is Up Real Line, implemented by COM-UP-REAL-LINE:НЙMove up vertically to previous real line.НЙMoves as far as possible horizontally toward the goal column for successiveНЙcommands.ННThe "name of the function" is important for people who are customizing ZMacs.НIt is what appears in the ZMacs Chart as the documentation for the commandНcharacter. For now you can ignore it.ННMulti-character commands such as 1C-X* 1C-F* are also allowed after 1Help* 1C*.ННHere are some other useful 1Help* options:НН 1Help* 1D*ЙDescribe a function. You type in the name of theНЙЙfunction. To see your text again when it is done,НЙЙtype a 1Space* or 1Abort*.НН1>>*ЙTry typing 1Help* 1D Replace String*. Then type a1 Space* when you areНЙfinished reading it.НН 1Help* 1A*ЙApropos. Type in a keyword and ZMacs will listНЙЙall the functions containing that keyword. For someНЙЙfunctions it will also list a one or two characterНЙЙcommand which has the same effect.НН1>>*ЙType 1Help* 1A File*. You will see a list of all functions (1M-X* commands)НЙwith "file" in their names. You will also see commands like 1C-X* 1C-F* and 1C-X*НЙ1C-S*, listed under the corresponding function names. When it says "**MORE**"НЙat the bottom of the screen, type a 1Space* to see the rest of the list, orНЙ1Abort* to abort the rest of the listing.НН 1Help L *This tells you what the last 60. characters you typed were. If youНЙ don't know what you did to make something happen, this can beНЙ useful.ННН2USING MULTIPLE FONTS*ННOne of the things which you surely noticed about this file is the use of multipleНtypefaces, or 2fonts*, for various things in the file. Using multiple fonts can makeНyour document much more readable. Also, if you are using the LMI printerНsoftware with an appropriate printer, your files can be printed in multiple fonts.ННThe first thing you must do when you create your file is use the 1M-X Set Fonts*Нcommand. This lets you name the fonts you want to use in your file. You typeНthe font names you want, separated by spaces. The order is significant; we willНget to that in a moment. After you type the fonts, you will be asked "ChangeНthe -*- line of the file as well?". You should answer 1Y* to this question. ThisНcauses a 2File attribute list* to be created (or updated, if the file already hasНone) at the top of the file. (This file has one, for example; it specifies the fourНfonts which are used in this file, and specifies Fundamental Mode as the mode inНwhich the file should be edited. If your file is being edited in Lisp Mode, theНattribute list will be put inside a comment, so it will not affect your program.НН1>>*ЙMove to the top of the file and look at the attribute list.ННThis document uses four fonts: 2HL12* (Helvetica 12 point) is used for the mainНtext of the file. 2HL12B* (Helvetica 12 point bold) is used for ZMacs commandsНand character names. 2HL12BI* (Helvetica 12 point bold italic) is used for sectionНheadings and for emphasis in the text; 2CPTFONT* (named after a brand ofНmonitor used on early Lisp Machines) is used for characters (like the up and downНarrows and underscores) which do not exist in some of the other fonts. ThereНare many other fonts available; the command 1M-X List Fonts* will tell you whatНthey all are, and clicking the mouse on one of the font names displayed by thatНcommand will allow you to see what a font looks like. If you give the 1List Fonts*Нcommand a numeric argument, it will list fonts on the system directory (SYS:НFONTS;) in addition to the fonts that are already loaded. Note that a few of theНfonts contain special symbols like arrows; these are not intended for normal text.НThese special fonts are used for such things as the mouse cursor. (2MOUSE* andН2NARROW* are examples of special fonts.) 2CPTFONT* is the default font for mostНwindows on the Lisp Machine, and the wholine is always displayed in that font.ННIf you want to type a number of things in a new font, the 1C-M-J* (1Change* 1DefaultНFont*) command is what you are looking for. This changes the 2default font*; thatНis, the font which will be used for any new characters which are typed into theНbuffer. You specify the new font by giving a letter; font A is the first font inНthe attribute list, font B is the second one, and so on. When the file is first readНin, font A will be the default font, so it should be the font most often used.НН1>>*ЙChange the default font to 1B* (1HL12B*). Type some text.ННThere are also various commands for changing the font of text which is alreadyНin the buffer. 1C-J* (1Change Font Char*) changes the font of one character at aНtime (or the number of characters specified by an argument). You will beНaskedfor a font to use in the same way as in 1C-M-J. *If you give successiveН1C-J* commands without moving the cursor, you will not be asked for the new fontНafter the first one; it is assumed that you want to continue changing charactersНto the same font. (If that is not what you want, simply move the cursor aНcharacter forward, move it back, then proceed with the 1C-J* command.НН1M-J* (1Change Font Word*) lets you change the font of existing text one word at aНtime. It is otherwise similar to 1C-J*. 1C-X C-J* (1Change Font Region*) changes theНfont of all the characters in the region.ННН2CONCLUSION*ННRemember, to exit, use the 1System* key. (1System* 1Help* will tell you what systemНcommands are accepted.) Make sure to save any files you need saved beforeНexiting.ННUnfortunately, there is no ZMacs manual yet. You may, however, find anНEMACS manual to be useful. Most of the commands documented there alsoНwork in ZMacs.ННThis tutorial is meant to be understandable to all new users, so ifНyou found something unclear, don't sit and blame yourself - complain!НLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 12 :LENGTH-IN-BYTES 12014 :AUTHOR "pace" :CREATION-DATE 2669619061 :QFASLP NIL :LENGTH 12014 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "TURTLE" :TYPE "LISP" :VERSION 2) ;;; -*- Package: ICON; Mode: LISP; Base: 10 -*-Н;Н; YATI (Yet another Turtle Implementation)Н; Copyright 1984, Steve StrassmannН;Н; This software is in the public domain. You may freely distribute itН; for educational purposes and incorporate it in other publicН; domain software, but it can not be incorporated into a productН; and sold without permission from the author.Н;Н; To use this file: Н; No other files need to be loaded. Н; This provides the basic building blocks for other, neater turtles.Н;Н; Experienced logoites will need no introduction; others can justН; try loading DEMO-ICON and playing with the turtles.Н; Н;------------------------------------------------------------------------------Н;Н; This file defines the following flavors:Н;Н; BASIC-TURTLE, which acts like a standard LOGO turtleН; POND-MIXIN, a window mixin which handles turtles.Н; Always mix in this flavor to any window which willН; have turtles on it.НН;==============================================================================Н;Н; Basic Turtles are things which obey standard LOGO-type turtle commands.Н; They look like triangles pointed in a certain direction (specified in degrees,Н; with 0 degrees meaning pointing toward the top of the screen), at a certainН; position in the screen.Н;Н; You can send them these messages:Н;Н; :FORWARD :FD Н; :BACKWARD :BK Н; :LEFT :LT Н; :RIGHT :RT Н; :PENUP :PUН; :PENDOWN [] :PD [] is optional. It defaults to :DOWN (ior).Н; Others are :IOR, :XOR, :ERASE; :UP, T & NILН; :HIDE Makes the turtle invisible.Н; :UNHIDE Makes the turtle visible.Н; :HOME Puts turtle in the screen's center, facing up.Н; :CS Clears the turtle's screen.Н; :SET-POS Н; :SET-HEADING Н; :SET-WINDOW Move the turtle to a new window.Н;Н; You can make a turtle with Н;Н; (MAKE-TURTLE . )Н; Window must have POND-MIXIN.Н; After the window come alternating keywords and valuesН; for initializing the turtle. Its position defaults toН; the HOME position: center of the pond, facing up.Н; Н;==============================================================================Н;Н; This is a window which has turtles on itН;Н;Н; It keeps track of its turtles with the following messages:Н;Н; :ADD-TURTLE Н; :REMOVE-TURTLE Н; :TELL-TURTLES [ ... ]Н;Н;Н(defflavor pond-mixinНЙ((turtles nil))НЙ(tv:graphics-mixin tv:stream-mixin)Й; This stream has nothing to do with ponds.Н :initable-instance-variablesЙЙЙ; It's the boring old lispm STREAM mixin.Н :gettable-instance-variablesН :settable-instance-variables)НН(defmethod (pond-mixin :after :refresh) (&rest ignore)Н (loop for turtle in turtlesНЙdo (send turtle ':set-drawn? nil)Й; Inform the turtle it's been erased.НЙdo (send turtle ':draw)))ЙЙ; Draw it and make it visible.НН(defmethod (pond-mixin :add-turtle) (turtle)Н (setq turtles (cons turtle turtles)))НН(defmethod (pond-mixin :remove-turtle) (turtle)Н (setq turtles (remq turtle turtles)))НН; &REST takes the rest of the arguments and makes a list, ARGS.Н; Lexpr-funcall unravels its last argument and passes its contentsН; to the function being called.Н; Thus, for example, (lexpr-funcall '+ 1 1 '(1 1)) returns 4.Н;Н; You could send a message like (send window ':tell-turtles ':forward 100)Н; and all the turtles would go forward 100.Н;Н(defmethod (pond-mixin :tell-turtles) (message &rest args)Н (loop for turtle in turtlesНЙdo (lexpr-funcall turtle message args)))ННН;==============================================================================ННН(defflavor basic-turtleНЙ((xcor nil)НЙ (ycor nil)НЙ (pen ':down)НЙ (hidden? nil)ЙЙЙЙ; Hidden turtles don't want to get drawn.НЙ (drawn? nil)ЙЙЙЙ; Undrawn, non-hidden turtles get drawn.НЙ (heading 0)ЙЙЙЙ; 0 degrees is due North.НЙ (height 5)ЙЙЙЙ; 1/3 height of the turtle's triangle НЙ (width 5)ЙЙЙЙ; 1/2 base of the turtle's triangleНЙ (window nil))НЙ()Н :initable-instance-variablesН :gettable-instance-variablesН :settable-instance-variables)НН; You can make a turtle with (MAKE-TURTLE . )Н; For example, (SETQ FRED (MAKE-TURTLE *MY-WINDOW ':XCOR 50 ':HEADING 180))Н;Н; The window must have POND-MIXIN. After the window come alternatingН; keywords and values for initializing the turtle. The turtle's position defaultsН; to the HOME position: center of the pond, facing up. (see the :INIT method)Н;Н(defmacro make-turtle (window . options)Н `(make-instance 'basic-turtle ':window ,window . ,options))НН; SET-POS and SET-HEADING handle going beyond limits so nothing else has to.Н; The position is in screen coordinates.Н;Н(defmethod (basic-turtle :set-pos) (x y)Н (if (not hidden?) (send self ':erase))Н (setq xcor (wrap x (send window ':width))НЙycor (wrap y (send window ':height)))Н (if (not hidden?) (send self ':draw)))НН; Degrees, not radians. 0 degrees is straight up.Н;Н(defmethod (basic-turtle :set-heading) (h)Н (send self ':erase)Н (setq heading (wrap h 360))Н (send self ':draw))НН; Confines x to the interval 0 x bound.Н; Probably faster than modulo, though I never benchmarked it.Н;Н(defun wrap (x bound)ЙЙЙ Н (cond ((minusp x) (wrap (+ x bound) bound))НЙ((> x bound)(wrap (- x bound) bound))НЙ(t x)))НН; The three corners of the triangle are rotated relative to the center.Н; If the turtle were facing north, its corners would have the followingН; relative coordinates:Н; Top x: 0 y: (* 2 height) *Н; Left x: -width y: -height ***Н; Right x: width y: -height *****НН(defmethod (basic-turtle :draw) ()Н (if (or hidden? drawn?) nilЙ Й; don't draw hidden or already drawn turtles.Н (send window ':draw-triangleЙЙЙ; draw-triangle takes 7 arguments:НЙ (fixr (+ xcor (rotx 0 (* 2 height) heading)))Й; x1НЙ (fixr (- ycor (roty 0 (* 2 height) heading)))Й; y1НЙ (fixr (+ xcor (rotx (- width) (- height) heading)))Й; x2НЙ (fixr (- ycor (roty (- width) (- height) heading)))Й; y2НЙ (fixr (+ xcor (rotx width (- height) heading)))Й; x3НЙ (fixr (- ycor (roty width (- height) heading)))Й; y3НЙ tv:alu-xor) ЙЙЙ ; aluН (setq drawn? t)))НН(defmethod (basic-turtle :erase) ()Н (if (not drawn?) nilЙЙ Й; don't erase undrawn turtlesН (send window ':draw-triangleЙЙЙ; draw-triangle takes 7 arguments:НЙ (fixr (+ xcor (rotx 0 (* 2 height) heading)))Й; x1НЙ (fixr (- ycor (roty 0 (* 2 height) heading)))Й; y1НЙ (fixr (+ xcor (rotx (- width) (- height) heading)))Й; x2НЙ (fixr (- ycor (roty (- width) (- height) heading)))Й; y2НЙ (fixr (+ xcor (rotx width (- height) heading)))Й; x3НЙ (fixr (- ycor (roty width (- height) heading)))Й; y3НЙ tv:alu-xor) ЙЙЙ ; aluН (setq drawn? nil)))ННН; This returns the X-coordinate of the rotated pointН;Н(defun rotx (x y theta)Н (+ (* x (cosd theta))Н (* y (sind theta))))НН; This returns the Y-coordinate of the rotated pointН;Н(defun roty (x y theta)Н (- (* y (cosd theta))Н (* x (sind theta))))НН;------------------------------------------------------------------------------НН; Let's keep track of every turtle ever created automatically.Н; The window should have the flavor POND-MIXIN mixed in.Н;Н(defmethod (basic-turtle :after :init) (&rest ignore)Н (if (null window)Н nilЙЙЙЙЙ; Can't do anythingН (send window ':add-turtle self)Н (or xcor (setq xcor (* .5 (send window ':width))))Н (or ycor (setq ycor (* .5 (send window ':height))))Н (send self ':draw)))НН(defmethod (basic-turtle :before :set-window) (ignore)Н (and window (send window ':remove-turtle self)))НН(defmethod (basic-turtle :after :set-window) (new-window)Н (and new-window (send new-window ':add-turtle self)))НН;------------------------------------------------------------------------------Н; Go forward (move ahead, whip it, whip it good ......)Н;Н(defmethod (basic-turtle :forward) (n)Н (let* ((dx (* (sind heading) n))НЙ (dy (* (cosd heading) -1 n))ЙЙ; Remember that Y increases downwardsНЙ (nx (+ xcor dx))ЙЙЙ; on the lisp machine....НЙ (ny (+ ycor dy)))Н (send self ':handle-pen dx dy nx ny)Н (send self ':set-pos nx ny)))НН; Wraparound is the notion that going off to one side makes you show up on theН; other side. Our turtles "wrap" when they try to leave the screen.Н; :HANDLE-PEN must draw one line if the turtle's movement is totally on-screen,Н; and two lines if there's wraparound. Clipping (trimming the length of the lines)Н; isn't necessary, since the lisp machine will merely ignore the part of theН; line that lies off-screen. I use the following position variables:Н;Н; DX,DY: change in position. NX,NY: unclipped new position. WX,WY: wrapped new position.Н;Н; PEN must be bound to a keyword or T or NIL. This tells the turtle what kind ofН; line to draw. PICK-ALU decides which kind of alu to use when drawing; for more infoН; on alu's, see the Window system manual. These keywords are defined:Н; :IOR, :XOR, :ERASE, :UP (does nothing), :DOWN (inclusive or).Н; Also, T means :DOWN and NIL means :UP.Н;Н; Note that the turtles are erased. This is kind of like lifting up your feetН; before painting the floor; an inaccurate line would be drawn if the turtleН; stayed on the screen.Н;Н(defmethod (basic-turtle :handle-pen) (dx dy nx ny)Н (if (or (null pen) (eq pen ':up))Н nilЙЙЙЙЙ; don't draw a line if the pen is up.Н (send window ':tell-turtles ':erase)Н (let ((wx (wrap nx (send window ':width)))НЙ (wy (wrap ny (send window ':height))))НЙ(send window ':draw-line (fixr xcor) (fixr ycor)НЙ (fixr nx) (fixr ny) (pick-alu pen) nil)Й; draw first lineНЙ(if (or ( nx wx) ( ny wy))НЙ (send window ':draw-line (fixr (- wx dx)) (fixr (- wy dy))НЙЙ (fixr wx) (fixr wy) (pick-alu pen) nil)))Н (send window ':tell-turtles ':draw)))ННН(defun pick-alu (pen)Н (selectq penН ((t :DOWN :IOR) tv:alu-ior)ЙЙЙ; T, :DOWN, or :IOR mean inclusive-or.Н (:XOR tv:alu-xor)ЙЙЙЙ; :XOR means exclusive-or.Н (:ERASE tv:alu-andca)ЙЙЙ; :ERASE means nand.Н (t 3)))ЙЙЙЙЙ; anything else means do nothing.НН;------------------------------------------------------------------------------Н;Н; The rest of the standard turtle functions:НН(defmethod (basic-turtle :backward) (n) (send self ':forward (- n)))НН(defmethod (basic-turtle :right) (a)Н (send self ':set-heading (+ heading a)))НН(defmethod (basic-turtle :left) (a)Н (send self ':set-heading (- heading a)))НН(defmethod (basic-turtle :penup) ()Н (setq pen ':up))НН(defmethod (basic-turtle :pendown) (&optional (p ':down))Н (setq pen p))НН(defmethod (basic-turtle :hide) ()Н (setq hidden? t)Н (send self ':erase))НН(defmethod (basic-turtle :unhide) ()Н (setq hidden? nil)Н (send self ':draw))НН(defmethod (basic-turtle :home) ()Н (send self ':set-pos (* .5 (send window ':width))НЙ (* .5 (send window ':height)))Н (send self ':set-heading 0))НН(defmethod (basic-turtle :cs) ()Н (send window ':refresh))НН;------------------------------------------------------------------------------Н;Н; Here's some shorthand for the same messages:Н Н(defmethod (basic-turtle :fd) (n) (send self ':forward n))Й; ForwardН(defmethod (basic-turtle :bk) (n) (send self ':forward (- n)))Й; BackwardН(defmethod (basic-turtle :rt) (a) (send self ':right a))Й; RightН(defmethod (basic-turtle :lt) (a) (send self ':right (- a)))Й; LeftН(defmethod (basic-turtle :pu) () (send self ':penup))Й ; Pen upН(defmethod (basic-turtle :pd) (&optional (p ':down))Й ; Pen downН (send self ':pendown p))НН(compile-flavor-methods basic-turtle)Н(defvar *turtle-loadedp t)LMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 12 :LENGTH-IN-BYTES 12016 :AUTHOR "WILDE" :CREATION-DATE 2725554940 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "TURTLE" :TYPE "LISP" :VERSION 3) ;;; -*- Package: (ICON); Mode: LISP; Base: 10 -*-Н;Н; YATI (Yet another Turtle Implementation)Н; Copyright 1984, Steve StrassmannН;Н; This software is in the public domain. You may freely distribute itН; for educational purposes and incorporate it in other publicН; domain software, but it can not be incorporated into a productН; and sold without permission from the author.Н;Н; To use this file: Н; No other files need to be loaded. Н; This provides the basic building blocks for other, neater turtles.Н;Н; Experienced logoites will need no introduction; others can justН; try loading DEMO-ICON and playing with the turtles.Н; Н;------------------------------------------------------------------------------Н;Н; This file defines the following flavors:Н;Н; BASIC-TURTLE, which acts like a standard LOGO turtleН; POND-MIXIN, a window mixin which handles turtles.Н; Always mix in this flavor to any window which willН; have turtles on it.НН;==============================================================================Н;Н; Basic Turtles are things which obey standard LOGO-type turtle commands.Н; They look like triangles pointed in a certain direction (specified in degrees,Н; with 0 degrees meaning pointing toward the top of the screen), at a certainН; position in the screen.Н;Н; You can send them these messages:Н;Н; :FORWARD :FD Н; :BACKWARD :BK Н; :LEFT :LT Н; :RIGHT :RT Н; :PENUP :PUН; :PENDOWN [] :PD [] is optional. It defaults to :DOWN (ior).Н; Others are :IOR, :XOR, :ERASE; :UP, T & NILН; :HIDE Makes the turtle invisible.Н; :UNHIDE Makes the turtle visible.Н; :HOME Puts turtle in the screen's center, facing up.Н; :CS Clears the turtle's screen.Н; :SET-POS Н; :SET-HEADING Н; :SET-WINDOW Move the turtle to a new window.Н;Н; You can make a turtle with Н;Н; (MAKE-TURTLE . )Н; Window must have POND-MIXIN.Н; After the window come alternating keywords and valuesН; for initializing the turtle. Its position defaults toН; the HOME position: center of the pond, facing up.Н; Н;==============================================================================Н;Н; This is a window which has turtles on itН;Н;Н; It keeps track of its turtles with the following messages:Н;Н; :ADD-TURTLE Н; :REMOVE-TURTLE Н; :TELL-TURTLES [ ... ]Н;Н;Н(defflavor pond-mixinНЙ((turtles nil))НЙ(tv:graphics-mixin tv:stream-mixin)Й; This stream has nothing to do with ponds.Н :initable-instance-variablesЙЙЙ; It's the boring old lispm STREAM mixin.Н :gettable-instance-variablesН :settable-instance-variables)НН(defmethod (pond-mixin :after :refresh) (&rest ignore)Н (loop for turtle in turtlesНЙdo (send turtle ':set-drawn? nil)Й; Inform the turtle it's been erased.НЙdo (send turtle ':draw)))ЙЙ; Draw it and make it visible.НН(defmethod (pond-mixin :add-turtle) (turtle)Н (setq turtles (cons turtle turtles)))НН(defmethod (pond-mixin :remove-turtle) (turtle)Н (setq turtles (remq turtle turtles)))НН; &REST takes the rest of the arguments and makes a list, ARGS.Н; Lexpr-funcall unravels its last argument and passes its contentsН; to the function being called.Н; Thus, for example, (lexpr-funcall '+ 1 1 '(1 1)) returns 4.Н;Н; You could send a message like (send window ':tell-turtles ':forward 100)Н; and all the turtles would go forward 100.Н;Н(defmethod (pond-mixin :tell-turtles) (message &rest args)Н (loop for turtle in turtlesНЙdo (lexpr-funcall turtle message args)))ННН;==============================================================================ННН(defflavor basic-turtleНЙ((xcor nil)НЙ (ycor nil)НЙ (pen ':down)НЙ (hidden? nil)ЙЙЙЙ; Hidden turtles don't want to get drawn.НЙ (drawn? nil)ЙЙЙЙ; Undrawn, non-hidden turtles get drawn.НЙ (heading 0)ЙЙЙЙ; 0 degrees is due North.НЙ (height 5)ЙЙЙЙ; 1/3 height of the turtle's triangle НЙ (width 5)ЙЙЙЙ; 1/2 base of the turtle's triangleНЙ (window nil))НЙ()Н :initable-instance-variablesН :gettable-instance-variablesН :settable-instance-variables)НН; You can make a turtle with (MAKE-TURTLE . )Н; For example, (SETQ FRED (MAKE-TURTLE *MY-WINDOW ':XCOR 50 ':HEADING 180))Н;Н; The window must have POND-MIXIN. After the window come alternatingН; keywords and values for initializing the turtle. The turtle's position defaultsН; to the HOME position: center of the pond, facing up. (see the :INIT method)Н;Н(defmacro make-turtle (window . options)Н `(make-instance 'basic-turtle ':window ,window . ,options))НН; SET-POS and SET-HEADING handle going beyond limits so nothing else has to.Н; The position is in screen coordinates.Н;Н(defmethod (basic-turtle :set-pos) (x y)Н (if (not hidden?) (send self ':erase))Н (setq xcor (wrap x (send window ':width))НЙycor (wrap y (send window ':height)))Н (if (not hidden?) (send self ':draw)))НН; Degrees, not radians. 0 degrees is straight up.Н;Н(defmethod (basic-turtle :set-heading) (h)Н (send self ':erase)Н (setq heading (wrap h 360))Н (send self ':draw))НН; Confines x to the interval 0 x bound.Н; Probably faster than modulo, though I never benchmarked it.Н;Н(defun wrap (x bound)ЙЙЙ Н (cond ((minusp x) (wrap (+ x bound) bound))НЙ((> x bound)(wrap (- x bound) bound))НЙ(t x)))НН; The three corners of the triangle are rotated relative to the center.Н; If the turtle were facing north, its corners would have the followingН; relative coordinates:Н; Top x: 0 y: (* 2 height) *Н; Left x: -width y: -height ***Н; Right x: width y: -height *****НН(defmethod (basic-turtle :draw) ()Н (if (or hidden? drawn?) nilЙ Й; don't draw hidden or already drawn turtles.Н (send window ':draw-triangleЙЙЙ; draw-triangle takes 7 arguments:НЙ (fixr (+ xcor (rotx 0 (* 2 height) heading)))Й; x1НЙ (fixr (- ycor (roty 0 (* 2 height) heading)))Й; y1НЙ (fixr (+ xcor (rotx (- width) (- height) heading)))Й; x2НЙ (fixr (- ycor (roty (- width) (- height) heading)))Й; y2НЙ (fixr (+ xcor (rotx width (- height) heading)))Й; x3НЙ (fixr (- ycor (roty width (- height) heading)))Й; y3НЙ tv:alu-xor) ЙЙЙ ; aluН (setq drawn? t)))НН(defmethod (basic-turtle :erase) ()Н (if (not drawn?) nilЙЙ Й; don't erase undrawn turtlesН (send window ':draw-triangleЙЙЙ; draw-triangle takes 7 arguments:НЙ (fixr (+ xcor (rotx 0 (* 2 height) heading)))Й; x1НЙ (fixr (- ycor (roty 0 (* 2 height) heading)))Й; y1НЙ (fixr (+ xcor (rotx (- width) (- height) heading)))Й; x2НЙ (fixr (- ycor (roty (- width) (- height) heading)))Й; y2НЙ (fixr (+ xcor (rotx width (- height) heading)))Й; x3НЙ (fixr (- ycor (roty width (- height) heading)))Й; y3НЙ tv:alu-xor) ЙЙЙ ; aluН (setq drawn? nil)))ННН; This returns the X-coordinate of the rotated pointН;Н(defun rotx (x y theta)Н (+ (* x (cosd theta))Н (* y (sind theta))))НН; This returns the Y-coordinate of the rotated pointН;Н(defun roty (x y theta)Н (- (* y (cosd theta))Н (* x (sind theta))))НН;------------------------------------------------------------------------------НН; Let's keep track of every turtle ever created automatically.Н; The window should have the flavor POND-MIXIN mixed in.Н;Н(defmethod (basic-turtle :after :init) (&rest ignore)Н (if (null window)Н nilЙЙЙЙЙ; Can't do anythingН (send window ':add-turtle self)Н (or xcor (setq xcor (* .5 (send window ':width))))Н (or ycor (setq ycor (* .5 (send window ':height))))Н (send self ':draw)))НН(defmethod (basic-turtle :before :set-window) (ignore)Н (and window (send window ':remove-turtle self)))НН(defmethod (basic-turtle :after :set-window) (new-window)Н (and new-window (send new-window ':add-turtle self)))НН;------------------------------------------------------------------------------Н; Go forward (move ahead, whip it, whip it good ......)Н;Н(defmethod (basic-turtle :forward) (n)Н (let* ((dx (* (sind heading) n))НЙ (dy (* (cosd heading) -1 n))ЙЙ; Remember that Y increases downwardsНЙ (nx (+ xcor dx))ЙЙЙ; on the lisp machine....НЙ (ny (+ ycor dy)))Н (send self ':handle-pen dx dy nx ny)Н (send self ':set-pos nx ny)))НН; Wraparound is the notion that going off to one side makes you show up on theН; other side. Our turtles "wrap" when they try to leave the screen.Н; :HANDLE-PEN must draw one line if the turtle's movement is totally on-screen,Н; and two lines if there's wraparound. Clipping (trimming the length of the lines)Н; isn't necessary, since the lisp machine will merely ignore the part of theН; line that lies off-screen. I use the following position variables:Н;Н; DX,DY: change in position. NX,NY: unclipped new position. WX,WY: wrapped new position.Н;Н; PEN must be bound to a keyword or T or NIL. This tells the turtle what kind ofН; line to draw. PICK-ALU decides which kind of alu to use when drawing; for more infoН; on alu's, see the Window system manual. These keywords are defined:Н; :IOR, :XOR, :ERASE, :UP (does nothing), :DOWN (inclusive or).Н; Also, T means :DOWN and NIL means :UP.Н;Н; Note that the turtles are erased. This is kind of like lifting up your feetН; before painting the floor; an inaccurate line would be drawn if the turtleН; stayed on the screen.Н;Н(defmethod (basic-turtle :handle-pen) (dx dy nx ny)Н (if (or (null pen) (eq pen ':up))Н nilЙЙЙЙЙ; don't draw a line if the pen is up.Н (send window ':tell-turtles ':erase)Н (let ((wx (wrap nx (send window ':width)))НЙ (wy (wrap ny (send window ':height))))НЙ(send window ':draw-line (fixr xcor) (fixr ycor)НЙ (fixr nx) (fixr ny) (pick-alu pen) nil)Й; draw first lineНЙ(if (or ( nx wx) ( ny wy))НЙ (send window ':draw-line (fixr (- wx dx)) (fixr (- wy dy))НЙЙ (fixr wx) (fixr wy) (pick-alu pen) nil)))Н (send window ':tell-turtles ':draw)))ННН(defun pick-alu (pen)Н (selectq penН ((t :DOWN :IOR) tv:alu-ior)ЙЙЙ; T, :DOWN, or :IOR mean inclusive-or.Н (:XOR tv:alu-xor)ЙЙЙЙ; :XOR means exclusive-or.Н (:ERASE tv:alu-andca)ЙЙЙ; :ERASE means nand.Н (t 3)))ЙЙЙЙЙ; anything else means do nothing.НН;------------------------------------------------------------------------------Н;Н; The rest of the standard turtle functions:НН(defmethod (basic-turtle :backward) (n) (send self ':forward (- n)))НН(defmethod (basic-turtle :right) (a)Н (send self ':set-heading (+ heading a)))НН(defmethod (basic-turtle :left) (a)Н (send self ':set-heading (- heading a)))НН(defmethod (basic-turtle :penup) ()Н (setq pen ':up))НН(defmethod (basic-turtle :pendown) (&optional (p ':down))Н (setq pen p))НН(defmethod (basic-turtle :hide) ()Н (setq hidden? t)Н (send self ':erase))НН(defmethod (basic-turtle :unhide) ()Н (setq hidden? nil)Н (send self ':draw))НН(defmethod (basic-turtle :home) ()Н (send self ':set-pos (* .5 (send window ':width))НЙ (* .5 (send window ':height)))Н (send self ':set-heading 0))НН(defmethod (basic-turtle :cs) ()Н (send window ':refresh))НН;------------------------------------------------------------------------------Н;Н; Here's some shorthand for the same messages:Н Н(defmethod (basic-turtle :fd) (n) (send self ':forward n))Й; ForwardН(defmethod (basic-turtle :bk) (n) (send self ':forward (- n)))Й; BackwardН(defmethod (basic-turtle :rt) (a) (send self ':right a))Й; RightН(defmethod (basic-turtle :lt) (a) (send self ':right (- a)))Й; LeftН(defmethod (basic-turtle :pu) () (send self ':penup))Й ; Pen upН(defmethod (basic-turtle :pd) (&optional (p ':down))Й ; Pen downН (send self ':pendown p))НН(compile-flavor-methods basic-turtle)Н(defvar *turtle-loadedp t)LMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 3 :LENGTH-IN-BYTES 2165 :AUTHOR "WILDE" :CREATION-DATE 2716905366 :QFASLP NIL :LENGTH 2165 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "TURTLE-CONSTRAINT-FRAME-KEY-TOGGLE" :TYPE "TEXT" :VERSION 2) -*- Mode:Text; Fonts:(CPTFONT) -*-НН;; Copyright (C) 1985 LISP Machine, Incorporated.НННTitle: Constraint FramesНSubtitle: Problem solution for toggling configurations byН binding a key.НFile: none - make changes as below.НННTo toggle between configurations add the function change-displayНand change turtle as below. The changes should be in Нturtle-constraint-one-config. See turtle-constraint-two-config.НННН(defun change-display ()НН "Does the work of toggling between configurations on command.НDetermine which configuration is displayed, then go to the otherНone. Refresh the screen when you are done."НН (send *turtle-frameНЙ':set-configurationНЙ(if (eq (send *turtle-frame ':configuration)НЙЙ'alternate-configuration)НЙ 'standard-configurationНЙ 'alternate-configuration))Н (send *turtle-lake ':refresh))НННННН; Turtle is the top-level function. It makes the turtle frame,Н; then runs a loop reading from the io-buffer, and performingН; the actions indicated.НН(defun turtle ()Н (let* ((*turtle-frame (make-instance 'turtle-frame))НЙ (*command-pane (send *turtle-frameНЙЙЙ :get-pane 'command-pane))НЙ (*turtle-lake (send *turtle-frameНЙЙЙ :get-pane 'turtle-pane))НЙ (*prompt-pane (send *turtle-frameНЙЙЙ :get-pane 'prompt-pane))НЙ (base 10.)НЙ (ibase 10.)НЙ (terminal-io *prompt-pane)НЙ (query-io *prompt-pane)НЙ (error-output *prompt-pane)НЙ *turtle)Н Н (send *turtle-frame :expose)Н (send *turtle-frame :activate)Н (send *prompt-pane :select)НН (setq *turtle (make-turtle *turtle-lake))Н (send *turtle :pendown)Н Н (loop for input = (send *prompt-pane :any-tyi)НЙ do (cond ((atom input)НЙЙ (selectq inputНН; Here is where you add conde to intercept keyboard inputН; and do special things with defined keys.Н; Notice that the key "c" has been given the functionalityН; of toggling between the two configurations of the turtleН; constraint frame.ННЙЙ (#/c (change-display)) НЙЙ (#\end (send *turtle-frame :bury))НЙЙ (t (beep))))НЙЙ ((listp input)НЙЙ (selectq (car input)НЙЙ (:menuНЙЙ (send (fourth input)НЙЙЙ :execute (second input)))НЙЙ (t (beep))))))))НLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 2 :LENGTH-IN-BYTES 1396 :AUTHOR "WILDE" :CREATION-DATE 2716906250 :QFASLP NIL :LENGTH 1396 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "TURTLE-CONSTRAINT-FRAME-TWO-CONFIG" :TYPE "TEXT" :VERSION 3) -*- Mode:Text; Fonts:(CPTFONT) -*-НН;; Copyright (C) 1985 LISP Machine, Incorporated.ННTitle: Constraint FramesНSubtitle: Problem solution for adding constraint an alternateН configuration to the constraint frame.НFile: none - change the turtle-frame in files as indicated-below.ННННTo add an alternate configuration to turtle-frame change Нturtle-frame in turtle-constraint-one-config to look as below.НSee turtle-constraint-two-config.ННН(defflavor turtle-frameНЙ ()НЙ (tv:bordered-constraint-frame-with-shared-io-buffer)Н :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variablesН (:documentationН "Turtle Frame")Н (:default-init-plistН :expose-p t ; expose w/o blink on instantiationН :activate-p t ; activate on instantiationН :save-bits :delayed ; make save bits array on deexposureН :panesН '((command-pane turtle-command)Н (turtle-pane turtle-lake)Н (prompt-pane prompt-pane))Н :constraintsН '((standard-configurationНЙ(command-pane turtle-pane prompt-pane)НЙ((command-pane :ask :pane-size)) ; as big as it needsНЙ((prompt-pane 8 :lines)) ; 8 linesНЙ((turtle-pane :even))) ; whatever's left overН (alternate-configurationНЙ(turtle-pane command-pane prompt-pane)НЙ((command-pane :ask :pane-size))НЙ((prompt-pane 8 :lines))НЙ((turtle-pane :even))))))НLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 6 :LENGTH-IN-BYTES 5948 :AUTHOR "WILDE" :CREATION-DATE 2716906333 :QFASLP NIL :LENGTH 5948 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "TURTLE-CONSTRAINT-ONE-CONFIG" :TYPE "LISP" :VERSION 6) ;;; -*- Mode:LISP; Package:ICON; Base:10; Fonts:(CPTFONT) -*-НН;; Copyright (C) 1985 LISP Machine, Incorporated.ННН; Title: Constraint FramesН; Subtitle: A simple three-pane constraint-frame for turtle.Н; File: turtle-constraint-one-config.lisp and .qfaslННН; To run, load the file turtle.qfasl, load this file, then doН; 1.ННН; This file sets up a constraint frame for turtle consistingН; of a command pane, a turtle lake pane, and a prompt paneН; for prompts and user type-in.НН; We are dealing with only one turtle here, although the code Н; in turtle is capable of making and handling more.ННН; The turtle frame has one configuration:НН; - standard-configuration, which has the command menu onН; top and the turtle pond on the bottom.ННН; The following variables are bound in the toplevel function Н; turtle.НН(defvar *turtle-frame :unboundН "The turtle frame")НН(defvar *command-pane :unboundН "The command pane")НН(defvar *turtle-lake :unboundН "The turtle pond")НН(defvar *prompt-pane :unboundН "An interaction and prompting pane")НН(defvar *turtle :unboundН "The turtle")ННН; This is the command pane in the turtle world.НН(defflavor turtle-commandНЙ ()НЙ (tv:command-menu)Н :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variablesН (:documentationН "Turtle Command Pane")Н (:default-init-plistН :font-map '(fonts:bigfnt)Н :columns 4Н :item-list *command-list))НН Н; These are the commands that appear in the command pane.Н Н(defvar *command-listННЙ'(("Set Position"НЙ :evalНЙ (send *turtle :set-posНЙЙ (prompt-and-read :numberНЙЙЙЙ "Enter x pos in pixels: ")НЙЙ (prompt-and-read :numberНЙЙЙЙ "Enter y pos in pixels: "))НЙ :documentation "Set the turtle's position")НЙ НЙ ("Set Heading"НЙ :evalНЙ (send *turtle :set-headingНЙЙ (prompt-and-read :numberНЙЙЙЙ "Enter heading in degrees: "))НЙ :documentation "Set the turtle's position")ННЙ ("Draw Turtle"НЙ :evalНЙ (send *turtle :draw)НЙ :documentation "Draw the turtle in the pond")НЙ НЙ ("Erase Turtle"НЙ :evalНЙ (send *turtle :erase)НЙ :documentation "Erase the turtle")НЙ НЙ ("Move Forward"НЙ :evalНЙ (send *turtle :forwardНЙЙ (prompt-and-read :numberНЙЙЙЙ "How many pixels? "))НЙ :documentation "Move the turtle forward")НЙ НЙ ("Move Backward"НЙ :evalНЙ (send *turtle :backwardНЙЙ (prompt-and-read :numberНЙЙЙЙ "How many pixels? "))НЙ :documentation "Move the turtle backwards")НЙ НЙ ("Turn Right"НЙ :evalНЙ (send *turtle :rightНЙЙ (prompt-and-read :numberНЙЙЙЙ "How many degrees? "))НЙ :documentation "Take a right turn")НЙ НЙ ("Turn Left"НЙ :evalНЙ (send *turtle :leftНЙЙ (prompt-and-read :numberНЙЙЙЙ "How many degrees? "))НЙ :documentation "Take a left turn")НЙ НЙ ("Pen Up"НЙ :evalНЙ (send *turtle :penup)НЙ :documentation "Lift up the pen")НЙ НЙ ("Pen Down"НЙ :evalНЙ (send *turtle :pendown)НЙ :documentation "Put the pen to paper")НЙ НЙ ("Hide"НЙ :evalНЙ (send *turtle :hide)НЙ :documentation "Hide the turtle")НЙ НЙ ("Unhide"НЙ :evalНЙ (send *turtle :unhide)НЙ :documentation "Unhide the turtle")НЙ НЙ ("Go Home"НЙ :evalНЙ (send *turtle :home)НЙ :documentation "Send the turtle home")НЙ НЙ ("Clear Screen"НЙ :evalНЙ (send *turtle-lake :refresh)НЙ :documentation "Clear the turtle pond")ННЙ ("Exit"НЙ :evalНЙ (send *turtle-frame :bury)НЙ :documentationНЙ "Leave the pond")))ННННННН; This is a small lake for the turtle to live in.Н; Notice that it has pond-mixin as a component flavor.НН(defflavor turtle-lakeНЙ ()НЙ (pond-mixin tv:window)Н (:documentationН "Turtle pond")Н (:default-init-plistН :save-bits tН :label "Turtle Pond")Н :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variables)ННН; Define a prompt pane for prompts and user interaction.НН(defflavor prompt-paneНЙ ()НЙ (tv:pane-mixin tv:window))НННН; The turtle frame ties it all together.НН(defflavor turtle-frameНЙ ()НЙ (tv:bordered-constraint-frame-with-shared-io-buffer)Н :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variablesН (:documentationН "Turtle Frame")Н (:default-init-plistН :expose-p t ; expose w/o blink on instantiationН :activate-p t ; activate on instantiationН :save-bits :delayed ; make save bits array on deexposureН :panesН '((command-pane turtle-command)Н (turtle-pane turtle-lake)Н (prompt-pane prompt-pane))Н :constraintsН '((standard-configurationНЙ(command-pane turtle-pane prompt-pane)НЙ((command-pane :ask :pane-size)) ; as big as it needsНЙ((prompt-pane 8 :lines)) ; 8 linesНЙ((turtle-pane :even)))))) ; whatever's left overННННЙ Н; Turtle is the top-level function. It makes the turtle frame,Н; then runs a loop reading from the io-buffer, and performingН; the actions indicated.НН(defun turtle ()Н (let* ((*turtle-frame (make-instance 'turtle-frame))НЙ (*command-pane (send *turtle-frameНЙЙЙ :get-pane 'command-pane))НЙ (*turtle-lake (send *turtle-frameНЙЙЙ :get-pane 'turtle-pane))НЙ (*prompt-pane (send *turtle-frameНЙЙЙ :get-pane 'prompt-pane))НЙ (base 10.)НЙ (ibase 10.)НЙ (terminal-io *prompt-pane)НЙ (query-io *prompt-pane)НЙ (error-output *prompt-pane)НЙ *turtle)Н Н (send *turtle-frame :expose)Н (send *turtle-frame :activate)Н (send *prompt-pane :select)Н Н (setq *turtle (make-turtle *turtle-lake))Н (send *turtle :pendown)Н Н (loop for input = (send *turtle-lake :any-tyi)НЙ do (cond ((atom input)НЙЙ (selectq inputНЙЙ (#\end (send *turtle-frame :bury))НЙЙ (t (beep))))НЙЙ ((listp input)НЙЙ (selectq (car input)НЙЙ (:menuНЙЙ (send (fourth input)НЙЙЙ :execute (second input)))НЙЙ (t (beep))))))))НЙЙЙННН; Put turtle on system key 1. In order to run turtle, doН; 1НН(tv:add-system-key #\1 '(turtle) "Turtle Pond")LMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 6 :LENGTH-IN-BYTES 5950 :AUTHOR "debbie" :CREATION-DATE 2725558008 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "TURTLE-CONSTRAINT-ONE-CONFIG" :TYPE "LISP" :VERSION 7) ;;; -*- Mode:LISP; Package:(ICON); Base:10; Fonts:(CPTFONT) -*-НН;; Copyright (C) 1985 LISP Machine, Incorporated.ННН; Title: Constraint FramesН; Subtitle: A simple three-pane constraint-frame for turtle.Н; File: turtle-constraint-one-config.lisp and .qfaslННН; To run, load the file turtle.qfasl, load this file, then doН; 1.ННН; This file sets up a constraint frame for turtle consistingН; of a command pane, a turtle lake pane, and a prompt paneН; for prompts and user type-in.НН; We are dealing with only one turtle here, although the code Н; in turtle is capable of making and handling more.ННН; The turtle frame has one configuration:НН; - standard-configuration, which has the command menu onН; top and the turtle pond on the bottom.ННН; The following variables are bound in the toplevel function Н; turtle.НН(defvar *turtle-frame :unboundН "The turtle frame")НН(defvar *command-pane :unboundН "The command pane")НН(defvar *turtle-lake :unboundН "The turtle pond")НН(defvar *prompt-pane :unboundН "An interaction and prompting pane")НН(defvar *turtle :unboundН "The turtle")ННН; This is the command pane in the turtle world.НН(defflavor turtle-commandНЙ ()НЙ (tv:command-menu)Н :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variablesН (:documentationН "Turtle Command Pane")Н (:default-init-plistН :font-map '(fonts:bigfnt)Н :columns 4Н :item-list *command-list))НН Н; These are the commands that appear in the command pane.Н Н(defvar *command-listННЙ'(("Set Position"НЙ :evalНЙ (send *turtle :set-posНЙЙ (prompt-and-read :numberНЙЙЙЙ "Enter x pos in pixels: ")НЙЙ (prompt-and-read :numberНЙЙЙЙ "Enter y pos in pixels: "))НЙ :documentation "Set the turtle's position")НЙ НЙ ("Set Heading"НЙ :evalНЙ (send *turtle :set-headingНЙЙ (prompt-and-read :numberНЙЙЙЙ "Enter heading in degrees: "))НЙ :documentation "Set the turtle's position")ННЙ ("Draw Turtle"НЙ :evalНЙ (send *turtle :draw)НЙ :documentation "Draw the turtle in the pond")НЙ НЙ ("Erase Turtle"НЙ :evalНЙ (send *turtle :erase)НЙ :documentation "Erase the turtle")НЙ НЙ ("Move Forward"НЙ :evalНЙ (send *turtle :forwardНЙЙ (prompt-and-read :numberНЙЙЙЙ "How many pixels? "))НЙ :documentation "Move the turtle forward")НЙ НЙ ("Move Backward"НЙ :evalНЙ (send *turtle :backwardНЙЙ (prompt-and-read :numberНЙЙЙЙ "How many pixels? "))НЙ :documentation "Move the turtle backwards")НЙ НЙ ("Turn Right"НЙ :evalНЙ (send *turtle :rightНЙЙ (prompt-and-read :numberНЙЙЙЙ "How many degrees? "))НЙ :documentation "Take a right turn")НЙ НЙ ("Turn Left"НЙ :evalНЙ (send *turtle :leftНЙЙ (prompt-and-read :numberНЙЙЙЙ "How many degrees? "))НЙ :documentation "Take a left turn")НЙ НЙ ("Pen Up"НЙ :evalНЙ (send *turtle :penup)НЙ :documentation "Lift up the pen")НЙ НЙ ("Pen Down"НЙ :evalНЙ (send *turtle :pendown)НЙ :documentation "Put the pen to paper")НЙ НЙ ("Hide"НЙ :evalНЙ (send *turtle :hide)НЙ :documentation "Hide the turtle")НЙ НЙ ("Unhide"НЙ :evalНЙ (send *turtle :unhide)НЙ :documentation "Unhide the turtle")НЙ НЙ ("Go Home"НЙ :evalНЙ (send *turtle :home)НЙ :documentation "Send the turtle home")НЙ НЙ ("Clear Screen"НЙ :evalНЙ (send *turtle-lake :refresh)НЙ :documentation "Clear the turtle pond")ННЙ ("Exit"НЙ :evalНЙ (send *turtle-frame :bury)НЙ :documentationНЙ "Leave the pond")))ННННННН; This is a small lake for the turtle to live in.Н; Notice that it has pond-mixin as a component flavor.НН(defflavor turtle-lakeНЙ ()НЙ (pond-mixin tv:window)Н (:documentationН "Turtle pond")Н (:default-init-plistН :save-bits tН :label "Turtle Pond")Н :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variables)ННН; Define a prompt pane for prompts and user interaction.НН(defflavor prompt-paneНЙ ()НЙ (tv:pane-mixin tv:window))НННН; The turtle frame ties it all together.НН(defflavor turtle-frameНЙ ()НЙ (tv:bordered-constraint-frame-with-shared-io-buffer)Н :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variablesН (:documentationН "Turtle Frame")Н (:default-init-plistН :expose-p t ; expose w/o blink on instantiationН :activate-p t ; activate on instantiationН :save-bits :delayed ; make save bits array on deexposureН :panesН '((command-pane turtle-command)Н (turtle-pane turtle-lake)Н (prompt-pane prompt-pane))Н :constraintsН '((standard-configurationНЙ(command-pane turtle-pane prompt-pane)НЙ((command-pane :ask :pane-size)) ; as big as it needsНЙ((prompt-pane 8 :lines)) ; 8 linesНЙ((turtle-pane :even)))))) ; whatever's left overННННЙ Н; Turtle is the top-level function. It makes the turtle frame,Н; then runs a loop reading from the io-buffer, and performingН; the actions indicated.НН(defun turtle ()Н (let* ((*turtle-frame (make-instance 'turtle-frame))НЙ (*command-pane (send *turtle-frameНЙЙЙ :get-pane 'command-pane))НЙ (*turtle-lake (send *turtle-frameНЙЙЙ :get-pane 'turtle-pane))НЙ (*prompt-pane (send *turtle-frameНЙЙЙ :get-pane 'prompt-pane))НЙ (base 10.)НЙ (ibase 10.)НЙ (terminal-io *prompt-pane)НЙ (query-io *prompt-pane)НЙ (error-output *prompt-pane)НЙ *turtle)Н Н (send *turtle-frame :expose)Н (send *turtle-frame :activate)Н (send *prompt-pane :select)Н Н (setq *turtle (make-turtle *turtle-lake))Н (send *turtle :pendown)Н Н (loop for input = (send *turtle-lake :any-tyi)НЙ do (cond ((atom input)НЙЙ (selectq inputНЙЙ (#\end (send *turtle-frame :bury))НЙЙ (t (beep))))НЙЙ ((listp input)НЙЙ (selectq (car input)НЙЙ (:menuНЙЙ (send (fourth input)НЙЙЙ :execute (second input)))НЙЙ (t (beep))))))))НЙЙЙННН; Put turtle on system key 1. In order to run turtle, doН; 1НН(tv:add-system-key #\1 '(turtle) "Turtle Pond")LMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 5 :LENGTH-IN-BYTES 5088 :AUTHOR "WILDE" :CREATION-DATE 2716905472 :QFASLP NIL :LENGTH 5088 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "TURTLE-CONSTRAINT-ONE-CONFIG-EXERCISE" :TYPE "LISP" :VERSION 1) ;;; -*- Mode:LISP; Package:ICON; Base:10; Fonts:(CPTFONT) -*-ННН;; Copyright (C) 1985 LISP Machine, Incorporated.НН; Title: Constraint FramesН; Subtitle: A simple three-pane constraint-frame for turtle.Н; File: turtle-constraint-one-config.lisp and .qfaslННН; To run, load the file turtle.qfasl, load this file, then doН; 1.ННН; This file sets up a constraint frame for turtle consistingН; of a command pane, a turtle lake pane, and a prompt paneН; for prompts and user type-in.НН; We are dealing with only one turtle here, although the code Н; in turtle is capable of making and handling more.ННН; The turtle frame has one configuration:НН; - standard-configuration, which has the command menu onН; top and the turtle pond on the bottom.ННН; The following variables are bound in the toplevel function Н; turtle.НН(defvar *turtle-frame ':unboundН "The turtle frame")НН(defvar *command-pane ':unboundН "The command pane")НН(defvar *turtle-lake ':unboundН "The turtle pond")НН(defvar *prompt-pane ':unboundН "An interaction and prompting pane")НН(defvar *turtle ':unboundН "The turtle")НННН; This is the command pane in the turtle world.НН; ********** FILL IN THE MISSING CODE **********Н(defflavor turtle-commandННЙ )НМ НННННН; These are the commands that appear in the command pane.Н Н(defvar *command-listННЙ'(("Set Position"НЙ :evalНЙ (send *turtle ':set-posНЙЙ (prompt-and-read ':numberНЙЙЙЙ "Enter x pos in pixels: ")НЙЙ (prompt-and-read ':numberНЙЙЙЙ "Enter y pos in pixels: "))НЙ :documentation "Set the turtle's position")НЙ НЙ ("Set Heading"НЙ :evalНЙ (send *turtle ':set-headingНЙЙ (prompt-and-read ':numberНЙЙЙЙ "Enter heading in degrees: "))НЙ :documentation "Set the turtle's position")ННЙ ("Draw Turtle"НЙ :evalНЙ (send *turtle ':draw)НЙ :documentation "Draw the turtle in the pond")НЙ НЙ ("Erase Turtle"НЙ :evalНЙ (send *turtle ':erase)НЙ :documentation "Erase the turtle")НЙ НЙ ("Move Forward"НЙ :evalНЙ (send *turtle ':forwardНЙЙ (prompt-and-read ':numberНЙЙЙЙ "How many pixels? "))НЙ :documentation "Move the turtle forward")НЙ НЙ ("Move Backward"НЙ :evalНЙ (send *turtle ':backwardНЙЙ (prompt-and-read ':numberНЙЙЙЙ "How many pixels? "))НЙ :documentation "Move the turtle backwards")НМНННННЙ НЙ ("Turn Right"НЙ :evalНЙ (send *turtle ':rightНЙЙ (prompt-and-read ':numberНЙЙЙЙ "How many degrees? "))НЙ :documentation "Take a right turn")НЙ НЙ ("Turn Left"НЙ :evalНЙ (send *turtle ':leftНЙЙ (prompt-and-read ':numberНЙЙЙЙ "How many degrees? "))НЙ :documentation "Take a left turn")НЙ НЙ ("Pen Up"НЙ :evalНЙ (send *turtle ':penup)НЙ :documentation "Lift up the pen")НЙ НЙ ("Pen Down"НЙ :evalНЙ (send *turtle ':pendown)НЙ :documentation "Put the pen to paper")НЙ НЙ ("Hide"НЙ :evalНЙ (send *turtle ':hide)НЙ :documentation "Hide the turtle")НЙ НЙ ("Unhide"НЙ :evalНЙ (send *turtle ':unhide)НЙ :documentation "Unhide the turtle")НЙ НЙ ("Go Home"НЙ :evalНЙ (send *turtle ':home)НЙ :documentation "Send the turtle home")НЙ НЙ ("Clear Screen"НЙ :evalНЙ (send *turtle-lake ':refresh)НЙ :documentation "Clear the turtle pond")ННЙ ("Exit"НЙ :evalНЙ (send *turtle-frame ':bury)НЙ :documentationНЙ "Leave the pond")))НМННННННН; This is a small lake for the turtle to live in.Н; Notice that it has pond-mixin as a component flavor.НН(defflavor turtle-lakeНЙ ()НЙ (pond-mixin tv:window)Н (:documentationН "Turtle pond")Н (:default-init-plistН :save-bits tН :label "Turtle Pond")Н :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variables)ННН; Define a prompt pane for prompts and user interaction.НН(defflavor prompt-paneНЙ ()НЙ (tv:pane-mixin tv:window))НННН; The turtle frame ties it all together.НН; ********** FILL IN THE MISSING CODE **********Н(defflavor turtle-frameННЙ )ННЙ Н; Turtle is the top-level function. It makes the turtle frame,Н; then runs a loop reading from the io-buffer, and performingН; the actions indicated.НН(defun turtle ()Н (let* ((*turtle-frame (make-instance 'turtle-frame))НЙ (*command-pane (send *turtle-frameНЙЙЙ ':get-pane 'command-pane))НЙ (*turtle-lake (send *turtle-frameНЙЙЙ ':get-pane 'turtle-pane))НЙ (*prompt-pane (send *turtle-frameНЙЙЙ ':get-pane 'prompt-pane))НЙ (base 10.)НЙ (ibase 10.)НЙ (terminal-io *prompt-pane)НЙ (query-io *prompt-pane)НЙ (error-output *prompt-pane)НЙ *turtle)Н Н (send *turtle-frame ':expose)Н (send *turtle-frame ':activate)Н (send *prompt-pane ':select)Н Н (setq *turtle (make-turtle *turtle-lake))Н (send *turtle ':pendown)Н Н (loop for input = (send *turtle-lake ':any-tyi)НЙ do (cond ((atom input)НЙЙ (selectq inputНЙЙ (#\end (send *turtle-frame ':bury))НЙЙ (t (beep))))НЙЙ ((listp input)НЙЙ (selectq (car input)НЙЙ (:menuНЙЙ (send (fourth input)НЙЙЙ ':execute (second input)))НЙЙ (t (beep))))))))НЙЙЙННН; Put turtle on system key 9. In order to run turtle, doН; 9НН; ********** FILL IN THE MISSING CODE **********НLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 5 :LENGTH-IN-BYTES 5090 :AUTHOR "debbie" :CREATION-DATE 2725558034 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "TURTLE-CONSTRAINT-ONE-CONFIG-EXERCISE" :TYPE "LISP" :VERSION 2) ;;; -*- Mode:LISP; Package:(ICON); Base:10; Fonts:(CPTFONT) -*-ННН;; Copyright (C) 1985 LISP Machine, Incorporated.НН; Title: Constraint FramesН; Subtitle: A simple three-pane constraint-frame for turtle.Н; File: turtle-constraint-one-config.lisp and .qfaslННН; To run, load the file turtle.qfasl, load this file, then doН; 1.ННН; This file sets up a constraint frame for turtle consistingН; of a command pane, a turtle lake pane, and a prompt paneН; for prompts and user type-in.НН; We are dealing with only one turtle here, although the code Н; in turtle is capable of making and handling more.ННН; The turtle frame has one configuration:НН; - standard-configuration, which has the command menu onН; top and the turtle pond on the bottom.ННН; The following variables are bound in the toplevel function Н; turtle.НН(defvar *turtle-frame ':unboundН "The turtle frame")НН(defvar *command-pane ':unboundН "The command pane")НН(defvar *turtle-lake ':unboundН "The turtle pond")НН(defvar *prompt-pane ':unboundН "An interaction and prompting pane")НН(defvar *turtle ':unboundН "The turtle")НННН; This is the command pane in the turtle world.НН; ********** FILL IN THE MISSING CODE **********Н(defflavor turtle-commandННЙ )НМ НННННН; These are the commands that appear in the command pane.Н Н(defvar *command-listННЙ'(("Set Position"НЙ :evalНЙ (send *turtle ':set-posНЙЙ (prompt-and-read ':numberНЙЙЙЙ "Enter x pos in pixels: ")НЙЙ (prompt-and-read ':numberНЙЙЙЙ "Enter y pos in pixels: "))НЙ :documentation "Set the turtle's position")НЙ НЙ ("Set Heading"НЙ :evalНЙ (send *turtle ':set-headingНЙЙ (prompt-and-read ':numberНЙЙЙЙ "Enter heading in degrees: "))НЙ :documentation "Set the turtle's position")ННЙ ("Draw Turtle"НЙ :evalНЙ (send *turtle ':draw)НЙ :documentation "Draw the turtle in the pond")НЙ НЙ ("Erase Turtle"НЙ :evalНЙ (send *turtle ':erase)НЙ :documentation "Erase the turtle")НЙ НЙ ("Move Forward"НЙ :evalНЙ (send *turtle ':forwardНЙЙ (prompt-and-read ':numberНЙЙЙЙ "How many pixels? "))НЙ :documentation "Move the turtle forward")НЙ НЙ ("Move Backward"НЙ :evalНЙ (send *turtle ':backwardНЙЙ (prompt-and-read ':numberНЙЙЙЙ "How many pixels? "))НЙ :documentation "Move the turtle backwards")НМНННННЙ НЙ ("Turn Right"НЙ :evalНЙ (send *turtle ':rightНЙЙ (prompt-and-read ':numberНЙЙЙЙ "How many degrees? "))НЙ :documentation "Take a right turn")НЙ НЙ ("Turn Left"НЙ :evalНЙ (send *turtle ':leftНЙЙ (prompt-and-read ':numberНЙЙЙЙ "How many degrees? "))НЙ :documentation "Take a left turn")НЙ НЙ ("Pen Up"НЙ :evalНЙ (send *turtle ':penup)НЙ :documentation "Lift up the pen")НЙ НЙ ("Pen Down"НЙ :evalНЙ (send *turtle ':pendown)НЙ :documentation "Put the pen to paper")НЙ НЙ ("Hide"НЙ :evalНЙ (send *turtle ':hide)НЙ :documentation "Hide the turtle")НЙ НЙ ("Unhide"НЙ :evalНЙ (send *turtle ':unhide)НЙ :documentation "Unhide the turtle")НЙ НЙ ("Go Home"НЙ :evalНЙ (send *turtle ':home)НЙ :documentation "Send the turtle home")НЙ НЙ ("Clear Screen"НЙ :evalНЙ (send *turtle-lake ':refresh)НЙ :documentation "Clear the turtle pond")ННЙ ("Exit"НЙ :evalНЙ (send *turtle-frame ':bury)НЙ :documentationНЙ "Leave the pond")))НМННННННН; This is a small lake for the turtle to live in.Н; Notice that it has pond-mixin as a component flavor.НН(defflavor turtle-lakeНЙ ()НЙ (pond-mixin tv:window)Н (:documentationН "Turtle pond")Н (:default-init-plistН :save-bits tН :label "Turtle Pond")Н :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variables)ННН; Define a prompt pane for prompts and user interaction.НН(defflavor prompt-paneНЙ ()НЙ (tv:pane-mixin tv:window))НННН; The turtle frame ties it all together.НН; ********** FILL IN THE MISSING CODE **********Н(defflavor turtle-frameННЙ )ННЙ Н; Turtle is the top-level function. It makes the turtle frame,Н; then runs a loop reading from the io-buffer, and performingН; the actions indicated.НН(defun turtle ()Н (let* ((*turtle-frame (make-instance 'turtle-frame))НЙ (*command-pane (send *turtle-frameНЙЙЙ ':get-pane 'command-pane))НЙ (*turtle-lake (send *turtle-frameНЙЙЙ ':get-pane 'turtle-pane))НЙ (*prompt-pane (send *turtle-frameНЙЙЙ ':get-pane 'prompt-pane))НЙ (base 10.)НЙ (ibase 10.)НЙ (terminal-io *prompt-pane)НЙ (query-io *prompt-pane)НЙ (error-output *prompt-pane)НЙ *turtle)Н Н (send *turtle-frame ':expose)Н (send *turtle-frame ':activate)Н (send *prompt-pane ':select)Н Н (setq *turtle (make-turtle *turtle-lake))Н (send *turtle ':pendown)Н Н (loop for input = (send *turtle-lake ':any-tyi)НЙ do (cond ((atom input)НЙЙ (selectq inputНЙЙ (#\end (send *turtle-frame ':bury))НЙЙ (t (beep))))НЙЙ ((listp input)НЙЙ (selectq (car input)НЙЙ (:menuНЙЙ (send (fourth input)НЙЙЙ ':execute (second input)))НЙЙ (t (beep))))))))НЙЙЙННН; Put turtle on system key 9. In order to run turtle, doН; 9НН; ********** FILL IN THE MISSING CODE **********НLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 7 :LENGTH-IN-BYTES 7079 :AUTHOR "WILDE" :CREATION-DATE 2716906414 :QFASLP NIL :LENGTH 7079 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "TURTLE-CONSTRAINT-TWO-CONFIG" :TYPE "LISP" :VERSION 8) ;;; -*- Mode:LISP; Package:ICON; Base:10; Fonts:(CPTFONT) -*-ННН;; Copyright (C) 1985 LISP Machine, Incorporated.НН; Title: Constraint FramesН; Subtitle: A two-configuration constraint frame for turtle.Н; Problem solution for exercise to add a configurationН; to the constraint frame, and toggle with a key.Н; File: turtle-constraint-two-config.lisp and .qfasl.ННН; To run, load the file turtle.qfasl, load this file, then doН; 1.ННН; This file sets up a constraint frame for turtle consistingН; of a command pane, a turtle pond pane, and a prompt pane Н; for prompts and user responses.НН; We are dealing with only one turtle here, although the code Н; in turtle is capable of making and handling more.ННН; The turtle frame has two configurations:НН; - standard-configuration, which has the command menu onН; top and the turtle pond on the bottom, andНН; - alternate-configuration, which has the turtle pond on theН; top and the command menu on the bottom.ННН; The following variables are bound in the toplevel functionН; turtle.НН(defvar *turtle-frame :unboundН "The turtle frame")НН(defvar *command-pane :unboundН "The command pane")НН(defvar *turtle-lake :unboundН "The turtle pond")НН(defvar *prompt-pane :unboundН "An interaction and prompting pane")НН(defvar *turtle :unboundН "The turtle")НННН; This is the command pane in the turtle world.НН(defflavor turtle-commandНЙ ()НЙ (tv:command-menu)Н :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variablesН (:documentationН "Turtle Command Pane")Н (:default-init-plistН :font-map '(fonts:bigfnt)Н :columns 4Н :item-list *command-list))НННН; These are the commands that appear in the command pane.НН(defvar *command-listНЙНЙ'(("Set Position"НЙ :evalНЙ (send *turtle :set-posНЙЙ (prompt-and-read :numberНЙЙЙЙ "Enter x pos in pixels: ")НЙЙ (prompt-and-read :numberНЙЙЙЙ "Enter y pos in pixels: "))НЙ :documentation "Set the turtle's position")НЙ НЙ ("Set Heading"НЙ :evalНЙ (send *turtle :set-headingНЙЙ (prompt-and-read :numberНЙЙЙЙ "Enter heading in degrees: "))НЙ :documentation "Set the turtle's position")НЙ НЙ ("Draw Turtle"НЙ :evalНЙ (send *turtle :draw)НЙ :documentation "Draw the turtle in the pond")НЙ НЙ ("Erase Turtle"НЙ :evalНЙ (send *turtle :erase)НЙ :documentation "Erase the turtle")НЙ НЙ ("Move Forward"НЙ :evalНЙ (send *turtle :forwardНЙЙ (prompt-and-read :numberНЙЙЙЙ "How many pixels? "))НЙ :documentation "Move the turtle forward")НЙ НЙ ("Move Backward"НЙ :evalНЙ (send *turtle :backwardНЙЙ (prompt-and-read :numberНЙЙЙЙ "How many pixels? "))НЙ :documentation "Move the turtle backwards")НЙ НЙ ("Turn Right"НЙ :evalНЙ (send *turtle :rightНЙЙ (prompt-and-read :numberНЙЙЙЙ "How many degrees? "))НЙ :documentation "Take a right turn")НЙ НЙ ("Turn Left"НЙ :evalНЙ (send *turtle :leftНЙЙ (prompt-and-read :numberНЙЙЙЙ "How many degrees? "))НЙ :documentation "Take a left turn")НЙ НЙ ("Pen Up"НЙ :evalНЙ (send *turtle :penup)НЙ :documentation "Lift up the pen")НЙ НЙ ("Pen Down"НЙ :evalНЙ (send *turtle :pendown)НЙ :documentation "Put the pen to paper")НЙ НЙ ("Hide"НЙ :evalНЙ (send *turtle :hide)НЙ :documentation "Hide the turtle")НЙ НЙ ("Unhide"НЙ :evalНЙ (send *turtle :unhide)НЙ :documentation "Unhide the turtle")НЙ НЙ ("Go Home"НЙ :evalНЙ (send *turtle :home)НЙ :documentation "Send the turtle home")НЙ НЙ ("Clear Screen"НЙ :evalНЙ (send *turtle-lake :refresh)НЙ :documentation "Clear the turtle pond")НЙ НЙ ("Exit"НЙ :evalНЙ (send *turtle-frame :bury)НЙ :documentationНЙ "Leave the pond")))НННН; This is a small lake for the turtle to live in.Н; Notice that it has pond-mixin as a component flavor.НН(defflavor turtle-lakeНЙ ()НЙ (pond-mixin tv:window)Н (:documentationН "Turtle pond")Н (:default-init-plistН :save-bits tН :label "Turtle Pond")Н :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variables)НННН; Define a prompt pane for prompts and user interaction.НН(defflavor prompt-paneНЙ ()НЙ (tv:pane-mixin tv:window))НННН; The turtle frame ties it all together.Н; Notice that two configurations are defined.НН(defflavor turtle-frameНЙ ()НЙ (tv:bordered-constraint-frame-with-shared-io-buffer)Н :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variablesН (:documentationН "Turtle Frame")Н (:default-init-plistН :expose-p t ; expose w/o blink on instantiationН :activate-p t ; activate on instantiationН :save-bits :delayed ; make save bits array on deexposureН :panesН '((command-pane turtle-command)Н (turtle-pane turtle-lake)Н (prompt-pane prompt-pane))Н :constraintsН '((standard-configurationНЙ(command-pane turtle-pane prompt-pane)НЙ((command-pane :ask :pane-size)) ; as big as it needsНЙ((prompt-pane 8 :lines)) ; 8 linesНЙ((turtle-pane :even))) ; whatever's left overН (alternate-configurationНЙ(turtle-pane command-pane prompt-pane)НЙ((command-pane :ask :pane-size))НЙ((prompt-pane 8 :lines))НЙ((turtle-pane :even))))))НННННН(defun change-display ()НН "Does the work of toggling between configurations on command.НDetermine which configuration is displayed, then go to the otherНone. Refresh the screen when you are done."НН (send *turtle-frameНЙ:set-configurationНЙ(if (eq (send *turtle-frame :configuration)НЙЙ'alternate-configuration)НЙ 'standard-configurationНЙ 'alternate-configuration))Н (send *turtle-lake :refresh))НЙ НН; Turtle is the top-level function. It makes the turtle frame,Н; then runs a loop reading from the io-buffer, and performingН; the actions indicated.НН(defun turtle ()Н (let* ((*turtle-frame (make-instance 'turtle-frame))НЙ (*command-pane (send *turtle-frameНЙЙЙ :get-pane 'command-pane))НЙ (*turtle-lake (send *turtle-frameНЙЙЙ :get-pane 'turtle-pane))НЙ (*prompt-pane (send *turtle-frameНЙЙЙ :get-pane 'prompt-pane))НЙ (base 10.)НЙ (ibase 10.)НЙ (terminal-io *prompt-pane)НЙ (query-io *prompt-pane)НЙ (error-output *prompt-pane)НЙ *turtle)Н Н (send *turtle-frame :expose)Н (send *turtle-frame :activate)Н (send *prompt-pane :select)НН (setq *turtle (make-turtle *turtle-lake))Н (send *turtle :pendown)Н Н (loop for input = (send *prompt-pane :any-tyi)НЙ do (cond ((atom input)НЙЙ (selectq inputНН; Here is where you add conde to intercept keyboard inputН; and do special things with defined keys.Н; Notice that the key "c" has been given the functionalityН; of toggling between the two configurations of the turtleН; constraint frame.ННЙЙ (#/c (change-display)) НЙЙ (#\end (send *turtle-frame :bury))НЙЙ (t (beep))))НЙЙ ((listp input)НЙЙ (selectq (car input)НЙЙ (:menuНЙЙ (send (fourth input)НЙЙЙ :execute (second input)))НЙЙ (t (beep))))))))НЙЙЙННН; Put turtle on system key 1. In order to run turtle, doН; 1НН(tv:add-system-key #\1 '(turtle) "Turtle Pond")LMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 7 :LENGTH-IN-BYTES 7081 :AUTHOR "debbie" :CREATION-DATE 2725558059 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "TURTLE-CONSTRAINT-TWO-CONFIG" :TYPE "LISP" :VERSION 9) ;;; -*- Mode:LISP; Package:(ICON); Base:10; Fonts:(CPTFONT) -*-ННН;; Copyright (C) 1985 LISP Machine, Incorporated.НН; Title: Constraint FramesН; Subtitle: A two-configuration constraint frame for turtle.Н; Problem solution for exercise to add a configurationН; to the constraint frame, and toggle with a key.Н; File: turtle-constraint-two-config.lisp and .qfasl.ННН; To run, load the file turtle.qfasl, load this file, then doН; 1.ННН; This file sets up a constraint frame for turtle consistingН; of a command pane, a turtle pond pane, and a prompt pane Н; for prompts and user responses.НН; We are dealing with only one turtle here, although the code Н; in turtle is capable of making and handling more.ННН; The turtle frame has two configurations:НН; - standard-configuration, which has the command menu onН; top and the turtle pond on the bottom, andНН; - alternate-configuration, which has the turtle pond on theН; top and the command menu on the bottom.ННН; The following variables are bound in the toplevel functionН; turtle.НН(defvar *turtle-frame :unboundН "The turtle frame")НН(defvar *command-pane :unboundН "The command pane")НН(defvar *turtle-lake :unboundН "The turtle pond")НН(defvar *prompt-pane :unboundН "An interaction and prompting pane")НН(defvar *turtle :unboundН "The turtle")НННН; This is the command pane in the turtle world.НН(defflavor turtle-commandНЙ ()НЙ (tv:command-menu)Н :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variablesН (:documentationН "Turtle Command Pane")Н (:default-init-plistН :font-map '(fonts:bigfnt)Н :columns 4Н :item-list *command-list))НННН; These are the commands that appear in the command pane.НН(defvar *command-listНЙНЙ'(("Set Position"НЙ :evalНЙ (send *turtle :set-posНЙЙ (prompt-and-read :numberНЙЙЙЙ "Enter x pos in pixels: ")НЙЙ (prompt-and-read :numberНЙЙЙЙ "Enter y pos in pixels: "))НЙ :documentation "Set the turtle's position")НЙ НЙ ("Set Heading"НЙ :evalНЙ (send *turtle :set-headingНЙЙ (prompt-and-read :numberНЙЙЙЙ "Enter heading in degrees: "))НЙ :documentation "Set the turtle's position")НЙ НЙ ("Draw Turtle"НЙ :evalНЙ (send *turtle :draw)НЙ :documentation "Draw the turtle in the pond")НЙ НЙ ("Erase Turtle"НЙ :evalНЙ (send *turtle :erase)НЙ :documentation "Erase the turtle")НЙ НЙ ("Move Forward"НЙ :evalНЙ (send *turtle :forwardНЙЙ (prompt-and-read :numberНЙЙЙЙ "How many pixels? "))НЙ :documentation "Move the turtle forward")НЙ НЙ ("Move Backward"НЙ :evalНЙ (send *turtle :backwardНЙЙ (prompt-and-read :numberНЙЙЙЙ "How many pixels? "))НЙ :documentation "Move the turtle backwards")НЙ НЙ ("Turn Right"НЙ :evalНЙ (send *turtle :rightНЙЙ (prompt-and-read :numberНЙЙЙЙ "How many degrees? "))НЙ :documentation "Take a right turn")НЙ НЙ ("Turn Left"НЙ :evalНЙ (send *turtle :leftНЙЙ (prompt-and-read :numberНЙЙЙЙ "How many degrees? "))НЙ :documentation "Take a left turn")НЙ НЙ ("Pen Up"НЙ :evalНЙ (send *turtle :penup)НЙ :documentation "Lift up the pen")НЙ НЙ ("Pen Down"НЙ :evalНЙ (send *turtle :pendown)НЙ :documentation "Put the pen to paper")НЙ НЙ ("Hide"НЙ :evalНЙ (send *turtle :hide)НЙ :documentation "Hide the turtle")НЙ НЙ ("Unhide"НЙ :evalНЙ (send *turtle :unhide)НЙ :documentation "Unhide the turtle")НЙ НЙ ("Go Home"НЙ :evalНЙ (send *turtle :home)НЙ :documentation "Send the turtle home")НЙ НЙ ("Clear Screen"НЙ :evalНЙ (send *turtle-lake :refresh)НЙ :documentation "Clear the turtle pond")НЙ НЙ ("Exit"НЙ :evalНЙ (send *turtle-frame :bury)НЙ :documentationНЙ "Leave the pond")))НННН; This is a small lake for the turtle to live in.Н; Notice that it has pond-mixin as a component flavor.НН(defflavor turtle-lakeНЙ ()НЙ (pond-mixin tv:window)Н (:documentationН "Turtle pond")Н (:default-init-plistН :save-bits tН :label "Turtle Pond")Н :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variables)НННН; Define a prompt pane for prompts and user interaction.НН(defflavor prompt-paneНЙ ()НЙ (tv:pane-mixin tv:window))НННН; The turtle frame ties it all together.Н; Notice that two configurations are defined.НН(defflavor turtle-frameНЙ ()НЙ (tv:bordered-constraint-frame-with-shared-io-buffer)Н :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variablesН (:documentationН "Turtle Frame")Н (:default-init-plistН :expose-p t ; expose w/o blink on instantiationН :activate-p t ; activate on instantiationН :save-bits :delayed ; make save bits array on deexposureН :panesН '((command-pane turtle-command)Н (turtle-pane turtle-lake)Н (prompt-pane prompt-pane))Н :constraintsН '((standard-configurationНЙ(command-pane turtle-pane prompt-pane)НЙ((command-pane :ask :pane-size)) ; as big as it needsНЙ((prompt-pane 8 :lines)) ; 8 linesНЙ((turtle-pane :even))) ; whatever's left overН (alternate-configurationНЙ(turtle-pane command-pane prompt-pane)НЙ((command-pane :ask :pane-size))НЙ((prompt-pane 8 :lines))НЙ((turtle-pane :even))))))НННННН(defun change-display ()НН "Does the work of toggling between configurations on command.НDetermine which configuration is displayed, then go to the otherНone. Refresh the screen when you are done."НН (send *turtle-frameНЙ:set-configurationНЙ(if (eq (send *turtle-frame :configuration)НЙЙ'alternate-configuration)НЙ 'standard-configurationНЙ 'alternate-configuration))Н (send *turtle-lake :refresh))НЙ НН; Turtle is the top-level function. It makes the turtle frame,Н; then runs a loop reading from the io-buffer, and performingН; the actions indicated.НН(defun turtle ()Н (let* ((*turtle-frame (make-instance 'turtle-frame))НЙ (*command-pane (send *turtle-frameНЙЙЙ :get-pane 'command-pane))НЙ (*turtle-lake (send *turtle-frameНЙЙЙ :get-pane 'turtle-pane))НЙ (*prompt-pane (send *turtle-frameНЙЙЙ :get-pane 'prompt-pane))НЙ (base 10.)НЙ (ibase 10.)НЙ (terminal-io *prompt-pane)НЙ (query-io *prompt-pane)НЙ (error-output *prompt-pane)НЙ *turtle)Н Н (send *turtle-frame :expose)Н (send *turtle-frame :activate)Н (send *prompt-pane :select)НН (setq *turtle (make-turtle *turtle-lake))Н (send *turtle :pendown)Н Н (loop for input = (send *prompt-pane :any-tyi)НЙ do (cond ((atom input)НЙЙ (selectq inputНН; Here is where you add conde to intercept keyboard inputН; and do special things with defined keys.Н; Notice that the key "c" has been given the functionalityН; of toggling between the two configurations of the turtleН; constraint frame.ННЙЙ (#/c (change-display)) НЙЙ (#\end (send *turtle-frame :bury))НЙЙ (t (beep))))НЙЙ ((listp input)НЙЙ (selectq (car input)НЙЙ (:menuНЙЙ (send (fourth input)НЙЙЙ :execute (second input)))НЙЙ (t (beep))))))))НЙЙЙННН; Put turtle on system key 1. In order to run turtle, doН; 1НН(tv:add-system-key #\1 '(turtle) "Turtle Pond")LMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 5 :LENGTH-IN-BYTES 4270 :AUTHOR "WILDE" :CREATION-DATE 2716906511 :QFASLP NIL :LENGTH 4270 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "TURTLE-HACKS" :TYPE "LISP" :VERSION 2) ;;; -*- Mode:LISP; Package:ICON; Fonts:(CPTFONT); Base:10 -*-НН;; Copyright (C) 1984 LISP Machine, Incorporated.ННН(defflavor turtle-pond ((doc))НЙ (tv:list-mouse-buttons-mixin pond-mixin tv:window))НН(defmethod (turtle-pond :set-doc) (d)Н (setq doc d))НН(defflavor pond-window ((turtle-list))НЙ (tv:process-mixin tv:select-mixinНЙ tv:stream-mixinНЙ tv:bordered-constraint-frame-with-shared-io-buffer)Н :gettable-instance-variablesН :settable-instance-variables)НН(defmethod (turtle-pond :handle-mouse) (&aux bl)Н (setq bl (tv:mouse-set-blinker-definitionНЙ :character 6. 7. :onНЙ :set-character 37))Н (tv:mouse-default-handler self nil)Н (tv:blinker-set-visibility bl nil))НН(defmethod (turtle-pond :who-line-documentation-string) ()Н doc)НН(defun make-pond-window ()Н (make-instanceН 'pond-windowН :process '(manage-pond-window)Н :panesН '((pond turtle-pondНЙ :label nil :blinker-p nil)Н (menu-pane tv:command-menuНЙЙ :item-listНЙЙ (("Set Speed" :value SPEEDНЙЙ :documentationНЙЙ "Set the Speed of an exposed Turtle")НЙЙ ("Reverse Direction" :value REVERSEНЙЙ :documentationНЙЙ "Make an exposed Turtle back up")НЙЙ ("Turn Left" :value LEFTНЙЙ :documentation "Turn an exposed Turtle left")НЙЙ ("Turn Right" :value RIGHTНЙЙ :documentation "Turn an exposed Turtle right")НЙЙ ("Lift Pen" :value LIFTНЙЙ :documentation "Lift an exposed Turtle's pen")НЙЙ ("Lower Pen" :value LOWERНЙЙ :documentationНЙЙ "Lower an exposed Turtle's pen")НЙЙ ("Make New Turtle" :value CREATEНЙЙ :documentationНЙЙ "Create a new exposed Turtle at 0,0"))))Н :constraintsН '((main . ((pond menu-pane)НЙ ((menu-pane 2 :lines))НЙ ((pond :even)))))))ННН(defvar *test-var* ())НН(defun manage-pond-window (window)Н (do-foreverН (handle-clicks window)))НН(defun handle-clicks (window &aux click)Н (setq click (send window :any-tyi))Н (if (not (numberp click))Н (if (equal (car click)НЙЙ :MENU)НЙ (selectq (get (cadr click) :VALUE)НЙ (CREATEНЙ (sendНЙ (send window :get-pane 'pond) :set-docНЙ "Please indicate where to place the new Turtle")НЙ (tv:mouse-warpНЙ (// (send tv:mouse-sheet :width) 2)НЙ НЙ (// (send tv:mouse-sheet :height) 2))НЙ (setq click nil)НЙ (do ()НЙЙ (click)НЙ (setq click (send window :any-tyi))НЙ (if (numberp click)НЙЙ (setq click nil)НЙЙ (if (not (equal (car click) :MOUSE-BUTTON))НЙЙ (setq click nil))))НЙ (push (make-turtleНЙЙ (send window :get-pane 'pond)НЙЙ :xcor (fourth click)НЙЙ :ycor (fifth click))НЙЙ (send window :turtle-list))НЙ (send (send window :get-pane 'pond) :set-doc nil))НЙ (SPEEDНЙ (send (choose-turtle window)НЙЙ :FORWARD (enter-distance)))НЙ (LOWERНЙ (send (choose-turtle window) :pd ))НЙ (RIGHTНЙ (send (choose-turtle window) :right (enter-angle)))НЙ (LEFTНЙ (send (choose-turtle window) :left (enter-angle)))НЙ (LIFTНЙ (send (choose-turtle window) :pu))НЙ (REVERSEНЙ (send (choose-turtle window)НЙЙ :BK (enter-distance)))))))НН(defun choose-turtle (window &aux click turtle (dist 888888888))Н (send (send window :get-pane 'pond) :set-docНЙ"Please indicate which Turtle to use")Н (tv:mouse-warp (// (send tv:mouse-sheet :width) 2)НЙЙ (// (send tv:mouse-sheet :height) 2))Н (setq click nil)Н (do ()Н (click)Н (setq click (send window :any-tyi))Н (if (numberp click)НЙ(setq click nil)Н (if (not (equal (car click) :MOUSE-BUTTON))НЙ (setq click nil))))Н (dolist (turt (send window :turtle-list))Н (if (< (sqrt (+ (^ (- (fourth click) (send turt :xcor)) 2)НЙЙ (^ (- (fifth click) (send turt :ycor)) 2)))НЙ dist)НЙ(setq turtle turtНЙ dist (sqrt (+ (^ (- (fourth click)НЙЙЙЙ (send turt :xcor)) 2)НЙЙЙ (^ (- (fifth click)НЙЙЙЙ (send turt :ycor)) 2))))))Н (send (send window :get-pane 'pond) :set-doc nil)Н turtle)НН(defvar *holding-value* 10.)Н(defvar *holding-angle* 45.)НН(defun enter-distance ()Н (let ((ibase 10.) (base 10.))Н (tv:choose-variable-valuesН '((*holding-value* "Distance to move" :number)))Н *holding-value*))НН(defun enter-angle ()Н (let ((ibase 10.) (base 10.))Н (tv:choose-variable-valuesН '((*holding-angle* "Angle" :number)))Н *holding-angle*))ННLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 5 :LENGTH-IN-BYTES 4272 :AUTHOR "debbie" :CREATION-DATE 2725558092 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "TURTLE-HACKS" :TYPE "LISP" :VERSION 3) ;;; -*- Mode:LISP; Package:(ICON); Fonts:(CPTFONT); Base:10 -*-НН;; Copyright (C) 1984 LISP Machine, Incorporated.ННН(defflavor turtle-pond ((doc))НЙ (tv:list-mouse-buttons-mixin pond-mixin tv:window))НН(defmethod (turtle-pond :set-doc) (d)Н (setq doc d))НН(defflavor pond-window ((turtle-list))НЙ (tv:process-mixin tv:select-mixinНЙ tv:stream-mixinНЙ tv:bordered-constraint-frame-with-shared-io-buffer)Н :gettable-instance-variablesН :settable-instance-variables)НН(defmethod (turtle-pond :handle-mouse) (&aux bl)Н (setq bl (tv:mouse-set-blinker-definitionНЙ :character 6. 7. :onНЙ :set-character 37))Н (tv:mouse-default-handler self nil)Н (tv:blinker-set-visibility bl nil))НН(defmethod (turtle-pond :who-line-documentation-string) ()Н doc)НН(defun make-pond-window ()Н (make-instanceН 'pond-windowН :process '(manage-pond-window)Н :panesН '((pond turtle-pondНЙ :label nil :blinker-p nil)Н (menu-pane tv:command-menuНЙЙ :item-listНЙЙ (("Set Speed" :value SPEEDНЙЙ :documentationНЙЙ "Set the Speed of an exposed Turtle")НЙЙ ("Reverse Direction" :value REVERSEНЙЙ :documentationНЙЙ "Make an exposed Turtle back up")НЙЙ ("Turn Left" :value LEFTНЙЙ :documentation "Turn an exposed Turtle left")НЙЙ ("Turn Right" :value RIGHTНЙЙ :documentation "Turn an exposed Turtle right")НЙЙ ("Lift Pen" :value LIFTНЙЙ :documentation "Lift an exposed Turtle's pen")НЙЙ ("Lower Pen" :value LOWERНЙЙ :documentationНЙЙ "Lower an exposed Turtle's pen")НЙЙ ("Make New Turtle" :value CREATEНЙЙ :documentationНЙЙ "Create a new exposed Turtle at 0,0"))))Н :constraintsН '((main . ((pond menu-pane)НЙ ((menu-pane 2 :lines))НЙ ((pond :even)))))))ННН(defvar *test-var* ())НН(defun manage-pond-window (window)Н (do-foreverН (handle-clicks window)))НН(defun handle-clicks (window &aux click)Н (setq click (send window :any-tyi))Н (if (not (numberp click))Н (if (equal (car click)НЙЙ :MENU)НЙ (selectq (get (cadr click) :VALUE)НЙ (CREATEНЙ (sendНЙ (send window :get-pane 'pond) :set-docНЙ "Please indicate where to place the new Turtle")НЙ (tv:mouse-warpНЙ (// (send tv:mouse-sheet :width) 2)НЙ НЙ (// (send tv:mouse-sheet :height) 2))НЙ (setq click nil)НЙ (do ()НЙЙ (click)НЙ (setq click (send window :any-tyi))НЙ (if (numberp click)НЙЙ (setq click nil)НЙЙ (if (not (equal (car click) :MOUSE-BUTTON))НЙЙ (setq click nil))))НЙ (push (make-turtleНЙЙ (send window :get-pane 'pond)НЙЙ :xcor (fourth click)НЙЙ :ycor (fifth click))НЙЙ (send window :turtle-list))НЙ (send (send window :get-pane 'pond) :set-doc nil))НЙ (SPEEDНЙ (send (choose-turtle window)НЙЙ :FORWARD (enter-distance)))НЙ (LOWERНЙ (send (choose-turtle window) :pd ))НЙ (RIGHTНЙ (send (choose-turtle window) :right (enter-angle)))НЙ (LEFTНЙ (send (choose-turtle window) :left (enter-angle)))НЙ (LIFTНЙ (send (choose-turtle window) :pu))НЙ (REVERSEНЙ (send (choose-turtle window)НЙЙ :BK (enter-distance)))))))НН(defun choose-turtle (window &aux click turtle (dist 888888888))Н (send (send window :get-pane 'pond) :set-docНЙ"Please indicate which Turtle to use")Н (tv:mouse-warp (// (send tv:mouse-sheet :width) 2)НЙЙ (// (send tv:mouse-sheet :height) 2))Н (setq click nil)Н (do ()Н (click)Н (setq click (send window :any-tyi))Н (if (numberp click)НЙ(setq click nil)Н (if (not (equal (car click) :MOUSE-BUTTON))НЙ (setq click nil))))Н (dolist (turt (send window :turtle-list))Н (if (< (sqrt (+ (^ (- (fourth click) (send turt :xcor)) 2)НЙЙ (^ (- (fifth click) (send turt :ycor)) 2)))НЙ dist)НЙ(setq turtle turtНЙ dist (sqrt (+ (^ (- (fourth click)НЙЙЙЙ (send turt :xcor)) 2)НЙЙЙ (^ (- (fifth click)НЙЙЙЙ (send turt :ycor)) 2))))))Н (send (send window :get-pane 'pond) :set-doc nil)Н turtle)НН(defvar *holding-value* 10.)Н(defvar *holding-angle* 45.)НН(defun enter-distance ()Н (let ((ibase 10.) (base 10.))Н (tv:choose-variable-valuesН '((*holding-value* "Distance to move" :number)))Н *holding-value*))НН(defun enter-angle ()Н (let ((ibase 10.) (base 10.))Н (tv:choose-variable-valuesН '((*holding-angle* "Angle" :number)))Н *holding-angle*))ННLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 2 :LENGTH-IN-BYTES 1548 :AUTHOR "WILDE" :CREATION-DATE 2716906555 :QFASLP NIL :LENGTH 1548 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "TURTLE-POND" :TYPE "LISP" :VERSION 2) ;;; -*- Mode:LISP; Package:ICON; Base:10 -*-НН;; Copyright (C) 1985 LISP Machine, Incorporated.НН;;; Load this file after TURTLE.LISP to initialize a window (*MY-POND*)Н;;; for making turtlesНН;;; To use this new window effectively, execute the following sequence:Н;;; (icon:start-turtle) -> gets you into a new lisp listenerН;;; with a pond mixinН;;; (pkg-goto 'icon) -> sets the package to iconН;;; You are then ready to create turtles.Н;;; A turtle is made with:Н;;; (MAKE-TURTLE . )Н;;; For example:Н;;; (SETQ TOM (MAKE-TURTLE *MY-POND* :HEADING 180))Н;;; Remember to send a pen down message the first time a turtle isН;;; created. For example:Н;;; (SEND TOM :PD)Н;;; Now you are ready to play with moving the turtles. For example:Н;;; (SEND TOM :FD 50)ННН(defvar *my-pond* () "The window in which the turtles live")ННН;;; POND is a window with a pond mixin that can handle turtles Н(defflavor pondНЙ ()НЙ (pond-mixin tv:lisp-listener))Н НН;;; Function START-TURTLE creates an instance of a pond (*MY-POND*)Н;;; that is ready to accept turtles. Н(defun start-turtle ()Н "Creates a window for drawing turtles."Н (cond (*my-pond*НЙ (send *my-pond* :select)НЙ *my-pond*)НЙ(t (setq *my-pond* (make-instance 'pond))НЙ (send *my-pond* :select))))НННН;;; Function SPIRAL is an example of turtle movement.Н(defun spiral (turtle)Н "Moves the turtle in a spiral."Н (loop for size from 1 to 100НЙdo (send turtle :fd size)НЙ (send turtle :rt 112.)))LMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 2 :LENGTH-IN-BYTES 1550 :AUTHOR "debbie" :CREATION-DATE 2725558114 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "TURTLE-POND" :TYPE "LISP" :VERSION 3) ;;; -*- Mode:LISP; Package:(ICON); Base:10 -*-НН;; Copyright (C) 1985 LISP Machine, Incorporated.НН;;; Load this file after TURTLE.LISP to initialize a window (*MY-POND*)Н;;; for making turtlesНН;;; To use this new window effectively, execute the following sequence:Н;;; (icon:start-turtle) -> gets you into a new lisp listenerН;;; with a pond mixinН;;; (pkg-goto 'icon) -> sets the package to iconН;;; You are then ready to create turtles.Н;;; A turtle is made with:Н;;; (MAKE-TURTLE . )Н;;; For example:Н;;; (SETQ TOM (MAKE-TURTLE *MY-POND* :HEADING 180))Н;;; Remember to send a pen down message the first time a turtle isН;;; created. For example:Н;;; (SEND TOM :PD)Н;;; Now you are ready to play with moving the turtles. For example:Н;;; (SEND TOM :FD 50)ННН(defvar *my-pond* () "The window in which the turtles live")ННН;;; POND is a window with a pond mixin that can handle turtles Н(defflavor pondНЙ ()НЙ (pond-mixin tv:lisp-listener))Н НН;;; Function START-TURTLE creates an instance of a pond (*MY-POND*)Н;;; that is ready to accept turtles. Н(defun start-turtle ()Н "Creates a window for drawing turtles."Н (cond (*my-pond*НЙ (send *my-pond* :select)НЙ *my-pond*)НЙ(t (setq *my-pond* (make-instance 'pond))НЙ (send *my-pond* :select))))НННН;;; Function SPIRAL is an example of turtle movement.Н(defun spiral (turtle)Н "Moves the turtle in a spiral."Н (loop for size from 1 to 100НЙdo (send turtle :fd size)НЙ (send turtle :rt 112.)))LMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 8 :LENGTH-IN-BYTES 7732 :AUTHOR "WILDE" :CREATION-DATE 2716906632 :QFASLP NIL :LENGTH 7732 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "TURTLE-PROCESS" :TYPE "LISP" :VERSION 3) ;;; -*- Mode:LISP; Package:ICON; Base:10; Fonts:(CPTFONT) -*-НН;; Copyright (C) 1985 LISP Machine, Incorporated.НН; Title: ProcessesН; Subtitle: Turtle as a process.Н; File: turtle-process.lisp and .qfaslННН; To run, load the file turtle.qfasl, load this file, then doН; 1.ННН; This file sets up a constraint frame for turtle consistingН; of a command pane, a turtle pond pane, and a prompt paneН; for prompts and user responses.НН; The constraint frame has an init option of :process,Н; which sets up a process when the window is instantiated.Н; the function turtle-initial-function is the initial function,Н; and it is given the window as an argument. Н; Turtle-initial-function now does most of the work done by Н; the function turtle in previous versions.НН; The function turtle now just creates and returns the Н; constraint frame.ННН; We are dealing with only one turtle here, although the code Н; in turtle is capable of making and handling more.НН; The turtle frame has two configurations:НН; - standard-configuration, which has the command menu onН; top and the turtle pond on the bottom, andНН; - alternate-configuration, which has the turtle pond on theН; top and the command menu on the bottom.ННН; The following variables are bound in the toplevel functionН; turtle-initial-function.НН(defvar *turtle-frame :unboundН "The turtle frame")НН(defvar *command-pane :unboundН "The command pane")НН(defvar *turtle-lake :unboundН "The turtle pond")НН(defvar *prompt-pane :unboundН "An interaction and prompting pane")НН(defvar *turtle :unboundН "The turtle")НННН; This is the command pane in the turtle world.НН(defflavor turtle-commandНЙ ()НЙ (tv:command-menu)Н :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variablesН (:documentationН "Turtle Command Pane")Н (:default-init-plistН :font-map '(fonts:bigfnt)Н :columns 4Н :item-list *command-list))НННН; These are the commands that appear in the command pane.НН(defvar *command-listНЙНЙ'(("Set Position"НЙ :evalНЙ (send *turtle :set-posНЙЙ (prompt-and-read :numberНЙЙЙЙ "Enter x pos in pixels: ")НЙЙ (prompt-and-read :numberНЙЙЙЙ "Enter y pos in pixels: "))НЙ :documentation "Set the turtle's position")НЙ НЙ ("Set Heading"НЙ :evalНЙ (send *turtle :set-headingНЙЙ (prompt-and-read :numberНЙЙЙЙ "Enter heading in degrees: "))НЙ :documentation "Set the turtle's position")НЙ НЙ ("Draw Turtle"НЙ :evalНЙ (send *turtle :draw)НЙ :documentation "Draw the turtle in the pond")НЙ НЙ ("Erase Turtle"НЙ :evalНЙ (send *turtle :erase)НЙ :documentation "Erase the turtle")НЙ НЙ ("Move Forward"НЙ :evalНЙ (send *turtle :forwardНЙЙ (prompt-and-read :numberНЙЙЙЙ "How many pixels? "))НЙ :documentation "Move the turtle forward")НЙ НЙ ("Move Backward"НЙ :evalНЙ (send *turtle :backwardНЙЙ (prompt-and-read :numberНЙЙЙЙ "How many pixels? "))НЙ :documentation "Move the turtle backwards")НЙ НЙ ("Turn Right"НЙ :evalНЙ (send *turtle :rightНЙЙ (prompt-and-read :numberНЙЙЙЙ "How many degrees? "))НЙ :documentation "Take a right turn")НЙ НЙ ("Turn Left"НЙ :evalНЙ (send *turtle :leftНЙЙ (prompt-and-read :numberНЙЙЙЙ "How many degrees? "))НЙ :documentation "Take a left turn")НЙ НЙ ("Pen Up"НЙ :evalНЙ (send *turtle :penup)НЙ :documentation "Lift up the pen")НЙ НЙ ("Pen Down"НЙ :evalНЙ (send *turtle :pendown)НЙ :documentation "Put the pen to paper")НЙ НЙ ("Hide"НЙ :evalНЙ (send *turtle :hide)НЙ :documentation "Hide the turtle")НЙ НЙ ("Unhide"НЙ :evalНЙ (send *turtle :unhide)НЙ :documentation "Unhide the turtle")НЙ НЙ ("Go Home"НЙ :evalНЙ (send *turtle :home)НЙ :documentation "Send the turtle home")НЙ НЙ ("Clear Screen"НЙ :evalНЙ (send *turtle-lake :refresh)НЙ :documentation "Clear the turtle pond")НЙ НЙ ("Exit"НЙ :evalНЙ (send *turtle-frame :bury)НЙ :documentationНЙ "Leave the pond")))НННН; This is a small lake for the turtle to live in.Н; Notice that it has pond-mixin as a component flavor.НН(defflavor turtle-lakeНЙ ()НЙ (pond-mixin tv:window)Н (:documentationН "Turtle pond")Н (:default-init-plistН :save-bits tН :label "Turtle Pond")Н :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variables)НННН; Define a prompt pane for prompts and user interaction.НН(defflavor prompt-paneНЙ ()НЙ (tv:pane-mixin tv:window))НННН; The turtle frame ties it all together.Н; Notice that two configurations are defined, and thatН; the frame has a :process init option, with Н; turtle-initial-function as the initial function.НН(defflavor turtle-frameНЙ ()НЙ (tv:process-mixinНЙ tv:bordered-constraint-frame-with-shared-io-buffer)Н :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variablesН (:documentationН "Turtle Frame")Н (:default-init-plistН :expose-p t ; expose w/o blink on instantiationН :activate-p t ; activate on instantiationН :save-bits :delayed ; make save bits array on deexposureН :process '(turtle-initial-function)Н :panesН '((command-pane turtle-command)Н (turtle-pane turtle-lake)Н (prompt-pane prompt-pane))Н :constraintsН '((standard-configurationНЙ(command-pane turtle-pane prompt-pane)НЙ((command-pane :ask :pane-size)) ; as big as it needsНЙ((prompt-pane 8 :lines)) ; 8 linesНЙ((turtle-pane :even))) ; whatever's left overН (alternate-configurationНЙ(turtle-pane command-pane prompt-pane)НЙ((command-pane :ask :pane-size))НЙ((prompt-pane 8 :lines))НЙ((turtle-pane :even))))))НННННН(defun change-display ()НН "Does the work of toggling between configurations on command.НDetermine which configuration is displayed, then go to the otherНone. Refresh the screen when you are done."НН (send *turtle-frameНЙ:set-configurationНЙ(if (eq (send *turtle-frame :configuration)НЙЙ'alternate-configuration)НЙ 'standard-configurationНЙ 'alternate-configuration))Н (send *turtle-lake :refresh))НЙ ННН; Turtle-initial-function is the function called when Н; turtle-frame is instantiated by the function turtle. Н; Turtle-initial-function has a single argument - the Н; instantiated window. Н; The function turtle is called when you do 1.ННН(defun turtle-initial-function (window)Н (let* ((*turtle-frame window)НЙ (*command-pane (send *turtle-frameНЙЙЙ :get-pane 'command-pane))НЙ (*turtle-lake (send *turtle-frameНЙЙЙ :get-pane 'turtle-pane))НЙ (*prompt-pane (send *turtle-frameНЙЙЙ :get-pane 'prompt-pane))НЙ (base 10.)НЙ (ibase 10.)НЙ (terminal-io *prompt-pane)НЙ (query-io *prompt-pane)НЙ (error-output *prompt-pane)НЙ *turtle)Н Н (send *prompt-pane :select)НН (setq *turtle (make-turtle *turtle-lake))Н Н (loop for input = (send *prompt-pane :any-tyi)НЙ do (cond ((atom input)НЙЙ (selectq inputНН; Here is where you add code to intercept keyboard inputН; and do special things with defined keys.Н; Notice that the key "c" has been given the functionalityН; of toggling between the two configurations of the turtleН; constraint frame.ННЙЙ (#/c (change-display))НЙЙ (#\end (send *turtle-frame :bury))НЙЙ (t (beep))))НЙЙ ((listp input)НЙЙ (selectq (car input)НЙЙ (:menuНЙЙ (send (fourth input)НЙЙЙ :execute (second input)))НЙЙ (t (beep))))))))ННН; Turtle creates and returns an instance of turtle-frame.НН(defun turtle ()Н (setq *turtle-frame (make-instance 'turtle-frame))Н (send *turtle-frame :activate)Н (send *turtle-frame :expose)Н (tv:await-window-exposure)Н *turtle-frame)ННН; Put turtle on system key 1. In order to run turtle, doН; 1Н Н(tv:add-system-key #\1 '(turtle) "Turtle Lake")LMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 8 :LENGTH-IN-BYTES 7734 :AUTHOR "debbie" :CREATION-DATE 2725558132 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "TURTLE-PROCESS" :TYPE "LISP" :VERSION 4) ;;; -*- Mode:LISP; Package:(ICON); Base:10; Fonts:(CPTFONT) -*-НН;; Copyright (C) 1985 LISP Machine, Incorporated.НН; Title: ProcessesН; Subtitle: Turtle as a process.Н; File: turtle-process.lisp and .qfaslННН; To run, load the file turtle.qfasl, load this file, then doН; 1.ННН; This file sets up a constraint frame for turtle consistingН; of a command pane, a turtle pond pane, and a prompt paneН; for prompts and user responses.НН; The constraint frame has an init option of :process,Н; which sets up a process when the window is instantiated.Н; the function turtle-initial-function is the initial function,Н; and it is given the window as an argument. Н; Turtle-initial-function now does most of the work done by Н; the function turtle in previous versions.НН; The function turtle now just creates and returns the Н; constraint frame.ННН; We are dealing with only one turtle here, although the code Н; in turtle is capable of making and handling more.НН; The turtle frame has two configurations:НН; - standard-configuration, which has the command menu onН; top and the turtle pond on the bottom, andНН; - alternate-configuration, which has the turtle pond on theН; top and the command menu on the bottom.ННН; The following variables are bound in the toplevel functionН; turtle-initial-function.НН(defvar *turtle-frame :unboundН "The turtle frame")НН(defvar *command-pane :unboundН "The command pane")НН(defvar *turtle-lake :unboundН "The turtle pond")НН(defvar *prompt-pane :unboundН "An interaction and prompting pane")НН(defvar *turtle :unboundН "The turtle")НННН; This is the command pane in the turtle world.НН(defflavor turtle-commandНЙ ()НЙ (tv:command-menu)Н :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variablesН (:documentationН "Turtle Command Pane")Н (:default-init-plistН :font-map '(fonts:bigfnt)Н :columns 4Н :item-list *command-list))НННН; These are the commands that appear in the command pane.НН(defvar *command-listНЙНЙ'(("Set Position"НЙ :evalНЙ (send *turtle :set-posНЙЙ (prompt-and-read :numberНЙЙЙЙ "Enter x pos in pixels: ")НЙЙ (prompt-and-read :numberНЙЙЙЙ "Enter y pos in pixels: "))НЙ :documentation "Set the turtle's position")НЙ НЙ ("Set Heading"НЙ :evalНЙ (send *turtle :set-headingНЙЙ (prompt-and-read :numberНЙЙЙЙ "Enter heading in degrees: "))НЙ :documentation "Set the turtle's position")НЙ НЙ ("Draw Turtle"НЙ :evalНЙ (send *turtle :draw)НЙ :documentation "Draw the turtle in the pond")НЙ НЙ ("Erase Turtle"НЙ :evalНЙ (send *turtle :erase)НЙ :documentation "Erase the turtle")НЙ НЙ ("Move Forward"НЙ :evalНЙ (send *turtle :forwardНЙЙ (prompt-and-read :numberНЙЙЙЙ "How many pixels? "))НЙ :documentation "Move the turtle forward")НЙ НЙ ("Move Backward"НЙ :evalНЙ (send *turtle :backwardНЙЙ (prompt-and-read :numberНЙЙЙЙ "How many pixels? "))НЙ :documentation "Move the turtle backwards")НЙ НЙ ("Turn Right"НЙ :evalНЙ (send *turtle :rightНЙЙ (prompt-and-read :numberНЙЙЙЙ "How many degrees? "))НЙ :documentation "Take a right turn")НЙ НЙ ("Turn Left"НЙ :evalНЙ (send *turtle :leftНЙЙ (prompt-and-read :numberНЙЙЙЙ "How many degrees? "))НЙ :documentation "Take a left turn")НЙ НЙ ("Pen Up"НЙ :evalНЙ (send *turtle :penup)НЙ :documentation "Lift up the pen")НЙ НЙ ("Pen Down"НЙ :evalНЙ (send *turtle :pendown)НЙ :documentation "Put the pen to paper")НЙ НЙ ("Hide"НЙ :evalНЙ (send *turtle :hide)НЙ :documentation "Hide the turtle")НЙ НЙ ("Unhide"НЙ :evalНЙ (send *turtle :unhide)НЙ :documentation "Unhide the turtle")НЙ НЙ ("Go Home"НЙ :evalНЙ (send *turtle :home)НЙ :documentation "Send the turtle home")НЙ НЙ ("Clear Screen"НЙ :evalНЙ (send *turtle-lake :refresh)НЙ :documentation "Clear the turtle pond")НЙ НЙ ("Exit"НЙ :evalНЙ (send *turtle-frame :bury)НЙ :documentationНЙ "Leave the pond")))НННН; This is a small lake for the turtle to live in.Н; Notice that it has pond-mixin as a component flavor.НН(defflavor turtle-lakeНЙ ()НЙ (pond-mixin tv:window)Н (:documentationН "Turtle pond")Н (:default-init-plistН :save-bits tН :label "Turtle Pond")Н :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variables)НННН; Define a prompt pane for prompts and user interaction.НН(defflavor prompt-paneНЙ ()НЙ (tv:pane-mixin tv:window))НННН; The turtle frame ties it all together.Н; Notice that two configurations are defined, and thatН; the frame has a :process init option, with Н; turtle-initial-function as the initial function.НН(defflavor turtle-frameНЙ ()НЙ (tv:process-mixinНЙ tv:bordered-constraint-frame-with-shared-io-buffer)Н :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variablesН (:documentationН "Turtle Frame")Н (:default-init-plistН :expose-p t ; expose w/o blink on instantiationН :activate-p t ; activate on instantiationН :save-bits :delayed ; make save bits array on deexposureН :process '(turtle-initial-function)Н :panesН '((command-pane turtle-command)Н (turtle-pane turtle-lake)Н (prompt-pane prompt-pane))Н :constraintsН '((standard-configurationНЙ(command-pane turtle-pane prompt-pane)НЙ((command-pane :ask :pane-size)) ; as big as it needsНЙ((prompt-pane 8 :lines)) ; 8 linesНЙ((turtle-pane :even))) ; whatever's left overН (alternate-configurationНЙ(turtle-pane command-pane prompt-pane)НЙ((command-pane :ask :pane-size))НЙ((prompt-pane 8 :lines))НЙ((turtle-pane :even))))))НННННН(defun change-display ()НН "Does the work of toggling between configurations on command.НDetermine which configuration is displayed, then go to the otherНone. Refresh the screen when you are done."НН (send *turtle-frameНЙ:set-configurationНЙ(if (eq (send *turtle-frame :configuration)НЙЙ'alternate-configuration)НЙ 'standard-configurationНЙ 'alternate-configuration))Н (send *turtle-lake :refresh))НЙ ННН; Turtle-initial-function is the function called when Н; turtle-frame is instantiated by the function turtle. Н; Turtle-initial-function has a single argument - the Н; instantiated window. Н; The function turtle is called when you do 1.ННН(defun turtle-initial-function (window)Н (let* ((*turtle-frame window)НЙ (*command-pane (send *turtle-frameНЙЙЙ :get-pane 'command-pane))НЙ (*turtle-lake (send *turtle-frameНЙЙЙ :get-pane 'turtle-pane))НЙ (*prompt-pane (send *turtle-frameНЙЙЙ :get-pane 'prompt-pane))НЙ (base 10.)НЙ (ibase 10.)НЙ (terminal-io *prompt-pane)НЙ (query-io *prompt-pane)НЙ (error-output *prompt-pane)НЙ *turtle)Н Н (send *prompt-pane :select)НН (setq *turtle (make-turtle *turtle-lake))Н Н (loop for input = (send *prompt-pane :any-tyi)НЙ do (cond ((atom input)НЙЙ (selectq inputНН; Here is where you add code to intercept keyboard inputН; and do special things with defined keys.Н; Notice that the key "c" has been given the functionalityН; of toggling between the two configurations of the turtleН; constraint frame.ННЙЙ (#/c (change-display))НЙЙ (#\end (send *turtle-frame :bury))НЙЙ (t (beep))))НЙЙ ((listp input)НЙЙ (selectq (car input)НЙЙ (:menuНЙЙ (send (fourth input)НЙЙЙ :execute (second input)))НЙЙ (t (beep))))))))ННН; Turtle creates and returns an instance of turtle-frame.НН(defun turtle ()Н (setq *turtle-frame (make-instance 'turtle-frame))Н (send *turtle-frame :activate)Н (send *turtle-frame :expose)Н (tv:await-window-exposure)Н *turtle-frame)ННН; Put turtle on system key 1. In order to run turtle, doН; 1Н Н(tv:add-system-key #\1 '(turtle) "Turtle Lake")LMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 6 :LENGTH-IN-BYTES 5557 :AUTHOR "SAM" :CREATION-DATE 2720047942 :QFASLP NIL :LENGTH 5557 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "UNIFICATION" :TYPE "LISP" :VERSION 1) ;;; -*- Mode:LISP; Readtable:COMMON-LISP; Base:10 -*-Н#|НН (C) COPYRIGHT 1986 LISP Machine, IncorporatedН All Rights ReservedНН___________________________________________________________________________Н|#НН;;; Samuel F. PilatoНННН;;;;UNIFICATIONНН(require 'pattern-definition)Н(require 'variable-substitution)Н(provide 'unification)ННН#|ННA pattern may be defined as a binary external tree with variables. ForНexample, a predicate-calculus formula in implicit-quantifier form,Нexpressed in list notation, can be taken to be a pattern. Notice thatНnested and dotted lists are fair game.ННA substitution is a table of variables and their corresponding values inНthe context of that substitution.ННA unifier, if any, of two patterns in the context of a substitution is anНextension of the given substitution which when applied to the patterns,Нreplacing variables with their values, results in equivalent patterns.ННA most general unifier (MGU), if any, of two patterns is a smallest unifierНin the context of an empty substitution. That is, each variable has aНvalue only if needed to make the patterns equivalent.НН|#ННН(defun unify? (pat1 pat2 &optional (substitution (make-substitution)))Н "Return a unifier, if any, of patterns PAT1 and PAT2 by extending a givenН non-NIL SUBSTITUTION. If SUBSTITUTION is NIL, we return NIL. If noН substitution is given, we return a most general unifier, if any."Н (if substitution (unifier? pat1 pat2 substitution)))НН(defmacro mgu? (pat1 pat2)Н "Return a most general unifier, if any, of patterns PAT1 and PAT2."Н `(unifier? ,pat1 ,pat2 (make-substitution)))НМ#|НA UNIFICATION ALGORITHMНННTo unify two patterns given a non-NIL (but possibly empty) substitution:НН If the patterns are identical:НН Return the substitution.НН Else if either pattern is a bound variable:НН Unify that variable's ultimate value with the other pattern given theН same substitution.НН Else if either pattern is an unbound variable:НН If that variable does not occur in the other pattern:НН Then return the substitution extended by adding that variable withН the other pattern as its value.НН Else return NIL (failure to unify).НН Else if either pattern is a constant:НН If that constant equals the other pattern:НН Then return the substitution.НН Else return NIL.НН Else:НН Unify the first components of the patterns given the sameН substitution. If the result is a non-NIL substitution:НН Then unify the remainders of the patterns given the newН substitution.НН Else return NIL.НННAn unbound variable occurs in a pattern given a substitution iff:НН The variable is identical to the pattern; ORНН The pattern is a bound variable and the unbound variable occurs in theН bound variable's ultimate value; ORНН The pattern is a composite and the variable occurs in either theН pattern's first component or the remainder of the pattern.НННThe following code is a slight variant of this algorithm.Н|#МН(defun unifier? (pat1 pat2 substitution)Н "Return a unifier, if any, of patterns PAT1 and PAT2 by extending a givenН non-NIL SUBSTITUTION."Н (if (variable-p pat1) (setq pat1 (get-ultimate-value pat1 substitution)))Н (if (variable-p pat2) (setq pat2 (get-ultimate-value pat2 substitution)))Н (cond ((eq pat1 pat2) substitution)НЙ((variable-p pat1) (unify-variable? pat1 pat2 substitution))НЙ((variable-p pat2) (unify-variable? pat2 pat1 substitution))НЙ((constant-p pat1) (unify-constant? pat1 pat2 substitution))НЙ((constant-p pat2) nil)Н;recur-Й((let ((s (unifier? (next-component pat1)Н;siveЙЙЙ (next-component pat2) substitution)))Н;ver-Й (if s (unifier? (rest-of-components pat1)Н;sionЙЙЙ (rest-of-components pat2) s))))НЙ((do* ((s substitution (or (unifier? (next-component p1)НЙЙЙЙЙ (next-component p2) s)НЙЙЙЙ (return nil)))НЙ (p1 pat1 (rest-of-components p1))НЙ (p2 pat2 (rest-of-components p2)))НЙ ((or (eq p1 p2) (atomic-p p1) (atomic-p p2))НЙ (unifier? p1 p2 s))))НЙ))НН(defun unify-constant? (constant other-pat-not-a-variable substitution)Н "Unify CONSTANT with another (not EQ) pattern, where the other pattern isН not a variable and SUBSTITUTION is non-NIL. The resulting SUBSTITUTION,Н if any, is returned."Н (if (match-constant-p constant other-pat-not-a-variable) substitution))НН(defun unify-variable? (unbound-var other-pattern substitution)Н "Unify UNBOUND-VAR with another (not EQ) pattern, given a non-NILН SUBSTITUTION. The resulting SUBSTITUTION, if any, is returned."Н (if (and (not (occurs-in-p unbound-var other-pattern substitution))НЙ (match-variable-p unbound-var other-pattern))Н (add-binding-pair unbound-var other-pattern substitution)))НН(defun occurs-in-p (unbound-var pattern substitution)Н "Does UNBOUND-VAR occur in PATTERN, given a non-NIL substitution?"Н (cond ((eq unbound-var pattern))НЙ((constant-p pattern) nil)НЙ((variable-p pattern)НЙ (let ((value-pat (get-ultimate-value pattern substitution)))НЙ (if (not (eq value-pat pattern))НЙ (occurs-in-p unbound-var value-pat substitution))))Н;recur-Й((or (occurs-in-p unbound-var (next-component pattern)Н;siveЙЙЙЙ substitution)Н;ver-Й (occurs-in-p unbound-var (rest-of-components pattern)Н;sionЙЙЙЙ substitution)))НЙ((do ((p pattern (rest-of-components p)))НЙ ((atomic-p p) (occurs-in-p unbound-var p substitution))НЙ (if (occurs-in-p unbound-var (next-component p) substitution)НЙ (return t))))НЙ))НLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 4 :LENGTH-IN-BYTES 4053 :AUTHOR "SAM" :CREATION-DATE 2720040962 :QFASLP NIL :LENGTH 4053 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "VARIABLE-SUBSTITUTION" :TYPE "LISP" :VERSION 1) ;;; -*- Mode:LISP; Readtable:COMMON-LISP; Base:10 -*-Н#|НН (C) COPYRIGHT 1986 LISP Machine, IncorporatedН All Rights ReservedНН___________________________________________________________________________Н|#НН;;; Samuel F. PilatoНННН;;;;VARIABLE SUBSTITUTIONНН(provide 'variable-substitution)ННН;;; A SUBSTITUTION is a set of VARIABLE - VALUE pairs. Each pair indicatesН;;; that, in the context of this substitution, the variable is BOUND to theН;;; associated value. Even an empty substitution is non-NIL.НН(defmacro make-binding-pair (variable value) `(cons ,variable ,value))Н(defmacro binding-variable (binding-pair) `(car ,binding-pair))Н(defmacro binding-value (binding-pair) `(cdr ,binding-pair))НН(defmacro make-substitution () `(ncons nil))НН(defmacro empty-substitution-p (substitution) `(null (cdr ,substitution)))НН(defmacro get-binding-pair (variable substitution)Н "Given a VARIABLE, return its variable-value pair, if any, inН SUBSTITUTION."Н `(assoc ,variable ,substitution :test #'eq))НН(defmacro add-binding-pair (variable value substitution)Н "Make the binding of VARIABLE be VALUE in SUBSTITUTION. SUBSTITUTION isН constructively altered and returned."Н `(acons ,variable ,value ,substitution))НН(defun get-ultimate-value (variable substitution)Н "Given a VARIABLE, return either its ultimate binding, if any, inН SUBSTITUTION or the VARIABLE itself. (If variable X's immediate bindingН is variable Y and Y also has a binding, then X's ultimate binding isН whatever Y's ultimate binding is. We do not handle circularities.)"Н (do (p) (nil)Н (setf p (or (get-binding-pair variable substitution) (return variable))НЙ variable (binding-value p))))НМН(defmacro do-substitutionНЙ ((pair substitution &optional resultform) &body body)Н "Iterate BODY with PAIR bound to successive variable-value pairs inН SUBSTITUTION. RETURN and GO can be used inside the BODY. If there isН no early return, RESULTFORM is finally evaluated and its valueН returned."Н `(dolist (,pair ,substitution ,resultform) (when ,pair ,@body)))НН(defmacro copy-substitution (substitution)Н "Return a copy of SUBSTITUTION."Н `(copy-alist ,substitution))НМН#|Н;;; This code could be used for applications where a substitution need notН;;; be a stack and may be destructively altered.НН(defun make-substitution (&key (test #'eq))Н "Make an empty substitution with given retrieval predicate."Н (vector 'substitution test (make-hash-table :test test)))НН(defmacro substitution-predicate (substitution) `(aref ,substitution 1))Н(defmacro substitution-set (substitution) `(aref ,substitution 2))НН(defmacro substitution-count (substitution)Н `(hash-table-count (substitution-set ,substitution)))НН(defmacro empty-substitution-p (substitution)Н `(zerop (substitution-count ,substitution)))НН(defmacro get-binding-pair (variable substitution)Н "Given VARIABLE, return its variable-value pair, if any, inН SUBSTITUTION."Н `(gethash ,variable (substitution-set ,substitution)))НН(defun set-binding-pair (variable value substitution)Н "Make the binding of VARIABLE be VALUE in SUBSTITUTION. SUBSTITUTION isН destructively altered and returned."Н (setf (get-binding-pair variable substitution)НЙ(make-binding-pair variable value))Н substitution)НН(defmacro do-substitutionНЙ ((pair substitution &optional resultform) &body body)Н "Iterate BODY with PAIR bound to successive variable-value pairs inН SUBSTITUTION. RETURN can be used inside the BODY. If there is no earlyН return, RESULTFORM is finally evaluated and its value returned."Н (let ((var (make-symbol "variable")))Н `(block nilН (maphash #'(lambda (,var ,pair) (declare (ignore ,var)) ,@body)НЙЙ(substitution-set ,substitution))Н ,resultform)))НН(defun copy-substitution (substitution)Н "Return a copy of SUBSTITUTION."Н (let ((s (make-substitution :test (substitution-predicate substitution))))Н (do-substitution (pair substitution s)Н (set-binding-pair (binding-variable pair) (binding-value pair) s))))Н|#НLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 3 :LENGTH-IN-BYTES 2344 :AUTHOR "WILDE" :CREATION-DATE 2716906682 :QFASLP NIL :LENGTH 2344 :CHARACTERS T :DIRECTORY "LISP2-CIRCULATION" :NAME "WINDOW-BRINGUP-PROCESS" :TYPE "LISP" :VERSION 4) ;;; -*- Mode:LISP; Package:USER; Fonts:(CPTFONT); Base:10 -*-НН;; Copyright (C) 1985 LISP Machine, Incorporated.НН; Title: ProcessesН; Subtitle: Window to bring up a process.Н; File name: window-bringup-process.lisp and .qfaslННН; To demo, execute (make-simple-process-window)НН; Write a window to bring up a process.НН; First, define a simple window.Н; We need to include tv:process-mixin as a component flavor.ННН(defflavor simple-proc-windowНЙ ()НЙ (tv:process-mixin tv:window)Н :gettable-instance-variablesН :settable-instance-variablesН :initable-instance-variablesН (:default-init-plistН :borders 2Н :label '(:top :centered :string "Simple Process Window")Н :more-p nilН :edges-from :mouse))ННННН; Then, write a function to make a window which has a processН; associated with it.НН; The init option :process, below, specifies the process forН; the window. The argument can be a process, or it can beН; a list, which is used as a description for creating a process.НН; The list looks likeН; (initial-function make-process-options)НН; When the process starts up, it will call initial-functionН; with the window as its sole argument. Usually the initialН; function should bind terminal-io to the argument.НН(defun make-simple-process-window (&aux simple-proc-window)Н (setq simple-proc-windowНЙ(make-instance 'simple-proc-windowНЙЙ :process '(line-hack)))Н (send simple-proc-window :activate)Н (send simple-proc-window :expose)Н (tv:await-window-exposure))НННН; The initial function for this process is a line hack.Н; It stops when something is typed on the keyboard.Н; To get out of the window, just select another one.НН(defun line-hack (stream &rest ignore)Н (let ((terminal-io stream))Н (send stream :select)Н (multiple-value-bind (xlim ylim)НЙ(send stream :inside-size)Н (loop until (send stream :tyi-no-hang) doНЙ (loopНЙ with hx = (// xlim 2)НЙ with hy = (// ylim 2)НЙ with alu = tv:alu-xorНЙ for cntr from 1 to (min hx hy)НЙ doНЙ (send streamНЙЙ :draw-lineНЙЙ 0 (- hy cntr) (+ hx cntr) 0 alu)НЙ (send streamНЙЙ :draw-lineНЙЙ (+ hx cntr) 0 xlim (+ hy cntr) alu)НЙ (send streamНЙЙ :draw-lineНЙЙ xlim (+ hy cntr) (- hx cntr) ylimНЙЙ alu)НЙ (send streamНЙЙ :draw-lineНЙЙ (- hx cntr) ylim 0 (- hy cntr) alu)НЙ )))))НLMFL(:BYTE-SIZE 8 :LENGTH-IN-BLOCKS 3 :LENGTH-IN-BYTES 2923 :AUTHOR "MDS" :CREATION-DATE 2734026984 :CHARACTERS T :DIRECTORY "OEHLMANNQ" :NAME "DRIB" :TYPE "LISP" :VERSION 1) Н;Reading at top level in Lisp Listener 1.Н;Reading in base 10 in package USER with standard Zetalisp readtable.НН(define-flavor space-ship (x-thrust y-thrust z-thrust (mass 35)) 'space-object)НSPACE-SHIPН(describe-flavor 'space-ship)НFlavor SPACE-SHIP directly depends on flavors: QUOTE, SPACE-OBJECTНNot counting inherited methods, the methods for SPACE-SHIP are:Н :SET-Z-THRUSTН :SET-Y-THRUSTН :SET-X-THRUSTН :Z-THRUSTН :Y-THRUSTН :X-THRUSTН :SET-MASSН :SET-ZTHRUSTН :MASSН :ZTHRUSTН :SET-YTHRUSTН :CASE :SET :Z-THRUST, :CASE :SET :Y-THRUST, :CASE :SET :X-THRUST, :CASE :SET :MASS, :CASE :SET :ZTHRUST, :CASE :SET :YTHRUST, :CASE :SET :XTHRUSTН :SET-XTHRUSTН :YTHRUSTН :XTHRUSTНAutomatically-generated methods to get instance variables: X-THRUST, Y-THRUST, Z-THRUST, MASSНAutomatically-generated methods to set instance variables: X-THRUST, Y-THRUST, Z-THRUST, MASSНInstance variables that may be set by initialization: X-THRUST, Y-THRUST, Z-THRUST, MASSНDefined in package USERНProperties:Н :SETTABLE-INSTANCE-VARIABLES:Й(X-THRUST Y-THRUST Z-THRUST MASS)Н :GETTABLE-INSTANCE-VARIABLES:Й(X-THRUST Y-THRUST Z-THRUST MASS)Н SI::INSTANCE-AREA-FUNCTION:ЙNILН SI::REQUIRED-INIT-KEYWORDS:ЙNILН SI::REMAINING-INIT-KEYWORDS:ЙNILН SI::REMAINING-DEFAULT-PLIST:ЙNILН SI::ALL-INITTABLE-INSTANCE-VARIABLES:ЙNILН SI::ALL-SPECIAL-INSTANCE-VARIABLES:ЙNILН SI::INSTANCE-VARIABLE-INITIALIZATIONS:ЙNILН SI::MAPPED-COMPONENT-FLAVORS:ЙNILН SI::UNMAPPED-INSTANCE-VARIABLES:ЙNILН COMPILE-FLAVOR-METHODS:ЙNILН SI::ALL-INSTANCE-VARIABLES-SPECIAL:ЙNILН SI::ADDITIONAL-INSTANCE-VARIABLES:ЙNILНFlavor SPACE-SHIP does not yet have a method hash tableННNILН(macroexpand 'space-ship)НSPACE-SHIPН(macroexpand '(define-flavor space-ship (x-thrust y-thrust z-thrust (mass 35)) 'space-object))Н(PROGN (EVAL-WHEN (LOAD EVAL) (SI::DEFFLAVOR2 (QUOTE SPACE-SHIP) (QUOTE (X-THRUST Y-THRUST Z-THRUST (MASS 35))) (QUOTE (QUOTE SPACE-OBJECT)) (QUOTE (:INITTABLE-INSTANCE-VARIABLES :GETTABLE-INSTANCE-VARIABLES :SETTABLE-INSTANCE-VARIABLES)))) (EVAL-WHEN (COMPILE) (IF (SI::JUST-COMPILING) (LET ((SI::*JUST-COMPILING* T)) (SI::DEFFLAVOR2 (QUOTE SPACE-SHIP) (QUOTE (X-THRUST Y-THRUST Z-THRUST (MASS 35))) (QUOTE (QUOTE SPACE-OBJECT)) (QUOTE (:INITTABLE-INSTANCE-VARIABLES :GETTABLE-INSTANCE-VARIABLES :SETTABLE-INSTANCE-VARIABLES))) (SI::COMPOSE-AUTOMATIC-METHODS (SI:COMPILATION-FLAVOR (QUOTE SPACE-SHIP)))) (SI::COMPOSE-AUTOMATIC-METHODS (GET (QUOTE SPACE-SHIP) (QUOTE SI:FLAVOR))))) (EVAL-WHEN (EVAL) (SI::COMPOSE-AUTOMATIC-METHODS (GET (QUOTE SPACE-SHIP) (QUOTE SI:FLAVOR)))) (EVAL-WHEN (COMPILE LOAD EVAL)) (QUOTE SPACE-SHIP))НН(defmacro define-flavor (flavor-name vars flavors &body options)Н `(defflavor ,flavor-name ,vars ,flavorsН :inittable-instance-variablesН :gettable-instance-variablesН :settable-instance-variablesН ,@options))НDEFINE-FLAVORН(dribble)