dos_compilers/Ashwood-Smith PC-LISP v3/MATCH.L

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