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 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])
|
|
@ -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 #{}})
|
||||
))
|
||||
|
||||
|
|
Loading…
Reference in a new issue