[rjain-utils-cvs] CVS formulate/src

[rjain]

Update of /project/rjain-utils/cvsroot/formulate/src
In directory cl-net:/tmp/cvs-serv28087/src

Modified Files:
	formulate.lisp metaobjects.lisp package.lisp variables.lisp 
Log Message:
add dynamic-formulators: formua-formulators which allow changing of the formula at run time

unify the procedure for accessing the formuator of a variable or slot


--- /project/rjain-utils/cvsroot/formulate/src/formulate.lisp	2009/11/11 08:52:10	1.4
+++ /project/rjain-utils/cvsroot/formulate/src/formulate.lisp	2009/11/19 00:44:14	1.5
@@ -7,6 +7,8 @@
 ;;; *** GENERAL DEFINITIONS ***
 ;;;
 
+(defvar *get-formulator* nil)
+
 (defvar *formulating* '()
   "The FORMULATOR, if any, that is being evaluated.")
 
@@ -116,3 +118,15 @@
 (defmethod formulator-value-changed
     ((sink lazy-formula-formulator-sink) source new-value old-value)
   (formulator-invalidate sink))
+
+;;;
+;;; DYNAMIC-FORMULATOR
+;;;
+
+(defclass dynamic-formulator (lazy-formula-formulator-sink)
+  ())
+
+(defmethod (setf formulator-value) (new-value (formulator dynamic-formulator))
+  (setf (formulator-formula formulator) new-value
+        (formulator-formula-function formulator) (compile nil `(lambda () ,new-value)))
+  (formulator-invalidate formulator))
--- /project/rjain-utils/cvsroot/formulate/src/metaobjects.lisp	2009/11/04 21:41:35	1.2
+++ /project/rjain-utils/cvsroot/formulate/src/metaobjects.lisp	2009/11/19 00:44:14	1.3
@@ -57,17 +57,15 @@
 
 (defvar *me*)
 
-(defvar *get-slot-formulator* nil)
-
 (defmethod slot-value-using-class :around
     (class object (slotd formulated-effective-slot-definition))
-  (if *get-slot-formulator*
+  (if *get-formulator*
       (call-next-method)
       (let ((*me* object))
         (formulator-value (call-next-method) 'unbound-slot (slot-definition-name slotd)))))
 
 (defmethod slot-formulator-using-class (class object (slotd formulated-effective-slot-definition))
-  (let ((*get-slot-formulator* t))
+  (let ((*get-formulator* t))
     (slot-value-using-class class object slotd)))
 
 (defmethod (setf slot-value-using-class) :around
@@ -80,3 +78,7 @@
 (declaim (inline my))
 (defun my (slot)
   (slot-value *me* slot))
+
+(defun slot-formulator (object slot-name)
+  (let ((*get-formulator* t))
+    (slot-value object slot-name)))
\ No newline at end of file
--- /project/rjain-utils/cvsroot/formulate/src/package.lisp	2009/11/11 08:53:07	1.3
+++ /project/rjain-utils/cvsroot/formulate/src/package.lisp	2009/11/19 00:44:14	1.4
@@ -29,5 +29,6 @@
                  #:formulated-slot-definition
                  #:formulated-direct-slot-definition
                  #:formulated-effective-slot-definition
+                 #:slot-formulator
                  #:slot-formulator-using-class))
   (:shadowing-import-from :formulate . #1#))
--- /project/rjain-utils/cvsroot/formulate/src/variables.lisp	2009/11/11 08:54:08	1.3
+++ /project/rjain-utils/cvsroot/formulate/src/variables.lisp	2009/11/19 00:44:14	1.4
@@ -12,7 +12,7 @@
      (setf (symbol-value ',name)
            (make-instance ',(or formulator-class
                                 (if formula-p
-                                    'lazy-formula-formulator-sink
+                                    'dynamic-formulator
                                     'simple-formulator-source))
                           'formula ',formula
                           'formula-function (lambda () (declare , at declare) ,formula)
@@ -20,7 +20,9 @@
      ',name))
 
 (defun formulate-variable (name)
-  (formulator-value (symbol-value name) 'unbound-variable name))
+  (if *get-formulator*
+      (symbol-value name)
+      (formulator-value (symbol-value name) 'unbound-variable name)))
 
 (defun (setf formulate-variable) (new-value name)
   (setf (formulator-value (symbol-value name)) new-value))