├── .gitattributes ├── .gitignore ├── Lisp Books 2.png ├── zahl-raten.lisp ├── README.md ├── threaded-make-random-vector.lisp ├── dot-slot-value-access.lisp ├── kata-roman-mumerals.lisp ├── kw-zebra.lisp ├── collapse.lisp ├── fowler-dsl-example.lisp ├── hash-table-reader-printer.lisp ├── hash-table-reader-printer-h.lisp ├── life.lisp ├── json.lisp ├── usenet-extensions.lisp ├── micro-talespin.lisp └── pbi-code.lisp /.gitattributes: -------------------------------------------------------------------------------- 1 | *.lisp diff=lisp 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | *.64xfasl 3 | *.dx64fsl 4 | *.abcl 5 | *.fasl 6 | *~ 7 | -------------------------------------------------------------------------------- /Lisp Books 2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lispm/CommonLispCode/HEAD/Lisp Books 2.png -------------------------------------------------------------------------------- /zahl-raten.lisp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lispm/CommonLispCode/HEAD/zahl-raten.lisp -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # CommonLispCode 2 | 3 | This is some random Common Lisp stuff I've collected. 4 | -------------------------------------------------------------------------------- /threaded-make-random-vector.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright Rainer Joswig, joswig@lisp.de, 2012 2 | 3 | ;;; Example for creating a vector of random numbers, using N-THREADS 4 | 5 | #-lispworks6 6 | (cerror "only runs in LispWorks 6 and above using the barrier functionality") 7 | 8 | (defun make-random-vector (&key (size 10000) (n-threads 4)) 9 | (let ((vector (make-sequence 'vector size)) 10 | (barrier (mp:make-barrier (1+ n-threads))) 11 | (delta (truncate size n-threads))) 12 | (loop for i below n-threads 13 | do (mp:process-run-function 14 | "initializing vector" 15 | nil 16 | (lambda (vector start end barrier) 17 | (loop for i from start below end do 18 | (setf (svref vector i) (random 1.0))) 19 | (mp:barrier-wait barrier :pass-through t)) 20 | vector 21 | (* i delta) 22 | (+ delta (* i delta)) 23 | barrier)) 24 | (mp:barrier-wait barrier) 25 | vector)) 26 | -------------------------------------------------------------------------------- /dot-slot-value-access.lisp: -------------------------------------------------------------------------------- 1 | ;;; Dot notation for slot values 2 | 3 | ;;; Rainer Joswig, joswig@lisp.de, 2012 4 | 5 | 6 | ; Example 7 | ; 8 | ; #!turtle.drawing.pen-down-p 9 | ; 10 | ; expands to 11 | ; 12 | ; (slot-value (slot-value turtle 'drawing) 'pen-down-p) 13 | ; 14 | 15 | 16 | (defun make-calls (string) 17 | (let ((symbols (reverse 18 | (mapcar (lambda (string) 19 | (intern string)) 20 | (split-sequence '(#\.) string))))) 21 | (labels ((nest (list) 22 | (if (not (cddr list)) 23 | `(slot-value ,(second list) ',(first list)) 24 | `(slot-value ,(nest (cdr list)) 25 | ',(first list))))) 26 | (nest symbols)))) 27 | 28 | (defun read-instance-slot-value (stream subchar arg) 29 | (declare (ignore subchar arg)) 30 | (make-calls (symbol-name (let ((*readtable* (copy-readtable nil))) 31 | (read stream))))) 32 | 33 | (set-dispatch-macro-character 34 | #\# #\! 35 | #'read-instance-slot-value) 36 | 37 | 38 | -------------------------------------------------------------------------------- /kata-roman-mumerals.lisp: -------------------------------------------------------------------------------- 1 | ;;; Code Kata: Roman Numerals 2 | ;;; Rainer Joswig, 2012 3 | 4 | (defparameter *roman-number-descriptors* 5 | '((M 1000 900) 6 | (D 500 400) 7 | (C 100 90) 8 | (L 50 40) 9 | (X 10 9) 10 | (V 5 4) 11 | (I 1 1)) 12 | "list of (roman-digit decimal-digit interval-start)") 13 | 14 | (defun roman-digit-to-decimal-value (roman-digit) 15 | "Returns the decimal value for a roman digit." 16 | (second (assoc roman-digit *roman-number-descriptors*))) 17 | 18 | (defun find-descriptor (n) 19 | "find the roman number descriptor for a number" 20 | (find-if (lambda (desc) 21 | (>= n (third desc))) 22 | *roman-number-descriptors*)) 23 | 24 | (defun print-as-roman (n) 25 | "prints the integer as a roman number" 26 | (check-type n (integer 1 3000)) 27 | (loop while (plusp n) do 28 | (destructuring-bind (r d s) 29 | (find-descriptor n) 30 | (let ((p (- d s))) 31 | (when (and (< n d) (plusp p)) 32 | (write (first (find-descriptor p))) 33 | (incf n p))) 34 | (write r) 35 | (decf n d)))) 36 | 37 | (defun test-all-roman-numbers () 38 | (macrolet ((str (&body body) 39 | `(with-output-to-string (*standard-output*) 40 | ,@body))) 41 | (loop for i from 1 upto 3000 42 | always (string= (str (format t "~@R" i)) 43 | (str (print-as-roman i)))))) 44 | 45 | 46 | -------------------------------------------------------------------------------- /kw-zebra.lisp: -------------------------------------------------------------------------------- 1 | 2 | ;;; Zebra Problem in LispWorks' KnowledgeWorks Prolog 3 | 4 | ;; adapted from Peter Norvig's book PAIP by Rainer Joswig, 2012, joswig@lisp.de 5 | 6 | (require "prolog") 7 | 8 | (in-package "CP-USER") 9 | 10 | ;;;; Section 11.4 (The Zebra Problem) 11 | 12 | (clog:defrel 13 | nextto 14 | ((nextto ?x ?y ?list) (iright ?x ?y ?list)) 15 | ((nextto ?x ?y ?list) (iright ?y ?x ?list))) 16 | 17 | (clog:defrel 18 | iright 19 | ((iright ?left ?right (?left ?right . ?rest))) 20 | ((iright ?left ?right (?x . ?rest)) 21 | (iright ?left ?right ?rest))) 22 | 23 | (clog:defrel 24 | zebra 25 | ((zebra ?h ?w ?z) 26 | ;; Each house is of the form: 27 | ;; (house nationality pet cigarette drink house-color) 28 | (= ?h ((house norwegian ? ? ? ?) ;1,10 29 | ? 30 | (house ? ? ? milk ?) ? ?)) ; 9 31 | (member (house englishman ? ? ? red) ?h) ; 2 32 | (member (house spaniard dog ? ? ?) ?h) ; 3 33 | (member (house ? ? ? coffee green) ?h) ; 4 34 | (member (house ukrainian ? ? tea ?) ?h) ; 5 35 | (iright (house ? ? ? ? ivory) ; 6 36 | (house ? ? ? ? green) ?h) 37 | (member (house ? snails winston ? ?) ?h) ; 7 38 | (member (house ? ? kools ? yellow) ?h) ; 8 39 | (nextto (house ? ? chesterfield ? ?) ;11 40 | (house ? fox ? ? ?) ?h) 41 | (nextto (house ? ? kools ? ?) ;12 42 | (house ? horse ? ? ?) ?h) 43 | (member (house ? ? luckystrike oj ?) ?h) ;13 44 | (member (house japanese ? parliaments ? ?) ?h) ;14 45 | (nextto (house norwegian ? ? ? ?) ;15 46 | (house ? ? ? ? blue) ?h) 47 | (member (house ?w ? ? water ?) ?h) ;Q1 48 | (member (house ?z zebra ? ? ?) ?h))) ;Q2 49 | 50 | 51 | ; (logic '(zebra ?houses ?water-drinker ?zebra-owner) :return-type :alist) 52 | ; or call the Prolog REPL with (rqp) 53 | -------------------------------------------------------------------------------- /collapse.lisp: -------------------------------------------------------------------------------- 1 | ;;; Lisp 1 vs. Common Lisp vs. Scheme vs. Emacs Lisp 2 | 3 | ;;; Rainer Joswig, joswig@lisp.de, 2012 4 | 5 | ;;; The original code is from 6 | ;;; THE LISP 1 PROGRAMMER'S MANUAL FROM 1960, PAGE 99FF 7 | 8 | ; the Lisp 1 Programmer's manual is the first manual for the first Lisp implementation. 9 | ; DEFINE then was the operator to define new function.s 10 | ; With minor rewriting the code runs largely unchanged in Common Lisp. 11 | ; That's what makes Common Lisp one of the main Lisp dialects: 12 | ; 13 | ; it still contains at its core the original functionality of LISP from 1960. 14 | ; 15 | ; This makes it possible to understand code from decades back to the 1960s. 16 | ; 17 | ; One can see below that both Emacs Lisp and Scheme are two other languages 18 | ; which can express the same program also with only minor changes. 19 | 20 | 21 | #| 22 | 23 | ; THE LISP 1 PROGRAMMER'S MANUAL FROM 1960, PAGE 99FF: 24 | ; http://bitsavers.org/pdf/mit/rle_lisp/LISP_I_Programmers_Manual_Mar60.pdf 25 | 26 | ; Lisp 1 used DEFINE to define functions. The comma character was whitespace 27 | ; between the list elements. 28 | 29 | DEFINE 30 | (((COLLAPSE,(LAMBDA,(L),(COND, 31 | ((ATOM,L),(CONS,L,NIL)) 32 | ((NULL,(CDR,L)), 33 | (COND,((ATOM,(CAR,L)),L),(T,(COLLAPSE,(CAR,L))))) 34 | (T,(APPEND,(COLLAPSE,(CAR,L)),(COLLAPSE,(CDR,L))))) 35 | )))))) 36 | 37 | |# 38 | 39 | 40 | ; THE SAME, JUST REFORMATTED, IN COMMON LISP: 41 | 42 | (DEFUN COLLAPSE (L) 43 | (COND 44 | ((ATOM L) (CONS L NIL)) 45 | ((NULL (CDR L)) 46 | (COND ((ATOM (CAR L)) L) 47 | (T (COLLAPSE (CAR L))))) 48 | (T (APPEND (COLLAPSE (CAR L)) 49 | (COLLAPSE (CDR L)))))) 50 | 51 | #| 52 | 53 | CL-USER > (COLLAPSE '(((A B) ((C))) ((D (E F)) (G) ((H))))) 54 | (A B C D E F G H) 55 | 56 | |# 57 | 58 | ; Scheme 59 | 60 | (define collapse 61 | (lambda (l) 62 | (cond 63 | ((atom? l) (cons l '())) 64 | ((null? (cdr l)) 65 | (cond ((atom? (car l)) l) 66 | (else (collapse (car l))))) 67 | (else (append (collapse (car l)) 68 | (collapse (cdr l))))))) 69 | 70 | ; Emacs Lisp 71 | 72 | (defun collapse (l) 73 | (cond 74 | ((atom l) (cons l nil)) 75 | ((null (cdr l)) 76 | (cond ((atom (car l)) l) 77 | (t (collapse (car l))))) 78 | (t (append (collapse (car l)) 79 | (collapse (cdr l)))))) 80 | -------------------------------------------------------------------------------- /fowler-dsl-example.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Package: "COMMON-LISP-USER"; BASE: 10.; Syntax: ANSI-COMMON-LISP; Default-Character-Style: (:FIX :ROMAN :NORMAL);-*- 2 | 3 | ;;; Copyright Rainer Joswig, joswig@lisp.de, 2012 4 | 5 | ;;; ================================================================ 6 | ;;; short 7 | 8 | (LET ((S "SVCLFOWLER 10101MS0120050313......................... 9 | SVCLHOHPE 10201DX0320050315........................ 10 | SVCLTWO X10301MRP220050329.............................. 11 | USGE10301TWO X50214..7050329") (M '((SVCL (NAME 4 19) (ID 19 24) (CALL-TYPE-CODE 24 28) (DATE-OF-CALL 28 36)) (USGE (ID 4 9) (NAME 9 23) (CYCLE 30 31) (READ-DATE 31 36))))) (MAPCAR (LAMBDA (L &AUX (N (SUBSEQ L 0 4))) (CONS N (MAPCAR (LAMBDA (A) (LIST (CAR A) (SUBSEQ L (CADR A) (CADDR A)))) (CDR (ASSOC N M :TEST #'STRING=))))) (SPLIT-SEQUENCE '(#\NEWLINE) S))) 12 | 13 | 14 | ; or 15 | 16 | (let ((text "SVCLFOWLER 10101MS0120050313......................... 17 | SVCLHOHPE 10201DX0320050315........................ 18 | SVCLTWO X10301MRP220050329.............................. 19 | USGE10301TWO X50214..7050329") 20 | (mappings '((svcl (name 4 19) (id 19 24) (call-type-code 24 28) (date-of-call 28 36)) 21 | (usge (id 4 9) (name 9 23) (cycle 30 31) (read-date 31 36))))) 22 | (mapcar (lambda (line &aux (name (subseq line 0 4))) 23 | (cons name (mapcar (lambda (fields) 24 | (list (car fields) (subseq line (cadr fields) (caddr fields)))) 25 | (cdr (assoc name mappings :test #'string=))))) 26 | (split-sequence '(#\newline) text))) 27 | 28 | 29 | ;;; ================================================================ 30 | ;;; different lengths keys 31 | 32 | (defparameter *example-text* 33 | "SVCLFOWLER 10101MS0120050313......................... 34 | SVCLHOHPE 10201DX0320050315........................ 35 | SVCLTWO X10301MRP220050329.............................. 36 | USGE10301TWO X50214..7050329") 37 | 38 | (defparameter *mappings* 39 | '(("SVC" (name 4 19) 40 | (id 19 24) 41 | (call-type-code 24 28) 42 | (date-of-call 28 36)) 43 | ("USGE" (id 4 9) 44 | (name 9 23) 45 | (cycle 30 31) 46 | (read-date 31 36)))) 47 | 48 | (defun find-mapping (line mappings) 49 | (find-if (lambda (item) 50 | (string-equal line (first item) :end1 (length (first item)))) 51 | mappings)) 52 | 53 | (defun parse-log-lines-example (text mappings) 54 | (mapcar (lambda (line) 55 | (destructuring-bind (name . fields) 56 | (find-mapping line mappings) 57 | (cons name (mapcar (lambda (field) 58 | (list (car field) (subseq line (cadr field) (caddr field)))) 59 | fields)))) 60 | (split-sequence '(#\newline) text))) 61 | 62 | ;;; ================================================================ 63 | ;;; Using a literal hash-table 64 | 65 | (defparameter *example-text* 66 | "SVCLFOWLER 10101MS0120050313......................... 67 | SVCLHOHPE 10201DX0320050315........................ 68 | SVCLTWO X10301MRP220050329.............................. 69 | USGE10301TWO X50214..7050329") 70 | 71 | (defparameter *mappings* 72 | '#3{("svcl" ((name 4 19) 73 | (id 19 24) 74 | (call-type-code 24 28) 75 | (date-of-call 28 36))) 76 | ("usge" ((id 4 9) 77 | (name 9 23) 78 | (cycle 30 31) 79 | (read-date 31 36)))}) 80 | 81 | (defun parse-log-lines-example (text mappings) 82 | (mapcar (lambda (line &aux (name (subseq line 0 4))) 83 | (cons name 84 | (mapcar (lambda (fields) 85 | (list (car fields) 86 | (subseq line (cadr fields) (caddr fields)))) 87 | (gethash name mappings)))) 88 | (split-sequence '(#\newline) text))) 89 | 90 | -------------------------------------------------------------------------------- /hash-table-reader-printer.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Package: ("HASH-TABLE-READER-PRINTER" :USE "COMMON-LISP"); BASE: 10.; Syntax: ANSI-COMMON-LISP; Default-Character-Style: (:FIX :ROMAN :NORMAL);-*- 2 | 3 | ;;;; a simple hash-table reader and printer in Common Lisp 4 | 5 | ;;; Copyright 2012, Rainer Joswig, joswig@lisp.de 6 | 7 | ;;; Tested in LispWorks 6.1. 8 | 9 | ;;; use: 10 | ;;; reads #{(a 1) (b 2)} as a hash-table 11 | ;;; arguments can determine the test function: 12 | ;;; this use EQUALP: #3{("a" 1) ("B" 2)} 13 | 14 | ;;; ================================================================ 15 | ;;; Package HASH-TABLE-READER-PRINTER 16 | 17 | (cl:defpackage "HASH-TABLE-READER-PRINTER" 18 | (:use "COMMON-LISP") 19 | (:export 20 | "INSTALL-HASH-TABLE-SYNTAX" 21 | "PRINT-HASH-TABLE" 22 | )) 23 | 24 | (in-package "HASH-TABLE-READER-PRINTER") 25 | 26 | 27 | ;;; ================================================================ 28 | ;;; reading 29 | 30 | (defparameter *comparison-functions* 31 | '(eq eql equal equalp)) 32 | 33 | (defun read-hash-table (stream character n &aux (delimiter #\})) 34 | (declare (ignore character)) 35 | (let ((table (make-hash-table :test 36 | (if n 37 | (nth n *comparison-functions*) 38 | 'eql)))) 39 | (loop until (char= (peek-char t stream) delimiter) 40 | do (destructuring-bind (key value) 41 | (read stream) 42 | (setf (gethash key table) value))) 43 | (read-char stream) 44 | table)) 45 | 46 | (defun install-hash-table-syntax (&optional (readtable *readtable*)) 47 | (set-dispatch-macro-character #\# #\{ 'read-hash-table) 48 | (set-syntax-from-char #\} #\) readtable) 49 | readtable) 50 | 51 | (install-hash-table-syntax) 52 | 53 | ;;; ================================================================ 54 | ;;; printing 55 | 56 | (defun print-hash-table (hash-table &optional (stream *standard-output*)) 57 | (write-char #\# stream) 58 | (cond ((eq (hash-table-test hash-table) 'eql) 'do-nothing) 59 | ((member (hash-table-test hash-table) *comparison-functions*) 60 | (write (position (hash-table-test hash-table) *comparison-functions*) 61 | :stream stream))) 62 | (write-char #\{ stream) 63 | (let ((first-p t)) 64 | (maphash (lambda (key value) 65 | (if first-p 66 | (setf first-p (not first-p)) 67 | (write-char #\space stream)) 68 | (prin1 (list key value) stream)) 69 | hash-table)) 70 | (write-char #\} stream) 71 | hash-table) 72 | 73 | (defun pprint-hash-table (*standard-output* hash-table) 74 | (pprint-logical-block 75 | (*standard-output* 76 | nil 77 | :prefix (cond ((eq (hash-table-test hash-table) 'eql) 78 | "#{") 79 | ((member (hash-table-test hash-table) 80 | *comparison-functions*) 81 | (format nil "#~a{" 82 | (position (hash-table-test hash-table) 83 | *comparison-functions*))) 84 | (t "#{")) 85 | 86 | :suffix "}") 87 | (let ((end (hash-table-count hash-table)) (i 0)) 88 | (when (plusp end) 89 | (block printing 90 | (maphash (lambda (key value) 91 | (pprint-pop) 92 | (write (list key value)) 93 | (if (= (incf i) end) (return-from printing nil)) 94 | (write-char #\Space) 95 | (pprint-newline :fill)) 96 | hash-table)))))) 97 | 98 | (set-pprint-dispatch 'hash-table 'pprint-hash-table) 99 | 100 | 101 | ;;; ================================================================ 102 | ;;; Examples 103 | 104 | ; #{(a 5) (c 6) (b 3)} ; uses EQL as the test function 105 | ; #2{("a" 5) ("c" 6) ("b" 3)} ; uses EQUAL as the test function 106 | 107 | 108 | ;;; ================================================================ 109 | ;;; End of File 110 | -------------------------------------------------------------------------------- /hash-table-reader-printer-h.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Package: ("HASH-TABLE-READER-PRINTER" :USE "COMMON-LISP"); BASE: 10.; Syntax: ANSI-COMMON-LISP; Default-Character-Style: (:FIX :ROMAN :NORMAL);-*- 2 | 3 | ;;;; a simple hash-table reader and printer in Common Lisp 4 | 5 | ;;; Copyright 2012, Rainer Joswig, joswig@lisp.de 6 | 7 | ;;; Tested in LispWorks 6.1. 8 | 9 | ;;; use: 10 | ;;; reads #H((a 1) (b 2)) as a hash-table 11 | ;;; arguments can determine the test function: 12 | ;;; this use EQUALP: #3H(("a" 1) ("B" 2)) 13 | 14 | ;;; ================================================================ 15 | ;;; Package HASH-TABLE-READER-PRINTER 16 | 17 | (cl:defpackage "HASH-TABLE-READER-PRINTER" 18 | (:use "COMMON-LISP") 19 | (:export 20 | "INSTALL-HASH-TABLE-SYNTAX" 21 | "PRINT-HASH-TABLE" 22 | )) 23 | 24 | (in-package "HASH-TABLE-READER-PRINTER") 25 | 26 | 27 | ;;; ================================================================ 28 | ;;; reading 29 | 30 | (defparameter *comparison-functions* 31 | '(eq eql equal equalp)) 32 | 33 | (defun read-hash-table (stream character n &aux (delimiter #\))) 34 | (declare (ignore character)) 35 | (read-char stream) 36 | (let ((table (make-hash-table :test 37 | (if n 38 | (nth n *comparison-functions*) 39 | 'eql)))) 40 | (loop until (char= (peek-char t stream) delimiter) 41 | do (destructuring-bind (key value) 42 | (read stream) 43 | (setf (gethash key table) value))) 44 | (read-char stream) 45 | table)) 46 | 47 | (defun install-hash-table-syntax (&optional (readtable *readtable*)) 48 | (set-dispatch-macro-character #\# #\H 'read-hash-table) 49 | (set-dispatch-macro-character #\# #\h 'read-hash-table) 50 | readtable) 51 | 52 | (install-hash-table-syntax) 53 | 54 | ;;; ================================================================ 55 | ;;; printing 56 | 57 | (defun print-hash-table (hash-table &optional (stream *standard-output*)) 58 | (write-char #\# stream) 59 | (cond ((eq (hash-table-test hash-table) 'eql) 'do-nothing) 60 | ((member (hash-table-test hash-table) *comparison-functions*) 61 | (write (position (hash-table-test hash-table) *comparison-functions*) 62 | :stream stream))) 63 | (write-string "H(" stream) 64 | (let ((first-p t)) 65 | (maphash (lambda (key value) 66 | (if first-p 67 | (setf first-p (not first-p)) 68 | (write-char #\space stream)) 69 | (prin1 (list key value) stream)) 70 | hash-table)) 71 | (write-char #\) stream) 72 | hash-table) 73 | 74 | (defun pprint-hash-table (*standard-output* hash-table) 75 | (pprint-logical-block 76 | (*standard-output* 77 | nil 78 | :prefix (cond ((eq (hash-table-test hash-table) 'eql) 79 | "#H(") 80 | ((member (hash-table-test hash-table) 81 | *comparison-functions*) 82 | (format nil "#~aH(" 83 | (position (hash-table-test hash-table) 84 | *comparison-functions*))) 85 | (t "#H(")) 86 | 87 | :suffix ")") 88 | (let ((end (hash-table-count hash-table)) (i 0)) 89 | (when (plusp end) 90 | (block printing 91 | (maphash (lambda (key value) 92 | (pprint-pop) 93 | (write (list key value)) 94 | (if (= (incf i) end) (return-from printing nil)) 95 | (write-char #\Space) 96 | (pprint-newline :fill)) 97 | hash-table)))))) 98 | 99 | (set-pprint-dispatch 'hash-table 'pprint-hash-table) 100 | 101 | 102 | ;;; ================================================================ 103 | ;;; Examples 104 | 105 | ; #H((a 5) (c 6) (b 3)) ; uses EQL as the test function 106 | ; #2H(("a" 5) ("c" 6) ("b" 3)) ; uses EQUAL as the test function 107 | 108 | 109 | ;;; ================================================================ 110 | ;;; End of File 111 | -------------------------------------------------------------------------------- /life.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Game of Life 2 | 3 | ;;; Clojure Version 4 | 5 | ;; http://programmablelife.blogspot.de/2012/08/conways-game-of-life-in-clojure.html 6 | ;; http://dl.dropbox.com/u/84194941/Code/Clojure/conways_game_of_life.clj 7 | 8 | #|| 9 | 10 | (ns conways-game-of-life.core) 11 | 12 | (defn create-world 13 | "Creates rectangular world with the specified width and height. 14 | Optionally takes coordinates of living cells." 15 | [w h & living-cells] 16 | (vec (for [y (range w)] 17 | (vec (for [x (range w)] 18 | (if (contains? (first living-cells) [y x]) "X" " ")))))) 19 | 20 | (defn neighbours 21 | "Determines all the neighbours of a given coordinate" 22 | [[x y]] 23 | (for [dx [-1 0 1] dy [-1 0 1] :when (not= 0 dx dy)] 24 | [(+ dx x) (+ dy y)])) 25 | 26 | (defn stepper 27 | "Returns a step function for Life-like cell automata. 28 | neighbours takes a location and return a sequential collection 29 | of locations. survive? and birth? are predicates on the number 30 | of living neighbours." 31 | [neighbours birth? survive?] 32 | (fn [cells] 33 | (set (for [[loc n] (frequencies (mapcat neighbours cells)) 34 | :when (if (cells loc) (survive? n) (birth? n))] 35 | loc)))) 36 | 37 | ; patterns 38 | (def glider #{[2 0] [2 1] [2 2] [1 2] [0 1]}) 39 | (def light-spaceship #{[2 0] [4 0] [1 1] [1 2] [1 3] [4 3] [1 4] [2 4] [3 4]}) 40 | 41 | ; steppers 42 | (def conway-stepper (stepper neighbours #{3} #{2 3})) 43 | 44 | (defn conway 45 | "Generates world of given size with initial pattern in specified generation" 46 | [[w h] pattern iterations] 47 | (->> (iterate conway-stepper pattern) 48 | (drop iterations) 49 | first 50 | (create-world w h) 51 | (map println))) 52 | 53 | ;; sample queries 54 | ;(conway [5 15] light-spaceship 4) 55 | ;(map (comp println #(conway [5 15] light-spaceship %)) (range 5)) 56 | ;(map (comp println #(conway [4 4] glider %)) (range 5)) 57 | 58 | ||# 59 | 60 | ;;; Common Lisp versions 61 | ;;; Copyright Rainer Joswig, joswig@lisp.de , 2012 62 | 63 | #|| 64 | 65 | (defun create-world (size 66 | &optional living-cells 67 | &aux (world (make-array size :initial-element nil))) 68 | "Creates rectangular world with the specified width and height. 69 | Optionally takes coordinates of living cells." 70 | (loop for (x y) in living-cells do (setf (aref world x y) t)) 71 | world) 72 | 73 | (defun print-world (world) 74 | (loop for x below (array-dimension world 0) do 75 | (terpri) 76 | (loop for y below (array-dimension world 1) 77 | do (write-string (if (aref world x y) " X " " "))))) 78 | 79 | (defun neighbours (pos) 80 | "Determines all the neighbours of a given coordinate" 81 | (destructuring-bind (x y) pos 82 | (loop for dx in '(-1 0 1) 83 | append (loop for dy in '(-1 0 1) 84 | when (not (= 0 dx dy)) 85 | collect (list (+ dx x) (+ dy y)))))) 86 | 87 | (defun frequency (items &aux (hmap (make-hash-table :test #'equal))) 88 | (loop for item in items do (incf (gethash item hmap 0))) 89 | (loop for k being each hash-key in hmap using (hash-value v) 90 | collect (list v k))) 91 | 92 | (defun stepper (neighbours birth survive) 93 | "Returns a step function for Life-like cell automata. 94 | neighbours takes a location and return a sequential collection 95 | of locations. survive? and birth? are predicates on the number 96 | of living neighbours." 97 | (lambda (cells) 98 | (loop for (n item) in (frequency (mapcan neighbours cells)) 99 | when (if (member item cells :test #'equal) 100 | (member n survive) 101 | (member n birth)) 102 | collect item))) 103 | 104 | (defvar *glider* '((2 0) (2 1) (2 2) (1 2) (0 1))) 105 | (defvar *light-spaceship* '((2 0) (4 0) (1 1) (1 2) (1 3) (4 3) (1 4) (2 4) (3 4))) 106 | 107 | (defun conway (size pattern iterations) 108 | "Generates world of given size with initial pattern in specified generation" 109 | (let ((conway-stepper (stepper #'neighbours '(3) '(2 3)))) 110 | (loop repeat iterations 111 | for cells = pattern then (funcall conway-stepper cells) 112 | finally do (print-world (create-world size cells)) 113 | (terpri)))) 114 | 115 | (defun ex1 (&optional (n 10)) 116 | (conway '(5 15) *light-spaceship* n)) 117 | 118 | ||# 119 | 120 | 121 | ;;; ================================================================ 122 | ;;; Slightly more advanced version of above Game of Life 123 | 124 | ; utils 125 | 126 | (defun frequency (items &key (test 'eql) &aux (hmap (make-hash-table :test test))) 127 | "return a hashtable with the item frequencies" 128 | (loop for item in items do (incf (gethash item hmap 0))) 129 | hmap) 130 | 131 | ; cells and worlds 132 | 133 | (defun add-cell (world x y) 134 | "add a cell to the world" 135 | (setf (gethash (list x y) world) t) 136 | world) 137 | 138 | (defun cell-occupied-p (world x y) 139 | "is the cell occupied in the world?" 140 | (gethash (list x y) world)) 141 | 142 | (defun make-world (&optional living-cells &aux (world (make-hash-table :test #'equal))) 143 | "Returns a world, implemented as a hash-table" 144 | (loop for (x y) in living-cells do (add-cell world x y)) 145 | world) 146 | 147 | (defun print-world (world w h) 148 | (loop for x below w do 149 | (loop for y below h do 150 | (write-string (if (cell-occupied-p world x y) " X " " "))) 151 | (terpri))) 152 | 153 | (defun iterate-cells-loc (world fn) 154 | "Iterates function fn over the cells of the world" 155 | (maphash (lambda (k v) 156 | (declare (ignore v)) 157 | (funcall fn k)) 158 | world)) 159 | 160 | ; engine 161 | 162 | (defun neighbours (pos) 163 | "Determines all the neighbours of a given coordinate" 164 | (destructuring-bind (x y) pos 165 | (loop for dx in '(-1 0 1) 166 | append (loop for dy in '(-1 0 1) 167 | when (not (= 0 dx dy)) 168 | collect (list (+ dx x) (+ dy y)))))) 169 | 170 | (defun all-neighbour-locations (world neighbours &aux (locs '())) 171 | "returns a list of all neighbour locations in the world" 172 | (iterate-cells-loc world 173 | (lambda (loc) 174 | (loop for loc1 in (funcall neighbours loc) 175 | do (push loc1 locs)))) 176 | locs) 177 | 178 | (defun stepper (neighbours birth survive) 179 | "Returns a step function for Life-like cell automata. 180 | neighbours takes a location and return a sequential collection 181 | of locations. survive and birth are lists of numbers." 182 | (lambda (world new-world) 183 | (loop for (x y) being each hash-key 184 | in (frequency (all-neighbour-locations world neighbours) :test #'equal) 185 | using (hash-value n) 186 | when (if (cell-occupied-p world x y) 187 | (member n survive) 188 | (member n birth)) 189 | do (add-cell new-world x y)) 190 | new-world)) 191 | 192 | ; conway 193 | 194 | (defun conway (pattern iterations w h) 195 | "Generates world with initial pattern in specified generation. 196 | Prints the result in a give size w and h." 197 | (let ((conway-stepper (stepper #'neighbours '(3) '(2 3)))) 198 | (loop repeat iterations 199 | for world = (make-world pattern) then (funcall conway-stepper world (make-world)) 200 | do (print-world world w h)))) 201 | 202 | ; example 203 | 204 | (defvar *glider* 205 | '((2 0) (2 1) (2 2) (1 2) (0 1)) 206 | "a glider pattern for the game of life") 207 | 208 | (defvar *light-spaceship* 209 | '((2 0) (4 0) (1 1) (1 2) (1 3) (4 3) (1 4) (2 4) (3 4)) 210 | "a light-spaceship pattern for the game of life") 211 | 212 | (defun ex1 (&optional (n 10)) 213 | "example of the game of life" 214 | (conway *light-spaceship* n 20 10)) 215 | 216 | 217 | 218 | -------------------------------------------------------------------------------- /json.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Package: ("JSON" :USE "COMMON-LISP"); BASE: 10.; Syntax: ANSI-COMMON-LISP; Default-Character-Style: (:FIX :ROMAN :NORMAL);-*- 2 | 3 | ;;;; a simple JSON reader in Common Lisp 4 | 5 | ;;; http://www.ietf.org/rfc/rfc4627.txt 6 | ;;; http://www.json.org/ 7 | ;;; http://en.wikipedia.org/wiki/JSON 8 | 9 | ;;; Copyright 2010/2012, Rainer Joswig, joswig@lisp.de 10 | 11 | ;;; This simple JSON reader uses the standard Common Lisp reader facility. 12 | ;;; It assumes support for Unicode strings. 13 | ;;; Tested in LispWorks 6.1. 14 | 15 | ;;; use: 16 | ;; (json-read stream eof-errop-p eof-value recursivep) 17 | ;; (json-reader t) installs the reader in the current readtable 18 | 19 | 20 | ;;; ================================================================ 21 | ;;; Package JSON 22 | 23 | (defpackage "JSON" 24 | (:use "COMMON-LISP") 25 | (:export 26 | "JSON-READ" ; Function, read a JSON expression from a stream 27 | "JSON-READER" ; Function, use the JSON readtable 28 | )) 29 | 30 | (in-package "JSON") 31 | 32 | 33 | ;;; ================================================================ 34 | ;;; string 35 | 36 | (defun json-string-reader (stream first-char) 37 | "This function implements a reader for JSON strings. It should be 38 | used with the Common Lisp reader as a macro character function." 39 | (declare (ignore first-char)) 40 | (labels ((read-unicode-character (stream) 41 | (code-char (+ (ash (digit-char-p (read-char stream) 16) 12) 42 | (ash (digit-char-p (read-char stream) 16) 8) 43 | (ash (digit-char-p (read-char stream) 16) 4) 44 | (digit-char-p (read-char stream) 16)))) 45 | (read-escaped-character (stream) 46 | (ecase (read-char stream) 47 | (#\" #\") 48 | (#\\ #\\) 49 | (#\/ #\/) 50 | (#\b #\backspace) 51 | (#\f #\formfeed) 52 | (#\n #\newline) 53 | (#\r #\return) 54 | (#\t #\tab) 55 | (#\u (read-unicode-character stream))))) 56 | (with-output-to-string (out nil :element-type 'character) 57 | (loop for char = (read-char stream) 58 | until (char= char #\") 59 | do (write-char (if (char= char #\\) 60 | (read-escaped-character stream) 61 | char) 62 | out))))) 63 | 64 | (defmacro with-json-string-reader (&body body) 65 | "Install the JSON string reader temporarily during body execution." 66 | (let ((fn-sym (gensym "FN"))) 67 | `(let ((,fn-sym (get-macro-character #\" *readtable*))) 68 | (unwind-protect 69 | (progn 70 | (set-macro-character #\" 'json-string-reader nil *readtable*) 71 | ,@body) 72 | (set-macro-character #\" ,fn-sym nil *readtable*))))) 73 | 74 | 75 | ;;; ================================================================ 76 | ;;; array 77 | 78 | (defun convert-json-array (list) 79 | "Takes a list and returns a vector." 80 | (coerce list 'vector)) 81 | 82 | (defun json-array-reader (stream first-char) 83 | "This function implements a reader for JSON arrays. It should be 84 | used with the Common Lisp reader as a macro character function." 85 | (declare (ignore first-char)) 86 | (with-json-string-reader 87 | (convert-json-array (prog1 (loop for char = (peek-char t stream) 88 | until (char= char #\]) 89 | collect (read stream) 90 | when (char= (peek-char t stream) #\,) 91 | do (read-char stream)) 92 | (read-char stream))))) 93 | 94 | ;;; ================================================================ 95 | ;;; object 96 | 97 | (defun convert-json-object (list) 98 | "Converts a list of keys and values to an assoc list." 99 | (loop for (key value) on list by #'cddr 100 | collect (cons key value))) 101 | 102 | (defparameter *json-read-objects-as-type* :clos 103 | "one of :clos, :hash-table or :list") 104 | 105 | (defun read-object-as-list (stream) 106 | (loop until (char= (peek-char t stream) #\}) 107 | collect (cons (read stream) 108 | (progn 109 | (peek-char #\: stream) 110 | (read-char stream) 111 | (peek-char t stream) 112 | (read stream))) 113 | when (char= (peek-char t stream) #\,) 114 | do (read-char stream))) 115 | 116 | (defun read-object-as-hash-table (stream) 117 | (let ((table (make-hash-table :test 'equalp))) 118 | (loop until (char= (peek-char t stream) #\}) 119 | do (setf (gethash (read stream) table) 120 | (progn 121 | (peek-char #\: stream) 122 | (read-char stream) 123 | (peek-char t stream) 124 | (read stream))) 125 | when (char= (peek-char t stream) #\,) 126 | do (read-char stream)) 127 | table)) 128 | 129 | (defclass json-map () 130 | ((table :initform (make-hash-table :test 'equalp) 131 | :accessor json-map-table))) 132 | 133 | (defun read-object-as-clos-instance (stream) 134 | (let* ((object (make-instance 'json-map)) 135 | (table (json-map-table object))) 136 | (loop until (char= (peek-char t stream) #\}) 137 | do (setf (gethash (read stream) table) 138 | (progn 139 | (peek-char #\: stream) 140 | (read-char stream) 141 | (peek-char t stream) 142 | (read stream))) 143 | when (char= (peek-char t stream) #\,) 144 | do (read-char stream)) 145 | object)) 146 | 147 | (defun json-object-reader (stream first-char) 148 | "This function implements a reader for JSON objects. It should be 149 | used with the Common Lisp reader as a macro character function." 150 | (declare (ignore first-char)) 151 | (with-json-string-reader 152 | (prog1 153 | (ecase *json-read-objects-as-type* 154 | (:list (read-object-as-list stream)) 155 | (:hash-table (read-object-as-hash-table stream)) 156 | (:clos (read-object-as-clos-instance stream))) 157 | (read-char stream)))) 158 | 159 | ;;; ================================================================ 160 | ;;; printing json object 161 | 162 | (defun print-json-object-from-hash-table (table stream) 163 | (write-char #\{ stream) 164 | (let ((first-p t)) 165 | (maphash (lambda (key value) 166 | (if first-p 167 | (setf first-p (not first-p)) 168 | (write-string " , " stream)) 169 | (write key :stream stream) 170 | (write-char #\space stream) 171 | (write-char #\: stream) 172 | (write-char #\space stream) 173 | (write value :stream stream)) 174 | table)) 175 | (write-char #\} stream)) 176 | 177 | (defmethod print-object ((object json-map) stream) 178 | (with-slots (table) object 179 | (print-json-object-from-hash-table table stream)) 180 | object) 181 | 182 | 183 | ;;; ================================================================ 184 | ;;; readtable and reader 185 | 186 | (defun make-json-readtable (&optional (readtable (copy-readtable nil))) 187 | "Creates a readtable with added functionality to 188 | read JSON datastructures (array, object, string). 189 | If the readtable is supplied, it is modified." 190 | (loop for (char fn) in '((#\[ json-array-reader) 191 | (#\{ json-object-reader)) 192 | do (set-macro-character char fn nil readtable)) 193 | (loop for (to from) in '((#\] #\)) 194 | (#\} #\))) 195 | do (set-syntax-from-char to from readtable)) 196 | readtable) 197 | 198 | (defparameter *json-readtable* 199 | (make-json-readtable) 200 | "A readtable which parses JSON expressions.") 201 | 202 | (defun json-read (&optional (stream *standard-input*) (eof-error-p t) eof-value recursivep) 203 | "Reads a JSON expression from stream. Uses the *json-readtable*." 204 | (let ((*readtable* (or *json-readtable* (make-json-readtable))) 205 | (*read-base* 10)) 206 | (read stream eof-error-p eof-value recursivep))) 207 | 208 | (defun json-reader (&optional (on t)) 209 | "Modifies the current readtable to parse JSON expressions. 210 | Uses the characters {, }, [ and ]." 211 | (if on 212 | (make-json-readtable *readtable*) 213 | (let ((readtable *readtable*) 214 | (orig-readtable (copy-readtable nil))) 215 | (loop for char in '(#\[ #\{) 216 | do (set-macro-character char (get-macro-character char orig-readtable) nil readtable)) 217 | (loop for char in '(#\] #\}) 218 | do (set-syntax-from-char char char readtable orig-readtable)) 219 | readtable))) 220 | 221 | 222 | ;;; ================================================================ 223 | ;;; Examples 224 | 225 | #|| 226 | 227 | (defun test () 228 | (let ((strings '("12" 229 | "123" 230 | "1e4" 231 | "\"hi\\bho\\rha\"" 232 | "[1,2,3]" 233 | "[true,false,null]" 234 | "[ true , false , null ]" 235 | "\"-\\u01ae-\"" 236 | "[[2,3],[4,5,6]]" 237 | "{\"a\":10,\"b\":\"b1\"}" 238 | "{\"a\":[1,2,\"foo\"],\"b\":\"b1\"}"))) 239 | (loop for string in strings 240 | collect (list string (with-input-from-string (stream string) 241 | (json-read stream)))))) 242 | 243 | (defun test-examples (&optional (file "/Users/joswig/Desktop/json-examples.json")) 244 | (with-open-file (stream file) 245 | (loop for ex = (json-read stream nil) 246 | while ex 247 | do (pprint ex) 248 | do (terpri)))) 249 | 250 | ||# 251 | 252 | ;;; ================================================================ 253 | ;;; End of File 254 | -------------------------------------------------------------------------------- /usenet-extensions.lisp: -------------------------------------------------------------------------------- 1 | ;;; Some extensions to Common Lisp, mostly written by Rainer Joswig 2 | ;;; useful for providing solutions to questions on comp.lang.lisp 3 | 4 | ;;; Code by me (other authors are noted) is licensed as Public Domain 5 | ;;; and has Copyright Rainer Joswig, joswig@lisp.de, 2011 , 2012 6 | 7 | ;;; Runs in LispWorks 6.1 8 | 9 | 10 | ;;; ================================================================ 11 | ;;; Some read macros 12 | 13 | 14 | ;; reading a list with angle brackets 15 | 16 | #+ignore 17 | (defun |[-reader| (stream char) 18 | (declare (ignore char)) 19 | (read-delimited-list #\] stream t)) 20 | #+ignore 21 | (progn 22 | (set-macro-character #\[ #'|[-reader|) 23 | (set-macro-character #\] (get-macro-character #\) nil))) 24 | 25 | ;; [a b] creates a list of numbers from a below b 26 | 27 | #+ignore 28 | (defun |[-reader| (stream char) 29 | (declare (ignore char)) 30 | (let ((list (read-delimited-list #\] stream t))) 31 | `(iota ,(- (second list) (first list)) ,(first list)))) 32 | 33 | #+ignore 34 | (progn 35 | (set-macro-character #\[ #'|[-reader|) 36 | (set-macro-character #\] (get-macro-character #\) nil))) 37 | 38 | 39 | ;;; ================================================================ 40 | ;;; Control structures 41 | 42 | (defmacro llet (name vars &body body) 43 | "Recursive LET like in Clojure. Name is the name for the loop call. 44 | Vars is a list of variables for this loop, with initial bindings." 45 | (labels ((generate-list-of-var-syms (vars) 46 | (loop for var in vars 47 | collect (if (consp var) 48 | (first var) 49 | var)))) 50 | (let ((start-tag (gensym)) 51 | (list-of-var-syms (generate-list-of-var-syms vars))) 52 | `(prog ,vars 53 | ,start-tag 54 | (macrolet ((,name (&rest args) 55 | `(progn 56 | (setf ,@(mapcan #'list ',list-of-var-syms args)) 57 | (go ,',start-tag)))) 58 | (locally ,@body)))))) 59 | 60 | #| 61 | 62 | (llet recur ((list '(1))) 63 | (when (< (length list) 17) 64 | (format t "~{~6D~^,~}~%" list) 65 | (recur (mapcar '+ (cons 0 list) (append list '(0)))))) 66 | 67 | (defun foo (n) 68 | (llet recur ((x n)) 69 | (print x) 70 | (unless (zerop x) 71 | (recur (1- x))))) 72 | 73 | (defun foo (n) 74 | (llet recur ((x n) (y (+ n 10))) 75 | (print (list x y)) 76 | (unless (zerop x) 77 | (recur (1- x) (1+ y))))) 78 | 79 | |# 80 | 81 | ; Pascal Costanza 82 | (defmacro pipe (&body forms) 83 | (let ((var (gensym))) 84 | `(macrolet ((=> (&body forms) 85 | `(let ((,',var (funcall #',(car forms) ,',var))) 86 | ,(if (cdr forms) (cdr forms) ',var)))) 87 | (let ((,var ,(car forms))) 88 | ,(if (cdr forms) (cdr forms) var))))) 89 | 90 | 91 | (defun curry (f &rest args) 92 | (lambda (&rest x) (apply f (append args x)))) 93 | 94 | (defun rcurry (f &rest last-args) 95 | (lambda (&rest x) (apply f (append x last-args)))) 96 | 97 | 98 | ;;; Paul Graham, On Lisp, p191 99 | (defmacro aif (test-form then-form &optional else-form) 100 | `(let ((it ,test-form)) 101 | (if it ,then-form ,else-form))) 102 | 103 | 104 | ;;; ================================================================ 105 | ;;; List handling 106 | 107 | ;;; Take, like in Mathematica 108 | (defun %take (it what) 109 | (cond ((eq what :all) it) 110 | ((eq what :none) nil) 111 | ((and (numberp what) (plusp what)) 112 | (subseq it 0 what)) 113 | ((and (numberp what) (minusp what)) 114 | (last it (- what))) 115 | ((and (consp what) 116 | (= (length what) 1) 117 | (numberp (first what))) 118 | (nth (first what) it)) 119 | ((and (consp what) 120 | (= (length what) 2) 121 | (numberp (first what)) 122 | (numberp (second what))) 123 | (let ((end (if (minusp (second what)) 124 | (+ (length it) (second what)) 125 | (second what)))) 126 | (subseq it (first what) end))) 127 | ((and (consp what) 128 | (= (length what) 3) 129 | (numberp (first what)) 130 | (numberp (second what)) 131 | (numberp (third what))) 132 | (let ((start (first what)) 133 | (end (if (minusp (second what)) 134 | (+ (length it) (second what)) 135 | (second what))) 136 | (by-step (third what))) 137 | (loop for e = (subseq it start) then (nthcdr by-step e) 138 | for i from start below end by by-step 139 | collect (first e)))))) 140 | 141 | (defun take (thing &rest description) 142 | "Taking things from lists like in Mathematica 143 | Description is one or more of: 144 | :all | :none | [sign]number | ( start [end [step]])" 145 | (cond ((null description) nil) 146 | ((and (consp description) 147 | (= (length description) 1)) 148 | (%take thing (first description))) 149 | (t (loop for e in (%take thing (first description)) 150 | collect (apply #'take e (rest description)))))) 151 | 152 | ; (take '(1 2 3 4 5 6 7) '(2 5)) 153 | ; (take '(1 2 3 4 5 6 7) 3) 154 | ; (take '((a b c d) (1 2 3 4) (5 6 7 8)) 2 2) 155 | ; (take '(a b c d) '(0 -1 2)) 156 | ; (take '(1 2 3 4 5 6 7) -3) 157 | 158 | (defun take-n (list n) 159 | (loop for e in list 160 | repeat n 161 | collect e)) 162 | 163 | (defun take-best-n (n list &key (key 'identity) (predicate '>)) 164 | "Returns the best n items. Preserves order." 165 | (let ((taken (take-n (sort (copy-list list) predicate :key key) n))) 166 | (mapcan (lambda (e) 167 | (when (member e taken :test #'equal) (list e))) 168 | list))) 169 | 170 | (defun iota* (n &optional (start 0)) 171 | "Creates a list of n elements starting with element START. 172 | START can be a number, a character, a string or a symbol." 173 | (etypecase start 174 | (number (loop for i from start 175 | repeat n 176 | collect i)) 177 | (character (loop with c = (char-code (or (and (characterp start) start) #\a)) 178 | for i from 0 179 | repeat n 180 | collect (code-char (+ c i)))) 181 | (string (loop with c = (char-code (or (and (stringp start) (aref start 0)) #\a)) 182 | for i from 0 183 | repeat n 184 | collect (string (code-char (+ c i))))) 185 | (symbol (loop with c = (char-code (or (and (symbolp start) (aref (string start) 0)) #\a)) 186 | for i from 0 187 | repeat n 188 | collect (intern (string (code-char (+ c i))) (symbol-package start)))))) 189 | 190 | (defun repeat (it n) 191 | "Returns a list of n elements of IT." 192 | (loop repeat n collect it)) 193 | 194 | (defun distribution (seq &key (test 'eql) (sort-pred #'<)) 195 | (let ((table (make-hash-table :test test)) result) 196 | (map nil (lambda (x) (incf (gethash x table 0))) seq) 197 | (maphash (lambda (k v) 198 | (push (cons k v) result)) 199 | table) 200 | (sort result sort-pred :key #'cdr))) 201 | 202 | (defun flatten (list) 203 | (mapcan (lambda (item) 204 | (if (listp item) (flatten item) (list item))) 205 | list)) 206 | 207 | (defun max-by (l f) 208 | "Returns two values, the position and the maximum value (after applying the function F)" 209 | (values-list (car (sort (mapcar 'list l (mapcar f l)) '> :key 'second))) ) 210 | 211 | (defun circ (list) 212 | "Returns a circular list. The argument can be a list of elements or a single atom." 213 | (let ((l (or (and (atom list) (list list)) (copy-list list)))) 214 | (setf (cdr (last l)) l) 215 | l)) 216 | 217 | ;; Peter Norvig 218 | (defun cross-product (fn xlist ylist) 219 | "Return a list of all (fn x y) values." 220 | (mapcan #'(lambda (y) 221 | (mapcar #'(lambda (x) (funcall fn x y)) 222 | xlist)) 223 | ylist)) 224 | 225 | (defun join (type seq1 seq2) 226 | "Creates a new sequence of the elements of seq1 with the seq2 spliced in between." 227 | (ecase type 228 | (string (with-output-to-string (s) 229 | (princ (first seq1) s) 230 | (loop for e in (rest seq1) 231 | do (princ seq2 s) (princ e s)))))) 232 | 233 | (defun rot13 (text) 234 | (let ((letters '#.(let* ((uc "ABCDEFGHIJKLMNOPQRSTUVWXYZ") 235 | (lc (string-downcase uc))) 236 | (concatenate 'list uc uc lc lc)))) 237 | (map 'string 238 | (lambda (c) 239 | (aif (member c letters) 240 | (nth 13 it) 241 | c)) 242 | text))) 243 | 244 | (defun mapn (f list n) 245 | (loop for l = list then (nthcdr n l) 246 | for l1 = (take-n l n) 247 | while (= (length l1) n) 248 | do (funcall f l1))) 249 | 250 | #+ignore 251 | (defun tuple-products (list n) 252 | (mapn (lambda (group) 253 | (format t "~%~{~D~^ * ~} = ~a" group (reduce '* group))) 254 | list 255 | n)) 256 | 257 | (defun remove-every-nth (list n) 258 | (mapcan (lambda (a b) (when b (list a))) 259 | list 260 | (circ (append (iota (1- n)) '(()))))) 261 | 262 | (defun split-at (seq &optional (n (ceiling (length seq) 2))) 263 | (values (subseq seq 0 n) (subseq seq n))) 264 | 265 | (defun split-half (list) 266 | (values (loop for nil in list by #'cddr collect (pop list)) 267 | list)) 268 | 269 | 270 | ;;; SRFI 1 - List Library 271 | 272 | ;; Constructors 273 | 274 | (defun xcons (a d) 275 | (cons d a)) 276 | 277 | (defun cons* (&rest elements) 278 | (apply #'list* (first elements) (rest elements))) 279 | 280 | (defun list-tabulate (n function) 281 | "Creates a list of values of applying function to i in 0..n-1" 282 | (loop for i below n collect (funcall function i))) 283 | 284 | (defun circular-list (&rest elements) 285 | (circ elements)) 286 | 287 | (defun iota (n &optional (start 0) (step 1)) 288 | "Creates a list of n elements starting with element START." 289 | (loop for i from start by step 290 | repeat n 291 | collect i)) 292 | 293 | (defun drop (list n) 294 | (subseq list n)) 295 | 296 | (defun take-right (list n) 297 | (last list n)) 298 | 299 | (defun drop-right (list n) 300 | (butlast list n)) 301 | 302 | (defun zip (&rest lists) 303 | (apply #'mapcar #'list lists)) 304 | 305 | (defun unzip2 (list) 306 | (loop for (a b) in list 307 | collect a into a-list 308 | collect b into b-list 309 | finally (return (values a-list b-list)))) 310 | 311 | ;;; ================================================================ 312 | ;;; Fowler's example in plain Lisp 313 | 314 | (defparameter *example-text* 315 | "SVCLFOWLER 10101MS0120050313......................... 316 | SVCLHOHPE 10201DX0320050315........................ 317 | SVCLTWO X10301MRP220050329.............................. 318 | USGE10301TWO X50214..7050329") 319 | 320 | (defparameter *mappings* 321 | '((svcl (name 4 19) 322 | (id 19 24) 323 | (call-type-code 24 28) 324 | (date-of-call 28 36)) 325 | (usge (id 4 9) 326 | (name 9 23) 327 | (cycle 30 31) 328 | (read-date 31 36)))) 329 | 330 | (defun parse-log-lines-example (text mappings) 331 | (mapcar (lambda (line &aux (name (subseq line 0 4))) 332 | (cons name (mapcar (lambda (fields) 333 | (list (car fields) (subseq line (cadr fields) (caddr fields)))) 334 | (cdr (assoc name mappings :test #'string=))))) 335 | (split-sequence '(#\newline) text))) 336 | 337 | ;;; ================================================================ 338 | ;;; End of File 339 | 340 | 341 | -------------------------------------------------------------------------------- /micro-talespin.lisp: -------------------------------------------------------------------------------- 1 | ;***************************************************************** 2 | ; MICRO-TALESPIN: A STORY GENERATOR 3 | ; 4 | ; A reconstruction, in Common Lisp, of James Meehan's program in 5 | ; _Inside_Computer_Understanding:_Five_Programs_Plus_Miniatures_ 6 | ; Roger Schank and Christopher Riesbeck (eds.) 7 | ; 8 | ; Warren Sack 9 | ; MIT Media Lab 10 | ; 20 Ames Street, E15-486 11 | ; Cambridge MA 02139 12 | ; wsack@media.mit.edu 13 | ; 14 | ; October 1992 15 | ; 16 | ; I translated Micro-Talespin into Common Lisp as a 17 | ; "literature review exercise": I wanted to see and play 18 | ; with storyteller systems that had been written in the past. 19 | ; I am currently working on creating storyteller systems which 20 | ; produce not only text (as Micro-Talespin does) but also 21 | ; audio and video. If you are working on a similar project 22 | ; I'd love to hear from you. I can be reached at the 23 | ; above address. 24 | ; 25 | ;***************************************************************** 26 | 27 | 28 | ; Changes by Rainer Joswig, joswig@lisp.de, 2012: 29 | ; fixed: dprox-plan1, ptrans only if the actor knows the new loc 30 | ; hacked: Output sentence starts with an uppercase letter and then lowercase letters follow. 31 | ; Changes by Rainer Joswig, joswig@lisp.de, 2008: 32 | ; fixed: persuade and not peruade 33 | ; fixed: three args to persuade 34 | ; fixed: changed implementation of PCVar from Structure to Symbol (symbol with leading ?) 35 | ; fixed: correct spaces in output 36 | ; fixed: put symbols instead of functions, makes tracing easier 37 | 38 | 39 | ; Standard definition of put. 40 | (defmacro put (x y z) 41 | `(setf (get ,x ,y) ,z)) 42 | 43 | ; Definition necessary for pattern variables. 44 | (defun pcvar-p (item) 45 | (and (symbolp item) 46 | (> (length (symbol-name item)) 0) 47 | (char= (aref (symbol-name item) 0) #\?))) 48 | 49 | ; Definition of Globals 50 | 51 | (defvar *personae*) 52 | (defvar *goals*) 53 | (defvar *all-locations*) 54 | (defvar *all-objects*) 55 | 56 | 57 | (defvar *init-facts* nil 58 | "This is the initial data base. It can be extended before 59 | running a story.") 60 | 61 | (defun init-facts () 62 | (setf *init-facts* 63 | '((world (loc (actor joe) (val cave))) 64 | (joe (loc (actor joe) (val cave))) 65 | (world (loc (actor irving) (val oak-tree))) 66 | (irving (loc (actor irving) (val oak-tree))) 67 | (joe (loc (actor irving) (val oak-tree))) 68 | (world (loc (actor water) (val river))) 69 | (joe (loc (actor water) (val river))) 70 | (world (loc (actor honey) (val elm-tree))) 71 | (irving (loc (actor honey) (val elm-tree))) 72 | (world (loc (actor worm) (val ground))) 73 | (joe (loc (actor worm) (val ground))) 74 | (irving (loc (actor joe) (val cave))) 75 | (world (loc (actor fish) (val river))) 76 | (irving (loc (actor fish) (val river)))))) 77 | 78 | 79 | (defun init-world () 80 | "init-world sets up a bunch of facts such as Joe is a bear, birds 81 | eat worms, and so on. The variable *init-facts* contains location 82 | and relationship facts, along with which character knows them." 83 | (put 'joe 'is-a 'bear) 84 | (put 'joe 'home 'cave) 85 | (put 'irving 'is-a 'bird) 86 | (put 'irving 'home 'tree) 87 | (put 'bear 'food '(honey berries fish)) 88 | (put 'bird 'food '(worm)) 89 | (setf *personae* '(joe irving)) 90 | (setf *goals* '(hungry thirsty)) 91 | (setf *all-locations* '(cave oak-tree elm-tree ground river)) 92 | (setf *all-objects* (append *all-locations* 93 | '(honey berries fish worm water))) 94 | (mapc #'(lambda (persona) 95 | (put persona 'facts nil) 96 | (put persona 'goals nil) 97 | (put persona 'demons nil)) 98 | (cons 'world *personae*)) 99 | (mapc #'(lambda (fact) 100 | (now-knows (car fact) (cadr fact) t)) 101 | *init-facts*)) 102 | 103 | (defun ask-plan (actor agent action) 104 | "The success of asking something depends upon whether the other person 105 | is honest and likes you." 106 | `(and (not (relate ',actor ',agent ',actor 'deceive)) 107 | (relate ',actor ',actor ',agent 'like) 108 | (tell ',actor ',agent (question ',action)) 109 | ;(is-true ',result) 110 | )) 111 | 112 | (defun bargain-plan (actor agent action) 113 | "The success of bargaining with someone by giving them food depends 114 | on whether the other person is honest, you don't already have the 115 | goal of getting the food you're going to bargain with, and you can 116 | get the food to the other person." 117 | (let ((atrans-food (atrans actor 'food agent actor))) 118 | `(and (not (relate ',actor ',agent ',actor 'deceive)) 119 | (not (knows ',actor (has ',agent 'food))) 120 | (not (has-goal-of ',actor (has ',actor 'food))) 121 | (doit (mbuild ',actor (cause ',atrans-food (maybe ',action)))) 122 | (tell ',actor 123 | ',agent 124 | (question (cause ',atrans-food (future ',action)))) 125 | (dcont ',actor 'food) 126 | (dprox ',actor ',actor ',agent) 127 | (doit ',atrans-food) 128 | (is-true ',action)))) 129 | 130 | 131 | (defun threat-plan (actor agent action) 132 | "The success of threatening depends upon whether you dominate 133 | the other person." 134 | `(and (not (relate ',actor ',agent ',actor 'dominate)) 135 | (tell ',actor 136 | ',agent 137 | (cause (negate ',action) (future (propel ',actor 'hand ',agent)))) 138 | (or (is-true ',action) 139 | (and (doit (propel ',actor 'hand ',agent)) 140 | (is-true ',action))))) 141 | 142 | (defvar *default-tense* 'past ; or present 143 | "Set the storytelling in the past tense.") 144 | 145 | ; micro-talespin-demo variables for sample stories 146 | 147 | ; No plot: joe gets a drink of water. 148 | (defvar *story1* 149 | '(joe thirsty)) 150 | 151 | (defvar *story2* 152 | '(irving thirsty 153 | (irving (like (actor joe) (to irving) (mode (neg)))) 154 | (irving (dominate (actor joe) (to irving) (mode (neg)))) 155 | (irving (deceive (actor joe) (to irving) (mode (pos)))) 156 | (irving (like (actor irving) (to joe) (mode (neg)))) 157 | (joe (deceive (actor irving) (to joe) (mode (neg))))) 158 | "irving kills joe.") 159 | 160 | (defvar *story3* 161 | '(joe hungry 162 | (joe (like (actor irving) (to joe) (mode (neg)))) 163 | (joe (dominate (actor irving) (to joe) (mode (pos))))) 164 | "joe is frustrated at every turn.") 165 | 166 | (defvar *story4* 167 | '(joe hungry 168 | (world (hungry (actor irving) (mode (pos)))) 169 | (joe (like (actor irving) (to joe) (mode (pos)))) 170 | (joe (deceive (actor irving) (to joe) (mode (neg)))) 171 | (joe (like (actor joe) (to irving) (mode (pos)))) 172 | (irving (like (actor irving) (to joe) (mode (pos)))) 173 | (irving (dominate (actor irving) (to joe) (mode (neg)))) 174 | (irving (deceive (actor irving) (to joe) (mode (neg))))) 175 | "joe and irving strike a deal.") 176 | 177 | (defvar *story5* 178 | '(irving thirsty 179 | (irving (like (actor irving) (to joe) (mode (pos)))) 180 | (irving (like (actor joe) (to irving) (mode (pos)))) 181 | (irving (deceive (actor joe) (to irving) (mode (neg)))) 182 | (irving (dominate (actor joe) (to irving) (mode (pos)))) 183 | (world (hungry (actor joe) (mode (pos)))) 184 | (joe (like (actor joe) (to irving) (mode (neg)))) 185 | (joe (deceive (actor joe) (to irving) (mode (pos))))) 186 | "joe tricks irving") 187 | 188 | (defvar *story6* 189 | '(joe hungry 190 | (joe (like (actor irving) (to joe) (mode (pos)))) 191 | (joe (dominate (actor irving) (to joe) (mode (neg))))) 192 | "This is an interactive version of *story4* and/or *story5*") 193 | 194 | ; Declare globals used in forward-chaining through goals and plans. 195 | (defvar *actions*) 196 | (defvar *plans*) 197 | (defvar *conseqs*) 198 | 199 | (defun micro-talespin () 200 | (init-facts) 201 | (init-world) 202 | (let ((main-character (pick-one 'character *personae*)) 203 | (problem (pick-one 'problem *goals*))) 204 | (format t "~%Once upon a time ...") 205 | ; (init-world) 206 | (format t "~%One day,") 207 | (assert-fact (mloc 'world (state main-character problem 'pos))) 208 | (format t "~%The end."))) 209 | 210 | (defun micro-talespin-demo (story) 211 | "micro-talespin-demo lets you predefine more facts for a story. 212 | story should be a list of the form (character problem fact fact ...) 213 | where 214 | character is either joe or irving, 215 | problem is either hunger or thirst, 216 | facts have the for (character 'CD-form). The character field 217 | says who knows this fact." 218 | (init-facts) 219 | (setf *init-facts* 220 | (append *init-facts* (cddr story))) 221 | (let ((main-character (car story)) 222 | (problem (cadr story))) 223 | (format t "~%Once upon a time ...") 224 | (init-world) 225 | (format t "~%One day, ") 226 | (assert-fact (mloc 'world (state main-character problem 'pos))) 227 | (format t "~%The end."))) 228 | 229 | (defun pick-one (name l) 230 | "pick-one is used to get the character and problem from the terminal." 231 | (format t "~%Choose a ~s from this list:~%~s~%> " name l) 232 | (let ((a (read))) 233 | (if (member a l) a (pick-one name l)))) 234 | 235 | (defun goal-eval (actor goal plans) 236 | "goal evaluator: executes each plan until one works and the goal 237 | can be removed, or until none do and the character fails to get the 238 | goal. If the goal is already true (and the actor knows that), then 239 | return success immediately. If the actor already has the goal, 240 | then he's in a loop and has failed. Otherwise, set up the goal and go." 241 | (cond ((knows actor goal) 242 | t) 243 | ((has-goal-of actor goal) 244 | nil) 245 | (t 246 | (gets-new-goal-of actor goal) 247 | (cond ((run-plans plans) 248 | (forgets-goal-of actor goal) 249 | t) 250 | (t 251 | (now-knows actor (negate (future goal)) t) 252 | nil))))) 253 | 254 | #+ignore 255 | (defun run-plans (plans) 256 | (let ((plan (car plans))) 257 | (if plan 258 | (if (eval plan) 259 | t 260 | (run-plans (cdr plans)))))) 261 | 262 | (defun run-plans (plans) 263 | (loop for plan in plans 264 | when (eval plan) 265 | do (return t))) 266 | 267 | ; gen-plans replicates the same plan with different objects 268 | ; e.g., trying to get any one of the several foods with the 269 | ; same bargaining plan. 270 | (defun gen-plans (var possibilities plan-form) 271 | (mapcar #'(lambda (possibility) 272 | (subst possibility var plan-form)) 273 | possibilities)) 274 | 275 | ; Two S-goals -- thirst and hunger: 276 | 277 | ; To satisfy thirst, go to some water and drink it. 278 | (defun sthirst (actor) 279 | (goal-eval actor 280 | (state actor 'thirsty 'neg) 281 | (list (sthirst-plan actor)))) 282 | 283 | (defun sthirst-plan (actor) 284 | `(and (dprox ',actor ',actor 'water) 285 | (doit (ingest ',actor 'water)))) 286 | 287 | ; To satisfy hunger, get some food and eat it. 288 | (defun shunger (actor) 289 | (goal-eval actor 290 | (state actor 'hungry 'neg) 291 | (gen-plans 'food 292 | (get-isa 'food actor) 293 | (shunger-plan actor)))) 294 | 295 | (defun shunger-plan (actor) 296 | `(and (dcont ',actor 'food) 297 | (doit (ingest ',actor 'food)))) 298 | 299 | ; Three D-goals -- dcont, dknow, dprox: 300 | 301 | ; To get an object: if you know someone has it, persuade them to 302 | ; give it to you; otherwise try to find out where the object is, 303 | ; go there and take it. 304 | (defun dcont (actor object) 305 | (let ((owner (knows-owner actor object))) 306 | (goal-eval actor 307 | (has actor object) 308 | (if owner 309 | (list (dcont-plan1 actor object owner)) 310 | (list (dcont-plan2 actor object)))))) 311 | 312 | (defun dcont-plan1 (actor object owner) 313 | `(persuade ',actor 314 | ',owner 315 | (atrans ',owner ',object ',actor ',owner))) 316 | 317 | (defun dcont-plan2 (actor object) 318 | `(and (dknow ',actor (where-is ',object)) 319 | (dprox ',actor ',actor ',object) 320 | (doit (atrans ',actor ',object ',actor nil)))) 321 | 322 | ; To find out something: find a friend to tell you 323 | (defun dknow (actor info) 324 | (goal-eval actor 325 | (mloc actor info) 326 | (gen-plans 'agent 327 | (remove actor *personae*) 328 | (dknow-plan actor info)))) 329 | 330 | (defun dknow-plan (actor info) 331 | `(and (knows-loc ',actor 'agent) 332 | (or (is-friend-of 'agent ',actor) 333 | (not (relate ',actor 'agent ',actor 'dominate))) 334 | (persuade ',actor 335 | 'agent 336 | (mtrans 'agent ',info ',actor 'agent)))) 337 | 338 | ; To move an object (including yourself) to where some other 339 | ; person or object is: get the first object (if not yourself), then 340 | ; find out where the second object is and go there with the first 341 | ; object. If this doesn't work, try persuading the object to go 342 | ; there itself. 343 | (defun dprox (actor object new-object) 344 | (goal-eval actor 345 | (is-at object new-object) 346 | (list (dprox-plan1 actor object new-object) 347 | (dprox-plan2 actor object new-object)))) 348 | 349 | (defun dprox-plan1 (actor object new-object) 350 | `(and (or (equal ',actor ',object) 351 | (dprox ',actor ',actor ',object)) 352 | (dknow ',actor (where-is ',new-object)) 353 | (or (equal ',actor ',object) 354 | (doit (grasp ',actor ',object))) 355 | (or (is-prox ',actor (loc-name-of ',new-object)) 356 | (and (knows-loc ',actor ',new-object) 357 | (doit (ptrans ',actor 358 | ',object 359 | (knows-loc ',actor ',new-object) 360 | (knows-loc ',actor ',actor))))) 361 | (or (equal ',actor ',object) 362 | (doit (un-grasp ',actor ',object))))) 363 | 364 | (defun dprox-plan2 (actor object new-object) 365 | `(and (not (equal ',actor ',object)) 366 | (member ',object *personae*) 367 | (persuade ',actor 368 | ',object 369 | (ptrans ',object 370 | ',object 371 | ',new-object 372 | (loc-name-of ',object))))) 373 | 374 | ; Subgoals and plans -- persuade, ask, bargain, threaten, and tell: 375 | 376 | ; You can persuade someone to do something by either asking them, 377 | ; giving them food or threatening them. 378 | (defun persuade (actor agent action) 379 | (goal-eval actor 380 | action 381 | (append (gen-plans 'food 382 | (get-isa 'food agent) 383 | (bargain-plan actor agent action)) 384 | (list (ask-plan actor agent action)) 385 | (list (threat-plan actor agent action))))) 386 | 387 | ; To tell someone something, go there and say it. 388 | (defun tell (actor agent info) 389 | (goal-eval actor 390 | (mloc agent info) 391 | (list (tell-plan actor agent info)))) 392 | 393 | (defun tell-plan (actor agent info) 394 | `(and (dprox ',actor ',actor ',agent) 395 | (doit (mtrans ',actor ',info ',agent ',actor)))) 396 | 397 | ; The simulator 398 | 399 | ; doit adds a CD and its consequences to the data base, by calling 400 | ; assert-fact. mtranses with '?unspecified have to be filled out, as in 401 | ; "Irving told Joe where the honey was" -- the "where" being represented 402 | ; in the CD with an '?unspecified form. 403 | (defun doit (cd) 404 | (let ((newcd 405 | (if (and (equal (header-cd cd) 'mtrans) 406 | (knows (cdpath '(actor) cd) 407 | (cdpath '(object) cd))) 408 | (setrole 'object 409 | (knows (cdpath '(actor) cd) 410 | (cdpath '(object) cd)) 411 | cd) 412 | cd))) 413 | (assert-fact newcd) 414 | newcd)) 415 | 416 | ; assert-fact is one of the central control functions. It starts with 417 | ; one fact, infers the consequences, infers the consequences of the 418 | ; consequences, etc. Besides the simple result put in *conseqs* 419 | ; (e.g., ptrans changes locs), new states may lead to response actions 420 | ; (put in *actions*) or new plans (put in *plans*). The plans are 421 | ; done after all the consequences are inferred. 422 | (defun assert-fact (x) 423 | (setf *actions* nil) 424 | (setf *plans* nil) 425 | (forward-chain (list x)) 426 | (mapc #'(lambda (cd) (doit (setrole 'time *default-tense* cd))) 427 | *actions*) 428 | (mapc #'eval *plans*)) 429 | 430 | (defun forward-chain (l) 431 | (setf *conseqs* nil) 432 | (mapc #'(lambda (i) 433 | (now-knows 'world i nil) 434 | (conseqs i)) 435 | l) 436 | (if *conseqs* (forward-chain *conseqs*))) 437 | 438 | ; Each act and state is associated with a function for 439 | ; calculating the consequences. 440 | (defun conseqs (cd) 441 | (case (header-cd cd) 442 | (atrans (atrans-conseqs cd)) 443 | (grasp (grasp-conseqs cd)) 444 | (ingest (ingest-conseqs cd)) 445 | (loc (loc-conseqs cd)) 446 | (mbuild (mbuild-conseqs cd)) 447 | (mloc (mloc-conseqs cd)) 448 | (mtrans (mtrans-conseqs cd)) 449 | (plan (plan-conseqs cd)) 450 | (propel (propel-conseqs cd)) 451 | (ptrans (ptrans-conseqs cd)) 452 | (t nil))) 453 | 454 | ; add-conseq adds and returns a CD to the list of consequences 455 | (defun add-conseq (x) 456 | (push x *conseqs*) 457 | x) 458 | 459 | ; Consequences of an atrans: everyone in the area notices it and the 460 | ; resulting change of possesion, the object changes locations, and the 461 | ; from filler knows he no longer has it. 462 | (defun atrans-conseqs (cd) 463 | (notice (cdpath '(actor) cd) 464 | cd) 465 | (notice (cdpath '(actor) cd) 466 | (add-conseq (has (cdpath '(to) cd) 467 | (cdpath '(object) cd)))) 468 | (add-conseq (is-at (cdpath '(object) cd) 469 | (cdpath '(to) cd))) 470 | (if (cdpath '(from) cd) 471 | (notice (cdpath '(actor) cd) 472 | (add-conseq (negate (has (cdpath '(from) cd) 473 | (cdpath '(object) cd))))))) 474 | 475 | ; Consequences of a grasp: everyone knows that the actor either has or 476 | ; (in the case of a tf (transition final or the end of an action) of the 477 | ; grasp) doesn't have the object 478 | (defun grasp-conseqs (cd) 479 | (notice (cdpath '(actor) cd) 480 | (add-conseq (if (in-mode cd 'tf) 481 | (negate (has (cdpath '(actor) cd) 482 | (cdpath '(object) cd))) 483 | (has (cdpath '(actor) cd) 484 | (cdpath '(object) cd)))))) 485 | 486 | ; Consequences of an ingest: everyone knows that the actor 487 | ; is no longer hungry or thirsty. 488 | (defun ingest-conseqs (cd) 489 | (notice (cdpath '(actor) cd) 490 | (add-conseq (state (cdpath '(actor) cd) 491 | (if (equal (cdpath '(object) cd) 'water) 492 | 'thirsty 493 | 'hungry) 494 | 'neg)))) 495 | 496 | ; Consequences of a loc change: everyone knows it. 497 | (defun loc-conseqs (cd) 498 | (notice (cdpath '(actor) cd) cd)) 499 | 500 | ; Consequences of an mbuild: if the object is a causal then a demon 501 | ; is set up for the actor that will be triggered by the antecedent. 502 | (defun mbuild-conseqs (cd) 503 | (if (equal (cdpath '(actor) cd) 504 | (cdpath '(object conseq actor) cd)) 505 | (put (cdpath '(actor) cd) 506 | 'demons 507 | (cons (cons (cdpath '(object ante) cd) 508 | (cdpath '(object conseq) cd)) 509 | (get (cdpath '(actor) cd) 'demons)))) 510 | nil) 511 | 512 | ; Consequences of an mloc change: check the demons to see if the 513 | ; learned fact affects the learner. Also check the reaction list 514 | ; for general responses to learning such facts. 515 | (defun mloc-conseqs (cd) 516 | (demon-check (cdpath '(val part) cd) 517 | (cdpath '(con) cd)) 518 | (if (not (member 'neg (cdpath '(con mode) cd))) 519 | (case (header-cd (cdpath '(con) cd)) 520 | (loc (loc-react cd)) 521 | (mloc (mloc-react cd)) 522 | (hungry (hunger-react cd)) 523 | (thirsty (thirst-react cd)) 524 | (t nil)))) 525 | 526 | ; Stored under each character is a list of "demons." A demon is 527 | ; a CD pattern plus an action. Whenever the character learns 528 | ; something this list is checked to see if there is a response to make. 529 | ; Demons are set up by things like the mbuild in a bargain-plan. 530 | (defun demon-check (who event) 531 | (put who 532 | 'demons 533 | (remove-if #'null 534 | (mapc #'(lambda (demon) 535 | (cond ((unify-cds (car demon) event) 536 | (push (cdr demon) *actions*) 537 | nil) 538 | (t 539 | demon))) 540 | (get who 'demons))))) 541 | 542 | ; Consequences of an mtrans: if there is a ques in the CD mtransed, 543 | ; and if it is a causal, then it is a bargaining promise; otherwise, 544 | ; it is a request (assuming the actors in the sub-CD are in the right 545 | ; places). If there is no ques in the CD mtransed, then the hearer 546 | ; knows about the mtrans, and if he believes the speaker, then he 547 | ; believes what the speaker believes. 548 | (defun mtrans-conseqs (cd) 549 | (let ((actor (cdpath '(actor) cd)) 550 | (object (cdpath '(object) cd)) 551 | (hearer (cdpath '(to part) cd))) 552 | (cond ((member 'ques (cdpath '(object mode) cd)) 553 | (cond ((and (equal (header-cd object) 'cause) 554 | (equal actor (cdpath '(object ante actor) cd)) 555 | (equal hearer (cdpath '(object conseq actor) cd))) 556 | (promise-conseqs hearer 557 | (cdpath '(object conseq) cd) 558 | actor 559 | (cdpath '(object ante) cd))) 560 | ((equal (cdpath '(object actor) cd) hearer) 561 | (request-conseqs actor 562 | hearer 563 | (future (un-question object)))))) 564 | ((not (equal actor hearer)) 565 | (add-conseq (mloc hearer cd)) 566 | (cond ((not (relate hearer actor hearer 'deceive)) 567 | (add-conseq (mloc hearer (mloc actor object))))))))) 568 | 569 | ; Consequences of y asking x to promise to do xdo if y does ydo: 570 | ; If x deceives y, then after ydo, x will call y stupid, but says 571 | ; that he will do xdo in return for ydo; 572 | ; else if x likes y, then x will do xdo after ydo and says so. 573 | ; Otherwise x says no. 574 | (defun promise-conseqs (x xdo y ydo) 575 | (let ((a (cause ydo (affirm xdo)))) 576 | (cond ((relate x x y 'deceive) 577 | (add-conseq (mbuild x 578 | (cause ydo 579 | (future (mtrans x 580 | (state y 'smart 'neg) 581 | y 582 | x))))) 583 | (add-conseq (mtrans x a y x))) 584 | ((relate x x y 'like) 585 | (add-conseq (mbuild x a)) 586 | (add-conseq (mtrans x a y x))) 587 | (t 588 | (add-conseq (mtrans x (negate a) y x)))))) 589 | 590 | ; Consequences of x asking y to do z: 591 | ; If y doesn't like x or dominates x, then y will say no; otherwise 592 | ; y will do z. 593 | (defun request-conseqs (x y z) 594 | (add-conseq (if (or (not (relate y y x 'like)) 595 | (relate y y x 'dominate)) 596 | (plan y (future (mtrans y (negate z) x y))) 597 | (plan y z)))) 598 | 599 | ; Consequences of a plan: If the actor of the plan act is the actor of 600 | ; the object of the plan, then add the object to the list of actions. 601 | (defun plan-conseqs (cd) 602 | (if (equal (cdpath '(actor) cd) (cdpath '(object actor) cd)) 603 | (push (cdpath '(object) cd) *actions*)) 604 | nil) 605 | 606 | 607 | ; Consequences of a propel: the object struck dies 608 | (defun propel-conseqs (cd) 609 | (if (member (cdpath '(to) cd) *personae*) 610 | (add-conseq (state (cdpath '(to) cd) 'health 'neg)))) 611 | 612 | ; Consequences of a ptrans: location change, for both actor 613 | ; and object. 614 | (defun ptrans-conseqs (cd) 615 | (add-conseq (is-at (cdpath '(object) cd) (cdpath '(to) cd))) 616 | (if (not (equal (cdpath '(actor) cd) (cdpath '(object) cd))) 617 | (add-conseq (is-at (cdpath '(actor) cd) (cdpath '(to) cd))))) 618 | 619 | ; Reactions to learning of a location change: if it's food or water, 620 | ; check to see if learner is hungry or thirsty. 621 | (defun loc-react (cd) 622 | (and (or (member (cdpath '(con actor) cd) 623 | (get-isa 'food (cdpath '(val part) cd))) 624 | (equal (cdpath '(con actor) cd) 'water)) 625 | (sgoal-check (cdpath '(val part) cd) 626 | (if (equal (cdpath '(con actor) cd) 'water) 627 | 'thirsty 628 | 'hungry)))) 629 | 630 | ; If a character is hungry or thirsty, add the appropriate s-goal 631 | ; to the list of plans. 632 | (defun sgoal-check (actor scale) 633 | (and (in-state actor scale) 634 | (push (list (if (equal scale 'thirsty) 635 | 'sthirst 636 | 'shunger) 637 | (list 'quote actor)) 638 | *plans*))) 639 | 640 | ; Reactions to learning that someone has learned something: 641 | ; if it's someone else, and it's about himself or you believe he 642 | ; doesn't deceive you, then you believe it too. 643 | (defun mloc-react (cd) 644 | (and (not (equal (cdpath '(val part) cd) (cdpath '(con val part) cd))) 645 | (or (equal (cdpath '(con con actor) cd) (cdpath '(con val part) cd)) 646 | (not (relate (cdpath '(val part) cd) 647 | (cdpath '(con val part) cd) 648 | (cdpath '(val part) cd) 649 | 'deceive))) 650 | (add-conseq (mloc (cdpath '(val part) cd) 651 | (cdpath '(con con) cd))))) 652 | 653 | ; Reactions to learning that you're hungry: add s-goal to list 654 | ; of plans. 655 | (defun hunger-react (cd) 656 | (push (list 'shunger (list 'quote (cdpath '(con actor) cd))) *plans*)) 657 | 658 | ; Reactions to learning you're thirsty: add s-goal to list 659 | ; of plans. 660 | (defun thirst-react (cd) 661 | (push (list 'sthirst (list 'quote (cdpath '(con actor) cd))) *plans*)) 662 | 663 | ; Notice says that everyone in the same location as who knows 664 | ; about CD. 665 | (defun notice (who cd) 666 | (let ((where (loc-name-of who))) 667 | (mapc #'(lambda (persona) 668 | (if (equal (loc persona) where) 669 | (add-conseq (mloc persona cd)))) 670 | *personae*))) 671 | 672 | ; Memory functions and pattern matcher 673 | ; addfact adds a CD to knower's knowledge set. Also if world 674 | ; learns a character has died, then the character is removed from the 675 | ; global list of characters. 676 | ; The CD is added to the front of the fact list, so that memquery 677 | ; will get the most recent CD that matches its query pattern. Older 678 | ; contradicted facts are still on the list but are not seen. 679 | (defun addfact (knower cd) 680 | (put knower 'facts (cons cd (get knower 'facts))) 681 | ;;; Now check for deceased people. 682 | (if (and (equal knower 'world) 683 | (equal (header-cd cd) 'health) 684 | (member 'neg (cdpath '(mode) cd))) 685 | (setf *personae* 686 | (remove (cdpath '(actor) cd) 687 | *personae*))) 688 | nil) 689 | 690 | ; is-state returns non-nil if CD is one of the state forms. 691 | (defun is-state (cd) 692 | (member (header-cd cd) 693 | '(loc 694 | mloc 695 | cont 696 | like 697 | deceive 698 | dominate 699 | hungry 700 | thristy 701 | health 702 | smart))) 703 | 704 | ; now-knows adds what to the data base for who. It also prints in 705 | ; English this new fact. If who = world (a true fact) and what is 706 | ; an mloc, then save the content of the mloc under the person who 707 | ; learned it. If say-flag is t, then mlocs are always generated in 708 | ; English; otherwise only facts (who = world) are generated. This 709 | ; reduces the volume of the output. 710 | (defun now-knows (who what say-flag) 711 | (let ((newwho 712 | (if (and (equal who 'world) 713 | (equal (header-cd what) 'mloc)) 714 | (cdpath '(val part) what) 715 | who)) 716 | (newwhat 717 | (if (and (equal who 'world) 718 | (equal (header-cd what) 'mloc)) 719 | (cdpath '(con) what) 720 | what))) 721 | (if (or say-flag 722 | (equal newwho 'world)) 723 | (say (mloc newwho newwhat))) 724 | (addfact newwho newwhat))) 725 | 726 | ; knows(knower,fact) returns fact if fact is in data base for knower: 727 | ; -- if fact = knows(knower,subfact), assume everyone knows what they 728 | ; know and look up subfact, 729 | ; -- if fact has a ?unspec, then return the filler that replaces 730 | ; the ?unspec in the data base. 731 | (defun knows (knower fact) 732 | (let ((newfact 733 | (if (and (equal (header-cd fact) 'mloc) 734 | (equal (cdpath '(val part) fact) knower)) 735 | (cdpath '(con) fact) 736 | fact))) 737 | (memquery knower newfact))) 738 | 739 | (defun knows-loc (knower object) 740 | (cdpath '(val) (knows knower (where-is object)))) 741 | 742 | (defun knows-owner (knower object) 743 | (cdpath '(val) (knows knower (who-has object)))) 744 | 745 | (defun knows-if (knower cd) 746 | (cdpath '(mode) (knows knower (setrole 'mode '?unspecified cd)))) 747 | 748 | ; memquery find the first item in knower's data base that 749 | ; matches fact. 750 | (defun memquery (knower pat) 751 | (car (pat-member pat (get knower 'facts)))) 752 | 753 | ; pat-member finds the first item in cd-list that matches 754 | ; pat and returns cd-list from that item on. 755 | (defun pat-member (pat cd-list) 756 | (if cd-list 757 | (let ((cd (car cd-list))) 758 | (if (unify-cds pat cd) 759 | cd-list 760 | (pat-member pat (cdr cd-list)))))) 761 | 762 | ; Returns non-nil if actor has goal. 763 | (defun has-goal-of (actor pat) 764 | (car (pat-member pat (get actor 'goals)))) 765 | 766 | ; Adds goal to data base. 767 | (defun gets-new-goal-of (actor goal) 768 | (put actor 'goals (cons goal (get actor 'goals))) 769 | (say (wants actor goal))) 770 | 771 | ; Removes goal from data base 772 | (defun forgets-goal-of (actor goal) 773 | (let ((goal-to-be-forgotten (has-goal-of actor goal))) 774 | (put actor 775 | 'goals 776 | (remove-if #'(lambda (g) 777 | (equal g goal-to-be-forgotten)) 778 | (get actor 'goals))))) 779 | 780 | ; Returns non-nil if x is in a state, e.g., hungry. 781 | (defun in-state (x st) 782 | (find-out 'world (state x st 'pos))) 783 | 784 | ; Returns non-nil if X believes that y relates to z in a certain way. 785 | ; Usually either y or z is x. 786 | (defun relate (x y z rel) 787 | (find-out x (relation y z rel 'pos))) 788 | 789 | ; Looks up CD in the data base for who. If there, return non-nil if 790 | ; the CD is not a negative fact. If not there, ask the user at the 791 | ; terminal and save the result. Note that the generator is used to 792 | ; ask questions. 793 | ; 794 | ; find-out is used to determine if a given character is in a 795 | ; given state (e.g., is the character hungry or thirsty) and is 796 | ; also used to determine how two characters relate to on another 797 | ; (e.g., do they like one another?, does one have a tendency to 798 | ; deceive the other, etc.). 799 | (defun find-out (who cd) 800 | (let ((mode (knows-if who cd))) 801 | (cond (mode 802 | (member 'pos mode)) 803 | (t 804 | (say (mloc who cd)) 805 | (format t "~% [Y/N]? ~%>") 806 | (let ((answer (equal (read) 'y))) 807 | (addfact who 808 | (setrole 'mode 809 | (list (if answer 'pos 'neg)) 810 | cd)) 811 | answer))))) 812 | 813 | ; True if y thinks x is a friend of his. 814 | (defun is-friend-of (x y) 815 | (and (not (equal x y)) 816 | (relate y x y 'like))) 817 | 818 | ; Returns location of x. 819 | (defun loc (x) 820 | (knows-loc 'world x)) 821 | 822 | ; True if x and y are in the same place. 823 | (defun is-prox (x y) 824 | (equal (loc-name-of x) 825 | (loc-name-of y))) 826 | 827 | ; A CD is true if it's an mloc and the content is in the person's 828 | ; data base, or it's in the data base for world. 829 | (defun is-true (cd) 830 | (if (equal (header-cd cd) 'mloc) 831 | (knows (cdpath '(val part) cd) (cdpath '(con) cd)) 832 | (knows 'world cd))) 833 | 834 | ; loc-name-of returns the real location of x. This may involve going 835 | ; up several levels -- e.g., when Joe takes a worm, its location is 836 | ; stored as joe, but its real location is the location Joe is at. 837 | (defun loc-name-of (x) 838 | (let ((loc-of-x (loc x))) 839 | (cond ((member x *all-locations*) 840 | x) 841 | ((member loc-of-x *all-locations*) 842 | loc-of-x) 843 | ;;; If something isn't anywhere in particular, 844 | ;;; then it on the ground. 845 | ((null loc-of-x) 846 | 'ground) 847 | (t 848 | (loc-name-of loc-of-x))))) 849 | 850 | ; get-isa is like get but checks is-a node for x if x has no 851 | ; y property. 852 | (defun get-isa (x y) 853 | (or (get y x) 854 | (get (get y 'is-a) x))) 855 | 856 | ; Functions to build CD forms 857 | 858 | ; Acts 859 | 860 | (defun atrans (actor object to from) 861 | (list 'atrans 862 | (list 'actor actor) 863 | (list 'object object) 864 | (list 'to to) 865 | (list 'from from))) 866 | 867 | (defun cause (x y) 868 | (list 'cause 869 | (list 'ante x) 870 | (list 'conseq y))) 871 | 872 | (defun grasp (actor object) 873 | (list 'grasp 874 | (list 'actor actor) 875 | (list 'object object))) 876 | 877 | (defun un-grasp (actor object) 878 | (tf (grasp actor object))) 879 | 880 | (defun ingest (actor object) 881 | (list 'ingest 882 | (list 'actor actor) 883 | (list 'object object))) 884 | 885 | (defun mbuild (actor object) 886 | (list 'mbuild 887 | (list 'actor actor) 888 | (list 'object object))) 889 | 890 | (defun mtrans (actor object to from) 891 | (list 'mtrans 892 | (list 'actor actor) 893 | (list 'object object) 894 | (list 'to (list 'cp (list 'part to))) 895 | (list 'from from))) 896 | 897 | (defun plan (actor object) 898 | (list 'plan 899 | (list 'actor actor) 900 | (list 'object object))) 901 | 902 | (defun propel (actor object to) 903 | (list 'propel 904 | (list 'actor actor) 905 | (list 'object object) 906 | (list 'to to))) 907 | 908 | (defun ptrans (actor object to from) 909 | (if to 910 | (list 'ptrans 911 | (list 'actor actor) 912 | (list 'object object) 913 | (list 'to to) 914 | (list 'from from)))) 915 | 916 | (defun wants (actor goal) 917 | (list 'want 918 | (list 'actor actor) 919 | (list 'object goal))) 920 | 921 | ; States 922 | 923 | (defun has (actor object) 924 | (list 'cont 925 | (list 'actor object) 926 | (list 'val actor))) 927 | 928 | (defun is-at (actor loc) 929 | (list 'loc 930 | (list 'actor actor) 931 | (list 'val loc))) 932 | 933 | (defun mloc (actor con) 934 | (list 'mloc 935 | (list 'con con) 936 | (list 'val (list 'cp (list 'part actor))))) 937 | 938 | (defun state (actor st mode) 939 | (list st 940 | (list 'actor actor) 941 | (list 'mode (list mode)))) 942 | 943 | (defun relation (actor object rel mode) 944 | (list rel 945 | (list 'actor actor) 946 | (list 'to object) 947 | (list 'mode (list mode)))) 948 | 949 | (defun where-is (x) 950 | (list 'loc 951 | (list 'actor x) 952 | (list 'val '?unspecified))) 953 | 954 | (defun who-has (x) 955 | (list 'cont 956 | (list 'actor x) 957 | (list 'val '?unspecified))) 958 | 959 | ; Mode functions 960 | 961 | (defun mode (cd) 962 | (cdpath '(mode) cd)) 963 | 964 | ; Affirm/Negate set the mode of a CD to true/false. 965 | 966 | (defun affirm (cd) 967 | (if (member 'pos (mode cd)) 968 | cd 969 | (setrole 'mode (cons 'pos (remove 'neg (mode cd))) cd))) 970 | 971 | (defun negate (cd) 972 | (if (member 'neg (mode cd)) 973 | (affirm cd) 974 | (setrole 'mode (cons 'neg (remove 'pos (mode cd))) cd))) 975 | 976 | ; maybe makes a CD hypothetical -- doesn't matter if it's true or false. 977 | (defun maybe (cd) 978 | (if (member 'maybe (mode cd)) 979 | cd 980 | (setrole 'mode (cons 'maybe (mode cd)) cd))) 981 | 982 | ; question/un-question make a CD a question/non-question -- doesn't 983 | ; matter if it's true or false. 984 | (defun question (cd) 985 | (if (member 'ques (mode cd)) 986 | cd 987 | (setrole 'mode (cons 'ques (mode cd)) cd))) 988 | 989 | (defun un-question (cd) 990 | (setrole 'mode (remove 'ques (mode cd)) cd)) 991 | 992 | ; tf adds "transition final" to a CD -- doesn't matter if it's true 993 | ; or false. 994 | (defun tf (cd) 995 | (if (member 'tf (mode cd)) 996 | cd 997 | (setrole 'mode (cons 'tf (mode cd)) cd))) 998 | 999 | ; future sets a CD to a future time. 1000 | (defun future (cd) 1001 | (setrole 'time 'future cd)) 1002 | 1003 | ; Path 1004 | ; 1005 | ; cdpath finds the filler at the end of the role list in a CD. 1006 | ; 1007 | ; For example, if 1008 | ; CD = (mtrans (actor joe) 1009 | ; (object (ptrans (actor joe) 1010 | ; (object worm) 1011 | ; (from joe) 1012 | ; (to irving)))) 1013 | ; then 1014 | ; (cdpath '(actor) cd) returns joe; 1015 | ; (cdpath '(object) cd) returns (ptrans (actor joe) 1016 | ; (object worm) 1017 | ; (from joe) 1018 | ; (to irving)); 1019 | ; (cdpath '(object object) cd) returns worm. 1020 | ; 1021 | ; If a role doesn't exist in a CD form, then cdpath returns nil. 1022 | (defun cdpath (rolelist cd) 1023 | (if (null rolelist) 1024 | cd 1025 | (cdpath (cdr rolelist) (filler-role (car rolelist) cd)))) 1026 | 1027 | ; each string should start with a capital letter and then be lower case. 1028 | (defun beautify-string (string) 1029 | (when (plusp (length string)) 1030 | (nstring-downcase string) 1031 | (setf (aref string 0) (char-upcase (aref string 0)))) 1032 | string) 1033 | 1034 | ; micro-mumble: micro English generator 1035 | 1036 | ; say prints a CD as an English sentence. If CD is an mloc of the 1037 | ; world, then only the fact itself is said, otherwise the whole mloc 1038 | ; is used. The original CD is returned. say1 is called with the 1039 | ; infinitive flag off and the say-subject flag on. 1040 | (defun say (cd) 1041 | (let ((cd-to-be-said (if (unify-cds '(mloc (val (cp (part world)))) cd) 1042 | (cdpath '(con) cd) 1043 | cd))) 1044 | (flet ((say-it () 1045 | (format t "~%") 1046 | (write-string 1047 | (beautify-string 1048 | (with-output-to-string (*standard-output*) 1049 | (say1 cd-to-be-said 1050 | (or (cdpath '(time) cd-to-be-said) 1051 | *default-tense*) 1052 | nil 1053 | t)))) 1054 | (format t "."))) 1055 | (say-it)) 1056 | cd)) 1057 | 1058 | ; say1 prints cd according to the program under the head predicate. 1059 | ; If no program is there, the CD is printed with <>s around it. 1060 | ; 1061 | ; These generation programs are lists of expressions to be evaluated. 1062 | ; Attached to primative acts, they are normally concerned with 1063 | ; generating subject-verb-object clauses. Since some of the acts, 1064 | ; such as mtrans, want and plan, take subclauses, the generator has to 1065 | ; be recursive, so that the atrans program that generates the clause 1066 | ; "Joe gave Irving the worm" can also generate the subclause in 1067 | ; "Joe planned to give Irving the worm." This means that the programs have 1068 | ; to know when to say or not say the subject, when to use the 1069 | ; infinitive form, and what tense to use. 1070 | ; subj = true means print the subject, 1071 | ; inf = true means use the infinitive form, 1072 | ; tense is set to either past, present, or future, or cond (for 1073 | ; conditional, i.e., hypothetical) 1074 | (defun say1 (cd tense inf subj) 1075 | (let ((say-fun (get (header-cd cd) 'say-fun))) 1076 | (if say-fun 1077 | (apply say-fun (list cd tense inf subj)) 1078 | (progn 1079 | ; (break) 1080 | (format t "~% < ~s > " cd))))) ; RJ 1081 | 1082 | ; subclause recursively calls say1 with the subconcept at the 1083 | ; endpoint of rolelist. word, if non-nil, starts the subclause, 1084 | ; unless relative-pronoun has a better idea. Tense is calculated 1085 | ; by sub-tense. 1086 | (defun subclause (cd word rolelist tense) 1087 | (when word 1088 | (format t "~s " (or (relative-pronoun rolelist cd) 1089 | word))) 1090 | (let ((subcd (cdpath rolelist cd))) 1091 | (say1 subcd (sub-tense tense subcd) nil t))) 1092 | 1093 | ; sub-tense is given a tense and a CD and picks the tense to use. 1094 | ; The given tense is used, except with states (i.e., don't 1095 | ; say "he told him where the honey would be" even though conceptually 1096 | ; that's right), and with past statements about the future (i.e., say 1097 | ; "he said he would" rather than "he said he will"). 1098 | (defun sub-tense (tense subcd) 1099 | (cond ((is-state subcd) 1100 | *default-tense*) 1101 | ((and (equal tense 'past) 1102 | (equal (cdpath '(time) subcd) 'future)) 1103 | 'cond) 1104 | (t 1105 | tense))) 1106 | 1107 | ; relative-pronoun returns the word to start the subclause 1108 | ; for the CD at the end of the CD role path. 1109 | (defun relative-pronoun (rolelist cd) 1110 | (let ((subcd (cdpath rolelist cd))) 1111 | (cond ((and (equal (header-cd subcd) 'loc) 1112 | (pcvar-p (cdpath '(val) subcd))) 1113 | 'where) 1114 | ((pcvar-p (next-subject cd)) 1115 | 'who) 1116 | (t 1117 | nil)))) 1118 | 1119 | ; next-subject returns the subject of a subconcept, which is normally 1120 | ; the actor slot, except for cont (where it's in the val slot) and 1121 | ; mloc (where it's in the part slot of the val slot). 1122 | (defun next-subject (cd) 1123 | (let ((subcd (cdpath '(object) cd))) 1124 | (cdpath (case (header-cd subcd) 1125 | (cont '(val)) 1126 | (mloc '(val part)) 1127 | (t '(actor))) 1128 | subcd))) 1129 | 1130 | ; infclause calls recursively say1 with the subconcept at the 1131 | ; endpoint of rolelist. An infinitive is printed, and the subject 1132 | ; is suppressed. 1133 | (defun infclause (cd rolelist subj-flag tense) 1134 | (say1 (cdpath rolelist cd) tense t subj-flag)) 1135 | 1136 | ; Store say-funs for each of the CD forms 1137 | 1138 | ; atrans may go to either "take" (if actor = to) or "give." 1139 | (defun say-atrans (cd tense inf subj) 1140 | (cond ((equal (cdpath '(actor) cd) (cdpath '(to) cd)) 1141 | (say-subj-verb cd tense inf subj '(actor) 'take) 1142 | (format t " ") 1143 | (say-filler cd '(object)) 1144 | (say-prep cd 'from '(from) t)) 1145 | (t 1146 | (say-subj-verb cd tense inf subj '(actor) 'give) 1147 | (format t " ") 1148 | (say-filler cd '(to)) 1149 | (format t " ") 1150 | (say-filler cd '(object))))) 1151 | 1152 | (put 'atrans 'say-fun 'say-atrans) 1153 | 1154 | ; mtrans may go to either "ask whether" or "tell that" 1155 | (defun say-mtrans (cd tense inf subj) 1156 | (cond ((member 'ques (cdpath '(object mode) cd)) 1157 | (say-subj-verb cd tense inf subj '(actor) 'ask) 1158 | (format t " ") 1159 | (say-filler cd '(to part)) 1160 | (format t " ") 1161 | (subclause cd 'whether '(object) 'cond)) 1162 | (t 1163 | (say-subj-verb cd tense inf subj '(actor) 'tell) 1164 | (format t " ") 1165 | (say-filler cd '(to part)) 1166 | (format t " ") 1167 | (subclause cd 'that '(object) (cdpath '(time) cd))))) 1168 | 1169 | (put 'mtrans 'say-fun 'say-mtrans) 1170 | 1171 | ; ptrans may go to either "go" or "move." 1172 | (defun say-ptrans (cd tense inf subj) 1173 | (cond ((equal (cdpath '(actor) cd) 1174 | (cdpath '(object) cd)) 1175 | (say-subj-verb cd tense inf subj '(actor) 'go)) 1176 | (t 1177 | (say-subj-verb cd tense inf subj '(actor) 'move) 1178 | (format t " ") 1179 | (say-filler cd '(object)))) 1180 | (say-prep cd 'to '(to) t)) 1181 | 1182 | (put 'ptrans 'say-fun 'say-ptrans) 1183 | 1184 | ; mbuild may go to either "decide to" or "decide that." 1185 | (defun say-mbuild (cd tense inf subj) 1186 | (say-subj-verb cd tense inf subj '(actor) 'decide) 1187 | (format t " ") 1188 | (cond ((equal (cdpath '(actor) cd) 1189 | (cdpath '(object actor) cd)) 1190 | (infclause cd '(object) nil 'future)) 1191 | (t 1192 | (subclause cd 'that '(object) 'future)))) 1193 | 1194 | (put 'mbuild 'say-fun 'say-mbuild) 1195 | 1196 | ; propel goes to strike 1197 | (defun say-propel (cd tense inf subj) 1198 | (say-subj-verb cd tense inf subj '(actor) 'strike) 1199 | (format t " ") 1200 | (say-filler cd '(to))) 1201 | 1202 | (put 'propel 'say-fun 'say-propel) 1203 | 1204 | ; grasp may go to either "let go of" or "grab." 1205 | (defun say-grasp (cd tense inf subj) 1206 | (cond ((in-mode cd 'tf) 1207 | (say-subj-verb cd tense inf subj '(actor) 'let) 1208 | (format t " GO OF")) 1209 | (t 1210 | (say-subj-verb cd tense inf subj '(actor) 'grab))) 1211 | (say-filler cd '(object))) 1212 | 1213 | (put 'grasp 'say-fun 'say-grasp) 1214 | 1215 | ; ingest may go to either "eat" or "drink." 1216 | (defun say-ingest (cd tense inf subj) 1217 | (say-subj-verb cd tense inf subj '(actor) 1218 | (if (equal (cdpath '(object) cd) 'water) 1219 | 'drink 1220 | 'eat)) 1221 | (format t " ") 1222 | (say-filler cd '(object))) 1223 | 1224 | (put 'ingest 'say-fun 'say-ingest) 1225 | 1226 | ; plan goes to "plan." 1227 | (defun say-plan (cd tense inf subj) 1228 | (say-subj-verb cd tense inf subj '(actor) 'plan) 1229 | (format t " ") 1230 | (infclause cd '(object) nil 'future)) 1231 | 1232 | (put 'plan 'say-fun 'say-plan) 1233 | 1234 | ; want goes to "want to" -- the third argument of infclause is set to 1235 | ; true if the subject of the subclause is different that the subject 1236 | ; of the main clause. 1237 | (defun say-want (cd tense inf subj) 1238 | (say-subj-verb cd tense inf subj '(actor) 'want) 1239 | (format t " ") 1240 | (infclause cd 1241 | '(object) 1242 | (not (equal (cdpath '(actor) cd) 1243 | (next-subject cd))) 1244 | 'future)) 1245 | 1246 | (put 'want 'say-fun 'say-want) 1247 | 1248 | ; loc goes to "be near." 1249 | (defun say-loc (cd tense inf subj) 1250 | (say-subj-verb cd tense inf subj '(actor) 'be) 1251 | (or (pcvar-p (cdpath '(val) cd)) 1252 | (say-prep cd 'near '(val) t))) 1253 | 1254 | (put 'loc 'say-fun 'say-loc) 1255 | 1256 | ; cont goes to "have." 1257 | (defun say-cont (cd tense inf subj) 1258 | (say-subj-verb cd tense inf subj '(val) 'have) 1259 | (format t " ") 1260 | (say-filler cd '(actor))) 1261 | 1262 | (put 'cont 'say-fun 'say-cont) 1263 | 1264 | ; mloc may go to either "know that", "know whether", or "think that." 1265 | (defun say-mloc (cd tense inf subj) 1266 | (say-subj-verb cd 1267 | tense 1268 | inf 1269 | subj 1270 | '(val part) 1271 | (if (or (relative-pronoun '(con) cd) 1272 | (is-true (cdpath '(con) cd))) 1273 | 'know 1274 | 'think)) 1275 | (format t " ") 1276 | (subclause cd 'that '(con) *default-tense*)) 1277 | 1278 | (put 'mloc 'say-fun 'say-mloc) 1279 | 1280 | ; health goes to "be alive" 1281 | (defun say-health (cd tense inf subj) 1282 | (say-subj-verb cd tense inf subj '(actor) 'be) 1283 | (format t " ") 1284 | (format t "ALIVE")) 1285 | 1286 | (put 'health 'say-fun 'say-health) 1287 | 1288 | ; smart goes to "be bright" 1289 | (defun say-smart (cd tense inf subj) 1290 | (say-subj-verb cd tense inf subj '(actor) 'be) 1291 | (format t " ") 1292 | (format t "BRIGHT")) 1293 | 1294 | (put 'smart 'say-fun 'say-smart) 1295 | 1296 | ; hungry goes to "be hungry" 1297 | (defun say-hungry (cd tense inf subj) 1298 | (say-subj-verb cd tense inf subj '(actor) 'be) 1299 | (format t " ") 1300 | (format t "HUNGRY")) 1301 | 1302 | (put 'hungry 'say-fun 'say-hungry) 1303 | 1304 | ; thirsty goes to "be thirsty" 1305 | (defun say-thirsty (cd tense inf subj) 1306 | (say-subj-verb cd tense inf subj '(actor) 'be) 1307 | (format t " ") 1308 | (format t "THIRSTY")) 1309 | 1310 | (put 'thirsty 'say-fun 'say-thirsty) 1311 | 1312 | ; cause may go to either "x if y" or "if x then y" 1313 | (defun say-cause (cd tense inf subj) 1314 | (declare (ignore inf)) 1315 | (declare (ignore subj)) 1316 | (cond ((in-mode cd 'ques) 1317 | (subclause cd nil '(conseq) 'future) 1318 | (format t " IF ") 1319 | (subclause cd nil '(ante) (case tense 1320 | (figure 'present) 1321 | (cond *default-tense*) 1322 | (t tense)))) 1323 | (t 1324 | (format t "IF ") 1325 | (subclause cd nil '(ante) 'future) 1326 | (format t " THEN ") 1327 | (subclause cd nil '(conseq) 'cond)))) 1328 | 1329 | (put 'cause 'say-fun 'say-cause) 1330 | 1331 | ; like goes to "like" 1332 | (defun say-like (cd tense inf subj) 1333 | (say-subj-verb cd tense inf subj '(actor) 'like) 1334 | (format t " ") 1335 | (say-filler cd '(to))) 1336 | 1337 | (put 'like 'say-fun 'say-like) 1338 | 1339 | ; dominate goes to "dominate" 1340 | (defun say-dominate (cd tense inf subj) 1341 | (say-subj-verb cd tense inf subj '(actor) 'dominate) 1342 | (format t " ") 1343 | (say-filler cd '(to))) 1344 | 1345 | (put 'dominate 'say-fun 'say-dominate) 1346 | 1347 | ; deceive goes to "deceive" 1348 | (defun say-deceive (cd tense inf subj) 1349 | (say-subj-verb cd tense inf subj '(actor) 'deceive) 1350 | (format t " ") 1351 | (say-filler cd '(to))) 1352 | 1353 | (put 'deceive 'say-fun 'say-deceive) 1354 | 1355 | ; say-filler prints the CD at the end of a CD role path 1356 | (defun say-filler (cd rolelist) 1357 | (say-pp (cdpath rolelist cd))) 1358 | 1359 | ; say-pp prints a CD (adds "the" to object). 1360 | (defun say-pp (cd) 1361 | (if (member cd *all-objects*) 1362 | (format t "THE ")) 1363 | (format t "~s" cd)) 1364 | 1365 | ; say-prep prints a preposition plus a CD at the end of a role path, 1366 | ; if any exists. 1367 | (defun say-prep (cd prep rolelist &optional space) 1368 | (let ((subcd (cdpath rolelist cd))) 1369 | (cond (subcd 1370 | (when space 1371 | (format t " ")) 1372 | (format t "~s " prep) 1373 | (say-pp subcd))))) 1374 | 1375 | ; in-mode tests whether x is in CD's mode. 1376 | (defun in-mode (cd x) 1377 | (member x (cdpath '(mode) cd))) 1378 | 1379 | ; say-neg prints "not" if CD is negative. 1380 | (defun say-neg (cd &optional space0 space1) 1381 | (when (in-mode cd 'neg) 1382 | (when space0 1383 | (format t " ")) 1384 | (format t "NOT") 1385 | (when space1 1386 | (format t " ")))) 1387 | 1388 | ; say-subj-verb prints the subject (unless suppressed by 1389 | ; subj = nil, infinitives, or an ?unspec as the subject) and verb, 1390 | ; with auxillary and tensing, if any. Note that future tense is 1391 | ; treated as an auxillary. 1392 | (defun say-subj-verb (cd tense inf subj rolelist infinitive) 1393 | (let ((subject (cdpath rolelist cd))) 1394 | (cond (inf 1395 | (when subj (say-pp subject) (format t " ")) 1396 | (say-neg cd nil t) 1397 | (format t "TO ~s" infinitive)) 1398 | (t 1399 | (when (not (pcvar-p subject)) 1400 | (say-pp subject) 1401 | (format t " ")) 1402 | (let ((plural 1403 | (get subject 'plural)) 1404 | (auxilary 1405 | (cond ((in-mode cd 'maybe) 1406 | 'might) 1407 | ((equal tense 'future) 1408 | (if (equal *default-tense* 'past) 1409 | 'would 1410 | 'will)) 1411 | ((equal tense 'cond) 1412 | 'would) 1413 | ((and (in-mode cd 'neg) 1414 | (not (equal infinitive 'be))) 1415 | 'do)))) 1416 | (cond (auxilary 1417 | (say-tense cd tense inf subj auxilary plural) 1418 | (say-neg cd t nil) 1419 | (format t " ~s" infinitive)) 1420 | (t 1421 | (say-tense cd tense inf subj infinitive plural) 1422 | (when (equal infinitive 'be) 1423 | (say-neg cd t nil))))))))) 1424 | 1425 | ; say-tense prints a verb, with tense and number inflection. 1426 | ; Conjugations of irregular verbs are stored under the past and present 1427 | ; properties of the verb, in the format (singular plural) for each. 1428 | ; For regular verbs, say-tense adds "d", "ed", or "s" as appropriate. 1429 | (defun say-tense (cd tense inf subj infinitive plural) 1430 | (declare (ignore cd)) 1431 | (declare (ignore inf)) 1432 | (declare (ignore subj)) 1433 | (let ((tense-forms (get infinitive tense))) 1434 | (cond (tense-forms 1435 | (format t "~s" (if plural 1436 | (cadr tense-forms) 1437 | (car tense-forms)))) 1438 | (t 1439 | (format t "~s" infinitive) 1440 | (case tense 1441 | (past 1442 | (if (not (or (equal (lastchar infinitive) #\E) 1443 | (equal (lastchar infinitive) #\e))) 1444 | (format t "E")) 1445 | (format t "D")) 1446 | (present 1447 | (if (not plural) 1448 | (format t "S")))))))) 1449 | 1450 | ; lastchar returns that last character in x 1451 | (defun lastchar (x) 1452 | (car (last (explode x)))) 1453 | 1454 | (defun explode (x) 1455 | (coerce (princ-to-string x) 'list)) 1456 | 1457 | ; Generator Dictionary 1458 | ; 1459 | ; Set the past and/or present tenses for irregular verbs. 1460 | ; Each tense is of the form (singular plural). 1461 | 1462 | (put 'be 'past '(was were)) 1463 | (put 'be 'present '(is are)) 1464 | (put 'do 'past '(did did)) 1465 | (put 'do 'present '(does do)) 1466 | (put 'drink 'past '(drank drank)) 1467 | (put 'eat 'past '(ate ate)) 1468 | (put 'give 'past '(gave gave)) 1469 | (put 'go 'past '(went went)) 1470 | (put 'go 'present '(goes go)) 1471 | (put 'grab 'past '(grabbed grabbed)) 1472 | (put 'have 'past '(had had)) 1473 | (put 'have 'present '(has have)) 1474 | (put 'know 'past '(knew knew)) 1475 | (put 'let 'past '(let let)) 1476 | (put 'might 'past '(might might)) 1477 | (put 'might 'present '(might might)) 1478 | (put 'plan 'past '(planned planned)) 1479 | (put 'strike 'past '(struck struck)) 1480 | (put 'take 'past '(took took)) 1481 | (put 'tell 'past '(told told)) 1482 | (put 'think 'past '(thought thought)) 1483 | 1484 | ; Berries is the only plural in the current set-up. 1485 | (put 'berries 'plural t) 1486 | 1487 | ; CD Functions 1488 | 1489 | ; is-cd-p determines whether a given sexpr is a CD. 1490 | (defun is-cd-p (x) 1491 | (and (listp x) 1492 | (atom (header-cd x)) 1493 | (list-of-role-filler-pairs-p (roles-cd x)))) 1494 | 1495 | (defun list-of-role-filler-pairs-p (x) 1496 | (or (null x) 1497 | (and (listp x) 1498 | (listp (car x)) 1499 | (atom (role-pair (car x))) 1500 | (list-of-role-filler-pairs-p (cdr x))))) 1501 | 1502 | ; header-cd gets the head act of a CD form. 1503 | (defun header-cd (x) 1504 | (car x)) 1505 | 1506 | ; roles-cd gets the list of role-pairs of a CD form. 1507 | (defun roles-cd (x) 1508 | (cdr x)) 1509 | 1510 | ; Role-pairs have the form (role filler). 1511 | ; role-pair returns the role. 1512 | (defun role-pair (x) 1513 | (car x)) 1514 | 1515 | ; filler-pair returns the filler. 1516 | (defun filler-pair (x) 1517 | (cadr x)) 1518 | 1519 | ; A filler for a role is found by looking for the role name in the CD, 1520 | ; and returning the filler if a pair is found. 1521 | (defun filler-role (role cd) 1522 | (if (listp cd) 1523 | (let ((pair (assoc role (roles-cd cd)))) 1524 | (if pair (filler-pair pair))))) 1525 | 1526 | ; setrole makes a new CD form with (role filler) added 1527 | ; or replacing the old (role ...) pair. 1528 | (defun setrole (role filler cd) 1529 | (cons (header-cd cd) 1530 | (cons (list role filler) 1531 | (delete-if #'(lambda (pair) 1532 | (eq (car pair) role)) 1533 | (roles-cd cd))))) 1534 | 1535 | ; Pattern Unifier 1536 | ; This unifier is an adapted version of the unify function which appears 1537 | ; in the book _Artificial_Intelligence_Programming_ (2nd ed.) 1538 | ; Eugene Chaniak, Drew McDermott, and James Meehan. 1539 | 1540 | (defun unify (Pat1 Pat2) 1541 | (unify-1 Pat1 Pat2 NIL)) 1542 | 1543 | (defun unify-1 (Pat1 Pat2 Sub) 1544 | (cond ((pcvar-p Pat1) 1545 | (var-unify Pat1 Pat2 Sub)) 1546 | ((pcvar-p Pat2) 1547 | (var-unify Pat2 Pat1 Sub)) 1548 | ((atom Pat1) 1549 | (cond ((eql Pat1 Pat2) (list Sub)) 1550 | (T NIL))) 1551 | ((atom Pat2) 1552 | NIL) 1553 | (T 1554 | (mapcan #'(lambda (Sub) 1555 | (unify-1 (cdr Pat1) (cdr Pat2) Sub)) 1556 | (unify-1 (car Pat1) (car Pat2) Sub))))) 1557 | 1558 | (defvar *OccursCheck-P* T) 1559 | 1560 | (defun var-unify (PCVar Pat Sub) 1561 | (cond ((eql PCVar Pat) 1562 | (list Sub)) 1563 | (T 1564 | (let ((Binding (pcvar-binding PCVar Sub))) 1565 | (cond (Binding 1566 | (unify-1 (binding-value Binding) Pat Sub)) 1567 | ((and *OccursCheck-P* 1568 | (occurs-in-p PCVar Pat Sub)) 1569 | NIL) 1570 | (T 1571 | (list (extend-binding PCVar Pat Sub)))))))) 1572 | 1573 | (defun occurs-in-p (PCVar Pat Sub) 1574 | (cond ((pcvar-p Pat) 1575 | (or (eq PCVar Pat) 1576 | (let ((Binding (pcvar-binding Pat Sub))) 1577 | (and Binding 1578 | (occurs-in-p PCVar (binding-value Binding) Sub))))) 1579 | ((atom Pat) 1580 | NIL) 1581 | (T 1582 | (or (occurs-in-p PCVar (car Pat) Sub) 1583 | (occurs-in-p PCVar (cdr Pat) Sub))))) 1584 | 1585 | (defun pcvar-binding (PCVar AList) 1586 | (assoc PCVar AList)) 1587 | 1588 | (defun extend-binding (PCVar Pat AList) 1589 | (cons (list PCVar Pat) 1590 | AList)) 1591 | 1592 | (defun binding-value (Binding) (cadr Binding)) 1593 | 1594 | (defun pcvar-value (Pat Sub) 1595 | (let ((Binding (pcvar-binding Pat Sub))) 1596 | (cond ((null Binding) 1597 | Pat) 1598 | (T 1599 | (let ((Value (binding-value Binding))) 1600 | (cond ((eql Value Pat) 1601 | Pat) 1602 | (T 1603 | (replace-variables Value Sub)))))))) 1604 | 1605 | (defun replace-variables (Pat Sub) 1606 | (cond ((pcvar-p Pat) 1607 | (pcvar-value Pat Sub)) 1608 | ((atom Pat) 1609 | Pat) 1610 | (T 1611 | (cons (replace-variables (car Pat) Sub) 1612 | (replace-variables (cdr Pat) Sub))))) 1613 | 1614 | (defun instantiate (Pat Subs) 1615 | (cond ((pcvar-p Pat) 1616 | (let ((Entry (assoc Pat Subs))) 1617 | (if Entry 1618 | (instantiate (cadr Entry) Subs) 1619 | Pat))) 1620 | ((atom Pat) 1621 | Pat) 1622 | (T 1623 | (cons (instantiate (car Pat) Subs) 1624 | (instantiate (cdr Pat) Subs))))) 1625 | 1626 | ; CD Unifier 1627 | ; This replaces the less-general CD pattern matcher that was 1628 | ; used in the original Micro-Talespin program. This unifier 1629 | ; allows pattern variables to appear on both of the 1630 | ; expressions to be compared while a pattern matcher 1631 | ; only allows variables to appear in one of the expressions. 1632 | 1633 | (defun unify-cds (cd1 cd2) 1634 | (unify-cds-1 cd1 cd2 nil)) 1635 | 1636 | (defun unify-cds-1 (cd1 cd2 sub) 1637 | (and (eq (header-cd cd1) (header-cd cd2)) 1638 | (unify-pairs (roles-cd cd1) (roles-cd cd2) sub))) 1639 | 1640 | ; unify-pairs sees if the roles and fillers of a CD can 1641 | ; be matched together. It is more complicated than the 1642 | ; function unify-1 given above because (1) the role-filler pairs 1643 | ; do not need to be in the same order in the two CDs being 1644 | ; compared; (2) a missing pair in one CD means that that CD 1645 | ; is more general than the other CD and can, thus, be matched 1646 | ; against it; and, finally, (3) the filler of a pair can be a CD, 1647 | ; and most fillers which are lists are CDs, however, fillers which 1648 | ; are "modes" are the exception; they are fillers which are lists, 1649 | ; but are not CDs, so a special exception has to be made for them 1650 | ; in the unification procedure below. 1651 | (defun unify-pairs (pairs1 pairs2 sub) 1652 | (if (or (null pairs1) (null pairs2)) 1653 | (list sub) 1654 | (let* ((role 1655 | (role-pair (car pairs1))) 1656 | (pair-from-pairs2 1657 | (assoc role pairs2)) 1658 | (rest-of-pairs-from-pairs2 1659 | (remove-if #'(lambda (pair) 1660 | (equal (role-pair pair) role)) 1661 | pairs2)) 1662 | (newsubs 1663 | (cond ((eq role 'mode) 1664 | (unify-1 (car pairs1) pair-from-pairs2 sub)) 1665 | ((and pair-from-pairs2 1666 | (or (pcvar-p (cadr pair-from-pairs2)) 1667 | (atom (cadr pair-from-pairs2)))) 1668 | (unify-1 (car pairs1) pair-from-pairs2 sub)) 1669 | ((and pair-from-pairs2 1670 | (or (pcvar-p (cadr (car pairs1))) 1671 | (atom (cadr (car pairs1))))) 1672 | (unify-1 (car pairs1) pair-from-pairs2 sub)) 1673 | (pair-from-pairs2 1674 | (unify-cds-1 (car pairs1) pair-from-pairs2 sub)) 1675 | (t 1676 | (list sub))))) 1677 | (mapcan #'(lambda (newsub) 1678 | (unify-pairs (cdr pairs1) 1679 | rest-of-pairs-from-pairs2 1680 | newsub)) 1681 | newsubs)))) 1682 | 1683 | ; Done loading 1684 | (format t "~%Done loading Micro-Talespin") 1685 | 1686 | 1687 | -------------------------------------------------------------------------------- /pbi-code.lisp: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; pbi-code.cl 3 | ;;; 4 | ;;; contains all the function and macro definitions from Principles of 5 | ;;; Biomedical Informatics by Ira J. Kalet. This code is available for 6 | ;;; use without restrictions. I only ask that you cite the book in any 7 | ;;; written documents that report on the use of the code or actually 8 | ;;; include the code. 9 | ;;; 10 | ;;;----------------------------------------------------- 11 | 12 | ;;; only the function and macro definitions are here, not the example 13 | ;;; dialogs with the Lisp read-eval-print loop. They are in order by chapter. 14 | 15 | ;;;----------------------------------------------------- 16 | ;;; Chapter 1 17 | ;;;----------------------------------------------------- 18 | 19 | (defun hypotenuse (x y) 20 | "returns the hypotenuse of the triangle 21 | whose sides are x and y" 22 | (sqrt (+ (* x x) (* y y)))) 23 | 24 | (defun factorial (n) 25 | (if (= n 0) 1 26 | (* n (factorial (- n 1))))) 27 | 28 | (defun all-pos (item seq start) 29 | (let ((pos (position item seq :start start))) 30 | (if pos 31 | (cons pos 32 | (all-pos item seq (+ 1 pos))) 33 | nil))) 34 | 35 | ;;;----------------------------------------------------- 36 | ;;; there are three versions of all-positions. Here I name them 37 | ;;;differently so the load function does not complain 38 | ;;;----------------------------------------------------- 39 | 40 | (defun all-positions-1 (item seq) 41 | (all-pos item seq 0)) 42 | 43 | (defun all-positions-2 (item seq) 44 | (labels 45 | ((all-pos-aux (item seq start) 46 | (let ((pos (position item seq :start start))) 47 | (if pos (cons pos 48 | (all-pos-aux item seq (+ 1 pos))) 49 | nil)))) 50 | (all-pos-aux item seq 0))) 51 | 52 | (defun all-positions-3 (item seq) 53 | (labels 54 | ((all-pos-aux (item seq start accum) 55 | (let ((pos (position item seq :start start))) 56 | (if pos 57 | (all-pos-aux item seq (+ 1 pos) 58 | (cons pos accum)) 59 | (reverse accum))))) 60 | (all-pos-aux item seq 0 nil))) 61 | 62 | ;;;----------------------------------------------------- 63 | 64 | (defun count-g (dna) 65 | (if (null dna) 0 66 | (if (eql (first dna) 'g) 67 | (+ 1 (count-g (rest dna))) 68 | (count-g (rest dna))))) 69 | 70 | (defun dna-count-simple (seq) 71 | "does an explicit count of the G A C and T in seq" 72 | (let ((ng 0) 73 | (na 0) 74 | (nc 0) 75 | (nt 0)) 76 | (dolist (base seq) 77 | (case base 78 | (g (incf ng)) 79 | (a (incf na)) 80 | (c (incf nc)) 81 | (t (incf nt)))) 82 | (list ng na nc nt))) 83 | 84 | (defun gc-ratio-broken (freq-table) 85 | (/ (+ (first freq-table) (third freq-table)) 86 | (+ freq-table))) 87 | 88 | (defun gc-ratio (freq-table) 89 | (/ (+ (first freq-table) (third freq-table)) 90 | (apply #'+ freq-table))) 91 | 92 | (defun gc-ratio-from-file (filename) 93 | (gc-ratio (dna-count-simple (get-data filename)))) 94 | 95 | (defun item-count (seq) 96 | "returns a frequency table of all the items in seq, a list 97 | of items, tagging the count by the item itself" 98 | (let ((results nil)) 99 | (dolist (item seq results) 100 | (let ((tmp (find item results :key #'first))) 101 | (if tmp (incf (second tmp)) 102 | (push (list item 1) results)))))) 103 | 104 | (defun naive-read-from-file (strm) 105 | (let ((char (read-char strm nil :eof))) 106 | (if (eql char :eof) nil 107 | (cons (intern (string char)) 108 | (naive-read-from-file strm))))) 109 | 110 | (defun read-from-file (strm accum) 111 | (let ((char (read-char strm nil :eof))) 112 | (if (eql char :eof) (reverse accum) 113 | (read-from-file strm (cons (intern (string char)) 114 | accum))))) 115 | 116 | (defun get-data (filename) 117 | (with-open-file (strm filename) 118 | (read-from-file strm nil))) 119 | 120 | (defun read-from-file (strm accum) 121 | (let ((char (read-char strm nil :eof))) 122 | (cond ((eql char :eof) (reverse accum)) 123 | ((member char (list #\g #\c #\a #\t #\G #\C #\A #\T)) 124 | (read-from-file strm 125 | (cons (intern (string-upcase 126 | (string char))) 127 | accum))) 128 | (t (read-from-file strm accum))))) 129 | 130 | (defun parse-line (line) 131 | "parses tab delimited text, assumes no other whitespace between 132 | objects" 133 | (labels ((read-items (str accum pos tab) 134 | (if (>= pos (length str)) 135 | (reverse (if tab (cons "" accum) accum)) 136 | (let ((first (char str pos))) 137 | (if (eql first #\Tab) 138 | (read-item str 139 | (if tab (cons "" accum) accum) 140 | (1+ pos) t) 141 | (multiple-value-bind (item next) 142 | (read-from-string str nil :eof :start pos 143 | :preserve-whitespace t) 144 | (if (eql item :eof) 145 | (reverse (if tab (cons "" accum) accum)) 146 | (read-items str (cons item accum) 147 | next nil)))))))) 148 | (read-items line nil 0 t))) 149 | 150 | (defun parse-loinc (filename) 151 | (let ((n 0)) 152 | (labels ((read-loinc-records (strm accum) 153 | (let ((line (read-line strm nil :eof))) 154 | (format t "Reading record ~A~%" (incf n)) 155 | (if (eql line :eof) (reverse accum) 156 | (read-loinc-records strm 157 | (cons (parse-line line) 158 | accum)))))) 159 | (with-open-file (strm filename) 160 | (list (parse-line (read-line strm)) 161 | (read-loinc-records strm nil)))))) 162 | 163 | (defun print-loinc-record (headers record) 164 | (mapcar #'(lambda (hdr item) 165 | (format nil "~A = ~A" hdr item)) 166 | headers record)) 167 | 168 | (defun make-sagittal-image (image-list) 169 | (let ((new-img (make-array '(512 512))) 170 | (image-num 0)) 171 | (dolist (image image-list) 172 | (dotimes (i 512) 173 | (setf (aref new-img i image-num) 174 | (aref image i 256))) 175 | (incf image-num)) 176 | new-img)) 177 | 178 | (defun make-graymap (window level range-top) 179 | (let* ((map (make-array (1+ range-top))) 180 | (low-end (- level (truncate (/ window 2)))) 181 | (high-end (+ low-end window))) 182 | (do ((i 0 (1+ i))) 183 | ((= i low-end)) 184 | (setf (aref map i) 0)) ;; black 185 | (do ((i low-end (1+ i))) 186 | ((= i high-end)) 187 | (setf (aref map i) 188 | (round (/ (* 255 (- i low-end)) window)))) 189 | (do ((i high-end (1+ i))) 190 | ((> i range-top)) 191 | (setf (aref map i) 255)) 192 | map)) 193 | 194 | (defun map-image (raw-image window level range) 195 | (let* ((x-dim (array-dimension raw-image 1)) 196 | (y-dim (array-dimension raw-image 0)) 197 | (new-image (make-array (list y-dim x-dim))) 198 | (map (make-graymap window level range))) 199 | (dotimes (i y-dim) 200 | (dotimes (j x-dim) 201 | (setf (aref new-image i j) 202 | (aref map (aref raw-image i j))))) 203 | new-image)) 204 | 205 | (defun diagnosis (patient-data) 206 | (find 'diagnosis (rest patient-data) :key #'first)) 207 | 208 | (defstruct person () 209 | name birthdate telephone email) 210 | 211 | (defstruct (patient (:include person)) 212 | diagnosis appointments) 213 | 214 | (defstruct (provider (:include person)) 215 | specialty title office patients) 216 | 217 | (defvar *patients*) 218 | 219 | (defvar *providers*) 220 | 221 | (defun add-provider (name specialty title) 222 | (push (make-provider :name name 223 | :specialty specialty 224 | :title title) 225 | *providers*)) 226 | 227 | (defun lookup-specialty (name) 228 | (provider-specialty (find name *providers* 229 | :key #'person-name 230 | :test #'string-equal))) 231 | 232 | (defun update-patient-phone (name phone) 233 | (let ((record (find name *patients* 234 | :key #'person-name 235 | :test #'string-equal))) 236 | (setf (person-telephone record) phone))) 237 | 238 | (defstruct heart () 239 | size beat-rate x y z) 240 | 241 | (defstruct kidney () 242 | side x y z) 243 | 244 | (defstruct tumor () 245 | size grade tissue-type x y z) 246 | 247 | (defmethod draw ((obj t) (v t)) 248 | "DRAW (obj t) (v t) 249 | This is a default or stub method so we can build and use the various 250 | functions without crashing on not yet implemented draw calls." 251 | (format t "No DRAW method for class ~A in ~A~%" 252 | (class-name (class-of obj)) 253 | (class-name (class-of v)))) 254 | 255 | (defclass heart () 256 | ((size :accessor size) 257 | (beat-rate :accessor beat-rate) 258 | (x :accessor x) 259 | (y :accessor y) 260 | (z :accessor z) 261 | )) 262 | 263 | (defclass kidney () 264 | ((side :accessor side) 265 | (x :accessor x) 266 | (y :accessor y) 267 | (z :accessor z) 268 | )) 269 | 270 | (defclass tumor () 271 | ((size :accessor size) 272 | (grade :accessor grade) 273 | (tissue-type :accessor tissue-type) 274 | (x :accessor x) 275 | (y :accessor y) 276 | (z :accessor z) 277 | )) 278 | 279 | (defclass patient () 280 | ((name :accessor name :initarg :name) 281 | (hospital-id :accessor hospital-id :initarg :hospital-id) 282 | (age :accessor age :initarg :age) 283 | (address :accessor address :initarg :address) 284 | (diagnosis :accessor diagnosis :initarg :diagnosis) 285 | (lab-tests :accessor lab-tests :initarg :lab-tests) 286 | )) 287 | 288 | (defclass address () 289 | ((number :accessor number :initarg :number) 290 | (street :accessor street :initarg :street) 291 | (city :accessor city :initarg :city) 292 | (zip-code :accessor zip-code :initarg :zip-code))) 293 | 294 | (defclass diagnosis () 295 | ((name :accessor name :initarg :name) 296 | (evidence :accessor evidence :initarg :evidence) 297 | )) 298 | 299 | (defmethod print-object ((obj patient) strm) 300 | (format strm "(Patient ~%") 301 | (format strm " :name ~S~%" (name obj)) 302 | (format strm " :hospital-id ~S~%" (hospital-id obj)) 303 | (format strm " ...etc. ) ~%")) 304 | 305 | (defun read-object (stream) 306 | (apply #'make-instance (read stream))) 307 | 308 | (defun read-object (stream) 309 | (eval (read stream))) 310 | 311 | (defun slot-names (obj) 312 | (mapcar #'slot-definition-name 313 | (class-slots (class-of obj)))) 314 | 315 | (defun get-object-basic (in-stream) 316 | (let* ((current-key (read in-stream)) 317 | (object (make-instance current-key))) 318 | (loop 319 | (setq current-key (read in-stream)) 320 | (if (eq current-key :end) ;; no more slots? 321 | (return object) 322 | (setf (slot-value object current-key) 323 | (read in-stream)))))) 324 | 325 | (defun put-object-basic (object out-stream &optional (tab 0)) 326 | (tab-print (class-name (class-of object)) out-stream tab t) 327 | (dolist (slotname (slot-names object)) 328 | (when (slot-boundp object slotname) 329 | (tab-print slotname out-stream (+ 2 tab)) 330 | (tab-print (slot-value object slotname) 331 | out-stream 0 t))) 332 | (tab-print :end out-stream tab t)) 333 | 334 | (defun tab-print (item stream tab &optional (new-line nil)) 335 | (format stream "~A~S " 336 | (make-string tab :initial-element #\space) 337 | item) 338 | (when new-line (format stream "~%"))) 339 | 340 | (defun get-object (in-stream) 341 | (let* ((current-key (read in-stream)) 342 | (object (if (eq current-key :end) 343 | nil ;; end of object list 344 | (make-instance current-key)))) 345 | (loop 346 | (setq current-key (read in-stream)) 347 | (if (eq current-key :end) ;; no more slots? 348 | (return object) 349 | (setf (slot-value object current-key) 350 | (case (slot-type object current-key) 351 | (:simple (read in-stream)) 352 | (:object (get-object in-stream)) 353 | (:object-list 354 | (let ((slotlist '()) 355 | (next-object nil)) 356 | (loop 357 | (setq next-object 358 | (get-object in-stream :parent object)) 359 | (if next-object 360 | (push next-object slotlist) 361 | (return (nreverse slotlist)))))))))))) 362 | 363 | (defun put-object (object out-stream &optional (tab 0)) 364 | (tab-print (class-name (class-of object)) out-stream tab t) 365 | (dolist (slotname (slot-names object)) 366 | (when (slot-boundp object slotname) 367 | (tab-print slotname out-stream (+ 2 tab)) 368 | (case (slot-type object slotname) 369 | (:simple 370 | (tab-print (slot-value object slotname) 371 | out-stream 0 t)) 372 | (:object 373 | (fresh-line out-stream) 374 | (put-object (slot-value object slotname) 375 | out-stream (+ 4 tab))) 376 | (:object-list 377 | (fresh-line out-stream) 378 | (dolist (obj (slot-value object slotname)) 379 | (put-object obj out-stream (+ 4 tab))) 380 | (tab-print :end out-stream (+ 2 tab) t))))) 381 | (tab-print :end out-stream tab t)) 382 | 383 | (defmethod slot-type ((object t) slotname) 384 | :simple) 385 | 386 | (defmethod slot-type ((object patient) slotname) 387 | (case slotname 388 | ((address diagnosis) :object) 389 | (otherwise :simple))) 390 | 391 | (defmethod slot-type ((object patient) slotname) 392 | (case slotname 393 | ((address diagnosis) :object) 394 | (otherwise (call-next-method)))) 395 | 396 | (defun get-all-objects (filename) 397 | (with-open-file (stream filename 398 | :direction :input 399 | :if-does-not-exist nil) 400 | (when (streamp stream) 401 | (let ((object-list '())) 402 | (loop 403 | (cond ((eq (peek-char t stream nil :eof) :eof) 404 | (return object-list)) 405 | (t (push (get-object stream) object-list)))))))) 406 | 407 | (defun put-all-objects (object-list filename) 408 | (with-open-file (stream filename 409 | :direction :output 410 | :if-exists :new-version) 411 | (dolist (obj object-list) 412 | (put-object obj stream)))) 413 | 414 | (defclass image () 415 | ((uid :type string :accessor uid :initarg :uid) 416 | (patient-id :accessor patient-id :initarg :patient-id 417 | :documentation "The patient id of the 418 | patient this image belongs to.") 419 | (image-set-id :accessor image-set-id :initarg :image-set-id 420 | :documentation "The image set id of the 421 | primary image set the image belongs to.") 422 | (position :type string 423 | :accessor position :initarg :position 424 | :documentation "String, one of HFP, HFS, 425 | FFP, FFS, etc. describing patient position as 426 | scanned (Head/Feet-First Prone/Supine, etc).") 427 | (description :type string 428 | :accessor description :initarg :description) 429 | (origin :type (vector single-float 3) 430 | :accessor origin :initarg :origin 431 | :documentation "Origin refers to the location in 432 | patient space of the corner of the image as defined 433 | by the point at pixel array reference 0 0 or voxel 434 | array reference 0 0 0.") 435 | (size :type list ;; of two or three elements, x y z 436 | :accessor size :initarg :size 437 | :documentation "The size slot refers to the physical 438 | size of the image in each dimension, measured in 439 | centimeters in patient space.") 440 | ;; ...other slots 441 | ) 442 | (:default-initargs :id 0 :uid "" :patient-id 0 443 | :image-set-id 0 :position "HFS" 444 | :description "") 445 | (:documentation "The basic information common to all types of 446 | images, including 2-D images, 3-D images.")) 447 | 448 | (defclass image-2d (image) 449 | ((thickness :type single-float 450 | :accessor thickness :initarg :thickness) 451 | (x-orient :type (vector single-float 3) 452 | :accessor x-orient :initarg :x-orient 453 | :documentation "A vector in patient space defining 454 | the orientation of the X axis of the image in the 455 | patient coordinate system.") 456 | (y-orient :type (vector single-float 3) 457 | :accessor y-orient :initarg :y-orient 458 | :documentation "See x-orient.") 459 | (pix-per-cm :type single-float 460 | :accessor pix-per-cm :initarg :pix-per-cm) 461 | (pixels :type (simple-array (unsigned-byte 16) 2) 462 | :accessor pixels :initarg :pixels 463 | :documentation "The array of image data itself."))) 464 | 465 | (defclass image-3d (image) 466 | ((voxels :type (simple-array (unsigned-byte 16) 3) 467 | :accessor voxels 468 | :initarg :voxels 469 | :documentation "a 3-D array of image data values")) 470 | (:documentation "An image-3D depicts some 3-D rectangular 471 | solid region of a patient's anatomy.")) 472 | 473 | (defun read-bin-array (filename size) 474 | (let ((bin-array (make-array (list size) 475 | :element-type '(unsigned-byte 16)))) 476 | (with-open-file (infile filename :direction :input 477 | :element-type 478 | '(unsigned-byte 16)) 479 | (read-sequence bin-array infile)) 480 | bin-array)) 481 | 482 | (defun read-bin-array (filename bin-array) 483 | (with-open-file (infile filename :direction :input 484 | :element-type 485 | '(unsigned-byte 16)) 486 | (read-sequence bin-array infile))) 487 | 488 | (defun read-bin-array (filename dimensions) 489 | (let* ((bin-array (make-array dimensions 490 | :element-type '(unsigned-byte 16))) 491 | (disp-array (make-array (array-total-size bin-array) 492 | :element-type '(unsigned-byte 16) 493 | :displaced-to bin-array))) 494 | (with-open-file (infile filename :direction :input 495 | :element-type '(unsigned-byte 16)) 496 | (read-sequence disp-array infile)) 497 | bin-array)) 498 | 499 | (defun read-bin-array (filename bin-array) 500 | (let ((disp-array (make-array (array-total-size bin-array) 501 | :element-type '(unsigned-byte 16) 502 | :displaced-to bin-array))) 503 | (with-open-file (infile filename :direction :input 504 | :element-type '(unsigned-byte 16)) 505 | (read-sequence disp-array infile)))) 506 | 507 | (defun get-object (in-stream) 508 | (let* ((current-key (read in-stream)) 509 | (object (if (eq current-key :end) 510 | nil ;; end of object list 511 | (make-instance current-key)))) 512 | (loop 513 | (setq current-key (read in-stream)) 514 | (if (eq current-key :end) ;; no more slots? 515 | (return object) 516 | (setf (slot-value object current-key) 517 | (case (slot-type object current-key) 518 | (:simple (read in-stream)) 519 | (:object (get-object in-stream)) 520 | (:object-list 521 | (let ((slotlist '()) 522 | (next-object nil)) 523 | (loop 524 | (let ((obj (get-object in-stream 525 | :parent object))) 526 | (if obj (push obj slotlist) 527 | (return (nreverse slotlist))))))) 528 | (:bin-array 529 | (let ((bin-info (read in-stream))) 530 | (read-bin-array (first bin-info) 531 | (rest bin-info)))) 532 | )))))) 533 | 534 | (defun put-object-xml (object out-stream &optional (tab 0)) 535 | (let ((tag (class-name (class-of object)))) 536 | (print-xml-tag tag out-stream tab) 537 | (mapc #'(lambda (slotname) 538 | (when (slot-boundp object slotname) 539 | (print-xml-tag slotname out-stream (+ 2 tab)) 540 | (case (slot-type object slotname) 541 | (:simple (tab-print (slot-value object slotname) 542 | out-stream 0 t)) 543 | (:object (fresh-line out-stream) 544 | (put-object-xml 545 | (slot-value object slotname) 546 | out-stream (+ 4 tab))) 547 | (:object-list 548 | (fresh-line out-stream) 549 | (mapc #'(lambda (obj) 550 | (put-object-xml obj out-stream 551 | (+ 4 tab))) 552 | (slot-value object slotname)))) 553 | ;; closing tag for each slot regardless of content 554 | (print-xml-end-tag slotname out-stream (+ 2 tab)) 555 | )) 556 | (set-difference (slot-names object) (not-saved object))) 557 | (print-xml-end-tag tag out-stream tab))) ; terminates object 558 | 559 | (defun print-xml-tag (tag stream tab) 560 | (format stream "~a<~a>~%" 561 | (make-string tab :initial-element #\space) 562 | tag)) 563 | 564 | (defun print-xml-end-tag (tag stream tab) 565 | (format stream "~a~%" 566 | (make-string tab :initial-element #\space) 567 | tag)) 568 | 569 | (defun make-xml-tag (tag stream tab &optional close) 570 | (format stream (if close "~a~%" 571 | "~a<~a>~%") 572 | (make-string tab :initial-element #\space) 573 | tag)) 574 | 575 | (defun put-objects-xml (object-list filename) 576 | (with-open-file (stream filename 577 | :direction :output 578 | :if-exists :new-version) 579 | (dolist (obj object-list) 580 | (put-object-xml obj stream)))) 581 | 582 | (defmethod print-dom-node ((node dom1-text)) 583 | (format t "Value: ~A~%" (dom-node-value node))) 584 | 585 | (defmethod print-dom-node ((node dom1-element)) 586 | (let ((name (dom-node-name node))) 587 | (format t "Element name: ~A~%" name) 588 | (mapcar #'print-dom-node 589 | (dom-child-node-list node)) 590 | (format t "End of ~A~%" name))) 591 | 592 | (defmethod print-dom-node ((node dom1-document)) 593 | (format t "DOCUMENT ") 594 | (print-dom-node (dom-document-element node))) 595 | 596 | ;;;----------------------------------------------------- 597 | ;;; Chapter 2 598 | ;;;----------------------------------------------------- 599 | 600 | (defvar *rules* (make-hash-table) "The so-called knowledge base") 601 | 602 | (defun <-fn (consequent &optional antecedent) 603 | (push antecedent (gethash consequent *rules*))) 604 | 605 | (defmacro <- (consequent &optional antecedent) 606 | (list 'push antecedent (list 'gethash consequent '*rules*))) 607 | 608 | (defmacro <- (consequent &optional antecedent) 609 | (list 'push (list 'quote antecedent) 610 | (list 'gethash (list 'quote consequent) '*rules*))) 611 | 612 | (defmacro <- (consequent &optional antecedent) 613 | `(push ',antecedent (gethash ',consequent *rules*))) 614 | 615 | (defmacro <- (consequent &optional antecedent) 616 | "adds antecedent to the hash table entry for consequent, even if 617 | antecedent is nil" 618 | `(length (push ',antecedent (gethash ',consequent *rules*)))) 619 | 620 | (defun prove-simple (pred) 621 | "checks if an entry is present, and succeeds if there is a nil for 622 | simple assertion, or an expression that itself can be proved" 623 | (multiple-value-bind (ants found) (gethash pred *rules*) 624 | (cond ((not found) nil) 625 | ((member nil ants) t) ;; find won't work here! 626 | (t (some #'prove ants))))) 627 | 628 | (defun prove (expr) 629 | (if (listp expr) 630 | (case (first expr) 631 | (and (every #'prove (reverse (rest expr)))) 632 | (or (some #'prove (rest expr))) 633 | (not (not (prove (second expr))))) 634 | (prove-simple expr))) 635 | 636 | (defun printhash (hashtable) 637 | "prints out the contents of hashtable" 638 | (maphash #'(lambda (key val) 639 | (format t "Key: ~S Value: ~S~%" key val)) 640 | hashtable)) 641 | 642 | (defvar *clauses* nil 643 | "The cumulative list of clauses, aka knowledge base.") 644 | 645 | (defstruct clause 646 | ants con count) 647 | 648 | (defmacro -> (antecedents consequent) 649 | `(let* ((ants ',antecedents) ;; to avoid multiple eval 650 | (con ',consequent) 651 | (clause (make-clause :ants ants 652 | :con con 653 | :count (length ants)))) 654 | (dolist (pred ants) 655 | (push clause (get pred 'on-clauses))) 656 | (push clause *clauses*) 657 | clause)) 658 | 659 | (defun init-stack (clauses) 660 | (let (stack) 661 | (dolist (clause clauses) 662 | (if (zerop (clause-count clause)) 663 | (push (clause-con clause) stack))) 664 | stack)) 665 | 666 | (defun forward-chain (clauses) 667 | (labels ((fc-aux (stack results) 668 | (if (null stack) results 669 | (let ((prop (first stack)) 670 | (newprops nil)) 671 | (format t "Current prop: ~A~%" prop) 672 | (dolist (clause (get prop 'on-clauses)) 673 | (format t "Clause: ~S~%" clause) 674 | (if (zerop (decf (clause-count clause))) 675 | (let ((concl (clause-con clause))) 676 | (format t "Concl: ~A~%" concl) 677 | (if (null concl) (return-from fc-aux 'fail) 678 | (unless (find concl results) 679 | (push concl newprops)))))) 680 | (fc-aux (append newprops (rest stack)) 681 | (cons prop results)))))) 682 | (fc-aux (init-stack clauses) nil))) 683 | 684 | (defmacro <- (con &optional ant) 685 | "adds ant to the hash table entry for con, even if ant is nil" 686 | `(length (push (cons (rest ',con) ',ant) 687 | (gethash (first ',con) *rules*)))) 688 | 689 | (defun prove (expr &optional binds) 690 | (case (first expr) 691 | (and (prove-and (reverse (rest expr)) binds)) 692 | (or (prove-or (rest expr) binds)) 693 | (not (prove-not (first (rest expr)) binds)) 694 | (t (prove-simple (first expr) (rest expr) binds)))) 695 | 696 | (defun prove-simple (pred args binds) 697 | (mapcan #'(lambda (r) 698 | (multiple-value-bind (b2 yes) 699 | (match args (first r) binds) 700 | (when yes 701 | (if (rest r) (prove (rest r) b2) 702 | (list b2))))) 703 | (mapcar #'change-vars 704 | (gethash pred *rules*)))) 705 | 706 | (defun change-vars (r) 707 | (sublis (mapcar #'(lambda (v) (cons v (gensym "?"))) 708 | (vars-in r)) 709 | r)) 710 | 711 | (defun var? (x) 712 | (and (symbolp x) 713 | (eql (char (symbol-name x) 0) #\?))) 714 | 715 | (defun vars-in (expr) 716 | (if (atom expr) 717 | (if (var? expr) (list expr)) 718 | (union (vars-in (first expr)) 719 | (vars-in (rest expr))))) 720 | 721 | (defun match (x y &optional binds) 722 | (cond 723 | ((eql x y) (values binds t)) 724 | ((assoc x binds) (match (binding x binds) y binds)) 725 | ((assoc y binds) (match x (binding y binds) binds)) 726 | ((var? x) (values (cons (cons x y) binds) t)) 727 | ((var? y) (values (cons (cons y x) binds) t)) 728 | (t 729 | (when (and (consp x) (consp y)) 730 | (multiple-value-bind (b2 yes) 731 | (match (first x) (first y) binds) 732 | (and yes (match (rest x) (rest y) b2))))))) 733 | 734 | (defun binding (x binds) 735 | (let ((b (assoc x binds))) 736 | (if b 737 | (or (binding (rest b) binds) 738 | (rest b))))) 739 | 740 | (defun prove-and (clauses binds) 741 | (if (null clauses) 742 | (list binds) 743 | (mapcan #'(lambda (b) 744 | (prove (first clauses) b)) 745 | (prove-and (rest clauses) binds)))) 746 | 747 | (defun prove-or (clauses binds) 748 | (mapcan #'(lambda (c) (prove c binds)) 749 | clauses)) 750 | 751 | (defun prove-not (clause binds) 752 | (unless (prove clause binds) 753 | (list binds))) 754 | 755 | (defmacro with-answer (query &body body) 756 | (let ((binds (gensym))) 757 | `(dolist (,binds (prove ',query)) 758 | (let ,(mapcar #'(lambda (v) 759 | `(,v (binding ',v ,binds))) 760 | (vars-in query)) 761 | ,@body)))) 762 | 763 | (defclass frame () 764 | ((id :reader id 765 | :initform (gentemp "frame-")) 766 | (name :accessor name 767 | :initarg :name 768 | :initform nil) 769 | (instance-of :accessor instance-of 770 | :initarg :instance-of 771 | :initform nil) 772 | (superclasses :accessor superclasses 773 | :initarg :superclasses 774 | :initform nil) 775 | (template-slots :accessor template-slots 776 | :initarg :template-slots 777 | :initform nil) 778 | (own-slots :accessor own-slots 779 | :initarg :own-slots 780 | :initform nil) 781 | (instances :accessor instances 782 | :initform nil) 783 | )) 784 | 785 | (defvar *frames* nil "The global list of all frames") 786 | 787 | (defun find-frame-by-id (frm-id) 788 | (find frm-id *frames* :key #'id)) 789 | 790 | (defun find-frame-by-name (frm-name) 791 | (find frm-name *frames* :key #'name :test #'equal)) 792 | 793 | (defun add-frame (frm) 794 | (push fr *frames*)) 795 | 796 | (defun remove-frame (frm) 797 | (setf *frames* (remove frm *frames*))) 798 | 799 | (defun save-frame-kb (filename) 800 | (put-all-objects *frames* filename)) 801 | 802 | (defun restore-frame-kb (filename) 803 | (setq *frames* (get-all-objects filename))) 804 | 805 | (defun slot-name (slot) (first slot)) 806 | 807 | (defun contents (slot) (second slot)) 808 | 809 | (defun (setf contents) (newval slot) 810 | (setf (second slot) newval)) 811 | 812 | (defun get-slot (fr name) 813 | (find name (own-slots fr) :key #'slot-name)) 814 | 815 | (defun slot-list (fr) 816 | (mapcar #'slot-name (own-slots fr))) 817 | 818 | (defun slot-data (fr slot-name) 819 | (contents (get-slot fr slot-name))) 820 | 821 | (defun (setf slot-data) (newval fr slot-name) 822 | (setf (contents (get-slot fr slot-name)) 823 | newval)) 824 | 825 | (defun frame-type (fr) 826 | (let ((parent (instance-of fr))) 827 | (if parent (name (find-frame-by-id parent))))) 828 | 829 | (defun all-superclasses (fr) 830 | "returns the frame-ids of all the frames that are superclasses of 831 | frame fr all the way up the class hierarchy" 832 | (let ((direct-sup-ids (superclasses fr))) 833 | (apply #'append 834 | direct-sup-ids 835 | (mapcar #'(lambda (frm-id) 836 | (all-superclasses 837 | (find-frame-by-id frm-id))) 838 | direct-sup-ids)))) 839 | 840 | (defun all-template-slots (fr) 841 | (remove-duplicates 842 | (apply #'append 843 | (template-slots fr) 844 | (mapcar #'(lambda (id) 845 | (template-slots (find-frame-by-id id))) 846 | (all-superclasses fr))))) 847 | 848 | (defun make-pairs (x) 849 | (if (oddp (length x)) (error "list length not even") 850 | (if x (cons (list (first x) (second x)) 851 | (make-pairs (rest (rest x))))))) 852 | 853 | (defun initialize-slot (slotname inits) 854 | (or (assoc slotname inits) 855 | (list slotname nil))) 856 | 857 | (defun make-frame (name &key class superclasses template-slots 858 | &rest slot-inits) 859 | (let* ((parent (if class (find-frame-by-name class))) 860 | (super-ids (mapcar #'(lambda (x) 861 | (id (find-frame-by-name x))) 862 | superclasses)) 863 | (fr (make-instance 'frame 864 | :name name 865 | :instance-of (if parent (id parent)) 866 | :superclasses super-ids 867 | :template-slots template-slots 868 | :own-slots 869 | (if parent 870 | (mapcar #'(lambda (name) 871 | (initialize-slot name 872 | (make-pairs slot-inits))) 873 | (all-template-slots parent))) 874 | ))) 875 | (if parent (push fr (instances parent))) 876 | (add-frame fr) 877 | fr)) 878 | 879 | (defun disease-lookup (drug-inst) 880 | (let ((drug-type (find-frame-by-id (slot-data drug-inst 881 | 'instance-of)))) 882 | (append (slot-data drug-inst 'diseases) 883 | (slot-data drug-type 'diseases) 884 | (mapcar #'(lambda (x) (slot-data 885 | (find-frame-by-id x) 886 | 'diseases)) 887 | (all-superclasses drug-type))))) 888 | 889 | (defun subsumed-by (fr1 fr2) 890 | (let ((id-list (superclasses fr1))) 891 | (cond ((null id-list) nil) 892 | ((find (frame-id fr2) id-list) t) 893 | (some #'(lambda (x) 894 | (subsumed-by (find-frame-by-id x) fr2)) 895 | id-list)))) 896 | 897 | (defun part-of (fr) 898 | (slot-data fr 'part-of)) 899 | 900 | (defun is-part-of (fr1 fr2) 901 | (let ((id-list (part-of fr1))) 902 | (cond ((null id-list) nil) 903 | ((find (frame-id fr2) id-list) t) 904 | (some #'(lambda (x) 905 | (is-part-of (find-frame-by-id x) fr2)) 906 | id-list)))) 907 | 908 | (defun connected-upward (fr1 fr2 link-fn) 909 | (let ((id-list (funcall link-fn fr1))) 910 | (cond ((null id-list) nil) 911 | ((find (frame-id fr2) id-list) t) 912 | ((some #'(lambda (x) 913 | (connected-upward 914 | (find-frame-by-id x) fr2 link-fn)) 915 | id-list))))) 916 | 917 | (defun get-all-children (fr frame-kb) 918 | "searches the entire frame knowledge base to collect all the 919 | subclass-of descendants of frame fr." 920 | (let ((children nil)) 921 | (dolist (entry frame-kb children) 922 | (if (subsumed-by entry fr) 923 | (push entry children))))) 924 | 925 | (defun get-all-parts (fr frame-kb) 926 | "searches for items in the part-of subtree" 927 | (let ((parts nil)) 928 | (dolist (entry frame-kb parts) 929 | (if (is-part-of entry fr) 930 | (push entry parts))))) 931 | 932 | (defun slot-data (fr slot) 933 | "returns the contents of slot slot-name in frame fr, after 934 | executing any :if-needed function that might be present" 935 | (let* ((the-slot (get-slot fr slot)) 936 | (if-needed-fn (second (member :if-needed the-slot)))) 937 | (if if-needed-fn (funcall if-needed-fn fr slot)) 938 | (second (get-slot fr slot)))) 939 | 940 | (defun (setf slot-data) (newval fr slot) 941 | "updates the contents of slot slot-name in frame fr, after 942 | executing any :if-added function that might be present" 943 | (let* ((the-slot (get-slot fr slot)) 944 | (if-added-fn (second (member :if-added the-slot)))) 945 | (if if-added-fn (funcall if-added-fn fr slot newval)) 946 | (setf (second (get-slot fr slot)) newval))) 947 | 948 | (defun set-attached-fn (fr slot fn key) 949 | "puts function fn in the slot named slot in frame fr, using key as 950 | a tag, e.g., :if-needed or :if-added or possibly other types of 951 | attached functions" 952 | (let* ((the-slot (get-slot fr slot)) 953 | (length (length the-slot)) 954 | (location (position key the-slot))) 955 | (if location (setf (elt the-slot (+ location 1)) fn) 956 | (setf (rest (last the-slot)) (list key fn))))) 957 | 958 | (defun remove-attached-fn (fr slot key) 959 | "replaces any attached function for key to nil" 960 | (set-attached-fn fr slot nil key)) 961 | 962 | (defun simple-search (initial-state goal) 963 | (labels 964 | ((search-inner (queue) 965 | (if (null queue) 'fail 966 | (let ((current (first queue))) 967 | (if (eql current goal) 968 | 'success 969 | (search-inner (append (successors current) 970 | (rest queue)))))))) 971 | (search-inner (list initial-state)))) 972 | 973 | (defun better-search (initial-state goal? successors) 974 | (labels 975 | ((search-inner (queue) 976 | (if (null queue) 'fail 977 | (let ((current (first queue))) 978 | (if (funcall goal? current) 'success 979 | (search-inner (append (funcall successors 980 | current) 981 | (rest queue)))))))) 982 | (search-inner (list initial-state)))) 983 | 984 | (defun multi-search (initial-state goal? enough? successors) 985 | (labels 986 | ((search-inner (queue wins) 987 | (if (null queue) wins 988 | (let ((current (first queue)) 989 | (remains (rest queue))) 990 | (cond ((funcall goal? current) 991 | (setq wins (cons current wins)) 992 | (if (or (eq enough? t) 993 | (and (null enough?) 994 | (null remains)) 995 | (and enough? 996 | (funcall enough? wins))) 997 | wins 998 | (search-inner remains wins))) 999 | (t (search-inner (append (funcall successors 1000 | current) 1001 | remains)))))))) 1002 | (search-inner (list initial-state) '()))) 1003 | 1004 | (defun gsearch (initial-state goal? enough? successors merge) 1005 | (labels 1006 | ((search-inner (queue wins) 1007 | (if (null queue) wins 1008 | (let ((current (first queue)) 1009 | (remains (rest queue))) 1010 | (cond ((funcall goal? current) 1011 | (setq wins (funcall merge (list current) 1012 | wins)) 1013 | (if (or (eq enough? t) 1014 | (and (null enough?) 1015 | (null remains)) 1016 | (and enough? 1017 | (funcall enough? wins))) 1018 | (values wins remains) 1019 | (search-inner remains wins))) 1020 | (t 1021 | (search-inner (funcall merge 1022 | (funcall successors 1023 | current) 1024 | remains) 1025 | wins))))))) 1026 | (search-inner (list initial-state) '()))) 1027 | 1028 | (defun depth-first-search (initial-state goal? enough? successors) 1029 | (gsearch initial-state goal? enough? successors #'append)) 1030 | 1031 | (defun breadth-first-search (initial-state goal? enough? successors) 1032 | (gsearch initial-state goal? enough? successors 1033 | #'(lambda (new-states queue) (append queue new-states)))) 1034 | 1035 | (defun hill-climb-search (initial-state goal? enough? 1036 | successors estim-fn) 1037 | (gsearch initial-state goal? enough? successors 1038 | #'(lambda (new-states queue) 1039 | (append (sort new-states 1040 | #'(lambda (s1 s2) 1041 | (< (funcall estim-fn s1) 1042 | (funcall estim-fn s2)))) 1043 | queue)))) 1044 | 1045 | (defun priority-merge (a b val-fn same?) 1046 | (cond ((null a) b) 1047 | ((null b) a) 1048 | ((and same? (funcall same? (first a) (first b))) 1049 | (cons (if (< (funcall val-fn (first a)) 1050 | (funcall val-fn (first b))) 1051 | (first a) 1052 | (first b)) 1053 | (priority-merge (rest a) (rest b) val-fn same?))) 1054 | ((< (funcall val-fn (first a)) 1055 | (funcall val-fn (first b))) 1056 | (cons (first a) 1057 | (priority-merge (rest a) b val-fn same?))) 1058 | (t (cons (first b) 1059 | (priority-merge a (rest b) val-fn same?))))) 1060 | 1061 | (defun best-first-search (initial-state goal? enough? 1062 | successors estim-fn same?) 1063 | (gsearch initial-state goal? enough? successors 1064 | #'(lambda (new-states queue) 1065 | (priority-merge (sort new-states 1066 | #'(lambda (s1 s2) 1067 | (< (funcall estim-fn s1) 1068 | (funcall estim-fn s2)))) 1069 | queue estim-fn same?)))) 1070 | 1071 | (defun a*-search (initial-state goal? enough? successors g h* same?) 1072 | (labels ((estim-fn (state) 1073 | (+ (funcall g state) (funcall h* state)))) 1074 | (gsearch initial-state goal? enough? successors 1075 | #'(lambda (new-states queue) 1076 | (priority-merge (sort new-states 1077 | #'(lambda (s1 s2) 1078 | (< (estim-fn s1) 1079 | (estim-fn s2)))) 1080 | queue #'estim-fn same?))))) 1081 | 1082 | (defun extend-path (path successors extender) 1083 | (mapcar #'(lambda (new) (funcall extender new path)) 1084 | (funcall successors path))) 1085 | 1086 | (defun path-search (start goal? enough? successors extender merge) 1087 | (gsearch (list start) ;; makes start into a path of length 1 1088 | goal? ;; keep goal parametrization 1089 | enough? ;; and when to stop 1090 | #'(lambda (current) 1091 | (extend-path current successors extender)) 1092 | merge)) ;; keeps parametrization of control strategy 1093 | 1094 | (defun all-paths-goal (current successors) 1095 | (null (funcall successors current))) 1096 | 1097 | ;;;----------------------------------------------------- 1098 | ;;; Chapter 3 1099 | ;;;----------------------------------------------------- 1100 | 1101 | (defun mean (m) 1102 | (let ((n (1- (array-dimension m 0)))) 1103 | (/ (do ((i 0 (1+ i)) 1104 | (stop n) 1105 | (result 0)) 1106 | ((> i stop) result) 1107 | (incf result (aref m i))) 1108 | n))) 1109 | 1110 | (defmacro sum (var start stop &rest body) 1111 | (let ((gstop (gensym)) 1112 | (gresult (gensym))) 1113 | `(do ((,var ,start (1+ ,var)) 1114 | (,gstop ,stop) 1115 | (,gresult 0)) 1116 | ((> ,var ,gstop) ,gresult) 1117 | (incf ,gresult 1118 | (progn ,@body))))) 1119 | 1120 | (defun mean (m) 1121 | (let ((n (1- (array-dimension m 0)))) 1122 | (/ (sum i 0 n (aref m i)) 1123 | n))) 1124 | 1125 | (defun variance (m mu) 1126 | (let* ((n (1- (array-dimension m 0))) 1127 | (sigma-squared 1128 | (/ (sum i 0 n (expt (- (aref m i) mu) 2)) 1129 | n))) 1130 | (values sigma-squared (sqrt sigma-squared)))) 1131 | 1132 | (defparameter *words* (make-hash-table :size 10000)) 1133 | 1134 | (defconstant maxword 100) 1135 | 1136 | (defun read-text (pathname) 1137 | (with-open-file (s pathname :direction :input) 1138 | (let ((buffer (make-string maxword)) 1139 | (pos 0)) 1140 | (do ((c (read-char s nil :eof) 1141 | (read-char s nil :eof))) 1142 | ((eql c :eof)) 1143 | (if (or (alpha-char-p c) (char= c #\')) 1144 | (progn 1145 | (setf (aref buffer pos) c) 1146 | (incf pos)) 1147 | (progn 1148 | (unless (zerop pos) 1149 | (see (intern (string-downcase 1150 | (subseq buffer 0 pos)))) 1151 | (setf pos 0)) 1152 | (let ((p (punc c))) 1153 | (if p (see p))))))))) 1154 | 1155 | (defun punc (c) 1156 | (case c 1157 | (#\. '|.|) (#\, '|,|) (#\; '|;|) 1158 | (#\! '|!|) (#\? '|?|) )) 1159 | 1160 | (let ((prev `|.|)) 1161 | (defun see (symb) 1162 | (let ((pair (assoc symb (gethash prev *words*)))) 1163 | (if (null pair) 1164 | (push (cons symb 1) (gethash prev *words*)) 1165 | (incf (cdr pair)))) 1166 | (setf prev symb))) 1167 | 1168 | (defun generate-text (n &optional (prev '|.|)) 1169 | (if (zerop n) (terpri) 1170 | (let ((next (random-next prev))) 1171 | (format t "~A " next) 1172 | (generate-text (1- n) next)))) 1173 | 1174 | (defun random-next (prev) 1175 | (let* ((choices (gethash prev *words*)) 1176 | (i (random (reduce #'+ choices :key #'cdr)))) 1177 | (dolist (pair choices) 1178 | (if (minusp (decf i (cdr pair))) 1179 | (return (car pair)))))) 1180 | 1181 | (defun entropy (probs) 1182 | (- (apply #'+ 1183 | (mapcar #'(lambda (p) 1184 | (* p (log p 2))) 1185 | probs)))) 1186 | 1187 | ;;;----------------------------------------------------- 1188 | ;;; Chapter 4 1189 | ;;;----------------------------------------------------- 1190 | 1191 | (defun boole-or-query (query doc) 1192 | (some #'(lambda (x y) (plusp (logand x y))) 1193 | query doc)) 1194 | 1195 | (defun boole-and-query (query doc) 1196 | (every #'(lambda (x y) (if (plusp x) (plusp y) t)) 1197 | query doc)) 1198 | 1199 | (defun norm (v) 1200 | (sqrt (sum i 0 (array-dimension v 0) 1201 | (expt (aref v i) 2)))) 1202 | 1203 | (defun similarity (v1 v2) 1204 | (/ (sum i 0 (array-dimension v1 0) 1205 | (* (aref v1 i) (aref v2 i))) 1206 | (* (norm v1) (norm v2)))) 1207 | 1208 | (defun item-count-hashed (stream) 1209 | (let ((results (make-hash-table)) 1210 | (tmp (read stream nil :eof))) 1211 | (until (eql tmp :eof) 1212 | (if (gethash tmp results) (incf (gethash tmp results)) 1213 | (setf (gethash tmp results) 1)) 1214 | (setq tmp (read stream nil :eof))) 1215 | results)) 1216 | 1217 | (defmacro until (test &rest body) 1218 | `(do () 1219 | (,test) 1220 | ,@body)) 1221 | 1222 | (require :aserve) 1223 | (require :pxml) 1224 | 1225 | (defparameter +eutils-host+ "eutils.ncbi.nlm.nih.gov") 1226 | (defparameter +entrez-query-url+ "/entrez/eutils/esearch.fcgi") 1227 | 1228 | (defun pubmed-query (searchstr &key start maximum) 1229 | (let ((query-alist `(("db" . "m") 1230 | ("term" . ,searchstr) 1231 | ("mode" . "xml")))) 1232 | (when maximum (push (cons "dispmax" maximum) query-alist)) 1233 | (when start (push (cons "dispstart" start) query-alist)) 1234 | (net.aserve.client:do-http-request 1235 | (format nil "http://~a~a" +eutils-host+ +entrez-query-url+) 1236 | :method :get 1237 | :query query-alist))) 1238 | 1239 | (defun whitespace-char-p (ch) 1240 | "Our own definition of which characters are whitespace" 1241 | (find ch '(#\Space #\Newline #\Tab #\Linefeed #\Return 1242 | #\Page #\Null) 1243 | :test #'char=)) 1244 | 1245 | (defun strip-blanks (terms) 1246 | "terms is a nested list possibly containing blank strings at 1247 | multiple levels. This function returns a new list with the same 1248 | items, each with blank strings recursively removed" 1249 | (labels ((strip-aux (accum terms) 1250 | (if (null terms) (reverse accum) 1251 | (strip-aux 1252 | (let ((term (first terms))) 1253 | (typecase term 1254 | (string (if (every #'whitespace-char-p term) 1255 | accum 1256 | (cons term accum))) 1257 | (list (cons (strip-aux nil term) 1258 | accum)) 1259 | (t (cons term accum)))) 1260 | (rest terms))))) 1261 | (strip-aux nil terms))) 1262 | 1263 | (defparameter +entrez-fetch-url+ "/entrez/eutils/efetch.fcgi") 1264 | 1265 | (defun pubmed-fetch (pmid) 1266 | "Gets the XML for a single entry given the PubMed ID of the entry" 1267 | (net.aserve.client:do-http-request 1268 | (format nil "http://~a~a" +eutils-host+ +entrez-fetch-url+) 1269 | :method :get 1270 | :query 1271 | `(("db" . "PubMed") ("report" . "xml") ("mode" . "text") 1272 | ("id" . ,(format nil "~A" pmid))))) 1273 | 1274 | (defun path-query (tree path) 1275 | "returns the first match to path in tree, where path is a list of 1276 | tags referring to nested lists" 1277 | (cond ((null tree) nil) 1278 | ((null path) tree) 1279 | (t (let ((next (assoc (first path) tree))) 1280 | (if next (path-query (rest next) 1281 | (rest path)) 1282 | nil))))) 1283 | 1284 | ;;;----------------------------------------------------- 1285 | ;;; Chapter 5 1286 | ;;;----------------------------------------------------- 1287 | 1288 | (defun read-fasta (strm allowed-chars accum) 1289 | (let ((char (read-char strm nil :eof))) 1290 | (cond ((eql char :eof) accum) 1291 | ((eql char #\>) 1292 | (if (null accum) ;; at beginning of sequence 1293 | (progn 1294 | (read-line strm) ;; skip description and cont. 1295 | (read-fasta strm allowed-chars accum)) 1296 | (reverse accum))) 1297 | ((member char allowed-chars) 1298 | (read-fasta strm allowed-chars 1299 | (cons (intern (string-upcase (string char))) 1300 | accum))) 1301 | (t (read-fasta strm allowed-chars accum))))) 1302 | 1303 | (defconstant +aa-codes+ 1304 | (let ((valid-letters "ACDEFGHIKLMNPQRSTVWY")) 1305 | (append (map 'list #'identity valid-letters) 1306 | (map 'list #'char-downcase valid-letters)))) 1307 | 1308 | (defconstant +base-codes+ 1309 | (let ((valid-letters "GCAT")) 1310 | (append (map 'list #'char-downcase valid-letters) 1311 | (map 'list #'identity valid-letters)))) 1312 | 1313 | (defun read-first-protein (filename codes) 1314 | "returns the first protein sequence in filename" 1315 | (with-open-file (strm filename) 1316 | (read-fasta strm +aa-codes+ nil))) 1317 | 1318 | (defun read-fasta (strm &optional (allowed-chars +aa-codes+) 1319 | (ac-parser #'sp-parser)) 1320 | (labels 1321 | ((scan (accum) 1322 | (let ((char (read-char strm nil :eof))) 1323 | (cond ((eql char :eof) (reverse accum)) 1324 | ((eql char #\>) (unread-char char strm) 1325 | (reverse accum)) 1326 | ((member char allowed-chars) 1327 | (scan (cons (intern (string-upcase (string char))) 1328 | accum))) 1329 | (t (scan accum)))))) 1330 | ;; the ac-parser call will return nil if end of file is reached 1331 | (let ((accession-number (funcall ac-parser strm))) 1332 | (if (null accession-number) 1333 | nil 1334 | (list accession-number (scan nil)))))) 1335 | 1336 | (defun sp-parser (strm) 1337 | (let ((ac (make-string 6)) 1338 | (ch (read-char strm nil :eof))) ;; get rid of the > 1339 | (if (eql ch :eof) nil ;; at end of file! 1340 | (progn 1341 | (dotimes (i 6) 1342 | (setq ch (read-char strm nil :eof)) 1343 | (if (eql ch :eof) ;; shouldn't happen! 1344 | (return-from sp-parser nil) 1345 | (setf (aref ac i) ch))) 1346 | (read-line strm nil :eof) 1347 | ac)))) 1348 | 1349 | (defun read-proteins (filename n) 1350 | "returns the first n protein sequences in filename" 1351 | (let ((sequences nil)) 1352 | (with-open-file (strm filename) 1353 | (dotimes (i n (reverse sequences)) 1354 | (push (read-fasta strm) 1355 | sequences))))) 1356 | 1357 | (defparameter alphabet '(a c t g)) 1358 | 1359 | (defparameter mutation-penalties 1360 | '((a (c . 0.3) (g . 0.4) (t . 0.3)) 1361 | (c (a . 0.4) (g . 0.2) (t . 0.3)) 1362 | (g (a . 0.1) (c . 0.3) (t . 0.2)) 1363 | (t (a . 0.3) (c . 0.4) (g . 0.1) ))) 1364 | 1365 | (defconstant infinity 10000000.0) 1366 | (defconstant omit-penalty 0.5) 1367 | (defconstant insert-penalty 0.7) 1368 | 1369 | (defun mutation-penalty (from to) 1370 | (if (eql from to) 0.0 1371 | (let ((from-entry (assoc from mutation-penalties))) 1372 | (if from-entry 1373 | (let ((to-entry (assoc to (rest from-entry)))) 1374 | (if to-entry (rest to-entry) 1375 | infinity)) 1376 | infinity)))) 1377 | 1378 | (defstruct ms 1379 | seq1 seq2 score history) 1380 | 1381 | (defun ms-goal? (ms) 1382 | (and (null (ms-seq1 ms)) 1383 | (null (ms-seq2 ms)))) 1384 | 1385 | (defun ms-same? (ms1 ms2) 1386 | (and (eql (ms-seq1 ms1) (ms-seq1 ms2)) 1387 | (eql (ms-seq2 ms1) (ms-seq2 ms2)))) 1388 | 1389 | (defun generate-successors (ms) 1390 | (let ((x (ms-seq1 ms)) 1391 | (y (ms-seq2 ms)) 1392 | (sc (ms-score ms)) 1393 | (hx (ms-history ms))) 1394 | (if (not (null x)) 1395 | (if (not (null y)) 1396 | (if (eql (first x) (first y)) 1397 | (list (make-ms :seq1 (rest x) :seq2 (rest y) 1398 | :score sc 1399 | :history (cons (list 'match 1400 | (first x)) 1401 | hx))) 1402 | (list (make-ms :seq1 (rest x) :seq2 (rest y) 1403 | :score (+ sc (mutation-penalty 1404 | (first x) 1405 | (first y))) 1406 | :history (cons (list 'mutate 1407 | (first x) 1408 | (first y)) 1409 | hx)) 1410 | (make-ms :seq1 x :seq2 (rest y) 1411 | :score (+ sc omit-penalty) 1412 | :history (cons (list 'omit (first y)) 1413 | hx)) 1414 | (make-ms :seq1 (rest x) :seq2 y 1415 | :score (+ sc insert-penalty) 1416 | :history (cons (list 'insert (first x)) 1417 | hx)))) 1418 | (list (make-ms :seq1 (rest x) :seq2 y 1419 | :score (+ sc insert-penalty) 1420 | :history (cons (list 'insert (first x)) 1421 | hx)))) 1422 | (list (make-ms :seq1 x :seq2 (rest y) 1423 | :score (+ sc omit-penalty) 1424 | :history (cons (list 'omit (first y)) 1425 | hx)))))) 1426 | 1427 | (defun found-one? (wins) 1428 | (not (null wins))) 1429 | 1430 | (defun match-hc (one two) 1431 | (hill-climb-search 1432 | (make-ms :seq1 one :seq2 two :score 0.0 :history nil) 1433 | #'ms-goal? 1434 | #'found-one? 1435 | #'generate-successors 1436 | #'ms-score)) 1437 | 1438 | (defun match-bf (one two) 1439 | (best-first-search 1440 | (make-ms :seq1 one :seq2 two :score 0.0 :history nil) 1441 | #'ms-goal? 1442 | #'found-one? 1443 | #'generate-successors 1444 | #'ms-score 1445 | #'ms-same?)) 1446 | 1447 | (defun match-a* (one two) 1448 | (a*-search 1449 | (make-ms :seq1 one :seq2 two :score 0.0 :history nil) 1450 | #'ms-goal? 1451 | #'found-one? 1452 | #'generate-successors 1453 | #'ms-score ;; f 1454 | #'(lambda (s) 0.0) ;; g* 1455 | #'ms-same?)) 1456 | 1457 | (defparameter s1 '(a a t c t g c c t a t t g t c g a c g c)) 1458 | (defparameter s2 '(a a t c a g c a g c t c a t c g a c g g)) 1459 | (defparameter s3 '(a g a t c a g c a c t c a t c g a c g g)) 1460 | 1461 | (defun dna-to-rna-base (base) 1462 | "for any dna base, returns the corresponding rna base" 1463 | (if (eql base 't) 'u base)) 1464 | 1465 | (defun dna-to-rna (seq) 1466 | "produces an rna sequence corresponding to the dna sequence seq" 1467 | (mapcar #'dna-to-rna-base seq)) 1468 | 1469 | (defconstant +rna-to-amino-table+ 1470 | (make-array '(4 4 4) :initial-contents 1471 | '(((gly gly gly gly) 1472 | (glu glu asp asp) 1473 | (ala ala ala ala) 1474 | (val val val val)) 1475 | ((arg arg ser ser) 1476 | (lys lys asn asn) 1477 | (thr thr thr thr) 1478 | (met ile ile ile)) 1479 | ((arg arg arg arg) 1480 | (glu glu his his) 1481 | (pro pro pro pro) 1482 | (leu leu leu leu)) 1483 | ((trp STOP cys cys) 1484 | (STOP STOP tyr tyr) 1485 | (ser ser ser ser) 1486 | (leu leu phe phe)))) 1487 | "The genetic code table") 1488 | 1489 | (defconstant +rna-indices+ '((g 0) (a 1) (c 2) (u 3))) 1490 | 1491 | (defun rna-index (base) 1492 | (second (assoc base +rna-indices+))) 1493 | 1494 | (defun rna-to-amino (b1 b2 b3) 1495 | "takes three bases and returns the corresponding amino acid" 1496 | (aref +rna-to-amino-table+ 1497 | (rna-index b1) 1498 | (rna-index b2) 1499 | (rna-index b3))) 1500 | 1501 | (defun rna-translate (mrna-seq) 1502 | "takes an mrna sequence and converts it to a polypeptide, 1503 | a sequence of amino acids" 1504 | (cond ((null mrna-seq) nil) 1505 | ((< (length mrna-seq) 3) nil) 1506 | (t (cons (rna-to-amino (first mrna-seq) 1507 | (second mrna-seq) 1508 | (third mrna-seq)) 1509 | (rna-translate (nthcdr 3 mrna-seq)))))) 1510 | 1511 | (defun is-stop (b1 b2 b3) 1512 | (eql (rna-to-amino b1 b2 b3) 'stop)) 1513 | 1514 | (defun find-stops (mrna-seq) 1515 | (labels ((fs-local (seq pos accum) 1516 | (if (< (length seq) 3) 1517 | (reverse accum) ;; no complete codon left so done 1518 | (cond ((is-stop (first seq) (second seq) (third seq)) 1519 | (fs-local (rest seq) (1+ pos) 1520 | (cons (list pos (mod pos 3)) 1521 | accum))) 1522 | (t (fs-local (rest seq) (1+ pos) accum)))))) 1523 | (fs-local mrna-seq 0 nil))) 1524 | 1525 | (defclass amino-acid () 1526 | ((name :accessor name 1527 | :initarg :name 1528 | :documentation "Symbol, the full name") 1529 | (abr1 :accessor abr1 1530 | :initarg :abr1 1531 | :documentation "Symbol, single letter abbreviation") 1532 | (abr3 :accessor abr3 1533 | :initarg :abr3 1534 | :documentation "Symbol, three letter abbreviation") 1535 | (mass :accessor mass 1536 | :initarg :mass 1537 | :documentation "Average molecular mass in Daltons") 1538 | (volume :accessor volume 1539 | :initarg :volume) 1540 | (surface-area :accessor surface-area 1541 | :initarg :surface-area) 1542 | (part-spec-vol :accessor part-spec-vol 1543 | :initarg :part-spec-vol) 1544 | (pk :accessor pk 1545 | :initarg :pk 1546 | :documentation "Ionization constant") 1547 | (hydrophobicity :accessor hydrophobicity 1548 | :initarg :hydrophobicity))) 1549 | 1550 | (defconstant +amino-acids+ 1551 | (list 1552 | (make-instance 'amino-acid 1553 | :name 'Alanine :abr1 'A :abr3 'ala 1554 | :mass 71 :volume 88.6 :surface-area 115 1555 | :part-spec-vol .748 :hydrophobicity .5) 1556 | (make-instance 'amino-acid 1557 | :name 'Arginine :abr1 'R :abr3 'arg 1558 | :mass 156 :volume 173.4 :surface-area 225 1559 | :part-spec-vol .666 :hydrophobicity -11.2) 1560 | (make-instance 'amino-acid 1561 | :name 'Asparagine :abr1 'n :abr3 'Asn 1562 | :mass 114 :volume 117.7 :surface-area 160 1563 | :part-spec-vol .619 :hydrophobicity -.2) 1564 | (make-instance 'amino-acid 1565 | :name 'Aspartate :abr1 'd :abr3 'asp 1566 | :mass 115 :volume 111.1 :surface-area 150 1567 | :part-spec-vol .579 :hydrophobicity -7.4) 1568 | (make-instance 'amino-acid 1569 | :name 'Cysteine :abr1 'c :abr3 'cys 1570 | :mass 103 :volume 108.5 :surface-area 135 1571 | :part-spec-vol .631 :hydrophobicity -2.8) 1572 | (make-instance 'amino-acid 1573 | :name 'Glutamine :abr1 'Q :abr3 'Gln 1574 | :mass 128 :volume 143.9 :surface-area 180 1575 | :part-spec-vol .674 :hydrophobicity -.3) 1576 | (make-instance 'amino-acid 1577 | :name 'Glutamate :abr1 'E :abr3 'glu 1578 | :mass 129 :volume 138.4 :surface-area 190 1579 | :part-spec-vol .643 :hydrophobicity -9.9) 1580 | (make-instance 'amino-acid 1581 | :name 'Glycine :abr1 'G :abr3 'gly 1582 | :mass 57 :volume 60.1 :surface-area 75 1583 | :part-spec-vol .632 :hydrophobicity 0) 1584 | (make-instance 'amino-acid 1585 | :name 'histidine :abr1 'H :abr3 'his 1586 | :mass 137 :volume 153.2 :surface-area 195 1587 | :part-spec-vol .67 :hydrophobicity .5) 1588 | (make-instance 'amino-acid 1589 | :name 'Isoleucine :abr1 'I :abr3 'ile 1590 | :mass 113 :volume 166.7 :surface-area 175 1591 | :part-spec-vol .884 :hydrophobicity 2.5) 1592 | (make-instance 'amino-acid 1593 | :name 'Leucine :abr1 'L :abr3 'leu 1594 | :mass 113 :volume 166.7 :surface-area 170 1595 | :part-spec-vol .884 :hydrophobicity 1.8) 1596 | (make-instance 'amino-acid 1597 | :name 'Lysine :abr1 'K :abr3 'lys 1598 | :mass 128 :volume 168.6 :surface-area 200 1599 | :part-spec-vol .789 :hydrophobicity -4.2) 1600 | (make-instance 'amino-acid 1601 | :name 'Methionine :abr1 'M :abr3 'met 1602 | :mass 131 :volume 162.9 :surface-area 185 1603 | :part-spec-vol .745 :hydrophobicity 1.3) 1604 | (make-instance 'amino-acid 1605 | :name 'Phenylalanine :abr1 'F :abr3 'phe 1606 | :mass 147 :volume 189.9 :surface-area 210 1607 | :part-spec-vol .774 :hydrophobicity 2.5) 1608 | (make-instance 'amino-acid 1609 | :name 'Proline :abr1 'P :abr3 'pro 1610 | :mass 97 :volume 122.7 :surface-area 145 1611 | :part-spec-vol .758 :hydrophobicity -3.3) 1612 | (make-instance 'amino-acid 1613 | :name 'Serine :abr1 'S :abr3 'ser 1614 | :mass 87 :volume 89.0 :surface-area 115 1615 | :part-spec-vol .613 :hydrophobicity -.3) 1616 | (make-instance 'amino-acid 1617 | :name 'Threonine :abr1 'T :abr3 'thr 1618 | :mass 101 :volume 116.1 :surface-area 140 1619 | :part-spec-vol .689 :hydrophobicity .4) 1620 | (make-instance 'amino-acid 1621 | :name 'Trypophan :abr1 'W :abr3 'trp 1622 | :mass 186.21 :volume 227.8 :surface-area 255 1623 | :part-spec-vol .734 :hydrophobicity 3.4) 1624 | (make-instance 'amino-acid 1625 | :name 'Tyrosine :abr1 'Y :abr3 'tyr 1626 | :mass 163 :volume 193.6 :surface-area 230 1627 | :part-spec-vol .712 :hydrophobicity 2.3) 1628 | (make-instance 'amino-acid 1629 | :name 'Valine :abr1 'V :abr3 'val 1630 | :mass 99 :volume 140.0 :surface-area 155 1631 | :part-spec-vol .847 :hydrophobicity 1.5) 1632 | )) 1633 | 1634 | (let ((amino-acid-table (make-hash-table))) 1635 | (dolist (amino-acid +amino-acids+ 'done) 1636 | (setf (gethash (name amino-acid) amino-acid-table) 1637 | amino-acid) 1638 | (setf (gethash (abr1 amino-acid) amino-acid-table) 1639 | amino-acid) 1640 | (setf (gethash (abr3 amino-acid) amino-acid-table) 1641 | amino-acid)) 1642 | (defun lookup-amino-acid (aa-name) 1643 | (gethash (if (stringp aa-name) 1644 | (read-from-string aa-name nil nil) 1645 | aa-name) 1646 | amino-acid-table))) 1647 | 1648 | (defconstant +mass-water+ 18.0) 1649 | 1650 | (defmethod mass ((pp polypeptide)) 1651 | (+ (mass (seq pp)) +mass-water+)) 1652 | 1653 | (defmethod mass ((seq list)) 1654 | (apply #'+ 1655 | (mapcar #'(lambda (x) (mass (lookup-amino-acid x))) 1656 | seq))) 1657 | 1658 | (defconstant ext-tyr 1490) 1659 | (defconstant ext-trp 5500) 1660 | (defconstant ext-cys 125) ;; this is actually cystine, not cysteine 1661 | 1662 | (defun extinction-coeff (seq) 1663 | (+ (* (count 'tyr seq) ext-tyr) 1664 | (* (count 'trp seq) ext-trp) 1665 | (* (count 'cys seq) ext-cys))) 1666 | 1667 | (defun absorbance (seq) 1668 | (/ (extinction-coeff seq) (mass seq))) 1669 | 1670 | (defun profile (seq) 1671 | "returns a profile table for any sequence of items - each table 1672 | entry has the item, the occurrence count and the corresponding 1673 | percentage or frequency." 1674 | (let ((size (length seq))) 1675 | (mapcar #'(lambda (x) 1676 | (list (first x) ;; the name 1677 | (second x) ;; the count 1678 | (/ (second x) size))) ;; the percentage 1679 | (item-count seq)))) 1680 | 1681 | (defun sort-profile-by-percent (profile) 1682 | (sort (copy-list profile) #'< :key #'third)) 1683 | 1684 | (defun sort-profile-by-name (profile) 1685 | (sort profile #'string-lessp 1686 | :key #'(lambda (x) (symbol-name (first x))))) 1687 | 1688 | (defun sum-square-diff (profile-1 profile-2) 1689 | "Each profile is an alist sorted the same way. The sum of the 1690 | squared differences of the values is returned." 1691 | (apply #'+ (mapcar #'(lambda (x y) 1692 | (expt (- (third x) (third y)) 2)) 1693 | profile-1 profile-2))) 1694 | 1695 | (defconstant +aa-symbols+ 1696 | (list 'a 'b 'c 'd 'e 'f 'g 'h 'i 'k 'l 'm 1697 | 'n 'p 'q 'r 's 't 'u 'v 'w 'x 'y 'z)) 1698 | 1699 | (defun make-full-profile (profile &optional (names +aa-symbols+)) 1700 | "adds any not found in sequence and sorts by name" 1701 | (let ((full-profile (copy-list profile))) 1702 | (dolist (name names) 1703 | (unless (find name profile :key #'first) 1704 | (push (list name 0 0) full-profile))) 1705 | (sort-profile-by-name full-profile))) 1706 | 1707 | (defun fasta-profiler (filename &optional (codes +aa-codes+) 1708 | (ac-parser #'sp-parser)) 1709 | (let ((profiles '()) 1710 | (seq nil) 1711 | (n 0)) 1712 | (with-open-file (strm filename) 1713 | (loop 1714 | (setq seq (read-fasta strm codes nil ac-parser)) 1715 | (if seq 1716 | (progn 1717 | (format t "~&Record ~A accession number ~A~%" 1718 | (incf n) (first seq)) 1719 | (push (list (first seq) 1720 | (profile (second seq))) 1721 | profiles)) 1722 | (return profiles)))))) 1723 | 1724 | (defun fasta-profiler-to-file (&optional (infile *standard-input*) 1725 | (outfile *standard-output*) 1726 | (codes +aa-codes+) 1727 | (ac-parser #'sp-parser)) 1728 | (let ((seq nil) 1729 | (n 0)) 1730 | (with-open-file (in-strm infile :direction :input) 1731 | (with-open-file (out-strm outfile :direction :output) 1732 | (loop 1733 | (setq seq (read-fasta in-strm codes nil ac-parser)) 1734 | (if seq 1735 | (progn 1736 | (format t "~&Record ~A accession number ~A~%" 1737 | (incf n) (first seq)) 1738 | (pprint 1739 | (list (first seq) 1740 | (profile (second seq))) 1741 | out-strm)) 1742 | (return n))))))) 1743 | 1744 | (defun compare-profiles-from-file (p filename) 1745 | (let ((p2 (make-full-profile (second p)))) 1746 | (pprint p) 1747 | (pprint p2) 1748 | (with-open-file (strm filename) 1749 | (do ((profile (read strm nil :eof) (read strm nil :eof)) 1750 | (results '()) 1751 | (n 1 (1+ n))) 1752 | ((eql profile :eof) (sort results #'< :key #'second)) 1753 | (format t "~&Processing profile ~A~%" n) 1754 | (push (list (first profile) 1755 | (sum-square-diff p2 (make-full-profile 1756 | (second profile)))) 1757 | results))))) 1758 | 1759 | (defun sum-square-diff (profile-1 profile-2) 1760 | "Each profile is an alist sorted the same way. The sum of the 1761 | squared differences of the values is returned." 1762 | (apply #'+ (mapcar #'(lambda (x y) 1763 | (expt (- (coerce (third x) 'single-float) 1764 | (coerce (third y) 'single-float)) 1765 | 2)) 1766 | profile-1 profile-2))) 1767 | 1768 | (defun display-rank (data &optional n) 1769 | (do* ((temp data (rest temp)) 1770 | (d (first temp) (first temp)) 1771 | (i 0 (1+ i))) 1772 | ((if n (= i n) (endp temp))) 1773 | (format t "~&~A ~10,7F~%" (first d) (second d)))) 1774 | 1775 | (defun find-frame-by-name (name) 1776 | (find name *frame-kb* :key #'name :test #'string-equal)) 1777 | 1778 | (defmacro is? (name1 connector name2) 1779 | `(subsumed-by (find-frame-by-name ,name1) 1780 | (find-frame-by-name ,name2))) 1781 | 1782 | (defstruct reaction 1783 | reactants ;; Lefthand side 1784 | products ;; Righthand side, significant products 1785 | other-products) ;; non-significant products 1786 | 1787 | (defvar *reactions* nil) 1788 | 1789 | (defmacro add-reaction (reactants products &optional other-products) 1790 | `(push (make-reaction :reactants ',reactants 1791 | :products ',products 1792 | :other-products ',other-products) 1793 | *reactions*)) 1794 | 1795 | (defun make-reactions () 1796 | (add-reaction (fru) (f1p)) 1797 | (add-reaction (f1p) (glh dap)) 1798 | (add-reaction (glh) (g3p)) 1799 | (add-reaction (glu atp) (g6p) (adp)) 1800 | (add-reaction (g6p) (f6p)) 1801 | (add-reaction (f6p atp) (fbp) (adp)) 1802 | (add-reaction (fbp) (dap g3p)) 1803 | (add-reaction (dap) (g3p)) 1804 | (add-reaction (P NAD+ g3p) (bpg) (NADH H+)) 1805 | (add-reaction (bpg adp) (3pg) (atp)) 1806 | (add-reaction (3pg) (2pg)) 1807 | (add-reaction (2pg) (pep) (H2O)) 1808 | (add-reaction (pep atp) (pyr) (adp)) 1809 | (add-reaction (pyr NAD+ coa) (aca) (NADH H+ CO2)) 1810 | (add-reaction (cit) (ict)) 1811 | (add-reaction (ict NAD+) (akg) (NADH H+ CO2)) 1812 | (add-reaction (akg NAD+ coa) (sca) (NADH H+ CO2)) 1813 | (add-reaction (sca gdp P) (suc coa) (gtp)) 1814 | (add-reaction (suc FAD) (fum) (FADH2)) 1815 | (add-reaction (fum H2O) (mal)) 1816 | (add-reaction (mal NAD+) (oxa) (NADH H+))) 1817 | 1818 | (defvar *reactant-table* (make-hash-table)) 1819 | 1820 | (defun lookup-by-reactants (prod) 1821 | (gethash prod *reactant-table*)) 1822 | 1823 | (defun init-reactant-table (rxns) 1824 | (dolist (rxn rxns) 1825 | (let ((reactants (reaction-reactants rxn))) 1826 | (dolist (mol reactants) 1827 | (pushnew rxn (gethash mol *reactant-table*)))))) 1828 | 1829 | (defun applicable-rxns (mols env) 1830 | (apply #'append 1831 | (mapcar #'(lambda (mol) 1832 | (remove-if-not 1833 | #'(lambda (x) (every #'(lambda (y) 1834 | (find y env)) 1835 | (reaction-reactants x))) 1836 | (lookup-by-reactants mol))) 1837 | mols))) 1838 | 1839 | (defun mappend (fn the-list) 1840 | (apply #'append (mapcar fn the-list))) 1841 | 1842 | (defun applicable-rxns (mols env) 1843 | (mappend #'(lambda (mol) 1844 | (remove-if-not #'(lambda (x) 1845 | (every #'(lambda (y) 1846 | (find y env)) 1847 | (reaction-reactants x))) 1848 | (lookup-by-reactants mol))) 1849 | mols)) 1850 | 1851 | (defun apply-rxn (rxn env) 1852 | "returns a new environment with the products of rxn added to the 1853 | current environment env. This function uses but does not modify 1854 | env." 1855 | (labels ((add-prods (prods accum) 1856 | (if (null prods) accum 1857 | (if (find (first prods) accum) 1858 | (add-prods (rest prods) accum) 1859 | (add-prods (rest prods) 1860 | (cons (first prods) accum)))))) 1861 | ;; note we want to add the small molecules too if new, e.g., ADP 1862 | (add-prods (reaction-other-products rxn) 1863 | (add-prods (reaction-products rxn) env)))) 1864 | 1865 | (defstruct node rxn env) 1866 | 1867 | (defun next-nodes (path) 1868 | "returns a list of next nodes in the pathway graph from a given 1869 | path, where path is a list of nodes, most recently added first." 1870 | (let* ((current (first path)) 1871 | (last-rxn (node-rxn current)) 1872 | (env (node-env current)) 1873 | (rxns (applicable-rxns (reaction-products last-rxn) 1874 | env))) 1875 | (mapcar #'(lambda (rxn) 1876 | (make-node :rxn rxn :env (apply-rxn rxn env))) 1877 | rxns))) 1878 | 1879 | (defun metabolic-paths (end-product start-env max-paths) 1880 | (path-search start-env 1881 | ;; check if end-product is in the current environment 1882 | #'(lambda (current) ;; current is a path 1883 | (find end-product (node-env (first current)))) 1884 | #'(lambda (wins) ;; no more than max-paths 1885 | (>= (length wins) max-paths)) 1886 | #'next-nodes ;; see above 1887 | #'cons ;; just put new nodes on front 1888 | #'(lambda (x y) (append y x)))) ;; breadth-first 1889 | 1890 | (defun initial-nodes (mols env) 1891 | (mapcar #'(lambda (rxn) 1892 | (make-node :rxn rxn :env (apply-rxn rxn env))) 1893 | (applicable-rxns mols env))) 1894 | 1895 | (defun pprint-reaction (rxn) 1896 | (format nil "~A --> ~A + ~A" 1897 | (reaction-reactants rxn) 1898 | (reaction-products rxn) 1899 | (reaction-other-products rxn))) 1900 | 1901 | (defun print-path (path) 1902 | (let ((nice-rxns (mapcar #'(lambda (node) 1903 | (pprint-reaction (node-rxn node))) 1904 | path))) 1905 | (dolist (rxn nice-rxns) 1906 | (format t "~A~%" rxn)))) 1907 | 1908 | (defvar *init-env* '(atp adp gdp gtp fru glu NAD+ FAD P)) 1909 | 1910 | (defvar *init-mols* '(glu fru)) 1911 | 1912 | (defun init () 1913 | (make-reactions) 1914 | (init-reactant-table *reactions*) 1915 | (initial-nodes *init-mols* *init-env*)) 1916 | 1917 | (defun test (init-node n) 1918 | (mapcar #'reverse ;; or make metabolic-paths reverse stuff 1919 | (metabolic-paths 'pyr init-node n))) 1920 | 1921 | (defun test2 (init-node n) 1922 | (mapcar #'reverse 1923 | (metabolic-paths 'mal init-node n))) 1924 | 1925 | (defun make-state-table (&optional (size 100)) 1926 | (make-hash-table :size size)) 1927 | 1928 | (defun add-variable (table state-var initial-val) 1929 | (setf (gethash state-var table) initial-val)) 1930 | 1931 | (defun next-state (table trans-fn history) 1932 | "updates the state table in parallel, by computing the new state 1933 | values, then adding them after doing all of them." 1934 | (let (new-states) 1935 | (maphash #'(lambda (var val) 1936 | (push (list var 1937 | (funcall trans-fn var table)) 1938 | new-states)) 1939 | table) 1940 | (mapc #'(lambda (new) 1941 | (if history 1942 | (push (second new) 1943 | (gethash (first new) table)) 1944 | (setf (gethash (first new) table) 1945 | (second new)))) 1946 | new-states))) 1947 | 1948 | (defun run-state-machine (table trans-fn 1949 | &key history (cycles 1)) 1950 | (dotimes (i cycles table) 1951 | (next-state table trans-fn history))) 1952 | 1953 | (defun box-transition (var box) 1954 | (let ((switch-state (gethash 'switch box)) 1955 | (hand-state (gethash 'hand box)) 1956 | (lid-state (gethash 'lid box))) 1957 | (case var 1958 | (switch (if (and (eql switch-state 'on) 1959 | (eql hand-state 'out)) 1960 | 'off 1961 | switch-state)) 1962 | (lid (if (and (eql switch-state 'on) 1963 | (eql lid-state 'closed)) 1964 | 'open 1965 | (if (and (eql switch-state 'off) 1966 | (eql lid-state 'open) 1967 | (eql hand-state 'in)) 1968 | 'closed 1969 | lid-state))) 1970 | (hand (if (and (eql switch-state 'on) 1971 | (eql hand-state 'in) 1972 | (eql lid-state 'open)) 1973 | 'out 1974 | (if (and (eql switch-state 'off) 1975 | (eql hand-state 'out)) 1976 | 'in 1977 | hand-state)))))) 1978 | 1979 | (defparameter *model-graph* ;; (fig 1b) 1980 | '((size + cln3) 1981 | (cln3 + mbf) 1982 | (cln3 + sbf) 1983 | (sbf + cln12) 1984 | (cln12 - sic1) 1985 | (cln12 - cdh1) 1986 | (sic1 - clb56) 1987 | (sic1 - clb12) 1988 | (mbf + clb56) 1989 | (clb56 + mcm1/sff) 1990 | (clb56 - sic1) 1991 | (clb56 + clb12) 1992 | (clb56 - cdh1) 1993 | (cdh1 - clb12) 1994 | (clb12 - cdh1) 1995 | (clb12 + mcm1/sff) 1996 | (clb12 + cdc20&14) 1997 | (clb12 - sic1) 1998 | (clb12 - swi5) 1999 | (clb12 - mbf) 2000 | (clb12 - sbf) 2001 | (mcm1/sff + cdc20&14) 2002 | (mcm1/sff + swi5) 2003 | (mcm1/sff + clb12) 2004 | (cdc20&14 + swi5) 2005 | (cdc20&14 + cdh1) 2006 | (cdc20&14 - clb12) 2007 | (cdc20&14 + sic1) 2008 | (cdc20&14 - clb56) 2009 | (swi5 + sic1) 2010 | )) 2011 | 2012 | (defun make-graph-hash (graph) 2013 | "returns a new hash table indexed by the target proteins, 2014 | containing the influencing protein and its sign." 2015 | (let ((graph-table (make-hash-table))) 2016 | (dolist (arc graph graph-table) 2017 | (push (butlast arc) 2018 | (gethash (third arc) graph-table))))) 2019 | 2020 | (defun set-proteins (proteins state table) 2021 | (dolist (p proteins) 2022 | (push (list state 0) (gethash p table)))) 2023 | 2024 | (defun graph-node-list (graph) 2025 | (let (nodes) 2026 | (dolist (arc graph nodes) 2027 | (pushnew (first arc) nodes) 2028 | (pushnew (third arc) nodes)))) 2029 | 2030 | (defun init-cell-cycle (graph initially-on-list) 2031 | (let* ((nodes (graph-node-list graph)) 2032 | (state-table (make-state-table (length nodes)))) 2033 | (set-proteins nodes 0 state-table) 2034 | (set-proteins initially-on-list 1 state-table) 2035 | state-table)) 2036 | 2037 | (defparameter *self-degrading-proteins* 2038 | '(cln3 cln12 mcm1/sff swi5 cdc20&14)) 2039 | 2040 | (defparameter *degrade-time* 5) 2041 | 2042 | (defun self-degrading (p) 2043 | (find p *self-degrading-proteins*)) 2044 | 2045 | (defun self-degradation (p table) 2046 | (let ((history (gethash p table))) 2047 | (and (self-degrading p) 2048 | (>= (length history) *degrade-time*) 2049 | (every #'(lambda (state) 2050 | (equal state '(1 0))) 2051 | (subseq history 0 *degrade-time*))))) 2052 | 2053 | (defun new-protein-state (p state-table graph-hash) 2054 | "returns a list containing a 1 or 0 for the next state and the 2055 | influence sum, for a particular protein, p, based on the current 2056 | state. If p is a self degrading protein, its history is checked 2057 | and if it is time to degrade, its state becomes 0." 2058 | (let ((influence-sum 0)) 2059 | (dolist (p2-arc (gethash p graph-hash)) 2060 | (let* ((p2 (first p2-arc)) 2061 | (p2-state (first (first (gethash p2 state-table))))) 2062 | (case (second p2-arc) 2063 | (+ (incf influence-sum p2-state)) 2064 | (- (decf influence-sum p2-state))))) 2065 | (list 2066 | (cond ((> influence-sum 0) 1) 2067 | ((< influence-sum 0) 0) 2068 | (t (if (self-degradation p state-table) 0 2069 | (first (first (gethash p state-table)))))) 2070 | influence-sum))) 2071 | 2072 | (defun run-cell-cycle (graph initially-on n) 2073 | (let ((state-table (init-cell-cycle graph initially-on)) 2074 | (graph-hash (make-graph-hash graph))) 2075 | (run-state-machine state-table 2076 | #'(lambda (var table) 2077 | (new-protein-state var table 2078 | graph-hash)) 2079 | :history t :cycles 1) 2080 | (set-proteins initially-on 0 state-table) 2081 | (run-state-machine state-table 2082 | #'(lambda (var table) 2083 | (new-protein-state var table 2084 | graph-hash)) 2085 | :history t :cycles n))) 2086 | 2087 | ;;;----------------------------------------------------- 2088 | ;;; Chapter 6 2089 | ;;;----------------------------------------------------- 2090 | 2091 | (defconstant *data-flag* 4) 2092 | (defconstant *end-flag* 3) 2093 | (defconstant *fms-host* "fma.biostr.washington.edu") 2094 | (defconstant *fms-port* 8098) 2095 | 2096 | #+lispworks (require "comm") 2097 | 2098 | (defvar *fms-socket* nil "open socket to the fms") 2099 | 2100 | (defun fms-connect (&optional (host *fms-host*) (port *fms-port*)) 2101 | (let ((stream #+allegro (socket:make-socket :remote-host host 2102 | :remote-port port) 2103 | #+lispworks (comm:open-tcp-stream host port) 2104 | #+cmu (system:make-fd-stream 2105 | (extensions:connect-to-inet-socket host port) 2106 | :input t :output t :element-type 'character) 2107 | )) 2108 | (format t "~A~%" (fms-readback stream)) 2109 | (setq *fms-socket* stream))) 2110 | 2111 | (defun fms-readback (stream) 2112 | (let (item data) 2113 | (loop 2114 | (setq item (read stream nil :eof)) 2115 | (cond ((eql item :eof) (return data)) 2116 | ((eql item *data-flag*) (read-line stream) 2117 | (setq data (read stream))) 2118 | ((eql item *end-flag*) 2119 | (read-line stream) (return data)) 2120 | (t (setq data item)))))) 2121 | 2122 | (defun fms-query (expr) 2123 | (if (listp expr) 2124 | (setq expr ;; convert to string with embedded " around terms 2125 | (format nil "(~A~{ \"~A\"~})" (first expr) (rest expr)))) 2126 | (write-line expr *fms-socket*) 2127 | (finish-output *fms-socket*) 2128 | (fms-readback *fms-socket*)) 2129 | 2130 | (defun fms-disconnect (&optional (stream *fms-socket*)) 2131 | (fms-query stream "(quit)") 2132 | (close stream) 2133 | (format t "~%FMS Connection closed~%")) 2134 | 2135 | (defun get-children (term relation) 2136 | (fms-query (list 'fms-get-children term relation))) 2137 | 2138 | (defun const-parts (term) 2139 | (get-children term "constitutional part")) 2140 | 2141 | (defun get-attributes (term) 2142 | (fms-query (list 'fms-get-attributes term))) 2143 | 2144 | (defun get-parents (term relation) 2145 | (fms-query (list 'fms-get-parents term relation))) 2146 | 2147 | (defun get-hierarchies (&optional term) 2148 | (fms-query (if term (list 'fms-get-hierarchies term) 2149 | (list 'fms-get-hierarchies)))) 2150 | 2151 | (defun all-subclasses (term) 2152 | (let ((subs (get-children term ":DIRECT-SUBCLASSES"))) 2153 | (cond ((null subs) nil) 2154 | (t (append subs 2155 | (mappend #'all-subclasses 2156 | subs)))))) 2157 | 2158 | (defun lymphatic-drainage (term) 2159 | (get-children term "lymphatic drainage")) 2160 | 2161 | (defun regional-parts (term) 2162 | (get-children term "regional part")) 2163 | 2164 | (defun efferent-to (term) 2165 | (get-children term "efferent to")) 2166 | 2167 | (defun afferent-to (term) 2168 | (get-children term "afferent to")) 2169 | 2170 | (defun find-all-paths (start successors extender merge) 2171 | (path-search start 2172 | #'(lambda (current) ;; goal - stop when no more nexts 2173 | (null (funcall successors current))) 2174 | nil ;; get all the paths 2175 | successors extender merge)) 2176 | 2177 | (defun lymphatic-paths (site) 2178 | (mappend #'(lambda (start) 2179 | (find-all-paths start 2180 | #'(lambda (path) 2181 | (efferent-to (first path))) 2182 | #'cons #'append)) 2183 | (lymphatic-drainage site))) 2184 | 2185 | (defun get-efferents (terms) 2186 | (mapcar #'(lambda (x) 2187 | (list x (efferent-to x))) 2188 | terms)) 2189 | 2190 | (defun check-efferents (termslots allowed) 2191 | "termslots is a list of chains or vessels and their efferent to 2192 | slot values. allowed is the complete list of allowed values" 2193 | (let (good bad not-done) 2194 | (dolist (chain termslots) 2195 | (let ((efferents (second chain))) 2196 | (cond ((null efferents) (push chain not-done)) 2197 | ((every #'(lambda (x) 2198 | (find x allowed :test #'string-equal)) 2199 | efferents) 2200 | (push chain good)) 2201 | (t (push chain bad))))) 2202 | (list good bad not-done))) 2203 | 2204 | ;;;----------------------------------------------------- 2205 | ;;; Chapter 7 2206 | ;;;----------------------------------------------------- 2207 | 2208 | (defclass drug-label () 2209 | ((name :documentation "The generic name of the drug") 2210 | description 2211 | (clinical-pharm :documentation "The pharmacologic action") 2212 | (indications :documentation "List of uses of the drug") 2213 | (contraindications :documentation "Conditions that indicate the 2214 | drug should not be used") 2215 | (precautions :documentation "Interactions usually included here") 2216 | (dosage :documentation 2217 | "Recommended dosage for various situations") 2218 | )) 2219 | 2220 | (defclass drug() 2221 | ((generic-name :accessor generic-name 2222 | :documentation "Commonly used name") 2223 | (drug-class :accessor drug-class 2224 | :documentation "the therepeutic class of the drug") 2225 | (dosage :accessor dosage 2226 | :documentation "a list of approved dosages") 2227 | (form :accessor form 2228 | :documentation "oral, transdermal, or iv") 2229 | (indications :accessor indications 2230 | :documentation "what is the drug supposed to treat, 2231 | i.e., a list of ICD-9 codes.") 2232 | (side-effects :accessor side-effects 2233 | :documentation "a list of symbols naming side 2234 | effects") 2235 | (substrate-of :accessor substrate-of 2236 | :documentation "list of enzymes this drug is a 2237 | substrate of") 2238 | (inhibits :accessor inhibits 2239 | :documentation "list of enzymes drug inhibits, with 2240 | mechanism, strength") 2241 | (induces :accessor induces 2242 | :documentation "list of enzymes this drug induces") 2243 | (narrow-ther-index :accessor narrow-ther-index 2244 | :documentation "yes or no") 2245 | (level-of-first-pass :accessor level-of-first-pass 2246 | :documentation "unknown or [enzyme level]") 2247 | (prim-first-pass-enzyme :accessor prim-first-pass-enzyme) 2248 | (prim-clearance-mechanism :accessor prim-clearance-mechanism 2249 | :documentation "metabolic or renal") 2250 | (contraindications :accessor contraindications) 2251 | (prodrug :accessor prodrug 2252 | :documentation "is it a prodrug, yes or no?") 2253 | )) 2254 | 2255 | (defun recursive-lookup (drug-inst slotname) 2256 | (let ((drug-type (find-frame-by-id (slot-data drug-inst 2257 | 'instance-of)))) 2258 | (append (slot-data drug-inst slotname) 2259 | (slot-data drug-type slotname) 2260 | (mapcar #'(lambda (x) (slot-data 2261 | (find-frame-by-id x) 2262 | slotname)) 2263 | (all-superclasses drug-type))))) 2264 | 2265 | (defun inhibition-interaction (precip obj) 2266 | (null (set-difference (substrate-of obj) 2267 | (inhibits precip)))) 2268 | 2269 | (defun induction-interaction (precip obj) 2270 | (null (set-difference (substrate-of obj) 2271 | (induces precip)))) 2272 | 2273 | (defun inhibition-interaction-3 (precip-1 precip-2 obj) 2274 | (null (set-difference (substrate-of obj) 2275 | (append (inhibits precip-1) 2276 | (inhibits precip-2))))) 2277 | 2278 | (defun induction-interaction-3 (precip-1 precip-2 obj) 2279 | (null (set-difference (substrate-of obj) 2280 | (append (induces precip-1) 2281 | (induces precip-2))))) 2282 | 2283 | (defun inhibition-interaction-n (obj &rest precips) 2284 | (null (set-difference (substrate-of obj) 2285 | (mappend #'inhibits precips)))) 2286 | 2287 | (defun induction-interaction-n (obj &rest precips) 2288 | (null (set-difference (substrate-of obj) 2289 | (mappend #'induces precips)))) 2290 | 2291 | (defun lookup (fr-name slotname) 2292 | (slot-data (find-frame-by-name fr-name) slotname)) 2293 | 2294 | (defun inhibits (drugname) 2295 | (lookup drugname 'inhibits)) 2296 | 2297 | (defun induces (drugname) 2298 | (lookup drugname 'induces)) 2299 | 2300 | (defun substrate-of (drugname) 2301 | (lookup drugname 'substrate-of)) 2302 | 2303 | (<- (metabolic-inhibit-interact ?precip ?object ?enz) 2304 | (and (inhibits-primary-clearance-enzyme ?precip ?object ?enz) 2305 | (narrow-ther-index ?object yes))) 2306 | 2307 | (<- (inhibits-primary-clearance-enzyme ?precip ?object ?enz) 2308 | (and (inhibits-partial-clearance ?precip ?object ?enz) 2309 | (major-pathway ?object ?enz))) 2310 | 2311 | (<- (inhibits-partial-clearance ?precip ?object ?enz) 2312 | (and (inhibits-effectively ?precip ?enz) 2313 | (substrate-of ?object ?enz) 2314 | (primary-clearance-mechanism ?object metabolic))) 2315 | 2316 | (<- (inhibits-effectively ?drug ?enz) 2317 | (and (inhibits ?drug ?enz) 2318 | (or (inhibit-strength ?drug ?enz strong) 2319 | (inhibit-strength ?drug ?enz moderate)))) 2320 | 2321 | (defun interacts (drug-a drug-b) 2322 | (or 2323 | (intersection (effects drug-a) 2324 | (contraindications drug-b)) 2325 | (intersection (effects drug-b) 2326 | (contraindications drug-a)))) 2327 | 2328 | (defun effects (entryname) 2329 | (recursive-lookup (find-frame-by-name entryname) 'effects)) 2330 | 2331 | (defun contraindications (entryname) 2332 | (recursive-lookup (find-frame-by-name entryname) 2333 | 'contraindications)) 2334 | 2335 | ;;;----------------------------------------------------- 2336 | ;;; Chapter 8 2337 | ;;;----------------------------------------------------- 2338 | 2339 | (defun tcp-server (applic-fn port) 2340 | (let ((socket (make-socket :connect :passive 2341 | :address-family :internet 2342 | :type :stream 2343 | :local-port port)) 2344 | (stream nil)) 2345 | (unwind-protect 2346 | (loop 2347 | (setq stream (accept-connection socket :wait t)) 2348 | (funcall applic-fn stream) 2349 | (close stream))) 2350 | (close socket))) ;; only here if severe error occurs 2351 | 2352 | (defun tcp-client (applic-fn port) 2353 | (let ((stream (make-socket :connect :active 2354 | :address-family :internet 2355 | :type :stream 2356 | :remote-host host 2357 | :remote-port port))) 2358 | (unwind-protect 2359 | (funcall applic-fn stream)) 2360 | (close stream))) 2361 | 2362 | (defun next-token (delimiter text start) 2363 | (let ((end (position delimiter text :start start))) 2364 | (values 2365 | (subseq text start end) end))) 2366 | 2367 | (defun scan-hl7 (delimiter text) 2368 | "returns a list of tokens from text that are demarcated 2369 | by delimiter" 2370 | (labels ((scan-aux (delim txt start) 2371 | (multiple-value-bind (token end) 2372 | (next-token delim txt start) 2373 | (if end ;; non-null so more string is left 2374 | (cons token 2375 | (scan-aux delim txt (1+ end))) 2376 | ;; no divisions - just listify it 2377 | (list token))))) 2378 | (scan-aux delimiter text 0))) 2379 | 2380 | (defun delimiters (msg) 2381 | "returns the 5 characters that are used as the field, component, 2382 | subcomponent, etc. delimiters in the HL7 message msg as multiple 2383 | values" 2384 | (if (string= (subseq msg 0 3) "MSH") 2385 | (values (elt msg 3) (elt msg 4) (elt msg 5) 2386 | (elt msg 6) (elt msg 7)) 2387 | ;; this is probably a little severe... 2388 | (error "Wrong first segment type"))) 2389 | 2390 | (defun hl7-message-scan (msg) 2391 | "returns a list of segments, with each segment represented as a 2392 | list of fields, and each field a list of components. Assumes that 2393 | segments are separated by but uses the embedded delimiters in 2394 | the message for the fields and components." 2395 | (multiple-value-bind (fld cmp rep esc subcmp) (delimiters msg) 2396 | (mapcar #'(lambda (seg) 2397 | (mapcar #'(lambda (field) 2398 | ;; separate each field into components 2399 | (scan-hl7 cmp field)) 2400 | ;; separate each segment into fields 2401 | (scan-hl7 fld seg))) 2402 | ;; separate msg into segments 2403 | (butlast (scan-hl7 #\return msg))))) 2404 | 2405 | (defun dicom-server (port) 2406 | (let ((socket (make-socket :connect :passive 2407 | :address-family :internet 2408 | :type :stream 2409 | :local-port port))) 2410 | (unwind-protect 2411 | (dicom-state-machine socket :server nil)) 2412 | (close socket))) ;; only here if severe error occurs 2413 | 2414 | (defun dicom-client (host port) 2415 | (let ((env (list (list 'remote-host-name host) 2416 | (list 'remote-port port)))) 2417 | (unwind-protect 2418 | (dicom-state-machine nil :client env)))) 2419 | 2420 | (defun path-find (path env) 2421 | (cond ((null path) nil) 2422 | ((null env) nil) 2423 | ((null (rest path)) (assoc (first path) env)) 2424 | (t (path-find (rest path) 2425 | (rest (assoc (first path) env)))))) 2426 | 2427 | (defvar *event* nil) 2428 | 2429 | (defun dicom-state-machine-simple (socket mode env) 2430 | (let ((tcp-stream nil) 2431 | (state 'state-01) 2432 | (trans-data nil) 2433 | (action-fn nil)) 2434 | (loop 2435 | (setq trans-data (get-transition-data state *event*) 2436 | action-fn (first trans-data) 2437 | env (funcall action-fn env tcp-stream) 2438 | state (second trans-data))))) 2439 | 2440 | (defvar *event* nil) 2441 | 2442 | (defun dicom-state-machine (socket mode env) 2443 | (let ((tcp-stream nil) 2444 | (state 'state-01) 2445 | (trans-data nil) 2446 | (action-fn nil) 2447 | (iteration 0)) 2448 | (loop 2449 | (case state 2450 | (state-01 (if (eq mode :server) 2451 | (setq tcp-stream 2452 | (accept-connection socket :wait t) 2453 | *event* 'event-05) 2454 | (if (= iteration 0) 2455 | (setq *event* 'event-01) 2456 | (return)))) 2457 | ((state-02 state-05 state-07 state-10 state-11 state-13) 2458 | (setq env (read-pdu tcp-stream env)))) 2459 | (setq trans-data (get-transition-data state *event*) 2460 | action-fn (first trans-data) 2461 | env (funcall action-fn env tcp-stream) 2462 | state (second trans-data) 2463 | iteration (1+ iteration))))) 2464 | 2465 | (defun get-transition-data (state event) 2466 | (let* ((state-entry (find state *state-table* :key #'first)) 2467 | (evlist (rest (rest state-entry))) 2468 | (ev-entry (find event evlist :test #'member :key #'first))) 2469 | (rest ev-entry))) 2470 | 2471 | (defun ae-05 (env tcp-stream) 2472 | "Issue connection open message" 2473 | nil) ;; return a fresh, empty environment 2474 | 2475 | (defun ae-06 (env tcp-stream) 2476 | "Determine acceptability of A-ASSOCIATE-RQ" 2477 | (cond ((and (remote-id-ok env tcp-stream) 2478 | (SOP-Class-UID-OK env)) 2479 | (setq *event* 'event-07) 2480 | (setq *presentation-contexts* 2481 | (check-presentation-contexts env))) 2482 | (t (setq *event* 'event-08) 2483 | (setq *reject-reasons* (reject-reasons env)))) 2484 | env) ;; return env unchanged 2485 | 2486 | (defun ae-07 (env tcp-strm) 2487 | "Issue A-Associate-AC message and send associated PDU" 2488 | (let ((limit (path-find '(:A-Associate-RQ 2489 | :User-Information-Item 2490 | :Max-DataField-Len-Item 2491 | Max-DataField-Len) 2492 | env))) 2493 | (setq *max-datafield-len* 2494 | (if (typep limit 'fixnum) (min limit #.PDU-Bufsize) 2495 | #.PDU-Bufsize)) 2496 | (apply #'send-pdu :A-Associate-AC env tcp-strm *args*) 2497 | (setq *args* nil))) 2498 | 2499 | (defun ae-08 (env tcp-strm) 2500 | "Issue A-Associate-RJ message and send associated PDU" 2501 | (apply #'send-pdu :A-Associate-RJ env tcp-strm *args*) 2502 | (setq *args* nil)) 2503 | 2504 | (defun ar-01 (env tcp-strm) 2505 | "Send A-Release-RQ PDU" 2506 | (send-pdu :A-Release-RQ env tcp-strm) 2507 | nil) 2508 | 2509 | (defun ar-02 (env tcp-strm) 2510 | "Issue A-Release message" 2511 | (setq *event* 'event-14) 2512 | nil) 2513 | 2514 | (defun ar-03 (env tcp-strm) 2515 | "Issue A-Release confirmation message, close connection" 2516 | (close-connection tcp-strm) 2517 | nil) 2518 | 2519 | (defun ar-04 (env tcp-strm) 2520 | "Send A-Release-RSP PDU" 2521 | (send-pdu :A-Release-RSP env tcp-strm) 2522 | nil) 2523 | 2524 | (defun aa-01 (env tcp-strm) 2525 | "Error detected -- send A-Abort PDU (Service-User-Initiated)" 2526 | (cond ((consp *args*) 2527 | (apply #'send-pdu :A-Abort env tcp-strm *args*) 2528 | (setq *args* nil)) 2529 | (t (send-pdu :A-Abort env tcp-strm 2530 | 'Abort-Source 0 'Abort-Diagnostic 2) 2531 | nil))) 2532 | 2533 | (defun aa-02 (env tcp-strm) 2534 | "ARTIM timeout" 2535 | (when (eq *mode* :Client) (close-connection tcp-strm)) 2536 | nil) 2537 | 2538 | (defun ae-01 (env tcp-strm) 2539 | (open-connection (path-find '(remote-hostname) env) 2540 | (path-find '(remote-port) env)) 2541 | (setq *event* 'event-02) 2542 | env) 2543 | 2544 | (defun ae-02 (env tcp-strm) 2545 | (send-pdu :A-Associate-RQ env *tcp-buffer* tcp-strm) 2546 | env) 2547 | 2548 | (defun read-pdu (tcp-stream env) 2549 | (let ((tail 6) ;; read only 6 bytes to start 2550 | (pdu-end 0) ;; will be set when PDU length is known 2551 | (connection-reset nil) 2552 | (timeout nil) 2553 | (eof? nil)) 2554 | (unless 2555 | (ignore-errors 2556 | (cond ((= tail (read-sequence *tcp-buffer* tcp-strm 2557 | :start 0 :end tail)) 2558 | (setq pdu-end ;; encoded PDU length + 6 bytes 2559 | (+ (decode-fixnum *tcp-buffer* 2 4) tail)) 2560 | (setq tail (read-sequence *tcp-buffer* tcp-strm 2561 | :start tail :end pdu-end)) 2562 | t) 2563 | (t (setq eof? t)))) 2564 | (setq connection-reset t)) 2565 | (setq *event* 2566 | (cond 2567 | (connection-reset 'event-17) 2568 | (timeout 'event-18) 2569 | (eof? 'event-17) 2570 | ((< tail pdu-end) 'event-17) 2571 | (t (let ((rule (get-rule (aref *tcp-buffer* head) :parser))) 2572 | (if rule ;; try to parse the message 2573 | (multiple-value-bind (next-byte new-env) 2574 | (rule-based-parser rule 2575 | env *tcp-buffer* (+ head 6) pdu-end) 2576 | (cond 2577 | ((eql new-env :Fail) 'event-19) 2578 | ((= next-byte pdu-end) 2579 | (setq env new-env) 2580 | (case (first rule) 2581 | (:A-Associate-AC 'event-03) 2582 | (:A-Associate-RJ 'event-04) 2583 | (:A-Associate-RQ 'event-06) 2584 | (:P-Data-TF 'event-10) 2585 | (:A-Release-RQ (if (eq *mode* :Client) 2586 | 'event-12A 2587 | 'event-12B)) 2588 | (:A-Release-RSP 'event-13) 2589 | (:A-Abort 'event-16))) 2590 | (t 'event-15) ;; inconsistent length PDU 2591 | )) 2592 | 'event-19))))) ;; unrecognized or invalid PDU 2593 | env)) 2594 | 2595 | (defun rule-based-parser (rule env buffer head tail) 2596 | (let ((init-head head) 2597 | (init-env env)) 2598 | (dolist (term (rest rule)) 2599 | (multiple-value-bind (next-byte new-env) 2600 | (parse-term term env buffer head tail) 2601 | (if (eq new-env :Fail) 2602 | (return (values init-head :Fail)) 2603 | (setq head next-byte env new-env)))) 2604 | ;; If nothing added to environment, return it unchanged. 2605 | ;; If anything added, package items added during parse 2606 | ;; into a tagged structure and add it at front. 2607 | (unless (eq env init-env) 2608 | (do ((item env (rest item)) 2609 | (next (rest env) (rest next))) 2610 | ((eq next init-env) 2611 | (setf (rest item) nil) 2612 | (setq env 2613 | (cons (first rule) (nreverse env))) 2614 | (setq env 2615 | ;; If environment additions duplicate 2616 | ;; items already there, ignore them. 2617 | (if (equal env (first init-env)) init-env 2618 | ;; Otherwise prepend new material. 2619 | (cons env init-env)))))) 2620 | (values head env))) 2621 | 2622 | (defun parse-term (term env tcp-buffer head tail) 2623 | (let ((init-head head)) 2624 | (cond 2625 | ((typep term 'fixnum) ;; required fixed byte value 2626 | (cond ((>= head tail) (setq env :Fail)) 2627 | ((= term (aref tcp-buffer head)) 2628 | (setq head (1+ head))) 2629 | (t (setq env :Fail)))) 2630 | ((eq term '=ignored-byte) 2631 | (when (> (setq head (1+ head)) tail) 2632 | (setq head init-head env :Fail))) 2633 | ((keywordp term) ;; a sub-item with own rule, call parser 2634 | (cond ((>= head tail) (setq env :Fail)) 2635 | (t (multiple-value-setq (head env) 2636 | (rule-based-parser 2637 | (get-rule item :parser) 2638 | env tcp-buffer head tail))))) 2639 | ((eq (first term) '>decode-var) 2640 | ;; ... 2641 | ) 2642 | ;; ...more clauses 2643 | ))) 2644 | 2645 | (defun parse-command (env *tcp-buffer* head tail) 2646 | (dolist (msgtype *Message-Type-List*) 2647 | (multiple-value-bind (next-byte new-env) 2648 | (rule-based-parser (get-rule msgtype :parser) 2649 | env *tcp-buffer* head tail) 2650 | (unless (eq new-env :Fail) 2651 | (return (values msgtype new-env)))))) 2652 | 2653 | ;;;----------------------------------------------------- 2654 | ;;; Chapter 9 2655 | ;;;----------------------------------------------------- 2656 | 2657 | (defun all-nodes (fms site) 2658 | (list (lymphatic-paths fms site) 2659 | (let ((parts (get-children fms site "regional part"))) 2660 | (append (list site 'parts) 2661 | (mapcar #'(lambda (part) (all-nodes fms part)) 2662 | parts))))) 2663 | 2664 | (defconstant *clinical-regions* 2665 | '(("Deep cervical lymphatic chain" "Va" "Vb") 2666 | ("Deep parotid lymphatic chain" "P") 2667 | ("Inferior deep lateral cervical lymphatic chain" "IV") 2668 | ("Jugular lymphatic chain" "VI" "IV") 2669 | ("Jugular lymphatic trunk" "VI" "IV") 2670 | ("Jugulo-omohyoid lymphatic chain" "III") 2671 | ("Jugulodigastric lymphatic chain" "IIa") 2672 | ("Left deep cervical lymphatic chain" "Va" "Vb") 2673 | ("Left inferior deep lateral cervical lymphatic chain" "IV") 2674 | ("Left jugular lymphatic tree" "IV") ;VI? 2675 | ("Left jugular lymphatic trunk" "VI" "IV") 2676 | ("Left retropharyngeal lymphatic chain" "RP") 2677 | ("Left submandibular lymphatic chain" "Ib") 2678 | ("Left superficial cervical lymphatic chain" ) 2679 | ("Left superior deep lateral cervical lymphatic chain" "Va") 2680 | ("Right deep cervical lymphatic chain" "Va" "Vb") 2681 | ("Right inferior deep lateral cervical lymphatic chain" "IV") 2682 | ("Right jugular lymphatic tree" "IV") ;VI? 2683 | ("Right jugular lymphatic trunk" "VI" "IV") 2684 | ("Right retropharyngeal lymphatic chain" "RP") 2685 | ("Right submandibular lymphatic chain" "Ib") 2686 | ("Right superficial cervical lymphatic chain" ) 2687 | ("Right superior deep lateral cervical lymphatic chain" "Va") 2688 | ("Submandibular lymph node" "Ib") 2689 | ("Submandibular lymphatic chain" "Ib") 2690 | ("Submental lymphatic chain" "Ia") 2691 | ("Superficial cervical lymphatic chain" ) 2692 | ("Superior deep lateral cervical lymphatic chain" 2693 | "IIa" "III" "IV"))) 2694 | 2695 | (defclass tumor-site () 2696 | ((name :initarg :name :accessor name) 2697 | (part-of :initarg :part-of :accessor part-of) 2698 | (parts :initarg :parts :accessor parts 2699 | :documentation "A list of symbols naming 2700 | daughter nodes")) 2701 | (:documentation "Each instance represents a single anatomic 2702 | site or larger anatomic region. The tree 2703 | structure implied by the parts and part-of 2704 | slots describes anatomic relationships of 2705 | tumor sites and groups of tumor sites.") 2706 | (:default-initargs :name nil :part-of nil :parts nil)) 2707 | 2708 | (defmethod initialize-instance :after ((site tumor-site) 2709 | &rest initargs) 2710 | "This method makes the site instance available by name" 2711 | (set (name site) site)) 2712 | 2713 | (defun print-tree (node &key (indent 0) (stream t)) 2714 | (when node 2715 | (tab-print (name node) stream indent t) 2716 | (mapc #'(lambda (x) (print-tree (symbol-value x) 2717 | :indent (+ indent 3) 2718 | :stream stream)) 2719 | (parts node)))) 2720 | 2721 | (defun assert-value (pred obj &optional val) 2722 | "converts an object value pair to an assertion named pred" 2723 | (if val (eval `(<- (,pred ,obj ,val))) 2724 | (eval `(<- (,pred ,obj))))) 2725 | 2726 | (defmethod initialize-instance :after ((site tumor-site) 2727 | &rest initargs) 2728 | "This method makes the site instance available by name 2729 | and registers a rule for the part-of slot." 2730 | (set (name site) site) 2731 | (assert-value 'part-of (name site) (part-of site))) 2732 | 2733 | (<- (within ?x ?x)) 2734 | 2735 | (<- (within ?x ?y) (and (part-of ?x ?z) 2736 | (within ?z ?y))) 2737 | 2738 | (<- (pt-movement ?x (0.1 0.1 0.1)) 2739 | (and (location ?x ?y) 2740 | (within ?y head-and-neck) 2741 | (immob-dev ?x mask))) 2742 | 2743 | (<- (setup-error ?x (0.5 0.5 0.5)) 2744 | (and (location ?x ?y) 2745 | (within ?y head-and-neck) 2746 | (immob-dev ?x mask))) 2747 | 2748 | (<- (pt-movement ?x (0.3 0.3 0.3)) 2749 | (and (location ?x ?y) 2750 | (within ?y head-and-neck) 2751 | (immob-dev ?x none))) 2752 | 2753 | (<- (setup-error ?x (0.8 0.8 0.8)) 2754 | (and (location ?x ?y) 2755 | (within ?y head-and-neck) 2756 | (immob-dev ?x none))) 2757 | 2758 | (<- (setup-error ?x (0.6 0.6 0.6)) 2759 | (and (location ?x ?y) 2760 | (within ?y lung) 2761 | (immob-dev ?x alpha-cradle))) 2762 | 2763 | (<- (pt-movement ?x (0.2 0.2 0.2)) 2764 | (and (location ?x ?y) 2765 | (within ?y lung) 2766 | (immob-dev ?x alpha-cradle))) 2767 | 2768 | (<- (tumor-movement ?x (0.0 0.0 0.0)) 2769 | (and (location ?x ?y) 2770 | (within ?y nasopharynx))) 2771 | 2772 | (<- (tumor-movement ?x (0.8 0.0 0.0)) 2773 | (and (location ?x ?y) 2774 | (within ?y lung) 2775 | (region ?x mediastinum))) 2776 | 2777 | (<- (tumor-movement ?x (0.5 0.5 1.0)) 2778 | (and (location ?x ?y) 2779 | (within ?y lung) 2780 | (region ?x lower-lobe))) 2781 | 2782 | (defconstant *chi-sq-factor* 1.88) 2783 | 2784 | (defun target-volume (tumor immob) 2785 | (assert-value 'location tumor (site tumor)) 2786 | (assert-value 'immob-dev tumor immob) 2787 | (let* ((setup-m (with-answer (setup-error ?y ?x) 2788 | (if (eql ?y tumor) (return ?x)))) 2789 | (tumor-m (with-answer (tumor-movement ?y ?x) 2790 | (if (eql ?y tumor) (return ?x)))) 2791 | (pt-m (with-answer (pt-movement ?y ?x) 2792 | (if (eql ?y tumor) (return ?x)))) 2793 | ;; prob-m is a list of the x, y and z margins 2794 | (prob-m (mapcar #'(lambda (m) (* m *chi-sq-factor*)) 2795 | (rms setup-m tumor-m pt-m)))) 2796 | (make-instance 'target 2797 | :contours (expand-volume tumor prob-m)))) 2798 | 2799 | (defun rms (list-1 list-2 list-3) 2800 | (mapcar #'(lambda (a b c) 2801 | (sqrt (+ (* a a) (* b b) (* c c)))) 2802 | list-1 list-2 list-3)) 2803 | 2804 | ;;;----------------------------------------------------- 2805 | ;;; Chapter 10 2806 | ;;;----------------------------------------------------- 2807 | 2808 | (defvar beam 'off "Allowed values: off on") 2809 | 2810 | (defvar current 'high "Allowed values: high low") 2811 | 2812 | (defvar target 'in "Allowed values: in out") 2813 | 2814 | (defun electron-mode () 2815 | (and (eql current 'low) (eql target 'out))) 2816 | 2817 | (defun xray-mode () 2818 | (and (eql current 'high) (eql target 'in))) 2819 | 2820 | (defun safe-mode () 2821 | (or (eql beam 'off) ;; safe for sure 2822 | (eql target 'in) ;; safe even with current high 2823 | (eql current 'low) ;; safe even with target out 2824 | )) 2825 | 2826 | (defun beam-on () 2827 | (if (eql beam 'off) (setf beam 'on))) 2828 | 2829 | (defun beam-off () 2830 | (if (eql beam 'on) (setf beam 'off))) 2831 | 2832 | (defun select-electrons () 2833 | (if (eql beam 'off) 2834 | (setf current 'low target 'out))) 2835 | 2836 | (defun select-xrays () 2837 | (if (eql beam 'off) 2838 | (setf target 'in current 'high))) 2839 | 2840 | (defun safe-mode () 2841 | (or (electron-mode) 2842 | (xray-mode) 2843 | )) 2844 | 2845 | (defun target-in () 2846 | (if (eql target 'out) (setf target 'in))) 2847 | 2848 | (defun target-out () 2849 | (if (eql target 'in) (setf target 'out))) 2850 | 2851 | (defun beam-on-with-guard () 2852 | (if (and (eql beam 'off) 2853 | (or (electron-mode) (xray-mode))) 2854 | (setf beam 'on))) 2855 | 2856 | (defvar accum 0.0) 2857 | 2858 | (defvar prescribed 0.0) 2859 | 2860 | (defvar tolerance 0.1) 2861 | 2862 | (defun safe-dose () 2863 | (< accum (+ prescribed tolerance))) 2864 | 2865 | (defun safe-linac () 2866 | (and (safe-mode) (safe-dose))) 2867 | 2868 | (defun deliver-dose () 2869 | (if (eql beam 'on) 2870 | (incf accum delta))) 2871 | 2872 | (defun beam-off-dosim () 2873 | (if (and (eql beam 'on) 2874 | (>= accum prescribed)) 2875 | (setf beam 'off))) 2876 | 2877 | (defun beam-on-dose-guard () 2878 | (if (and (eql beam 'off) 2879 | (or (electron-mode) (xray-mode)) 2880 | (and (< accum prescribed))) 2881 | (setf beam 'on))) 2882 | 2883 | ;;;----------------------------------------------------- 2884 | ;;; Appendix 2885 | ;;;----------------------------------------------------- 2886 | 2887 | (defmethod combine ((x number) (y number)) 2888 | (+ x y)) 2889 | 2890 | (defmethod combine ((x string) (y string)) 2891 | (concatenate 'string x y)) 2892 | 2893 | (defmethod combine (x y) 2894 | (list x y)) 2895 | 2896 | (defmethod combine ((x ice-cream) (y topping)) 2897 | (format nil "~A ice cream with ~A topping." (name x) (name y))) 2898 | 2899 | (defun map-image-fast (raw-image window level range) 2900 | (declare (fixnum window level range) 2901 | (type (simple-array (unsigned-byte 16) 2) raw-image)) 2902 | (let* ((x-dim (array-dimension raw-image 1)) 2903 | (y-dim (array-dimension raw-image 0)) 2904 | (new-image (make-array (list y-dim x-dim) 2905 | :element-type '(unsigned-byte 8))) 2906 | (map (make-graymap window level range))) 2907 | (declare (type fixnum x-dim y-dim)) 2908 | (declare (type (simple-array (unsigned-byte 8) 2) new-image)) 2909 | (declare (type (simple-array (unsigned-byte 8)) map)) 2910 | (dotimes (j y-dim) 2911 | (declare (fixnum j)) 2912 | (dotimes (i x-dim) 2913 | (declare (fixnum i)) 2914 | (setf (aref new-image j i) 2915 | (aref map (aref raw-image j i))))) 2916 | new-image)) 2917 | 2918 | ;;;----------------------------------------------------- 2919 | ;;; End of book code. 2920 | --------------------------------------------------------------------------------