[rjain-utils-cvs] CVS formulate/src
rjain
rjain at common-lisp.net
Wed Nov 4 21:41:35 UTC 2009
Update of /project/rjain-utils/cvsroot/formulate/src
In directory cl-net:/tmp/cvs-serv29200/src
Modified Files:
formulate.lisp metaobjects.lisp package.lisp variables.lisp
Removed Files:
tests.lisp
Log Message:
Refactor a bit and get everything working for the basic lazy evaluation
and unconditional propagation scenario.
--- /project/rjain-utils/cvsroot/formulate/src/formulate.lisp 2007/11/02 20:45:39 1.1.1.1
+++ /project/rjain-utils/cvsroot/formulate/src/formulate.lisp 2009/11/04 21:41:35 1.2
@@ -1,48 +1,108 @@
(in-package :formulate)
+(deftype list-of (elt-type)
+ 'list)
+
(defvar *formulating* '()
- "Dynamically rebound each time we start computing a formula with the
-FORMULATOR CONSed to the front of it.")
+ "The FORMULATOR, if any, that is being evaluated.")
(define-condition set-formulated-location (cell-error)
())
-(defclass standard-formulator-source ()
- (reverse-dependencies :initform '() :type list :accessor reverse-dependencies)
- (value)
- (eager-propagation :initform t))
+(defgeneric formulator-value (formulator
+ &optional unbound-condition cell-name))
-(defclass standard-formulator-sink ()
- ((eager-recomputation :initform nil)))
-(defclass standard-formulator (standard-formulator-source standard-formulator-sink)
- ((formula :initarg formula :initform (error "need to specify a formula")
- :accessor formulator-formula)
- (formula-function :initarg formula-function :initform (error "need to specify a formula-function") :type function
- :accessor formulator-formula-function)))
+(defmethod formulator-value :around (formulator
+ &optional unbound-condition cell-name)
+ (when *formulating*
+ (note-formula-dependency formulator *formulating*))
+ (if (formulator-value-validp formulator)
+ (call-next-method)
+ (error unbound-condition :name cell-name)))
+
+(defgeneric formulator-value-changed (sink source new-value old-value))
+
+(defclass simple-formulator-source ()
+ ((dependents :initform '()
+ :type (list-of formulator-sink)
+ :accessor formulator-dependents)
+ (value))
+ (:documentation "FORMULATOR-SOURCE implementation that unconditionally
+ notifies all sinks that depend on it every time its value is changed."))
+
+(defmethod initialize-instance :after ((formulator simple-formulator-source)
+ &key ((formula formula)) ((formula-function formula-function)))
+ (when formula-function
+ (setf (slot-value formulator 'value) (funcall formula-function))))
+
+(defmethod formulator-value-validp ((source simple-formulator-source))
+ (slot-boundp source 'value))
+
+(defmethod formulator-invalidate ((source simple-formulator-source))
+ (slot-makunbound source 'value))
+
+(defmethod formulator-value ((formulator simple-formulator-source)
+ &optional cond cell)
+ (slot-value formulator 'value))
+
+(defmethod (setf formulator-value) (new-value (formulator simple-formulator-source))
+ (let ((old-value (and (formulator-value-validp formulator)
+ (formulator-value formulator)))
+ (result (setf (slot-value formulator 'value) new-value)))
+ (dolist (dependent (formulator-dependents formulator))
+ (formulator-source-value-changed dependent formulator new-value old-value))
+ result))
-(defun formulate (formulator unbound-condition cell-name)
- (if (null formulator)
- (error unbound-condition :name cell-name)
- (if (slot-boundp formulator 'value)
- (slot-value formulator 'value)
- (compute-formula formulator))))
-
-(defmethod compute-formula ((formulator formulator))
- (note-formula-dependency formulator)
- (setf (reverse-dependencies formulator) '())
- (let ((*formulating* (cons formulator *formulating*)))
- (setf (slot-value formulator 'value)
- (funcall (formulator-formula-function formulator))))
- (when (slot-value formulator 'eager-propagation)
- (mapcar (lambda (dependent) (note-dependency-value-changed dependent formulator))
- (slot-value formulator 'reverse-dependencies))))
-
-(defmethod note-formula-dependency ((formulator standard-formulator))
- (dolist (surrounding-formulator *formulating*)
- (pushnew formulator (reverse-dependencies surrounding-formulator))))
-
-(defmethod note-dependency-value-changed ((dependent standard-formulator) (dependency standard-formulator))
- (slot-makunbound dependent 'value)
- (when (slot-value dependent 'eager-recomputation)
- (compute-formula dependent)))
\ No newline at end of file
+(defclass formula-formulator-sink ()
+ ((formula :initarg formula
+ :accessor formulator-formula)
+ (formula-function :initarg formula-function
+ :initform (error "need to specify a formula-function")
+ :type function
+ :accessor formulator-formula-function))
+ (:documentation "FORMULATOR-SINK implementation that recomputes the
+ formula every time it is asked for a value."))
+
+(defmethod formulator-value ((formulator formula-formulator-sink)
+ &optional cond cell)
+ (funcall (formulator-formula-function formulator)))
+
+(defmethod formulator-value-validp ((formulator formula-formulator-sink))
+ (slot-boundp formulator 'formula))
+
+(defclass lazy-formula-formulator-sink (formula-formulator-sink)
+ ((source :initarg source
+ :initform (make-instance 'simple-formulator-source)
+ :accessor formulator-source
+ :documentation "FORMULATOR-SOURCE that contains the cached
+ value and propagates changes to sinks that refer to this
+ formulator's parent cell."))
+ (:documentation "FORMULATOR-SINK implementation that lazily recomputes
+ and caches the formula's value."))
+
+(defmethod formulator-dependents ((formulator lazy-formula-formulator-sink))
+ (formulator-dependents (formulator-source formulator)))
+
+(defmethod (setf formulator-dependents) (new-value (formulator lazy-formula-formulator-sink))
+ (setf (formulator-dependents (formulator-source formulator)) new-value))
+
+(defmethod formulator-value ((formulator lazy-formula-formulator-sink)
+ &optional cond cell)
+ (let ((source (formulator-source formulator)))
+ (if (formulator-value-validpxo source)
+ (let ((*formulating* nil))
+ (formulator-value source cond cell))
+ (let ((*formulating* formulator))
+ ;; TODO: remove dependencies when dependencies change
+ (setf (formulator-value source) (call-next-method))))))
+
+(defmethod formulator-invalidate ((formulator lazy-formula-formulator-sink))
+ (formulator-invalidate (formulator-source formulator)))
+
+(defmethod note-formula-dependency (source sink)
+ (pushnew sink (formulator-dependents source)))
+
+(defmethod formulator-source-value-changed
+ ((sink lazy-formula-formulator-sink) source new-value old-value)
+ (formulator-invalidate sink))
--- /project/rjain-utils/cvsroot/formulate/src/metaobjects.lisp 2007/11/02 20:45:39 1.1.1.1
+++ /project/rjain-utils/cvsroot/formulate/src/metaobjects.lisp 2009/11/04 21:41:35 1.2
@@ -7,62 +7,75 @@
t)
(defclass formulated-slot-definition (standard-slot-definition)
- ((formulator-class :initform 'standard-formulator :initarg formulator-class :accessor formulator-class)
- (formulator-options :initform '() :initarg formulator-options :accessor formulator-options)))
+ ((formulator-class :initarg formulator-class
+ :accessor formulator-class)
+ (formulator-options :initform '()
+ :initarg formulator-options
+ :accessor formulator-options)))
(defclass formulated-direct-slot-definition (formulated-slot-definition standard-direct-slot-definition)
())
+(defmethod initialize-instance :after ((instance formulated-direct-slot-definition)
+ &key ((formula-p formula-p)))
+ "default formulator-class based on whether this is a formula or not"
+ (unless (slot-boundp instance 'formulator-class)
+ (setf (slot-value instance 'formulator-class)
+ (if formula-p
+ 'lazy-formula-formulator-sink
+ 'simple-formulator-source))))
+
(defmethod slot-definition-initfunction ((slotd formulated-direct-slot-definition))
(lambda () (apply 'make-instance (formulator-class slotd)
'formula (slot-definition-initform slotd)
'formula-function (call-next-method)
(formulator-options slotd))))
-(defmethod initialize-instance :after ((instance formulated-slot-definition) &key ((formula-p formula-p) t))
- (declare (ignore formula-p))
- ;; FORMULA-P is already reflected in the class chosen by DIRECT-SLOT-DEFINITION-CLASS
- )
-
-(defmethod direct-slot-definition-class ((class formulated-class)
- &key ((formula-p formula-p) nil) &allow-other-keys)
- (if formula-p
- 'formulated-direct-slot-definition
- 'formulated-source-))
+(defmethod direct-slot-definition-class ((class formulated-class) &key &allow-other-keys)
+ ;; formula-p only indicates whether this is a formula sink as well as
+ ;; a source.
+ 'formulated-direct-slot-definition)
(defclass formulated-effective-slot-definition (formulated-slot-definition standard-effective-slot-definition)
())
-(defvar *computing-formulated-eslotd* nil)
-
(defmethod effective-slot-definition-class ((class formulated-class) &key &allow-other-keys)
- (if *computing-formulated-eslotd*
- 'formulated-effective-slot-definition
- (call-next-method)))
+ ;; formula-p only indicates whether this is a formula sink as well as
+ ;; a source.
+ 'formulated-effective-slot-definition)
(defmethod compute-effective-slot-definition ((class formulated-class) slot-name dslotds)
- (declare (type list dslotds))
- (let ((*computing-formulated-eslotd*
- (find-if (lambda (slotd) (typep slotd 'formulated-direct-slot-definition)) dslotds)))
- (call-next-method)))
+ (let ((eslotd (call-next-method))
+ (most-specific-fdslotd
+ (find-if
+ (lambda (slotd)
+ (typep slotd 'formulated-direct-slot-definition))
+ dslotds)))
+ (setf (slot-value eslotd 'formulator-class)
+ (formulator-class most-specific-fdslotd))
+ eslotd))
(defvar *me*)
-(defmethod slot-value-using-class ((class formulated-class) object (slotd formulated-effective-slot-definition))
- (let ((*me* object))
- (formulate (call-next-method) 'unbound-slot (slot-definition-name slotd))))
+(defvar *get-slot-formulator* nil)
-(define-condition set-formulated-slot (set-formulated-location)
- ())
-
-(defmethod (setf slot-value-using-class) (new-value
- (class formulated-class) object (slotd formulated-effective-slot-definition))
- (declare (ignore new-value class))
- (call-next-method)
- #+nil ; this doesn't seem to work...
- (if (typep object 'formulator)
+(defmethod slot-value-using-class :around
+ (class object (slotd formulated-effective-slot-definition))
+ (if *get-slot-formulator*
(call-next-method)
- (error 'set-formulated-slot :name (slot-definition-name slotd))))
+ (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))
+ (slot-value-using-class class object slotd)))
+
+(defmethod (setf slot-value-using-class) :around
+ (new-value
+ class object (slotd formulated-effective-slot-definition))
+ (if (slot-boundp-using-class class object slotd)
+ (setf (formulator-value (slot-formulator-using-class class object slotd)) new-value)
+ (call-next-method)))
(declaim (inline my))
(defun my (slot)
--- /project/rjain-utils/cvsroot/formulate/src/package.lisp 2007/11/02 20:45:35 1.1.1.1
+++ /project/rjain-utils/cvsroot/formulate/src/package.lisp 2009/11/04 21:41:35 1.2
@@ -1,11 +1,15 @@
(defpackage :formulate
(:export #:formulator
- #:standard-formulator
+ #:simple-formulator-source
+ #:formula-formulator-sink
+ #:lazy-formula-formulator-sink
#:formulated-class
#:my
#:formula-p
+ #:formulator-class
+ #:formulator-options
#:define-formulated-variable)
- (:use :cl :mop))
+ (:use :cl #.(first '(#+sbcl :sb-mop :mop))))
(defpackage :formulate-user
(:use :cl :formulate))
\ No newline at end of file
--- /project/rjain-utils/cvsroot/formulate/src/variables.lisp 2007/11/02 20:45:39 1.1.1.1
+++ /project/rjain-utils/cvsroot/formulate/src/variables.lisp 2009/11/04 21:41:35 1.2
@@ -1,25 +1,22 @@
(in-package :formulate)
(defmacro define-formulated-variable (name formula
- &key declare
+ &key declare
documentation
- (formulator-class 'standard-formulator)
+ (formulator-class 'lazy-formula-formulator-sink)
formulator-options)
`(progn
(define-symbol-macro ,name (formulate-variable ',name))
(setf (documentation ',name 'variable) ,documentation)
- (setf (get name 'formulator)
+ (setf (symbol-value ',name)
(make-instance ',formulator-class
'formula ',formula
'formula-function (lambda () (declare , at declare) ,formula)
- , at formulator-options))))
+ , at formulator-options))
+ ',name))
(defun formulate-variable (name)
- (formulate (get name 'formulator) 'unbound-variable name))
-
-(define-condition set-formuated-variable (set-formulated-location)
- ())
+ (formulator-value (symbol-value name) 'unbound-variable name))
(defun (setf formulate-variable) (new-value name)
- (declare (ignore new-value))
- (error 'set-formulated-variable :name name))
+ (setf (formulator-value (symbol-value name)) new-value))
More information about the Rjain-utils-cvs
mailing list