diff --git a/src/hottub/stm.clj b/src/hottub/stm.clj index f1783da..bfa5e7a 100644 --- a/src/hottub/stm.clj +++ b/src/hottub/stm.clj @@ -9,9 +9,9 @@ (defmulti start-state-for-stm (fn [stmid] stmid)) (defmulti is-end-state dispatch-id-state) -(defmethod enter-state :default [stm] stm) +(defmethod enter-state :default [stm] nil) (defmethod exit-state :default [stm]) -(defmethod on-event :default [stm event] stm) +(defmethod on-event :default [stm event] nil) (defmethod on-call :default [stm] nil) (defmethod start-state-for-stm :default [stmid] :start) (defmethod is-end-state :default [stm] (= (:state stm) :end)) @@ -19,33 +19,74 @@ (defn state [stm] (:state stm)) (defn value [stm] (:value stm)) -(defn start [stmid & [value]] - (runI {:id stmid :state (start-state-for-stm stmid) :value value} nil)) - (defn goto [stm state & [value]] (assoc stm :state state :value (or value (:value stm)))) -(defn- runI [stm event] - (if stm - (let [stmnew (if event (on-event stm event) (enter-state stm))] - (cond - (not= (:state stmnew) (:state stm)) - (do - (exit-state stm) - (recur stmnew nil)) - (is-end-state stmnew) - (do - (exit-state stmnew) - (if-let [stmreturn (:return-to stmnew)] - (recur (:return-to stmnew) {:id ::return :stmid (:id stmnew) :state (:state stmnew) :value (:value stmnew)}) - nil)) - (not event) - (if-let [stmcall (on-call stmnew)] - (assoc stmcall :return-to stmnew) - stmnew) - :else stmnew)) - nil)) +(defn post-event [stm event] + (assoc stm :events (conj (:events stm) event))) -(defn run [stm event] - {:pre [event]} - (runI stm event)) +(defn- transition [stepnext fntrans stmold & args] + (if-let [stmnew (apply fntrans stmold args)] + (if-not (= (:state stmnew) (:state stmold)) + (do + (exit-state stmold) + [stmnew :enter]) + [stmnew stepnext]) + [stmold stepnext])) + +(declare start) + +(defn- process-state [stm step] + ;(println step (:state stm) (:value stm) (seq (:events stm))) + (case step + :enter + (let [[stmnew stepnext] (transition :return-from enter-state stm)] + (recur stmnew stepnext)) + :return-from + (if (is-end-state stm) + (do + (exit-state stm) + (if-let [stmreturn (:return-to stm)] + (let [stmreturn (assoc stmreturn :events (:events stm))] + (recur (post-event stmreturn {:id ::return :stmid (:id stm) :state (:state stm) :value (:value stm)}) :events)) + nil)) + (recur stm :call)) + :call + (if-let [[stmid value] (on-call stm)] + (recur (assoc (start stmid value) :return-to (dissoc stm :events) :events (:events stm)) :events) + (recur stm :events)) + :events + (let [queue (:events stm) + event (first queue) + stm (if event (assoc stm :events (pop queue)) stm)] + (if event + (let [[stmnew stepnext] (transition :events on-event stm event)] + (recur stmnew stepnext)) + stm)) + stm)) + +(defn start [stmid & [value]] + (let [stm {:id stmid + :state (start-state-for-stm stmid) + :value value + :events clojure.lang.PersistentQueue/EMPTY}] + (process-state stm :enter))) + +(defn run [stm & events] + (process-state (reduce post-event stm events) :events)) + +(defn- remove-stm-method [stmid multifn] + (doseq [[key method] (methods multifn)] + (if (and (vector? key) (= (first key) stmid)) + (remove-method multifn key)))) + +(defn remove-stm [stmid] + (doseq [multifn [enter-state exit-state on-event on-call start-state-for-stm is-end-state]] + (remove-stm-method stmid multifn))) + +(defmacro defstm [stmid & body] + `(doto ~stmid + (remove-stm) + ~@body)) + +(defmacro defseries [stmid [startstate afterstate] & statedefs]) \ No newline at end of file diff --git a/src/hottub/stm/input.clj b/src/hottub/stm/input.clj index 2bc3633..9721f7c 100644 --- a/src/hottub/stm/input.clj +++ b/src/hottub/stm/input.clj @@ -14,35 +14,22 @@ (defn advance [stm input state-next activehigh] (let [active (is-active input (stm/value stm))] (if (or (and activehigh active) (and (not activehigh) (not active))) - (stm/goto stm state-next) - stm))) + (stm/goto stm state-next)))) (defmethod stm/enter-state [:click :start] [stm] (let [input-now (:input (first (gs/q :name :input)))] - (advance stm input-now :wait-for-press false))) + (stm/post-event stm (assoc input-now :type :input)))) (defmethod stm/on-event [:click :start] [stm event] (if (is-input-event event) - (advance stm event :wait-for-press false) - stm)) + (advance stm event :wait-for-press false))) (defmethod stm/on-event [:click :wait-for-press] [stm event] (if (is-input-event event) - (advance stm event :wait-for-release true) - stm)) + (advance stm event :wait-for-release true))) (defmethod stm/on-event [:click :wait-for-release] [stm event] (if (is-input-event event) - (advance stm event :end false) - stm)) + (advance stm event :end false))) -(gs/with-gs gs/gs-empty - (gs/add-index :name) - (gs/set-entity (gs/gen-id) {:name :input :input {:mousebuttons #{:left}}}) - (-> (stm/start :click) - (stm/run {:type :input :mousebuttons #{}}) - ;(stm/run {:type :input :mousebuttons #{:left}}) - ;(stm/run {:type :input :mousebuttons #{:left}}) - ;(stm/run {:type :input :mousebuttons #{}}) -))