layer@franz.UUCP (Kevin Layer) (05/19/89)
I assume that the following is what you're after (from chapters 21 and
22). I got it directly from Robert Wilensky...
Kevin
----------------------------------------
: chapter 22
(set-macro-character #\?
#'(lambda (stream char) (list '*var* (read stream t nil t))))
(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)
(if (eq pattern1 pattern2) (values t bindings)))
((atom pattern2) nil)
(t (multiple-value-bind
(flag carbindings)
(match-with-bindings
(car pattern1) (car pattern2) bindings)
(and flag
(match-with-bindings (cdr pattern1)
(cdr pattern2)
carbindings))))))
(defun variable-match (pattern-var item bindings)
(if (equal pattern-var item) (values t bindings)
(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))
(values t (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 pattern-var-p (item)
(and (listp item) (eq '*var* (car item))))
(defun get-binding (pattern-var bindings)
(cadr (assoc pattern-var bindings :test #'equal)))
; chapter 22
(defmacro add-to-data-base (item d-b-name)
`(setq ,d-b-name
(cons (replace-variables (quote ,item)) ,d-b-name)))
(defun replace-variables (item)
(values (replace-variables-with-bindings item nil)))
(defun replace-variables-with-bindings (item bindings)
(cond ((atom item) (values item bindings))
((pattern-var-p item)
(let ((var-binding (get-binding item bindings)))
(if var-binding
(values var-binding bindings)
(let ((newvar (makevar (gensym "VAR"))))
(values newvar
(add-binding item
newvar
bindings))))))
(t (multiple-value-bind
(newlhs lhsbindings)
(replace-variables-with-bindings
(car item)
bindings)
(multiple-value-bind
(newrhs finalbindings)
(replace-variables-with-bindings
(cdr item)
lhsbindings)
(values (cons newlhs newrhs)
finalbindings))))))
(defun makevar (sym)
(list '*var* sym))
(defun query (request data-base)
(mapcan #'(lambda (item)
(multiple-value-bind
(flag bindings)
(match item request)
(if flag (list bindings))))
data-base))
(defun index (item data-base)
(let ((place (cond ((atom (car item)) (car item))
((pattern-var-p (car item)) '*var*)
(t '*list*))))
(setf (get place data-base)
(cons (replace-variables item)
(get place data-base)))
(setf (get data-base '*keys*)
(adjoin place (get data-base '*keys*)))))
(defun fast-query (request data-base)
(if (pattern-var-p (car request))
(mapcan
#'(lambda (key)
(query request (get key data-base)))
(get data-base '*keys*))
(nconc
(query request
(get (if (atom (car request))
(car request)
'*list*)
data-base))
(query request
(get '*var* data-base)))))
(defun retrieve (request data-base)
(nconc
(fast-query request data-base)
(mapcan #'(lambda (bindings)
(retrieve
(substitute-vars
(get-binding '?antecedent bindings)
bindings)
data-base))
(fast-query `(<- ,request ?antecedent)
data-base))))
(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)))))