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:
Jeremy Penner 2013-04-02 23:31:18 -04:00
parent e646c8f7e6
commit eb089cacbc
2 changed files with 74 additions and 46 deletions

View file

@ -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])

View file

@ -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 #{}})
))