Simulation.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}

{- | Lamport clock network simulation.
'ReplicaSim' provides 'Replica' and 'Clock' instances,
replicas may interchange data while they are connected in a 'NetworkSim'.
-}
module RON.Event.Simulation (
    NetworkSimT,
    ReplicaSimT,
    runNetworkSimT,
    runReplicaSimT,
) where

import RON.Prelude

import Control.Monad.State.Strict (state)
import Data.Bits (xor)
import Data.HashMap.Strict qualified as HM

import RON.Event (
    Event (..),
    Replica (Replica),
    ReplicaClock,
    TimeVariety (Logical),
    advance,
    getEvents,
    getPid,
    mkTime,
 )
import RON.Util.Word (Word60, ls60, safeCast)

{- | Lamport clock simulation. Key is 'Replica'.
Non-present value is equivalent to (0, initial).
-}
newtype NetworkSimT m a = NetworkSim (StateT (HashMap Replica Word60) m a)
    deriving (Applicative, Functor, Monad, MonadError e)

instance MonadTrans NetworkSimT where
    lift = NetworkSim . lift

-- | ReplicaSim inside Lamport clock simulation.
newtype ReplicaSimT m a = ReplicaSim (ReaderT Replica (NetworkSimT m) a)
    deriving (Applicative, Functor, Monad, MonadError e)

instance MonadTrans ReplicaSimT where
    lift = ReplicaSim . lift . lift

-- Hash backported from older version of `hashable`
oldHash :: Word60 -> Word64 -> Word64
oldHash x y = defaultSalt `combine` safeCast x `combine` 1 `combine` y
  where
    defaultSalt = 0xdc36d1615b7400a4
    combine a b = (a * 16777619) `xor` b

instance (Monad m) => ReplicaClock (ReplicaSimT m) where
    getPid = ReplicaSim ask

    getEvents n' = ReplicaSim $ do
        replica <- ask
        (t0, t1) <-
            lift $ NetworkSim $ state \replicaStates ->
                let t0orig = HM.lookupDefault (ls60 0) replica replicaStates
                    Replica r = replica
                    randomLeap = ls60 $ oldHash t0orig r `mod` 0x10000
                    t0 = t0orig + randomLeap
                    t1 = t0 + n
                in  ((t0, t1), HM.insert replica t1 replicaStates)
        pure [Event{time = mkTime Logical t, replica} | t <- [succ t0 .. t1]]
      where
        n = max n' (ls60 1)

    advance time = ReplicaSim $ do
        rid <- ask
        lift . NetworkSim . modify' $ HM.alter (Just . advancePS) rid
      where
        advancePS = \case
            Nothing -> time
            Just current -> max time current

instance (MonadFail m) => MonadFail (ReplicaSimT m) where
    fail = lift . fail

{- | Execute network simulation

Usage:

@
'runExceptT' . runNetworkSimT $ do
    'runReplicaSimT' r1 $ do
        actions...
    'runReplicaSimT' r2 $ do
        actions...
    'runReplicaSimT' r1 $ ...
@

Each 'runNetworkSimT' starts its own networks.
One shouldn't use in one network events generated in another.
-}
runNetworkSimT :: (Monad m) => NetworkSimT m a -> m a
runNetworkSimT (NetworkSim action) = evalStateT action mempty

runReplicaSimT :: Replica -> ReplicaSimT m a -> NetworkSimT m a
runReplicaSimT rid (ReplicaSim action) = runReaderT action rid