Update of /project/cl-unification/cvsroot/cl-unification In directory cl-net:/tmp/cvs-serv26579
Modified Files: apply-substitution.lisp Log Message: Added some functionality and comments.
--- /project/cl-unification/cvsroot/cl-unification/apply-substitution.lisp 2008/07/10 17:39:16 1.2 +++ /project/cl-unification/cvsroot/cl-unification/apply-substitution.lisp 2009/04/15 10:05:58 1.3 @@ -9,28 +9,68 @@ ;;;--------------------------------------------------------------------------- ;;; Substitution application.
-(defgeneric apply-substitution (substitution item)) +;;; apply-substitution -- +;;; +;;; EXCLUDE-VARS are variables that will just pass through (a list for +;;; the time being).
+(defgeneric apply-substitution (substitution item &optional exclude-vars))
-(defmethod apply-substitution ((substitution environment) (s symbol)) + +(defmethod apply-substitution ((substitution environment) (s symbol) + &optional (exclude-vars ())) + (declare (type list exclude-vars)) (cond ((variable-any-p s) s) ((variablep s) - (multiple-value-bind (val foundp) - (find-variable-value s substitution) - (cond (foundp val) - (t (warn "~S is a free variable in the current environment." - s) - s)))) + (if (member s exclude-vars :test #'eq) + s + (multiple-value-bind (val foundp) + (find-variable-value s substitution) + (cond (foundp val) + (t (warn "~S is a free variable in the current environment." + s) + s)))) + ) (t s)))
-(defmethod apply-substitution ((substitution environment) (l cons)) - (cons (apply-substitution substitution (first l)) - (apply-substitution substitution (rest l)))) +(defmethod apply-substitution ((substitution environment) (l cons) + &optional (exclude-vars ())) + (declare (type list exclude-vars)) + (cons (apply-substitution substitution (first l) exclude-vars) + (apply-substitution substitution (rest l) exclude-vars))) +
-(defmethod apply-substitution ((substitution environment) (l null)) +(defmethod apply-substitution ((substitution environment) (l null) + &optional exclude-vars) + (declare (ignore exclude-vars)) '())
+ +;;; compose-substitions -- +;;; The definition is a direct translation of TPL's definition at page 318. +;;; Usually these are done by directly composing and currying +;;; functions in ML/Haskell derivatives, but that is just being "lazy". +;;; The current definition may be too "eager", but the "correct" +;;; semantics should be preserved. + +(defun compose-substitutions (env2 env1) ; note the order. + (declare (type environment env2 env1)) + + (loop for env1-frame in (environment-frames env1) + collect + (loop for (var . term) in (frame-bindings env1-frame) + collect (make-binding var (apply-substitution env2 term)) + into result-bindings + finally (return (make-frame result-bindings))) + into frames + finally (return (make-environment :frames frames)))) + + + + +;;; ground-term -- + (defun ground-term (term &optional (substitution (make-empty-environment))) (apply-substitution substitution term))