[cl-unification-cvs] CVS cl-unification

[mantoniotti]

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