Possible fix for #304: Simplify init_clock and make sinceLast a Maybe

automaton/src/Data/Automaton.hs

@@ -522,3 +522,15 @@ count = feedback 0 $! arr (\(_, n) -> let n' = n + 1 in (n', n'))
 -- | Remembers the last 'Just' value, defaulting to the given initialisation value.
 lastS :: (Monad m) => a -> Automaton m (Maybe a) a
 lastS a = arr Last >>> mappendS >>> arr (getLast >>> fromMaybe a)
+
+-- | Caches the first input value.
+cacheFirst :: Applicative m => Automaton m a a
+cacheFirst = unfold Nothing $ \aIn -> maybe (Result (Just aIn) aIn) $ \aCached -> Result (Just aCached) aCached
+
+-- | Perform the action on the first tick, caching the result and outputting it forever.
+onStart :: Monad m => (a -> m b) -> Automaton m a b
+onStart f = arrM f >>> cacheFirst
+
+-- | Like 'onStart', but not requiring input
+onStart_ :: Monad m => m b -> Automaton m arbitrary b
+onStart_ = onStart . const

rhine-gloss/src/FRP/Rhine/Gloss/IO.hs

@@ -126,7 +126,7 @@ data GlossEventClockIO = GlossEventClockIO
 instance (MonadIO m) => Clock (GlossConcT m) GlossEventClockIO where
   type Time GlossEventClockIO = Float
   type Tag GlossEventClockIO = Event
-  initClock _ = return (constM getEvent, 0)
+  initClock _ = constM getEvent
     where
       getEvent = do
         GlossEnv {eventVar, timeRef} <- GlossConcT ask
@@ -148,7 +148,7 @@ data GlossSimClockIO = GlossSimClockIO
 instance (MonadIO m) => Clock (GlossConcT m) GlossSimClockIO where
   type Time GlossSimClockIO = Float
   type Tag GlossSimClockIO = ()
-  initClock _ = return (constM getTime &&& arr (const ()), 0)
+  initClock _ = constM getTime &&& arr (const ())
     where
       getTime = GlossConcT $ do
         GlossEnv {timeVar} <- ask

rhine-gloss/src/FRP/Rhine/Gloss/Pure.hs

@@ -35,7 +35,6 @@ import Control.Monad.Schedule.Class
 import Control.Monad.Schedule.Yield
 
 -- automaton
-import Data.Automaton.Trans.Except (performOnFirstSample)
 import qualified Data.Automaton.Trans.Reader as AutomatonReader
 import qualified Data.Automaton.Trans.Writer as AutomatonWriter
 
@@ -82,7 +81,7 @@ instance Semigroup GlossClock where
 instance Clock GlossM GlossClock where
   type Time GlossClock = Float
   type Tag GlossClock = Maybe Event
-  initClock _ = return (constM (GlossM $ yield >> lift ask) >>> (sumS *** Category.id), 0)
+  initClock _ = constM (GlossM $ yield >> lift ask) >>> (sumS *** Category.id)
 
 instance GetClockProxy GlossClock
 
@@ -125,7 +124,7 @@ flowGloss GlossSettings {..} rhine =
   play display backgroundColor stepsPerSecond (worldAutomaton, Blank) getPic handleEvent simStep
   where
     worldAutomaton :: WorldAutomaton
-    worldAutomaton = AutomatonWriter.runWriterS $ AutomatonReader.runReaderS $ hoistS (runYieldT . unGlossM) $ performOnFirstSample $ eraseClock rhine
+    worldAutomaton = AutomatonWriter.runWriterS $ AutomatonReader.runReaderS $ hoistS (runYieldT . unGlossM) $ eraseClock rhine
     stepWith :: (Float, Maybe Event) -> (WorldAutomaton, Picture) -> (WorldAutomaton, Picture)
     stepWith (diff, eventMaybe) (automaton, _) = let Result automaton' (picture, _) = runIdentity $ stepAutomaton automaton ((diff, eventMaybe), ()) in (automaton', picture)
     getPic (_, pic) = pic

rhine-terminal/src/FRP/Rhine/Terminal.hs

@@ -44,15 +44,10 @@ instance (MonadInput m, MonadIO m) => Clock m TerminalEventClock where
   type Time TerminalEventClock = UTCTime
   type Tag TerminalEventClock = Either Interrupt Event
 
-  initClock TerminalEventClock = do
-    initialTime <- liftIO getCurrentTime
-    return
-      ( constM $ do
-          event <- awaitEvent
-          time <- liftIO getCurrentTime
-          return (time, event)
-      , initialTime
-      )
+  initClock TerminalEventClock = constM $ do
+    event <- awaitEvent
+    time <- liftIO getCurrentTime
+    return (time, event)
 
 instance GetClockProxy TerminalEventClock
 

rhine/src/FRP/Rhine/ClSF/Util.hs

@@ -33,9 +33,12 @@ import Data.VectorSpace
 import Data.TimeDomain
 
 -- rhine
+
+import Data.Functor ((<&>))
 import FRP.Rhine.ClSF.Core
 import FRP.Rhine.ClSF.Except
 import FRP.Rhine.Clock
+import Data.Maybe (fromMaybe)
 
 -- * Read time information
 
@@ -54,7 +57,7 @@ timeInfoOf :: (Monad m) => (TimeInfo cl -> b) -> ClSF m cl a b
 timeInfoOf f = constM $ asks f
 
 -- | Continuously return the time difference since the last tick.
-sinceLastS :: (Monad m) => ClSF m cl a (Diff (Time cl))
+sinceLastS :: (Monad m) => ClSF m cl a (Maybe (Diff (Time cl)))
 sinceLastS = timeInfoOf sinceLast
 
 -- | Continuously return the time difference since clock initialisation.
@@ -161,7 +164,7 @@ integralFrom ::
   BehaviorF m td v v
 integralFrom v0 = proc v -> do
   _sinceLast <- timeInfoOf sinceLast -< ()
-  sumFrom v0 -< _sinceLast *^ v
+  sumFrom v0 -< maybe zeroVector (*^ v) _sinceLast
 
 -- | Euler integration, with zero initial offset.
 integral ::
@@ -182,19 +185,19 @@ derivativeFrom ::
   , s ~ Diff td
   ) =>
   v ->
-  BehaviorF m td v v
+  BehaviorF m td v (Maybe v)
 derivativeFrom v0 = proc v -> do
   vLast <- delay v0 -< v
   TimeInfo {..} <- timeInfo -< ()
-  returnA -< (v ^-^ vLast) ^/ sinceLast
+  returnA -< ((v ^-^ vLast) ^/) <$> sinceLast
 
 -- | Numerical derivative with input initialised to zero.
 derivative ::
   ( Monad m
   , VectorSpace v s
   , s ~ Diff td
   ) =>
-  BehaviorF m td v v
+  BehaviorF m td v (Maybe v)
 derivative = derivativeFrom zeroVector
 
 {- | Like 'derivativeFrom', but uses three samples to compute the derivative.
@@ -208,11 +211,11 @@ threePointDerivativeFrom ::
   ) =>
   -- | The initial position
   v ->
-  BehaviorF m td v v
+  BehaviorF m td v (Maybe v)
 threePointDerivativeFrom v0 = proc v -> do
   dv <- derivativeFrom v0 -< v
-  dv' <- delay zeroVector -< dv
-  returnA -< (dv ^+^ dv') ^/ 2
+  dv' <- delay (Just zeroVector) -< dv -- FIXME think about this. Or just delay 2 samples?
+  returnA -< ((^+^) <$> dv <*> dv') <&> (^/ 2)
 
 {- | Like 'threePointDerivativeFrom',
    but with the initial position initialised to 'zeroVector'.
@@ -223,7 +226,7 @@ threePointDerivative ::
   , s ~ Diff td
   , Num s
   ) =>
-  BehaviorF m td v v
+  BehaviorF m td v (Maybe v)
 threePointDerivative = threePointDerivativeFrom zeroVector
 
 -- ** Averaging and filters
@@ -269,7 +272,7 @@ averageFrom ::
 averageFrom v0 t = proc v -> do
   TimeInfo {..} <- timeInfo -< ()
   let
-    weight = exp $ -(sinceLast / t)
+    weight = exp $ -(maybe 0 (/ t) sinceLast)
   weightedAverageFrom v0 -< (v, weight)
 
 -- | An average, or low pass, initialised to zero.
@@ -303,7 +306,7 @@ averageLinFrom ::
 averageLinFrom v0 t = proc v -> do
   TimeInfo {..} <- timeInfo -< ()
   let
-    weight = t / (sinceLast + t)
+    weight = t / (fromMaybe 0 sinceLast + t)
   weightedAverageFrom v0 -< (v, weight)
 
 -- | Linearised version of 'average'.

rhine/src/FRP/Rhine/Clock.hs

@@ -3,7 +3,6 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
 
 {- |
@@ -40,13 +39,6 @@ that cause the environment to wait until the specified time is reached.
 -}
 type RunningClock m time tag = Automaton m () (time, tag)
 
-{- |
-When initialising a clock, the initial time is measured
-(typically by means of a side effect),
-and a running clock is returned.
--}
-type RunningClockInit m time tag = m (RunningClock m time tag, time)
-
 {- |
 Since we want to leverage Haskell's type system to annotate signal networks by their clocks,
 each clock must be an own type, 'cl'.
@@ -69,13 +61,13 @@ class (TimeDomain (Time cl)) => Clock m cl where
     -- | The clock value, containing e.g. settings or device parameters
     cl ->
     -- | The stream of time stamps, and the initial time
-    RunningClockInit m (Time cl) (Tag cl)
+    RunningClock m (Time cl) (Tag cl)
 
 -- * Auxiliary definitions and utilities
 
 -- | An annotated, rich time stamp.
 data TimeInfo cl = TimeInfo
-  { sinceLast :: Diff (Time cl)
+  { sinceLast :: Maybe (Diff (Time cl))
   -- ^ Time passed since the last tick
   , sinceInit :: Diff (Time cl)
   -- ^ Time passed since the initialisation of the clock
@@ -112,21 +104,15 @@ type RescalingM m cl time = Time cl -> m time
 -}
 type RescalingS m cl time tag = Automaton m (Time cl, Tag cl) (time, tag)
 
-{- | Like 'RescalingS', but allows for an initialisation
-   of the rescaling morphism, together with the initial time.
--}
-type RescalingSInit m cl time tag = Time cl -> m (RescalingS m cl time tag, time)
-
-{- | Convert an effectful morphism of time domains into a stateful one with initialisation.
-   Think of its type as @RescalingM m cl time -> RescalingSInit m cl time tag@,
+{- | Convert an effectful morphism of time domains into a stateful one.
+   Think of its type as @'RescalingM' m cl time -> 'RescalingS' m cl time tag@,
    although this type is ambiguous.
 -}
-rescaleMToSInit ::
+rescaleMToS ::
   (Monad m) =>
   (time1 -> m time2) ->
-  time1 ->
-  m (Automaton m (time1, tag) (time2, tag), time2)
-rescaleMToSInit rescaling time1 = (arrM rescaling *** Category.id,) <$> rescaling time1
+  Automaton m (time1, tag) (time2, tag)
+rescaleMToS rescaling = arrM rescaling *** Category.id
 
 -- ** Applying rescalings to clocks
 
@@ -142,12 +128,7 @@ instance
   where
   type Time (RescaledClock cl time) = time
   type Tag (RescaledClock cl time) = Tag cl
-  initClock (RescaledClock cl f) = do
-    (runningClock, initTime) <- initClock cl
-    return
-      ( runningClock >>> first (arr f)
-      , f initTime
-      )
+  initClock (RescaledClock cl f) = initClock cl >>> first (arr f)
 
 {- | Instead of a mere function as morphism of time domains,
    we can transform one time domain into the other with an effectful morphism.
@@ -165,13 +146,7 @@ instance
   where
   type Time (RescaledClockM m cl time) = time
   type Tag (RescaledClockM m cl time) = Tag cl
-  initClock RescaledClockM {..} = do
-    (runningClock, initTime) <- initClock unscaledClockM
-    rescaledInitTime <- rescaleM initTime
-    return
-      ( runningClock >>> first (arrM rescaleM)
-      , rescaledInitTime
-      )
+  initClock RescaledClockM {..} = initClock unscaledClockM >>> first (arrM rescaleM)
 
 -- | A 'RescaledClock' is trivially a 'RescaledClockM'.
 rescaledClockToM :: (Monad m) => RescaledClock cl time -> RescaledClockM m cl time
@@ -187,7 +162,7 @@ rescaledClockToM RescaledClock {..} =
 data RescaledClockS m cl time tag = RescaledClockS
   { unscaledClockS :: cl
   -- ^ The clock before the rescaling
-  , rescaleS :: RescalingSInit m cl time tag
+  , rescaleS :: RescalingS m cl time tag
   -- ^ The rescaling stream function, and rescaled initial time,
   --   depending on the initial time before rescaling
   }
@@ -198,13 +173,7 @@ instance
   where
   type Time (RescaledClockS m cl time tag) = time
   type Tag (RescaledClockS m cl time tag) = tag
-  initClock RescaledClockS {..} = do
-    (runningClock, initTime) <- initClock unscaledClockS
-    (rescaling, rescaledInitTime) <- rescaleS initTime
-    return
-      ( runningClock >>> rescaling
-      , rescaledInitTime
-      )
+  initClock RescaledClockS {..} = initClock unscaledClockS >>> rescaleS
 
 -- | A 'RescaledClockM' is trivially a 'RescaledClockS'.
 rescaledClockMToS ::
@@ -214,7 +183,7 @@ rescaledClockMToS ::
 rescaledClockMToS RescaledClockM {..} =
   RescaledClockS
     { unscaledClockS = unscaledClockM
-    , rescaleS = rescaleMToSInit rescaleM
+    , rescaleS = rescaleMToS rescaleM
     }
 
 -- | A 'RescaledClock' is trivially a 'RescaledClockS'.
@@ -236,12 +205,7 @@ instance
   where
   type Time (HoistClock m1 m2 cl) = Time cl
   type Tag (HoistClock m1 m2 cl) = Tag cl
-  initClock HoistClock {..} = do
-    (runningClock, initialTime) <- monadMorphism $ initClock unhoistedClock
-    return
-      ( hoistS monadMorphism runningClock
-      , initialTime
-      )
+  initClock HoistClock {..} = hoistS monadMorphism $ initClock unhoistedClock
 
 -- | Lift a clock type into a monad transformer.
 type LiftClock m t cl = HoistClock m (t m) cl

rhine/src/FRP/Rhine/Clock/Except.hs

@@ -5,7 +5,6 @@ import Control.Arrow
 import Control.Exception
 import Control.Exception qualified as Exception
 import Control.Monad ((<=<))
-import Data.Functor ((<&>))
 import Data.Void
 
 -- time
@@ -50,11 +49,7 @@ instance (Exception e, Clock IO cl, MonadIO eio, MonadError e eio) => Clock eio
   type Time (ExceptClock cl e) = Time cl
   type Tag (ExceptClock cl e) = Tag cl
 
-  initClock ExceptClock {getExceptClock} = do
-    ioerror $
-      Exception.try $
-        initClock getExceptClock
-          <&> first (hoistS (ioerror . Exception.try))
+  initClock ExceptClock {getExceptClock} = hoistS (ioerror . Exception.try) $ initClock getExceptClock
     where
       ioerror :: (MonadError e eio, MonadIO eio) => IO (Either e a) -> eio a
       ioerror = liftEither <=< liftIO
@@ -76,17 +71,10 @@ data CatchClock cl1 e cl2 = CatchClock cl1 (e -> cl2)
 instance (Time cl1 ~ Time cl2, Clock (ExceptT e m) cl1, Clock m cl2, Monad m) => Clock m (CatchClock cl1 e cl2) where
   type Time (CatchClock cl1 e cl2) = Time cl1
   type Tag (CatchClock cl1 e cl2) = Either (Tag cl2) (Tag cl1)
-  initClock (CatchClock cl1 handler) = do
-    tryToInit <- runExceptT $ first (>>> arr (second Right)) <$> initClock cl1
-    case tryToInit of
-      Right (runningClock, initTime) -> do
-        let catchingClock = safely $ do
-              e <- AutomatonExcept.try runningClock
-              let cl2 = handler e
-              (runningClock', _) <- once_ $ initClock cl2
-              safe $ runningClock' >>> arr (second Left)
-        return (catchingClock, initTime)
-      Left e -> (fmap (first (>>> arr (second Left))) . initClock) $ handler e
+  initClock (CatchClock cl1 handler) = safely $ do
+    e <- AutomatonExcept.try $ initClock cl1 >>> arr (second Right)
+    let cl2 = handler e
+    safe $ initClock cl2 >>> arr (second Left)
 
 instance (GetClockProxy (CatchClock cl1 e cl2))
 
@@ -134,14 +122,13 @@ data Single m time tag e = Single
 instance (TimeDomain time, MonadError e m) => Clock m (Single m time tag e) where
   type Time (Single m time tag e) = time
   type Tag (Single m time tag e) = tag
-  initClock Single {singleTag, getTime, exception} = do
-    initTime <- getTime
-    let runningClock = hoistS (errorT . runExceptT) $ runAutomatonExcept $ do
-          step_ (initTime, singleTag)
-          return exception
-        errorT :: (MonadError e m) => m (Either e a) -> m a
-        errorT = (>>= liftEither)
-    return (runningClock, initTime)
+  initClock Single {singleTag, getTime, exception} = hoistS (errorT . runExceptT) $ runAutomatonExcept $ do
+    initTime <- once_ getTime
+    step_ (initTime, singleTag)
+    return exception
+    where
+      errorT :: (MonadError e m) => m (Either e a) -> m a
+      errorT = (>>= liftEither)
 
 -- * 'DelayException'
 

rhine/src/FRP/Rhine/Clock/FixedStep.hs

@@ -51,12 +51,9 @@ instance (MonadSchedule m, Monad m) => Clock (ScheduleT Integer m) (FixedStep n)
   type Tag (FixedStep n) = ()
   initClock cl =
     let step = stepsize cl
-     in return
-          ( arr (const step)
-              >>> accumulateWith (+) 0
-              >>> arrM (\time -> wait step $> (time, ()))
-          , 0
-          )
+     in arr (const step)
+          >>> accumulateWith (+) 0
+          >>> arrM (\time -> wait step $> (time, ()))
 
 instance GetClockProxy (FixedStep n)