mirror of
https://github.com/marcosh/crem.git
synced 2024-09-11 12:36:19 +03:00
state machines have an instance of Choice
This commit is contained in:
parent
91462083ad
commit
c97e7bf21e
@ -4,7 +4,7 @@ module CRM.BaseMachine where
|
||||
|
||||
import CRM.Topology
|
||||
import "base" Data.Kind (Type)
|
||||
import "profunctors" Data.Profunctor (Profunctor (..), Strong (..))
|
||||
import "profunctors" Data.Profunctor (Choice (..), Profunctor (..), Strong (..))
|
||||
|
||||
-- * Specifying state machines
|
||||
|
||||
@ -57,6 +57,25 @@ instance Strong (BaseMachine topology) where
|
||||
, action = \state (c, a) -> (c,) <$> action state a
|
||||
}
|
||||
|
||||
instance Choice (BaseMachine topology) where
|
||||
left' :: BaseMachine topology a b -> BaseMachine topology (Either a c) (Either b c)
|
||||
left' (BaseMachine initialState action) =
|
||||
BaseMachine
|
||||
{ initialState = initialState
|
||||
, action = \state -> \case
|
||||
Left a -> Left <$> action state a
|
||||
Right c -> ActionResult state (Right c)
|
||||
}
|
||||
|
||||
right' :: BaseMachine topology a b -> BaseMachine topology (Either c a) (Either c b)
|
||||
right' (BaseMachine initialState action) =
|
||||
BaseMachine
|
||||
{ initialState = initialState
|
||||
, action = \state -> \case
|
||||
Left c -> ActionResult state (Left c)
|
||||
Right a -> Right <$> action state a
|
||||
}
|
||||
|
||||
-- | A value of type `InitialState state` describes the initial state of a
|
||||
-- state machine, describing the initial `vertex` in the `topology` and the
|
||||
-- actual initial data of type `state vertex`
|
||||
|
@ -5,7 +5,7 @@ module CRM.StateMachine where
|
||||
|
||||
import CRM.BaseMachine
|
||||
import CRM.Topology
|
||||
import "profunctors" Data.Profunctor (Profunctor (..), Strong (..))
|
||||
import "profunctors" Data.Profunctor (Choice (..), Profunctor (..), Strong (..))
|
||||
import "singletons-base" Data.Singletons (Demote, SingI, SingKind)
|
||||
|
||||
-- | A `StateMachine` is a [Mealy machine](https://en.wikipedia.org/wiki/Mealy_machine)
|
||||
@ -59,3 +59,12 @@ instance Strong StateMachine where
|
||||
second' (Compose machine1 machine2) = Compose (second' machine1) (second' machine2)
|
||||
|
||||
-- * Choice
|
||||
|
||||
instance Choice StateMachine where
|
||||
left' :: StateMachine a b -> StateMachine (Either a c) (Either b c)
|
||||
left' (Basic baseMachine) = Basic $ left' baseMachine
|
||||
left' (Compose machine1 machine2) = Compose (left' machine1) (left' machine2)
|
||||
|
||||
right' :: StateMachine a b -> StateMachine (Either c a) (Either c b)
|
||||
right' (Basic baseMachine) = Basic $ right' baseMachine
|
||||
right' (Compose machine1 machine2) = Compose (right' machine1) (right' machine2)
|
||||
|
Loading…
Reference in New Issue
Block a user