home *** CD-ROM | disk | FTP | other *** search
/ Phoenix CD 2.0 / Phoenix_CD.cdr / 01e / lisp211.zip / MATCH.L < prev    next >
Lisp/Scheme  |  1986-05-08  |  9KB  |  300 lines

  1. ;;  MATCH.L for PC-LISP.EXE (V2.11)
  2. ;;  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  3. ;;  A DEDUCTIVE DATA BASE RETRIEVER AS PER LISPcraft CHAPTERS 21&22
  4. ;;  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  
  5. ;;        This file called match.l implements all of the functions in  
  6. ;;  chapters 21 and 22 of LISPcraft by R.Wilensky. Together they form     
  7. ;;  a deductive data base retriever with two access functions. One is   
  8. ;;  called (insert) and the other (retrieve). Insert takes implications
  9. ;;  and base cases and inserts them into the given data base. (retrieve)
  10. ;;  returns a list of matches made with the data base and any bindings
  11. ;;  neccssary to make the match true. Hence an output like (nil) means
  12. ;;  one match requiring no bindings. The functions have been slightly
  13. ;;  modified to run with PC-LISP.  Note that they require the PC-LISP.L
  14. ;;  file to be loaded specificially for the let macro and a few other
  15. ;;  goodies. If you put PC-LISP.L in the current directory it will be
  16. ;;  automatically loaded. Or you can put it in a library directory, see
  17. ;;  the (load) function.
  18. ;;
  19. ;;             March 15 1986  
  20. ;;                Peter Ashwood-Smith
  21. ;;
  22. ;;  Example queries:
  23. ;;            (mammal Fido)     gives (nil) meaning Yes he is a mammal
  24. ;;            (dog ?x)          gives (?x Fido) meaning Yes if (?x is Fido)
  25. ;;            (mammal ?x)       etc.. you get the idea.
  26. ;;            (? Fido)
  27. ;;
  28. ;;      You really cannot get much out of this example unless you get
  29. ;; the LISPcraft book. Have Fun!
  30.   
  31. ;;
  32. ;; Main processing Loop - input a data base query, expand the variables
  33. ;; ?x to (*var* x) as the read macro in LISPcraft page 295 would do then 
  34. ;; pass the request to the (retrieve) function.
  35. ;;
  36.  
  37. (setsyntax '|?| 'vmacro '(lambda()(list '*var* (read))))
  38.  
  39. (setq displace-macros t)   ;runs much faster if let is displaced at eval time
  40.  
  41. (defun ProcessQueries (data-base)
  42.        (prog (InputQuery)
  43.     loop (princ "query?")
  44.          (setq InputQuery (read))   
  45.          (cond ((null InputQuery) (return)))
  46.          (princ "ans=")
  47.          (patom (CompressVariables (retrieve InputQuery data-base)))
  48.          (princ (ascii 10))   
  49.          (go loop)
  50.        )
  51. )
  52.  
  53. ;;
  54. ;; Opposite of Read Macro for ? - turn list  elements like (*var* x) into
  55. ;; ?x
  56. ;;
  57.  
  58. (defun CompressVariables (List)
  59.        (cond ((null List) ())
  60.          ((atom List) List)
  61.          ((eq (car List) '*var*)
  62.         (implode (list '|?| (cadr List)))
  63.          )
  64.          (t (cons(CompressVariables(car List))(CompressVariables (cdr List))))
  65.        )
  66. )
  67.  
  68. ;;
  69. ;; top level matcher function, just drives the recursive next level
  70. ;; by setting bindings to nil.
  71. ;;
  72.  
  73. (defun match (pattern1 pattern2) 
  74.       (match-with-bindings pattern1 pattern2 nil)
  75. )
  76.  
  77. (defun match-with-bindings (pattern1 pattern2 bindings)
  78.       (cond ((pattern-var-p pattern1)
  79.            (variable-match pattern1 pattern2 bindings)
  80.         )
  81.         ((pattern-var-p pattern2)
  82.            (variable-match pattern2 pattern1 bindings)
  83.         )
  84.         ((atom pattern1)
  85.            (cond ((eq pattern1 pattern2) 
  86.              (list bindings)
  87.              )
  88.            )
  89.         )
  90.         ((atom pattern2) nil)
  91.         (t (let ((car-result    
  92.                (match-with-bindings
  93.              (car pattern1)(car pattern2) bindings)))     
  94.             (and car-result
  95.                (match-with-bindings
  96.              (cdr pattern1)
  97.              (cdr pattern2)
  98.              (car car-result)
  99.                )
  100.             )
  101.            )  
  102.         )
  103.       )   
  104. )
  105.  
  106. (defun variable-match (pattern-var item bindings)
  107.        (cond ((equal pattern-var item) (list bindings))
  108.          (t (let ((var-binding (get-binding pattern-var bindings)))
  109.           (cond (var-binding
  110.               (match-with-bindings var-binding item bindings))
  111.             ((not (contained-in pattern-var item bindings))
  112.               (list (add-binding pattern-var item bindings)))
  113.           )
  114.         )
  115.          )
  116.        )
  117. )
  118.  
  119. (defun contained-in (pattern-var item bindings)
  120.       (cond ((atom item) nil)
  121.         ((pattern-var-p item)
  122.           (or (equal pattern-var item)
  123.           (contained-in pattern-var 
  124.                    (get-binding item bindings)
  125.                 bindings)
  126.           )        
  127.         )
  128.         (t (or (contained-in pattern-var (car item) bindings)
  129.            (contained-in pattern-var (cdr item) bindings)
  130.            )
  131.         )         
  132.       )
  133. )
  134.  
  135. (defun add-binding (pattern-var item bindings)
  136.        (cons (list pattern-var item) bindings)
  137. )
  138.  
  139. (defun get-binding (pattern-var bindings)
  140.        (cadr (assoc pattern-var bindings))
  141.  
  142. (defun pattern-var-p (item)
  143.        (and (listp item) (eq '*var* (car item)))
  144. )
  145.  
  146. ;; 
  147. ;; Fast Data Base Manager Operations. Using matcher function above to perform
  148. ;; deductive retreival. Indexing as per LISPcraft chapter 22.
  149. ;;
  150.  
  151. (defun replace-variables(item)
  152.       (let ((!bindings ()))
  153.        (replace-variables-with-bindings item)))
  154.  
  155. (defun replace-variables-with-bindings(item)
  156.       (cond ((atom item) item)
  157.         ((pattern-var-p item)
  158.          (let ((var-binding (get-binding item !bindings)))
  159.           (cond (var-binding)
  160.             (t (let ((newvar (makevar (gensym 'var))))
  161.                 (setq !bindings
  162.                    (add-binding item newvar !bindings))
  163.                 newvar))
  164.           )
  165.          )
  166.         )
  167.         (t (cons (replace-variables-with-bindings (car item))
  168.              (replace-variables-with-bindings (cdr item))
  169.            )
  170.         )
  171.       )
  172. )
  173.  
  174. (defun makevar (atom)
  175.        (list '*var* atom)
  176. )
  177.  
  178. (defun query (request data-base)
  179.        (apply 'append (mapcar '(lambda(item)(match item request))  
  180.                   data-base
  181.               )
  182.        )
  183. )
  184.    
  185. (defun index (item data-base)
  186.       (let ((place (cond ((atom (car item)) (car item))
  187.              ((pattern-var-p (car item)) '*var*)
  188.              (t '*list*)
  189.            )   
  190.         )
  191.        )
  192.        (putprop place (cons (replace-variables item)(get place data-base))
  193.                 data-base)
  194.        (putprop data-base
  195.            (enter place (get data-base '*keys*)) 
  196.           '*keys*) 
  197.       )
  198. )
  199.   
  200. (defun enter (e l)
  201.       (cond ((not (memq e l)) (cons e l))
  202.         (t l)
  203.       )
  204. )
  205.  
  206. (defun fast-query (request data-base)
  207.       (cond ((pattern-var-p (car request))
  208.          (apply 'append  
  209.         (mapcar '(lambda(key)(query request (get key data-base)))
  210.              (get data-base '*keys*)
  211.         )
  212.          )
  213.         )
  214.         (t (append
  215.          (query request (get (cond ((atom (car request))
  216.                           (car request)
  217.                        )
  218.                        (t '*list*)
  219.                       )
  220.                       data-base
  221.                 )
  222.          )
  223.          (query request (get '*var* data-base))
  224.            )
  225.         )
  226.       )
  227. )   
  228.  
  229. ;;
  230. ;; deductive retreiver (LISPcraft page 314) use backward chaining to establish
  231. ;; bindings.
  232. ;;
  233.  
  234. (defun retrieve (request data-base)
  235.       (append
  236.       (fast-query request data-base)
  237.       (apply 'append  
  238.            (mapcar '(lambda(bindings)
  239.                 (retrieve
  240.                 (substitute-vars
  241.                    (get-binding '(*var* antecedent) bindings)
  242.                    bindings)
  243.                 data-base))
  244.             (fast-query (list '<- request '(*var* antecedent))
  245.                     data-base)
  246.         )
  247.       )
  248.       )
  249. )
  250.  
  251. ;;
  252. ;; substitute variables for bindings recursively. LISPcraft page 315.
  253. ;;
  254.  
  255. (defun substitute-vars (item bindings)
  256.       (cond ((atom item) item)
  257.         ((pattern-var-p item)
  258.            (let ((binding (get-binding item bindings)))
  259.             (cond (binding (substitute-vars binding bindings))
  260.               (t item)
  261.             )
  262.            )
  263.         )
  264.         (t (cons (substitute-vars (car item) bindings)
  265.              (substitute-vars (cdr item) bindings)
  266.            )
  267.         )
  268.       )
  269. )
  270.  
  271. ;;
  272. ;; page 315 of LISPcraft add too !d-b1!
  273. ;; by calling index to insert the implications and base cases.
  274. ;;
  275.  
  276. (index  '(<- (scales ?x) (fish ?x)) '!d-b1!)       ; fishes have scales
  277. (index  '(<- (fins ?x) (fish ?x)) '!d-b1!)         ; fishes have fins
  278. (index  '(<- (legs ?x) (mammal ?x)) '!d-b1!)       ; some mammals have legs
  279. (index  '(<- (mammal ?x) (dog ?x)) '!d-b1!)        ; a dog is a mammal
  280. (index  '(<- (dog ?x) (poodle ?x)) '!d-b1!)        ; a poodle is a dog
  281. (index  '(poodle Fido) '!d-b1!)                    ; fido is a poodle
  282. (index  '(horse Terry) '!d-b1!)                    ; terry is a horse
  283. (index  '(fish Eric) '!d-b1!)                      ; Eric is a fish
  284.  
  285. ;;
  286. ;; start processing queries from data base #1 which was entered above
  287. ;; some good things to try are (mammal Fido) which will return (nil)
  288. ;; meaning that one match was found needing no bindings to make it true.
  289. ;; this was established via the chain (poodle Fido)-->(dog Fido)-->
  290. ;; (mammal Fido).
  291. ;;
  292.  
  293. (defun run() (ProcessQueries '!d-b1!))
  294.  
  295. (princ "Data Base Retreiver Loaded and Ready To Go")
  296. (princ (ascii 10))
  297. (princ "Just type (run) to start it, have fun.")
  298. (princ (ascii 10))
  299.