Initial state machine skeleton with testcase
This commit is contained in:
parent
d7c4cac751
commit
e646c8f7e6
51
src/hottub/stm.clj
Normal file
51
src/hottub/stm.clj
Normal file
|
@ -0,0 +1,51 @@
|
||||||
|
(ns hottub.stm)
|
||||||
|
|
||||||
|
(defn- dispatch-id-state [stm] [(:id stm) (:state stm)])
|
||||||
|
(defmulti enter-state dispatch-id-state)
|
||||||
|
(defmulti exit-state dispatch-id-state)
|
||||||
|
(defmulti on-event (fn [stm event] (dispatch-id-state stm)))
|
||||||
|
(defmulti on-call dispatch-id-state)
|
||||||
|
|
||||||
|
(defmulti start-state-for-stm (fn [stmid] stmid))
|
||||||
|
(defmulti is-end-state dispatch-id-state)
|
||||||
|
|
||||||
|
(defmethod enter-state :default [stm] stm)
|
||||||
|
(defmethod exit-state :default [stm])
|
||||||
|
(defmethod on-event :default [stm event] stm)
|
||||||
|
(defmethod on-call :default [stm] nil)
|
||||||
|
(defmethod start-state-for-stm :default [stmid] :start)
|
||||||
|
(defmethod is-end-state :default [stm] (= (:state stm) :end))
|
||||||
|
|
||||||
|
(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 run [stm event]
|
||||||
|
{:pre [event]}
|
||||||
|
(runI stm event))
|
48
src/hottub/stm/input.clj
Normal file
48
src/hottub/stm/input.clj
Normal file
|
@ -0,0 +1,48 @@
|
||||||
|
;; Anything you type in here will be executed
|
||||||
|
;; immediately with the results shown on the
|
||||||
|
;; right.
|
||||||
|
(ns hottub.stm.input
|
||||||
|
(:require [hottub.stm :as stm]
|
||||||
|
[hottub.gs :as gs]))
|
||||||
|
|
||||||
|
(defn is-active [input v]
|
||||||
|
(contains? (:mousebuttons input) :left))
|
||||||
|
|
||||||
|
(defn is-input-event [event]
|
||||||
|
(= (:type event) :input))
|
||||||
|
|
||||||
|
(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)))
|
||||||
|
|
||||||
|
(defmethod stm/enter-state [:click :start] [stm]
|
||||||
|
(let [input-now (:input (first (gs/q :name :input)))]
|
||||||
|
(advance stm input-now :wait-for-press false)))
|
||||||
|
|
||||||
|
(defmethod stm/on-event [:click :start] [stm event]
|
||||||
|
(if (is-input-event event)
|
||||||
|
(advance stm event :wait-for-press false)
|
||||||
|
stm))
|
||||||
|
|
||||||
|
(defmethod stm/on-event [:click :wait-for-press] [stm event]
|
||||||
|
(if (is-input-event event)
|
||||||
|
(advance stm event :wait-for-release true)
|
||||||
|
stm))
|
||||||
|
|
||||||
|
(defmethod stm/on-event [:click :wait-for-release] [stm event]
|
||||||
|
(if (is-input-event event)
|
||||||
|
(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