mirror of
https://github.com/marcosh/crem.git
synced 2024-09-11 12:36:19 +03:00
allow machines to execute effects when emitting output
This commit is contained in:
parent
e096f7d33f
commit
743242aaf4
@ -15,11 +15,11 @@ booleanStateMachine initialState =
|
||||
( \state input -> case state of
|
||||
SFalse ->
|
||||
if even input
|
||||
then ActionResult SFalse (input + 1)
|
||||
else ActionResult STrue (input * 3)
|
||||
then pureResult (input + 1) SFalse
|
||||
else pureResult (input * 3) STrue
|
||||
STrue ->
|
||||
if even input
|
||||
then ActionResult STrue (input - 1)
|
||||
else ActionResult SFalse (input * 5)
|
||||
then pureResult (input - 1) STrue
|
||||
else pureResult (input * 5) SFalse
|
||||
)
|
||||
(InitialState initialState)
|
||||
|
@ -47,22 +47,22 @@ data LockDoorEvent
|
||||
|
||||
lockDoorMachine :: SLockDoorVertex a -> BaseMachine LockDoorTopology LockDoorCommand LockDoorEvent
|
||||
lockDoorMachine initialState =
|
||||
BaseMachine
|
||||
BaseMachineT
|
||||
{ initialState = InitialState initialState
|
||||
, action = \case
|
||||
SIsLockOpen -> \case
|
||||
LockOpen -> ActionResult SIsLockOpen LockNoOp
|
||||
LockClose -> ActionResult SIsLockClosed LockClosed
|
||||
LockLock -> ActionResult SIsLockOpen LockNoOp
|
||||
LockUnlock -> ActionResult SIsLockOpen LockNoOp
|
||||
LockOpen -> pureResult LockNoOp SIsLockOpen
|
||||
LockClose -> pureResult LockClosed SIsLockClosed
|
||||
LockLock -> pureResult LockNoOp SIsLockOpen
|
||||
LockUnlock -> pureResult LockNoOp SIsLockOpen
|
||||
SIsLockClosed -> \case
|
||||
LockOpen -> ActionResult SIsLockOpen LockOpened
|
||||
LockClose -> ActionResult SIsLockClosed LockNoOp
|
||||
LockLock -> ActionResult SIsLockLocked LockLocked
|
||||
LockUnlock -> ActionResult SIsLockClosed LockNoOp
|
||||
LockOpen -> pureResult LockOpened SIsLockOpen
|
||||
LockClose -> pureResult LockNoOp SIsLockClosed
|
||||
LockLock -> pureResult LockLocked SIsLockLocked
|
||||
LockUnlock -> pureResult LockNoOp SIsLockClosed
|
||||
SIsLockLocked -> \case
|
||||
LockOpen -> ActionResult SIsLockLocked LockNoOp
|
||||
LockClose -> ActionResult SIsLockLocked LockNoOp
|
||||
LockLock -> ActionResult SIsLockLocked LockNoOp
|
||||
LockUnlock -> ActionResult SIsLockClosed LockUnlocked
|
||||
LockOpen -> pureResult LockNoOp SIsLockLocked
|
||||
LockClose -> pureResult LockNoOp SIsLockLocked
|
||||
LockLock -> pureResult LockNoOp SIsLockLocked
|
||||
LockUnlock -> pureResult LockUnlocked SIsLockClosed
|
||||
}
|
||||
|
@ -9,7 +9,7 @@ import "singletons-base" Data.Singletons.Base.TH
|
||||
|
||||
oneVertexMachine :: BaseMachine (TrivialTopology @()) () ()
|
||||
oneVertexMachine =
|
||||
BaseMachine
|
||||
BaseMachineT
|
||||
{ initialState = InitialState STuple0
|
||||
, action = \STuple0 _ -> ActionResult STuple0 ()
|
||||
, action = \STuple0 _ -> pureResult () STuple0
|
||||
}
|
||||
|
@ -3,92 +3,115 @@
|
||||
module CRM.BaseMachine where
|
||||
|
||||
import CRM.Topology
|
||||
import "base" Data.Bifunctor (Bifunctor (..), first)
|
||||
import "base" Data.Kind (Type)
|
||||
import "base" Data.List.NonEmpty (NonEmpty (..))
|
||||
|
||||
-- import "base" Data.List.NonEmpty (NonEmpty (..))
|
||||
import "profunctors" Data.Profunctor (Choice (..), Profunctor (..), Strong (..))
|
||||
import "profunctors" Data.Profunctor.Sieve (Cosieve (..))
|
||||
|
||||
-- import "profunctors" Data.Profunctor.Sieve (Cosieve (..))
|
||||
|
||||
import "base" Data.Functor.Identity (Identity (..))
|
||||
import "singletons-base" Data.Singletons.Base.TH (STuple0 (..))
|
||||
|
||||
-- * Specifying state machines
|
||||
|
||||
-- | A `BaseMachine topology input output` describes a state machine with
|
||||
-- | A `BaseMachineT topology input output` describes a state machine with
|
||||
-- allowed transitions constrained by a given `topology`.
|
||||
-- A state machine is composed by an `initialState` and an `action`, which
|
||||
-- defines the `output` and the new `state` given the current `state` and an
|
||||
-- `input`
|
||||
data
|
||||
BaseMachine
|
||||
BaseMachineT
|
||||
m
|
||||
(topology :: Topology vertex)
|
||||
(input :: Type)
|
||||
(output :: Type) = forall state.
|
||||
BaseMachine
|
||||
BaseMachineT
|
||||
{ initialState :: InitialState state
|
||||
, action
|
||||
:: forall initialVertex
|
||||
. state initialVertex
|
||||
-> input
|
||||
-> ActionResult topology state initialVertex output
|
||||
-> ActionResult m topology state initialVertex output
|
||||
}
|
||||
|
||||
instance Profunctor (BaseMachine topology) where
|
||||
lmap :: (a -> b) -> BaseMachine topology b c -> BaseMachine topology a c
|
||||
lmap f (BaseMachine initialState action) =
|
||||
BaseMachine
|
||||
type BaseMachine
|
||||
(topology :: Topology vertex)
|
||||
(input :: Type)
|
||||
(output :: Type) =
|
||||
forall m. Monad m => BaseMachineT m topology input output
|
||||
|
||||
-- * Hoist
|
||||
|
||||
baseHoist
|
||||
:: (forall x. m x -> n x)
|
||||
-> BaseMachineT m topology a b
|
||||
-> BaseMachineT n topology a b
|
||||
baseHoist f (BaseMachineT initialState action) =
|
||||
BaseMachineT
|
||||
initialState
|
||||
((hoistResult f .) . action)
|
||||
|
||||
instance Functor m => Profunctor (BaseMachineT m topology) where
|
||||
lmap :: (a -> b) -> BaseMachineT m topology b c -> BaseMachineT m topology a c
|
||||
lmap f (BaseMachineT initialState action) =
|
||||
BaseMachineT
|
||||
{ initialState = initialState
|
||||
, action = (. f) . action
|
||||
}
|
||||
|
||||
rmap :: (b -> c) -> BaseMachine topology a b -> BaseMachine topology a c
|
||||
rmap f (BaseMachine initialState action) =
|
||||
BaseMachine
|
||||
rmap :: (b -> c) -> BaseMachineT m topology a b -> BaseMachineT m topology a c
|
||||
rmap f (BaseMachineT initialState action) =
|
||||
BaseMachineT
|
||||
{ initialState = initialState
|
||||
, action = ((f <$>) .) . action
|
||||
}
|
||||
|
||||
instance Strong (BaseMachine topology) where
|
||||
first' :: BaseMachine topology a b -> BaseMachine topology (a, c) (b, c)
|
||||
first' (BaseMachine initialState action) =
|
||||
BaseMachine
|
||||
instance Functor m => Strong (BaseMachineT m topology) where
|
||||
first' :: BaseMachineT m topology a b -> BaseMachineT m topology (a, c) (b, c)
|
||||
first' (BaseMachineT initialState action) =
|
||||
BaseMachineT
|
||||
{ initialState = initialState
|
||||
, action = \state (a, c) -> (,c) <$> action state a
|
||||
}
|
||||
|
||||
second' :: BaseMachine topology a b -> BaseMachine topology (c, a) (c, b)
|
||||
second' (BaseMachine initialState action) =
|
||||
BaseMachine
|
||||
second' :: BaseMachineT m topology a b -> BaseMachineT m topology (c, a) (c, b)
|
||||
second' (BaseMachineT initialState action) =
|
||||
BaseMachineT
|
||||
{ initialState = initialState
|
||||
, 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
|
||||
instance Applicative m => Choice (BaseMachineT m topology) where
|
||||
left' :: BaseMachineT m topology a b -> BaseMachineT m topology (Either a c) (Either b c)
|
||||
left' (BaseMachineT initialState action) =
|
||||
BaseMachineT
|
||||
{ initialState = initialState
|
||||
, action = \state -> \case
|
||||
Left a -> Left <$> action state a
|
||||
Right c -> ActionResult state (Right c)
|
||||
Right c -> ActionResult $ pure (Right c, state)
|
||||
}
|
||||
|
||||
right' :: BaseMachine topology a b -> BaseMachine topology (Either c a) (Either c b)
|
||||
right' (BaseMachine initialState action) =
|
||||
BaseMachine
|
||||
right' :: BaseMachineT m topology a b -> BaseMachineT m topology (Either c a) (Either c b)
|
||||
right' (BaseMachineT initialState action) =
|
||||
BaseMachineT
|
||||
{ initialState = initialState
|
||||
, action = \state -> \case
|
||||
Left c -> ActionResult state (Left c)
|
||||
Left c -> ActionResult $ pure (Left c, state)
|
||||
Right a -> Right <$> action state a
|
||||
}
|
||||
|
||||
-- | see https://hackage.haskell.org/package/profunctors-5.6.2/docs/Data-Profunctor-Sieve.html#v:cosieve
|
||||
-- This is basically saying that we can interpret a `BaseMachine topology a b`
|
||||
-- as a function from a `NonEmpty a` to `b`
|
||||
instance Cosieve (BaseMachine topology) NonEmpty where
|
||||
cosieve :: BaseMachine topology a b -> NonEmpty a -> b
|
||||
cosieve machine (a0 :| as0) =
|
||||
case runBaseMachine machine a0 of
|
||||
(b, machine') -> case as0 of
|
||||
[] -> b
|
||||
a1 : as1 -> cosieve machine' (a1 :| as1)
|
||||
-- -- | see https://hackage.haskell.org/package/profunctors-5.6.2/docs/Data-Profunctor-Sieve.html#v:cosieve
|
||||
-- -- This is basically saying that we can interpret a `BaseMachineT m topology a b`
|
||||
-- -- as a function from a `NonEmpty a` to `b`
|
||||
-- instance Cosieve (BaseMachineT m topology) NonEmpty where
|
||||
-- cosieve :: BaseMachineT m topology a b -> NonEmpty a -> m b
|
||||
-- cosieve machine (a0 :| as0) =
|
||||
-- case runBaseMachineT machine a0 of
|
||||
-- (b, machine') -> case as0 of
|
||||
-- [] -> b
|
||||
-- a1 : as1 -> cosieve machine' (a1 :| as1)
|
||||
|
||||
-- | A value of type `InitialState state` describes the initial state of a
|
||||
-- state machine, describing the initial `vertex` in the `topology` and the
|
||||
@ -101,6 +124,7 @@ data InitialState (state :: vertex -> Type) where
|
||||
-- where the transition from `initialVertex` to `finalVertex` is allowed by the machine `topology`
|
||||
data
|
||||
ActionResult
|
||||
m
|
||||
(topology :: Topology vertex)
|
||||
(state :: vertex -> Type)
|
||||
(initialVertex :: vertex)
|
||||
@ -108,44 +132,65 @@ data
|
||||
where
|
||||
ActionResult
|
||||
:: AllowedTransition topology initialVertex finalVertex
|
||||
=> state finalVertex
|
||||
-> output
|
||||
-> ActionResult topology state initialVertex output
|
||||
=> m (output, state finalVertex)
|
||||
-> ActionResult m topology state initialVertex output
|
||||
|
||||
instance Functor (ActionResult topology state initialVertex) where
|
||||
hoistResult
|
||||
:: (forall x. m x -> n x)
|
||||
-> ActionResult m topology state initialVertex output
|
||||
-> ActionResult n topology state initialVertex output
|
||||
hoistResult f (ActionResult outputStatePair) = ActionResult $ f outputStatePair
|
||||
|
||||
instance Functor m => Functor (ActionResult m topology state initialVertex) where
|
||||
fmap
|
||||
:: (a -> b)
|
||||
-> ActionResult topology state initialVertex a
|
||||
-> ActionResult topology state initialVertex b
|
||||
fmap f (ActionResult state output) =
|
||||
ActionResult state (f output)
|
||||
-> ActionResult m topology state initialVertex a
|
||||
-> ActionResult m topology state initialVertex b
|
||||
fmap f (ActionResult outputStatePair) =
|
||||
ActionResult $ first f <$> outputStatePair
|
||||
|
||||
pureResult
|
||||
:: (Applicative m, AllowedTransition topology initialVertex finalVertex)
|
||||
=> output
|
||||
-> state finalVertex
|
||||
-> ActionResult m topology state initialVertex output
|
||||
pureResult output state = ActionResult . pure $ (output, state)
|
||||
|
||||
sequence
|
||||
:: ActionResult Identity topology state initialVertex [output]
|
||||
-> ActionResult [] topology state initialVertex output
|
||||
sequence (ActionResult (Identity (outputs, state))) =
|
||||
ActionResult $ (,state) <$> outputs
|
||||
|
||||
-- ** Stateless machines
|
||||
|
||||
-- | The `statelessBase` transforms its input to its output and never changes its state
|
||||
statelessBase :: (a -> b) -> BaseMachine (TrivialTopology @()) a b
|
||||
statelessBase f =
|
||||
BaseMachine
|
||||
-- | The `statelessBaseT` transforms its input to its output and never changes its state
|
||||
statelessBaseT :: Applicative m => (a -> m b) -> BaseMachineT m (TrivialTopology @()) a b
|
||||
statelessBaseT f =
|
||||
BaseMachineT
|
||||
{ initialState = InitialState STuple0
|
||||
, action = \state input ->
|
||||
ActionResult state $ f input
|
||||
ActionResult $ (,state) <$> f input
|
||||
}
|
||||
|
||||
statelessBase :: (a -> b) -> BaseMachine (TrivialTopology @()) a b
|
||||
statelessBase f = statelessBaseT (pure . f)
|
||||
|
||||
-- ** Identity machine
|
||||
|
||||
-- | The `identity` machine simply outputs its input and never changes its state. It is the result of `statelessBase id`.
|
||||
identity :: BaseMachine (TrivialTopology @()) a a
|
||||
identity = statelessBase id
|
||||
|
||||
-- ** Unfold
|
||||
-- ** Unrestricted machines
|
||||
|
||||
-- | a machine modelled with explicit state, where every transition is allowed
|
||||
unrestrictedBaseMachine
|
||||
:: (forall initialVertex. state initialVertex -> a -> ActionResult (AllowAllTopology @vertex) state initialVertex b)
|
||||
unrestrictedBaseMachineT
|
||||
:: (forall initialVertex. state initialVertex -> a -> ActionResult m (AllowAllTopology @vertex) state initialVertex b)
|
||||
-> InitialState (state :: vertex -> Type)
|
||||
-> BaseMachine (AllowAllTopology @vertex) a b
|
||||
unrestrictedBaseMachine action initialState =
|
||||
BaseMachine
|
||||
-> BaseMachineT m (AllowAllTopology @vertex) a b
|
||||
unrestrictedBaseMachineT action initialState =
|
||||
BaseMachineT
|
||||
{ initialState = initialState
|
||||
, action = action
|
||||
}
|
||||
@ -154,19 +199,22 @@ unrestrictedBaseMachine action initialState =
|
||||
|
||||
-- | Given an `input`, run the machine to get an output and a new version of
|
||||
-- the machine
|
||||
runBaseMachine
|
||||
:: BaseMachine topology input output
|
||||
runBaseMachineT
|
||||
:: Functor m
|
||||
=> BaseMachineT m topology input output
|
||||
-> input
|
||||
-> (output, BaseMachine topology input output)
|
||||
runBaseMachine (BaseMachine (InitialState initialState) action) input =
|
||||
-> m (output, BaseMachineT m topology input output)
|
||||
runBaseMachineT (BaseMachineT (InitialState initialState) action) input =
|
||||
let
|
||||
actionResult = action initialState input
|
||||
in
|
||||
case actionResult of
|
||||
(ActionResult finalState output) ->
|
||||
( output
|
||||
, BaseMachine
|
||||
{ initialState = InitialState finalState
|
||||
, action = action
|
||||
}
|
||||
)
|
||||
ActionResult outputStatePair ->
|
||||
second
|
||||
( \finalState ->
|
||||
BaseMachineT
|
||||
{ initialState = InitialState finalState
|
||||
, action = action
|
||||
}
|
||||
)
|
||||
<$> outputStatePair
|
||||
|
@ -27,9 +27,9 @@ topologyAsGraph (Topology edges) = Graph $ edges >>= edgify
|
||||
-- | Interpret a `BaseMachine` as a `Graph` using the information contained in
|
||||
-- its topology
|
||||
baseMachineAsGraph
|
||||
:: forall vertex topology input output
|
||||
:: forall vertex topology input output m
|
||||
. (Demote (Topology vertex) ~ Topology vertex, SingKind vertex, SingI topology)
|
||||
=> BaseMachine (topology :: Topology vertex) input output
|
||||
=> BaseMachineT m (topology :: Topology vertex) input output
|
||||
-> Graph vertex
|
||||
baseMachineAsGraph _ = topologyAsGraph (demote @topology)
|
||||
|
||||
@ -39,7 +39,7 @@ renderUntypedMermaid (UntypedGraph graph) = renderMermaid graph
|
||||
|
||||
-- | Interpret a `StateMachine` as an `UntypedGraph` using the information
|
||||
-- contained in its structure and in the topology of its basic components
|
||||
machineAsGraph :: StateMachine input output -> UntypedGraph
|
||||
machineAsGraph :: StateMachineT m input output -> UntypedGraph
|
||||
machineAsGraph (Basic baseMachine) =
|
||||
UntypedGraph (baseMachineAsGraph baseMachine)
|
||||
machineAsGraph (Compose machine1 machine2) =
|
||||
|
@ -8,47 +8,64 @@ import CRM.BaseMachine as BaseMachine
|
||||
import CRM.Topology
|
||||
import "base" Control.Category (Category (..))
|
||||
import "base" Data.Bifunctor (Bifunctor (..), bimap)
|
||||
import "base" Data.Foldable (foldl')
|
||||
import "base" Data.Foldable (foldlM)
|
||||
import "base" Data.Kind (Type)
|
||||
import "base" Data.List.NonEmpty (NonEmpty (..), fromList)
|
||||
import "profunctors" Data.Profunctor (Choice (..), Costrong (..), Profunctor (..), Strong (..))
|
||||
import "profunctors" Data.Profunctor.Rep (Corepresentable (..), unfirstCorep, unsecondCorep)
|
||||
import "profunctors" Data.Profunctor.Sieve (Cosieve (..))
|
||||
|
||||
-- import "base" Data.List.NonEmpty (NonEmpty (..), fromList)
|
||||
import "profunctors" Data.Profunctor (Choice {-Costrong (..),-} (..), Profunctor (..), Strong (..))
|
||||
|
||||
-- import "profunctors" Data.Profunctor.Rep (Corepresentable (..), unfirstCorep, unsecondCorep)
|
||||
-- import "profunctors" Data.Profunctor.Sieve (Cosieve (..))
|
||||
import "singletons-base" Data.Singletons (Demote, SingI, SingKind)
|
||||
import Prelude hiding ((.))
|
||||
|
||||
-- | A `StateMachine` is a [Mealy machine](https://en.wikipedia.org/wiki/Mealy_machine)
|
||||
-- with inputs of type `input` and outputs of type `output`
|
||||
data StateMachine input output where
|
||||
data StateMachineT m input output where
|
||||
Basic
|
||||
:: forall vertex (topology :: Topology vertex) input output
|
||||
:: forall m vertex (topology :: Topology vertex) input output
|
||||
. ( Demote vertex ~ vertex
|
||||
, SingKind vertex
|
||||
, SingI topology
|
||||
, Eq vertex
|
||||
, Show vertex
|
||||
)
|
||||
=> BaseMachine topology input output
|
||||
-> StateMachine input output
|
||||
=> BaseMachineT m topology input output
|
||||
-> StateMachineT m input output
|
||||
Compose
|
||||
:: StateMachine a b
|
||||
-> StateMachine b c
|
||||
-> StateMachine a c
|
||||
:: StateMachineT m a b
|
||||
-> StateMachineT m b c
|
||||
-> StateMachineT m a c
|
||||
Parallel
|
||||
:: StateMachine a b
|
||||
-> StateMachine c d
|
||||
-> StateMachine (a, c) (b, d)
|
||||
:: StateMachineT m a b
|
||||
-> StateMachineT m c d
|
||||
-> StateMachineT m (a, c) (b, d)
|
||||
Alternative
|
||||
:: StateMachine a b
|
||||
-> StateMachine c d
|
||||
-> StateMachine (Either a c) (Either b d)
|
||||
:: StateMachineT m a b
|
||||
-> StateMachineT m c d
|
||||
-> StateMachineT m (Either a c) (Either b d)
|
||||
Loop
|
||||
:: StateMachine a [a]
|
||||
-> StateMachine a [a]
|
||||
:: StateMachineT m a [a]
|
||||
-> StateMachineT m a [a]
|
||||
|
||||
type StateMachine a b = forall m. Monad m => StateMachineT m a b
|
||||
|
||||
-- * Hoist
|
||||
|
||||
hoist :: (forall x. m x -> n x) -> StateMachineT m a b -> StateMachineT n a b
|
||||
hoist f machine = case machine of
|
||||
Basic baseMachine -> Basic $ baseHoist f baseMachine
|
||||
Compose machine1 machine2 -> Compose (hoist f machine1) (hoist f machine2)
|
||||
Parallel machine1 machine2 -> Parallel (hoist f machine1) (hoist f machine2)
|
||||
Alternative machine1 machine2 -> Alternative (hoist f machine1) (hoist f machine2)
|
||||
Loop machine' -> Loop $ hoist f machine'
|
||||
|
||||
-- | a state machine which does not rely on state
|
||||
stateless :: (a -> b) -> StateMachine a b
|
||||
stateless f = Basic $ statelessBase f
|
||||
statelessT :: Applicative m => (a -> m b) -> StateMachineT m a b
|
||||
statelessT f = Basic $ statelessBaseT f
|
||||
|
||||
stateless :: Applicative m => (a -> b) -> StateMachineT m a b
|
||||
stateless f = statelessT (pure . f)
|
||||
|
||||
-- | a machine modelled with explicit state, where every transition is allowed
|
||||
unrestrictedMachine
|
||||
@ -61,138 +78,132 @@ unrestrictedMachine
|
||||
=> ( forall initialVertex
|
||||
. state initialVertex
|
||||
-> a
|
||||
-> ActionResult (AllowAllTopology @vertex) state initialVertex b
|
||||
-> ActionResult m (AllowAllTopology @vertex) state initialVertex b
|
||||
)
|
||||
-> InitialState (state :: vertex -> Type)
|
||||
-> StateMachine a b
|
||||
unrestrictedMachine action state = Basic $ unrestrictedBaseMachine action state
|
||||
-> StateMachineT m a b
|
||||
unrestrictedMachine action state = Basic $ unrestrictedBaseMachineT action state
|
||||
|
||||
-- * Category
|
||||
|
||||
instance Category StateMachine where
|
||||
id :: StateMachine a a
|
||||
instance Monad m => Category (StateMachineT m) where
|
||||
id :: StateMachineT m a a
|
||||
id = Basic identity
|
||||
|
||||
(.) :: StateMachine b c -> StateMachine a b -> StateMachine a c
|
||||
(.) :: StateMachineT m b c -> StateMachineT m a b -> StateMachineT m a c
|
||||
(.) = flip Compose
|
||||
|
||||
-- * Profunctor
|
||||
|
||||
instance Profunctor StateMachine where
|
||||
lmap :: (a -> b) -> StateMachine b c -> StateMachine a c
|
||||
instance Applicative m => Profunctor (StateMachineT m) where
|
||||
lmap :: (a -> b) -> StateMachineT m b c -> StateMachineT m a c
|
||||
lmap f (Basic baseMachine) = Basic $ lmap f baseMachine
|
||||
lmap f (Compose machine1 machine2) = Compose (lmap f machine1) machine2
|
||||
lmap f machine = Compose (stateless f) machine
|
||||
|
||||
rmap :: (b -> c) -> StateMachine a b -> StateMachine a c
|
||||
rmap :: (b -> c) -> StateMachineT m a b -> StateMachineT m a c
|
||||
rmap f (Basic baseMachine) = Basic $ rmap f baseMachine
|
||||
rmap f (Compose machine1 machine2) = Compose machine1 (rmap f machine2)
|
||||
rmap f machine = Compose machine (stateless f)
|
||||
|
||||
-- * Strong
|
||||
|
||||
instance Strong StateMachine where
|
||||
first' :: StateMachine a b -> StateMachine (a, c) (b, c)
|
||||
instance Monad m => Strong (StateMachineT m) where
|
||||
first' :: StateMachineT m a b -> StateMachineT m (a, c) (b, c)
|
||||
first' = flip Parallel Control.Category.id
|
||||
|
||||
second' :: StateMachine a b -> StateMachine (c, a) (c, b)
|
||||
second' :: StateMachineT m a b -> StateMachineT m (c, a) (c, b)
|
||||
second' = Parallel Control.Category.id
|
||||
|
||||
-- * Choice
|
||||
|
||||
-- | An instance of `Choice` allows us to have parallel composition of state machines, meaning that we can pass two inputs to two state machines and get out the outputs of both
|
||||
instance Choice StateMachine where
|
||||
left' :: StateMachine a b -> StateMachine (Either a c) (Either b c)
|
||||
instance Monad m => Choice (StateMachineT m) where
|
||||
left' :: StateMachineT m a b -> StateMachineT m (Either a c) (Either b c)
|
||||
left' = flip Alternative Control.Category.id
|
||||
|
||||
right' :: StateMachine a b -> StateMachine (Either c a) (Either c b)
|
||||
right' :: StateMachineT m a b -> StateMachineT m (Either c a) (Either c b)
|
||||
right' = Alternative Control.Category.id
|
||||
|
||||
-- * Cosieve
|
||||
-- -- * Cosieve
|
||||
|
||||
-- | see https://hackage.haskell.org/package/profunctors-5.6.2/docs/Data-Profunctor-Sieve.html#v:cosieve
|
||||
-- This is basically saying that we can interpret a `StateMachine a b` as a
|
||||
-- function from a `NonEmpty a` to `b`
|
||||
instance Cosieve StateMachine NonEmpty where
|
||||
cosieve :: StateMachine a b -> NonEmpty a -> b
|
||||
cosieve machine (a0 :| as0) =
|
||||
case run machine a0 of
|
||||
(b, machine') -> case as0 of
|
||||
[] -> b
|
||||
a1 : as1 -> cosieve machine' (a1 :| as1)
|
||||
-- -- | see https://hackage.haskell.org/package/profunctors-5.6.2/docs/Data-Profunctor-Sieve.html#v:cosieve
|
||||
-- -- This is basically saying that we can interpret a `StateMachine a b` as a
|
||||
-- -- function from a `NonEmpty a` to `b`
|
||||
-- instance Cosieve (StateMachineT m) NonEmpty where
|
||||
-- cosieve :: StateMachineT m a b -> NonEmpty a -> m b
|
||||
-- cosieve machine (a0 :| as0) =
|
||||
-- case run machine a0 of
|
||||
-- (b, machine') -> case as0 of
|
||||
-- [] -> b
|
||||
-- a1 : as1 -> cosieve machine' (a1 :| as1)
|
||||
|
||||
-- * Corepresentable
|
||||
-- -- * Corepresentable
|
||||
|
||||
-- the state space for a machine with a topology containing a single vertex
|
||||
-- and a type of possible states in that vertex
|
||||
data SingleVertexState a (vertex :: ()) where
|
||||
SingleVertexState :: a -> SingleVertexState a '()
|
||||
-- -- the state space for a machine with a topology containing a single vertex
|
||||
-- -- and a type of possible states in that vertex
|
||||
-- data SingleVertexState a (vertex :: ()) where
|
||||
-- SingleVertexState :: a -> SingleVertexState a '()
|
||||
|
||||
-- | see https://hackage.haskell.org/package/profunctors-5.6.2/docs/Data-Profunctor-Rep.html#t:Corepresentable
|
||||
-- This is basically saying that we can interpret a function from `NonEmpty a`
|
||||
-- to `b` as a `StateMachine a b`, where we store the tail of the non-empty
|
||||
-- list in the state of the machine.
|
||||
instance Corepresentable StateMachine where
|
||||
type Corep StateMachine = NonEmpty
|
||||
-- -- | see https://hackage.haskell.org/package/profunctors-5.6.2/docs/Data-Profunctor-Rep.html#t:Corepresentable
|
||||
-- -- This is basically saying that we can interpret a function from `NonEmpty a`
|
||||
-- -- to `b` as a `StateMachine a b`, where we store the tail of the non-empty
|
||||
-- -- list in the state of the machine.
|
||||
-- instance Corepresentable (StateMachineT m) where
|
||||
-- type Corep (StateMachineT m) = NonEmpty
|
||||
|
||||
cotabulate :: forall a b. (NonEmpty a -> b) -> StateMachine a b
|
||||
cotabulate f =
|
||||
Basic @() @TrivialTopology $
|
||||
BaseMachine
|
||||
{ initialState = InitialState $ SingleVertexState ([] :: [a])
|
||||
, action = \(SingleVertexState as) input ->
|
||||
let
|
||||
allInputs = input : as
|
||||
in
|
||||
ActionResult
|
||||
(SingleVertexState allInputs)
|
||||
(f . fromList . reverse $ allInputs)
|
||||
}
|
||||
-- cotabulate :: forall a b. (NonEmpty a -> m b) -> StateMachineT m a b
|
||||
-- cotabulate f =
|
||||
-- Basic @_ @() @TrivialTopology $
|
||||
-- BaseMachineT
|
||||
-- { initialState = InitialState $ SingleVertexState ([] :: [a])
|
||||
-- , action = \(SingleVertexState as) input ->
|
||||
-- let
|
||||
-- allInputs = input : as
|
||||
-- in
|
||||
-- ActionResult
|
||||
-- (SingleVertexState allInputs)
|
||||
-- (f . fromList . reverse $ allInputs)
|
||||
-- }
|
||||
|
||||
-- * Costrong
|
||||
-- -- * Costrong
|
||||
|
||||
instance Costrong StateMachine where
|
||||
unfirst :: StateMachine (a, c) (b, c) -> StateMachine a b
|
||||
unfirst = unfirstCorep
|
||||
-- instance Costrong (StateMachineT m) where
|
||||
-- unfirst :: StateMachineT m (a, c) (b, c) -> StateMachineT m a b
|
||||
-- unfirst = unfirstCorep
|
||||
|
||||
unsecond :: StateMachine (c, a) (c, b) -> StateMachine a b
|
||||
unsecond = unsecondCorep
|
||||
-- unsecond :: StateMachineT m (c, a) (c, b) -> StateMachineT m a b
|
||||
-- unsecond = unsecondCorep
|
||||
|
||||
-- * Run a state machine
|
||||
|
||||
-- | Given an `input`, run the machine to get an output and a new version of
|
||||
-- the machine
|
||||
run :: StateMachine a b -> a -> (b, StateMachine a b)
|
||||
run (Basic baseMachine) a = Basic <$> runBaseMachine baseMachine a
|
||||
run (Compose machine1 machine2) a =
|
||||
let
|
||||
(output1, machine1') = run machine1 a
|
||||
(output2, machine2') = run machine2 output1
|
||||
in
|
||||
(output2, Compose machine1' machine2')
|
||||
run (Parallel machine1 machine2) (a, b) =
|
||||
let
|
||||
(output1, machine1') = run machine1 a
|
||||
(output2, machine2') = run machine2 b
|
||||
in
|
||||
((output1, output2), Parallel machine1' machine2')
|
||||
run :: Monad m => StateMachineT m a b -> a -> m (b, StateMachineT m a b)
|
||||
run (Basic baseMachine) a = second Basic <$> runBaseMachineT baseMachine a
|
||||
run (Compose machine1 machine2) a = do
|
||||
(output1, machine1') <- run machine1 a
|
||||
(output2, machine2') <- run machine2 output1
|
||||
pure (output2, Compose machine1' machine2')
|
||||
run (Parallel machine1 machine2) a = do
|
||||
(output1, machine1') <- run machine1 (fst a)
|
||||
(output2, machine2') <- run machine2 (snd a)
|
||||
pure ((output1, output2), Parallel machine1' machine2')
|
||||
run (Alternative machine1 machine2) a =
|
||||
case a of
|
||||
Left a1 -> bimap Left (`Alternative` machine2) $ run machine1 a1
|
||||
Right a2 -> bimap Right (machine1 `Alternative`) $ run machine2 a2
|
||||
run (Loop machine) a =
|
||||
let
|
||||
(as, machine') = run machine a
|
||||
in
|
||||
first (as <>) $ runMultiple (Loop machine') as
|
||||
Left a1 -> bimap Left (`Alternative` machine2) <$> run machine1 a1
|
||||
Right a2 -> bimap Right (machine1 `Alternative`) <$> run machine2 a2
|
||||
run (Loop machine) a = do
|
||||
(as, machine') <- run machine a
|
||||
first (as <>) <$> runMultiple (Loop machine') as
|
||||
|
||||
-- | process multiple inputs in one go, accumulating the results in a monoid
|
||||
runMultiple
|
||||
:: (Foldable f, Monoid b)
|
||||
=> StateMachine a b
|
||||
:: (Monad m, Foldable f, Monoid b)
|
||||
=> StateMachineT m a b
|
||||
-> f a
|
||||
-> (b, StateMachine a b)
|
||||
-> m (b, StateMachineT m a b)
|
||||
runMultiple machine =
|
||||
foldl'
|
||||
(\(b, machine') -> first (b <>) . run machine')
|
||||
foldlM
|
||||
(\(b, machine') a -> first (b <>) <$> run machine' a)
|
||||
(mempty, machine)
|
||||
|
Loading…
Reference in New Issue
Block a user