; This file defines an "isa hierarchy" and a very simple conversational interface ; to the hierarchy. The conversation program is based on a matching function that ; is used to test the user's input. This match function is more powerful than ; is needed in this application and might be useful elsewhere. ; The isa hierarchy in this program is strict in the sense that a thing can only ; be isa-related to one category. If a whale is a mammal, it can't also be a fish. ; A set of isa-facts is built into the program, and it is possible to add new facts ; to this set. However, no method is provided for removing facts from the set. ; Calling the (talk) function initiates a conversation. The user's input must be ; in the form of a list, enclosed in parentheses. Only a few inputs are recognized. ; The input must be of one of the following forms (except that "a" and "an" are ; interchangeable) where ?thing and ?category match any word: ; ; (a ?thing is a ?category) ; (is a ?thing a ?category) ; (what is a ?thing) ; (what is an example of a ?thing) ; (why is a ?thing a ?category) ; ; The remaining functions in the first section of this file are all helper functions ; for this main (talk) function. (defun talk () (loop (princ "Your input>> ") (setq input (read)) (if (member input '((bye) (goodbye) (exit) (quit) (done)) :test #'equal) (return 'goodbye)) (respond input) (terpri) (terpri))) ; (respond input) responds to one line of the user's input. It does this by ; matching the input against various templates and calling an appropriate function ; to generate the response. (defun respond (input) (cond ((not (listp input)) (print '(sorry but i do not understand your input))) ((match-and-bind '((a an) ?thing is (a an) ?category) input) (assert-isa ?thing ?category)) ((match-and-bind '(is (a an) ?thing (a an) ?category) input) (test-isa ?thing ?category)) ((match-and-bind '(what is (a an) ?thing) input) (what-isa ?thing)) ((match-and-bind '(what is (a an) example of (a an) ?thing) input) (example-of ?thing)) ((match-and-bind '(why is (a an) ?thing (a an) ?category) input) (why-isa ?thing ?category)) (t (print '(sorry but i do not understand your input))) )) ; If there is a fact of the form (isa ), then ; (isa-chain thing) returns a list (a1 a2 a3 a4 ...)such that ; a1 = thing and for i > 1, ai is the category that is isa-related ; to the previous thing in the list. If there is no fact of the ; form (isa ) then the return value is nil. ; This function is used in several of the following functions. (defun isa-chain (thing) (let ((chain (list thing)) (binding (match-fact `(isa ,thing ?x)))) (if (null binding) nil (loop (setq chain (cons (getval '?x binding) chain)) (setq binding (match-fact `(isa ,(getval '?x binding) ?x))) (if (null binding) (return (reverse chain))) )) )) ; (what-isa ) responds to a question of the form (what is a ) (defun what-isa (thing) (setq ?x nil) (match-fact-and-bind `(isa ,thing ?x)) (if ?x (print `(a ,thing is a ,?x)) (print `(sorry -- i do not know what a ,thing is)) )) ; (example-of ) respondes to input of the form (what is an example of a ) (defun example-of (thing) (if (match-fact-and-bind `(isa ?x ,thing)) (print `(a ,?x is a ,thing)) (print `(i dont know of anything that is a ,thing)) )) ; (test-isa ) responds to a question of the form (is a ) (defun test-isa (thing category) (cond ((equal thing category) (print `(well obviously))) ((member category (isa-chain thing)) (print `(yes a ,thing is a ,category))) (t (print `(as far as i know a ,thing is not a ,category))) )) ; (assert-isa ) responds to input of the form (a is a ) ; by adding the fact (isa ) to the fact database, unless there is already ; an isa-rule for . It refuses to add a rule that does not agree with an already known ; isa-fact. (defun assert-isa (thing category) (let ((chain (isa-chain thing))) (cond ((equal thing category) (print `(duhh))) ((member category chain) (print `(i already know that a ,thing is a ,category))) ((> (length chain) 1) (print `(a ,thing cant be a ,category since i already know what a ,thing is))) (t (add-fact `(isa ,thing ,category)) (print `(ok i have learned that a ,thing is a ,category)))) )) ; (why-isa ) responds to a question of the form (why is a a ) (defun why-isa (thing category) (let ((chain (isa-chain thing))) (cond ((equal thing category) (print '(duhh))) ((null chain) (print `(sorry I dont know what a ,thing is))) ((member category chain) (print-isa-chain thing category chain)) (t (print `(but a ,thing is not a ,category as far as i know)))) )) ; print-isa-chain is a helper function for the why-isa function. It prints ; out the complete isa chain starting from (defun print-isa-chain (thing category chain) (print `(a ,thing is a ,category because)) (cond ( (and (> (length chain) 1) (equal category (second chain))) (terpri) (princ " ") (prin1 `(it is given as a basic fact that a ,thing is a ,category)) (terpri) ) ( t (loop (terpri) (princ " ") (prin1 `(a ,(car chain) is a ,(second chain))) (if (equal (second chain) category) (return)) (setq chain (cdr chain)) (if (null (cdr chain)) (return))) ; this case shouldn't happen (terpri) ) )) ; (getval var assoc-list) will return the value associated to the key, var, in ; an association list, assoc-list. This is used for getting variable bindings ; out of the association list returned by the match function. (defun getval (var assoc-list) (cdr (assoc var assoc-list))) ;----------------------------------------------------------------------------- ; This section of the file defines a facts database and several functions for ; manipulating it. The facts database is accessible ONLY through these function. ; The (add-fact fact) function is used for adding a new fact to the front of the facts ; database. ; The (match-fact pattern) function tests whether any fact in the database matches ; the function. It does this using by calling (match pattern fact) for each fact ; in the database until a match is found or all the facts have been tested. The match ; function is defined in the next section of this file. If no fact matches, then ; nil is returned. If some fact matches, then the return value is the same as the ; value returned by match -- either T, or an association list of variable bindings if ; the pattern includes variables. ; The (match-all-facts pattern) function matches the patter against all facts ; and returns a list of all the non-null values returned by the match function. ; The (match-fact-and-bind pattern) function acts just like (match-fact pattern) ; except that if the match succeeds, it also sets the value of each variable used ; in the pattern to the value that the variable matched. This is provided as a ; convenient way of accessing the matched values, but it suffers from all the usual ; problems of using global variables. (let ((*facts* '( (isa animal organism) (isa plant orgainsm) (isa mammal animal) (isa bird animal) (isa fish animal) (isa primate mammal) (isa monkey primate) (isa lemure primate) (isa ape primate) (isa human ape) (isa chimp ape) (isa dog mammal) (isa collie dog) (isa beagle dog) (isa robin bird) (isa bluejay bird) (isa duck bird) (isa penguin bird) (isa cat mammal) (isa whale mammal) (isa tuna fish) (isa trout fish) (isa tree plant) (isa flower plant) (isa elm tree) (isa maple tree) (isa conifer tree) (isa pine conifer) (isa fir conifer) (isa rose flower) (isa daisy flower) ))) (defun match-fact (question) (dolist (fact *facts*) (let ((test (match question fact))) (if test (return test))))) (defun match-fact-and-bind (question) (dolist (fact *facts*) (let ((test (match-and-bind question fact))) (if test (return test))))) (defun match-all-facts (question) (let ((answer nil)) (dolist (fact *facts*) (let ((test (match question fact))) (if test (setq answer (cons test answer))))) (reverse answer))) (defun add-fact (fact) (setq *facts* (cons fact *facts*))) ) ; end of (let ((*facts ... ;-------------------------------------------------------------------------------------------------- ; This section of the file defines a matching function (and a few variations on that function.) ; All the functions use "patterns" which are lists that are matched against other lists. ; A pattern can include: ; ; 1. A symbol whose name begins with ?, such as ?x or ?thing. This is a variable ; that will match any single item in the data. If the same variable is used more than ; once in the pattern, it must match the same item in both cases. ; 2. A symbol whose name begins with *. This is a variable that will match any zero ; or more items in the data. If the same variable is used more than once in the pattern, ; it must match the same item in both cases. ; 3. Any other atom. This will match only the exact same atom in the data. ; 4. A list of atoms, where the first thing in the list is NOT "test". This will ; match a single item in the data which can be equal to any one of the atoms in the list. ; 5. A list where the first thing in the list is "test". In this case, the list ; must have just one more item. That item is a Lisp expression that can include any ; variables that occurred prior to the current point in the pattern. The expression is ; evaluated, using the matched values of the variables. If the value if nil, then the ; test fails and the matching function will backtrack. If the value is non-null, then ; the test succeeds and the match function continues processing. Note that the "test" ; item in the pattern does not match anything in the data. An example is the pattern: ; (i like ?x (test (numberp ?x)) things namely *list (test (= (length *list) ?x))) ; (match pattern data) matches the pattern against the data. If the match fails, nil is ; returned. If the match succeeds and the pattern contains no variables, the return value ; is T. If the match succeeds and the pattern does contain variables, then the return ; value is an association list that associates each variable in the pattern with the ; thing in the data that was matched by that variable. (defun match (pattern data) (multiple-value-bind (matches bindings) (basic-match pattern data nil) (if matches (if (null bindings) t bindings) nil))) ; (match-and-bind pattern data) has exactly the same return value as (match pattern data), ; but as a side effect when the match succeeds, it sets the value of each variable in the ; pattern to the associated thing in the data. This is done to provide a convenient way ; to access those values. However, the variables are treated as global variables, so ; this feature must be used with care. (defun match-and-bind (pattern data) (multiple-value-bind (matches bindings) (basic-match pattern data nil) (if matches (if (null bindings) t (set-all bindings)) nil))) ; (basic-match pattern data bindings) is a recursive matching function that should be called ; at the top level with bindings = nil. In general, as the match proceeds, bindings is an ; association list containing matched values of all variables that have been matched so far. ; This function returns two values. The first value is either T or NIL to indicate whether ; or not the match succeeds. The second value is only useful when the match succeeds. In ; that case, the second value is the association list of all variable bindings produced by ; the match -- note that this can be NIL even if the match succeeds when there are no ; variables in the pattern. (defun basic-match (pattern data bindings) (cond ((null pattern) (if (null data) (values t bindings) nil)) ((list-var? (car pattern)) (if (null (cdr pattern)) (match-rest (car pattern) data bindings) (list-var-match pattern data bindings)) ) ((and (listp (car pattern)) (equal (car (car pattern)) 'test)) (and (apply-test (second (car pattern)) bindings) (basic-match (cdr pattern) data bindings))) ((null data) nil) ((listp (car pattern)) (if (member (car data) (car pattern)) (basic-match (cdr pattern) (cdr data) bindings) nil)) ((var? (car pattern)) (var-match pattern data bindings)) ((equal (car pattern) (car data)) (basic-match (cdr pattern) (cdr data) bindings)) (t nil) ) ) ; set-all is a helper function for match-and-bind (defun set-all (assoc-list) (dolist (pair assoc-list) (set (car pair) (cdr pair))) assoc-list) ; All the remaining functions in this file are helper functions for basic-match. ; No further comments on them are given. (defun var? (x) (and (symbolp x) (eql #\? (char (symbol-name x) 0)))) (defun list-var? (x) (and (symbolp x) (eql #\* (char (symbol-name x) 0)))) (defun starts-with (prefix lst) (cond ((null prefix) t) ((null lst) nil) (t (and (equal (car prefix) (car lst)) (starts-with (cdr prefix) (cdr lst)))) )) (defun bind (var val bindings) (cons (cons var val) bindings)) (defun var-match (pattern data bindings) (let* ( (var (car pattern)) (newval (car data)) (oldassoc (assoc var bindings)) ) (if oldassoc (if (equal newval (cdr oldassoc)) (basic-match (cdr pattern) (cdr data) bindings) nil) (basic-match (cdr pattern) (cdr data) (bind var newval bindings)) ))) (defun match-rest (list-var data bindings) (let ( (oldassoc (assoc list-var bindings)) ) (if oldassoc (if (equal data (cdr oldassoc)) (values t bindings) NIL) (values t (bind list-var data bindings)) )) ) (defun list-var-match (pattern data bindings) (let* ( (var (car pattern)) (newval nil) (oldassoc (assoc var bindings)) ) (if oldassoc (if (starts-with data (cdr oldassoc)) (basic-match (cdr pattern) (nthcdr (length (cdr oldassoc)) data) bindings) nil ) (loop (multiple-value-bind (test newbindings) (basic-match (cdr pattern) data (bind (car pattern) newval bindings)) (if test (return (values t newbindings)))) (if (null data) (return nil)) (setq newval (append newval (list (car data)))) (setq data (cdr data)) )))) (defun apply-test (test bindings) (if (null bindings) (eval test) (eval `(let (,@(make-bind-list bindings)) ,test)))) (defun make-bind-list (bindings) (if (null bindings) nil (cons `(,(caar bindings) (quote ,(cdar bindings))) (make-bind-list (cdr bindings)))))