ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/MISC/PCLISP30.ZIP/MATCH.L

Text File | 1986-08-22 | 8.4 KB | 300 lines

;;  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))