Making SN an arrow: Further ideas

rhine-bayes/app/Main.hs

@@ -43,7 +43,9 @@
 import Control.Monad.Trans.MSF.Except
 
 -- rhine
-import FRP.Rhine
+import FRP.Rhine hiding (Rhine, flow, sn)
+import FRP.Rhine.Rhine.Free
+import FRP.Rhine.SN.Free
 
 -- rhine-gloss
 import FRP.Rhine.Gloss.IO
@@ -379,11 +381,13 @@
         return (arr $ \(timePassed, event) -> (addUTCTime (realToFrac timePassed) now, event), now)
     }
 
+type ModelClock = (LiftClock IO GlossConcT (Millisecond 100))
+
 {- | The part of the program which simulates latent position and sensor,
    running 100 times a second.
 -}
-modelRhine :: Rhine (GlossConcT IO) (LiftClock IO GlossConcT (Millisecond 100)) Temperature (Temperature, (Sensor, Pos))
-modelRhine = hoistClSF sampleIOGloss (clId &&& genModelWithoutTemperature) @@ liftClock waitClock
+model :: ClSF (GlossConcT IO) ModelClock Temperature (Sensor, Pos)
+model = hoistClSF sampleIOGloss genModelWithoutTemperature
 
 -- | The user can change the temperature by pressing the up and down arrow keys.
 userTemperature :: ClSF (GlossConcT IO) (GlossClockUTC GlossEventClockIO) () Temperature
@@ -393,41 +397,37 @@
     selector (EventKey (SpecialKey KeyDown) Down _ _) = Just (1 / 1.2)
     selector _ = Nothing
 
+type InferenceClock = LiftClock IO GlossConcT Busy
+
 {- | This part performs the inference (and passes along temperature, sensor and position simulations).
    It runs as fast as possible, so this will potentially drain the CPU.
 -}
-inference :: Rhine (GlossConcT IO) (LiftClock IO GlossConcT Busy) (Temperature, (Sensor, Pos)) Result
-inference = hoistClSF sampleIOGloss inferenceBehaviour @@ liftClock Busy
-  where
-    inferenceBehaviour :: (MonadDistribution m, Diff td ~ Double, MonadIO m) => BehaviourF m td (Temperature, (Sensor, Pos)) Result
-    inferenceBehaviour = proc (temperature, (measured, latent)) -> do
-      positionsAndTemperatures <- runPopulationCl nParticles resampleSystematic posteriorTemperatureProcess -< measured
-      returnA
-        -<
-          Result
-            { temperature
-            , measured
-            , latent
-            , particlesPosition = first snd <$> positionsAndTemperatures
-            , particlesTemperature = first fst <$> positionsAndTemperatures
-            }
-
--- | Visualize the current 'Result' at a rate controlled by the @gloss@ backend, usually 30 FPS.
-visualisationRhine :: Rhine (GlossConcT IO) (GlossClockUTC GlossSimClockIO) Result ()
-visualisationRhine = hoistClSF sampleIOGloss visualisation @@ glossClockUTC GlossSimClockIO
-
-{- FOURMOLU_DISABLE -}
+inference :: ClSF (GlossConcT IO) InferenceClock Sensor ([(Pos, Log Double)], [(Temperature, Log Double)])
+inference = hoistClSF sampleIOGloss $ proc measured -> do
+  positionsAndTemperatures <- runPopulationCl nParticles resampleSystematic posteriorTemperatureProcess -< measured
+  let
+    particlesPosition = first snd <$> positionsAndTemperatures
+    particlesTemperature = first fst <$> positionsAndTemperatures
+  returnA -< (particlesPosition, particlesTemperature)
+
+type VisualisationClock = GlossClockUTC GlossSimClockIO
+
+visualisationMultiRate :: ClSF (GlossConcT IO) VisualisationClock Result ()
+visualisationMultiRate = hoistClSF sampleIOGloss visualisation
+
 -- | Compose all four asynchronous components to a single 'Rhine'.
-mainRhineMultiRate =
-  userTemperature
-    @@ glossClockUTC GlossEventClockIO
-      >-- keepLast initialTemperature -->
-        modelRhine
-        >-- keepLast (initialTemperature, (zeroVector, zeroVector)) -->
-          inference
-            >-- keepLast emptyResult -->
-              visualisationRhine
-{- FOURMOLU_ENABLE -}
+mainRhineMultiRate = Rhine
+  { clocks = glossClockUTC GlossEventClockIO .:. (liftClock waitClock :: ModelClock) .:. (liftClock Busy :: InferenceClock) .:. (glossClockUTC GlossSimClockIO) .:. cnil
+  , sn = proc _ -> do
+      temperature <- synchronous userTemperature -< Present ()
+      measuredAndLatent <- synchronous model <<< resampling (keepLast initialTemperature) -< temperature
+      positionsAndTemperatures <- synchronous inference <<< resampling (keepLast zeroVector) -< fmap fst measuredAndLatent
+      temperatureVisualisation <- resampling $ keepLast initialTemperature -< temperature
+      (measured, latent) <- arr (fmap fst &&& fmap snd) <<< resampling (keepLast (zeroVector, zeroVector)) -< measuredAndLatent
+      (particlesPosition, particlesTemperature) <- arr (fmap fst &&& fmap snd) <<< resampling (keepLast ([], [])) -< positionsAndTemperatures
+      synchronous visualisationMultiRate -< Result <$> temperatureVisualisation <*> measured <*> latent <*> particlesPosition <*> particlesTemperature
+      returnA -< ()
+  }
 
 mainMultiRate :: IO ()
 mainMultiRate =

rhine-examples/src/ADSR.hs

@@ -30,7 +30,9 @@ when the user stops pressing the key.
 module Main where
 
 -- rhine
-import FRP.Rhine
+import FRP.Rhine hiding (Rhine, flow, (-->), (>--), (>>>^), (@@), (^>>>))
+import FRP.Rhine.Rhine.Free
+import FRP.Rhine.SN.Free
 
 -- * The definition of an ADSR
 
@@ -133,8 +135,10 @@ linearly timeSpan initialAmplitude finalAmplitude overdue = proc _ -> do
   let
     remainingTime = timeSpan - time
     currentLevel =
-      ( initialAmplitude * remainingTime
-          + finalAmplitude * time
+      ( initialAmplitude
+          * remainingTime
+          + finalAmplitude
+          * time
       )
         / timeSpan
   _ <- throwOn' -< (remainingTime < 0, remainingTime)
@@ -203,14 +207,15 @@ release r s = linearly r s 0 0
 -- * The main program
 
 -- | A signal that alternates between 'False' and 'True' on every console newline.
-key :: Rhine IO StdinClock () Bool
-key = (count @Integer >>^ odd) @@ StdinClock
+key :: Rhine IO UTCTime '[StdinClock] () (At StdinClock Bool)
+key = Present ^>>> (count @Integer >>^ odd) @@ StdinClock
 
-{- | Output the current amplitude of the ADSR hull on the console,
-   every 0.03 seconds.
--}
-consoleADSR :: Rhine IO (Millisecond 30) Bool ()
-consoleADSR = runADSR myADSR >-> arrMCl print @@ waitClock
+-- | Output is produced every 0.03 seconds
+type OutputClock = Millisecond 30
+
+-- | Output the current amplitude of the ADSR hull on the console.
+consoleADSR :: Rhine IO UTCTime '[OutputClock] (At OutputClock Bool) ()
+consoleADSR = (runADSR myADSR >-> arrMCl print @@ waitClock) >>>^ const ()
 
 {- | Runs the main program, where you have the choice between console output
    and pulse output.

rhine-examples/src/Ball.hs

@@ -9,7 +9,9 @@ import System.Random
 import Data.Vector.Sized as VS
 
 -- rhine
-import FRP.Rhine
+import FRP.Rhine hiding (sn, flow, Rhine)
+import FRP.Rhine.SN.Free
+import FRP.Rhine.Rhine.Free
 
 type Ball = (Double, Double, Double)
 type BallVel = (Double, Double, Double)
@@ -76,21 +78,15 @@ statusMsg :: ClSF IO StatusClock Ball ()
 statusMsg = arrMCl $ \(x, y, z) ->
   printf "%.2f %.2f %.2f\n" x y z
 
-startVelRh :: Rhine IO StdinClock () BallVel
-startVelRh = startVel @@ StdinClock
-
-ballRh :: Rhine IO SimClock (Maybe BallVel) Ball
-ballRh = ball @@ waitClock
-
-statusRh :: Rhine IO StatusClock Ball ()
-statusRh = statusMsg @@ waitClock
-
-ballStatusRh :: Rhine IO (SeqClock SimClock StatusClock) (Maybe BallVel) ()
-ballStatusRh = ballRh >-- downsampleSimToStatus --> statusRh
-
 main :: IO ()
-main =
-  flow $
-    startVelRh
-      >-- fifoUnbounded
-      --> ballStatusRh
+main = flow $ Rhine
+  { clocks = StdinClock .:. (waitClock :: SimClock) .:. (waitClock :: StatusClock) .:. cnil
+  , sn =
+      arr Present
+      >>> synchronous startVel
+      >>> resampling fifoUnbounded
+      >>> synchronous ball
+      >>> resampling downsampleSimToStatus
+      >>> synchronous statusMsg
+      >>> arr (const ())
+  }

rhine-examples/src/Demonstration.hs

@@ -1,9 +1,13 @@
+{-# LANGUAGE Arrows #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 
-import FRP.Rhine
+import FRP.Rhine hiding (Rhine, flow, sn, (-->), (>--), (@@), (^>>>))
+import FRP.Rhine.Rhine.Free
+import FRP.Rhine.SN.Free
 
 {- | Create a simple message containing the time stamp since initialisation,
    for each tick of the clock.
@@ -48,11 +52,14 @@ printEverySecond = arrMCl print
 -}
 main :: IO ()
 main =
-  flow $
-    ms500 @@ waitClock |@|
-      ms1200 @@ waitClock
-        >-- collect
-        --> printEverySecond @@ waitClock
+  flow
+    $ Rhine
+      { clocks = waitClock @500 .:. waitClock @1200 .:. waitClock @1000 .:. cnil
+      , sn = proc _ -> do
+          msg500 <- resampling collect <<< synchronous ms500 -< Present ()
+          msg1200 <- resampling collect <<< synchronous ms1200 -< Present ()
+          synchronous printEverySecond -< (++) <$> msg500 <*> msg1200
+      }
 
 {- | Rhine prevents the consumption of a signal at a different clock than it is created,
    if no explicit resampling strategy is given.

rhine-examples/src/HelloWorld.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE DataKinds #-}
 
-import FRP.Rhine
+import FRP.Rhine hiding ((^>>>), (@@), flow)
+import FRP.Rhine.Rhine.Free
+import FRP.Rhine.SN.Free
 
 main :: IO ()
-main = flow $ constMCl (putStrLn "Hello World!") @@ (waitClock :: Millisecond 100)
+main = flow $ Present ^>>> constMCl (putStrLn "Hello World!") @@ (waitClock :: Millisecond 100)

rhine-examples/src/RandomWalk.hs

@@ -8,8 +8,6 @@ The internal state is a point in 2D space.
 Every millisecond, a unit step is taken in a random direction along either the X or Y axis.
 The current position and the distance to the origin is shown, as well as the position and distance to a saved point.
 (A point can be saved by pressing enter.)
-
-This mainly exists to test the 'feedbackRhine' construct.
 -}
 module Main where
 
@@ -20,28 +18,28 @@ import System.Random
 import Data.Vector2
 
 -- rhine
-import FRP.Rhine
+import FRP.Rhine hiding (Rhine, flow, sn)
+import FRP.Rhine.Rhine.Free
+import FRP.Rhine.SN.Free
 
 type Point = Vector2 Float
 
 type SimulationClock = Millisecond 1
 type DisplayClock = Millisecond 1000
-type AppClock = SequentialClock StdinClock (SequentialClock SimulationClock DisplayClock)
+type AppClock = '[SimulationClock, StdinClock, DisplayClock]
 
 {- | On every newline, show the current point and the local time.
    Also, forward the current point so it can be saved.
 -}
-keyboard :: ClSF IO StdinClock ((), Point) Point
-keyboard = proc ((), currentPoint) -> do
+keyboard :: ClSF IO StdinClock Point Point
+keyboard = proc currentPoint -> do
   arrMCl putStrLn -< "Saving: " ++ show currentPoint
   debugLocalTime -< ()
   returnA -< currentPoint
 
-{- | Every millisecond, go one step up, down, right or left.
-   Also, forward the current point when it was marked by the last newline.
--}
-simulation :: ClSF IO SimulationClock Point (Point, Point)
-simulation = feedback zeroVector $ proc (savedPoint, lastPoint) -> do
+-- | Every millisecond, go one step up, down, right or left.
+simulation :: ClSF IO SimulationClock () Point
+simulation = feedback zeroVector $ proc ((), lastPoint) -> do
   direction <- constMCl $ randomRIO (0, 3 :: Int) -< ()
   let
     shift = case direction of
@@ -51,12 +49,12 @@ simulation = feedback zeroVector $ proc (savedPoint, lastPoint) -> do
       3 -> vector2 0 1
       _ -> error "simulation: Internal error"
     nextPoint = lastPoint ^+^ shift
-  returnA -< ((savedPoint, nextPoint), nextPoint)
+  returnA -< (nextPoint, nextPoint)
 
 {- | Every second, display the current simulated point and the point saved by the keyboard,
    together with the distances from current point to origin and saved point, respectively.
 -}
-display :: ClSF IO DisplayClock (Point, Point) ((), Point)
+display :: ClSF IO DisplayClock (Point, Point) ()
 display = proc (savedPoint, currentPoint) -> do
   let
     distanceOrigin = norm currentPoint
@@ -69,7 +67,6 @@ display = proc (savedPoint, currentPoint) -> do
         , "Distance to origin: " ++ show distanceOrigin
         , "Distance to saved: " ++ show distanceSaved
         ]
-  returnA -< ((), currentPoint)
 
 -- | A helper to observe the difference between time since clock initialisation and local time
 debugLocalTime :: BehaviourF IO UTCTime a a
@@ -79,11 +76,28 @@ debugLocalTime = proc a -> do
   arrMCl putStrLn -< "since init: " ++ show sinceInit_ ++ "\nsince start: " ++ show sinceStart_
   returnA -< a
 
+-- | In this example, we will always zero-order resample, that is, by keeping the last value
+resample ::
+  ( HasClocksOrdered clA clB cls
+  , Monad m
+  ) =>
+  FreeSN m cls (At clA Point) (At clB Point)
+resample = resampling $ keepLast zeroVector
+
 -- | Wire together all components
-mainRhine :: Rhine IO AppClock () ()
+mainRhine :: Rhine IO UTCTime AppClock () ()
 mainRhine =
-  feedbackRhine (debugLocalTime ^->> keepLast zeroVector) $
-    keyboard @@ StdinClock >-- keepLast zeroVector --> simulation @@ waitClock >-- keepLast (zeroVector, zeroVector) --> display @@ waitClock
+  Rhine
+    -- The order of the clocks matters!
+    -- Since we are using the `simulation` first, we need to list its clock first.
+    { clocks = waitClock .:. StdinClock .:. waitClock .:. cnil
+    , sn = proc () -> do
+        currentPoint <- synchronous simulation -< pure ()
+        savedPoint <- resample <<< synchronous keyboard <<< resample -< currentPoint
+        currentPointDisplay <- resample -< currentPoint
+        synchronous display -< (,) <$> savedPoint <*> currentPointDisplay
+        returnA -< ()
+    }
 
 -- | Execute the main Rhine
 main :: IO ()

rhine/rhine.cabal

@@ -114,9 +114,11 @@ library
     FRP.Rhine.ResamplingBuffer.MSF
     FRP.Rhine.ResamplingBuffer.Timeless
     FRP.Rhine.ResamplingBuffer.Util
+    FRP.Rhine.Rhine.Free
     FRP.Rhine.Schedule
     FRP.Rhine.SN
     FRP.Rhine.SN.Combinators
+    FRP.Rhine.SN.Free
     FRP.Rhine.Type
 
   other-modules:
@@ -140,6 +142,9 @@ library
                      , simple-affine-space ^>= 0.2
                      , time-domain ^>= 0.1.0.2
                      , monad-schedule ^>= 0.1.2
+                     , free-category ^>= 0.0.4.5
+                     , sop-core ^>= 0.5.0.2
+                     , profunctors ^>= 5.6.2
 
   -- Directories containing source files.
   hs-source-dirs:      src