Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Posting-Version: version B 2.10.2 9/18/84; site utcsri.UUCP
Path: utzoo!utcsri!petera
From: petera@utcsri.UUCP (Smith)
Newsgroups: net.micro
Subject: PC-LISP PACKAGE (article 13 of 13)
Message-ID: <2648@utcsri.UUCP>
Date: Sun, 27-Apr-86 14:37:11 EDT
Article-I.D.: utcsri.2648
Posted: Sun Apr 27 14:37:11 1986
Date-Received: Sun, 27-Apr-86 15:42:16 EDT
Distribution: net
Organization: CSRI, University of Toronto
Lines: 323

;;  MATCH.L for PC-LISP.EXE (V2.10)
;;  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;;  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.
;;
;;             March 15 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.
;;

(defun ProcessQueries (data-base)
       (prog (InputQuery)
        loop (patom '|query?|)
             (setq InputQuery (read))   
             (cond ((null InputQuery) (return)))
             (setq InputQuery (ExpandVariables InputQuery))
             (patom '|ans=|)
             (print (CompressVariables (retrieve InputQuery data-base)))
             (patom (ascii 10))   
             (go loop)
       )
)

;;
;;  Function (ExpandVariables List)
;;        Make atoms like ?a become lists like (*var* a) this replaces the
;;  read macro in LISPcraft that PC-LISP does not have. Operate recursively
;;  as follows. A null list has no expansion. An atom of the form ?xyz is 
;;  turned into (*var* xyz) by the (cons '*var* ...) expression. If the
;;  atom is of the form xyz then it is returned untouched. A list expansion
;;  is just the expansion of the car cons'ed with the expansion of the cdr.
;;

(defun ExpandVariables (List)
       (cond ((null List) ())
             ((atom List)    
                (cond ((eq '? (car (explode List)))    
                         (cons '*var* (list(implode(cdr(explode List)))))
                      )
                      (t List)
                )
             )
             (t (cons(ExpandVariables(car List))(ExpandVariables (cdr List))))
       )
)

;;
;; Opposite of Expand Variables - 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)
               )
            )
      )
)

;; insert item into database - just expand the ?x forms to (*var* x) in the
;; same manner that the read macro in LISPcraft page 305 would do then call
;; the index function to put the actual item into the data base.

(defun insert (item db) (index (ExpandVariables item) db))

;;
;; page 315 of LISPcraft add too !d-b1!
;; by calling index to insert the implications and base cases.
;;

(insert '(<- (scales ?x) (fish ?x)) '!d-b1!)       ; fishes have scales
(insert '(<- (fins ?x) (fish ?x)) '!d-b1!)         ; fishes have fins
(insert '(<- (legs ?x) (mammal ?x)) '!d-b1!)       ; some mammals have legs
(insert '(<- (mammal ?x) (dog ?x)) '!d-b1!)        ; a dog is a mammal
(insert '(<- (dog ?x) (poodle ?x)) '!d-b1!)        ; a poodle is a dog
(insert '(poodle Fido) '!d-b1!)                    ; fido is a poodle
(insert '(horse Terry) '!d-b1!)                    ; terry is a horse
(insert '(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).
;;

(ProcessQueries '!d-b1!)