November 2009 - rjain-utils-cvs@common-lisp.net

[rjain-utils-cvs] CVS formulate/examples
by rjain 19 Nov '09

19 Nov '09

Update of /project/rjain-utils/cvsroot/formulate/examples In directory cl-net:/tmp/cvs-serv27901/examples Modified Files: simple.lisp Log Message: another formulated class for more interesting testing --- /project/rjain-utils/cvsroot/formulate/examples/simple.lisp 2009/11/11 08:57:21 1.3 +++ /project/rjain-utils/cvsroot/formulate/examples/simple.lisp 2009/11/19 00:41:57 1.4 @@ -25,6 +25,20 @@ (area formula-p t :initform (expt (my 'side) 2) :reader area)) (:metaclass formulated-class)) +(defclass polygon () + ((side :initarg side :initform 0 :accessor polygon-side) + (num-sides :initarg num-sides :initform 1 :accessor polygon-num-sides) + (perimeter formula-p t + :initform (* (my 'side) (my 'num-sides)) + :reader perimeter) + (area formula-p t + :initform (* 1/4 + (my 'num-sides) + (expt (my 'side) 2) + (/ (tan (/ pi (my 'num-sides))))) + :reader area)) + (:metaclass formulated-class)) + (defclass circle () ((radius :initform 0 :initarg radius :accessor circle-radius) (perimeter formula-p t :initform (* (my 'radius) 2 pi) :reader perimeter)

1 0

[rjain-utils-cvs] CVS formulate/src/clim-ui
by rjain 11 Nov '09

11 Nov '09

Update of /project/rjain-utils/cvsroot/formulate/src/clim-ui In directory cl-net:/tmp/cvs-serv15937/src/clim-ui Log Message: Directory /project/rjain-utils/cvsroot/formulate/src/clim-ui added to the repository

1 0

[rjain-utils-cvs] CVS formulate/src
by rjain 11 Nov '09

11 Nov '09

Update of /project/rjain-utils/cvsroot/formulate/src In directory cl-net:/tmp/cvs-serv9682/src Added Files: protocol.lisp Log Message: add definitions for formulator protocol and subprotocols --- /project/rjain-utils/cvsroot/formulate/src/protocol.lisp 2009/11/11 08:58:02 NONE +++ /project/rjain-utils/cvsroot/formulate/src/protocol.lisp 2009/11/11 08:58:02 1.1 (defprotocol formulator ()) (defprotocol formulator-source (formulator)) (defprotocol formulator-sink (formulator)) (defprotocol formula-formulator (formulator)) (defgeneric formulator-value (formulator &optional unbound-condition cell-name)) (defsignature formulator-value (formulator-source)) (defgeneric (setf formulator-value) (new-value formulator)) ;; separate formulator-root that allows setf? (defsignature (setf formulator-value) (t formulator-source)) (defgeneric formulator-value-validp (formulator)) (defsignature formulator-value-validp (formulator-source)) (defgeneric formulator-invalidate (formulator)) (defsignature formulator-invalidate (formulator-source)) (defgeneric formulator-dependents (formulator)) (defsignature formulator-dependents (formulator-source)) (defgeneric formulator-value-changed (sink source new-value old-value)) (defsignature formulator-value-changed (formulator-sink formulator-source t t)) (defgeneric formulator-formula (formulator)) ; change to formulator-formula-source? (defsignature formulator-formula (formula-formulator)) ; change to formulator-formula-source? (defgeneric formulator-formula-function (formulator)) ; change to formulator-function? (defsignature formulator-formula-function (formula-formulator)) ; change to formulator-function? (defgeneric (setf formulator-value) (new-formula formulator)) (defsignature (setf formulator-value) (function formula-formulator)) ; separate dynamic-formula-formulator subprotocol?

1 0

[rjain-utils-cvs] CVS formulate/examples
by rjain 11 Nov '09

11 Nov '09

Update of /project/rjain-utils/cvsroot/formulate/examples In directory cl-net:/tmp/cvs-serv9595/examples Modified Files: simple.lisp Log Message: fix perimeter formula and provide default side lengths --- /project/rjain-utils/cvsroot/formulate/examples/simple.lisp 2009/11/04 21:41:34 1.2 +++ /project/rjain-utils/cvsroot/formulate/examples/simple.lisp 2009/11/11 08:57:21 1.3 @@ -1,7 +1,8 @@ (in-package :formulate-user) +;; default is for variables to be formulas (define-formulated-variable *x* 5 - :formulator-class simple-formulator-source) + :formula-p nil) (define-formulated-variable *y* (expt *x* 2)) @@ -17,14 +18,15 @@ (defgeneric area (shape)) (defgeneric perimeter (shape)) +;; default is for slots to not be formulas --- is this inconsistency good or bad? (defclass square () - ((side :initarg side :accessor square-side) - (perimeter formula-p t :initform (* (my 'side) 2) :reader perimeter) + ((side :initarg side :initform 0 :accessor square-side) + (perimeter formula-p t :initform (* (my 'side) 4) :reader perimeter) (area formula-p t :initform (expt (my 'side) 2) :reader area)) (:metaclass formulated-class)) (defclass circle () - ((radius :initarg radius :accessor circle-radius) + ((radius :initform 0 :initarg radius :accessor circle-radius) (perimeter formula-p t :initform (* (my 'radius) 2 pi) :reader perimeter) (area formula-p t :initform (* (expt (my 'radius) 2) pi) :reader area)) (:metaclass formulated-class))

1 0

[rjain-utils-cvs] CVS formulate/src
by rjain 11 Nov '09

11 Nov '09

Update of /project/rjain-utils/cvsroot/formulate/src In directory cl-net:/tmp/cvs-serv9463/src Modified Files: clim-ui.lisp Log Message: get variables working get class instantiation and instance display and slot setting working class definition doesn't work in mcclim due to accepting of deep structure being hairy clicking on slots to use an instance's slot value does not work, either -- sends DREI off a cliff --- /project/rjain-utils/cvsroot/formulate/src/clim-ui.lisp 2007/11/02 20:45:39 1.1.1.1 +++ /project/rjain-utils/cvsroot/formulate/src/clim-ui.lisp 2009/11/11 08:56:26 1.2 @@ -1,27 +1,75 @@ (defpackage :formulate.clim-ui (:export #:formulate) - (:use :clim-lisp :formulate :clim)) + (:use :clim-lisp :formulate :clim #.(first (list #+sbcl :sb-mop :mop)))) (in-package :formulate.clim-ui) (define-application-frame formulate () - () + ((monitored-values :initform (make-array 5 :fill-pointer 0 :adjustable t) + :accessor monitored-values)) (:panes (interactor :interactor - :scroll-bars t)) + :scroll-bars t) + (monitor :application + :scroll-bars t + :incremental-redisplay t + :display-function 'display-monitor + :display-time :command-loop)) (:pointer-documentation t) (:layouts (default - interactor))) + monitor + interactor))) -(define-formulate-command (com-define-formulated-variable :name "Define Formulated Variable") - ((name 'symbol) (formula 'expression) - (declarations 'expression :default '()) - (documentation '(or string null) :default nil)) - (funcall (compile nil (lambda () `(define-formulated-variable ,name ,formula - :declare ,declarations :documentation ,documentation))))) - -(define-formulate-command (com-define-formulated-class :name "Define Formulated Class") - ((name 'symbol) (superclasses '(sequence class) :default '()) (slots '(sequence slot-specification))) +(defun display-monitor (*application-frame* *standard-output*) + (updating-output (t :unique-id (monitored-values *application-frame*)) + (map nil (lambda (item) (display-monitored-value item)) + (monitored-values *application-frame*)))) + +(defmethod display-monitored-value (item) + (updating-output (t :unique-id item) + (call-next-method))) + +(defmethod frame-standard-output ((frame formulate)) + (get-frame-pane frame 'interactor)) + + +;;; +;;; VARIABLES +;;; + +(define-formulate-command (com-define-formulated-variable :name "Define Variable") + ((name 'symbol :prompt "Name") + (formula-p 'boolean :prompt "Formula?") + (formula 'expression :prompt (if formula-p "Formula" "Initial value")) + (monitor-p 'boolean :default t :prompt "Show in monitor pane?") + (declarations 'expression :default '() :prompt "Declarations") + (documentation '(or string null) :default nil :prompt "Documentation")) + (eval `(define-formulated-variable ,name ,formula + :formula-p ,formula-p + :declare ,declarations :documentation ,documentation)) + (when monitor-p + (let ((*standard-output* (get-frame-pane *application-frame* 'monitor))) + (vector-push-extend name (monitored-values *application-frame*))))) + +(defmethod display-monitored-value ((name symbol)) + (let ((value (eval name))) + (fresh-line) + (present name 'symbol) + (write-string " = ") + (present value (presentation-type-of value)))) + +(define-formulate-command (com-set-variable :name "Set Variable") + ((name 'symbol) (value 'expression)) + (eval `(setf ,name ,value))) + +;;; +;;; CLASSES +;;; + +(define-formulate-command (com-define-formulated-class :name "Define Class") + ((name 'symbol :prompt "Name") + (superclasses '(sequence symbol) :default () :prompt "Superclasses") + (slots '(sequence slot-specification) :prompt "Slots")) (eval `(defclass ,name ,(coerce superclasses 'list) (,@(coerce slots 'list)) (:metaclass formulated-class)))) @@ -29,11 +77,78 @@ (define-presentation-type slot-specification () :inherit-from 'expression) -(define-presentation-method accept ((type slot-specification) stream view &key default default-type) +(define-presentation-method accept ((type slot-specification) stream view + &key default) (let* ((name (if default (accept 'symbol :prompt "Name" :default (first default)) - (accept 'symbol :prompt "Name"))) - (formulated-p (accept 'boolean :prompt "Formulated?" - :default (getf default 'formulated-p t) :default-type 'boolean)) - (initform (accept 'expression :prompt (if formulated-p "Formula" "Initial value")))) - `(,name formulated-p ,formulated-p :initform ,initform))) + (accept 'symbol :prompt "Name"))) + (formula-p (accept 'boolean + :prompt "Formula?" + :default (getf default 'formula-p t) + :default-type 'boolean)) + (initform (accept 'expression :prompt (if formula-p "Formula" "Initial value")))) + `(,name formula-p ,formula-p :initform ,initform))) + +(define-formulate-command (com-create-instance :name "Create Instance") + ((class 'symbol)) + (vector-push-extend (make-instance class) + (monitored-values *application-frame*))) + +(defmethod display-monitored-value ((object standard-object)) + (fresh-line) + (present object 'formulated-object)) + +(define-presentation-type formulated-object () + :inherit-from t) + +(define-presentation-method presentation-typep (object (type formulated-object)) + (some (lambda (super) (typep super 'formulated-class)) + (class-precedence-list object))) + +(define-presentation-method present (object (type formulated-object) stream view + &key acceptably for-context-type) + (prin1 (class-name (class-of object))) + (fresh-line) + (formatting-table (stream) + (dolist (slot (class-slots (class-of object))) + (present `(slot-value ,object ,(slot-definition-name slot)) + 'formulated-slot + :stream stream :view view + :acceptably acceptably :for-context-type for-context-type)))) + +(define-presentation-type formulated-slot () + ;; 3 element list: (slot-value <object> <slot-name>) + :inherit-from '(sequence t)) + +(define-presentation-method presentation-typep ((expression cons) (type formulated-slot)) + (and (= 3 (length expression)) + (destructuring-bind (slot-value object slot) expression + (and (eq 'slot-value slot-value) + (typep slot 'symbol) + (some (lambda (super) (typep super 'formulated-class)) + (class-precedence-list object)))))) + +(define-presentation-method present (expression (type formulated-slot) stream view + &key acceptably for-context-type) + (when (and (consp (first expression)) + (eq 'quote (first (first expression)))) + (setf expression (second (first expression)))) + (destructuring-bind (s-v object slot) expression + (formatting-row (stream) + (formatting-cell (stream) + (present slot 'symbol + :stream stream :view view :sensitive nil)) + (formatting-cell (stream) + (let ((slot-value (slot-value object slot))) + (present slot-value `(and ,(presentation-type-of slot-value) + formulated-value) + :stream stream :view view :sensitive t)))))) + +(define-formulate-command (com-set-slot-value :name "Set Slot Value") + ((object.slot 'formulated-slot :prompt "Slot") + (new-value 'expression :prompt "New value")) + ;; not sure why object.slot has other crap around it, but hacking + ;; around it. + (destructuring-bind (s-v object slot) (second (first object.slot)) + (setf (slot-value object slot) (eval new-value)))) +

1 0

[rjain-utils-cvs] CVS formulate/src
by rjain 11 Nov '09

11 Nov '09

Update of /project/rjain-utils/cvsroot/formulate/src In directory cl-net:/tmp/cvs-serv9275/src Modified Files: variables.lisp Log Message: default formulator class for variables in the same way we do for slots --- /project/rjain-utils/cvsroot/formulate/src/variables.lisp 2009/11/04 21:41:35 1.2 +++ /project/rjain-utils/cvsroot/formulate/src/variables.lisp 2009/11/11 08:54:08 1.3 @@ -3,13 +3,17 @@ (defmacro define-formulated-variable (name formula &key declare documentation - (formulator-class 'lazy-formula-formulator-sink) + (formula-p t) + formulator-class formulator-options) `(progn (define-symbol-macro ,name (formulate-variable ',name)) (setf (documentation ',name 'variable) ,documentation) (setf (symbol-value ',name) - (make-instance ',formulator-class + (make-instance ',(or formulator-class + (if formula-p + 'lazy-formula-formulator-sink + 'simple-formulator-source)) 'formula ',formula 'formula-function (lambda () (declare ,@declare) ,formula) ,@formulator-options))

1 0

[rjain-utils-cvs] CVS formulate/src
by rjain 11 Nov '09

11 Nov '09

Update of /project/rjain-utils/cvsroot/formulate/src In directory cl-net:/tmp/cvs-serv9184/src Modified Files: package.lisp Log Message: added *me* to exports added package for metaprogramming, but can't eval it right away, so commented it out for now --- /project/rjain-utils/cvsroot/formulate/src/package.lisp 2009/11/04 21:41:35 1.2 +++ /project/rjain-utils/cvsroot/formulate/src/package.lisp 2009/11/11 08:53:07 1.3 @@ -5,6 +5,7 @@ #:lazy-formula-formulator-sink #:formulated-class #:my + #:*me* #:formula-p #:formulator-class #:formulator-options @@ -12,4 +13,21 @@ (:use :cl #.(first '(#+sbcl :sb-mop :mop)))) (defpackage :formulate-user - (:use :cl :formulate)) \ No newline at end of file + (:use :cl :formulate)) + +#+nil +(defpackage :formulate-meta + (:export . #1=(#:*formulating* + #:formulator-value + #:formulator-formula + #:formulator-formula-function + #:formulator-value-validp + #:formulator-invalidate + #:simple-formulator-source + #:formula-formulator-sink + #:lazy-formula-formulator-sink + #:formulated-slot-definition + #:formulated-direct-slot-definition + #:formulated-effective-slot-definition + #:slot-formulator-using-class)) + (:shadowing-import-from :formulate . #1#))

1 0

[rjain-utils-cvs] CVS formulate/src
by rjain 11 Nov '09

11 Nov '09

Update of /project/rjain-utils/cvsroot/formulate/src In directory cl-net:/tmp/cvs-serv9061/src Modified Files: formulate.lisp Log Message: minor renaming and cleanups --- /project/rjain-utils/cvsroot/formulate/src/formulate.lisp 2009/11/05 21:27:45 1.3 +++ /project/rjain-utils/cvsroot/formulate/src/formulate.lisp 2009/11/11 08:52:10 1.4 @@ -3,16 +3,16 @@ (deftype list-of (elt-type) 'list) +;;; +;;; *** GENERAL DEFINITIONS *** +;;; + (defvar *formulating* '() "The FORMULATOR, if any, that is being evaluated.") (define-condition set-formulated-location (cell-error) ()) -(defgeneric formulator-value (formulator - &optional unbound-condition cell-name)) - - (defmethod formulator-value :around (formulator &optional unbound-condition cell-name) (when *formulating* @@ -21,7 +21,9 @@ (call-next-method) (error unbound-condition :name cell-name))) -(defgeneric formulator-value-changed (sink source new-value old-value)) +;;; +;;; *** SIMPLE FORMULATOR SOURCE +;;; (defclass simple-formulator-source () ((dependents :initform '() @@ -51,9 +53,13 @@ (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)) + (formulator-value-changed dependent formulator new-value old-value)) result)) +;;; +;;; FORMULA FORMULATOR SINK +;;; + (defclass formula-formulator-sink () ((formula :initarg formula :accessor formulator-formula) @@ -71,6 +77,10 @@ (defmethod formulator-value-validp ((formulator formula-formulator-sink)) (slot-boundp formulator 'formula)) +;;; +;;; *** LAZY FORMULATOR SINK +;;; + (defclass lazy-formula-formulator-sink (formula-formulator-sink) ((source :initarg source :initform (make-instance 'simple-formulator-source) @@ -103,6 +113,6 @@ (defmethod note-formula-dependency (source sink) (pushnew sink (formulator-dependents source))) -(defmethod formulator-source-value-changed +(defmethod formulator-value-changed ((sink lazy-formula-formulator-sink) source new-value old-value) (formulator-invalidate sink))

1 0

[rjain-utils-cvs] CVS formulate/src
by rjain 05 Nov '09

05 Nov '09

Update of /project/rjain-utils/cvsroot/formulate/src In directory cl-net:/tmp/cvs-serv31628/src Modified Files: formulate.lisp Log Message: fix typo... --- /project/rjain-utils/cvsroot/formulate/src/formulate.lisp 2009/11/04 21:41:35 1.2 +++ /project/rjain-utils/cvsroot/formulate/src/formulate.lisp 2009/11/05 21:27:45 1.3 @@ -90,7 +90,7 @@ (defmethod formulator-value ((formulator lazy-formula-formulator-sink) &optional cond cell) (let ((source (formulator-source formulator))) - (if (formulator-value-validpxo source) + (if (formulator-value-validp source) (let ((*formulating* nil)) (formulator-value source cond cell)) (let ((*formulating* formulator))

1 0

[rjain-utils-cvs] CVS formulate/src
by rjain 04 Nov '09

04 Nov '09

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

1 0