Store event queue in stm; allows enter-state to post fake events
allow returning nil from enter-state, on-event change on-call to return a [stmid value] rather than an arbitrary stm, too much weird shit can go wrong function to remove a state machine's code starting to build helper macros for defining state machines
This commit is contained in:
parent
e646c8f7e6
commit
eb089cacbc
|
@ -9,9 +9,9 @@
|
||||||
(defmulti start-state-for-stm (fn [stmid] stmid))
|
(defmulti start-state-for-stm (fn [stmid] stmid))
|
||||||
(defmulti is-end-state dispatch-id-state)
|
(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 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 on-call :default [stm] nil)
|
||||||
(defmethod start-state-for-stm :default [stmid] :start)
|
(defmethod start-state-for-stm :default [stmid] :start)
|
||||||
(defmethod is-end-state :default [stm] (= (:state stm) :end))
|
(defmethod is-end-state :default [stm] (= (:state stm) :end))
|
||||||
|
@ -19,33 +19,74 @@
|
||||||
(defn state [stm] (:state stm))
|
(defn state [stm] (:state stm))
|
||||||
(defn value [stm] (:value 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]]
|
(defn goto [stm state & [value]]
|
||||||
(assoc stm :state state :value (or value (:value stm))))
|
(assoc stm :state state :value (or value (:value stm))))
|
||||||
|
|
||||||
(defn- runI [stm event]
|
(defn post-event [stm event]
|
||||||
(if stm
|
(assoc stm :events (conj (:events stm) event)))
|
||||||
(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 run [stm event]
|
(defn- transition [stepnext fntrans stmold & args]
|
||||||
{:pre [event]}
|
(if-let [stmnew (apply fntrans stmold args)]
|
||||||
(runI stm event))
|
(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])
|
|
@ -14,35 +14,22 @@
|
||||||
(defn advance [stm input state-next activehigh]
|
(defn advance [stm input state-next activehigh]
|
||||||
(let [active (is-active input (stm/value stm))]
|
(let [active (is-active input (stm/value stm))]
|
||||||
(if (or (and activehigh active) (and (not activehigh) (not active)))
|
(if (or (and activehigh active) (and (not activehigh) (not active)))
|
||||||
(stm/goto stm state-next)
|
(stm/goto stm state-next))))
|
||||||
stm)))
|
|
||||||
|
|
||||||
(defmethod stm/enter-state [:click :start] [stm]
|
(defmethod stm/enter-state [:click :start] [stm]
|
||||||
(let [input-now (:input (first (gs/q :name :input)))]
|
(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]
|
(defmethod stm/on-event [:click :start] [stm event]
|
||||||
(if (is-input-event event)
|
(if (is-input-event event)
|
||||||
(advance stm event :wait-for-press false)
|
(advance stm event :wait-for-press false)))
|
||||||
stm))
|
|
||||||
|
|
||||||
(defmethod stm/on-event [:click :wait-for-press] [stm event]
|
(defmethod stm/on-event [:click :wait-for-press] [stm event]
|
||||||
(if (is-input-event event)
|
(if (is-input-event event)
|
||||||
(advance stm event :wait-for-release true)
|
(advance stm event :wait-for-release true)))
|
||||||
stm))
|
|
||||||
|
|
||||||
(defmethod stm/on-event [:click :wait-for-release] [stm event]
|
(defmethod stm/on-event [:click :wait-for-release] [stm event]
|
||||||
(if (is-input-event event)
|
(if (is-input-event event)
|
||||||
(advance stm event :end false)
|
(advance stm event :end false)))
|
||||||
stm))
|
|
||||||
|
|
||||||
(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 #{}})
|
|
||||||
))
|
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue