Experimental state-machine support.

src/clojure/freactive/core.cljs

@@ -372,6 +372,135 @@
   ([ref korks-or-getter] (cursor* ref korks-or-getter nil true ))
   ([ref getter setter] (cursor* ref getter setter true)))
 
-(defn debug-rx* [the-rx capture-callback invalidation-callback]
-  (add-invalidation-watch the-rx capture-callback invalidation-callback)
-  (add-invalidation-watch the-rx capture-callback invalidation-callback))
+;(defn debug-rx* [the-rx capture-callback invalidation-callback]
+;  (add-invalidation-watch the-rx capture-callback invalidation-callback)
+;  (add-invalidation-watch the-rx capture-callback invalidation-callback))
+
+(deftype StateMachine [state state-transtions allowed-states default-accept
+                       watches]
+  Object
+  (equiv [this other]
+    (-equiv this other))
+
+  IReactive
+  (-raw-deref [_] state)
+
+  cljs.core/IEquiv
+  (-equiv [o other] (identical? o other))
+
+  cljs.core/IDeref
+  (-deref [this]
+    (when-let [invalidate *invalidate-rx*]
+      (-add-watch this invalidate invalidate)
+      (when *trace-capture* (*trace-capture* this)))
+    state)
+
+  IMeta
+  (-meta [_] meta)
+
+  IPrintWithWriter
+  (-pr-writer [a writer opts]
+    (-write writer "#<StateMachine: ")
+    (pr-writer state writer opts)
+    (-write writer ">"))
+
+  IWatchable
+  (-notify-watches [this oldval newval]
+    (doseq [[key f] watches]
+      (f key this oldval newval)))
+  (-add-watch [this key f]
+    (set! (.-watches this) (assoc watches key f))
+    this)
+  (-remove-watch [this key]
+    (set! (.-watches this) (dissoc watches key)))
+
+  IHash
+  (-hash [this] (goog/getUid this))
+
+  IReset
+  (-reset! [this new-state]
+    (let [old-state state]
+      (when-not (keyword-identical? new-state old-state)
+        (set! (.-state this) new-state)
+        (-notify-watches this old-state new-state)))
+    state))
+
+(defn- test-transition
+  ([transition]
+   (cond (identical? transition true) true
+         (identical? transition false) false
+         :default (transition)))
+  ([transition arg]
+   (cond (identical? transition true) true
+         (identical? transition false) false
+         :default (transition arg))))
+
+(defn transition-to!
+  "Attempts to transition the state-machine to the requested-state. Returns
+  the state of the machine after the request has been made."
+  [state-machine requested-state]
+  (let [cur-state (.-state state-machine)]
+    (if-not (keyword-identical? cur-state requested-state)
+      (let [transitions (.-transition-map state-machine)
+            allowed-states (.-allowed-states state-machine)]
+        (if
+          (and
+            (if allowed-states
+              (allowed-states requested-state)
+              true)
+            (if-let [from-to-transition (get transitions
+                                             (keyword (str ":from-" cur-state
+                                                           "-to-" requested-state)))]
+              (test-transition from-to-transition)
+              (if-let [from-transition (get transitions (keyword (str ":from-" cur-state)))]
+                (when (test-transition from-transition requested-state)
+                  (if-let [to-transition (get transitions (keyword (str "to-" requested-state)))]
+                    (test-transition to-transition cur-state)
+                    (.-default-accept state-machine)))
+                (if-let [to-transition (get transitions (keyword (str "to-" requested-state)))]
+                  (test-transition to-transition cur-state)
+                  (.-default-accept state-machine)))))
+          (do
+            (set! (.-state state-machine) requested-state)
+            (when-let [after (get state-machine (keyword (str "after-"
+                                                              cur-state)))]
+              (after requested-state))
+            (when-let [on (get state-machine (keyword (str "on-" cur-state)))]
+              (on cur-state))
+            requested-state)
+          cur-state))
+      cur-state)))
+
+(defn state-machine
+  "Takes an initial-state and a map of state-transitions.
+
+  A state transition is named by a keyword that can be prefixed with either
+  :from- and to-. A convenience :from-state1-to-state2 form is
+  also allowed.
+
+  :from- and :to- transitions are used as tests to check if a requested
+  transiton is allowed and should either be a function taking a single parameter
+  representing the requested state (for :from- transitions) or the current state
+  (for :to- transitions) - or - a boolean value representing an unconditional
+  accept/reject for that transition. In order for a :from- or :to- transition
+  to succeed it must return a truthy value. If the matching transition
+  function is not found the :default-accept policy will be used. Convienence
+  :from-state1-to-state2 will take priority over :from- and :to- transitions
+  and take a 0-arity function or a boolean value.
+
+  For example, if the current state is :off and the state
+  requested is :on, The state machine will attempt to first to find a
+  transition named :from-off. If that succeeds it will look for a :to-on
+  transition. If that succeeds, the new state will be :on.
+
+  A set of allowed-states can also be defined and any other states will be
+  rejected.
+  "
+  [initial-state state-transitions
+                     & {:keys [default-accept allowed-states]
+                        :or  {default-accept true}}]
+  (assert (keyword? initial-state) "state must be keyword")
+  (when allowed-states
+    (assert (set? allowed-states) "allowed-states must be a set")
+    (assert (allowed-states initial-state) "initial-state must be in allowed states"))
+  (StateMachine. initial-state state-transitions allowed-states default-accept nil))

test/freactive/core_test.cljs

@@ -1,7 +1,8 @@
 (ns freactive.core-test
   (:refer-clojure :exclude [atom])
   (:require
-    [freactive.core :refer [atom cursor]]
+    [freactive.core :refer [atom cursor state-machine
+                            transition-to!]]
     [cljs.reader]
     [cemerick.cljs.test :refer-macros [deftest is run-tests]])
   (:require-macros [freactive.macros :refer [rx]]))
@@ -34,3 +35,59 @@
     (is (= @a {:b 1}))
     (reset! a {:c 2})
     (is (= @l "{:c 2}"))))
+
+;(defn sm1
+;  (state-machine
+;    :init
+;    {:from-init (fn [to] true)
+;     :to-init (fn [from] false)
+;     :to-running (fn [from]
+;                   (if (or (= from :init) (= :from :stopped))
+;                     true))
+;     :from-running {fn [to]
+;                    (when (= to :)
+;                      true)}
+;     :to-stopped (fn [from]
+;                   (when (= from :running)
+;                     true))
+;     :from-stopped (fn [to]
+;                     (when (= to :running)
+;                       true))}))
+
+(defn sm1 []
+  (state-machine
+    :init
+    {:from-init true
+     :to-init false
+     :from-running-to-stopped true
+     :from-stopped-to-running true
+     :to-finished true
+     :from-finished false}
+    :default-accept false
+    :allowed-states #{:init :running :stopped :finished}))
+
+(defn sm2 []
+  (state-machine
+    :init
+    {:from-init #(true)
+     :to-init #(false)
+     :from-running-to-stopped #(true)
+     :from-stopped-to-running #(true)
+     :to-finished #(true)
+     :from-finished #(false)}
+    :default-accept false
+    :allowed-states #{:init :running :stopped :finished}))
+
+(defn test-sm [sm]
+  (is (= @sm :init))
+  (is (= (transition-to! sm :running)) :running)
+  (is (= (transition-to! sm :stopped)) :stopped)
+  (is (= (transition-to! sm :running)) :running)
+  (is (= (transition-to! sm :finished)) :finished)
+  (is (= (transition-to! sm :running)) :finished)
+  (is (= (transition-to! sm :test1)) :finished)
+  )
+
+(deftest state-machine-test
+  (test-sm (sm1))
+  (test-sm (sm2)))