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 ,@declare) ,formula) - ,@formulator-options)))) + ,@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))