Clojure FSM sample

auto.clj

(ns sentinel.auto
  (:require [taoensso.timbre :as timbre]
            [clojure.core.match.date :refer :all]
            [clojure.core.match :refer [match]]
            [clojure.core.match.regex :refer :all]
            [clojure.string :as st]
            [clojure.core.async :refer [chan close! buffer go-loop to-chan <! >! >!! <!!] :as async]
            [clojure.core.async.impl.protocols :as impl]
            [clojure.spec.alpha :as s]
            [clojure.core.async :as async]))



(timbre/refer-timbre)


(def line-cleaner (comp st/trim-newline st/lower-case))


(s/def ::node keyword?)
(s/def ::pattern vector?)
(s/def ::emit-value (s/or :string string? :coll (s/coll-of string?)))
(s/def ::state-handler (s/or :inline seq?
                             :reference symbol?))

(s/def ::transition (s/cat :pattern ::pattern
                           :handler (s/? ::state-handler)
                           :emit (s/? ::emit-value)
                           :to (s/? ::node)))

(s/def ::recursive boolean?)

(s/def ::flags (s/keys :opt-un [::recursive]))

(s/def ::state-vector
  (s/cat :from (s/or :node ::node
                     :nodes (s/coll-of keyword? :kind vector?))
         :flags (s/? ::flags)
         :transitions (s/* ::transition)))


(s/def ::fsm-definition (s/coll-of ::state-vector))

(defmacro fsm1 [& body]
  (let [conformed-body (s/conform ::fsm-definition body)]
    (if (= conformed-body ::s/invalid)
      (s/explain ::fsm-definition body)
      conformed-body)))


(defmacro fsm [[state-symbol input-symbol] & body]
  (let [conformed-body (s/conform ::fsm-definition body)
        state-sym (gensym 'state)
        input-sym (gensym 'input)
        conformed-body (map #(update % :from second) conformed-body)
        cases# (->> conformed-body
                    (mapcat (fn [{:keys [from flags transitions]}]
                              (if (seq transitions)
                                (mapv (fn [transition]
                                        (assoc transition
                                          :from from
                                          :flags flags))
                                      transitions)
                                [{:from from}]))))
        single-cases (filter (comp keyword? :from) cases#)
        multi-cases (->> cases#
                         (filter (comp vector? :from))
                         (mapcat (fn [{nodes :from :as case}]
                                   (map #(assoc case :from %) nodes))))
        cases# (concat multi-cases single-cases)
        termination-nodes (->> conformed-body (remove :transitions) (map :from) set)]
    ;(println "Conformed" conformed-body)
    ;(println "Multi Cases" multi-cases)
    ;(println "Cases" cases#)
    ;(println "Termination nodes" termination-nodes)
    `(fn [{node# :node :as ~state-sym} ~input-sym]
       (let [~state-symbol ~state-sym
             ~input-symbol ~input-sym
             ~state-sym (dissoc ~state-sym :emit)]
         ;(println "INPUT" ~input-sym)
         (match [node# ~state-sym ~input-sym]
           ~@(mapcat (fn [{:keys [from to pattern emit]
                           [handler-type handler] :handler
                           {:keys [recursive] :as flags} :flags}]
                       [(vec (cons from (or pattern '[_ _])))
                        `(assoc ~(cond
                                   handler (list handler state-sym input-sym)
                                   emit `(assoc ~state-sym :emit ~(second emit))
                                   :default state-sym)
                           :node ~to
                           :terminated? ~(contains? termination-nodes to)
                           :recursive? ~recursive)])
                     cases#))))))



(def knock
  (fsm [state input]
    [:hello
     [_ :client/connect] "Someone is at the door.." :rec]
    [:rec {:recursive true}
     [_ _] (fn [_ _] {:emit "+OK UPDATE"}) :start]
    [:start
     [_ ("knock knock" :guard #(= input %))] "Who is there" :who-is-there
     [_ _] "Huh?" :start]
    [:who-is-there
     [_ "doctor"] "Doctor who?" :ask-name
     [_ _] "I am waiting for a doctor" :start]
    [:ask-name
     [_ input] (fn [_ i] {:emit (str "Hello Dr. " input)}) :start]
    [[:start :who-is-there]
     [_ "quit"] "Bye!!!" :quit]
    [:quit]))



(defn automate
  "Returns a state machine transducer"
  [fsm initial-state]
  (fn [xf]
    (trace "Creating automate with init" initial-state)
    (let [state (volatile! initial-state)]
      (fn
        ([] (xf))
        ([result]
         (xf result))
        ([result input]
         (let [{:keys [terminated? recursive? node] :as new-state} (fsm @state input)]
           (trace "New node:" node)
           (vswap! state merge new-state)
           (cond
             recursive? (do
                          (xf result new-state)
                          (recur result input)) 
             terminated? (ensure-reduced (xf result new-state))
             :default (xf result new-state))))))))