add Parallel and Alternative constructors

decision-log/2023-01-17-add-parallel-and-alternative-constructors.yaml

@@ -0,0 +1,23 @@
+name: Add Parallel and Alternative constructors
+date: 2023-01-17
+context: >
+  Mealy machine, at least in theory, admit an instance for `Strong` and
+  `Choice` type classes, to allow parallel and alternative composition.
+
+  In our current implementation, we could implement `Strong` and `Choice` just
+  by forwarding the composition to the `BaseMachine` layer.
+
+  Still everytime that we are combining two state machine, either sequentially,
+  in parallel or in alternative, the set of states is always the cartesian
+  product of the sets of states. It follows that we would not be able to
+  understand
+decision: >
+  We decide to add specific constructors for parallel and alternative
+  composition.
+consequences: >
+  We will be able to keep track of how a state machine is built.
+
+  Moreover we will be able to draw not only the set of spaces with allowed
+  transitions, but also a
+  [wiring diagram](https://math.mit.edu/~dspivak/informatics/talks/WD-IntroductoryTalk.pdf)
+  representing the flow of information through the machine.

src/CRM/BaseMachine.hs

@@ -107,16 +107,22 @@ instance Functor (ActionResult topology state initialVertex) where
   fmap f (ActionResult state output) =
     ActionResult state (f output)
 
--- ** Identity machine
+-- ** Stateless machines
 
--- | The `id` machine always outputs its input and never changes its state
-identity :: BaseMachine ('Topology '[ '( '(), '[ '()])]) a a
-identity =
+statelessBase :: (a -> b) -> BaseMachine TrivialTopology a b
+statelessBase f =
   BaseMachine
     { initialState = InitialState STuple0
-    , action = ActionResult
+    , action = \state input ->
+        ActionResult state $ f input
     }
 
+-- ** Identity machine
+
+-- | The `id` machine always outputs its input and never changes its state
+identity :: BaseMachine TrivialTopology a a
+identity = statelessBase id
+
 -- ** Run a machine
 
 -- | Given an `input`, run the machine to get an output and a new version of

src/CRM/Render.hs

@@ -46,3 +46,11 @@ machineAsGraph (Compose machine1 machine2) =
   untypedProductGraph
     (machineAsGraph machine1)
     (machineAsGraph machine2)
+machineAsGraph (Parallel machine1 machine2) =
+  untypedProductGraph
+    (machineAsGraph machine1)
+    (machineAsGraph machine2)
+machineAsGraph (Alternative machine1 machine2) =
+  untypedProductGraph
+    (machineAsGraph machine1)
+    (machineAsGraph machine2)

src/CRM/StateMachine.hs

@@ -6,6 +6,7 @@ module CRM.StateMachine where
 import CRM.BaseMachine as BaseMachine
 import CRM.Topology
 import "base" Control.Category (Category (..))
+import "base" Data.Bifunctor (bimap)
 import "profunctors" Data.Profunctor (Choice (..), Profunctor (..), Strong (..))
 import "singletons-base" Data.Singletons (Demote, SingI, SingKind)
 
@@ -25,6 +26,17 @@ data StateMachine input output where
     :: StateMachine a b
     -> StateMachine b c
     -> StateMachine a c
+  Parallel
+    :: StateMachine a b
+    -> StateMachine c d
+    -> StateMachine (a, c) (b, d)
+  Alternative
+    :: StateMachine a b
+    -> StateMachine c d
+    -> StateMachine (Either a c) (Either b d)
+
+stateless :: (a -> b) -> StateMachine a b
+stateless f = Basic $ statelessBase f
 
 -- * Category
 
@@ -41,32 +53,32 @@ instance Profunctor StateMachine where
   lmap :: (a -> b) -> StateMachine b c -> StateMachine a c
   lmap f (Basic baseMachine) = Basic $ lmap f baseMachine
   lmap f (Compose machine1 machine2) = Compose (lmap f machine1) machine2
+  lmap f machine@(Parallel _ _) = Compose (stateless f) machine
+  lmap f machine@(Alternative _ _) = Compose (stateless f) machine
 
   rmap :: (b -> c) -> StateMachine a b -> StateMachine a c
   rmap f (Basic baseMachine) = Basic $ rmap f baseMachine
   rmap f (Compose machine1 machine2) = Compose machine1 (rmap f machine2)
+  rmap f machine@(Parallel _ _) = Compose machine (stateless f)
+  rmap f machine@(Alternative _ _) = Compose machine (stateless f)
 
 -- * Strong
 
 instance Strong StateMachine where
   first' :: StateMachine a b -> StateMachine (a, c) (b, c)
-  first' (Basic baseMachine) = Basic $ first' baseMachine
-  first' (Compose machine1 machine2) = Compose (first' machine1) (first' machine2)
+  first' = flip Parallel Control.Category.id
 
   second' :: StateMachine a b -> StateMachine (c, a) (c, b)
-  second' (Basic baseMachine) = Basic $ second' baseMachine
-  second' (Compose machine1 machine2) = Compose (second' machine1) (second' machine2)
+  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)
-  left' (Basic baseMachine) = Basic $ left' baseMachine
-  left' (Compose machine1 machine2) = Compose (left' machine1) (left' machine2)
+  left' = flip Alternative Control.Category.id
 
   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)
+  right' = Alternative Control.Category.id
 
 -- * Run a state machine
 
@@ -80,3 +92,13 @@ run (Compose machine1 machine2) a =
     (output2, machine2') = run machine2 output1
    in
     (output2, Compose machine1' machine2')
+run (Parallel machine1 machine2) a =
+  let
+    (output1, machine1') = run machine1 (fst a)
+    (output2, machine2') = run machine2 (snd a)
+   in
+    ((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

src/CRM/Topology.hs

@@ -9,7 +9,7 @@
 
 module CRM.Topology where
 
-import "singletons-base" Data.Singletons.Base.TH (singletons)
+import "singletons-base" Data.Singletons.Base.TH
 
 -- * Topology
 
@@ -59,3 +59,12 @@ instance {-# INCOHERENT #-} AllowedTransition ('Topology map) a b => AllowedTran
 
 instance {-# INCOHERENT #-} AllowedTransition topology a a where
   allowsTransition = AllowIdentityEdge
+
+-- ** Trivial topology
+
+$( singletons
+    [d|
+      trivialTopology :: Topology ()
+      trivialTopology = Topology []
+      |]
+ )