petrisim.hs

-- first attempt (not compiled) of an example simulation of petri net https://twitter.com/semanticbeeng/status/1120662696985268225
-- assume that the input is stored by a process `receive` not detailed here which store the entries in two transactional variables


-- read from two typed channels A and B
-- return three responses of type C

import Control.Concurrent.STM.TVar
import Transient.Base
import Transient.Move
import Control.Applicative
import Transient.Indeterminism (groupByTime)

chanA :: TVar A
chanA = unsafePerformIO newTVarIO
chanB :: TVar B
chanB = unsafePerformIO newTVarIO

a= async . atomically $ readTVar chanA
b= async . atomically $ readTVar chanB

exp :: TransIO (A,A,A,A,A,B,B)   -- wait for five A's and two B's in parallel
exp= (,,,,,,) <$> a <*> a <*> a <*> a <*> a <*> b <*> b   -- no timeout
exp'= groupByTime timeout exp                             -- with timeout
                                                          -- produce the list of all frames of events gathered before the timeout

petri :: TransIO C
petri= do
      threads 0 $ choose [1..]    -- produce an endless loop, (without threads 0 would produce infinite threads
                                  -- that would execute exp' in parallel)
                                  -- it avoid an explicit loop so it make it monadically composable with `processFurther`
      frames<- exp'               
      mapM generate fs 
       
   where
   generate (a1,a2,a3,a4,a5,b1,b2)=
      -- generate three responses and send them non deterministically, each one in a new thread, down trough the monad
      -- to `processFurther`
      (c1,c2,c3) <- generate a1 a2 a3 a4 a5 b1 b2
      async (return c1) <|> async (return c2) <|> async (return c3)
      
      
main= initNode $ local petriProc <|> local receive

petriProc= local $ petri >>= processfurther

processfurther=   receive the responses from petri

receive :: Either A B -> TransIO ()
receive= do
    ...
    case msg of
      Left a  -> atomically $ writeTVar chanA a
      Right b -> atomically $ writeTVar chanB b