Adding dataflow as dependency
Tue Jan 26 11:34:06 PST 2010 marianomontone@gmail.com
* Adding dataflow as dependency
diff -rN -u old-gestalt/deps/dataflow/README new-gestalt/deps/dataflow/README
--- old-gestalt/deps/dataflow/README 1969-12-31 16:00:00.000000000 -0800
+++ new-gestalt/deps/dataflow/README 2014-07-29 17:59:52.000000000 -0700
@@ -0,0 +1,57 @@
+More comments: add to the README maybe.
+
+Human beings have three dimensions. The somatic, the psychic and the espiritual. Each of them is "superior" than the former, in that order. At the same time, some times there's not a clear distinction between them, as there are complex interactions. The "superior" dimensions, cancel and at the same time incorporate the once below.
+
+This principle could be applied for software. That is translated to a somewhat "coupled stratified design".
+
+In the dataflow world, callbacks (weak lambdas) are the inferior. The dataflow syntax is superior. But dataflow syntax should somehow "include" the weak lambdas. As a consecuence, weak lambdas, or even, simple lambdas, could be used in the same places that the full dataflow syntax is used.
+
+Other design:
+
+wlambdas make the algorithm for dataflow too coupled. The algorithm is embedded in the wlambda construction. That does not permit separating the dependecies from the algorithms for resolving them. In particular, we may want to have different policies or a transactional algorithm.
+
+In the current design, this is what happens:
+
+(let
+ ((a (make-cell :value 21))
+ (b (make-cell :value 11)))
+ (df (+ a b)))
+
+That would get transformed to something like:
+
+(let
+ ((a (make-cell :value 21))
+ (b (make-cell :value 11)))
+ (make-cell :lambda
+ (lambda ()
+ (block cell-lambda#1
+ (let ((weak-ref#1 (make-weak-ref a))
+ (weak-ref#2 (make-weak-ref b)))
+ (when (or (null-weak-ref weak-ref#1)
+ (null-weak-ref weak-ref#2))
+ (return-from cell-lambda#1)))
+ (symbol-macrolet
+ ((a (value
+
+An alternative design should provide the means to implement different resolving algorithms:
+
+(let
+ ((a (make-cell :value 21))
+ (b (make-cell :value 11)))
+ (df (+ a b)))
+
+Should get translated to:
+
+(make-cell :lambda (lambda (a b)
+ (symbol-macrolet
+ ((a `(value a))
+ (b `(value b)))
+ (+ a b)))
+ :args (list a b))
+
+make-cell builds a cell. Each cell holds the lambda to compute and a weak hash table to the dataflow variables. Now the cell holds the dependencies only, and doesn't know about the algorithm to resolve them.
+
+The (setf (value cell) value) could register the changes in the current memory transaction in a transactional dataflow resolving scheme.
+
+The cell computes itself providing its weakly referenced arguments to its lambda.
+
\ No newline at end of file
diff -rN -u old-gestalt/deps/dataflow/TODO new-gestalt/deps/dataflow/TODO
--- old-gestalt/deps/dataflow/TODO 1969-12-31 16:00:00.000000000 -0800
+++ new-gestalt/deps/dataflow/TODO 2014-07-29 17:59:52.000000000 -0700
@@ -0,0 +1,185 @@
+Value models and our dataflow extension
+---------------------------------------
+
+We need at least two different macros. One that creates a value-cell (value-holder) from syntax.
+Another that creates a aspect-cell (aspect-adaptor) from syntax.
+
+Value holders:
+-------------
+
+The first:
+
+(df (:value) ; note the :value keyword
+ (let*
+ ((value 44)
+ (suma (+ slot value)))
+ (format t "Getting value of suma2!!~%")
+ (* suma value)))
+
+ Should generate:
+ (make-instance 'value-cell
+ ...)
+
+
+
+Aspect adaptors: (Adapts on an object method)
+-------------
+
+So we need to generate appropiate dataflow-cell's.
+
+
+(df (:aspect)
+ (name person))
+
+Should generate:
+
+(make-cell :setter (lambda (arg) (setf (name person) arg))
+ :getter (lambda () (name person)))
+
+And we need (setf name) ((p person) value) to be defined. It throws an error otherwise.
+
+Anyway we had better use dataflow-class metaclass.
+
+
+(df
+ (let*
+ ((value 44)
+ (suma (+ slot value)))
+ (format t "Getting value of suma2!!~%")
+ (* suma value)))
+
+Other cases:
+-----------
+
+We can treat other cases explicetly (no macro syntax support). For example, we can build our own aspect cells explicetly
+providing the setter and getter lambdas.
+
+General refactoring:
+-------------------
+
+Nota: en este momento el algoritmo de dataflow se encuentra
+en los wlambda creados. Para desacoplar el algoritmo habria que transformar el codigo de forma tal de crear lambdas que bindeen con nuevas variables todas las variables libres. Además, cada celda debería contener una tabla weak a las variables libres. Para ejecutar, habria que pasar esas variables al nuevo lambda generado.
+
+Implementation sketch:
+
+Example:
+
+(let
+ ((x (make-instance 'value-cell :value 23))
+ (y (make-instance 'formula-cell
+ :arguments x
+ :formula (lambda (x) (+ 3 x)))))
+ ...)
+
+(defmethod initialize-instance :after ((cell formula-cell) &rest initargs)
+ ;; Keep weak-references to the bindings only
+ (setf (arguments cell)
+ (for arg in (arguments cell)
+ collect (make-weak-pointer arg))
+ do (add-dependent cell arg :changed))) ;; register as a dependent of the argument
+
+(defmethod evaluate ((cell formula-cell))
+ "cell evaluation
+ use the values of the weakly bound arguments. if one of them is not bound, returns nil
+ returns 2 values: the evaluated value, and T or NIL if the cell could be evaluated or not"
+ (let ((args (loop for arg in (arguments cell)
+ for c = (weak-pointer-value arg)
+ when (null c) do (return-from evaluate (values nil nil))
+ collect (value c))))
+ (values (apply (formula cell) args)
+ t)))
+
+(defmethod propagate (event cell)
+ (loop for dependent in (dependents-on :changed cell)
+ do (multiple-value-bind (value evaluated-p) (evaluate dependent)
+ (if evaluated-p
+ (propagate event dependent)))))
+
+(defvar *propagating* nil "t when we are propagating changes")
+
+(define-condition trigger-event-signal ()
+ ()
+ (:documentation "This condition is meant to be caught by the propagation algorithm when an event ocurrs"))
+
+(defun trigger-event (event triggerer &rest args)
+ (if *propagating*
+ (signal 'trigger-event-signal :event event
+ :triggerer triggerer
+ :args args)
+ ;else
+ (apply #'propagate-event event triggerer args)))
+
+(defun propagate-event (event triggerer &rest args)
+ (flet ((propagate-events (events)
+ (loop for (event triggerer args) in events
+ do (handler-bind ((trigger-event-signal (lambda (signal)
+ ; enqueue the recently ocurred event
+ (push events (list (event signal) (triggerer signal) (args signal)))
+ (continue))))
+
+ (loop for dependent in (dependents-on event triggerer)
+ do (evaluate dependent))))))
+ (let ((*propagating* t))
+ (propagate-events (list (list event triggerer args))))))
+
+
+TODO: consider adding runtime type checking to dataflow syntax
+--------------------------------------------------
+
+For example,
+
+(let ((a (make-value-cell :value 23))
+ (b 33))
+ (df
+ (+ a b)))
+
+should macroexpand to:
+(let
+ ((a (make-value-cell :value 23))
+ (b 33))
+ (let ((arguments-gensym (loop
+ for var-name in '(a b) ;; free-vars
+ for var-value in (list a b) ;; free-vars
+ when (typep var-value 'cell)
+ collect (cons var-name var-value))))
+ (make-instance 'formula-cell
+ :arguments arguments-gensym
+ ;; we do dynamic-compilation: we don't know which our arguments are until runtime (because we need the dynamic type of them)
+ ;; we take into account the type of the arguments only once, at creation time. once the function is compiled, we are done.
+ :formula (compile nil
+ `(lambda ,arguments-gensym
+ (symbol-macrolet
+ ,(loop for (var-name . var-value) in ,arguments-gensym
+ collect (list var-name var-value))
+ (+ a b)))))))
+
+Now, we don't need declarations to know which of the free variables are cells and which are not
+
+All of the following expressions work as expected:
+
+(let ((a (make-value-cell :value 23))
+ (b 33))
+ (df
+ (+ a b)))
+
+(let ((a (make-value-cell :value 23))
+ (b (make-value-cell :value 33)))
+ (df
+ (+ a b)))
+
+(let ((a 23)
+ (b (make-value-cell :value 33)))
+ (df
+ (+ a b)))
+
+Updating suspensions:
+--------------------
+
+(suspending-subscriptions (:subs :all) my-cell
+ (do-something))
+
+(suspending-subscriptions (:subs subscriber1 subscriber2) my-cell
+ (do-something))
+
+(suspending-subscriptions (:event :changed) my-cell
+ (do-something))
\ No newline at end of file
diff -rN -u old-gestalt/deps/dataflow/better-mop.lisp new-gestalt/deps/dataflow/better-mop.lisp
--- old-gestalt/deps/dataflow/better-mop.lisp 1969-12-31 16:00:00.000000000 -0800
+++ new-gestalt/deps/dataflow/better-mop.lisp 2014-07-29 17:59:52.000000000 -0700
@@ -0,0 +1,224 @@
+(in-package :dataflow)
+
+;; MOP glue for dataflow
+
+
+(defclass dataflow-class (standard-class)
+ ((dataflow-slots :initform '()
+ :accessor dataflow-slots)))
+
+(defclass dataflow-object ()
+ ((dataflow-slots :initform (make-hash-table :test #'equal)
+ :accessor dataflow-slots)
+ (listeners :initform (make-hash-table :test #'equal) :accessor listeners)))
+
+
+(defmethod validate-superclass ((class standard-class) (super dataflow-class))
+ t)
+
+(defmethod validate-superclass ((class dataflow-class) (super standard-class))
+ t)
+
+#|
+(defmethod shared-initialize :around ((class dataflow-class) slot-names &rest args &key direct-superclasses)
+ "Ensures we inherit from dataflow-object."
+ (log-for mop "Entering: dataflow-class shared-initialize :around~%")
+ (let* ((dataflow-metaclass (find-class 'dataflow-class))
+ (dataflow-object (find-class 'dataflow-object))
+ (not-already-dataflow (loop for superclass in direct-superclasses
+ never (eq (class-of superclass) dataflow-metaclass))))
+ (if (and (not (eq class dataflow-object)) not-already-dataflow)
+ (apply #'call-next-method class slot-names
+ :direct-superclasses (append direct-superclasses (list dataflow-object)) args)
+ (call-next-method)))
+ (log-for mop "Leaving: dataflow-class shared-initialize :around~%")
+ )
+
+|#
+
+
+(defclass dataflow-slot-mixin ()
+ ((dataflow :initarg :dataflow :initform t :accessor dataflow-slot-p)
+ (test :initarg :test :initform #'eq :accessor dataflow-slot-test)
+ ))
+
+(defmethod print-object ((slot-definition dataflow-slot-mixin) stream)
+ (print-unreadable-object (slot-definition stream :type t :identity t)
+ (format stream " name: ~A dataflow: ~A test: ~A"
+ (slot-definition-name slot-definition)
+ (dataflow-slot-p slot-definition)
+ (dataflow-slot-test slot-definition))))
+
+(defclass dataflow-slot (dfcell)
+ ((name :initarg :name :accessor dataflow-slot-name)
+ (owner :initarg :owner :accessor dataflow-slot-owner)
+ (test :initarg :test :initform #'eq :reader dataflow-slot-test)
+ ))
+
+(defmethod value ((slot dataflow-slot))
+ (slot-value (dataflow-slot-owner slot) (intern (dataflow-slot-name slot))))
+
+(defmethod (setf value) (new-value (slot dataflow-slot))
+ (setf (slot-value (dataflow-slot-owner slot) (intern (dataflow-slot-name slot))) new-value))
+
+(defmethod print-object ((object dataflow-slot) stream)
+ (print-unreadable-object (object stream :type t :identity t)
+ (format stream " slot-name: ~A owner: ~A test: ~A"
+ (dataflow-slot-name object)
+ (dataflow-slot-owner object)
+ (dataflow-slot-test object))))
+
+
+(defclass dataflow-direct-slot-definition
+ (dataflow-slot-mixin standard-direct-slot-definition)
+ ())
+
+(defclass dataflow-effective-slot-definition
+ (dataflow-slot-mixin standard-effective-slot-definition)
+ ())
+
+(defun get-dataflow-slot (slot-name object)
+ (assert (stringp slot-name))
+ (gethash slot-name (dataflow-slots object)))
+
+(defmethod shared-initialize :after ((obj dataflow-object) slot-names &rest args)
+ "Initialize the dataflow slots of the object"
+ (declare (ignore args))
+ (log-for mop "shared-initialize :after dataflow-object slot-names: ~A~%" slot-names)
+ (loop for slot in (class-slots (class-of obj))
+ do
+ (let ((slot-name (string (slot-definition-name slot))))
+ (assert (stringp slot-name))
+ (log-for mop "Initializing: ~A dataflow: ~A~%" slot (dataflow-slot-p slot) )
+ (when (and
+ (dataflow-slot-p slot)
+ (not (gethash slot-name (dataflow-slots obj))))
+ (setf (gethash slot-name (dataflow-slots obj))
+ (make-instance 'dataflow-slot
+ :name slot-name
+ :owner obj
+ :test (dataflow-slot-test slot)))
+ )))
+ ; We can start to track events now
+ (defmethod (setf slot-value-using-class) (new-value
+ (class dataflow-class)
+ object
+ slot-definition)
+ (log-for mop "dataflow-class (setf slot-value-using-class) object: ~A :slotname ~A~%" object (slot-definition-name slot-definition))
+ ;; Now notify the listeners of the change
+ (let ((dataflow-slot (get-dataflow-slot (string (slot-definition-name slot-definition)) object))
+ (old-value (slot-value object (slot-definition-name slot-definition))))
+ (log-for mop "Dataflow slot: ~A~%" dataflow-slot)
+ (call-next-method)
+ (when (not (funcall (dataflow-slot-test dataflow-slot) old-value new-value))
+ (trigger-event :changed dataflow-slot new-value)
+ ;; Notify the object changed
+ (trigger-event :changed object))))
+)
+
+(defmethod direct-slot-definition-class ((class dataflow-class)
+ &rest initargs)
+ (declare (ignore initargs))
+ (find-class 'dataflow-direct-slot-definition))
+
+
+(defmethod effective-slot-definition-class ((class dataflow-class)
+ &rest initargs)
+ (declare (ignore initargs))
+ (find-class 'dataflow-effective-slot-definition))
+
+(defmethod compute-effective-slot-definition :before ((class dataflow-class) slot-name direct-slots)
+ (log-for mop "compute-effective-slot-definition slot: ~A slots: ~A~%" slot-name direct-slots)
+ )
+
+(defmethod compute-effective-slot-definition ((class dataflow-class) name direct-slots)
+ (let ((effective-slot (call-next-method)))
+ (setf (dataflow-slot-p effective-slot)
+ (some #'dataflow-slot-p direct-slots))
+ (setf (dataflow-slot-test effective-slot)
+ (loop for direct-slot in direct-slots
+ when (dataflow-slot-test direct-slot)
+ return (dataflow-slot-test direct-slot)))
+ effective-slot))
+
+(defmethod dataflow-slot-p ((object slot-definition))
+ nil)
+
+(defmethod dataflow-slot-test ((object slot-definition))
+ nil)
+
+(defmacro with-df-slots (slots object &rest body)
+ (let
+ ((slots-gensyms (make-hash-table :test #'equal)))
+ `(let
+ ,(loop for slot in slots
+ collect
+ (let
+ ((slot-gensym (gensym (string-upcase (string slot)))))
+ (setf (gethash slot slots-gensyms) slot-gensym)
+ `(,slot-gensym (get-dataflow-slot ,(string slot) ,object))))
+ (symbol-macrolet
+ ,(loop for slot in slots
+ collect `(,slot ,(gethash slot slots-gensyms)))
+ ,@body))))
+
+;; Redefining slot-value-using-class and keeping the old definition?
+
+;; The more "reflective" option:
+(defvar *old-method* nil)
+(defvar *new-method* nil)
+
+(let ((gf (symbol-function sb-mop:slot-value-using-class)))
+ (setf *old-method* (sb-mop:compute-effective-method gf t
+ (sb-mop:compute-applicable-methods-using-classes (list (find-class 'dataflow-class) t t)))))
+; We can start to track events now
+(defmethod (setf slot-value-using-class) (new-value
+ (class dataflow-class)
+ object
+ slot-definition)
+ (log-for mop "dataflow-class (setf slot-value-using-class) object: ~A :slotname ~A~%" object (slot-definition-name slot-definition))
+ ;; Now notify the listeners of the change
+ (let ((dataflow-slot (get-dataflow-slot (string (slot-definition-name slot-definition)) object))
+ (old-value (slot-value object (slot-definition-name slot-definition))))
+ (log-for mop "Dataflow slot: ~A~%" dataflow-slot)
+ (call-next-method)
+ (when (not (funcall (dataflow-slot-test dataflow-slot) old-value new-value))
+ (trigger-event :changed dataflow-slot new-value)
+ ;; Notify the object changed
+ (trigger-event :changed object))))
+
+(setf *new-method* (sb-mop:compute-effective-method gf t
+ (sb-mop:compute-applicable-methods-using-classes (list (find-class 'dataflow-class) t t))))
+
+;; When we want to change:
+(add-method gf *new-method*)
+(add-method gf *old-method*)
+
+;; Note: this code is not tested at all. It's only a sketch of the idea.
+
+;; With dataflow, we don't need full method redefinition. We can decide whether to do
+;; track changes or not based on a dynamically bound variable:
+
+(defvar *df-on* t)
+
+(defmethod (setf slot-value-using-class) (new-value
+ (class dataflow-class)
+ object
+ slot-definition)
+ (when (not *df-on*)
+ (return (call-next-method)))
+ (log-for mop "dataflow-class (setf slot-value-using-class) object: ~A :slotname ~A~%" object (slot-definition-name slot-definition))
+ ;; Now notify the listeners of the change
+ (let ((dataflow-slot (get-dataflow-slot (string (slot-definition-name slot-definition)) object))
+ (old-value (slot-value object (slot-definition-name slot-definition))))
+ (log-for mop "Dataflow slot: ~A~%" dataflow-slot)
+ (call-next-method)
+ (when (not (funcall (dataflow-slot-test dataflow-slot) old-value new-value))
+ (trigger-event :changed dataflow-slot new-value)
+ ;; Notify the object changed
+ (trigger-event :changed object))))
+
+;; And we can provide a convenient macro:
+(defmacro with-df-off (&rest body)
+ (let ((*df-off* t))
+ ,@body))
diff -rN -u old-gestalt/deps/dataflow/dataflow.asd new-gestalt/deps/dataflow/dataflow.asd
--- old-gestalt/deps/dataflow/dataflow.asd 1969-12-31 16:00:00.000000000 -0800
+++ new-gestalt/deps/dataflow/dataflow.asd 2014-07-29 17:59:52.000000000 -0700
@@ -0,0 +1,27 @@
+(require :asdf)
+
+(defpackage :dataflow-system
+ (:nicknames :dfsys)
+ (:use :cl :asdf))
+
+(in-package :dataflow-system)
+
+(defsystem dataflow
+ :name "dataflow"
+ :version "0.0.1"
+ :maintainer "Mariano Montone <marianomontone@gmail.com>"
+ :author "Mariano Montone <marianomontone@gmail.com>"
+ :licence "LLGPL"
+ :description "A Common Lisp dataflow extension"
+ :components
+ ((:file "package")
+ (:file "logging")
+ (:file "dataflow")
+ (:file "mop")
+ (:file "test"))
+ :serial t
+ :depends-on (:gst.util
+ :log5
+ :fiveam
+ :trivial-garbage))
+
\ No newline at end of file
diff -rN -u old-gestalt/deps/dataflow/dataflow.lisp new-gestalt/deps/dataflow/dataflow.lisp
--- old-gestalt/deps/dataflow/dataflow.lisp 1969-12-31 16:00:00.000000000 -0800
+++ new-gestalt/deps/dataflow/dataflow.lisp 2014-07-29 17:59:52.000000000 -0700
@@ -0,0 +1,410 @@
+(in-package :dataflow)
+
+;----------------------------
+; Dataflow cells definitions
+;----------------------------
+
+(defclass cell ()
+ ((dependents :initform (make-hash-table)
+ :accessor dependents
+ :documentation "The cells dependents table. It is organized by event"))
+ (:documentation "A cell is an object that triggers events and has dependents interested in those changes"))
+
+(defclass value-cell (cell)
+ ((value :initarg :value
+ :accessor value
+ :initform (error "Provide the value")
+ :documentation "The value of the cell")
+ (test :initarg :test
+ :accessor test
+ :initform #'eql))
+ (:documentation "A cell that contains a changing value")
+ (:metaclass required-slots-class))
+
+(defclass standard-event (standard-class)
+ ()
+ (:documentation "Just to do some event matching in method parameters"))
+
+(defmethod validate-superclass ((class standard-event)
+ (super standard-class))
+ t)
+
+(defmethod hash ((event-class standard-event))
+ event-class)
+
+(defmethod event-dependents ((event symbol) (cell cell))
+ (event-dependents (find-class event) cell))
+
+(defmethod event-dependents ((event standard-event) (cell cell))
+ (gethash event (dependents cell)))
+
+
+(defclass event ()
+ ((triggerer :initarg :triggerer
+ :accessor triggerer
+ :initform (error "Provide the triggerer")
+ :documentation "The event triggerer"))
+ (:metaclass standard-event)
+ (:documentation "The events superclass"))
+
+(defmethod print-object ((event event) stream)
+ (print-unreadable-object (event stream)
+ (format stream "triggerer: ~A" (triggerer event))))
+
+(defclass changed (event)
+ ((value :initarg :value
+ :accessor value
+ :initform (error "Provide the value")
+ :documentation "The new triggerer value"))
+ (:metaclass standard-event)
+ (:documentation "Signaled when an object changes"))
+
+(defmethod print-object ((event changed) stream)
+ (print-unreadable-object (event stream :type t :identity t)
+ (format stream "~A changed to: ~A"
+ (triggerer event)
+ (value event))))
+
+(defclass formula (cell)
+ ((result :documentation "The formula result")
+ (arguments :initarg :arguments
+ :accessor arguments
+ :initform (error "Provide the arguments")
+ :documentation "The arguments of the formula. They are weakly bound")
+ (formula :initarg :formula
+ :accessor formula
+ :initform (error "Provide the formula")
+ :documentation "The formula. A function that takes the objects pointed by the arguments slot"))
+; (:metaclass funcallable-standard-class))
+ (:documentation "A formula cell is a cell that calculates a value based on arguments cells"))
+
+(defmethod value ((cell formula))
+ (result cell))
+
+(defmethod result ((formula formula))
+ (when (not (slot-boundp formula 'result))
+ (setf (slot-value formula 'result) (evaluate-formula formula)))
+ (slot-value formula 'result))
+
+(defmethod print-object ((formula formula) stream)
+ (print-unreadable-object (formula stream :type t :identity t)
+ (format stream "value: ~A" (result formula))))
+
+(defmethod initialize-instance :after ((cell formula) &rest initargs)
+ (declare (ignore initargs))
+ ;; (set-funcallable-instance-function cell
+ ;; (lambda (event)
+ ;; (declare (ignore event))
+ ;; (evaluate-formula cell)))
+ ;; Keep weak-references to the arguments only
+ (let ((args (copy-list (arguments cell))))
+ (setf (arguments cell)
+ (loop for arg in args
+ collect (make-weak-pointer arg)))
+ (loop for arg in args
+ do (add-dependent arg 'changed cell)))
+ (evaluate-formula cell))
+
+(defun evaluate-formula (cell)
+ (let ((args (loop for arg in (arguments cell)
+ for c = (weak-pointer-value arg)
+ when (null c)
+ do (return-from evaluate-formula
+ (values nil nil))
+ collect (value c))))
+ (let ((result (apply (formula cell) args)))
+ (setf (slot-value cell 'result) result)
+ (log-for df "~A evaluated" cell)
+ (trigger-event 'changed :triggerer cell :value result)
+ (values result t))))
+
+;-----------------------------
+; Cells dependents management
+;-----------------------------
+
+(define-condition dependency-exists (serious-condition)
+ ((cell :initarg :cell
+ :reader cell
+ :initform (error "Provide the cell"))
+ (event :initarg :event
+ :reader event
+ :initform (error "Provide the event"))
+ (dependent :initarg :dependent
+ :reader dependent
+ :initform (error "Provide the dependent")))
+ (:report (lambda (c s)
+ (format s "~A is already registered as dependent of ~A for event ~A"
+ (dependent c)
+ (cell c)
+ (event c))))
+ (:documentation "The dependent we are trying to add already exists"))
+
+(defun dependency-binding-target (binding)
+ (if (weak-pointer-p binding)
+ (weak-pointer-value binding)
+ binding))
+
+(defgeneric add-dependency-binding (binding cell event &key if-exists)
+ (:documentation "Adds a dependency binding to a cell. A dependency binding can be either a weak or a direct (strong) reference to the dependent object")
+ (:method (binding (cell cell) (event symbol) &key (if-exists :error))
+ (add-dependency-binding binding cell
+ (aif (find-class event)
+ it
+ (error "The event is not valid"))
+ :if-exists if-exists))
+ (:method (binding (cell cell) (event standard-event)
+ &key (if-exists :error))
+ (labels ((%add-dependency-binding ()
+ (symbol-macrolet ((events-dependents
+ (gethash (hash event) (dependents cell))))
+ (flet ((push-binding (binding)
+ ;; Hook for finalization
+ (when (weak-pointer-p binding)
+ (trivial-garbage:finalize
+ (weak-pointer-value binding)
+ (lambda ()
+ (log-for df "Removed obsolete ~A from ~A list of dependents" binding cell)
+ (setf events-dependents
+ (delete binding events-dependents)))))
+ ;; Add the binding
+ (push binding events-dependents)
+ binding))
+ (multiple-value-bind (list found-p) events-dependents
+ (declare (ignore list))
+ (when (not found-p)
+ (setf events-dependents '())))
+ (restart-case
+ (progn
+ (loop
+ with deps = events-dependents
+ for dep in deps
+ when
+ (eql (dependency-binding-target dep)
+ (dependency-binding-target binding))
+ do (error 'dependency-exists
+ :cell cell
+ :event event
+ :dependent (dependency-binding-target dep)))
+ (push-binding binding))
+ (superceed ()
+ (push-binding binding)))))))
+ (ecase if-exists
+ (:error (%add-dependency-binding))
+ (:superseed (handler-bind
+ ((dependency-exists (lambda (c)
+ (declare (ignore c))
+ (invoke-restart 'superceed))))
+ (%add-dependency-binding)))))))
+
+(defgeneric add-dependent (cell event dependent &key if-exists)
+ (:documentation "Adds a dependent to a cell")
+ (:method (cell event dependent &key (if-exists :error))
+ ;; add dependents weakly in general
+ (log-for df "Adding dependent ~A to ~A for event ~A"
+ dependent cell event)
+ (add-dependency-binding (make-weak-pointer dependent)
+ cell event
+ :if-exists if-exists))
+ (:method (cell event (dependent function) &key (if-exists :error))
+ ;; in the case of a function, add dependent strongly
+ (log-for df "Adding dependent ~A to ~A for event ~A"
+ dependent cell event)
+ (add-dependency-binding dependent cell event
+ :if-exists if-exists)))
+
+(defgeneric remove-dependent (cell event dependent)
+ (:documentation "Removes a dependent from the cell")
+ (:method ((cell cell) (event symbol) dependent)
+ (if (equalp event :all)
+ (maphash (lambda (ev tbl)
+ (declare (ignore tbl))
+ (remove-dependent cell ev dependent))
+ (dependents cell))
+ (remove-dependent cell (find-class event) dependent)))
+ (:method ((cell cell) (events cons) dependent)
+ (loop for event in events
+ do (remove-dependent cell event dependent)))
+ (:method ((cell cell) (event standard-event) dependent)
+ (let ((event-dependents (gethash (hash event) (dependents cell))))
+ (loop for binding in event-dependents
+ when (eql (dependency-binding-target binding)
+ dependent)
+ do (setf (gethash (hash event) (dependents cell))
+ (delete binding event-dependents))))))
+
+(defgeneric dependents-of-event (event cell)
+ (:documentation "Returns all the dependents for a cell on some event")
+ (:method ((event standard-event) (cell cell))
+ (flatten
+ (mapcar #'dependency-binding-target
+ (gethash (hash event) (dependents cell))))))
+
+(defmacro print-cell ((cell stream) &body body)
+ (once-only (cell)
+ `(print-unreadable-object (,cell ,stream :type t :identity t)
+ ,@body)))
+
+(defmethod print-object ((cell cell) stream)
+ (print-cell (cell stream)))
+
+(defmethod print-object ((cell value-cell) stream)
+ (print-cell (cell stream)
+ (format stream "value: ~A test: ~A"
+ (if (slot-boundp cell 'value)
+ (value cell)
+ "#unbound")
+ (test cell))))
+
+(defgeneric evaluate-dependent (dependent event)
+ (:documentation "(Re)evaluates a dependent because an event happened")
+ (:method ((dependent formula) event)
+ (log-for df "Evaluating dependent: ~A event: ~A" dependent event)
+ (evaluate-formula dependent))
+ (:method ((dependent function) event)
+ (log-for df "Evaluating dependent: ~A event: ~A" dependent event)
+ (funcall dependent event)))
+
+;--------------------------
+; Events handling policy
+;--------------------------
+
+(defvar *events-handling-policies*
+ (make-hash-table :test #'equalp)
+ "A table holding the events handling policies")
+
+(defvar *events-handling-policy* :default
+ "The event-handing policy for when events are propagated")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defmacro define-event-handling-policy (name args &body body)
+ (with-unique-names (event-handler-policy-function)
+ `(flet ((,event-handler-policy-function ,args
+ ,@body))
+ (setf (gethash ',name *events-handling-policies*)
+ #',event-handler-policy-function))))
+
+ (defmacro with-events-handling-policy (policy &body body)
+ `(let
+ ((*events-handling-policy* ,policy))
+ ,@body)))
+
+(define-event-handling-policy :default (event events)
+ (declare (ignore events))
+ (propagate-event event))
+
+(define-event-handling-policy :defer-events (event events)
+ (error "fix this. pushing to the events variable doesn't work")
+ (push event events))
+
+(define-event-handling-policy :once-only (event events)
+ (declare (ignore event events))
+ (error "TODO"))
+
+(defun get-handling-policy-function (policy)
+ (multiple-value-bind (function found-p)
+ (gethash policy
+ *events-handling-policies*)
+ (when (not found-p)
+ (error "The events handling policy ~A was not found" policy))
+ function))
+
+;----------------------
+; Events propagation
+;----------------------
+
+(defvar *propagating* nil "t when we are propagating changes")
+
+(defvar *restoring-functions* '()
+ "Command pattern functions for restoring cells values
+after an error has ocurred")
+
+(define-condition trigger-event-signal ()
+ ((event :initarg :event
+ :accessor event
+ :initform (error "Provide the event")
+ :documentation "The event that ocurred"))
+ (:documentation "This condition is meant to be caught by the propagation algorithm when an event ocurrs"))
+
+(defgeneric trigger-event (event &rest args)
+ (:documentation "Triggers an event")
+ (:method ((event event) &rest args)
+ (declare (ignore args))
+ (if *propagating*
+ (signal 'trigger-event-signal :event event)
+ ;else
+ (propagate-event event :handling-policy *events-handling-policy*)))
+ (:method ((event symbol) &rest args)
+ (trigger-event (apply #'make-instance event args))))
+
+(defmethod trigger-event :around ((event event) &rest args)
+ (if *propagating*
+ (apply #'call-next-method event args)
+ (restart-case
+ (apply #'call-next-method event args)
+ (restore-values ()
+ :report (lambda (s)
+ (format s "Restore the cells values"))
+ (loop for command in *restoring-functions*
+ do (funcall command))))))
+
+(defun propagate-event (event &key (handling-policy :default))
+ (let ((events (list event))
+ (policy-function (get-handling-policy-function handling-policy)))
+ (handler-bind
+ ((trigger-event-signal
+ (lambda (signal)
+ (funcall policy-function (event signal) events)
+ (continue))))
+ (let ((*propagating* t))
+ (loop
+ for event in events
+ do (loop
+ for dependent in (dependents-of-event (class-of event) (triggerer event))
+ do (evaluate-dependent dependent event)))))))
+
+(defmethod (setf value) (new-value (cell value-cell))
+ (flet ((set-value ()
+ (when (or (not (slot-boundp cell 'value))
+ (not (funcall (test cell) new-value (value cell))))
+ (let ((old-value (slot-value cell 'value)))
+ (log-for df "Setting value of: ~A to: ~A~%" cell new-value)
+ (setf (slot-value cell 'value) new-value)
+ (push (lambda () (setf (slot-value cell 'value) old-value))
+ *restoring-functions*)
+ (trigger-event 'changed
+ :triggerer cell
+ :value new-value))
+ new-value)))
+ (if *propagating*
+ (set-value)
+ (let ((*restoring-functions* '()))
+ (set-value)))))
+
+;-------------------------
+; Dataflow syntax
+;-------------------------
+
+(defmacro mk-formula (args &body body)
+ `(make-instance 'formula
+ :arguments (list ,@args)
+ :formula (lambda ,args
+ ,@body)))
+
+(defmacro mk-lambda (args &body body)
+ (with-unique-names (func event)
+ `(flet ((,func (,event) (declare (ignore ,event)) ,@body))
+ ,@(loop for arg in args
+ collect `(add-dependent ,arg 'changed #',func))
+ #',func)))
+
+
+(make-let df-vars (lambda (var-name var-value)
+ `(make-instance 'value-cell
+ :name ,(symbol-name var-name)
+ :value ,var-value)))
+(make-using df-vars (lambda (binding)
+ `(value ,binding)))
+
+(make-with df-vars)
+
+(make-as df-vars)
\ No newline at end of file
diff -rN -u old-gestalt/deps/dataflow/doc.txt new-gestalt/deps/dataflow/doc.txt
--- old-gestalt/deps/dataflow/doc.txt 1969-12-31 16:00:00.000000000 -0800
+++ new-gestalt/deps/dataflow/doc.txt 2014-07-29 17:59:52.000000000 -0700
@@ -0,0 +1,7 @@
+Note: note that both the formula as a dependent, and the formula arguments are bound weakly...is that correct? Yes..formulas are supposed to bind arguments; if no arguments are to be bound, then use a function. Functions are used when, for example, we want to display a message independently of the changing object. Example:
+
+(add-dependent some-cell 'changed (lambda (event)
+ (declare (ignore event))
+ (print "hola")))
+
+In this case, we cannot bind the lambda function weakly, because it would get lost. Formulas are different, because they simply calculate a value, and are not supposed to produce a side effect. So, we want them to get lost if we do not bind them from somewhere else than the changing cell.
diff -rN -u old-gestalt/deps/dataflow/examples.lisp new-gestalt/deps/dataflow/examples.lisp
--- old-gestalt/deps/dataflow/examples.lisp 1969-12-31 16:00:00.000000000 -0800
+++ new-gestalt/deps/dataflow/examples.lisp 2014-07-29 17:59:52.000000000 -0700
@@ -0,0 +1,89 @@
+(in-package :dataflow.example)
+
+(wlambda (button)
+ (declare (ignore button))
+ (declare (external those))
+ (setf (color button) 'black)
+ (set-color this 'red)
+ (setf (color that) 'blue)
+ (print (message this))
+ (print those))
+
+(setf *track* t)
+
+(defclass bank-account ()
+ ((money :initform (make-instance 'dfvaluecell :value 0))))
+
+(defparameter *ba* (make-instance 'bank-account))
+
+;; IMPORTANT: note that in *r*, the reference to b is lost, so once
+;; the gc is run, *r* is not updated anymore
+;; Play with (gc :full t) to see that.
+;; The correct version is *w*
+
+(defparameter *r*
+ (let ((suma (let ((slot (slot-value *ba* 'money))
+ (b (make-instance 'dfvaluecell :value 2)))
+ (df
+ (+ slot b)))))
+ (df
+ (format t "Getting value of suma1!!~%")
+ (* suma 5))))
+
+(defparameter *w*
+ (let ((suma (let ((slot (slot-value *ba* 'money))
+ (b 2))
+ (df
+ (declare (external b))
+ (+ slot b)))))
+ (df
+ (format t "Getting value of suma1!!~%")
+ (* suma 5))))
+
+(defparameter *s*
+ (let ((slot (slot-value *ba* 'money)))
+ (df
+ (let*
+ ((value 44)
+ (suma (+ slot value)))
+ (format t "Getting value of suma2!!~%")
+ (* suma value)))))
+
+(setf (value (slot-value *ba* 'money)) 2)
+(setf (value (slot-value *ba* 'money)) 10)
+
+
+;; Example with MOP glue
+
+(setf *track* t)
+
+(defclass b-account ()
+ ((money :initform 0 :dataflow t))
+ (:metaclass dataflow-class))
+
+(defparameter *ba* (make-instance 'b-account))
+
+(defparameter *w*
+ (let ((suma (let ((b 2))
+ (with-df-slots (money) *ba*
+ (df
+ (declare (external b))
+ (+ money b))))))
+ (df
+ (format t "Getting value of suma1!!~%")
+ (* suma 5))))
+
+(defparameter *s*
+ (with-df-slots (money) *ba*
+ (df
+ (let*
+ ((value 44)
+ (suma (+ money value)))
+ (format t "Getting value of suma2!!~%")
+ (* suma value)))))
+
+(setf (slot-value *ba* 'money) 2)
+(format t "Money:~A~%" (slot-value *ba* 'money))
+
+(with-slots (money) *ba*
+ (setf money 3))
\ No newline at end of file
diff -rN -u old-gestalt/deps/dataflow/logging.lisp new-gestalt/deps/dataflow/logging.lisp
--- old-gestalt/deps/dataflow/logging.lisp 1969-12-31 16:00:00.000000000 -0800
+++ new-gestalt/deps/dataflow/logging.lisp 2014-07-29 17:59:53.000000000 -0700
@@ -0,0 +1,29 @@
+(in-package :dataflow)
+
+;; log5 config
+(defcategory mop)
+(defcategory df)
+(defcategory all
+ (or mop df))
+(defcategory none)
+
+(defun start-df-tracking (&key (name 'df)
+ (stream *error-output*))
+ (start-sender name
+ (stream-sender :location stream)
+ :category-spec (list name)
+ :output-spec '(message)))
+
+(defun stop-df-tracking (&optional (name 'df))
+ (stop-sender name))
+
+(defvar *debug* t "Turn off to disable debugging macros. Note you'll have to recompile your code in order for this to be effective")
+
+(defmacro defdbgmacro (name args &rest body)
+ `(defmacro ,name ,args
+ (when *debug*
+ ,@body)))
+
+(defdbgmacro dbg (&body body)
+ `(progn
+ ,@body))
\ No newline at end of file
diff -rN -u old-gestalt/deps/dataflow/mop.lisp new-gestalt/deps/dataflow/mop.lisp
--- old-gestalt/deps/dataflow/mop.lisp 1969-12-31 16:00:00.000000000 -0800
+++ new-gestalt/deps/dataflow/mop.lisp 2014-07-29 17:59:53.000000000 -0700
@@ -0,0 +1,178 @@
+(in-package :dataflow)
+
+;; MOP glue for dataflow
+
+(defclass dataflow-class (standard-class)
+ ()
+ (:documentation "The dataflow objects metaclass"))
+
+(defclass dataflow-object (cell)
+ ((dataflow-slots :initform (make-hash-table :test #'equal)
+ :accessor dataflow-slots))
+ (:documentation "Base class of every dataflow enhanced object. This class is automatically to the list of the object's superclasses by the dataflow-class metaclass"))
+
+(defmethod validate-superclass ((class dataflow-class) (super standard-class))
+ t)
+
+(defmethod shared-initialize :around ((class dataflow-class) slot-names &rest args &key direct-superclasses)
+ "Ensures we inherit from dataflow-object."
+ (log-for mop "Entering: dataflow-class shared-initialize :around~%")
+ (let* ((dataflow-metaclass (find-class 'dataflow-class))
+ (dataflow-object (find-class 'dataflow-object))
+ (not-already-dataflow (loop for superclass in direct-superclasses
+ never (eq (class-of superclass) dataflow-metaclass))))
+ (if (and (not (eq class dataflow-object)) not-already-dataflow)
+ (apply #'call-next-method class slot-names
+ :direct-superclasses (append direct-superclasses (list dataflow-object)) args)
+ (call-next-method)))
+ (log-for mop "Leaving: dataflow-class shared-initialize :around~%"))
+
+(defclass dataflow-slot-mixin ()
+ ((dataflow :initarg :dataflow :initform t :accessor dataflow-slot-p)
+ (test :initarg :test :initform #'eq :accessor dataflow-slot-test)
+ ))
+
+(defmethod print-object ((slot-definition dataflow-slot-mixin) stream)
+ (print-unreadable-object (slot-definition stream :type t :identity t)
+ (format stream " name: ~A dataflow: ~A test: ~A"
+ (slot-definition-name slot-definition)
+ (dataflow-slot-p slot-definition)
+ (dataflow-slot-test slot-definition))))
+
+(defclass dataflow-slot (cell)
+ ((name :initarg :name :accessor dataflow-slot-name)
+ (owner :initarg :owner :accessor dataflow-slot-owner)
+ (test :initarg :test :initform #'eq :reader dataflow-slot-test)
+ ))
+
+(defmethod value ((slot dataflow-slot))
+ (slot-value (dataflow-slot-owner slot) (intern (dataflow-slot-name slot))))
+
+(defmethod (setf value) (new-value (slot dataflow-slot))
+ (setf (slot-value (dataflow-slot-owner slot) (intern (dataflow-slot-name slot))) new-value)
+ ;; Notify the slot changed
+ (trigger-event 'changed
+ :triggerer slot
+ :value new-value))
+
+(defmethod print-object ((object dataflow-slot) stream)
+ (print-unreadable-object (object stream :type t :identity t)
+ (format stream " slot-name: ~A owner: ~A test: ~A"
+ (dataflow-slot-name object)
+ (dataflow-slot-owner object)
+ (dataflow-slot-test object))))
+
+(defclass dataflow-direct-slot-definition
+ (dataflow-slot-mixin standard-direct-slot-definition)
+ ())
+
+(defclass dataflow-effective-slot-definition
+ (dataflow-slot-mixin standard-effective-slot-definition)
+ ())
+
+(defun get-dataflow-slot (slot-name object)
+ (assert (stringp slot-name))
+ (gethash slot-name (dataflow-slots object)))
+
+(defvar *df-mop* nil "Dataflow MOP active or not")
+
+;; And we can provide a convenient macro:
+(defmacro with-df-mop-off (&rest body)
+ `(let ((*df-off* t))
+ ,@body))
+
+(defmethod shared-initialize :after ((obj dataflow-object) slot-names &rest args)
+ "Initialize the dataflow slots of the object"
+ (declare (ignore args))
+ (log-for mop "shared-initialize :after dataflow-object slot-names: ~A~%" slot-names)
+ (loop for slot in (class-slots (class-of obj))
+ do
+ (let ((slot-name (string (slot-definition-name slot))))
+ (assert (stringp slot-name))
+ (log-for mop "Initializing: ~A dataflow: ~A~%" slot (dataflow-slot-p slot) )
+ (when (and
+ (dataflow-slot-p slot)
+ (not (gethash slot-name (dataflow-slots obj))))
+ (setf (gethash slot-name (dataflow-slots obj))
+ (make-instance 'dataflow-slot
+ :name slot-name
+ :owner obj
+ :test (dataflow-slot-test slot)))
+ ))))
+
+(defmethod shared-initialize :around ((obj dataflow-object) slot-names &rest args)
+ (declare (ignore obj slot-names args))
+ (let ((*df-mop* nil))
+ (call-next-method))
+ (setf *df-mop* t))
+
+
+(defmethod (setf slot-value-using-class) (new-value
+ (class dataflow-class)
+ object
+ slot-definition)
+ (if *df-mop*
+ (progn
+ (log-for mop "dataflow-class (setf slot-value-using-class) object: ~A :slotname ~A~%" object (slot-definition-name slot-definition))
+ ;; Now notify the dependents of the change
+ (let ((dataflow-slot (get-dataflow-slot (string (slot-definition-name slot-definition)) object)))
+ (log-for mop "Dataflow slot: ~A~%" dataflow-slot)
+ (call-next-method)
+
+ (when (or (not (slot-boundp object (slot-definition-name slot-definition)))
+ (let ((old-value (slot-value object (slot-definition-name slot-definition))))
+ (not (funcall (dataflow-slot-test dataflow-slot) old-value new-value))))
+
+ ;; Notify the object changed (no need for the object
+ ;; to register as a slot dependent)
+ (trigger-event 'changed
+ :triggerer object
+ :value object
+ ))))
+ ;; else
+ (call-next-method)))
+
+(defmethod direct-slot-definition-class ((class dataflow-class)
+ &rest initargs)
+ (declare (ignore initargs))
+ (find-class 'dataflow-direct-slot-definition))
+
+(defmethod effective-slot-definition-class ((class dataflow-class)
+ &rest initargs)
+ (declare (ignore initargs))
+ (find-class 'dataflow-effective-slot-definition))
+
+(defmethod compute-effective-slot-definition :before ((class dataflow-class) slot-name direct-slots)
+ (log-for mop "compute-effective-slot-definition slot: ~A slots: ~A~%" slot-name direct-slots))
+
+(defmethod compute-effective-slot-definition ((class dataflow-class) name direct-slots)
+ (let ((effective-slot (call-next-method)))
+ (setf (dataflow-slot-p effective-slot)
+ (some #'dataflow-slot-p direct-slots))
+ (setf (dataflow-slot-test effective-slot)
+ (loop for direct-slot in direct-slots
+ when (dataflow-slot-test direct-slot)
+ return (dataflow-slot-test direct-slot)))
+ effective-slot))
+
+(defmethod dataflow-slot-p ((object slot-definition))
+ nil)
+
+(defmethod dataflow-slot-test ((object slot-definition))
+ nil)
+
+(defmacro with-df-slots (slots object &body body)
+ (let
+ ((slots-gensyms (make-hash-table :test #'equal)))
+ (once-only (object)
+ `(let
+ ,(loop for slot in slots
+ collect
+ (let
+ ((slot-gensym (gensym (string-upcase (string slot)))))
+ (setf (gethash slot slots-gensyms) slot-gensym)
+ `(,slot-gensym (get-dataflow-slot ,(string slot) ,object))))
+ (symbol-macrolet
+ ,(loop for slot in slots
+ collect `(,slot ,(gethash slot slots-gensyms)))
+ ,@body)))))
\ No newline at end of file
diff -rN -u old-gestalt/deps/dataflow/package.lisp new-gestalt/deps/dataflow/package.lisp
--- old-gestalt/deps/dataflow/package.lisp 1969-12-31 16:00:00.000000000 -0800
+++ new-gestalt/deps/dataflow/package.lisp 2014-07-29 17:59:53.000000000 -0700
@@ -0,0 +1,61 @@
+(defpackage dataflow
+ (:use :common-lisp
+ :gst.util
+ :closer-mop
+ :log5
+ :trivial-garbage
+ :alexandria
+ :anaphora)
+ (:shadow #:add-dependent
+ #:remove-dependent)
+ (:shadowing-import-from :cl
+ #:defmethod
+ #:defgeneric
+ #:standard-generic-function)
+ (:export
+ ; dataflow cell definitions
+ #:cell
+ #:dependents
+ #:event-dependents
+ #:value-cell
+ #:value
+ #:test
+ #:standard-event
+ #:event
+ #:changed
+ #:formula
+ ; dependency management
+ #:add-dependent
+ #:remove-dependent
+ ; event handling policies
+ #:define-event-handling-policy
+ #:with-events-handling-policy
+ ; events propagation
+ #:trigger-event
+ ; mop
+ #:dataflow-class
+ ; dataflow syntax
+ #:mk-formula
+ #:mk-lambda
+ #:let-df-vars
+ #:using-df-vars
+ #:with-df-vars
+ #:as-df-vars
+ #:with-df-slots
+ ; logging
+ #:start-df-tracking
+ #:stop-df-tracking
+ #:df
+ #:all
+ #:mop
+ #:none
+ ; conditions
+ #:dependency-exists))
+
+(defpackage dataflow.test
+ (:use :cl :dataflow :fiveam)
+ (:shadowing-import-from :fiveam #:test)
+ (:export #:run-tests))
+
+(defpackage dataflow.examples
+ (:use :cl :dataflow))
\ No newline at end of file
diff -rN -u old-gestalt/deps/dataflow/test.lisp new-gestalt/deps/dataflow/test.lisp
--- old-gestalt/deps/dataflow/test.lisp 1969-12-31 16:00:00.000000000 -0800
+++ new-gestalt/deps/dataflow/test.lisp 2014-07-29 17:59:53.000000000 -0700
@@ -0,0 +1,192 @@
+(in-package :dataflow.test)
+
+(def-suite df-tests
+ :description "Dataflow tests")
+
+(defun run-tests ()
+ (run 'df-tests))
+
+(in-suite df-tests)
+
+; dataflow basic elements
+
+(test value-cell-test
+ ;; the value-cell requires a value
+ (signals error
+ (make-instance 'value-cell))
+ ;; notifies its dependents
+ (let ((v (make-instance 'value-cell :value 32)))
+ (is (equalp (value v) 32))
+ (let (set-value)
+ (add-dependent v 'changed
+ (lambda (event)
+ (setf set-value (value event))))
+ (setf (value v) 22)
+ (is (equalp set-value 22))))
+ ;; notifies its dependents once only, if the same value is set
+ (let ((v (make-instance 'value-cell :value 32))
+ (times 0))
+ (add-dependent v 'changed
+ (lambda (event)
+ (declare (ignore event))
+ (incf times)))
+ (setf (value v) 22)
+ (setf (value v) 22)
+ (setf (value v) 22)
+ (is (equalp times 1))))
+
+(test formula-test
+ (let ((x (make-instance 'value-cell :value 10))
+ (y (make-instance 'value-cell :value 10)))
+ (let ((f
+ (make-instance 'formula
+ :arguments (list x y)
+ :formula (lambda (x y)
+ (+ x y)))))
+ (is (equalp (value f) 20))
+ (setf (value x) 20)
+ (is (equalp (value f) 30))
+ (setf (value y) 20)
+ (is (equalp (value f) 40)))))
+
+(test formula-weakness-test
+ (let* ((money (make-instance 'value-cell :value 100))
+ (formula
+ (let ((suma (let ((b 2))
+ (mk-formula (money)
+ (+ money b)))))
+ (mk-formula (suma)
+ (* suma 5))))
+ (formula-value (value formula)))
+ (sb-ext:gc :full t)
+ (setf (value money) 12)
+ ;; the formula shouldn't have been updated since the binding
+ ;; should have been gone with the gc (the binding to the intermediate
+ ;; formula in suma should go away)
+ (is (equalp (value formula) formula-value)))
+
+ ; now, if we use mk-lambda, then we should have no problems,
+ ; because it binds strongly
+ ;; (let* ((money (make-instance 'value-cell :value 100))
+ ;; (formula
+ ;; (let ((suma (let ((b 2))
+ ;; (mk-lambda (money)
+ ;; (+ money b)))))
+ ;; (mk-formula (suma)
+ ;; (* suma 5))))
+ ;; (formula-value (value formula)))
+ ;; (sb-ext:gc :full t)
+ ;; (setf (value money) 12)
+ ;; (is (not (equalp (value formula) formula-value))))
+ )
+
+;; the above test doesnt work because simple closures cannot have dependents (in this case, the formula)
+
+;; design desition 1: global registry of dependents? that way, ANY object can have dependents...
+;; design desition 2: add-dependent returns the binding so we can convert it to a weak one afterwards by calling a weakly function on it??
+;; (weakly (add-dependent cell 'changed some-object))
+
+;; The following test is not working because it seems
+;; the gc is not being run when invoked
+(test weak-dependency-binding-removal-test
+ (let ((money (make-instance 'value-cell :value 100)))
+ (let ((suma (let ((b 2))
+ (mk-formula (money)
+ (+ money b)))))
+ (is (equalp (length (event-dependents 'changed money)) 1)))
+ (trivial-garbage:gc :full t :verbose t)
+ (is (zerop (length (event-dependents 'changed money))))))
+
+; dependency management
+
+(test add-dependent-test
+ (let* ((v (make-instance 'value-cell :value 32))
+ (f (make-instance 'formula
+ :arguments (list v)
+ :formula (lambda (v)
+ (+ v v)))))
+ ;; adding as dependent twice, throws an error
+ (signals dependency-exists
+ (add-dependent v 'changed f))))
+
+(test remove-dependent-test
+ (let* ((v (make-instance 'value-cell :value 22))
+ (f (make-instance 'formula
+ :arguments (list v)
+ :formula (lambda (v)
+ (+ v v)))))
+ (remove-dependent v 'changed f)
+ (setf (value v) 10)
+ (is (equalp (value f) 44))))
+
+
+; event handling policies
+
+(test events-handling-policy-test)
+
+; events propagation
+(test trigger-event-test)
+
+;mop
+(test mop-test)
+
+;dataflow syntax
+(test mk-formula-test)
+(test let-df-vars-test)
+(test using-df-vars-test)
+(test with-df-vars-test)
+(test as-df-vars-test)
+(test with-df-slots-test)
+
+
+;; (defclass bank-account ()
+;; ((money :initform (make-instance 'value-cell :value 0))))
+
+;; (defparameter *ba* (make-instance 'bank-account))
+
+
+;; (defparameter *s*
+;; (let ((slot (slot-value *ba* 'money)))
+;; (mk-formula (slot)
+;; (let*
+;; ((value 44)
+;; (suma (+ slot value)))
+;; (format t "Getting value of suma2!!~%")
+;; (* suma value)))))
+
+;; (setf (value (slot-value *ba* 'money)) 2)
+;; (setf (value (slot-value *ba* 'money)) 10)
+
+;; ;; Example with the new MOP glue
+
+
+;; (defclass b-account ()
+;; ((money :initform 0 :dataflow t))
+;; (:metaclass dataflow-class))
+
+;; (defparameter *ba* (make-instance 'b-account))
+
+;; (defparameter *w*
+;; (let ((suma (let ((b 2))
+;; (with-df-slots (money) *ba*
+;; (df
+;; (declare (external b))
+;; (+ money b))))))
+;; (df
+;; (format t "Getting value of suma1!!~%")
+;; (* suma 5))))
+
+;; (defparameter *s*
+;; (with-df-slots (money) *ba*
+;; (df
+;; (let*
+;; ((value 44)
+;; (suma (+ money value)))
+;; (format t "Getting value of suma2!!~%")
+;; (* suma value)))))
+
+;; (setf (slot-value *ba* 'money) 2)
+;; (format t "Money:~A~%" (slot-value *ba* 'money))
+
+;; (with-slots (money) *ba*
+;; (setf money 3))
\ No newline at end of file