300 lines
8.4 KiB
Plaintext
300 lines
8.4 KiB
Plaintext
|
;; MATCH.L for PC-LISP.EXE (V2.13)
|
||
|
|
;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||
|
|
;; A DEDUCTIVE DATA BASE RETRIEVER AS PER LISPcraft CHAPTERS 21&22
|
||
|
|
;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||
|
|
;; This file called match.l implements all of the functions in
|
||
|
|
;; chapters 21 and 22 of LISPcraft by R.Wilensky. Together they form
|
||
|
|
;; a deductive data base retriever with two access functions. One is
|
||
|
|
;; called (insert) and the other (retrieve). Insert takes implications
|
||
|
|
;; and base cases and inserts them into the given data base. (retrieve)
|
||
|
|
;; returns a list of matches made with the data base and any bindings
|
||
|
|
;; neccssary to make the match true. Hence an output like (nil) means
|
||
|
|
;; one match requiring no bindings. The functions have been slightly
|
||
|
|
;; modified to run with PC-LISP. Note that they require the PC-LISP.L
|
||
|
|
;; file to be loaded specificially for the let macro and a few other
|
||
|
|
;; goodies. If you put PC-LISP.L in the current directory it will be
|
||
|
|
;; automatically loaded. Or you can put it in a library directory, see
|
||
|
|
;; the (load) function.
|
||
|
|
;;
|
||
|
|
;; August 22nd 1986
|
||
|
|
;; Peter Ashwood-Smith
|
||
|
|
;;
|
||
|
|
;; Example queries:
|
||
|
|
;; (mammal Fido) gives (nil) meaning Yes he is a mammal
|
||
|
|
;; (dog ?x) gives (?x Fido) meaning Yes if (?x is Fido)
|
||
|
|
;; (mammal ?x) etc.. you get the idea.
|
||
|
|
;; (? Fido)
|
||
|
|
;;
|
||
|
|
;; You really cannot get much out of this example unless you get
|
||
|
|
;; the LISPcraft book. Have Fun!
|
||
|
|
|
||
|
|
;;
|
||
|
|
;; Main processing Loop - input a data base query, expand the variables
|
||
|
|
;; ?x to (*var* x) as the read macro in LISPcraft page 295 would do then
|
||
|
|
;; pass the request to the (retrieve) function.
|
||
|
|
;;
|
||
|
|
|
||
|
|
(setsyntax '|?| 'vmacro '(lambda()(list '*var* (read))))
|
||
|
|
|
||
|
|
(setq displace-macros t) ;runs much faster if let is displaced at eval time
|
||
|
|
|
||
|
|
(defun ProcessQueries (data-base)
|
||
|
|
(prog (InputQuery)
|
||
|
|
loop (princ "query?")
|
||
|
|
(setq InputQuery (read))
|
||
|
|
(cond ((null InputQuery) (return)))
|
||
|
|
(princ "ans=")
|
||
|
|
(patom (CompressVariables (retrieve InputQuery data-base)))
|
||
|
|
(princ (ascii 10))
|
||
|
|
(go loop)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
|
||
|
|
;;
|
||
|
|
;; Opposite of Read Macro for ? - turn list elements like (*var* x) into
|
||
|
|
;; ?x
|
||
|
|
;;
|
||
|
|
|
||
|
|
(defun CompressVariables (List)
|
||
|
|
(cond ((null List) ())
|
||
|
|
((atom List) List)
|
||
|
|
((eq (car List) '*var*)
|
||
|
|
(implode (list '|?| (cadr List)))
|
||
|
|
)
|
||
|
|
(t (cons(CompressVariables(car List))(CompressVariables (cdr List))))
|
||
|
|
)
|
||
|
|
)
|
||
|
|
|
||
|
|
;;
|
||
|
|
;; top level matcher function, just drives the recursive next level
|
||
|
|
;; by setting bindings to nil.
|
||
|
|
;;
|
||
|
|
|
||
|
|
(defun match (pattern1 pattern2)
|
||
|
|
(match-with-bindings pattern1 pattern2 nil)
|
||
|
|
)
|
||
|
|
|
||
|
|
(defun match-with-bindings (pattern1 pattern2 bindings)
|
||
|
|
(cond ((pattern-var-p pattern1)
|
||
|
|
(variable-match pattern1 pattern2 bindings)
|
||
|
|
)
|
||
|
|
((pattern-var-p pattern2)
|
||
|
|
(variable-match pattern2 pattern1 bindings)
|
||
|
|
)
|
||
|
|
((atom pattern1)
|
||
|
|
(cond ((eq pattern1 pattern2)
|
||
|
|
(list bindings)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
((atom pattern2) nil)
|
||
|
|
(t (let ((car-result
|
||
|
|
(match-with-bindings
|
||
|
|
(car pattern1)(car pattern2) bindings)))
|
||
|
|
(and car-result
|
||
|
|
(match-with-bindings
|
||
|
|
(cdr pattern1)
|
||
|
|
(cdr pattern2)
|
||
|
|
(car car-result)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
|
||
|
|
(defun variable-match (pattern-var item bindings)
|
||
|
|
(cond ((equal pattern-var item) (list bindings))
|
||
|
|
(t (let ((var-binding (get-binding pattern-var bindings)))
|
||
|
|
(cond (var-binding
|
||
|
|
(match-with-bindings var-binding item bindings))
|
||
|
|
((not (contained-in pattern-var item bindings))
|
||
|
|
(list (add-binding pattern-var item bindings)))
|
||
|
|
)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
|
||
|
|
(defun contained-in (pattern-var item bindings)
|
||
|
|
(cond ((atom item) nil)
|
||
|
|
((pattern-var-p item)
|
||
|
|
(or (equal pattern-var item)
|
||
|
|
(contained-in pattern-var
|
||
|
|
(get-binding item bindings)
|
||
|
|
bindings)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
(t (or (contained-in pattern-var (car item) bindings)
|
||
|
|
(contained-in pattern-var (cdr item) bindings)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
|
||
|
|
(defun add-binding (pattern-var item bindings)
|
||
|
|
(cons (list pattern-var item) bindings)
|
||
|
|
)
|
||
|
|
|
||
|
|
(defun get-binding (pattern-var bindings)
|
||
|
|
(cadr (assoc pattern-var bindings))
|
||
|
|
)
|
||
|
|
|
||
|
|
(defun pattern-var-p (item)
|
||
|
|
(and (listp item) (eq '*var* (car item)))
|
||
|
|
)
|
||
|
|
|
||
|
|
;;
|
||
|
|
;; Fast Data Base Manager Operations. Using matcher function above to perform
|
||
|
|
;; deductive retreival. Indexing as per LISPcraft chapter 22.
|
||
|
|
;;
|
||
|
|
|
||
|
|
(defun replace-variables(item)
|
||
|
|
(let ((!bindings ()))
|
||
|
|
(replace-variables-with-bindings item)))
|
||
|
|
|
||
|
|
(defun replace-variables-with-bindings(item)
|
||
|
|
(cond ((atom item) item)
|
||
|
|
((pattern-var-p item)
|
||
|
|
(let ((var-binding (get-binding item !bindings)))
|
||
|
|
(cond (var-binding)
|
||
|
|
(t (let ((newvar (makevar (gensym 'var))))
|
||
|
|
(setq !bindings
|
||
|
|
(add-binding item newvar !bindings))
|
||
|
|
newvar))
|
||
|
|
)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
(t (cons (replace-variables-with-bindings (car item))
|
||
|
|
(replace-variables-with-bindings (cdr item))
|
||
|
|
)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
|
||
|
|
(defun makevar (atom)
|
||
|
|
(list '*var* atom)
|
||
|
|
)
|
||
|
|
|
||
|
|
(defun query (request data-base)
|
||
|
|
(apply 'append (mapcar '(lambda(item)(match item request))
|
||
|
|
data-base
|
||
|
|
)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
|
||
|
|
(defun index (item data-base)
|
||
|
|
(let ((place (cond ((atom (car item)) (car item))
|
||
|
|
((pattern-var-p (car item)) '*var*)
|
||
|
|
(t '*list*)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
(putprop place (cons (replace-variables item)(get place data-base))
|
||
|
|
data-base)
|
||
|
|
(putprop data-base
|
||
|
|
(enter place (get data-base '*keys*))
|
||
|
|
'*keys*)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
|
||
|
|
(defun enter (e l)
|
||
|
|
(cond ((not (memq e l)) (cons e l))
|
||
|
|
(t l)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
|
||
|
|
(defun fast-query (request data-base)
|
||
|
|
(cond ((pattern-var-p (car request))
|
||
|
|
(apply 'append
|
||
|
|
(mapcar '(lambda(key)(query request (get key data-base)))
|
||
|
|
(get data-base '*keys*)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
(t (append
|
||
|
|
(query request (get (cond ((atom (car request))
|
||
|
|
(car request)
|
||
|
|
)
|
||
|
|
(t '*list*)
|
||
|
|
)
|
||
|
|
data-base
|
||
|
|
)
|
||
|
|
)
|
||
|
|
(query request (get '*var* data-base))
|
||
|
|
)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
|
||
|
|
;;
|
||
|
|
;; deductive retreiver (LISPcraft page 314) use backward chaining to establish
|
||
|
|
;; bindings.
|
||
|
|
;;
|
||
|
|
|
||
|
|
(defun retrieve (request data-base)
|
||
|
|
(append
|
||
|
|
(fast-query request data-base)
|
||
|
|
(apply 'append
|
||
|
|
(mapcar '(lambda(bindings)
|
||
|
|
(retrieve
|
||
|
|
(substitute-vars
|
||
|
|
(get-binding '(*var* antecedent) bindings)
|
||
|
|
bindings)
|
||
|
|
data-base))
|
||
|
|
(fast-query (list '<- request '(*var* antecedent))
|
||
|
|
data-base)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
|
||
|
|
;;
|
||
|
|
;; substitute variables for bindings recursively. LISPcraft page 315.
|
||
|
|
;;
|
||
|
|
|
||
|
|
(defun substitute-vars (item bindings)
|
||
|
|
(cond ((atom item) item)
|
||
|
|
((pattern-var-p item)
|
||
|
|
(let ((binding (get-binding item bindings)))
|
||
|
|
(cond (binding (substitute-vars binding bindings))
|
||
|
|
(t item)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
(t (cons (substitute-vars (car item) bindings)
|
||
|
|
(substitute-vars (cdr item) bindings)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
|
||
|
|
;;
|
||
|
|
;; page 315 of LISPcraft add too !d-b1!
|
||
|
|
;; by calling index to insert the implications and base cases.
|
||
|
|
;;
|
||
|
|
|
||
|
|
(index '(<- (scales ?x) (fish ?x)) '!d-b1!) ; fishes have scales
|
||
|
|
(index '(<- (fins ?x) (fish ?x)) '!d-b1!) ; fishes have fins
|
||
|
|
(index '(<- (legs ?x) (mammal ?x)) '!d-b1!) ; some mammals have legs
|
||
|
|
(index '(<- (mammal ?x) (dog ?x)) '!d-b1!) ; a dog is a mammal
|
||
|
|
(index '(<- (dog ?x) (poodle ?x)) '!d-b1!) ; a poodle is a dog
|
||
|
|
(index '(poodle Fido) '!d-b1!) ; fido is a poodle
|
||
|
|
(index '(horse Terry) '!d-b1!) ; terry is a horse
|
||
|
|
(index '(fish Eric) '!d-b1!) ; Eric is a fish
|
||
|
|
|
||
|
|
;;
|
||
|
|
;; start processing queries from data base #1 which was entered above
|
||
|
|
;; some good things to try are (mammal Fido) which will return (nil)
|
||
|
|
;; meaning that one match was found needing no bindings to make it true.
|
||
|
|
;; this was established via the chain (poodle Fido)-->(dog Fido)-->
|
||
|
|
;; (mammal Fido).
|
||
|
|
;;
|
||
|
|
|
||
|
|
(defun run() (ProcessQueries '!d-b1!))
|
||
|
|
|
||
|
|
(princ "Data Base Retreiver Loaded and Ready To Go")
|
||
|
|
(princ (ascii 10))
|
||
|
|
(princ "Just type (run) to start it, have fun.")
|
||
|
|
(princ (ascii 10))
|