diff --git a/lisp/auxfns.lisp b/lisp/auxfns.lisp index 95a3ac4d..a097dce4 100644 --- a/lisp/auxfns.lisp +++ b/lisp/auxfns.lisp @@ -18,7 +18,7 @@ #+Lispworks (setq *PACKAGES-FOR-WARN-ON-REDEFINITION* nil) - #+LCL + #+LCL (compiler-options :warnings nil) #+sbcl (progn @@ -36,13 +36,13 @@ (defvar *paip-modules* '()) (defvar *paip-files* - `("auxfns" "tutor" "examples" - "intro" "simple" "overview" "gps1" "gps" "eliza1" "eliza" "patmatch" - "eliza-pm" "search" "gps-srch" "student" "macsyma" "macsymar" "unify" - "prolog1" "prolog" "prologc1" "prologc2" "prologc" "prologcp" - "clos" "krep1" "krep2" "krep" "cmacsyma" "mycin" "mycin-r" "waltz" - "othello" "othello2" "syntax1" "syntax2" "syntax3" "unifgram" - "grammar" "lexicon" "interp1" "interp2" "interp3" + `("auxfns" "tutor" "examples" + "intro" "simple" "overview" "gps1" "gps" "eliza1" "eliza" "patmatch" + "eliza-pm" "search" "gps-srch" "student" "macsyma" "macsymar" "unify" + "prolog1" "prolog" "prologc1" "prologc2" "prologc" "prologcp" + "clos" "krep1" "krep2" "krep" "cmacsyma" "mycin" "mycin-r" "waltz" + "othello" "othello2" "syntax1" "syntax2" "syntax3" "unifgram" + "grammar" "lexicon" "interp1" "interp2" "interp3" "compile1" "compile2" "compile3" "compopt")) (defun requires (&rest files) @@ -62,9 +62,9 @@ "The location of the source files for this book. If things don't work, change it to reflect the location of the files on your computer.") -(defparameter *paip-source* +(defparameter *paip-source* (make-pathname :name nil :type "lisp" ;;??? Maybe Change this - :defaults *paip-directory*)) + :defaults *paip-directory*)) (defparameter *paip-binary* (make-pathname @@ -81,7 +81,7 @@ :defaults *paip-directory*)) (defun paip-pathname (name &optional (type :lisp)) - (make-pathname :name name + (make-pathname :name name :defaults (ecase type ((:lisp :source) *paip-source*) ((:binary :bin) *paip-binary*)))) @@ -169,7 +169,7 @@ "Find all those elements of sequence that match item, according to the keywords. Doesn't alter sequence." (if test-not - (apply #'remove item sequence + (apply #'remove item sequence :test-not (complement test-not) keyword-args) (apply #'remove item sequence :test (complement test) keyword-args))) @@ -208,15 +208,15 @@ new-length, if that is longer than the current length." (if (and (arrayp array) (array-has-fill-pointer-p array)) - (setf (fill-pointer array) + (setf (fill-pointer array) (max (fill-pointer array) new-length)))) ;;; ============================== ;;; NOTE: In ANSI Common Lisp, the effects of adding a definition (or most ;;; anything else) to a symbol in the common-lisp package is undefined. -;;; Therefore, it would be best to rename the function SYMBOL to something -;;; else. This has not been done (for compatibility with the book). +;;; Therefore, it would be best to rename the function SYMBOL to something +;;; else. This has not been done (for compatibility with the book). (defun symbol (&rest args) "Concatenate symbols or strings to form an interned symbol" @@ -237,7 +237,7 @@ Like mapcon, but uses append instead of nconc." (apply #'append (mapcar fn list))) -(defun mklist (x) +(defun mklist (x) "If x is a list return it, otherwise return the list of x" (if (listp x) x (list x))) @@ -245,7 +245,7 @@ "Get rid of imbedded lists (to one level only)." (mappend #'mklist exp)) -(defun random-elt (seq) +(defun random-elt (seq) "Pick a random element out of a sequence." (elt seq (random (length seq)))) @@ -405,7 +405,7 @@ "Place a no-longer-needed element back in the pool." (vector-push-extend ,name ,resource)) ,(if (> initial-copies 0) - `(mapc #',deallocate (loop repeat ,initial-copies + `(mapc #',deallocate (loop repeat ,initial-copies collect (,allocate)))) ',name))) @@ -456,7 +456,7 @@ ;;;; Other: -(defun sort* (seq pred &key key) +(defun sort* (seq pred &key key) "Sort without altering the sequence" (sort (copy-seq seq) pred :key key)) @@ -468,7 +468,7 @@ ;;; ============================== -(defun length=1 (x) +(defun length=1 (x) "Is x a list of length 1?" (and (consp x) (null (cdr x)))) @@ -561,7 +561,7 @@ (do-result (i) (if (and (vectorp result-sequence) (array-has-fill-pointer-p result-sequence)) - (setf (fill-pointer result-sequence) + (setf (fill-pointer result-sequence) (max i (fill-pointer result-sequence)))))) (declare (inline do-one-call)) ;; Decide if the result is a list or vector, diff --git a/lisp/clos.lisp b/lisp/clos.lisp index ed44eacb..c1a0217b 100644 --- a/lisp/clos.lisp +++ b/lisp/clos.lisp @@ -4,7 +4,7 @@ ;;;; File clos.lisp: Object-oriented programming examples -(defstruct account +(defstruct account (name "") (balance 0.00) (interest-rate .06)) (defun account-withdraw (account amt) @@ -85,7 +85,7 @@ (defun generic-fn-p (fn-name) "Is this a generic function?" - (and (fboundp fn-name) + (and (fboundp fn-name) (eq (get fn-name 'generic-fn) (symbol-function fn-name)))) ;;; ============================== diff --git a/lisp/cmacsyma.lisp b/lisp/cmacsyma.lisp index 81565f86..57ee63f5 100644 --- a/lisp/cmacsyma.lisp +++ b/lisp/cmacsyma.lisp @@ -26,7 +26,7 @@ (deftype polynomial () 'simple-vector) -(defsetf main-var (p) (val) +(defsetf main-var (p) (val) `(setf (svref (the polynomial ,p) 0) ,val)) (defsetf coef (p i) (val) @@ -37,7 +37,7 @@ (defun degree (p) (- (length (the polynomial p)) 2)) (defun poly (x &rest coefs) - "Make a polynomial with main variable x + "Make a polynomial with main variable x and coefficients in increasing order." (apply #'vector x coefs)) @@ -58,7 +58,7 @@ (mapcar #'prefix->canon (exp-args x)))) (t (error "Not a polynomial: ~a" x)))) -(dolist (item '((+ poly+) (- poly-) (* poly*poly) +(dolist (item '((+ poly+) (- poly-) (* poly*poly) (^ poly^n) (D deriv-poly))) (setf (get (first item) 'prefix->canon) (second item))) diff --git a/lisp/compile1.lisp b/lisp/compile1.lisp index 1e24adb8..d8e532c6 100644 --- a/lisp/compile1.lisp +++ b/lisp/compile1.lisp @@ -54,7 +54,7 @@ "Compile a lambda form into a closure with compiled code." (assert (and (listp args) (every #'symbolp args)) () "Lambda arglist must be a list of symbols, not ~a" args) - ;; For now, no &rest parameters. + ;; For now, no &rest parameters. ;; The next version will support Scheme's version of &rest (make-fn :env env :args args @@ -112,7 +112,7 @@ (if (atom name) `(name! (set! ,name . ,body) ',name) (scheme-macro-expand - `(define ,(first name) + `(define ,(first name) (lambda ,(rest name) . ,body))))) (defun name! (fn name) @@ -130,7 +130,7 @@ (defun show-fn (fn &optional (stream *standard-output*) (depth 0)) "Print all the instructions in a function. - If the argument is not a function, just princ it, + If the argument is not a function, just princ it, but in a column at least 8 spaces wide." (if (not (fn-p fn)) (format stream "~8a" fn) diff --git a/lisp/compile2.lisp b/lisp/compile2.lisp index 3418320d..1ad2dcff 100644 --- a/lisp/compile2.lisp +++ b/lisp/compile2.lisp @@ -40,7 +40,7 @@ "Report an error if form has wrong number of args." (let ((n-args (length (rest form)))) (assert (<= min n-args max) (form) - "Wrong number of arguments for ~a in ~a: + "Wrong number of arguments for ~a in ~a: ~d supplied, ~d~@[ to ~d~] expected" (first form) form n-args min (if (/= min max) max)))) @@ -97,7 +97,7 @@ (let ((L2 (gen-label))) (seq pcode (gen 'TJUMP L2) ecode (list L2) (unless more? (gen 'RETURN))))) - ((null ecode) ; (if p x) ==> p (FJUMP L1) x L1: + ((null ecode) ; (if p x) ==> p (FJUMP L1) x L1: (let ((L1 (gen-label))) (seq pcode (gen 'FJUMP L1) tcode (list L1) (unless more? (gen 'RETURN))))) @@ -143,7 +143,7 @@ ;;; ============================== -(defstruct (prim (:type list)) +(defstruct (prim (:type list)) symbol n-args opcode always side-effects) ;;; Note change from book: some of the following primitive fns have had @@ -157,10 +157,10 @@ (/= 2 /= nil nil) (= 2 = nil nil) (eq? 2 eq nil nil) (equal? 2 equal nil nil) (eqv? 2 eql nil nil) (not 1 not nil nil) (null? 1 not nil nil) (cons 2 cons true nil) - (car 1 car nil nil) (cdr 1 cdr nil nil) (cadr 1 cadr nil nil) + (car 1 car nil nil) (cdr 1 cdr nil nil) (cadr 1 cadr nil nil) (list 1 list1 true nil) (list 2 list2 true nil) (list 3 list3 true nil) (read 0 read nil t) (write 1 write nil t) (display 1 display nil t) - (newline 0 newline nil t) (compiler 1 compiler t nil) + (newline 0 newline nil t) (compiler 1 compiler t nil) (name! 2 name! true t) (random 1 random true nil))) (defun primitive-p (f env n-args) diff --git a/lisp/compile3.lisp b/lisp/compile3.lisp index 0bf8f22a..e83fb2a1 100644 --- a/lisp/compile3.lisp +++ b/lisp/compile3.lisp @@ -58,7 +58,7 @@ (defun show-fn (fn &optional (stream *standard-output*) (indent 2)) "Print all the instructions in a function. - If the argument is not a function, just princ it, + If the argument is not a function, just princ it, but in a column at least 8 spaces wide." ;; This version handles code that has been assembled into a vector (if (not (fn-p fn)) @@ -81,7 +81,7 @@ (defun is (instr op) "True if instr's opcode is OP, or one of OP when OP is a list." - (if (listp op) + (if (listp op) (member (opcode instr) op) (eq (opcode instr) op))) @@ -99,7 +99,7 @@ (setf instr (elt code pc)) (incf pc) (case (opcode instr) - + ;; Variable/stack manipulation instructions: (LVAR (push (elt (elt env (arg1 instr)) (arg2 instr)) stack)) @@ -109,12 +109,12 @@ (GSET (setf (get (arg1 instr) 'global-val) (top stack))) (POP (pop stack)) (CONST (push (arg1 instr) stack)) - + ;; Branching instructions: (JUMP (setf pc (arg1 instr))) (FJUMP (if (null (pop stack)) (setf pc (arg1 instr)))) (TJUMP (if (pop stack) (setf pc (arg1 instr)))) - + ;; Function call/return instructions: (SAVE (push (make-ret-addr :pc (arg1 instr) :fn f :env env) @@ -155,7 +155,7 @@ do (push (pop stack) args) finally (return args))) stack)) - + ;; Continuation instructions: (SET-CC (setf stack (top stack))) (CC (push (make-fn @@ -163,38 +163,38 @@ :code '((ARGS 1) (LVAR 1 0 ";" stack) (SET-CC) (LVAR 0 0) (RETURN))) stack)) - + ;; Nullary operations: ((SCHEME-READ NEWLINE) ; *** fix, gat, 11/9/92 (push (funcall (opcode instr)) stack)) - + ;; Unary operations: - ((CAR CDR CADR NOT LIST1 COMPILER DISPLAY WRITE RANDOM) + ((CAR CDR CADR NOT LIST1 COMPILER DISPLAY WRITE RANDOM) (push (funcall (opcode instr) (pop stack)) stack)) - + ;; Binary operations: ((+ - * / < > <= >= /= = CONS LIST2 NAME! EQ EQUAL EQL) (setf stack (cons (funcall (opcode instr) (second stack) (first stack)) (rest2 stack)))) - + ;; Ternary operations: (LIST3 (setf stack (cons (funcall (opcode instr) (third stack) (second stack) (first stack)) (rest3 stack)))) - + ;; Constants: ((T NIL -1 0 1 2) (push (opcode instr) stack)) - + ;; Other: ((HALT) (RETURN (top stack))) (otherwise (error "Unknown opcode: ~a" instr)))))) (defun init-scheme-comp () "Initialize values (including call/cc) for the Scheme compiler." - (set-global-var! 'exit + (set-global-var! 'exit (new-fn :name 'exit :args '(val) :code '((HALT)))) (set-global-var! 'call/cc (new-fn :name 'call/cc :args '(f) @@ -233,7 +233,7 @@ (defun optimize (code) "Perform peephole optimization on assembly code." (let ((any-change nil)) - ;; Optimize each tail + ;; Optimize each tail (loop for code-tail on code do (setf any-change (or (optimize-1 code-tail code) any-change))) @@ -293,11 +293,11 @@ ;;; ============================== -(set-dispatch-macro-character #\# #\t +(set-dispatch-macro-character #\# #\t #'(lambda (&rest ignore) t) *scheme-readtable*) -(set-dispatch-macro-character #\# #\f +(set-dispatch-macro-character #\# #\f #'(lambda (&rest ignore) nil) *scheme-readtable*) @@ -306,15 +306,15 @@ ;; #x, #o and #b are hexidecimal, octal, and binary, ;; e.g. #xff = #o377 = #b11111111 = 255 ;; In Scheme only, #d255 is decimal 255. - #'(lambda (stream &rest ignore) + #'(lambda (stream &rest ignore) (let ((*read-base* 10)) (scheme-read stream))) *scheme-readtable*) -(set-macro-character #\` - #'(lambda (s ignore) (list 'quasiquote (scheme-read s))) +(set-macro-character #\` + #'(lambda (s ignore) (list 'quasiquote (scheme-read s))) nil *scheme-readtable*) -(set-macro-character #\, +(set-macro-character #\, #'(lambda (stream ignore) (let ((ch (read-char stream))) (if (char= ch #\@) @@ -334,7 +334,7 @@ (list 1 list1 true) (list 2 list2 true) (list 3 list3 true) (read 0 scheme-read nil t) (eof-object? 1 eof-object?) ;*** (write 1 write nil t) (display 1 display nil t) - (newline 0 newline nil t) (compiler 1 compiler t) + (newline 0 newline nil t) (compiler 1 compiler t) (name! 2 name! true t) (random 1 random true nil))) @@ -349,7 +349,7 @@ (list 'apply 'vector (quasi-q (coerce x 'list)))) ((atom x) (if (constantp x) x (list 'quote x))) - ((starts-with x 'unquote) + ((starts-with x 'unquote) (assert (and (rest x) (null (rest2 x)))) (second x)) ((starts-with x 'quasiquote) diff --git a/lisp/eliza-pm.lisp b/lisp/eliza-pm.lisp index 5e860ec2..6d9a8150 100644 --- a/lisp/eliza-pm.lisp +++ b/lisp/eliza-pm.lisp @@ -14,7 +14,7 @@ (defun use-eliza-rules (input) "Find some rule with which to transform the input." - (rule-based-translator input *eliza-rules* + (rule-based-translator input *eliza-rules* :action #'(lambda (bindings responses) (sublis (switch-viewpoint bindings) (random-elt responses))))) diff --git a/lisp/eliza.lisp b/lisp/eliza.lisp index 7eb43f3c..f0f9b569 100644 --- a/lisp/eliza.lisp +++ b/lisp/eliza.lisp @@ -37,14 +37,14 @@ ;;; ============================== -(defun mappend (fn &rest lists) +(defun mappend (fn &rest lists) "Apply fn to each element of lists and append the results." (apply #'append (apply #'mapcar fn lists))) ;;; ============================== (defparameter *eliza-rules* - '((((?* ?x) hello (?* ?y)) + '((((?* ?x) hello (?* ?y)) (How do you do. Please state your problem.)) (((?* ?x) computer (?* ?y)) (Do computers worry you?) (What do you think about machines?) @@ -55,7 +55,7 @@ (((?* ?x) sorry (?* ?y)) (Please don't apologize) (Apologies are not necessary) (What feelings do you have when you apologize)) - (((?* ?x) I remember (?* ?y)) + (((?* ?x) I remember (?* ?y)) (Do you often think of ?y) (Does thinking of ?y bring anything else to mind?) (What else do you remember) (Why do you recall ?y right now?) @@ -65,7 +65,7 @@ (Did you think I would forget ?y ?) (Why do you think I should recall ?y now) (What about ?y) (You mentioned ?y)) - (((?* ?x) if (?* ?y)) + (((?* ?x) if (?* ?y)) (Do you really think its likely that ?y) (Do you wish that ?y) (What do you think about ?y) (Really-- if ?y)) @@ -74,17 +74,17 @@ (Have you dreamt ?y before?)) (((?* ?x) dream about (?* ?y)) (How do you feel about ?y in reality?)) - (((?* ?x) dream (?* ?y)) + (((?* ?x) dream (?* ?y)) (What does this dream suggest to you?) (Do you dream often?) (What persons appear in your dreams?) (Don't you believe that dream has to do with your problem?)) (((?* ?x) my mother (?* ?y)) (Who else in your family ?y) (Tell me more about your family)) (((?* ?x) my father (?* ?y)) - (Your father) (Does he influence you strongly?) + (Your father) (Does he influence you strongly?) (What else comes to mind when you think of your father?)) - (((?* ?x) I want (?* ?y)) + (((?* ?x) I want (?* ?y)) (What would it mean if you got ?y) (Why do you want ?y) (Suppose you got ?y soon)) (((?* ?x) I am glad (?* ?y)) @@ -93,24 +93,24 @@ (((?* ?x) I am sad (?* ?y)) (I am sorry to hear you are depressed) (I'm sure its not pleasant to be sad)) - (((?* ?x) are like (?* ?y)) + (((?* ?x) are like (?* ?y)) (What resemblance do you see between ?x and ?y)) - (((?* ?x) is like (?* ?y)) + (((?* ?x) is like (?* ?y)) (In what way is it that ?x is like ?y) (What resemblance do you see?) (Could there really be some connection?) (How?)) - (((?* ?x) alike (?* ?y)) + (((?* ?x) alike (?* ?y)) (In what way?) (What similarities are there?)) - (((?* ?x) same (?* ?y)) + (((?* ?x) same (?* ?y)) (What other connections do you see?)) - (((?* ?x) I was (?* ?y)) + (((?* ?x) I was (?* ?y)) (Were you really?) (Perhaps I already knew you were ?y) (Why do you tell me you were ?y now?)) (((?* ?x) was I (?* ?y)) (What if you were ?y ?) (Do you thin you were ?y) (What would it mean if you were ?y)) - (((?* ?x) I am (?* ?y)) + (((?* ?x) I am (?* ?y)) (In what way are you ?y) (Do you want to be ?y ?)) (((?* ?x) am I (?* ?y)) (Do you believe you are ?y) (Would you want to be ?y) @@ -122,7 +122,7 @@ (Why are you interested in whether I am ?y or not?) (Would you prefer if I weren't ?y) (Perhaps I am ?y in your fantasies)) - (((?* ?x) you are (?* ?y)) + (((?* ?x) you are (?* ?y)) (What makes you think I am ?y ?)) (((?* ?x) because (?* ?y)) @@ -130,13 +130,13 @@ (Does that reason seem to explain anything else?)) (((?* ?x) were you (?* ?y)) (Perhaps I was ?y) (What do you think?) (What if I had been ?y)) - (((?* ?x) I can't (?* ?y)) + (((?* ?x) I can't (?* ?y)) (Maybe you could ?y now) (What if you could ?y ?)) - (((?* ?x) I feel (?* ?y)) + (((?* ?x) I feel (?* ?y)) (Do you often feel ?y ?)) - (((?* ?x) I felt (?* ?y)) + (((?* ?x) I felt (?* ?y)) (What other feelings do you have?)) - (((?* ?x) I (?* ?y) you (?* ?z)) + (((?* ?x) I (?* ?y) you (?* ?z)) (Perhaps in your fantasy we ?y each other)) (((?* ?x) why don't you (?* ?y)) (Should you ?y yourself?) @@ -159,14 +159,14 @@ (Why do you ask?) (Does that question interest you?) (What is it you really want to know?) (What do you think?) (What comes to your mind when you ask that?)) - (((?* ?x) perhaps (?* ?y)) + (((?* ?x) perhaps (?* ?y)) (You do not seem quite certain)) (((?* ?x) are (?* ?y)) (Did you think they might not be ?y) (Possibly they are ?y)) - (((?* ?x)) + (((?* ?x)) (Very interesting) (I am not sure I understand you fully) - (What does that suggest to you?) (Please continue) (Go on) + (What does that suggest to you?) (Please continue) (Go on) (Do you feel strongly about discussing such things?)))) ;;; ============================== diff --git a/lisp/eliza1.lisp b/lisp/eliza1.lisp index 41368c61..54f7d7b1 100644 --- a/lisp/eliza1.lisp +++ b/lisp/eliza1.lisp @@ -20,9 +20,9 @@ ((eql pattern input) bindings) ((segment-pattern-p pattern) ; *** (segment-match pattern input bindings)) ; *** - ((and (consp pattern) (consp input)) + ((and (consp pattern) (consp input)) (pat-match (rest pattern) (rest input) - (pat-match (first pattern) (first input) + (pat-match (first pattern) (first input) bindings))) (t fail))) @@ -83,23 +83,23 @@ ;;; ============================== (defparameter *eliza-rules* - '((((?* ?x) hello (?* ?y)) + '((((?* ?x) hello (?* ?y)) (How do you do. Please state your problem.)) - (((?* ?x) I want (?* ?y)) + (((?* ?x) I want (?* ?y)) (What would it mean if you got ?y) (Why do you want ?y) (Suppose you got ?y soon)) - (((?* ?x) if (?* ?y)) + (((?* ?x) if (?* ?y)) (Do you really think its likely that ?y) (Do you wish that ?y) (What do you think about ?y) (Really-- if ?y)) (((?* ?x) no (?* ?y)) (Why not?) (You are being a bit negative) (Are you saying "NO" just to be negative?)) - (((?* ?x) I was (?* ?y)) + (((?* ?x) I was (?* ?y)) (Were you really?) (Perhaps I already knew you were ?y) (Why do you tell me you were ?y now?)) - (((?* ?x) I feel (?* ?y)) + (((?* ?x) I feel (?* ?y)) (Do you often feel ?y ?)) - (((?* ?x) I felt (?* ?y)) + (((?* ?x) I felt (?* ?y)) (What other feelings do you have?)))) ;;; ============================== @@ -136,7 +136,7 @@ x (list x))) -(defun mappend (fn the-list) +(defun mappend (fn the-list) "Apply fn to each element of list and append the results." (apply #'append (mapcar fn the-list))) @@ -148,21 +148,21 @@ ;;;> (eliza) ;;;ELIZA> (hello there) -;;;(HOW DO YOU DO. PLEASE STATE YOUR PROBLEM.) +;;;(HOW DO YOU DO. PLEASE STATE YOUR PROBLEM.) ;;;ELIZA> (i want to test this program) -;;;(WHAT WOULD IT MEAN IF YOU GOT TO TEST THIS PROGRAM) +;;;(WHAT WOULD IT MEAN IF YOU GOT TO TEST THIS PROGRAM) ;;;ELIZA> (i could see if it works) ;;;(DO YOU REALLY THINK ITS LIKELY THAT IT WORKS) ;;;ELIZA> (no not really) -;;;(ARE YOU SAYING "NO" JUST TO BE NEGATIVE?) +;;;(ARE YOU SAYING "NO" JUST TO BE NEGATIVE?) ;;;ELIZA> (no) -;;;(ARE YOU SAYING "NO" JUST TO BE NEGATIVE?) +;;;(ARE YOU SAYING "NO" JUST TO BE NEGATIVE?) ;;;ELIZA> (forget it-- i was wondering how general the program is) ;;;(WHY DO YOU TELL ME YOU WERE WONDERING HOW GENERAL THE PROGRAM IS NOW?) ;;;ELIZA> (i felt like it) -;;;(WHAT OTHER FEELINGS DO YOU HAVE?) +;;;(WHAT OTHER FEELINGS DO YOU HAVE?) ;;;ELIZA> (i feel this is enough) -;;;(DO YOU OFTEN FEEL THIS IS ENOUGH ?) +;;;(DO YOU OFTEN FEEL THIS IS ENOUGH ?) ;;;ELIZA> [Abort] ;;; ============================== diff --git a/lisp/examples.lisp b/lisp/examples.lisp index a34ac562..f4a2b611 100644 --- a/lisp/examples.lisp +++ b/lisp/examples.lisp @@ -50,7 +50,7 @@ ((first-name p) => JOHN) ((first-name '(Wilma Flintstone)) => WILMA) ((setf names '((John Q Public) (Malcolm X) - (Admiral Grace Murray Hopper) (Spot) + (Admiral Grace Murray Hopper) (Spot) (Aristotle) (A A Milne) (Z Z Top) (Sir Larry Olivier) (Miss Scarlet))) @ 14) ((first-name (first names)) => JOHN) @@ -133,7 +133,7 @@ "functions in Lisp." (:section "3.2 Special Forms") "Start with functions and special forms for repetition:" - "First, functions like MAPCAR can apply to any number of lists:" + "First, functions like MAPCAR can apply to any number of lists:" ((mapcar #'- '(1 2 3)) => (-1 -2 -3) @ 61) ((mapcar #'+ '(1 2) '(10 20) '(100 200)) => (111 222)) "Second, many of the functions accept keywords:" @@ -220,7 +220,7 @@ "This style of programming is covered in more detail in chapter 13." ) -(defexamples 4 "GPS: The General Problem Solver" +(defexamples 4 "GPS: The General Problem Solver" "The General problem Solver, developed in 1957 by Alan Newell and Herbert" "Simon, embodied a grandiose vision: a single computer program that could" "solve ANY problem. GPS caused quite a stir ..." @@ -250,7 +250,7 @@ "The bug is that when (EVERY #'ACHIEVE GOALS) returns true, it means all the" "goals were achieved in turn, but they might not still be all true." - (:section "4.8 The Leaping before You Look Problem") + (:section "4.8 The Leaping before You Look Problem") "What happens if we move the HAVE-MONEY goal to the end?" ((gps '(son-at-home car-needs-battery have-money have-phone-book) '(have-money son-at-school) @@ -277,7 +277,7 @@ "operator is applied, we will instead have GPS return the resulting state." ((requires "gps")) "We use the list of operators that includes the 'asking the shop their" - "phone number' operator." + "phone number' operator." ((push (make-op :action 'ask-phone-number :preconds '(in-communication-with-shop) :add-list '(know-phone-number)) @@ -288,7 +288,7 @@ ((gps '(son-at-home car-needs-battery have-money have-phone-book) '(son-at-school)) => ((START) - (EXECUTING LOOK-UP-NUMBER) + (EXECUTING LOOK-UP-NUMBER) (EXECUTING TELEPHONE-SHOP) (EXECUTING TELL-SHOP-PROBLEM) (EXECUTING GIVE-SHOP-MONEY) @@ -299,7 +299,7 @@ ((gps '(son-at-home car-needs-battery have-money have-phone-book) '(son-at-school)) => ((START) - (EXECUTING LOOK-UP-NUMBER) + (EXECUTING LOOK-UP-NUMBER) (EXECUTING TELEPHONE-SHOP) (EXECUTING TELL-SHOP-PROBLEM) (EXECUTING GIVE-SHOP-MONEY) @@ -347,7 +347,7 @@ ((gps '((at 1)) '((at 25))) @ 135) "We can define FIND-PATH to use the results of a GPS search:" - ((find-path 1 25) @ 136 => + ((find-path 1 25) @ 136 => (1 2 3 4 9 8 7 12 11 16 17 22 23 24 19 20 25)) ((find-path 1 1) => (1)) ((equal (find-path 1 25) (reverse (find-path 25 1))) => T) @@ -431,7 +431,7 @@ "Now a version of pat-match that works with such pairs:" ((pat-match '(I need a ?x) '(I need a vacation)) @ 158) "Showing how to plug it in:" - ((sublis (pat-match '(I need a ?x) '(I need a vacation)) + ((sublis (pat-match '(I need a ?x) '(I need a vacation)) '(what would it mean to you if you got a ?X ?)) => (what would it mean to you if you got a VACATION ?) @ 159) ((pat-match '(I need a ?x) '(I really need a vacation)) => nil) @@ -464,15 +464,15 @@ ((pat-match '(x = (?is ?n numberp)) '(x = 34)) => ((?n . 34)) @ 179) ((pat-match '(x = (?is ?n numberp)) '(x = x)) => NIL) ((pat-match '(?x (?or < = >) ?y) '(3 < 4)) => ((?Y . 4) (?X . 3))) - ((pat-match '(x = (?and (?is ?n numberp) (?is ?n oddp))) '(x = 3)) + ((pat-match '(x = (?and (?is ?n numberp) (?is ?n oddp))) '(x = 3)) => ((?N . 3))) ((pat-match '(?x /= (?not ?x)) '(3 /= 4)) => ((?X . 3)) @ 180) ((pat-match '(?x > ?y (?if (> ?x ?y))) '(4 > 3)) => ((?Y . 3) (?X . 4))) ((pat-match '(a (?* ?x) d) '(a b c d)) => ((?X B C)) @ 185) ((pat-match '(a (?* ?x) (?* ?y) d) '(a b c d)) => ((?Y B C) (?X))) - ((pat-match '(a (?* ?x) (?* ?y) ?x ?y) '(a b c d (b c) (d))) + ((pat-match '(a (?* ?x) (?* ?y) ?x ?y) '(a b c d (b c) (d))) => ((?Y D) (?X B C)) @ 186) - ((pat-match '(?x ?op ?y is ?z (?if (eql (funcall ?op ?x ?y) ?z))) + ((pat-match '(?x ?op ?y is ?z (?if (eql (funcall ?op ?x ?y) ?z))) '(3 + 4 is 7)) => ((?Z . 7) (?Y . 4) (?OP . +) (?X . 3))) ((pat-match '(?x ?op ?y (?if (funcall ?op ?x ?y))) '(3 > 4)) => NIL) @@ -481,7 +481,7 @@ ((setf axyd (expand-pat-match-abbrev '(a ?x* ?y* d))) => (A (?* ?X) (?* ?Y) D)) ((pat-match axyd '(a b c d)) => ((?Y B C) (?X))) - ((pat-match '(((?* ?x) (?* ?y)) ?x ?y) '((a b c d) (a b) (c d))) + ((pat-match '(((?* ?x) (?* ?y)) ?x ?y) '((a b c d) (a b) (c d))) => NIL) ((requires "eliza-pm")) @@ -516,7 +516,7 @@ ((tree-search '(1) (is 6) #'next2 #'prepend) => 6 @ 208) ((graph-search '(1) (is 6) #'next2 #'prepend) => 6) ((path-states - (a*-search (list (make-path :state 1)) (is 6) + (a*-search (list (make-path :state 1)) (is 6) #'next2 #'(lambda (x y) 1) (diff 6))) => (6 5 3 1) @ 210) (:section "6.5 GPS as Search") ((requires "gps-srch")) @@ -550,11 +550,11 @@ ((untrace isolate solve)) (:section "7.3 Examples") ((student '(If the number of customers Tom gets is twice the square of - 20 % of the number of advertisements he runs |,| + 20 % of the number of advertisements he runs |,| and the number of advertisements is 45 |,| then what is the number of customers Tom gets ?)) => nil @ 231) - ((student '(The daily cost of living for a group is the overhead cost plus - the running cost for each person times the number of people in + ((student '(The daily cost of living for a group is the overhead cost plus + the running cost for each person times the number of people in the group |.| This cost for one group equals $ 100 |,| and the number of people in the group is 40 |.| If the overhead cost is 10 times the running cost |,| @@ -595,16 +595,16 @@ ((simp '(d (a * x ^ 2 + b * x + c) / d x)) => ((2 * (A * X)) + B) ) "For the next one, note we had an error in the first printing of the book;" "the sign was reversed on the (d (u / v) ...) rule." - ((simp '(d ((a * x ^ 2 + b * x + c) / x) / d x)) + ((simp '(d ((a * x ^ 2 + b * x + c) / x) / d x)) => (((X * ((2 * (A * X)) + B)) - ((A * (X ^ 2)) + ((B * X) + C))) / (X ^ 2))) ((simp '(log ((d (x + x) / d x) / 2))) => 0 ) ((simp '(log(x + x) - log x)) => (LOG 2)) ((simp '(x ^ cos pi)) => (1 / X) ) "These next two examples were also affected by the (d (u / v) ...) rule." - ((simp '(d (3 * x + (cos x) / x) / d x)) + ((simp '(d (3 * x + (cos x) / x) / d x)) => ((((X * (- (SIN X))) - (COS X)) / (X ^ 2)) + 3)) - ((simp '(d ((cos x) / x) / d x)) + ((simp '(d ((cos x) / x) / d x)) => (((X * (- (SIN X))) - (COS X)) / (X ^ 2))) ((simp '(d (3 * x ^ 2 + 2 * x + 1) / d x)) => ((6 * X) + 2)) ((simp '(sin(x + x) ^ 2 + cos(d x ^ 2 / d x) ^ 2)) => 1 ) @@ -621,24 +621,24 @@ "In chapter 15, we develop a new version of the program that handles this problem." (:section "8.6 Integration") - ((set-simp-fn 'Int #'(lambda (exp) + ((set-simp-fn 'Int #'(lambda (exp) (integrate (exp-lhs exp) (exp-rhs exp)))) @ 258) ((simp '(Int x * sin(x ^ 2) d x)) => (1/2 * (- (COS (X ^ 2)))) ) - ((simp '(Int ((3 * x ^ 3) - 1 / (3 * x ^ 3)) d x)) + ((simp '(Int ((3 * x ^ 3) - 1 / (3 * x ^ 3)) d x)) => ((3 * ((X ^ 4) / 4)) - (1/3 * ((X ^ -2) / -2))) ) ((simp '(Int (3 * x + 2) ^ -2/3 d x)) => (((3 * X) + 2) ^ 1/3) ) ((simp '(Int sin(x) ^ 2 * cos(x) d x)) => (((SIN X) ^ 3) / 3) ) ((simp '(Int sin(x) / (1 + cos(x)) d x)) => (-1 * (LOG ((COS X) + 1))) ) - ((simp '(Int (2 * x + 1) / (x ^ 2 + x - 1) d x)) + ((simp '(Int (2 * x + 1) / (x ^ 2 + x - 1) d x)) => (LOG ((X ^ 2) + (X - 1))) ) - ((simp '(Int 8 * x ^ 2 / (x ^ 3 + 2) ^ 3 d x)) + ((simp '(Int 8 * x ^ 2 / (x ^ 3 + 2) ^ 3 d x)) => (8 * ((1/3 * (((X ^ 3) + 2) ^ -2)) / -2)) ) - ((set-simp-fn 'Int + ((set-simp-fn 'Int #'(lambda (exp) (unfactorize (factorize (integrate (exp-lhs exp) (exp-rhs exp)))))) @ 259) - ((simp '(Int 8 * x ^ 2 / (x ^ 3 + 2) ^ 3 d x)) + ((simp '(Int 8 * x ^ 2 / (x ^ 3 + 2) ^ 3 d x)) => (-4/3 * (((X ^ 3) + 2) ^ -2)) ) ) @@ -708,7 +708,7 @@ ((unify 'a 'a) => ((t . t))) "Here are some examples of UNIFIER:" ((unifier '(?x ?y a) '(?y ?x ?x)) => (a a a)) - ((unifier '((?a * ?x ^ 2) + (?b * ?x) + ?c) + ((unifier '((?a * ?x ^ 2) + (?b * ?x) + ?c) '(?z + (4 * 5) + 3)) => ((?a * 5 ^ 2) + (4 * 5) + 3)) @@ -750,7 +750,7 @@ ((<- (nextto ?x ?y ?list) (iright ?x ?y ?list)) @ 374) ((<- (nextto ?x ?y ?list) (iright ?y ?x ?list))) ((<- (iright ?left ?right (?left ?right . ?rest)))) - ((<- (iright ?left ?right (?x . ?rest)) + ((<- (iright ?left ?right (?x . ?rest)) (iright ?left ?right ?rest))) ((<- (= ?x ?x))) "Now we define the zebra puzzle:" @@ -758,7 +758,7 @@ ;; Each house is of the form: ;; (house nationality pet cigarette drink house-color) (= ?h ((house norwegian ? ? ? ?) ;1,10 - ? + ? (house ? ? ? milk ?) ? ?)) ; 9 (member (house englishman ? ? ? red) ?h) ; 2 (member (house spaniard dog ? ? ?) ?h) ; 3 @@ -854,7 +854,7 @@ ((defclass account* () ((name :initarg :name :reader name*) (balance :initarg :balance :initform 0.00 :accessor balance*) - (interest-rate :allocation :class :initform .06 + (interest-rate :allocation :class :initform .06 :reader interest-rate*))) @ 445) ((setf a1 (make-instance 'account* :balance 5000.00 :name "Fred")) @ 446) @@ -936,7 +936,7 @@ ((defclass binary-tree-eql-bfs-problem (binary-tree-problem eql-problem bfs-problem) ())) - ((setf p1 (make-instance 'binary-tree-eql-bfs-problem + ((setf p1 (make-instance 'binary-tree-eql-bfs-problem :states '(1) :goal 12))) ((searcher p1) => 12) @@ -957,19 +957,19 @@ ((defmethod problem-combiner :around ((prob beam-problem) new old) (let ((combined (call-next-method))) - (subseq combined 0 (min (problem-beam-width prob) + (subseq combined 0 (min (problem-beam-width prob) (length combined)))))) ((defclass binary-tree-eql-best-beam-problem - (binary-tree-problem eql-problem best-problem beam-problem) + (binary-tree-problem eql-problem best-problem beam-problem) ())) - ((setf p3 (make-instance 'binary-tree-eql-best-beam-problem + ((setf p3 (make-instance 'binary-tree-eql-best-beam-problem :states '(1) :goal 12 :beam-width 3))) ((searcher p3) => 12) - ((defclass trip-problem (binary-tree-eql-best-beam-problem) + ((defclass trip-problem (binary-tree-eql-best-beam-problem) ((beam-width :initform 1))) @ 453) ((defmethod cost-fn ((prob trip-problem) city) @@ -978,8 +978,8 @@ ((defmethod problem-successors ((prob trip-problem) city) (neighbors city))) - ((setf p4 (make-instance 'trip-problem - :states (list (city 'new-york)) + ((setf p4 (make-instance 'trip-problem + :states (list (city 'new-york)) :goal (city 'san-francisco)))) ((searcher p4) => @@ -1167,7 +1167,7 @@ ((print-labelings (diagram 'poiuyt)) @ 583) "Now we try a more complex diagram:" ((defdiagram tower - (a Y b c d) (n L q o) + (a Y b c d) (n L q o) (b W g e a) (o W y j n) (c W e f a) (p L r i) (d W f g a) (q W n s w) @@ -1181,7 +1181,7 @@ (l L h k) (y Y v u o) (m L k i) (z Y t u v)) @ 584) ((print-labelings (ground (diagram 'tower) 'l 'k)) @ 584)) - + (defexamples 18 "Search and the Game of Othello" "In this chapter we will develop a simplified Othello-playing program." "It will not be a champion, but is much better than beginning players." @@ -1192,7 +1192,7 @@ "Now we can compare the weighted squares and count difference strategies" "by playing two games, alternating who goes first. The NIL as third argument" "means don't print the board after each move." - ((othello (maximizer #'weighted-squares) + ((othello (maximizer #'weighted-squares) (maximizer #'count-difference) nil) @ 610) ((othello (maximizer #'count-difference) (maximizer #'weighted-squares) nil)) @@ -1213,7 +1213,7 @@ "another. The function RANDOM-OTHELLO-SERIES allows two strategies to" "compete in a series of games." ((requires "othello2")) - ((random-othello-series + ((random-othello-series (alpha-beta-searcher 2 #'weighted-squares) (alpha-beta-searcher 2 #'modified-weighted-squares) 5) @ 628) @@ -1234,7 +1234,7 @@ (alpha-beta-searcher 3 #'weighted-squares) (alpha-beta-searcher 3 #'modified-weighted-squares) #'random-strategy) - 1 10 + 1 10 '(count-difference weighted modified-weighted random))) ) @@ -1484,7 +1484,7 @@ ((do-s '(Every picture paints a story)) :input "." @ 699) ((do-s '(Every boy that paints a picture sleeps)) :input ".") ((do-s '(Every boy that sleeps paints a picture)) :input ".") - ((do-s '(Every boy that paints a picture that sells paints a picture + ((do-s '(Every boy that paints a picture that sells paints a picture that stinks)) :input "." @ 700) (:section "20.5 Preserving Quantifier Scope Ambiguity") @@ -1534,7 +1534,7 @@ ((?- (word sees verb ?infl ?senses)) :input ".") ((try S John promised Kim to persuade Lee to sleep) :input ";;;.") (:section "21.14 Examples") - ((try S When did John promise Kim to persuade Lee to sleep) + ((try S When did John promise Kim to persuade Lee to sleep) @ 746 :input ";;;.") ((try S Kim would not have been looking for Lee) @ 747 :input ";;;.") ((try s It should not surprise you that Kim does not like Lee) :input ";;;.") @@ -1549,11 +1549,11 @@ "to avoid going into a read-eval-print loop with SCHEME. This is a new" "functionality, no in the book, added to make these examples easier." ((scheme '(+ 2 2)) @ 760 => 4 ) - ((scheme '((if (= 1 2) * +) 3 4)) => 7) - ((scheme '((if (= 1 1) * +) 3 4)) => 12 @ 761) + ((scheme '((if (= 1 2) * +) 3 4)) => 7) + ((scheme '((if (= 1 1) * +) 3 4)) => 12 @ 761) ((scheme '(set! fact (lambda (n) (if (= n 0) 1 (* n (fact (- n 1)))))))) - ((scheme '(fact 5)) => 120) + ((scheme '(fact 5)) => 120) ((scheme '(set! table (lambda (f start end) (if (<= start end) (begin @@ -1573,7 +1573,7 @@ ((scheme-macro-expand '(let ((x 1) (y 2)) (+ x y))) => ((LAMBDA (X Y) (+ X Y)) 1 2)) ((scheme-macro-expand - '(letrec + '(letrec ((even? (lambda (x) (or (= x 0) (odd? (- x 1))))) (odd? (lambda (x) (even? (- x 1))))) (even? z)))) diff --git a/lisp/gps-srch.lisp b/lisp/gps-srch.lisp index 397c68a3..1a990291 100644 --- a/lisp/gps-srch.lisp +++ b/lisp/gps-srch.lisp @@ -26,7 +26,7 @@ (mapcar #'(lambda (op) (append - (remove-if #'(lambda (x) + (remove-if #'(lambda (x) (member-equal x (op-del-list op))) state) (op-add-list op))) diff --git a/lisp/gps.lisp b/lisp/gps.lisp index f10bb79b..bef26867 100644 --- a/lisp/gps.lisp +++ b/lisp/gps.lisp @@ -74,12 +74,12 @@ (defun apply-op (state goal op goal-stack) "Return a new, transformed state if op is applicable." (dbg-indent :gps (length goal-stack) "Consider: ~a" (op-action op)) - (let ((state2 (achieve-all state (op-preconds op) + (let ((state2 (achieve-all state (op-preconds op) (cons goal goal-stack)))) (unless (null state2) ;; Return an updated state (dbg-indent :gps (length goal-stack) "Action: ~a" (op-action op)) - (append (remove-if #'(lambda (x) + (append (remove-if #'(lambda (x) (member-equal x (op-del-list op))) state2) (op-add-list op))))) @@ -92,7 +92,7 @@ (defun use (oplist) "Use oplist as the default list of operators." - ;; Return something useful, but not too verbose: + ;; Return something useful, but not too verbose: ;; the number of operators. (length (setf *ops* oplist))) @@ -214,7 +214,7 @@ (subsetp goals current-state :test #'equal)) current-state))) -(defun orderings (l) +(defun orderings (l) (if (> (length l) 1) (list l (reverse l)) (list l))) @@ -231,10 +231,10 @@ (appropriate-ops goal state))))) ;*** (defun appropriate-ops (goal state) - "Return a list of appropriate operators, + "Return a list of appropriate operators, sorted by the number of unfulfilled preconditions." (sort (copy-list (find-all goal *ops* :test #'appropriate-p)) #'< - :key #'(lambda (op) + :key #'(lambda (op) (count-if #'(lambda (precond) (not (member-equal precond state))) (op-preconds op))))) diff --git a/lisp/gps1.lisp b/lisp/gps1.lisp index 0edc31a3..c2774785 100644 --- a/lisp/gps1.lisp +++ b/lisp/gps1.lisp @@ -19,7 +19,7 @@ "A goal is achieved if it already holds, or if there is an appropriate op for it that is applicable." (or (member goal *state*) - (some #'apply-op + (some #'apply-op (find-all goal *ops* :test #'appropriate-p)))) (defun appropriate-p (goal op) diff --git a/lisp/grammar.lisp b/lisp/grammar.lisp index b6d9d4a9..91603303 100644 --- a/lisp/grammar.lisp +++ b/lisp/grammar.lisp @@ -74,7 +74,7 @@ (rule (rel-clause ?agr ?x :sem) ==> (:ex (the man) "that she liked" "that liked her" "that I know Lee liked") - (opt-rel-pronoun ?case ?x ?int-subj ?rel-sem) + (opt-rel-pronoun ?case ?x ?int-subj ?rel-sem) (clause (finite ? ?) ? ?int-subj ?v (gap (NP ?agr ?case ?x)) (gap nil) ?clause-sem)) @@ -102,7 +102,7 @@ (:ex "sleeps" "quickly give the dog a bone") (modifiers pre verb ? () ?v (gap nil) (gap nil) ?pre-sem) (:sem (?role ?x ?v)) (:test (= ?subject-slot (?role 1 ?))) - (verb ?verb ?infl (?subject-slot . ?slots) ?v ?v-sem) + (verb ?verb ?infl (?subject-slot . ?slots) ?v ?v-sem) (modifiers post verb ? ?slots ?v ?g1 ?g2 ?mod-sem)) (rule (VP ?infl ?x ?subject-slot ?v ?g1 ?g2 :sem) ==> @@ -138,7 +138,7 @@ (= ?agree (- - + -))))) ;Non-NP subjects are 3sing (rule (subject ?agr ?x (?role 1 (NP ?x)) int-subj ?gap ?gap ?sem) - ==> + ==> (NP ?agr (common nom) ?wh ?x (gap nil) (gap nil) ?sem)) (<- (subj-pred-agree ?agr (finite ?agr ?))) @@ -176,7 +176,7 @@ ?clause-sem)) (rule (aux-inv-S ?ext ?v :sem) ==> - (:ex "Is he a doctor?") + (:ex "Is he a doctor?") (verb ?be (finite ?agr ?) ((?role ?n ?xp) . ?slots) ?v ?sem) (:test (word ?be be)) (subject ?agr ?x (?role ?n ?xp) int-subj @@ -196,7 +196,7 @@ (<- (slot-constituent (?role ?n (Adj ?x)) *** ?x ?)) (<- (slot-constituent (?role ?n (P ?particle)) *** ? ?)) -(rule (complement ?cat ?info (?role ?n ?xp) ?h ?gap1 ?gap2 :sem) +(rule (complement ?cat ?info (?role ?n ?xp) ?h ?gap1 ?gap2 :sem) ==> ;; A complement is anything expected by a slot (:sem (?role ?h ?x)) @@ -219,7 +219,7 @@ (opt-word ?word) (clause ?infl ?x int-subj ?v ?gap1 ?gap2 ?sem)) -(rule (XP (?role ?n (advp ?v)) (advp ?v) ?wh ?v ?gap1 ?gap2 ?sem) +(rule (XP (?role ?n (advp ?v)) (advp ?v) ?wh ?v ?gap1 ?gap2 ?sem) ==> (advp ?wh ?v ?gap1 ?gap2 ?sem)) @@ -407,7 +407,7 @@ (word not not) -(noun destruction * destruction +(noun destruction * destruction (pat (2) (PP of ?)) (agt (2) (PP by ?))) (noun beach) (noun bone) @@ -429,7 +429,7 @@ (word I pronoun 1sing (common nom) -wh speaker) (word we pronoun 1plur (common nom) -wh speaker+other) (word you pronoun 2pers (common ?) -wh listener) -(word he pronoun 3sing (common nom) -wh male) +(word he pronoun 3sing (common nom) -wh male) (word she pronoun 3sing (common nom) -wh female) (word it pronoun 3sing (common ?) -wh anything) (word they pronoun 3plur (common nom) -wh anything) diff --git a/lisp/interp1.lisp b/lisp/interp1.lisp index 54686ab2..88fc2d17 100644 --- a/lisp/interp1.lisp +++ b/lisp/interp1.lisp @@ -62,7 +62,7 @@ "Initialize the scheme interpreter with some global variables." ;; Define Scheme procedures as CL functions: (mapc #'init-scheme-proc *scheme-procs*) - ;; Define the boolean `constants'. Unfortunately, this won't + ;; Define the boolean `constants'. Unfortunately, this won't ;; stop someone from saying: (set! t nil) (set-global-var! t t) (set-global-var! nil nil)) @@ -176,7 +176,7 @@ (def-scheme-macro define (name &rest body) (if (atom name) `(begin (set! ,name . ,body) ',name) - `(define ,(first name) + `(define ,(first name) (lambda ,(rest name) . ,body)))) (def-scheme-macro delay (computation) diff --git a/lisp/interp2.lisp b/lisp/interp2.lisp index 8a344ca9..680c66da 100644 --- a/lisp/interp2.lisp +++ b/lisp/interp2.lisp @@ -15,7 +15,7 @@ (cond ((symbolp x) (get-var x env)) ((atom x) x) - ((scheme-macro (first x)) + ((scheme-macro (first x)) (setf x (scheme-macro-expand x)) (go :INTERP)) ((case (first x) (QUOTE (second x)) diff --git a/lisp/interp3.lisp b/lisp/interp3.lisp index 6d77e0d8..2828c11e 100644 --- a/lisp/interp3.lisp +++ b/lisp/interp3.lisp @@ -14,14 +14,14 @@ (cond ((symbolp x) (funcall cc (get-var x env))) ((atom x) (funcall cc x)) - ((scheme-macro (first x)) - (interp (scheme-macro-expand x) env cc)) + ((scheme-macro (first x)) + (interp (scheme-macro-expand x) env cc)) ((case (first x) (QUOTE (funcall cc (second x))) (BEGIN (interp-begin (rest x) env cc)) (SET! (interp (third x) env #'(lambda (val) - (funcall cc (set-var! (second x) + (funcall cc (set-var! (second x) val env))))) (IF (interp (second x) env #'(lambda (pred) @@ -81,7 +81,7 @@ (defun init-scheme-proc (f) "Define a Scheme primitive procedure as a CL function." (if (listp f) - (set-global-var! (first f) + (set-global-var! (first f) #'(lambda (cont &rest args) (funcall cont (apply (second f) args)))) (init-scheme-proc (list f f)))) diff --git a/lisp/intro.lisp b/lisp/intro.lisp index e90db6cd..6b9545c9 100644 --- a/lisp/intro.lisp +++ b/lisp/intro.lisp @@ -13,7 +13,7 @@ (first name)) (setf names '((John Q Public) (Malcolm X) - (Admiral Grace Murray Hopper) (Spot) + (Admiral Grace Murray Hopper) (Spot) (Aristotle) (A A Milne) (Z Z Top) (Sir Larry Olivier) (Miss Scarlet))) @@ -73,7 +73,7 @@ (count-atoms (rest exp)))))) (defun count-all-atoms (exp &optional (if-null 1)) - "Return the total number of atoms in the expression, + "Return the total number of atoms in the expression, counting nil as an atom only in non-tail position." (cond ((null exp) if-null) ((atom exp) 1) diff --git a/lisp/krep.lisp b/lisp/krep.lisp index 5b25cae4..13bd9093 100644 --- a/lisp/krep.lisp +++ b/lisp/krep.lisp @@ -147,7 +147,7 @@ (or (dtree-rest dtree) (setf (dtree-rest dtree) (make-dtree))))) ((null key)) ; don't index on nil - + ((variable-p key) ; index a variable (nalist-push world value (dtree-var dtree))) (t ;; Make sure there is an nlist for this atom, and add to it @@ -273,7 +273,7 @@ (run-attached-fn `(ind ,relation ,?a ,?b)))) (def-attached-fn sub (subcat supercat) - ;; Cache SUB facts + ;; Cache SUB facts (query-bind (?super-super) `(sub ,supercat ?super-super) (index-new-fact `(sub ,subcat ,?super-super)) (query-bind (?sub-sub) `(sub ?sub-sub ,subcat) diff --git a/lisp/krep1.lisp b/lisp/krep1.lisp index 67de87cf..fb195764 100644 --- a/lisp/krep1.lisp +++ b/lisp/krep1.lisp @@ -9,7 +9,7 @@ ;;; ============================== ;; An nlist is implemented as a (count . elements) pair: -(defun make-empty-nlist () +(defun make-empty-nlist () "Create a new, empty nlist." (cons 0 nil)) @@ -82,7 +82,7 @@ (p b (f c)) (p a (f . ?x))))) (clear-dtrees) (mapc #'index props) - (write (list props (get-dtree 'p)) + (write (list props (get-dtree 'p)) :circle t :array t :pretty t) (values))) diff --git a/lisp/krep2.lisp b/lisp/krep2.lisp index 4ab91128..df65cb8c 100644 --- a/lisp/krep2.lisp +++ b/lisp/krep2.lisp @@ -52,7 +52,7 @@ (defparameter *depth-start* 5 "The depth of the first round of iterative search.") -(defparameter *depth-incr* 5 +(defparameter *depth-incr* 5 "Increase each iteration of the search by this amount.") (defparameter *depth-max* most-positive-fixnum "The deepest we will ever search.") diff --git a/lisp/loop.lisp b/lisp/loop.lisp index e1210eea..05abcf7a 100644 --- a/lisp/loop.lisp +++ b/lisp/loop.lisp @@ -70,7 +70,7 @@ ;; No keywords implies simple loop: `(block nil (tagbody loop ,@exps (go loop))) ;; otherwise process loop keywords: - (let ((l (make-loop))) + (let ((l (make-loop))) (parse-loop-body l exps) (fill-loop-template l)))) @@ -100,7 +100,7 @@ "Add a variable, maybe including an update step." (unless (assoc var (loop-vars l)) (push (list var init) (loop-vars l))) - (when update? + (when update? (push `(setq ,var ,update) (loop-steps l)))) ;;; ============================== @@ -109,7 +109,7 @@ "Parse the exps based on the first exp being a keyword. Continue until all the exps are parsed." (unless (null exps) - (parse-loop-body + (parse-loop-body l (call-loop-fn l (first exps) (rest exps))))) (defun call-loop-fn (l key exps) @@ -133,7 +133,7 @@ ;;; ============================== (defloop repeat (l times) - "(LOOP REPEAT n ...) does loop body n times" + "(LOOP REPEAT n ...) does loop body n times" (let ((i (gensym "REPEAT"))) (add-var l i times `(- ,i 1)) (add-test l `(<= ,i 0)))) @@ -302,7 +302,7 @@ ;;; ============================== -(defloop when (l test exps) +(defloop when (l test exps) (loop-unless l `(not ,(maybe-set-it test exps)) exps)) (defloop unless (l test exps) diff --git a/lisp/macsyma.lisp b/lisp/macsyma.lisp index fcfb9d4a..b29c9e34 100644 --- a/lisp/macsyma.lisp +++ b/lisp/macsyma.lisp @@ -84,7 +84,7 @@ (defun simp (inf) (prefix->infix (simplify (infix->prefix inf)))) -(defun simplify (exp) +(defun simplify (exp) "Simplify an expression by first simplifying its components." (if (atom exp) exp (simplify-exp (mapcar #'simplify exp)))) @@ -203,11 +203,11 @@ ;; First try some trivial cases (cond ((free-of exp x) `(* ,exp x)) ; Int c dx = c*x - ((starts-with exp '+) ; Int f + g = + ((starts-with exp '+) ; Int f + g = `(+ ,(integrate (exp-lhs exp) x) ; Int f + Int g ,(integrate (exp-rhs exp) x))) - ((starts-with exp '-) - (ecase (length (exp-args exp)) + ((starts-with exp '-) + (ecase (length (exp-args exp)) (1 (integrate (exp-lhs exp) x)) ; Int - f = - Int f (2 `(- ,(integrate (exp-lhs exp) x) ; Int f - g = ,(integrate (exp-rhs exp) x))))) ; Int f - Int g @@ -240,7 +240,7 @@ (assert (starts-with factor '^)) (let* ((u (exp-lhs factor)) ; factor = u^n (n (exp-rhs factor)) - (k (divide-factors + (k (divide-factors factors (factorize `(* ,factor ,(deriv u x)))))) (cond ((free-of k x) ;; Int k*u^n*du/dx dx = k*Int u^n du diff --git a/lisp/macsymar.lisp b/lisp/macsymar.lisp index b2de09ff..4bef5158 100644 --- a/lisp/macsymar.lisp +++ b/lisp/macsymar.lisp @@ -38,7 +38,7 @@ (x + y - x = y) ))) -(setf *simplification-rules* +(setf *simplification-rules* (append *simplification-rules* (mapcar #'simp-rule '((s * n = n * s) (n * (m * x) = (n * m) * x) @@ -49,7 +49,7 @@ (x + (y + n) = (x + y) + n) ((x + n) + y = (x + y) + n))))) -(setf *simplification-rules* +(setf *simplification-rules* (append *simplification-rules* (mapcar #'simp-rule '( (log 1 = 0) (log 0 = undefined) @@ -70,14 +70,14 @@ )))) -(setf *simplification-rules* +(setf *simplification-rules* (append *simplification-rules* (mapcar #'simp-rule '( (d x / d x = 1) (d (u + v) / d x = (d u / d x) + (d v / d x)) (d (u - v) / d x = (d u / d x) - (d v / d x)) (d (- u) / d x = - (d u / d x)) (d (u * v) / d x = u * (d v / d x) + v * (d u / d x)) - (d (u / v) / d x = (v * (d u / d x) - u * (d v / d x)) + (d (u / v) / d x = (v * (d u / d x) - u * (d v / d x)) / v ^ 2) ; [This corrects an error in the first printing] (d (u ^ n) / d x = n * u ^ (n - 1) * (d u / d x)) (d (u ^ v) / d x = v * u ^ (v - 1) * (d u / d x) @@ -88,7 +88,7 @@ (d (e ^ u) / d x = (e ^ u) * (d u / d x)) (d u / d x = 0))))) - + (integration-table '((Int log(x) d x = x * log(x) - x) (Int exp(x) d x = exp(x)) diff --git a/lisp/mycin-r.lisp b/lisp/mycin-r.lisp index 239c3405..e4ec20db 100644 --- a/lisp/mycin-r.lisp +++ b/lisp/mycin-r.lisp @@ -31,7 +31,7 @@ (defparm morphology organism (member rod coccus) "Is ~a a rod or coccus (etc.):") (defparm aerobicity organism (member aerobic anaerobic)) -(defparm growth-conformation organism +(defparm growth-conformation organism (member chains pairs clumps)) (clear-rules) diff --git a/lisp/mycin.lisp b/lisp/mycin.lisp index 7fa0cbf7..d4737326 100644 --- a/lisp/mycin.lisp +++ b/lisp/mycin.lisp @@ -68,7 +68,7 @@ why - to see why this question is asked help - to see this list xxx - (for some specific xxx) if there is a definite answer - (xxx .5 yyy .4) - If there are several answers with + (xxx .5 yyy .4) - If there are several answers with different certainty factors.") (defun ask-vals (parm inst) @@ -127,7 +127,7 @@ (t (cons (list (first reply) (second reply)) (parse-reply (rest2 reply)))))) -(defstruct (parm (:constructor +(defstruct (parm (:constructor new-parm (name &optional context type-restriction prompt ask-first reader))) name (context nil) (prompt "~&What is the ~*~a of ~2:*~a?") @@ -236,7 +236,7 @@ (loop for pair in (get-vals parm inst) when (funcall op (first pair) val) sum (second pair)))) - + (defun reject-premise (premise) "A premise is rejected if it is known false, without needing to call find-out recursively." @@ -283,7 +283,7 @@ (get-context-data contexts))))) (defmacro defrule (number &body body) - "Define a rule with conditions, a certainty factor, and + "Define a rule with conditions, a certainty factor, and conclusions. Example: (defrule R001 if ... then .9 ...)" (assert (eq (first body) 'if)) (let* ((then-part (member 'then body)) @@ -338,7 +338,7 @@ (cf->english (rule-cf rule)) (rule-cf rule)) (print-conditions (rule-conclusions rule) stream)) -(defun print-conditions (conditions &optional +(defun print-conditions (conditions &optional (stream t) (num 1)) "Print a list of numbered conditions." (dolist (condition conditions) diff --git a/lisp/open-pdf.lisp b/lisp/open-pdf.lisp index 2651c630..88645aa7 100644 --- a/lisp/open-pdf.lisp +++ b/lisp/open-pdf.lisp @@ -1,5 +1,5 @@ (defvar *paip-pdf-uri* "https://github.com/norvig/paip-lisp/raw/master/") - + (defun open-pdf (&optional (part 1)) (let* ((name (format nil "PAIP-part~A.pdf" part)) (path (namestring diff --git a/lisp/othello.lisp b/lisp/othello.lisp index 2706914e..80ce7c8a 100644 --- a/lisp/othello.lisp +++ b/lisp/othello.lisp @@ -30,7 +30,7 @@ (deftype board () '(simple-array piece (100))) (defun bref (board square) (aref board square)) -(defsetf bref (board square) (val) +(defsetf bref (board square) (val) `(setf (aref ,board ,square) ,val)) (defun copy-board (board) @@ -87,7 +87,7 @@ "Would this move result in any flips in this direction? If so, return the square number of the bracketing piece." ;; A flip occurs if, starting at the adjacent square, c, there - ;; is a string of at least one opponent pieces, bracketed by + ;; is a string of at least one opponent pieces, bracketed by ;; one of player's pieces (let ((c (+ move dir))) (and (eql (bref board c) (opponent player)) @@ -104,7 +104,7 @@ "Compute the player to move next, or NIL if nobody can move." (let ((opp (opponent previous-player))) (cond ((any-legal-move? opp board) opp) - ((any-legal-move? previous-player board) + ((any-legal-move? previous-player board) (when print (format t "~&~c has no moves and must pass." (name-of opp))) @@ -132,7 +132,7 @@ (defun maximizer (eval-fn) "Return a strategy that will consider every legal move, - apply EVAL-FN to each resulting board, and choose + apply EVAL-FN to each resulting board, and choose the move for which EVAL-FN returns the best score. FN takes two arguments: the player-to-move and board" #'(lambda (player board) @@ -163,7 +163,7 @@ "Sum of the weights of player's squares minus opponent's." (let ((opp (opponent player))) (loop for i in all-squares - when (eql (bref board i) player) + when (eql (bref board i) player) sum (aref *weights* i) when (eql (bref board i) opp) sum (- (aref *weights* i))))) @@ -207,7 +207,7 @@ "A strategy that searches PLY levels and then uses EVAL-FN." #'(lambda (player board) (multiple-value-bind (value move) - (minimax player board ply eval-fn) + (minimax player board ply eval-fn) (declare (ignore value)) move))) @@ -243,7 +243,7 @@ #'(lambda (player board) (multiple-value-bind (value move) (alpha-beta player board losing-value winning-value - depth eval-fn) + depth eval-fn) (declare (ignore value)) move))) @@ -272,7 +272,7 @@ "Return a list of all squares adjacent to a square." (aref neighbor-table square))) -(let ((square-names +(let ((square-names (cross-product #'symbol '(? a b c d e f g h ?) '(? 1 2 3 4 5 6 7 8 ?)))) @@ -296,19 +296,19 @@ (defvar *move-number* 1 "The number of the move to be played") -(defun othello (bl-strategy wh-strategy +(defun othello (bl-strategy wh-strategy &optional (print t) (minutes 30)) "Play a game of othello. Return the score, where a positive difference means black, the first player, wins." (let ((board (initial-board)) (clock (make-array (+ 1 (max black white)) - :initial-element - (* minutes 60 + :initial-element + (* minutes 60 internal-time-units-per-second)))) (catch 'game-over (loop for *move-number* from 1 for player = black then (next-to-play board player print) - for strategy = (if (eql player black) + for strategy = (if (eql player black) bl-strategy wh-strategy) until (null player) @@ -341,7 +341,7 @@ (THROW 'game-over (if (eql player black) -64 64))) ((and (valid-p move) (legal-p move player board)) (when print - (format t "~&~c moves to ~a." + (format t "~&~c moves to ~a." (name-of player) (88->h8 move))) (make-move move player board)) (t (warn "Illegal move: ~a" (88->h8 move)) @@ -372,7 +372,7 @@ (floor (round time internal-time-units-per-second) 60) (format nil "~2d:~2,'0d" min sec))) -(defun random-othello-series (strategy1 strategy2 +(defun random-othello-series (strategy1 strategy2 n-pairs &optional (n-random 10)) "Play a series of 2*n games, starting from a random position." (othello-series @@ -415,7 +415,7 @@ :initial-element 0))) ;; Play the games (dotimes (i N) - (loop for j from (+ i 1) to (- N 1) do + (loop for j from (+ i 1) to (- N 1) do (let* ((wins (random-othello-series (elt strategies i) (elt strategies j) diff --git a/lisp/othello2.lisp b/lisp/othello2.lisp index 311b5116..ad2c5b69 100644 --- a/lisp/othello2.lisp +++ b/lisp/othello2.lisp @@ -13,7 +13,7 @@ (requires "othello") (defconstant all-squares - (sort (loop for i from 11 to 88 + (sort (loop for i from 11 to 88 when (<= 1 (mod i 10) 8) collect i) #'> :key #'(lambda (sq) (elt *weights* sq)))) @@ -179,16 +179,16 @@ (defun init-edge-table () "Initialize *edge-table*, starting from the empty board." ;; Initialize the static values - (loop for n-pieces from 0 to 10 do + (loop for n-pieces from 0 to 10 do (map-edge-n-pieces #'(lambda (board index) (setf (aref *edge-table* index) (static-edge-stability black board))) black (initial-board) n-pieces top-edge 0)) ;; Now iterate five times trying to improve: - (dotimes (i 5) + (dotimes (i 5) ;; Do the indexes with most pieces first - (loop for n-pieces from 9 downto 1 do + (loop for n-pieces from 9 downto 1 do (map-edge-n-pieces #'(lambda (board index) (setf (aref *edge-table* index) @@ -215,7 +215,7 @@ (setf (bref board sq) empty)))))) (defun possible-edge-moves-value (player board index) - "Consider all possible edge moves. + "Consider all possible edge moves. Combine their values into a single number." (combine-edge-moves (cons @@ -277,7 +277,7 @@ '(+1 -1))) (defparameter *static-edge-table* - '#2A(;stab semi un + '#2A(;stab semi un ( * 0 -2000) ; X ( 700 * *) ; corner (1200 200 -25) ; C @@ -303,7 +303,7 @@ (piece-stability board sq))))))) (let ((stable 0) (semi-stable 1) (unstable 2)) - + (defun piece-stability (board sq) (cond ((corner-p sq) stable) diff --git a/lisp/overview.lisp b/lisp/overview.lisp index 55c2d604..2b8122e0 100644 --- a/lisp/overview.lisp +++ b/lisp/overview.lisp @@ -15,10 +15,10 @@ ;;; ============================== (defstruct player (score 0) (wins 0)) - + (defun determine-winner (players) "Increment the WINS for the player with highest score." - (incf (player-wins (first (sort players #'> + (incf (player-wins (first (sort players #'> :key #'player-score))))) ;;; ============================== @@ -34,7 +34,7 @@ (defun length1.1 (list) ; alternate version: (let ((len 0)) ; (not my preference) (dolist (element list len) ; uses len as result here - (incf len)))) + (incf len)))) ;;; ============================== @@ -48,17 +48,17 @@ ;;; ============================== (defun length3 (list) - (do ((len 0 (+ len 1)) ; start with LEN=0, increment + (do ((len 0 (+ len 1)) ; start with LEN=0, increment (l list (rest l))) ; ... on each iteration ((null l) len))) ; (until the end of the list) ;;; ============================== -(defun length4 (list) +(defun length4 (list) (loop for element in list ; go through each element - count t)) ; counting each one + count t)) ; counting each one -(defun length5 (list) +(defun length5 (list) (loop for element in list ; go through each element summing 1)) ; adding 1 each time @@ -182,19 +182,19 @@ ;;; ============================== (defun english->french (words) - (sublis '((are . va) (book . libre) (friend . ami) + (sublis '((are . va) (book . libre) (friend . ami) (hello . bonjour) (how . comment) (my . mon) (red . rouge) (you . tu)) words)) ;;; ============================== -(defstruct node +(defstruct node name (yes nil) (no nil)) -(defvar *db* +(defvar *db* (make-node :name 'animal :yes (make-node :name 'mammal) :no (make-node @@ -262,7 +262,7 @@ ;;; ============================== (defun eat-porridge (bear) - (assert (< too-cold (temperature (bear-porridge bear)) too-hot) + (assert (< too-cold (temperature (bear-porridge bear)) too-hot) (bear (bear-porridge bear)) "~a's porridge is not just right: ~a" bear (hotness (bear-porridge bear))) @@ -318,7 +318,7 @@ "Find all those elements of sequence that match item, according to the keywords. Doesn't alter sequence." (if test-not - (apply #'remove item sequence + (apply #'remove item sequence :test-not (complement test-not) keyword-args) (apply #'remove item sequence :test (complement test) keyword-args))) diff --git a/lisp/patmatch.lisp b/lisp/patmatch.lisp index c73550cf..fd3f9698 100644 --- a/lisp/patmatch.lisp +++ b/lisp/patmatch.lisp @@ -18,13 +18,13 @@ ((variable-p pattern) (match-variable pattern input bindings)) ((eql pattern input) bindings) - ((segment-pattern-p pattern) - (segment-matcher pattern input bindings)) + ((segment-pattern-p pattern) + (segment-matcher pattern input bindings)) ((single-pattern-p pattern) ; *** (single-matcher pattern input bindings)) ; *** - ((and (consp pattern) (consp input)) + ((and (consp pattern) (consp input)) (pat-match (rest pattern) (rest input) - (pat-match (first pattern) (first input) + (pat-match (first pattern) (first input) bindings))) (t fail))) @@ -41,7 +41,7 @@ (defun segment-pattern-p (pattern) "Is this a segment-matching pattern like ((?* var) . pat)?" - (and (consp pattern) (consp (first pattern)) + (and (consp pattern) (consp (first pattern)) (symbolp (first (first pattern))) (segment-match-fn (first (first pattern))))) @@ -62,12 +62,12 @@ (rest pattern) input bindings)) (defun segment-match-fn (x) - "Get the segment-match function for x, + "Get the segment-match function for x, if it is a symbol that has one." (when (symbolp x) (get x 'segment-match))) (defun single-match-fn (x) - "Get the single-match function for x, + "Get the single-match function for x, if it is a symbol that has one." (when (symbolp x) (get x 'single-match))) @@ -94,7 +94,7 @@ "Succeed if any one of the patterns match the input." (if (null patterns) fail - (let ((new-bindings (pat-match (first patterns) + (let ((new-bindings (pat-match (first patterns) input bindings))) (if (eq new-bindings fail) (match-or (rest patterns) input bindings) @@ -152,11 +152,11 @@ (and (progv (mapcar #'car bindings) (mapcar #'cdr bindings) (eval (second (first pattern)))) - (pat-match (rest pattern) input bindings))) + (pat-match (rest pattern) input bindings))) (defun pat-match-abbrev (symbol expansion) "Define symbol as a macro standing for a pat-match pattern." - (setf (get symbol 'expand-pat-match-abbrev) + (setf (get symbol 'expand-pat-match-abbrev) (expand-pat-match-abbrev expansion))) (defun expand-pat-match-abbrev (pat) @@ -166,14 +166,14 @@ (t (cons (expand-pat-match-abbrev (first pat)) (expand-pat-match-abbrev (rest pat)))))) -(defun rule-based-translator - (input rules &key (matcher 'pat-match) +(defun rule-based-translator + (input rules &key (matcher 'pat-match) (rule-if #'first) (rule-then #'rest) (action #'sublis)) "Find the first rule in rules that matches input, and apply the action to that rule." - (some + (some #'(lambda (rule) - (let ((result (funcall matcher (funcall rule-if rule) + (let ((result (funcall matcher (funcall rule-if rule) input))) (if (not (eq result fail)) (funcall action result (funcall rule-then rule))))) diff --git a/lisp/prolog.lisp b/lisp/prolog.lisp index 34bbf295..694180a7 100644 --- a/lisp/prolog.lisp +++ b/lisp/prolog.lisp @@ -63,7 +63,7 @@ found-so-far)))) (defun find-anywhere-if (predicate tree) - "does predicate apply to any atom in the tree?" + "does predicate apply to any atom in the tree?" (if (atom tree) (funcall predicate tree) (or (find-anywhere-if predicate (first tree)) @@ -119,7 +119,7 @@ (#\; t) (#\. nil) (#\newline (continue-p)) - (otherwise + (otherwise (format t " Type ; to see more or . to stop") (continue-p)))) diff --git a/lisp/prolog1.lisp b/lisp/prolog1.lisp index 17d3e955..1eab561f 100644 --- a/lisp/prolog1.lisp +++ b/lisp/prolog1.lisp @@ -40,7 +40,7 @@ (setf (get predicate 'clauses) nil)) (defun prove (goal bindings) - "Return a list of possible solutions to goal." + "Return a list of possible solutions to goal." (mapcan #'(lambda (clause) (let ((new-clause (rename-variables clause))) (prove-all (clause-body new-clause) @@ -76,7 +76,7 @@ found-so-far)))) (defun find-anywhere-if (predicate tree) - "Does predicate apply to any atom in the tree?" + "Does predicate apply to any atom in the tree?" (if (atom tree) (funcall predicate tree) (or (find-anywhere-if predicate (first tree)) @@ -91,7 +91,7 @@ (prove-all goals no-bindings))) (defun show-prolog-solutions (vars solutions) - "Print the variables in each of the solutions." + "Print the variables in each of the solutions." (if (null solutions) (format t "~&No.") (mapc #'(lambda (solution) (show-prolog-vars vars solution)) diff --git a/lisp/prologc.lisp b/lisp/prologc.lisp index f361543c..2947b513 100644 --- a/lisp/prologc.lisp +++ b/lisp/prologc.lisp @@ -171,7 +171,7 @@ (defun anonymous-variables-in (tree) "Return a list of all variables that occur only once in tree." (values (anon-vars-in tree nil nil))) - + (defun anon-vars-in (tree seen-once seen-more) "Walk the data structure TREE, returning a list of variabless seen once, and a list of variables seen more than once." @@ -288,8 +288,8 @@ (defun compile-clause (parms clause cont) "Transform away the head, and compile the resulting body." - (bind-unbound-vars - parms + (bind-unbound-vars + parms (compile-body (nconc (mapcar #'make-= parms (args (clause-head clause))) @@ -297,7 +297,7 @@ cont (mapcar #'self-cons parms)))) ;*** -(defvar *uncompiled* nil +(defvar *uncompiled* nil "Prolog symbols that have not been compiled.") (defun add-clause (clause) @@ -388,13 +388,13 @@ (cond ((null body) `(funcall ,cont)) - ((eq (first body) '!) ;*** + ((eq (first body) '!) ;*** `(progn ,(compile-body (rest body) cont bindings) ;*** (return-from ,*predicate* nil))) ;*** (t (let* ((goal (first body)) (macro (prolog-compiler-macro (predicate goal))) - (macro-val (if macro - (funcall macro goal (rest body) + (macro-val (if macro + (funcall macro goal (rest body) cont bindings)))) (if (and macro (not (eq macro-val :pass))) macro-val @@ -406,7 +406,7 @@ ,(if (null (rest body)) cont `#'(lambda () - ,(compile-body + ,(compile-body (rest body) cont (bind-new-variables bindings goal)))))))))) diff --git a/lisp/prologc1.lisp b/lisp/prologc1.lisp index 2c1055c7..69ecfaeb 100644 --- a/lisp/prologc1.lisp +++ b/lisp/prologc1.lisp @@ -2,7 +2,7 @@ ;;;; Code from Paradigms of AI Programming ;;;; Copyright (c) 1991 Peter Norvig -;;;; File prologc1.lisp: Version 1 of the prolog compiler, +;;;; File prologc1.lisp: Version 1 of the prolog compiler, ;;;; including the destructive unification routines from Chapter 11. (requires "prolog") diff --git a/lisp/prologc2.lisp b/lisp/prologc2.lisp index 154e56e9..e2068946 100644 --- a/lisp/prologc2.lisp +++ b/lisp/prologc2.lisp @@ -2,7 +2,7 @@ ;;;; Code from Paradigms of AI Programming ;;;; Copyright (c) 1991 Peter Norvig -;;;; File prologc2.lisp: Version 2 of the prolog compiler, +;;;; File prologc2.lisp: Version 2 of the prolog compiler, ;;;; fixing the first set of bugs. (requires "prolog") diff --git a/lisp/prologcp.lisp b/lisp/prologcp.lisp index 5f938369..7f026708 100644 --- a/lisp/prologcp.lisp +++ b/lisp/prologcp.lisp @@ -42,7 +42,7 @@ (defun call/1 (goal cont) "Try to prove goal by calling it." (deref goal) - (apply (make-predicate (first goal) + (apply (make-predicate (first goal) (length (args goal))) (append (args goal) (list cont)))) @@ -77,7 +77,7 @@ (call/1 goal #'(lambda () ;; Bug fix by mdf0%shemesh@gte.com (Mark Feblowitz) ;; on 25 Jan 1996; was deref-COPY - (push (deref-EXP exp) answers))) + (push (deref-EXP exp) answers))) (if (and (not (null answers)) (unify! result (nreverse answers))) (funcall cont)))) @@ -126,7 +126,7 @@ (unify! ?result (apply (first exp) (rest exp)))) (funcall cont))) -(defun repeat/0 (cont) +(defun repeat/0 (cont) (loop (funcall cont))) (<- (if ?test ?then) (if ?then ?else (fail))) diff --git a/lisp/search.lisp b/lisp/search.lisp index 7adb988b..426e6a4f 100644 --- a/lisp/search.lisp +++ b/lisp/search.lisp @@ -37,7 +37,7 @@ (remove-if #'(lambda (child) (> child n)) (binary-tree x)))) -(defun diff (num) +(defun diff (num) "Return the function that finds the difference from num." #'(lambda (x) (abs (- x num)))) @@ -45,7 +45,7 @@ "Return a combiner function that sorts according to cost-fn." #'(lambda (new old) (sort (append new old) #'< :key cost-fn))) - + (defun best-first-search (start goal-p successors cost-fn) "Search lowest cost states first until goal is reached." (tree-search (list start) goal-p successors (sorter cost-fn))) @@ -53,14 +53,14 @@ (defun price-is-right (price) "Return a function that measures the difference from price, but gives a big penalty for going over price." - #'(lambda (x) (if (> x price) + #'(lambda (x) (if (> x price) most-positive-fixnum (- price x)))) (defun beam-search (start goal-p successors cost-fn beam-width) "Search highest scoring states first until goal is reached, but never consider more than beam-width states at a time." - (tree-search (list start) goal-p successors + (tree-search (list start) goal-p successors #'(lambda (old new) (let ((sorted (funcall (sorter cost-fn) old new))) (if (> beam-width (length sorted)) @@ -71,10 +71,10 @@ (defparameter *cities* '((Atlanta 84.23 33.45) (Los-Angeles 118.15 34.03) - (Boston 71.05 42.21) (Memphis 90.03 35.09) - (Chicago 87.37 41.50) (New-York 73.58 40.47) + (Boston 71.05 42.21) (Memphis 90.03 35.09) + (Chicago 87.37 41.50) (New-York 73.58 40.47) (Denver 105.00 39.45) (Oklahoma-City 97.28 35.26) - (Eugene 123.05 44.03) (Pittsburgh 79.57 40.27) + (Eugene 123.05 44.03) (Pittsburgh 79.57 40.27) (Flagstaff 111.41 35.13) (Quebec 71.11 46.49) (Grand-Jct 108.37 39.05) (Reno 119.49 39.30) (Houston 105.00 34.00) (San-Francisco 122.26 37.47) @@ -89,7 +89,7 @@ (< (air-distance c city) 1000.0))) *cities*)) -(defun city (name) +(defun city (name) "Find the city with this name." (assoc name *cities*)) @@ -193,7 +193,7 @@ (defun graph-search (states goal-p successors combiner &optional (state= #'eql) old-states) "Find a state that satisfies goal-p. Start with states, - and search according to successors and combiner. + and search according to successors and combiner. Don't try the same state twice." (dbg :search "~&;; Search: ~a" states) (cond ((null states) fail) diff --git a/lisp/student.lisp b/lisp/student.lisp index 660e6bd9..d4f2513f 100644 --- a/lisp/student.lisp +++ b/lisp/student.lisp @@ -55,7 +55,7 @@ (defun student (words) "Solve certain Algebra Word Problems." - (solve-equations + (solve-equations (create-list-of-equations (translate-to-expression (remove-if #'noise-word-p words))))) @@ -96,7 +96,7 @@ (defun solve (equations known) "Solve a system of equations by constraint propagation." - ;; Try to solve for one equation, and substitute its value into + ;; Try to solve for one equation, and substitute its value into ;; the others. If that doesn't work, return what is known. (or (some #'(lambda (equation) (let ((x (one-unknown equation))) diff --git a/lisp/syntax1.lisp b/lisp/syntax1.lisp index 67cc4bd9..bea86e48 100644 --- a/lisp/syntax1.lisp +++ b/lisp/syntax1.lisp @@ -31,7 +31,7 @@ (defun rules-starting-with (cat) "Return a list of rules where cat starts the rhs." - (find-all cat *grammar* + (find-all cat *grammar* :key #'(lambda (rule) (first-or-nil (rule-rhs rule))))) (defun complete-parses (parses) diff --git a/lisp/syntax2.lisp b/lisp/syntax2.lisp index ddb8db45..2601e913 100644 --- a/lisp/syntax2.lisp +++ b/lisp/syntax2.lisp @@ -24,7 +24,7 @@ (defun rules-starting-with (cat) "Return a list of rules where cat starts the rhs." - (find-all cat *grammar* + (find-all cat *grammar* :key #'(lambda (rule) (first-or-nil (rule-rhs rule))))) (defun first-or-nil (x) diff --git a/lisp/syntax3.lisp b/lisp/syntax3.lisp index 3a94d1ff..b9c34bd1 100644 --- a/lisp/syntax3.lisp +++ b/lisp/syntax3.lisp @@ -7,7 +7,7 @@ (defvar *grammar* "The grammar used by GENERATE.") -(defstruct (rule (:type list) +(defstruct (rule (:type list) (:constructor rule (lhs -> rhs &optional sem score))) lhs -> rhs sem score) @@ -18,7 +18,7 @@ "Switch to a new grammar." (clear-memoize 'rules-starting-with) (clear-memoize 'lexical-rules) - (length (setf *grammar* + (length (setf *grammar* (mapcar #'(lambda (r) (apply #'rule r)) grammar)))) @@ -32,7 +32,7 @@ (defun rules-starting-with (cat) "Return a list of rules where cat starts the rhs." - (find-all cat *grammar* + (find-all cat *grammar* :key #'(lambda (rule) (first-or-nil (rule-rhs rule))))) (defun first-or-nil (x) @@ -106,7 +106,7 @@ (mapcan #'(lambda (p) (if (eq (parse-lhs p) (first needed)) - (extend-parse lhs sem score + (extend-parse lhs sem score (append1 rhs (parse-tree p)) ;*** (parse-rem p) (rest needed)))) (parse rem)))) @@ -245,5 +245,5 @@ (if (null bag) nil (let ((e (random-elt bag))) - (cons e (permute (remove e bag :count 1 :test #'eq)))))) + (cons e (permute (remove e bag :count 1 :test #'eq)))))) diff --git a/lisp/tutor.lisp b/lisp/tutor.lisp index 84a2e230..8448d24c 100644 --- a/lisp/tutor.lisp +++ b/lisp/tutor.lisp @@ -9,8 +9,8 @@ (defvar *chapters* '() "List of chapter structures, one per chapter.") (defun do-examples (chapters &optional (stream *standard-output*)) - "Run examples from one or more chapters and sum the number of errors. - If all is well, this should return 0. If STREAM is nil, very little + "Run examples from one or more chapters and sum the number of errors. + If all is well, this should return 0. If STREAM is nil, very little output is produced." (loop with *package* = (or (find-package :paip) *package*) for chapter in (cond ((member chapters '(all :all)) *chapters*) @@ -19,8 +19,8 @@ sum (do-chapter chapter stream))) (defmacro defexamples (chapter-number title &rest examples) - "Define a set of test examples. Each example is of the form - (exp [ => result ] [ @ page ] [ :input string ]) + "Define a set of test examples. Each example is of the form + (exp [ => result ] [ @ page ] [ :input string ]) where [] indicates an optional part, and the parts can be in any order. Evaluate exp and complain if it is not equal to result. The page is the page in the book where the example appears. An 'example' may also be @@ -33,7 +33,7 @@ "Run the examples in a chapter. Return the number of unexpected results." (let ((chapter (find-chapter chapter))) (set-chapter chapter interface) - (let ((n (count-if-not + (let ((n (count-if-not #'(lambda (example) (do-example example interface)) (chapter-examples chapter)))) @@ -43,7 +43,7 @@ (format t "~%Chapter ~D done.~%" chapter)) n))) -(defstruct (chapter (:print-function +(defstruct (chapter (:print-function (lambda (chapter stream depth) (declare (ignore depth)) (format stream "~2D. ~A" (chapter-number chapter) @@ -52,10 +52,10 @@ (defun add-chapter (number title examples) "The functional interface for defexamples: adds test examples." - (let ((chapter (make-chapter :number number :title title + (let ((chapter (make-chapter :number number :title title :examples examples))) - (setf *chapters* - (sort + (setf *chapters* + (sort (cons chapter (delete number *chapters* :key #'chapter-number)) #'< :key #'chapter-number)) chapter)) @@ -99,9 +99,9 @@ (setf result (eval exp))) (when stream (format stream "~&~S~%" result)) - (unless (or (equal expected ':anything) + (unless (or (equal expected ':anything) (nearly-equal result expected)) - (if stream + (if stream (format *terminal-io* "~%**** expected ~S" expected) (format *terminal-io* @@ -127,8 +127,8 @@ (FLOAT (and (floatp y) (< (abs (- x y)) epsilon))) (VECTOR (and (vectorp y) (eql (length x) (length y)) (nearly-equal (coerce x 'list) (coerce y 'list)))) - (CONS (and (consp y) - (nearly-equal (car x) (car y)) + (CONS (and (consp y) + (nearly-equal (car x) (car y)) (nearly-equal (cdr x) (cdr y)))) (T (equal x y))))) @@ -139,18 +139,18 @@ ;;; If you want to write a GUI for the tutor, you need to do four things: ;;; (1) Define a class (or structure) which we call an interface -- it -;;; is the window in which the examples will be displayed. +;;; is the window in which the examples will be displayed. ;;; (2) Define the function PAIP-TUTOR which should start up the interface. ;;; (3) Implement the following six methods on your interface: -;;; SET-CHAPTER, SET-PAGE, SET-EXAMPLE, +;;; SET-CHAPTER, SET-PAGE, SET-EXAMPLE, ;;; DISPLAY-EXAMPLE, DISPLAY-SECTION, OUTPUT-STREAM ;;; (4) Edit the file "auxfns.lisp" to include your files. ;;; Below we show an implementation for the five methods that is good -;;; for output streams (without any fancy window GUI). +;;; for output streams (without any fancy window GUI). (defmethod set-chapter (chapter interface) diff --git a/lisp/unifgram.lisp b/lisp/unifgram.lisp index a50ffe2f..14b6f830 100644 --- a/lisp/unifgram.lisp +++ b/lisp/unifgram.lisp @@ -55,7 +55,7 @@ "Build an augmented DCG rule that handles :sem, :ex, and automatic conjunctiontive constituents." (if (eq (last1 head) :sem) - ;; Handle :sem + ;; Handle :sem (let* ((?sem (gensym "?SEM"))) (make-augmented-dcg `(,@(butlast head) ,?sem) @@ -64,7 +64,7 @@ ;; Separate out examples from body (multiple-value-bind (exs new-body) (partition-if #'(lambda (x) (starts-with x :ex)) body) - ;; Handle conjunctions + ;; Handle conjunctions (let ((rule `(rule ,(handle-conj head) --> ,@new-body))) (if (null exs) rule diff --git a/lisp/unify.lisp b/lisp/unify.lisp index 104d6ceb..528b9de8 100644 --- a/lisp/unify.lisp +++ b/lisp/unify.lisp @@ -15,7 +15,7 @@ ((variable-p x) (unify-variable x y bindings)) ((variable-p y) (unify-variable y x bindings)) ((and (consp x) (consp y)) - (unify (rest x) (rest y) + (unify (rest x) (rest y) (unify (first x) (first y) bindings))) (t fail))) diff --git a/lisp/waltz.lisp b/lisp/waltz.lisp index 0cdfe235..fefad372 100644 --- a/lisp/waltz.lisp +++ b/lisp/waltz.lisp @@ -29,7 +29,7 @@ (defun possible-labelings (vertex-type) "The list of possible labelings for a given vertex type." - ;; In these labelings, R means an arrow pointing away from + ;; In these labelings, R means an arrow pointing away from ;; the vertex, L means an arrow pointing towards it. (case vertex-type ((L) '((R L) (L R) (+ R) (L +) (- L) (R -))) @@ -74,21 +74,21 @@ ;; Account for the L-R mismatch with reverse-label. (find-all-if #'(lambda (labeling) - (every #'member (mapcar #'reverse-label labeling) + (every #'member (mapcar #'reverse-label labeling) neighbor-labels)) (vertex-labelings vertex)))) (defun search-solutions (diagram) "Try all labelings for one ambiguous vertex, and propagate." ;; If there is no ambiguous vertex, return the diagram. - ;; If there is one, make copies of the diagram trying each of + ;; If there is one, make copies of the diagram trying each of ;; the possible labelings. Propagate constraints and append ;; all the solutions together. (let ((v (find-if #'ambiguous-vertex-p (diagram-vertexes diagram)))) (if (null v) (list diagram) - (mapcan + (mapcan #'(lambda (v-labeling) (let* ((diagram2 (make-copy-diagram diagram)) (v2 (find-vertex (vertex-name v) diagram2))) @@ -173,7 +173,7 @@ "Build the vertex corresponding to the descriptor." ;; Descriptors are like: (x L y z) (make-vertex - :name (first vertex-descriptor) + :name (first vertex-descriptor) :type (second vertex-descriptor) :labelings (possible-labelings (second vertex-descriptor)))) @@ -183,13 +183,13 @@ (defun make-copy-diagram (diagram) "Make a copy of a diagram, preserving connectivity." - (let* ((new (make-diagram + (let* ((new (make-diagram :vertexes (mapcar #'copy-vertex (diagram-vertexes diagram))))) ;; Put in the neighbors for each vertex (dolist (v (diagram-vertexes new)) (setf (vertex-neighbors v) - (mapcar #'(lambda (neighbor) + (mapcar #'(lambda (neighbor) (find-vertex (vertex-name neighbor) new)) (vertex-neighbors v)))) new)) @@ -213,7 +213,7 @@ (defmacro defdiagram (name &rest vertex-descriptors) "Define a diagram. A copy can be gotten by (diagram name)." - `(put-diagram ',name (construct-diagram + `(put-diagram ',name (construct-diagram (check-diagram ',vertex-descriptors)))) (defun check-diagram (vertex-descriptors)