Hierarchical State Machine in F#

Question

I appreciate any feedback on where I might alter or improve my code for this project. This is an old attempt at implementing a Hierarchical State Machine in F#. I'm from a C#/OO background mostly.

module FSharp.HSM 

open Option
open System.Collections.Generic

exception NoTransition
exception NotInitialized
exception AlreadyStarted

type IStateMachine<'state,'event> =
  abstract member StateChanged: IEvent<'state>
  abstract member Init: 'state -> unit
  abstract member State: 'state with get
  abstract member IsIn: 'state -> bool

  abstract member Fire: 'event -> unit
  abstract member Fire: 'event * obj -> unit


type Transition<'state,'event> = 
  { Event: 'event 
    NextState: 'event -> obj -> 'state option
    Guard: unit -> bool }

type StateConfig<'state,'event> = 
  { State: 'state
    Entry: unit -> unit
    Exit: unit -> unit
    SuperState: 'state option
    Parents: 'state list
    AutoTransition: 'state option
    Transitions: Transition<'state,'event> list }

type internal StateMachine<'state,'event when 'state : equality and 'event :equality>(stateList:StateConfig<'state,'event> list) = 
    let stateEvent = new Event<'state>()
    let mutable current = stateList.Head.State
    let mutable started = false
    let states = stateList |> List.map (fun x -> x.State) |> List.toArray
    let configs = new Dictionary<'state,StateConfig<'state,'event>>()
    let find state : StateConfig<'state,'event> = configs.[state]
    let rec getParents results state =
      let currentConfig = stateList |> List.find (fun x -> x.State = state)
      if isSome currentConfig.SuperState then 
        let super = get currentConfig.SuperState
        getParents (super::results) super
      else results |> List.rev

    do 
      for stateConfig in stateList do
        configs.[stateConfig.State] <- { stateConfig with Parents = getParents [] stateConfig.State }

    let rec findTransition event state = 
      match state.Transitions |> List.tryFind (fun x -> x.Event = event), state.SuperState with
      | None, None -> raise NoTransition
      | None, Some x -> findTransition event (find x)
      | Some x, _ -> x

    let rec exitToCommonParent state limit = 
      match state.SuperState, limit with
      | None, _ -> ()
      | Some super, Some lim when super = lim -> ()
      | Some super, _  -> 
          let superConfig = find super
          superConfig.Exit()
          exitToCommonParent superConfig limit 

    let rec findCommon (list1:'state list) list2 = 
        if list1.IsEmpty then None else
        let restOfList1 = list1.Tail
        match list2 |> List.tryFind (fun x -> x = list1.Head), restOfList1 with
        | None, [] -> None
        | None, _ -> findCommon restOfList1 list2
        | Some x, _ -> Some(x)

    let rec transition currentState newState = 
      let currentStateConfig = find currentState
      let newStateConfig = find newState

      let isSelf = currentStateConfig.State = newStateConfig.State
      let moveToSub = not isSelf || newStateConfig.Parents |> List.exists (fun x -> x = currentState)
      let commonParent = if isSelf then None else findCommon currentStateConfig.Parents newStateConfig.Parents 

      if not moveToSub || isSelf then 
        currentStateConfig.Exit()

      exitToCommonParent currentStateConfig commonParent

      //enter parents below common Parents before newState, 
      //but not if we just autoed from there..
      match commonParent with
      | None -> ()
      | Some x -> //todo: optimize this
          let revParents = newStateConfig.Parents |> List.rev 
          let index = revParents |> List.findIndex (fun y -> y = x)
          for parent in revParents |> Seq.skip (index + 1) do
            if parent <> currentState then (find parent).Entry()

      current <- newState
      newStateConfig.Entry()
      stateEvent.Trigger newState

      match newStateConfig.AutoTransition with
      | None -> ()
      | Some x -> transition newState x
    interface IStateMachine<'state, 'event> with
      ///Initializes the state machine with its initial state
      member this.Init state = 
        if started then raise AlreadyStarted else started <- true
        let stateConfig = find state
        current <- state
        stateConfig.Entry()
        stateEvent.Trigger current
        match stateConfig.AutoTransition with
        | None -> ()
        | Some x -> transition state x
      ///Gets the current state
      member this.State with get() = if not started then raise NotInitialized else current
      ///Raise on a state change
      member this.StateChanged = stateEvent.Publish
      ///Check whether in state or parent state
      member this.IsIn (state:'state) = 
        if not started then raise NotInitialized
        if current = state then true else
          (find current).Parents |> List.exists (fun x -> x = state)
      ///Fire an event without data
      member this.Fire(event) = 
        if not started then raise NotInitialized
        let cur = find current
        let trans = findTransition event cur
        if trans.Guard() then 
          let nextState = trans.NextState event null
          if isSome nextState then 
            transition current (get nextState)
      ///Fire an event with data
      member this.Fire(event, data) = 
        let cur = find current
        let trans = findTransition event cur
        if trans.Guard() then
          let nextState = trans.NextState event data
          if isSome nextState then 
            transition current (get nextState)

let create(stateList:StateConfig<'state,'event> list) = (new StateMachine<'state,'event>(stateList)) :> IStateMachine<'state,'event>
///Sets up a new state config 
let configure state = 
  { State = state; Entry = (fun () -> ()); Exit = (fun () -> ()); 
    SuperState = None; Parents = []; AutoTransition = None; Transitions = [] }
///Sets an action on the entry of the state
let onEntry f state = {state with Entry = f }
///Sets an action on the exit of the state
let onExit f state = {state with Exit = f }
///Sets this state as a substate of the given state
let substateOf superState state = { state with SuperState = Some(superState) }
///Sets an auto transition to a new state
let transitionTo substate state = { state with AutoTransition = Some(substate) }
///Sets a transition to a new state on an event (same state allows re-entry)
let on event endState state =
  { state with Transitions = 
    { Event = event; NextState = (fun _ _ -> Some(endState)); Guard = (fun () -> true) }::state.Transitions }
///Sets a guarded transition to a new state on an event (same state allows re-entry)
let onIf event guard endState state = 
  { state with Transitions = 
    { Event = event; NextState = (fun _ _ -> Some(endState)); Guard = guard }::state.Transitions }
///Sets an event handler (with or without data) which returns the new state to transition to
let handle event f state = 
  { state with Transitions = 
    { Event = event; NextState = f; Guard = (fun () -> true) }::state.Transitions }
///Sets a guarded event handler (with or without data) which returns the new state
let handleIf event guard f state = 
  { state with Transitions = 
    { Event = event; NextState = f; Guard = guard }::state.Transitions }

Here's a simple example from some test code:

type State = 
    | OffHook
    | Ringing
    | Connected //composite
    | InCall
    | OnHold

type Trigger =
    | CallDialed 
    | HungUp 
    | CallConnected 
    | PlacedOnHold
    | TakenOffHold

let mutable timerOn = false
let startTimer() = 
    printfn "%A connected" DateTime.Now
    timerOn <- true
let stopTimer() = 
    printfn "%A ended" DateTime.Now
    timerOn <- false

let newPhoneCall() = 
  [ configure OffHook
      |> on CallDialed Ringing
    configure Ringing
      |> on CallConnected Connected
    configure Connected
      |> onEntry startTimer
      |> onExit stopTimer
      |> transitionTo InCall
      |> on HungUp OffHook
    configure InCall
      |> substateOf Connected
      |> on PlacedOnHold OnHold
    configure OnHold
      |> substateOf Connected
      |> on TakenOffHold InCall ] 
  |> create

and a much more complicated example from an article about HSM's I used as a ref:

type State = 
    | S0
    | S1
    | S11
    | S2
    | S21
    | S211

type Sig =
    | A 
    | B 
    | C 
    | D
    | E
    | F
    | G
    | H

type ComplexHSM() = 
  let mutable foo = false
  let hsm = [ configure S0
                |> onEntry (fun () -> printfn "Enter S0")
                |> onExit (fun () -> printfn "Exit S0")
                |> transitionTo S1
                |> on E S211
              configure S1
                |> onEntry (fun () -> printfn "Enter S1")
                |> onExit (fun () -> printfn "Exit S1")
                |> substateOf S0
                |> transitionTo S11
                |> on A S1 
                |> on B S11
                |> on C S211 
                |> on D S0 
                |> on F S211 
              configure S11
                |> onEntry (fun () -> printfn "Enter S11")
                |> onExit (fun () -> printfn "Exit S11")
                |> substateOf S1
                |> on G S211 
                |> handleIf H (fun () -> foo) (fun event arg -> printfn "fooFal"; foo <- false; None)
              configure S2
                |> onEntry (fun () -> printfn "Enter S2")
                |> onExit (fun () -> printfn "Exit S2")
                |> substateOf S0
                |> on C S1 
                |> on F S11 
              configure S21
                |> onEntry (fun () -> printfn "Enter S21")
                |> onExit (fun () -> printfn "Exit S21")
                |> substateOf S2
                |> transitionTo S211
                |> on B S211 
                |> handleIf H (fun () -> not foo) (fun event arg -> printfn "fooTru"; foo <- true; Some(S21) )
              configure S211
                |> onEntry (fun () -> printfn "Enter S211")
                |> onExit (fun () -> printfn "Exit S211")
                |> substateOf S21
                |> on D S21
                |> on G S0 ]  
          |> create
  member this.Hsm with get() = hsm

Answer 1

let rec getParents results state =
  let currentConfig = stateList |> List.find (fun x -> x.State = state)
  if isSome currentConfig.SuperState then 
    let super = get currentConfig.SuperState
    getParents (super::results) super
  else results |> List.rev

I think it's cleaner to use pattern matching here, it would avoid having to repeat currentConfig.SuperState.

Also, using accumulator like this makes sense if the results from the deepest level of recursion should be first, not last. But that's not what you want, so you can just drop the accumulator and then do something like super::(getParents super).

The rewritten function would look like this:

let rec getParents state =
  let currentConfig = stateList |> List.find (fun x -> x.State = state)
  match currentConfig.SuperState with
  | None -> []
  | Some super -> super::(getParents super)

It's possible you intentionally wrote it the way you did, because it's tail recursive, so it won't blow up your stack no matter how deep the recursion is. If that's the case, then I think you should make sure stack overflow is a real risk with the non-tail-recursive version. And then you should add a comment that explains that's the reason why you wrote it that way.

Answer 2

Review

Implementing a Hierarchical State Machine can get really tricky. You have a done a decent job, using both Mealy and Moore concepts. There are a couple of aspects that still require to be addressed further to make this a reusable API:

• pseudo states (fork, join infrastructure)
• (deep) history states (when entering a state with composite states, the default entry might be to enter its last activated state)
• exception handling (should you fallback to an error state or recover a history state?)
• local vs external vs internal transition (self-transitions can be internal or external, transitioning to substates can be local or external)
• there is entry and exit behavior, but no do behavior
• triggers should also have specific event data attached
• event deferral options (priority and deferral of events)
• event conflict resolution if both a state and substate allow to handle the event
• dynamic transition flow resolution (based on extended state, transition tables and guards, make a transition plan at runtime)

Extended state

What I'm really missing is extended state. This is data available to all states in the state machine. Each state should be able to access and change the extended state and consult it in the behavior, transition and auto-transition guards.