1 ;;;; -*- Mode: Lisp -*-
  2 
  3 ;;;; substitutions.lisp --
  4 ;;;; General CL structures unifier.
  5 ;;;; Substitution definitions.  Mostly a rehash of the usual SICP stuff.
  6 
  7 ;;;; See file COPYING for copyright licensing information.
  8 
  9 (in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow.
 10 
 11 ;;;---------------------------------------------------------------------------
 12 ;;; Bindings.
 13 
 14 (deftype binding () 'cons)
 15 
 16 (deftype bindings () 'list) ; An A-LIST.
 17 
 18 (defun make-binding (variable value)
 19   (cons variable value))
 20 
 21 (defun extend-bindings (variable value bindings)
 22   (acons variable value bindings))
 23 
 24 
 25 (defun binding-variable (b)
 26   (declare (type binding b))
 27   (car b))
 28 
 29 (defun (setf binding-variable) (v b)
 30   (declare (type binding b))
 31   (setf (car b) v))
 32 
 33 
 34 (defun binding-value (b)
 35   (declare (type binding b))
 36   (cdr b))
 37 
 38 
 39 (defun (setf binding-value) (v b)
 40   (declare (type binding b))
 41   (setf (cdr b) v))
 42 
 43 
 44 (defun bindings-values (bindings) (mapcar #'cdr bindings))
 45 
 46 (defun bindings-keys (bindings) (mapcar #'car bindings))
 47 
 48 
 49 
 50 (define-condition unification-variable-unbound (unbound-variable)
 51   ()
 52   )
 53 
 54 (define-condition unification-failure (simple-error)
 55   ())
 56 
 57 
 58 ;;;---------------------------------------------------------------------------
 59 ;;; Frames.
 60 
 61 (defstruct (frame (:constructor make-frame (&optional bindings)))
 62   (bindings () :type bindings))
 63 
 64 (defun empty-frame-p (f)
 65   (declare (type frame f))
 66   (null (frame-bindings f)))
 67 
 68 
 69 (defun find-variable-binding-in-frame (v f)
 70   (declare (type frame f))
 71   (assoc v (frame-bindings f)))
 72 
 73 
 74 (defun find-variable-value-in-frame (v f)
 75   (declare (type frame f))
 76   (let ((b (find-variable-binding-in-frame v f)))
 77     (declare (type (or null binding) b))
 78     (if b
 79         (values (cdr b) t)
 80         (values nil nil))))
 81 
 82 (defun frame-variables (frame)
 83   (mapcar 'binding-variable (frame-bindings frame)))
 84 
 85 
 86 (defun frame-values (frame)
 87   (mapcar 'binding-value (frame-bindings frame)))
 88 
 89 
 90 ;;;---------------------------------------------------------------------------
 91 ;;; Environments.
 92 
 93 (defstruct (environment (:print-object print-environment)
 94                         (:copier nil))
 95   (frames () :type list))
 96 
 97 (defun print-environment (env stream)
 98   (if *print-readably*
 99       (format stream "#S(ENVIRONMENT FRAMES ~S)"
100               (environment-frames env))
101       (print-unreadable-object (env stream :type nil :identity t)
102         (format stream "~:[~;EMPTY ~]UNIFY ENVIRONMENT: ~D frame~:P"
103                 (empty-environment-p env)
104                 (list-length (environment-frames env))))))
105 
106 (deftype substitution () 'environment)
107 
108 (defun substitution-p (x) (environment-p x))
109 
110 (defun first-frame (env)
111   (first (environment-frames env)))
112 
113 
114 (defun make-empty-environment ()
115   (make-environment :frames (list (make-frame))))
116 
117 (defun copy-environment (env)
118   (declare (type environment env))
119   (make-environment :frames (copy-list (environment-frames env))))
120 
121 (defun make-shared-environment (env &optional (pushp nil))
122   (declare (type environment env))
123   (make-environment :frames (if pushp
124                                 (cons (make-frame) (environment-frames env))
125                                 (environment-frames env))))
126 
127 (defun push-frame (env)
128   (declare (type environment env))
129   (push (make-frame) (environment-frames env)))
130 
131 (defun pop-frame (env)
132   (declare (type environment env))
133   (pop (environment-frames env)))
134 
135 
136 (defun make-expanded-environment (base-env)
137   (make-environment :frames (cons (make-frame) (environment-frames base-env))))
138 
139 (defun empty-environment-p (env)
140   (declare (type environment env))
141   (let ((env-frames (environment-frames env)))
142     (declare (type list env-frames))
143     (and (= 1 (list-length env-frames))
144          (empty-frame-p (first env-frames)))))
145 
146 (defparameter *null-environment* (make-empty-environment))
147 
148 
149 (defun find-variable-value (variable &optional (env *null-environment*) errorp)
150   (declare (type environment env))
151   (labels ((find-var-value (frames)
152              (cond (frames
153                     (multiple-value-bind (val foundp)
154                         (find-variable-value-in-frame variable (first frames))
155                       (if foundp
156                           (values val t)
157                           (find-var-value (rest frames)))))
158                    (errorp
159                     (error 'unification-variable-unbound :variable variable))
160                    (t (values nil nil))))
161            )
162     (find-var-value (environment-frames env))))
163 
164 
165 
166 (defun extend-environment (var pat &optional (env (make-empty-environment)))
167   (let ((first-frame (first-frame env)))
168     (setf (frame-bindings first-frame)
169           (extend-bindings var pat (frame-bindings first-frame)))
170     env))
171 
172 
173 (defun fill-environment (vars pats &optional (env (make-empty-environment)))
174   (map nil (lambda (v p) (extend-environment v p env)) vars pats)
175   env)
176 
177 
178 (defun fill-environment* (vars-pats &optional (env (make-empty-environment)))
179   (loop for (v . p) in vars-pats do (extend-environment v p env))
180   env)
181 
182 
183 (declaim (inline v?))
184 (declaim (ftype (function (symbol &optional environment boolean)
185                           (values t boolean))
186                 find-variable-value)
187          (ftype (function (symbol environment &optional boolean)
188                           (values t boolean))
189                 v?))
190 
191 (defun v? (s env &optional (plain-symbol-p nil))
192   (find-variable-value (if plain-symbol-p
193                            (make-var-name s)
194                            s)
195                        env))
196 
197 
198 (defun environment-variables (env)
199   (mapcan #'frame-variables (environment-frames env)))
200 
201 (defun environment-values (env)
202   (mapcan #'frame-values (environment-frames env)))
203 
204 
205 ;;;---------------------------------------------------------------------------
206 ;;; Simple debugging.
207 
208 (defun dump-frame (f &optional (out *standard-output*))
209   (declare (type frame f))
210   (loop for (var . value) in (frame-bindings f)
211         do (format out "~&~A~VT= ~A~%" var 8 value))
212   )
213 
214 (defun dump-environment (env &optional (out *standard-output*))
215   (declare (type environment env))
216   (if (empty-environment-p env)
217       (format out ">>> Empty unify environment ~S.~%" env)
218       (loop initially (format out ">>> Dumping unify environment ~S.~%" env)
219             for fr in (environment-frames env)
220             for fr-n downfrom (list-length (environment-frames env))
221             do (format out ">>> Frame ~D:~%" fr-n)
222             do (dump-frame fr out)
223             do (terpri out)
224             )))
225 
226 ;;;; end of file -- substitutions.lisp --