From 53217aea998c254a16d7e82479ad78799f901793 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Wed, 8 Nov 2023 09:01:37 +0100
Subject: [PATCH 01/25] WIP

---
 rhine/rhine.cabal              |   2 +
 rhine/src/FRP/Rhine/SN/Free.hs | 177 +++++++++++++++++++++++++++++++++
 2 files changed, 179 insertions(+)
 create mode 100644 rhine/src/FRP/Rhine/SN/Free.hs

diff --git a/rhine/rhine.cabal b/rhine/rhine.cabal
index b70722f7..2498ffdd 100644
--- a/rhine/rhine.cabal
+++ b/rhine/rhine.cabal
@@ -117,6 +117,7 @@ library
     FRP.Rhine.Schedule
     FRP.Rhine.SN
     FRP.Rhine.SN.Combinators
+    FRP.Rhine.SN.Free
     FRP.Rhine.Type
 
   other-modules:
@@ -140,6 +141,7 @@ library
                      , simple-affine-space ^>= 0.2
                      , time-domain ^>= 0.1.0.2
                      , monad-schedule ^>= 0.1.2
+                     , free-category ^>= 0.0.4.5
 
   -- Directories containing source files.
   hs-source-dirs:      src
diff --git a/rhine/src/FRP/Rhine/SN/Free.hs b/rhine/src/FRP/Rhine/SN/Free.hs
new file mode 100644
index 00000000..b0502dea
--- /dev/null
+++ b/rhine/src/FRP/Rhine/SN/Free.hs
@@ -0,0 +1,177 @@
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module FRP.Rhine.SN.Free (At (Present), eraseClockSNComponent)
+where
+
+import Control.Arrow.Free
+import Control.Monad.Trans.MSF.Reader (runReaderS, readerS)
+import Data.Kind (Constraint, Type)
+import Data.Proxy (Proxy (..))
+import FRP.Rhine (ResamplingBuffer, TimeInfo (TimeInfo))
+import FRP.Rhine.ClSF.Core
+import FRP.Rhine.Clock (Clock (..), TimeDomain, TimeInfo, tag)
+import FRP.Rhine.ResamplingBuffer (ResamplingBuffer (..))
+import Control.Category (Category)
+import Control.Monad.Trans.Reader (ReaderT, withReaderT)
+
+-- Don't export Absent
+data At cl a = Present !a | Absent
+
+currently :: At cl a -> Maybe a
+currently (Present a) = Just a
+currently Absent = Nothing
+
+instance Functor (At cl) where
+  fmap f (Present a) = Present $ f a
+  fmap _ Absent = Absent
+
+instance Applicative (At cl) where
+  pure = Present
+
+  Present f <*> Present a = Present $! f a
+  Absent <*> Absent = Absent
+  _ <*> _ = error "At.<*>: internal error, mixed Absent and Present"
+
+instance Monad (At cl) where
+  Present a >>= f = case f a of
+    b@(Present _) -> b
+    Absent -> error "At.>>=: internal error, mixed Absent and Present"
+  Absent >>= _ = Absent
+
+-- FIXME look up how something like this is done properly
+-- type family HasClock cl (cls :: [Type]) :: Constraint where
+--   HasClock cl (cl ': cls) = ()
+--   HasClock cl1 (cl2 ': cls) = HasClock cl1 cls
+
+-- FIXME rewrite with prisms?
+class HasClock cl cls where
+  inject :: Proxy cl -> TimeInfo cl -> Tick cls
+  project :: Proxy cl -> Tick cls -> Maybe (TimeInfo cl)
+
+instance HasClock cl (cl ': cls) where
+  inject _ = Here
+  project _ (Here ti) = Just ti
+  project _ _ = Nothing
+
+instance (HasClock cl cls) => HasClock cl (cl' ': cls) where
+  inject proxy ti = There $ inject proxy ti
+  project _ (Here _) = Nothing
+  project proxy (There tick) = project proxy tick
+
+type family HasClocksOrdered clA clB (cls :: [Type]) :: Constraint where
+  HasClocksOrdered clA clB (clA ': cls) = HasClock clB cls
+  HasClocksOrdered clA clB (cl ': cls) = HasClocksOrdered clA clB cls
+
+data SNComponent m cls a b where
+  Synchronous ::
+    (HasClock cl cls, Clock m cl) =>
+    ClSF m cl a b ->
+    SNComponent m cls (At cl a) (At cl b)
+  Resampling ::
+    ( HasClocksOrdered clA clB cls
+    , HasClock clA cls
+    , HasClock clB cls -- FIXME The first constraint implies the second and third
+    ) =>
+    ResamplingBuffer m clA clB a b ->
+    SNComponent m cls (At clA a) (At clB b)
+  Feedback :: -- FIXME Do I need a particular order for these clocks? Think about some examples
+    (HasClock clA cls, HasClock clB cls) =>
+    FreeSN m cls (At clB b, c) (At clA a, d) ->
+    ResamplingBuffer m clA clB a b ->
+    SNComponent m cls c d
+  Wild :: -- FIXME Do I need this really? It's like a general buffer
+    MSF m a b -> SNComponent m cls a b
+
+newtype FreeSN m cls a b = FreeSN {getFreeSN :: A (SNComponent m cls) a b}
+
+eraseClockSNComponent :: forall m cls a b . (Monad m) => SNComponent m cls a b -> MSF (ReaderT (Tick cls) m) a b
+eraseClockSNComponent (Synchronous clsf) = readerS $ proc (tick, a) -> do
+  case (project (proxyFromClSF clsf) tick, a) of
+    (Nothing, _) -> returnA -< Absent
+    (Just ti, Present a) -> do
+      b <- runReaderS clsf -< (ti, a)
+      returnA -< Present b
+    _ -> error "eraseClockSNComponent: Internal error (Synchronous)" -< ()
+eraseClockSNComponent (Resampling resbuf0) = readerS $ eraseClockResBuf (Proxy @cls) resbuf0
+
+eraseClockSNComponent (Feedback sn resbuf0) =
+  let
+    proxyIn = proxyInFromResBuf resbuf0
+    proxyOut = proxyOutFromResBuf resbuf0
+    snErased = runReaderS $ eraseClockFreeSN sn
+   in
+    readerS $ feedback resbuf0 $ proc ((tick, a), resbuf) -> do
+      (bAt, resbuf') <- case project proxyOut tick of
+        Nothing -> returnA -< (Absent, resbuf)
+        Just ti -> do
+          (b, resbuf') <- arrM $ uncurry get -< (resbuf, ti)
+          returnA -< (Present b, resbuf')
+      (aAt, b) <- snErased -< (tick, (bAt, a))
+      resbuf'' <- case (project proxyIn tick, aAt) of
+        (Nothing, _) -> returnA -< resbuf'
+        (Just ti, Present a) -> do
+          arrM $ uncurry $ uncurry put -< ((resbuf', ti), a)
+        _ -> error "eraseClockSNComponent: internal error (Resampling)" -< ()
+      returnA -< (b, resbuf'')
+
+eraseClockSNComponent (Wild msf) = liftTransS msf
+
+eraseClockResBuf ::
+  (Monad m, HasClock cla cls, HasClock clb cls) =>
+  Proxy cls ->
+  ResamplingBuffer m cla clb a1 a2 ->
+  MSF m (Tick cls, At cl1 a1) (At cl2 a2)
+eraseClockResBuf _ resbuf0 =
+  let
+    proxyIn = proxyInFromResBuf resbuf0
+    proxyOut = proxyOutFromResBuf resbuf0
+   in
+    feedback resbuf0 $ proc ((tick, a), resbuf) -> do
+      resbuf' <- case (project proxyIn tick, a) of
+        (Nothing, _) -> returnA -< resbuf
+        (Just ti, Present a) -> do
+          arrM $ uncurry $ uncurry put -< ((resbuf, ti), a)
+        _ -> error "eraseClockSNComponent: internal error (Resampling)" -< ()
+      case project proxyOut tick of
+        Nothing -> returnA -< (Absent, resbuf')
+        Just ti -> do
+          (b, resbuf'') <- arrM $ uncurry get -< (resbuf', ti)
+          returnA -< (Present b, resbuf'')
+
+proxyFromClSF :: ClSF m cl a b -> Proxy cl
+proxyFromClSF _ = Proxy
+
+proxyInFromResBuf :: ResamplingBuffer m clA clB a b -> Proxy clA
+proxyInFromResBuf _ = Proxy
+
+proxyOutFromResBuf :: ResamplingBuffer m clA clB a b -> Proxy clB
+proxyOutFromResBuf _ = Proxy
+
+eraseClockFreeSN :: Monad m => FreeSN m cls a b -> MSF (ReaderT (Tick cls) m) a b
+eraseClockFreeSN FreeSN {getFreeSN} = runA getFreeSN eraseClockSNComponent
+
+eraseClockFreeSN' :: Monad m => FreeSN m cls a b -> ClSF m (Clocks m td cls) a b
+eraseClockFreeSN' = morphS (withReaderT _) . eraseClockFreeSN
+
+type family Map (f :: Type -> Type) (ts :: [Type]) :: [Type] where
+  Map f '[] = '[]
+  Map f (t ': ts) = f t ': Map f ts
+
+data HTuple cls where
+  Unit :: cl -> HTuple '[cl]
+  Cons :: cl -> HTuple cls -> HTuple (cl ': cls)
+
+data ClassyClock m td cl where
+  ClassyClock :: (Clock m cl, Time cl ~ td) => cl -> ClassyClock m td cl
+
+-- FIXME maybe put Clock constraints and time domain here?
+-- data Clocks m td cls where
+--   UnitClock :: (Clock m cl, Time cl ~ td) => cl -> Clocks m td '[cl]
+--   ConsClocks :: (Clock m cl, Time cl ~ td) => cl -> Clocks m td cls -> Clocks m td (cl ': cls)
+newtype Clocks m td cls = Clocks {getClocks :: HTuple (Map (ClassyClock m td) cls)}
+
+data Tick cls where
+  Here :: TimeInfo cl -> Tick (cl ': cls)
+  There :: Tick cls -> Tick (cl ': cls)

From d29a747ac3278b17695f849034c295659911efe2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Mon, 13 Nov 2023 15:53:39 +0100
Subject: [PATCH 02/25] WIP

---
 rhine/src/FRP/Rhine/SN/Free.hs | 121 ++++++++++++++++++++++++++++-----
 1 file changed, 103 insertions(+), 18 deletions(-)

diff --git a/rhine/src/FRP/Rhine/SN/Free.hs b/rhine/src/FRP/Rhine/SN/Free.hs
index b0502dea..c200f6d4 100644
--- a/rhine/src/FRP/Rhine/SN/Free.hs
+++ b/rhine/src/FRP/Rhine/SN/Free.hs
@@ -1,20 +1,46 @@
 {-# LANGUAGE Arrows #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
-module FRP.Rhine.SN.Free (At (Present), eraseClockSNComponent)
+module FRP.Rhine.SN.Free (
+  At (
+    -- It is intentional _not_ to export the constructor Absent.
+    -- It may only be used internally to guarantee clock safety,
+    -- since otherwise a user could create an absent signal
+    -- in a situation where the clock ticks.
+    -- The constructor Present is harmless though, since an unneeded value is simply discarded.
+    Present
+  ),
+  eraseClockFreeSN,
+  synchronous,
+  resampling,
+  feedbackSN,
+  always,
+  currently,
+  Rhine(..),
+  eraseClockRhine,
+  flow,
+  Clocks(..)
+)
 where
 
 import Control.Arrow.Free
-import Control.Monad.Trans.MSF.Reader (runReaderS, readerS)
+import Control.Monad.Trans.MSF.Reader (readerS, runReaderS)
+import Control.Monad.Trans.Reader (ReaderT, withReaderT)
 import Data.Kind (Constraint, Type)
 import Data.Proxy (Proxy (..))
-import FRP.Rhine (ResamplingBuffer, TimeInfo (TimeInfo))
 import FRP.Rhine.ClSF.Core
-import FRP.Rhine.Clock (Clock (..), TimeDomain, TimeInfo, tag)
+import FRP.Rhine.Clock (Clock (..), TimeDomain, TimeInfo (..), tag)
 import FRP.Rhine.ResamplingBuffer (ResamplingBuffer (..))
+import FRP.Rhine.Clock.Util (genTimeInfo)
+import FRP.Rhine.Clock.Proxy (GetClockProxy(getClockProxy), toClockProxy, ToClockProxy)
+import FRP.Rhine.Schedule (scheduleList)
+import Data.List.NonEmpty (fromList, toList)
+import Control.Monad.Schedule.Class (MonadSchedule)
+import Data.MonadicStreamFunction.Async (concatS)
+import Control.Monad.Trans.MSF (performOnFirstSample)
 import Control.Category (Category)
-import Control.Monad.Trans.Reader (ReaderT, withReaderT)
 
 -- Don't export Absent
 data At cl a = Present !a | Absent
@@ -55,7 +81,7 @@ instance HasClock cl (cl ': cls) where
   project _ (Here ti) = Just ti
   project _ _ = Nothing
 
-instance (HasClock cl cls) => HasClock cl (cl' ': cls) where
+instance {-# OVERLAPPABLE #-} (HasClock cl cls) => HasClock cl (cl' ': cls) where
   inject proxy ti = There $ inject proxy ti
   project _ (Here _) = Nothing
   project proxy (There tick) = project proxy tick
@@ -81,12 +107,36 @@ data SNComponent m cls a b where
     FreeSN m cls (At clB b, c) (At clA a, d) ->
     ResamplingBuffer m clA clB a b ->
     SNComponent m cls c d
-  Wild :: -- FIXME Do I need this really? It's like a general buffer
+  Always :: -- FIXME Do I need this really? It's like a general buffer. So maybe I can get rid of MSF buffer? No, that is still helpful because it has clock constraints
     MSF m a b -> SNComponent m cls a b
 
 newtype FreeSN m cls a b = FreeSN {getFreeSN :: A (SNComponent m cls) a b}
+  deriving (Category, Arrow)
+
+synchronous :: (HasClock cl cls, Clock m cl) => ClSF m cl a b -> FreeSN m cls (At cl a) (At cl b)
+synchronous = FreeSN . liftFree2 . Synchronous
+
+resampling ::
+  ( HasClock clA cls
+  , Clock m clA
+  , HasClocksOrdered clA clB cls
+  , HasClock clB cls
+  ) =>
+  ResamplingBuffer m clA clB a b ->
+  FreeSN m cls (At clA a) (At clB b)
+resampling = FreeSN . liftFree2 . Resampling
+
+feedbackSN ::
+  (HasClock clA cls, HasClock clB cls) =>
+  FreeSN m cls (At clB b, c) (At clA a, d) ->
+  ResamplingBuffer m clA clB a b ->
+  FreeSN m cls c d
+feedbackSN sn = FreeSN . liftFree2 . Feedback sn
 
-eraseClockSNComponent :: forall m cls a b . (Monad m) => SNComponent m cls a b -> MSF (ReaderT (Tick cls) m) a b
+always :: MSF m a b -> FreeSN m cls a b
+always = FreeSN . liftFree2 . Always
+
+eraseClockSNComponent :: forall m cls a b. (Monad m) => SNComponent m cls a b -> MSF (ReaderT (Tick cls) m) a b
 eraseClockSNComponent (Synchronous clsf) = readerS $ proc (tick, a) -> do
   case (project (proxyFromClSF clsf) tick, a) of
     (Nothing, _) -> returnA -< Absent
@@ -95,7 +145,6 @@ eraseClockSNComponent (Synchronous clsf) = readerS $ proc (tick, a) -> do
       returnA -< Present b
     _ -> error "eraseClockSNComponent: Internal error (Synchronous)" -< ()
 eraseClockSNComponent (Resampling resbuf0) = readerS $ eraseClockResBuf (Proxy @cls) resbuf0
-
 eraseClockSNComponent (Feedback sn resbuf0) =
   let
     proxyIn = proxyInFromResBuf resbuf0
@@ -115,8 +164,7 @@ eraseClockSNComponent (Feedback sn resbuf0) =
           arrM $ uncurry $ uncurry put -< ((resbuf', ti), a)
         _ -> error "eraseClockSNComponent: internal error (Resampling)" -< ()
       returnA -< (b, resbuf'')
-
-eraseClockSNComponent (Wild msf) = liftTransS msf
+eraseClockSNComponent (Always msf) = liftTransS msf
 
 eraseClockResBuf ::
   (Monad m, HasClock cla cls, HasClock clb cls) =>
@@ -149,11 +197,15 @@ proxyInFromResBuf _ = Proxy
 proxyOutFromResBuf :: ResamplingBuffer m clA clB a b -> Proxy clB
 proxyOutFromResBuf _ = Proxy
 
-eraseClockFreeSN :: Monad m => FreeSN m cls a b -> MSF (ReaderT (Tick cls) m) a b
+eraseClockFreeSN :: (Monad m) => FreeSN m cls a b -> MSF (ReaderT (Tick cls) m) a b
 eraseClockFreeSN FreeSN {getFreeSN} = runA getFreeSN eraseClockSNComponent
 
-eraseClockFreeSN' :: Monad m => FreeSN m cls a b -> ClSF m (Clocks m td cls) a b
-eraseClockFreeSN' = morphS (withReaderT _) . eraseClockFreeSN
+-- eraseClockFreeSN' :: (Monad m) => FreeSN m cls a b -> ClSF m (Clocks m td cls) a b
+-- eraseClockFreeSN' = morphS (withReaderT _) . eraseClockFreeSN
+
+-- FIXME interesting idea: Erase only some clocks, e.g. the first one of the stack.
+-- Then I need a concept between FreeSN and MSF.
+-- The advantage would be higher flexibility, and I could maye also use MonadSchedule to make the data parts concurrent
 
 type family Map (f :: Type -> Type) (ts :: [Type]) :: [Type] where
   Map f '[] = '[]
@@ -167,11 +219,44 @@ data ClassyClock m td cl where
   ClassyClock :: (Clock m cl, Time cl ~ td) => cl -> ClassyClock m td cl
 
 -- FIXME maybe put Clock constraints and time domain here?
--- data Clocks m td cls where
---   UnitClock :: (Clock m cl, Time cl ~ td) => cl -> Clocks m td '[cl]
---   ConsClocks :: (Clock m cl, Time cl ~ td) => cl -> Clocks m td cls -> Clocks m td (cl ': cls)
-newtype Clocks m td cls = Clocks {getClocks :: HTuple (Map (ClassyClock m td) cls)}
+data Clocks m td cls where
+  UnitClock :: (GetClockProxy cl, Clock m cl, Time cl ~ td) => cl -> Clocks m td '[cl]
+  ConsClocks :: (GetClockProxy cl, Clock m cl, Time cl ~ td) => cl -> Clocks m td cls -> Clocks m td (cl ': cls)
+
+-- FIXME This is
+-- newtype Clocks m td cls = Clocks {getClocks :: HTuple (Map (ClassyClock m td) cls)}
 
 data Tick cls where
   Here :: TimeInfo cl -> Tick (cl ': cls)
   There :: Tick cls -> Tick (cl ': cls)
+
+data Rhine m td cls a b = Rhine
+  { clocks :: Clocks m td cls
+  , freeSN :: FreeSN m cls a b
+  }
+
+eraseClockRhine :: (Monad m, MonadSchedule m) => Rhine m td cls a b -> MSF m a b
+eraseClockRhine Rhine {clocks, freeSN} = proc a -> do
+  ti <- runClocks clocks -< ()
+  runReaderS (eraseClockFreeSN freeSN) -< (ti, a)
+
+flow :: (Monad m, MonadSchedule m) => Rhine m td cls () () -> m ()
+flow = reactimate . eraseClockRhine
+
+runClocks :: (Monad m, MonadSchedule m) => Clocks m td cls -> MSF m () (Tick cls)
+runClocks cls = performOnFirstSample $ scheduleMSFs <$> getRunningClocks cls
+ where
+  getRunningClocks :: Monad m => Clocks m td cls -> m [MSF m () (Tick cls)]
+  getRunningClocks (UnitClock cl) = pure <$> startAndInjectClock cl
+  getRunningClocks (ConsClocks cl cls) = (:) <$> startAndInjectClock cl <*> (map (>>> arr There) <$> getRunningClocks cls)
+
+  startAndInjectClock :: (Monad m, GetClockProxy cl, HasClock cl cls) => Clock m cl => cl -> m (MSF m () (Tick cls))
+  startAndInjectClock cl = do
+    (runningClock, initTime) <- initClock cl
+    return $ runningClock >>> genTimeInfo getClockProxy initTime >>> arr (inject (clockProxy cl))
+
+  clockProxy :: cl -> Proxy cl
+  clockProxy _ = Proxy
+
+  scheduleMSFs :: (Monad m, MonadSchedule m) => [MSF m () a] -> MSF m () a
+  scheduleMSFs msfs = concatS $ scheduleList (fromList msfs) >>> arr toList

From 7543f2927a020cc57a14724cbb7d7db8294661cb Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Mon, 13 Nov 2023 15:53:49 +0100
Subject: [PATCH 03/25] Test on ball example

---
 rhine-examples/src/Ball.hs | 20 ++++++++++++++++++--
 1 file changed, 18 insertions(+), 2 deletions(-)

diff --git a/rhine-examples/src/Ball.hs b/rhine-examples/src/Ball.hs
index 8691ccc3..be429c5c 100644
--- a/rhine-examples/src/Ball.hs
+++ b/rhine-examples/src/Ball.hs
@@ -10,6 +10,7 @@ import Data.Vector.Sized as VS
 
 -- rhine
 import FRP.Rhine
+import qualified FRP.Rhine.SN.Free as Free
 
 type Ball = (Double, Double, Double)
 type BallVel = (Double, Double, Double)
@@ -88,9 +89,24 @@ statusRh = statusMsg @@ waitClock
 ballStatusRh :: Rhine IO (SeqClock SimClock StatusClock) (Maybe BallVel) ()
 ballStatusRh = ballRh >-- downsampleSimToStatus --> statusRh
 
-main :: IO ()
-main =
+mainOld :: IO ()
+mainOld =
   flow $
     startVelRh
       >-- fifoUnbounded
       --> ballStatusRh
+
+mainNew :: IO ()
+mainNew = Free.flow $ Free.Rhine
+  { Free.clocks = Free.ConsClocks StdinClock $ Free.ConsClocks (waitClock :: SimClock) $ Free.UnitClock (waitClock :: StatusClock)
+  , Free.freeSN =
+      arr Free.Present
+      >>> Free.synchronous startVel
+      >>> Free.resampling fifoUnbounded
+      >>> Free.synchronous ball
+      >>> Free.resampling downsampleSimToStatus
+      >>> Free.synchronous statusMsg
+      >>> arr (const ())
+  }
+
+main = mainNew

From 4302246d7373e7a04fca4f869c927f18dfc854ac Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Wed, 29 Nov 2023 15:45:45 +0100
Subject: [PATCH 04/25] Introduce position in heterogeneous tuple

---
 rhine/src/FRP/Rhine/SN/Free.hs | 33 +++++++++++++++++++++++++--------
 1 file changed, 25 insertions(+), 8 deletions(-)

diff --git a/rhine/src/FRP/Rhine/SN/Free.hs b/rhine/src/FRP/Rhine/SN/Free.hs
index c200f6d4..ac651d12 100644
--- a/rhine/src/FRP/Rhine/SN/Free.hs
+++ b/rhine/src/FRP/Rhine/SN/Free.hs
@@ -41,6 +41,8 @@ import Control.Monad.Schedule.Class (MonadSchedule)
 import Data.MonadicStreamFunction.Async (concatS)
 import Control.Monad.Trans.MSF (performOnFirstSample)
 import Control.Category (Category)
+import Data.Type.Equality ((:~:) (Refl))
+import Data.Typeable (cast, Typeable)
 
 -- Don't export Absent
 data At cl a = Present !a | Absent
@@ -73,18 +75,29 @@ instance Monad (At cl) where
 
 -- FIXME rewrite with prisms?
 class HasClock cl cls where
-  inject :: Proxy cl -> TimeInfo cl -> Tick cls
-  project :: Proxy cl -> Tick cls -> Maybe (TimeInfo cl)
+  position :: Position cl cls
 
 instance HasClock cl (cl ': cls) where
-  inject _ = Here
-  project _ (Here ti) = Just ti
-  project _ _ = Nothing
+  position = PHere
 
 instance {-# OVERLAPPABLE #-} (HasClock cl cls) => HasClock cl (cl' ': cls) where
-  inject proxy ti = There $ inject proxy ti
-  project _ (Here _) = Nothing
-  project proxy (There tick) = project proxy tick
+  position = PThere position
+
+inject :: forall cl cls . HasClock cl cls => Proxy cl -> TimeInfo cl -> Tick cls
+inject _ = injectPosition (position @cl @cls)
+
+injectPosition :: Position cl cls -> TimeInfo cl -> Tick cls
+injectPosition PHere ti = Here ti
+injectPosition (PThere pointer) ti = There $ injectPosition pointer ti
+
+project :: forall cl cls . HasClock cl cls => Proxy cl -> Tick cls -> Maybe (TimeInfo cl)
+project _ = projectPosition $ position @cl @cls
+
+projectPosition :: Position cl cls -> Tick cls -> Maybe (TimeInfo cl)
+projectPosition PHere (Here ti) = Just ti
+projectPosition (PThere position) (There tick) = projectPosition position tick
+projectPosition _ _ = Nothing
+
 
 type family HasClocksOrdered clA clB (cls :: [Type]) :: Constraint where
   HasClocksOrdered clA clB (clA ': cls) = HasClock clB cls
@@ -226,6 +239,10 @@ data Clocks m td cls where
 -- FIXME This is
 -- newtype Clocks m td cls = Clocks {getClocks :: HTuple (Map (ClassyClock m td) cls)}
 
+data Position cl cls where
+  PHere :: Position cl (cl ': cls)
+  PThere :: Position cl cls -> Position cl (cl' ': cls)
+
 data Tick cls where
   Here :: TimeInfo cl -> Tick (cl ': cls)
   There :: Tick cls -> Tick (cl ': cls)

From 0b2fa68110d2f62320858552d9ec49ba2f6194dd Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Wed, 29 Nov 2023 15:46:09 +0100
Subject: [PATCH 05/25] FIXME

---
 rhine/src/FRP/Rhine/SN/Free.hs | 1 +
 1 file changed, 1 insertion(+)

diff --git a/rhine/src/FRP/Rhine/SN/Free.hs b/rhine/src/FRP/Rhine/SN/Free.hs
index ac651d12..6b4d3462 100644
--- a/rhine/src/FRP/Rhine/SN/Free.hs
+++ b/rhine/src/FRP/Rhine/SN/Free.hs
@@ -231,6 +231,7 @@ data HTuple cls where
 data ClassyClock m td cl where
   ClassyClock :: (Clock m cl, Time cl ~ td) => cl -> ClassyClock m td cl
 
+-- FIXME I could also have a Nil constructor, an SN with no clocks is simply an MSF
 -- FIXME maybe put Clock constraints and time domain here?
 data Clocks m td cls where
   UnitClock :: (GetClockProxy cl, Clock m cl, Time cl ~ td) => cl -> Clocks m td '[cl]

From 316836e9782483a98b33ec3e53000f8776af5aee Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Wed, 15 Nov 2023 14:26:38 +0100
Subject: [PATCH 06/25] Output GHC errors in reverse

---
 cabal.project | 3 +++
 1 file changed, 3 insertions(+)

diff --git a/cabal.project b/cabal.project
index f44a24c6..ae253b8a 100644
--- a/cabal.project
+++ b/cabal.project
@@ -1 +1,4 @@
 packages: */*.cabal
+
+program-options
+    ghc-options: -freverse-errors -fmax-errors=1

From 5e534e0ed716adb5aee14b549ee6d2e5bc81f9b6 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Wed, 15 Nov 2023 14:27:05 +0100
Subject: [PATCH 07/25] Use new syntax in bayes & ball, further simplifications

---
 rhine-bayes/app/Main.hs        | 67 +++++++++++++++++-----------------
 rhine-examples/src/Ball.hs     | 45 ++++++-----------------
 rhine/src/FRP/Rhine/SN/Free.hs | 16 ++++----
 3 files changed, 54 insertions(+), 74 deletions(-)

diff --git a/rhine-bayes/app/Main.hs b/rhine-bayes/app/Main.hs
index cfd8faa8..bee28fb0 100644
--- a/rhine-bayes/app/Main.hs
+++ b/rhine-bayes/app/Main.hs
@@ -43,7 +43,8 @@ import Control.Monad.Bayes.Sampler.Strict
 import Control.Monad.Trans.MSF.Except
 
 -- rhine
-import FRP.Rhine
+import FRP.Rhine hiding (Rhine, flow, sn)
+import FRP.Rhine.SN.Free
 
 -- rhine-gloss
 import FRP.Rhine.Gloss.IO
@@ -379,11 +380,13 @@ glossClockUTC cl =
         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 +396,37 @@ userTemperature = tagS >>> arr (selector >>> fmap Product) >>> mappendS >>> arr
     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 =
diff --git a/rhine-examples/src/Ball.hs b/rhine-examples/src/Ball.hs
index be429c5c..fbe528ff 100644
--- a/rhine-examples/src/Ball.hs
+++ b/rhine-examples/src/Ball.hs
@@ -9,8 +9,8 @@ import System.Random
 import Data.Vector.Sized as VS
 
 -- rhine
-import FRP.Rhine
-import qualified FRP.Rhine.SN.Free as Free
+import FRP.Rhine hiding (sn, flow, Rhine)
+import FRP.Rhine.SN.Free as Free
 
 type Ball = (Double, Double, Double)
 type BallVel = (Double, Double, Double)
@@ -77,36 +77,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
-
-mainOld :: IO ()
-mainOld =
-  flow $
-    startVelRh
-      >-- fifoUnbounded
-      --> ballStatusRh
-
-mainNew :: IO ()
-mainNew = Free.flow $ Free.Rhine
-  { Free.clocks = Free.ConsClocks StdinClock $ Free.ConsClocks (waitClock :: SimClock) $ Free.UnitClock (waitClock :: StatusClock)
-  , Free.freeSN =
-      arr Free.Present
-      >>> Free.synchronous startVel
-      >>> Free.resampling fifoUnbounded
-      >>> Free.synchronous ball
-      >>> Free.resampling downsampleSimToStatus
-      >>> Free.synchronous statusMsg
+main :: IO ()
+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 ())
   }
-
-main = mainNew
diff --git a/rhine/src/FRP/Rhine/SN/Free.hs b/rhine/src/FRP/Rhine/SN/Free.hs
index 6b4d3462..03f838dd 100644
--- a/rhine/src/FRP/Rhine/SN/Free.hs
+++ b/rhine/src/FRP/Rhine/SN/Free.hs
@@ -231,11 +231,13 @@ data HTuple cls where
 data ClassyClock m td cl where
   ClassyClock :: (Clock m cl, Time cl ~ td) => cl -> ClassyClock m td cl
 
+infixr :.
+
 -- FIXME I could also have a Nil constructor, an SN with no clocks is simply an MSF
 -- FIXME maybe put Clock constraints and time domain here?
 data Clocks m td cls where
-  UnitClock :: (GetClockProxy cl, Clock m cl, Time cl ~ td) => cl -> Clocks m td '[cl]
-  ConsClocks :: (GetClockProxy cl, Clock m cl, Time cl ~ td) => cl -> Clocks m td cls -> Clocks m td (cl ': cls)
+  CNil :: Clocks m td '[]
+  (:.) :: (GetClockProxy cl, Clock m cl, Time cl ~ td) => cl -> Clocks m td cls -> Clocks m td (cl ': cls)
 
 -- FIXME This is
 -- newtype Clocks m td cls = Clocks {getClocks :: HTuple (Map (ClassyClock m td) cls)}
@@ -250,13 +252,13 @@ data Tick cls where
 
 data Rhine m td cls a b = Rhine
   { clocks :: Clocks m td cls
-  , freeSN :: FreeSN m cls a b
+  , sn :: FreeSN m cls a b
   }
 
 eraseClockRhine :: (Monad m, MonadSchedule m) => Rhine m td cls a b -> MSF m a b
-eraseClockRhine Rhine {clocks, freeSN} = proc a -> do
+eraseClockRhine Rhine {clocks, sn} = proc a -> do
   ti <- runClocks clocks -< ()
-  runReaderS (eraseClockFreeSN freeSN) -< (ti, a)
+  runReaderS (eraseClockFreeSN sn) -< (ti, a)
 
 flow :: (Monad m, MonadSchedule m) => Rhine m td cls () () -> m ()
 flow = reactimate . eraseClockRhine
@@ -265,8 +267,8 @@ runClocks :: (Monad m, MonadSchedule m) => Clocks m td cls -> MSF m () (Tick cls
 runClocks cls = performOnFirstSample $ scheduleMSFs <$> getRunningClocks cls
  where
   getRunningClocks :: Monad m => Clocks m td cls -> m [MSF m () (Tick cls)]
-  getRunningClocks (UnitClock cl) = pure <$> startAndInjectClock cl
-  getRunningClocks (ConsClocks cl cls) = (:) <$> startAndInjectClock cl <*> (map (>>> arr There) <$> getRunningClocks cls)
+  getRunningClocks CNil = pure []
+  getRunningClocks (cl :. cls) = (:) <$> startAndInjectClock cl <*> (map (>>> arr There) <$> getRunningClocks cls)
 
   startAndInjectClock :: (Monad m, GetClockProxy cl, HasClock cl cls) => Clock m cl => cl -> m (MSF m () (Tick cls))
   startAndInjectClock cl = do

From 9b1ba5db405172af5204704a5aff977a11616eb5 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Wed, 29 Nov 2023 14:43:18 +0100
Subject: [PATCH 08/25] Make heterogeneous things more generic

---
 rhine/src/FRP/Rhine/SN/Free.hs | 38 ++++++++++++++++------------------
 1 file changed, 18 insertions(+), 20 deletions(-)

diff --git a/rhine/src/FRP/Rhine/SN/Free.hs b/rhine/src/FRP/Rhine/SN/Free.hs
index 03f838dd..6ba71a66 100644
--- a/rhine/src/FRP/Rhine/SN/Free.hs
+++ b/rhine/src/FRP/Rhine/SN/Free.hs
@@ -84,18 +84,18 @@ instance {-# OVERLAPPABLE #-} (HasClock cl cls) => HasClock cl (cl' ': cls) wher
   position = PThere position
 
 inject :: forall cl cls . HasClock cl cls => Proxy cl -> TimeInfo cl -> Tick cls
-inject _ = injectPosition (position @cl @cls)
+inject _ = Tick . injectPosition (position @cl @cls)
 
-injectPosition :: Position cl cls -> TimeInfo cl -> Tick cls
-injectPosition PHere ti = Here ti
-injectPosition (PThere pointer) ti = There $ injectPosition pointer ti
+injectPosition :: Position cl cls -> f cl -> HSum f cls
+injectPosition PHere ti = HHere ti
+injectPosition (PThere pointer) ti = HThere $ injectPosition pointer ti
 
 project :: forall cl cls . HasClock cl cls => Proxy cl -> Tick cls -> Maybe (TimeInfo cl)
-project _ = projectPosition $ position @cl @cls
+project _ = projectPosition (position @cl @cls) . getTick
 
-projectPosition :: Position cl cls -> Tick cls -> Maybe (TimeInfo cl)
-projectPosition PHere (Here ti) = Just ti
-projectPosition (PThere position) (There tick) = projectPosition position tick
+projectPosition :: Position cl cls -> HSum f cls -> Maybe (f cl)
+projectPosition PHere (HHere ti) = Just ti
+projectPosition (PThere position) (HThere tick) = projectPosition position tick
 projectPosition _ _ = Nothing
 
 
@@ -220,13 +220,9 @@ eraseClockFreeSN FreeSN {getFreeSN} = runA getFreeSN eraseClockSNComponent
 -- Then I need a concept between FreeSN and MSF.
 -- The advantage would be higher flexibility, and I could maye also use MonadSchedule to make the data parts concurrent
 
-type family Map (f :: Type -> Type) (ts :: [Type]) :: [Type] where
-  Map f '[] = '[]
-  Map f (t ': ts) = f t ': Map f ts
-
-data HTuple cls where
-  Unit :: cl -> HTuple '[cl]
-  Cons :: cl -> HTuple cls -> HTuple (cl ': cls)
+data HTuple (f :: Type -> Type) (cls :: [Type]) where
+  Nil :: HTuple f '[]
+  Cons :: f cl -> HTuple f cls -> HTuple f (cl ': cls)
 
 data ClassyClock m td cl where
   ClassyClock :: (Clock m cl, Time cl ~ td) => cl -> ClassyClock m td cl
@@ -240,15 +236,17 @@ data Clocks m td cls where
   (:.) :: (GetClockProxy cl, Clock m cl, Time cl ~ td) => cl -> Clocks m td cls -> Clocks m td (cl ': cls)
 
 -- FIXME This is
--- newtype Clocks m td cls = Clocks {getClocks :: HTuple (Map (ClassyClock m td) cls)}
+newtype Clocks' m td cls = Clocks {getClocks :: HTuple (ClassyClock m td) cls}
 
 data Position cl cls where
   PHere :: Position cl (cl ': cls)
   PThere :: Position cl cls -> Position cl (cl' ': cls)
 
-data Tick cls where
-  Here :: TimeInfo cl -> Tick (cl ': cls)
-  There :: Tick cls -> Tick (cl ': cls)
+data HSum (f :: Type -> Type) (cls :: [Type]) where
+  HHere :: f cl -> HSum f (cl ': cls)
+  HThere :: HSum f cls -> HSum f (cl ': cls)
+
+newtype Tick cls = Tick {getTick :: HSum TimeInfo cls}
 
 data Rhine m td cls a b = Rhine
   { clocks :: Clocks m td cls
@@ -268,7 +266,7 @@ runClocks cls = performOnFirstSample $ scheduleMSFs <$> getRunningClocks cls
  where
   getRunningClocks :: Monad m => Clocks m td cls -> m [MSF m () (Tick cls)]
   getRunningClocks CNil = pure []
-  getRunningClocks (cl :. cls) = (:) <$> startAndInjectClock cl <*> (map (>>> arr There) <$> getRunningClocks cls)
+  getRunningClocks (cl :. cls) = (:) <$> startAndInjectClock cl <*> (map (>>> arr (Tick . HThere . getTick)) <$> getRunningClocks cls)
 
   startAndInjectClock :: (Monad m, GetClockProxy cl, HasClock cl cls) => Clock m cl => cl -> m (MSF m () (Tick cls))
   startAndInjectClock cl = do

From a0ea1ab4c0a62ad62bd7e0ff14726bc1c30b71f5 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Wed, 29 Nov 2023 14:43:33 +0100
Subject: [PATCH 09/25] Remove unneeded fixme

---
 rhine/src/FRP/Rhine/SN/Free.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/rhine/src/FRP/Rhine/SN/Free.hs b/rhine/src/FRP/Rhine/SN/Free.hs
index 6ba71a66..b4c8f337 100644
--- a/rhine/src/FRP/Rhine/SN/Free.hs
+++ b/rhine/src/FRP/Rhine/SN/Free.hs
@@ -120,7 +120,7 @@ data SNComponent m cls a b where
     FreeSN m cls (At clB b, c) (At clA a, d) ->
     ResamplingBuffer m clA clB a b ->
     SNComponent m cls c d
-  Always :: -- FIXME Do I need this really? It's like a general buffer. So maybe I can get rid of MSF buffer? No, that is still helpful because it has clock constraints
+  Always ::
     MSF m a b -> SNComponent m cls a b
 
 newtype FreeSN m cls a b = FreeSN {getFreeSN :: A (SNComponent m cls) a b}

From 68d446968845994bd9e2b72d5063923113bc6cfc Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Wed, 29 Nov 2023 14:43:41 +0100
Subject: [PATCH 10/25] FIXUP typo

---
 rhine/src/FRP/Rhine/SN/Free.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/rhine/src/FRP/Rhine/SN/Free.hs b/rhine/src/FRP/Rhine/SN/Free.hs
index b4c8f337..b6cb9828 100644
--- a/rhine/src/FRP/Rhine/SN/Free.hs
+++ b/rhine/src/FRP/Rhine/SN/Free.hs
@@ -175,7 +175,7 @@ eraseClockSNComponent (Feedback sn resbuf0) =
         (Nothing, _) -> returnA -< resbuf'
         (Just ti, Present a) -> do
           arrM $ uncurry $ uncurry put -< ((resbuf', ti), a)
-        _ -> error "eraseClockSNComponent: internal error (Resampling)" -< ()
+        _ -> error "eraseClockSNComponent: internal error (Feedback)" -< ()
       returnA -< (b, resbuf'')
 eraseClockSNComponent (Always msf) = liftTransS msf
 

From 17e49f3f007d0e4c19b3a4d1bc0de2aca14a5a71 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Wed, 29 Nov 2023 14:46:42 +0100
Subject: [PATCH 11/25] FIXUP Even more generic

---
 rhine/src/FRP/Rhine/SN/Free.hs | 16 +++++++---------
 1 file changed, 7 insertions(+), 9 deletions(-)

diff --git a/rhine/src/FRP/Rhine/SN/Free.hs b/rhine/src/FRP/Rhine/SN/Free.hs
index b6cb9828..9b82d6a0 100644
--- a/rhine/src/FRP/Rhine/SN/Free.hs
+++ b/rhine/src/FRP/Rhine/SN/Free.hs
@@ -78,24 +78,24 @@ class HasClock cl cls where
   position :: Position cl cls
 
 instance HasClock cl (cl ': cls) where
-  position = PHere
+  position = HHere Refl
 
 instance {-# OVERLAPPABLE #-} (HasClock cl cls) => HasClock cl (cl' ': cls) where
-  position = PThere position
+  position = HThere position
 
 inject :: forall cl cls . HasClock cl cls => Proxy cl -> TimeInfo cl -> Tick cls
 inject _ = Tick . injectPosition (position @cl @cls)
 
 injectPosition :: Position cl cls -> f cl -> HSum f cls
-injectPosition PHere ti = HHere ti
-injectPosition (PThere pointer) ti = HThere $ injectPosition pointer ti
+injectPosition (HHere Refl) ti = HHere ti
+injectPosition (HThere pointer) ti = HThere $ injectPosition pointer ti
 
 project :: forall cl cls . HasClock cl cls => Proxy cl -> Tick cls -> Maybe (TimeInfo cl)
 project _ = projectPosition (position @cl @cls) . getTick
 
 projectPosition :: Position cl cls -> HSum f cls -> Maybe (f cl)
-projectPosition PHere (HHere ti) = Just ti
-projectPosition (PThere position) (HThere tick) = projectPosition position tick
+projectPosition (HHere Refl) (HHere ti) = Just ti
+projectPosition (HThere position) (HThere tick) = projectPosition position tick
 projectPosition _ _ = Nothing
 
 
@@ -238,9 +238,7 @@ data Clocks m td cls where
 -- FIXME This is
 newtype Clocks' m td cls = Clocks {getClocks :: HTuple (ClassyClock m td) cls}
 
-data Position cl cls where
-  PHere :: Position cl (cl ': cls)
-  PThere :: Position cl cls -> Position cl (cl' ': cls)
+type Position cl cls = HSum ((:~:) cl) cls
 
 data HSum (f :: Type -> Type) (cls :: [Type]) where
   HHere :: f cl -> HSum f (cl ': cls)

From 8fae5ca5bb514477c5f8ffe184b6d6657de632a9 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Wed, 29 Nov 2023 14:50:31 +0100
Subject: [PATCH 12/25] FIXUP rename

---
 rhine/src/FRP/Rhine/SN/Free.hs | 18 +++++++++---------
 1 file changed, 9 insertions(+), 9 deletions(-)

diff --git a/rhine/src/FRP/Rhine/SN/Free.hs b/rhine/src/FRP/Rhine/SN/Free.hs
index 9b82d6a0..994227bc 100644
--- a/rhine/src/FRP/Rhine/SN/Free.hs
+++ b/rhine/src/FRP/Rhine/SN/Free.hs
@@ -78,24 +78,24 @@ class HasClock cl cls where
   position :: Position cl cls
 
 instance HasClock cl (cl ': cls) where
-  position = HHere Refl
+  position = Here Refl
 
 instance {-# OVERLAPPABLE #-} (HasClock cl cls) => HasClock cl (cl' ': cls) where
-  position = HThere position
+  position = There position
 
 inject :: forall cl cls . HasClock cl cls => Proxy cl -> TimeInfo cl -> Tick cls
 inject _ = Tick . injectPosition (position @cl @cls)
 
 injectPosition :: Position cl cls -> f cl -> HSum f cls
-injectPosition (HHere Refl) ti = HHere ti
-injectPosition (HThere pointer) ti = HThere $ injectPosition pointer ti
+injectPosition (Here Refl) ti = Here ti
+injectPosition (There pointer) ti = There $ injectPosition pointer ti
 
 project :: forall cl cls . HasClock cl cls => Proxy cl -> Tick cls -> Maybe (TimeInfo cl)
 project _ = projectPosition (position @cl @cls) . getTick
 
 projectPosition :: Position cl cls -> HSum f cls -> Maybe (f cl)
-projectPosition (HHere Refl) (HHere ti) = Just ti
-projectPosition (HThere position) (HThere tick) = projectPosition position tick
+projectPosition (Here Refl) (Here ti) = Just ti
+projectPosition (There position) (There tick) = projectPosition position tick
 projectPosition _ _ = Nothing
 
 
@@ -241,8 +241,8 @@ newtype Clocks' m td cls = Clocks {getClocks :: HTuple (ClassyClock m td) cls}
 type Position cl cls = HSum ((:~:) cl) cls
 
 data HSum (f :: Type -> Type) (cls :: [Type]) where
-  HHere :: f cl -> HSum f (cl ': cls)
-  HThere :: HSum f cls -> HSum f (cl ': cls)
+  Here :: f cl -> HSum f (cl ': cls)
+  There :: HSum f cls -> HSum f (cl ': cls)
 
 newtype Tick cls = Tick {getTick :: HSum TimeInfo cls}
 
@@ -264,7 +264,7 @@ runClocks cls = performOnFirstSample $ scheduleMSFs <$> getRunningClocks cls
  where
   getRunningClocks :: Monad m => Clocks m td cls -> m [MSF m () (Tick cls)]
   getRunningClocks CNil = pure []
-  getRunningClocks (cl :. cls) = (:) <$> startAndInjectClock cl <*> (map (>>> arr (Tick . HThere . getTick)) <$> getRunningClocks cls)
+  getRunningClocks (cl :. cls) = (:) <$> startAndInjectClock cl <*> (map (>>> arr (Tick . There . getTick)) <$> getRunningClocks cls)
 
   startAndInjectClock :: (Monad m, GetClockProxy cl, HasClock cl cls) => Clock m cl => cl -> m (MSF m () (Tick cls))
   startAndInjectClock cl = do

From 5e3ec6362bbb8536ab88f848dad15623c2c71fae Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Wed, 29 Nov 2023 15:28:46 +0100
Subject: [PATCH 13/25] WIP simplfiy Clocks

---
 rhine-examples/src/Ball.hs     |  2 +-
 rhine/src/FRP/Rhine/SN/Free.hs | 40 +++++++++++++++++++---------------
 2 files changed, 23 insertions(+), 19 deletions(-)

diff --git a/rhine-examples/src/Ball.hs b/rhine-examples/src/Ball.hs
index fbe528ff..719945cd 100644
--- a/rhine-examples/src/Ball.hs
+++ b/rhine-examples/src/Ball.hs
@@ -79,7 +79,7 @@ statusMsg = arrMCl $ \(x, y, z) ->
 
 main :: IO ()
 main = flow $ Rhine
-  { clocks = StdinClock :. (waitClock :: SimClock) :. (waitClock :: StatusClock) :. CNil
+  { clocks = StdinClock .:. (waitClock :: SimClock) .:. (waitClock :: StatusClock) .:. cnil
   , sn =
       arr Present
       >>> synchronous startVel
diff --git a/rhine/src/FRP/Rhine/SN/Free.hs b/rhine/src/FRP/Rhine/SN/Free.hs
index 994227bc..a6890008 100644
--- a/rhine/src/FRP/Rhine/SN/Free.hs
+++ b/rhine/src/FRP/Rhine/SN/Free.hs
@@ -21,7 +21,11 @@ module FRP.Rhine.SN.Free (
   Rhine(..),
   eraseClockRhine,
   flow,
-  Clocks(..)
+  Clocks(..),
+  HTuple(..),
+  HSum(..),
+  (.:.),
+  cnil
 )
 where
 
@@ -221,22 +225,22 @@ eraseClockFreeSN FreeSN {getFreeSN} = runA getFreeSN eraseClockSNComponent
 -- The advantage would be higher flexibility, and I could maye also use MonadSchedule to make the data parts concurrent
 
 data HTuple (f :: Type -> Type) (cls :: [Type]) where
-  Nil :: HTuple f '[]
-  Cons :: f cl -> HTuple f cls -> HTuple f (cl ': cls)
+  HNil :: HTuple f '[]
+  HCons :: f cl -> HTuple f cls -> HTuple f (cl ': cls)
 
-data ClassyClock m td cl where
-  ClassyClock :: (Clock m cl, Time cl ~ td) => cl -> ClassyClock m td cl
+infixr .:.
+
+(.:.) :: (GetClockProxy cl, Clock m cl) => cl -> Clocks m (Time cl) cls -> Clocks m (Time cl) (cl ': cls)
+getClassyClock .:. Clocks {getClocks} = Clocks $ HCons ClassyClock {getClassyClock} getClocks
 
-infixr :.
+cnil :: Clocks m td '[]
+cnil = Clocks HNil
 
--- FIXME I could also have a Nil constructor, an SN with no clocks is simply an MSF
--- FIXME maybe put Clock constraints and time domain here?
-data Clocks m td cls where
-  CNil :: Clocks m td '[]
-  (:.) :: (GetClockProxy cl, Clock m cl, Time cl ~ td) => cl -> Clocks m td cls -> Clocks m td (cl ': cls)
+data ClassyClock m td cl where
+  ClassyClock :: (Clock m cl, GetClockProxy cl, Time cl ~ td) => {getClassyClock :: cl} -> ClassyClock m td cl
 
 -- FIXME This is
-newtype Clocks' m td cls = Clocks {getClocks :: HTuple (ClassyClock m td) cls}
+newtype Clocks m td cls = Clocks {getClocks :: HTuple (ClassyClock m td) cls}
 
 type Position cl cls = HSum ((:~:) cl) cls
 
@@ -260,14 +264,14 @@ flow :: (Monad m, MonadSchedule m) => Rhine m td cls () () -> m ()
 flow = reactimate . eraseClockRhine
 
 runClocks :: (Monad m, MonadSchedule m) => Clocks m td cls -> MSF m () (Tick cls)
-runClocks cls = performOnFirstSample $ scheduleMSFs <$> getRunningClocks cls
+runClocks cls = performOnFirstSample $ scheduleMSFs <$> getRunningClocks (getClocks cls)
  where
-  getRunningClocks :: Monad m => Clocks m td cls -> m [MSF m () (Tick cls)]
-  getRunningClocks CNil = pure []
-  getRunningClocks (cl :. cls) = (:) <$> startAndInjectClock cl <*> (map (>>> arr (Tick . There . getTick)) <$> getRunningClocks cls)
+  getRunningClocks :: Monad m => HTuple (ClassyClock m td) cls -> m [MSF m () (Tick cls)]
+  getRunningClocks HNil = pure []
+  getRunningClocks (HCons cl cls) = (:) <$> startAndInjectClock cl <*> (map (>>> arr (Tick . There . getTick)) <$> getRunningClocks cls)
 
-  startAndInjectClock :: (Monad m, GetClockProxy cl, HasClock cl cls) => Clock m cl => cl -> m (MSF m () (Tick cls))
-  startAndInjectClock cl = do
+  startAndInjectClock :: (Monad m, HasClock cl cls) => ClassyClock m td cl -> m (MSF m () (Tick cls))
+  startAndInjectClock (ClassyClock cl) = do
     (runningClock, initTime) <- initClock cl
     return $ runningClock >>> genTimeInfo getClockProxy initTime >>> arr (inject (clockProxy cl))
 

From d710c84902113c259d61e087bb5e5c0cbb3abddc Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Wed, 29 Nov 2023 16:07:09 +0100
Subject: [PATCH 14/25] Use generics-sop

---
 rhine/rhine.cabal              |  1 +
 rhine/src/FRP/Rhine/SN/Free.hs | 45 ++++++++++++++--------------------
 2 files changed, 20 insertions(+), 26 deletions(-)

diff --git a/rhine/rhine.cabal b/rhine/rhine.cabal
index 2498ffdd..ae6cea40 100644
--- a/rhine/rhine.cabal
+++ b/rhine/rhine.cabal
@@ -142,6 +142,7 @@ library
                      , time-domain ^>= 0.1.0.2
                      , monad-schedule ^>= 0.1.2
                      , free-category ^>= 0.0.4.5
+                     , generics-sop ^>= 0.5.1.3
 
   -- Directories containing source files.
   hs-source-dirs:      src
diff --git a/rhine/src/FRP/Rhine/SN/Free.hs b/rhine/src/FRP/Rhine/SN/Free.hs
index a6890008..158b60d9 100644
--- a/rhine/src/FRP/Rhine/SN/Free.hs
+++ b/rhine/src/FRP/Rhine/SN/Free.hs
@@ -22,8 +22,8 @@ module FRP.Rhine.SN.Free (
   eraseClockRhine,
   flow,
   Clocks(..),
-  HTuple(..),
-  HSum(..),
+  NP(..),
+  NS(..),
   (.:.),
   cnil
 )
@@ -47,6 +47,7 @@ import Control.Monad.Trans.MSF (performOnFirstSample)
 import Control.Category (Category)
 import Data.Type.Equality ((:~:) (Refl))
 import Data.Typeable (cast, Typeable)
+import Generics.SOP (NS (..), NP (..))
 
 -- Don't export Absent
 data At cl a = Present !a | Absent
@@ -82,24 +83,24 @@ class HasClock cl cls where
   position :: Position cl cls
 
 instance HasClock cl (cl ': cls) where
-  position = Here Refl
+  position = Z Refl
 
 instance {-# OVERLAPPABLE #-} (HasClock cl cls) => HasClock cl (cl' ': cls) where
-  position = There position
+  position = S position
 
 inject :: forall cl cls . HasClock cl cls => Proxy cl -> TimeInfo cl -> Tick cls
 inject _ = Tick . injectPosition (position @cl @cls)
 
-injectPosition :: Position cl cls -> f cl -> HSum f cls
-injectPosition (Here Refl) ti = Here ti
-injectPosition (There pointer) ti = There $ injectPosition pointer ti
+injectPosition :: Position cl cls -> f cl -> NS f cls
+injectPosition (Z Refl) ti = Z ti
+injectPosition (S pointer) ti = S $ injectPosition pointer ti
 
 project :: forall cl cls . HasClock cl cls => Proxy cl -> Tick cls -> Maybe (TimeInfo cl)
 project _ = projectPosition (position @cl @cls) . getTick
 
-projectPosition :: Position cl cls -> HSum f cls -> Maybe (f cl)
-projectPosition (Here Refl) (Here ti) = Just ti
-projectPosition (There position) (There tick) = projectPosition position tick
+projectPosition :: Position cl cls -> NS f cls -> Maybe (f cl)
+projectPosition (Z Refl) (Z ti) = Just ti
+projectPosition (S position) (S tick) = projectPosition position tick
 projectPosition _ _ = Nothing
 
 
@@ -224,31 +225,23 @@ eraseClockFreeSN FreeSN {getFreeSN} = runA getFreeSN eraseClockSNComponent
 -- Then I need a concept between FreeSN and MSF.
 -- The advantage would be higher flexibility, and I could maye also use MonadSchedule to make the data parts concurrent
 
-data HTuple (f :: Type -> Type) (cls :: [Type]) where
-  HNil :: HTuple f '[]
-  HCons :: f cl -> HTuple f cls -> HTuple f (cl ': cls)
-
 infixr .:.
 
 (.:.) :: (GetClockProxy cl, Clock m cl) => cl -> Clocks m (Time cl) cls -> Clocks m (Time cl) (cl ': cls)
-getClassyClock .:. Clocks {getClocks} = Clocks $ HCons ClassyClock {getClassyClock} getClocks
+getClassyClock .:. Clocks {getClocks} = Clocks $ ClassyClock {getClassyClock} :* getClocks
 
 cnil :: Clocks m td '[]
-cnil = Clocks HNil
+cnil = Clocks Nil
 
 data ClassyClock m td cl where
   ClassyClock :: (Clock m cl, GetClockProxy cl, Time cl ~ td) => {getClassyClock :: cl} -> ClassyClock m td cl
 
 -- FIXME This is
-newtype Clocks m td cls = Clocks {getClocks :: HTuple (ClassyClock m td) cls}
-
-type Position cl cls = HSum ((:~:) cl) cls
+newtype Clocks m td cls = Clocks {getClocks :: NP (ClassyClock m td) cls}
 
-data HSum (f :: Type -> Type) (cls :: [Type]) where
-  Here :: f cl -> HSum f (cl ': cls)
-  There :: HSum f cls -> HSum f (cl ': cls)
+type Position cl cls = NS ((:~:) cl) cls
 
-newtype Tick cls = Tick {getTick :: HSum TimeInfo cls}
+newtype Tick cls = Tick {getTick :: NS TimeInfo cls}
 
 data Rhine m td cls a b = Rhine
   { clocks :: Clocks m td cls
@@ -266,9 +259,9 @@ flow = reactimate . eraseClockRhine
 runClocks :: (Monad m, MonadSchedule m) => Clocks m td cls -> MSF m () (Tick cls)
 runClocks cls = performOnFirstSample $ scheduleMSFs <$> getRunningClocks (getClocks cls)
  where
-  getRunningClocks :: Monad m => HTuple (ClassyClock m td) cls -> m [MSF m () (Tick cls)]
-  getRunningClocks HNil = pure []
-  getRunningClocks (HCons cl cls) = (:) <$> startAndInjectClock cl <*> (map (>>> arr (Tick . There . getTick)) <$> getRunningClocks cls)
+  getRunningClocks :: Monad m => NP (ClassyClock m td) cls -> m [MSF m () (Tick cls)]
+  getRunningClocks Nil = pure []
+  getRunningClocks (cl :* cls) = (:) <$> startAndInjectClock cl <*> (map (>>> arr (Tick . S . getTick)) <$> getRunningClocks cls)
 
   startAndInjectClock :: (Monad m, HasClock cl cls) => ClassyClock m td cl -> m (MSF m () (Tick cls))
   startAndInjectClock (ClassyClock cl) = do

From 42068afcf8e52fe5710af343a9cf97a54bf932fb Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Wed, 29 Nov 2023 16:07:18 +0100
Subject: [PATCH 15/25] FIXUP

---
 rhine-bayes/app/Main.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/rhine-bayes/app/Main.hs b/rhine-bayes/app/Main.hs
index bee28fb0..39ca2608 100644
--- a/rhine-bayes/app/Main.hs
+++ b/rhine-bayes/app/Main.hs
@@ -416,7 +416,7 @@ visualisationMultiRate = hoistClSF sampleIOGloss visualisation
 
 -- | Compose all four asynchronous components to a single 'Rhine'.
 mainRhineMultiRate = Rhine
-  { clocks = glossClockUTC GlossEventClockIO :. (liftClock waitClock :: ModelClock) :. (liftClock Busy :: InferenceClock) :. (glossClockUTC GlossSimClockIO) :. CNil
+  { 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

From e2735d20ba8c25fec952420adf75119d1002ce5a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Tue, 5 Dec 2023 16:14:55 +0100
Subject: [PATCH 16/25] WIP

---
 rhine/src/FRP/Rhine/Rhine/Free.hs | 79 +++++++++++++++++++++++++++++++
 1 file changed, 79 insertions(+)
 create mode 100644 rhine/src/FRP/Rhine/Rhine/Free.hs

diff --git a/rhine/src/FRP/Rhine/Rhine/Free.hs b/rhine/src/FRP/Rhine/Rhine/Free.hs
new file mode 100644
index 00000000..e06e363e
--- /dev/null
+++ b/rhine/src/FRP/Rhine/Rhine/Free.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE ExistentialQuantification #-}
+
+module FRP.Rhine.Rhine.Free where
+
+import FRP.Rhine.SN.Free
+import Data.Profunctor
+import FRP.Rhine.Clock
+import FRP.Rhine.Clock.Proxy
+import FRP.Rhine.ClSF.Core
+import FRP.Rhine.ResamplingBuffer
+import Control.Monad.Schedule.Class
+import Control.Arrow.Free
+import Control.Monad.Trans.MSF.Reader (runReaderS)
+
+data Rhine m td cls a b = Rhine
+  { clocks :: Clocks m td cls
+  , sn :: FreeSN m cls a b
+  }
+
+instance Profunctor (Rhine m td cls) where
+  dimap f g Rhine {clocks, sn} =
+    Rhine
+      { clocks
+      , sn = dimap f g sn
+      }
+
+(>@>) :: Rhine m td cls1 a b -> Rhine m td cls2 b c -> Rhine m td (Append cls1 cls2) a c
+Rhine clocks1 sn1 >@> Rhine clocks2 sn2 =
+  let clocks = appendClocks clocks1 clocks2
+   in Rhine
+        { clocks
+        , sn = appendClocksSN clocks2 sn1 >>> prependClocksSN clocks1 sn2
+        }
+
+infix 5 @@
+(@@) :: (Clock m cl, GetClockProxy cl) => ClSF m cl a b -> cl -> Rhine m (Time cl) '[cl] (At cl a) (At cl b)
+clsf @@ cl =
+  Rhine
+    { clocks = Clocks {getClocks = ClassyClock cl :* Nil}
+    , sn = synchronous clsf
+    }
+
+data RhineAndResamplingBuffer m td cls clC a c
+  = forall clB b.
+    (Clock m clB) =>
+    RhineAndResamplingBuffer (Position clB cls) (Rhine m td cls a (At clB b)) (ResamplingBuffer m clB clC b c)
+
+infix 2 >--
+(>--) :: (Clock m clB, HasClock clB cls) => Rhine m td cls a (At clB b) -> ResamplingBuffer m clB clC b c -> RhineAndResamplingBuffer m td cls clC a c
+(>--) = RhineAndResamplingBuffer position
+
+infixr 1 -->
+(-->) :: (HasClock clC cls2) => RhineAndResamplingBuffer m td cls1 clC a c -> Rhine m td cls2 (At clC c) d -> Rhine m td (Append cls1 cls2) a d
+RhineAndResamplingBuffer positionB (Rhine cls1 sn1) rb --> Rhine cls2 sn2 =
+  let positionC = position
+   in Rhine
+        { clocks = appendClocks cls1 cls2
+        , sn =
+            appendClocksSN cls2 sn1
+              >>> FreeSN (liftFree2 (Resampling (orderedPositionsInAppend cls1 cls2 positionB positionC) rb))
+              >>> prependClocksSN cls1 sn2
+        }
+
+eraseClockRhine :: (Monad m, MonadSchedule m) => Rhine m td cls a b -> MSF m a b
+eraseClockRhine Rhine {clocks, sn} = proc a -> do
+  ti <- runClocks clocks -< ()
+  runReaderS (eraseClockFreeSN sn) -< (ti, a)
+
+flow :: (Monad m, MonadSchedule m) => Rhine m td cls () a -> m ()
+flow = reactimate . eraseClockRhine . (>>>^ const ())
+
+infix 2 *@*
+(*@*) :: Rhine m td cls1 a b -> Rhine m td cls2 c d -> Rhine m td (Append cls1 cls2) (a, c) (b, d)
+Rhine cls1 sn1 *@* Rhine cls2 sn2 =
+  Rhine
+    { clocks = appendClocks cls1 cls2
+    , sn = appendClocksSN cls2 sn1 *** prependClocksSN cls1 sn2
+    }

From f3cc34856a3c1896f8e9b9b7b117422eed0b3113 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Tue, 5 Dec 2023 16:33:51 +0100
Subject: [PATCH 17/25] WIP, refactor random walk 1

---
 cabal.project                       |   3 -
 rhine-bayes/app/Main.hs             |   1 +
 rhine-examples/src/ADSR.hs          |  25 +--
 rhine-examples/src/Demonstration.hs |  19 +-
 rhine-examples/src/HelloWorld.hs    |   6 +-
 rhine-examples/src/RandomWalk.hs    |  37 ++--
 rhine/rhine.cabal                   |   4 +-
 rhine/src/FRP/Rhine/SN/Free.hs      | 267 +++++++++++++++++++---------
 8 files changed, 242 insertions(+), 120 deletions(-)

diff --git a/cabal.project b/cabal.project
index ae253b8a..f44a24c6 100644
--- a/cabal.project
+++ b/cabal.project
@@ -1,4 +1 @@
 packages: */*.cabal
-
-program-options
-    ghc-options: -freverse-errors -fmax-errors=1
diff --git a/rhine-bayes/app/Main.hs b/rhine-bayes/app/Main.hs
index 39ca2608..71850af5 100644
--- a/rhine-bayes/app/Main.hs
+++ b/rhine-bayes/app/Main.hs
@@ -44,6 +44,7 @@ import Control.Monad.Trans.MSF.Except
 
 -- rhine
 import FRP.Rhine hiding (Rhine, flow, sn)
+import FRP.Rhine.Rhine.Free
 import FRP.Rhine.SN.Free
 
 -- rhine-gloss
diff --git a/rhine-examples/src/ADSR.hs b/rhine-examples/src/ADSR.hs
index b4059cc0..4a0671cd 100644
--- a/rhine-examples/src/ADSR.hs
+++ b/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.
diff --git a/rhine-examples/src/Demonstration.hs b/rhine-examples/src/Demonstration.hs
index 6aaf5bf2..43d8a9f9 100644
--- a/rhine-examples/src/Demonstration.hs
+++ b/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.
diff --git a/rhine-examples/src/HelloWorld.hs b/rhine-examples/src/HelloWorld.hs
index 632fb294..efbd743f 100644
--- a/rhine-examples/src/HelloWorld.hs
+++ b/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)
diff --git a/rhine-examples/src/RandomWalk.hs b/rhine-examples/src/RandomWalk.hs
index 9cc9cbb8..d658d9e6 100644
--- a/rhine-examples/src/RandomWalk.hs
+++ b/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,29 @@ import System.Random
 import Data.Vector2
 
 -- rhine
-import FRP.Rhine
+import FRP.Rhine hiding (flow, sn, Rhine)
+import FRP.Rhine.SN.Free
+import FRP.Rhine.Rhine.Free
 
 type Point = Vector2 Float
 
 type SimulationClock = Millisecond 1
 type DisplayClock = Millisecond 1000
-type AppClock = SequentialClock StdinClock (SequentialClock SimulationClock DisplayClock)
+type AppClock = '[StdinClock, SimulationClock, 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
+simulation :: ClSF IO SimulationClock () Point
+simulation = feedback zeroVector $ proc ((), lastPoint) -> do
   direction <- constMCl $ randomRIO (0, 3 :: Int) -< ()
   let
     shift = case direction of
@@ -51,12 +50,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 +68,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
@@ -80,10 +78,17 @@ debugLocalTime = proc a -> do
   returnA -< a
 
 -- | Wire together all components
-mainRhine :: Rhine IO AppClock () ()
-mainRhine =
-  feedbackRhine (debugLocalTime ^->> keepLast zeroVector) $
-    keyboard @@ StdinClock >-- keepLast zeroVector --> simulation @@ waitClock >-- keepLast (zeroVector, zeroVector) --> display @@ waitClock
+mainRhine :: Rhine IO UTCTime AppClock () ()
+mainRhine = Rhine
+  { clocks = StdinClock .:. waitClock .:. waitClock .:. cnil
+  , sn = feedbackSN (debugLocalTime ^->> keepLast zeroVector) $ proc (lastPoint, ()) -> do
+      savedPoint <- resampling (keepLast zeroVector) <<< synchronous keyboard -< lastPoint
+      currentPoint <- resampling (keepLast zeroVector) <<< synchronous simulation -< pure ()
+      synchronous display -< (,) <$> savedPoint <*> currentPoint
+      returnA -< (currentPoint, ())
+  }
+  -- feedbackRhine (debugLocalTime ^->> keepLast zeroVector) $
+  --   keyboard @@ StdinClock >-- keepLast zeroVector --> simulation @@ waitClock >-- keepLast (zeroVector, zeroVector) --> display @@ waitClock
 
 -- | Execute the main Rhine
 main :: IO ()
diff --git a/rhine/rhine.cabal b/rhine/rhine.cabal
index ae6cea40..73d51f8d 100644
--- a/rhine/rhine.cabal
+++ b/rhine/rhine.cabal
@@ -114,6 +114,7 @@ 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
@@ -142,7 +143,8 @@ library
                      , time-domain ^>= 0.1.0.2
                      , monad-schedule ^>= 0.1.2
                      , free-category ^>= 0.0.4.5
-                     , generics-sop ^>= 0.5.1.3
+                     , sop-core ^>= 0.5.0.2
+                     , profunctors ^>= 5.6.2
 
   -- Directories containing source files.
   hs-source-dirs:      src
diff --git a/rhine/src/FRP/Rhine/SN/Free.hs b/rhine/src/FRP/Rhine/SN/Free.hs
index 158b60d9..a25d4904 100644
--- a/rhine/src/FRP/Rhine/SN/Free.hs
+++ b/rhine/src/FRP/Rhine/SN/Free.hs
@@ -1,7 +1,12 @@
 {-# LANGUAGE Arrows #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 
 module FRP.Rhine.SN.Free (
   At (
@@ -12,53 +17,70 @@ module FRP.Rhine.SN.Free (
     -- The constructor Present is harmless though, since an unneeded value is simply discarded.
     Present
   ),
+  SNComponent (..),
+  FreeSN (..),
   eraseClockFreeSN,
   synchronous,
   resampling,
   feedbackSN,
   always,
   currently,
-  Rhine(..),
-  eraseClockRhine,
-  flow,
-  Clocks(..),
-  NP(..),
-  NS(..),
+  Clocks (..),
+  NP (..),
+  NS (..),
   (.:.),
-  cnil
+  cnil,
+  (^>>>),
+  (>>>^),
+  Append,
+  Position, -- FIXME this should be internal
+  HasClock (..),
+  runClocks,
+  -- FIXME the followong are probably internal
+  appendClocks,
+  appendClocksSN,
+  prependClocksSN,
+  ClassyClock (..),
+  orderedPositionsInAppend,
 )
 where
 
+-- FIXME sort imports and exports
+
 import Control.Arrow.Free
+import Control.Category (Category)
+import Control.Monad.Schedule.Class (MonadSchedule)
+import Control.Monad.Trans.MSF (performOnFirstSample)
 import Control.Monad.Trans.MSF.Reader (readerS, runReaderS)
-import Control.Monad.Trans.Reader (ReaderT, withReaderT)
-import Data.Kind (Constraint, Type)
+import Control.Monad.Trans.Reader (ReaderT)
+import Data.Kind (Type)
+import Data.List.NonEmpty (fromList, toList)
+import Data.MonadicStreamFunction.Async (concatS)
 import Data.Proxy (Proxy (..))
+import Data.SOP (NP (..), NS (..))
+import Data.Type.Equality ((:~:) (Refl))
+
+import Data.Profunctor (Profunctor (..), WrappedArrow (..))
+
 import FRP.Rhine.ClSF.Core
-import FRP.Rhine.Clock (Clock (..), TimeDomain, TimeInfo (..), tag)
-import FRP.Rhine.ResamplingBuffer (ResamplingBuffer (..))
+import FRP.Rhine.Clock (Clock (..), TimeInfo (..), tag)
+import FRP.Rhine.Clock.Proxy (GetClockProxy (getClockProxy))
 import FRP.Rhine.Clock.Util (genTimeInfo)
-import FRP.Rhine.Clock.Proxy (GetClockProxy(getClockProxy), toClockProxy, ToClockProxy)
+import FRP.Rhine.ResamplingBuffer (ResamplingBuffer (..))
 import FRP.Rhine.Schedule (scheduleList)
-import Data.List.NonEmpty (fromList, toList)
-import Control.Monad.Schedule.Class (MonadSchedule)
-import Data.MonadicStreamFunction.Async (concatS)
-import Control.Monad.Trans.MSF (performOnFirstSample)
-import Control.Category (Category)
-import Data.Type.Equality ((:~:) (Refl))
-import Data.Typeable (cast, Typeable)
-import Generics.SOP (NS (..), NP (..))
 
--- Don't export Absent
+-- FIXME Don't export Absent, maybe by having an internal module?
 data At cl a = Present !a | Absent
+  deriving (Show, Eq, Functor, Foldable, Traversable)
 
 currently :: At cl a -> Maybe a
 currently (Present a) = Just a
 currently Absent = Nothing
 
-instance Functor (At cl) where
-  fmap f (Present a) = Present $ f a
-  fmap _ Absent = Absent
+-- Internal use in this module only
+unsafeAssumePresent :: String -> At cl a -> a
+unsafeAssumePresent _ (Present a) = a
+unsafeAssumePresent msg Absent = error msg
 
 instance Applicative (At cl) where
   pure = Present
@@ -78,6 +100,7 @@ instance Monad (At cl) where
 --   HasClock cl (cl ': cls) = ()
 --   HasClock cl1 (cl2 ': cls) = HasClock cl1 cls
 
+-- FIXME rewrite with sop-core?
 -- FIXME rewrite with prisms?
 class HasClock cl cls where
   position :: Position cl cls
@@ -88,14 +111,14 @@ instance HasClock cl (cl ': cls) where
 instance {-# OVERLAPPABLE #-} (HasClock cl cls) => HasClock cl (cl' ': cls) where
   position = S position
 
-inject :: forall cl cls . HasClock cl cls => Proxy cl -> TimeInfo cl -> Tick cls
+inject :: forall cl cls. (HasClock cl cls) => Proxy cl -> TimeInfo cl -> Tick cls
 inject _ = Tick . injectPosition (position @cl @cls)
 
 injectPosition :: Position cl cls -> f cl -> NS f cls
 injectPosition (Z Refl) ti = Z ti
 injectPosition (S pointer) ti = S $ injectPosition pointer ti
 
-project :: forall cl cls . HasClock cl cls => Proxy cl -> Tick cls -> Maybe (TimeInfo cl)
+project :: forall cl cls. (HasClock cl cls) => Proxy cl -> Tick cls -> Maybe (TimeInfo cl)
 project _ = projectPosition (position @cl @cls) . getTick
 
 projectPosition :: Position cl cls -> NS f cls -> Maybe (f cl)
@@ -103,27 +126,42 @@ projectPosition (Z Refl) (Z ti) = Just ti
 projectPosition (S position) (S tick) = projectPosition position tick
 projectPosition _ _ = Nothing
 
+-- type family HasClocksOrdered clA clB (cls :: [Type]) :: Constraint where
+--   HasClocksOrdered clA clB (clA ': cls) = HasClock clB cls
+--   HasClocksOrdered clA clB (cl ': cls) = HasClocksOrdered clA clB cls
+
+class HasClocksOrdered clA clB cls where
+  orderedPositions :: OrderedPositions clA clB cls
+
+instance (HasClock clB cls) => HasClocksOrdered clA clB (clA ': cls) where
+  orderedPositions = OPHere position
+
+instance {-# OVERLAPPABLE #-} (HasClocksOrdered clA clB cls) => HasClocksOrdered clA clB (cl ': cls) where
+  orderedPositions = OPThere orderedPositions
+
+firstPosition :: OrderedPositions clA clB cls -> Position clA cls
+firstPosition (OPHere _) = Z Refl
+firstPosition (OPThere positions) = S $ firstPosition positions
 
-type family HasClocksOrdered clA clB (cls :: [Type]) :: Constraint where
-  HasClocksOrdered clA clB (clA ': cls) = HasClock clB cls
-  HasClocksOrdered clA clB (cl ': cls) = HasClocksOrdered clA clB cls
+secondPosition :: OrderedPositions clA clB cls -> Position clB cls
+secondPosition (OPHere pos) = S pos
+secondPosition (OPThere positions) = S $ secondPosition positions
 
 data SNComponent m cls a b where
   Synchronous ::
-    (HasClock cl cls, Clock m cl) =>
+    (Clock m cl) =>
+    Position cl cls ->
     ClSF m cl a b ->
     SNComponent m cls (At cl a) (At cl b)
   Resampling ::
-    ( HasClocksOrdered clA clB cls
-    , HasClock clA cls
-    , HasClock clB cls -- FIXME The first constraint implies the second and third
-    ) =>
+    OrderedPositions clA clB cls ->
     ResamplingBuffer m clA clB a b ->
     SNComponent m cls (At clA a) (At clB b)
   Feedback :: -- FIXME Do I need a particular order for these clocks? Think about some examples
-    (HasClock clA cls, HasClock clB cls) =>
-    FreeSN m cls (At clB b, c) (At clA a, d) ->
+    Position clA cls ->
+    Position clB cls ->
     ResamplingBuffer m clA clB a b ->
+    FreeSN m cls (At clB b, c) (At clA a, d) ->
     SNComponent m cls c d
   Always ::
     MSF m a b -> SNComponent m cls a b
@@ -131,8 +169,10 @@ data SNComponent m cls a b where
 newtype FreeSN m cls a b = FreeSN {getFreeSN :: A (SNComponent m cls) a b}
   deriving (Category, Arrow)
 
+deriving via (WrappedArrow (FreeSN m cls)) instance Profunctor (FreeSN m cls)
+
 synchronous :: (HasClock cl cls, Clock m cl) => ClSF m cl a b -> FreeSN m cls (At cl a) (At cl b)
-synchronous = FreeSN . liftFree2 . Synchronous
+synchronous = FreeSN . liftFree2 . Synchronous position
 
 resampling ::
   ( HasClock clA cls
@@ -142,41 +182,39 @@ resampling ::
   ) =>
   ResamplingBuffer m clA clB a b ->
   FreeSN m cls (At clA a) (At clB b)
-resampling = FreeSN . liftFree2 . Resampling
+resampling = FreeSN . liftFree2 . Resampling orderedPositions
 
 feedbackSN ::
   (HasClock clA cls, HasClock clB cls) =>
-  FreeSN m cls (At clB b, c) (At clA a, d) ->
   ResamplingBuffer m clA clB a b ->
+  FreeSN m cls (At clB b, c) (At clA a, d) ->
   FreeSN m cls c d
-feedbackSN sn = FreeSN . liftFree2 . Feedback sn
+feedbackSN sn = FreeSN . liftFree2 . Feedback position position sn
 
 always :: MSF m a b -> FreeSN m cls a b
 always = FreeSN . liftFree2 . Always
 
 eraseClockSNComponent :: forall m cls a b. (Monad m) => SNComponent m cls a b -> MSF (ReaderT (Tick cls) m) a b
-eraseClockSNComponent (Synchronous clsf) = readerS $ proc (tick, a) -> do
-  case (project (proxyFromClSF clsf) tick, a) of
+eraseClockSNComponent (Synchronous position clsf) = readerS $ proc (tick, a) -> do
+  case (projectPosition position (getTick tick), a) of
     (Nothing, _) -> returnA -< Absent
     (Just ti, Present a) -> do
       b <- runReaderS clsf -< (ti, a)
       returnA -< Present b
     _ -> error "eraseClockSNComponent: Internal error (Synchronous)" -< ()
-eraseClockSNComponent (Resampling resbuf0) = readerS $ eraseClockResBuf (Proxy @cls) resbuf0
-eraseClockSNComponent (Feedback sn resbuf0) =
+eraseClockSNComponent (Resampling positions resbuf0) = readerS $ eraseClockResBuf (Proxy @cls) positions resbuf0
+eraseClockSNComponent (Feedback posA posB resbuf0 sn) =
   let
-    proxyIn = proxyInFromResBuf resbuf0
-    proxyOut = proxyOutFromResBuf resbuf0
     snErased = runReaderS $ eraseClockFreeSN sn
    in
     readerS $ feedback resbuf0 $ proc ((tick, a), resbuf) -> do
-      (bAt, resbuf') <- case project proxyOut tick of
+      (bAt, resbuf') <- case projectPosition posB $ getTick tick of
         Nothing -> returnA -< (Absent, resbuf)
         Just ti -> do
           (b, resbuf') <- arrM $ uncurry get -< (resbuf, ti)
           returnA -< (Present b, resbuf')
       (aAt, b) <- snErased -< (tick, (bAt, a))
-      resbuf'' <- case (project proxyIn tick, aAt) of
+      resbuf'' <- case (projectPosition posA $ getTick tick, aAt) of
         (Nothing, _) -> returnA -< resbuf'
         (Just ti, Present a) -> do
           arrM $ uncurry $ uncurry put -< ((resbuf', ti), a)
@@ -185,22 +223,23 @@ eraseClockSNComponent (Feedback sn resbuf0) =
 eraseClockSNComponent (Always msf) = liftTransS msf
 
 eraseClockResBuf ::
-  (Monad m, HasClock cla cls, HasClock clb cls) =>
+  (Monad m) =>
   Proxy cls ->
-  ResamplingBuffer m cla clb a1 a2 ->
-  MSF m (Tick cls, At cl1 a1) (At cl2 a2)
-eraseClockResBuf _ resbuf0 =
+  OrderedPositions clA clB cls ->
+  ResamplingBuffer m clA clB a1 a2 ->
+  MSF m (Tick cls, At clA a1) (At clB a2)
+eraseClockResBuf _ orderedPositions resbuf0 =
   let
-    proxyIn = proxyInFromResBuf resbuf0
-    proxyOut = proxyOutFromResBuf resbuf0
+    posIn = firstPosition orderedPositions
+    posOut = secondPosition orderedPositions
    in
     feedback resbuf0 $ proc ((tick, a), resbuf) -> do
-      resbuf' <- case (project proxyIn tick, a) of
+      resbuf' <- case (projectPosition posIn $ getTick tick, a) of
         (Nothing, _) -> returnA -< resbuf
         (Just ti, Present a) -> do
           arrM $ uncurry $ uncurry put -< ((resbuf, ti), a)
         _ -> error "eraseClockSNComponent: internal error (Resampling)" -< ()
-      case project proxyOut tick of
+      case projectPosition posOut $ getTick tick of
         Nothing -> returnA -< (Absent, resbuf')
         Just ti -> do
           (b, resbuf'') <- arrM $ uncurry get -< (resbuf', ti)
@@ -225,7 +264,7 @@ eraseClockFreeSN FreeSN {getFreeSN} = runA getFreeSN eraseClockSNComponent
 -- Then I need a concept between FreeSN and MSF.
 -- The advantage would be higher flexibility, and I could maye also use MonadSchedule to make the data parts concurrent
 
-infixr .:.
+infixr 9 .:.
 
 (.:.) :: (GetClockProxy cl, Clock m cl) => cl -> Clocks m (Time cl) cls -> Clocks m (Time cl) (cl ': cls)
 getClassyClock .:. Clocks {getClocks} = Clocks $ ClassyClock {getClassyClock} :* getClocks
@@ -241,35 +280,99 @@ newtype Clocks m td cls = Clocks {getClocks :: NP (ClassyClock m td) cls}
 
 type Position cl cls = NS ((:~:) cl) cls
 
-newtype Tick cls = Tick {getTick :: NS TimeInfo cls}
-
-data Rhine m td cls a b = Rhine
-  { clocks :: Clocks m td cls
-  , sn :: FreeSN m cls a b
-  }
+data OrderedPositions cl1 cl2 cls where
+  OPHere :: Position cl2 cls -> OrderedPositions cl1 cl2 (cl1 ': cls)
+  OPThere :: OrderedPositions cl1 cl2 cls -> OrderedPositions cl1 cl2 (cl ': cls)
 
-eraseClockRhine :: (Monad m, MonadSchedule m) => Rhine m td cls a b -> MSF m a b
-eraseClockRhine Rhine {clocks, sn} = proc a -> do
-  ti <- runClocks clocks -< ()
-  runReaderS (eraseClockFreeSN sn) -< (ti, a)
+newtype Tick cls = Tick {getTick :: NS TimeInfo cls}
 
-flow :: (Monad m, MonadSchedule m) => Rhine m td cls () () -> m ()
-flow = reactimate . eraseClockRhine
+type family Append (cls1 :: [Type]) (cls2 :: [Type]) :: [Type] where
+  Append '[] cls = cls
+  Append (cl ': cls1) cls2 = cl ': Append cls1 cls2
+
+appendPosition :: Clocks m td cls2 -> Position cl cls1 -> Position cl (Append cls1 cls2)
+appendPosition _ (Z Refl) = Z Refl
+appendPosition clocks (S pos) = S $ appendPosition clocks pos
+
+prependPosition :: Clocks m td cls1 -> Position cl cls2 -> Position cl (Append cls1 cls2)
+prependPosition Clocks {getClocks = Nil} pos = pos
+prependPosition Clocks {getClocks = _ :* getClocks} pos = S $ prependPosition Clocks {getClocks} pos
+
+appendPositions :: Clocks m td cls2 -> OrderedPositions clA clB cls1 -> OrderedPositions clA clB (Append cls1 cls2)
+appendPositions clocks (OPHere pos) = OPHere $ appendPosition clocks pos
+appendPositions clocks (OPThere positions) = OPThere $ appendPositions clocks positions
+
+appendClocks :: Clocks m td cls1 -> Clocks m td cls2 -> Clocks m td (Append cls1 cls2)
+appendClocks Clocks {getClocks = Nil} clocks = clocks
+appendClocks Clocks {getClocks = cl :* cls} clocks =
+  let Clocks {getClocks} = appendClocks Clocks {getClocks = cls} clocks
+   in Clocks {getClocks = cl :* getClocks}
+
+addClockSNComponent :: SNComponent m cls a b -> SNComponent m (cl ': cls) a b
+addClockSNComponent (Synchronous position clsf) = Synchronous (S position) clsf
+addClockSNComponent (Resampling positions clsf) = Resampling (OPThere positions) clsf
+addClockSNComponent (Feedback posA posB resbuf sn) = Feedback (S posA) (S posB) resbuf (addClockSN sn)
+addClockSNComponent (Always msf) = Always msf
+
+appendClockSNComponent :: Clocks m td cls2 -> SNComponent m cls1 a b -> SNComponent m (Append cls1 cls2) a b
+appendClockSNComponent clocks (Synchronous position clsf) = Synchronous (appendPosition clocks position) clsf
+appendClockSNComponent clocks (Resampling positions resbuf) = Resampling (appendPositions clocks positions) resbuf
+appendClockSNComponent clocks (Feedback posA posB resbuf sn) =
+  Feedback
+    (appendPosition clocks posA)
+    (appendPosition clocks posB)
+    resbuf
+    (appendClocksSN clocks sn)
+appendClockSNComponent _ (Always msf) = Always msf
+
+addClockSN :: FreeSN m cls a b -> FreeSN m (cl ': cls) a b
+addClockSN = FreeSN . foldNatFree2 (liftFree2 . addClockSNComponent) . getFreeSN
+
+prependClocksSN :: Clocks m td cls1 -> FreeSN m cls2 a b -> FreeSN m (Append cls1 cls2) a b
+prependClocksSN Clocks {getClocks = Nil} = id
+prependClocksSN Clocks {getClocks = _ :* getClocks} = addClockSN . prependClocksSN Clocks {getClocks}
+
+appendClocksSN :: Clocks m td cls2 -> FreeSN m cls1 a b -> FreeSN m (Append cls1 cls2) a b
+appendClocksSN clocks = FreeSN . foldNatFree2 (liftFree2 . appendClockSNComponent clocks) . getFreeSN
+
+orderedPositionsInAppend ::
+  Clocks m td cls1 ->
+  Clocks m td cls2 ->
+  Position cl1 cls1 ->
+  Position cl2 cls2 ->
+  OrderedPositions cl1 cl2 (Append cls1 cls2)
+orderedPositionsInAppend Clocks {getClocks = _ :* getClocks} _ (Z Refl) pos2 = OPHere $ prependPosition Clocks {getClocks} pos2
+orderedPositionsInAppend Clocks {getClocks = _ :* getClocks} cls2 (S pos1) pos2 = OPThere $ orderedPositionsInAppend Clocks {getClocks} cls2 pos1 pos2
+-- I think that there are no other valid patterns. GHC 9.4 is unsure about that because of https://gitlab.haskell.org/ghc/ghc/-/issues/22684.
+-- Revisit with GHC 9.6.
+orderedPositionsInAppend Clocks {getClocks = Nil} _ _ _ = error "orderedPositionsInAppend: Internal error. Please report as a rhine bug."
 
 runClocks :: (Monad m, MonadSchedule m) => Clocks m td cls -> MSF m () (Tick cls)
 runClocks cls = performOnFirstSample $ scheduleMSFs <$> getRunningClocks (getClocks cls)
- where
-  getRunningClocks :: Monad m => NP (ClassyClock m td) cls -> m [MSF m () (Tick cls)]
-  getRunningClocks Nil = pure []
-  getRunningClocks (cl :* cls) = (:) <$> startAndInjectClock cl <*> (map (>>> arr (Tick . S . getTick)) <$> getRunningClocks cls)
+  where
+    getRunningClocks :: (Monad m) => NP (ClassyClock m td) cls -> m [MSF m () (Tick cls)]
+    getRunningClocks Nil = pure []
+    getRunningClocks (cl :* cls) = (:) <$> startAndInjectClock cl <*> (map (>>> arr (Tick . S . getTick)) <$> getRunningClocks cls)
+
+    startAndInjectClock :: (Monad m, HasClock cl cls) => ClassyClock m td cl -> m (MSF m () (Tick cls))
+    startAndInjectClock (ClassyClock cl) = do
+      (runningClock, initTime) <- initClock cl
+      return $ runningClock >>> genTimeInfo getClockProxy initTime >>> arr (inject (clockProxy cl))
+
+    clockProxy :: cl -> Proxy cl
+    clockProxy _ = Proxy
+
+    scheduleMSFs :: (Monad m, MonadSchedule m) => [MSF m () a] -> MSF m () a
+    scheduleMSFs msfs = concatS $ scheduleList (fromList msfs) >>> arr toList
+
+infix 4 >>>^
 
-  startAndInjectClock :: (Monad m, HasClock cl cls) => ClassyClock m td cl -> m (MSF m () (Tick cls))
-  startAndInjectClock (ClassyClock cl) = do
-    (runningClock, initTime) <- initClock cl
-    return $ runningClock >>> genTimeInfo getClockProxy initTime >>> arr (inject (clockProxy cl))
+-- | Operator alias for 'rmap', useful to postcompose a 'Rhine' or 'SN' with a function
+(>>>^) :: (Profunctor p) => p a b -> (b -> c) -> p a c
+(>>>^) = flip rmap
 
-  clockProxy :: cl -> Proxy cl
-  clockProxy _ = Proxy
+infix 3 ^>>>
 
-  scheduleMSFs :: (Monad m, MonadSchedule m) => [MSF m () a] -> MSF m () a
-  scheduleMSFs msfs = concatS $ scheduleList (fromList msfs) >>> arr toList
+-- | Operator alias for 'lmap', useful to precompose a 'Rhine' or 'SN' with a function
+(^>>>) :: (Profunctor p) => (a -> b) -> p b c -> p a c
+(^>>>) = lmap

From ebcb538a3264ebfe941b7ddf3948094facd29313 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Sat, 23 Dec 2023 12:13:30 +0100
Subject: [PATCH 18/25] Fix RandomWalk, small fixes, Util

---
 rhine-examples/src/RandomWalk.hs | 39 ++++++++++++++++++++------------
 rhine/src/FRP/Rhine/SN/Free.hs   |  9 ++++----
 2 files changed, 29 insertions(+), 19 deletions(-)

diff --git a/rhine-examples/src/RandomWalk.hs b/rhine-examples/src/RandomWalk.hs
index d658d9e6..157fbe14 100644
--- a/rhine-examples/src/RandomWalk.hs
+++ b/rhine-examples/src/RandomWalk.hs
@@ -18,15 +18,15 @@ import System.Random
 import Data.Vector2
 
 -- rhine
-import FRP.Rhine hiding (flow, sn, Rhine)
-import FRP.Rhine.SN.Free
+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 = '[StdinClock, 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.
@@ -37,8 +37,7 @@ keyboard = proc currentPoint -> do
   debugLocalTime -< ()
   returnA -< currentPoint
 
-{- | Every millisecond, go one step up, down, right or left.
--}
+-- | 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) -< ()
@@ -77,18 +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 UTCTime AppClock () ()
-mainRhine = Rhine
-  { clocks = StdinClock .:. waitClock .:. waitClock .:. cnil
-  , sn = feedbackSN (debugLocalTime ^->> keepLast zeroVector) $ proc (lastPoint, ()) -> do
-      savedPoint <- resampling (keepLast zeroVector) <<< synchronous keyboard -< lastPoint
-      currentPoint <- resampling (keepLast zeroVector) <<< synchronous simulation -< pure ()
-      synchronous display -< (,) <$> savedPoint <*> currentPoint
-      returnA -< (currentPoint, ())
-  }
-  -- feedbackRhine (debugLocalTime ^->> keepLast zeroVector) $
-  --   keyboard @@ StdinClock >-- keepLast zeroVector --> simulation @@ waitClock >-- keepLast (zeroVector, zeroVector) --> display @@ waitClock
+mainRhine =
+  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 ()
diff --git a/rhine/src/FRP/Rhine/SN/Free.hs b/rhine/src/FRP/Rhine/SN/Free.hs
index a25d4904..9de1817a 100644
--- a/rhine/src/FRP/Rhine/SN/Free.hs
+++ b/rhine/src/FRP/Rhine/SN/Free.hs
@@ -35,6 +35,7 @@ module FRP.Rhine.SN.Free (
   Append,
   Position, -- FIXME this should be internal
   HasClock (..),
+  HasClocksOrdered (..),
   runClocks,
   -- FIXME the followong are probably internal
   appendClocks,
@@ -175,10 +176,7 @@ synchronous :: (HasClock cl cls, Clock m cl) => ClSF m cl a b -> FreeSN m cls (A
 synchronous = FreeSN . liftFree2 . Synchronous position
 
 resampling ::
-  ( HasClock clA cls
-  , Clock m clA
-  , HasClocksOrdered clA clB cls
-  , HasClock clB cls
+  ( HasClocksOrdered clA clB cls
   ) =>
   ResamplingBuffer m clA clB a b ->
   FreeSN m cls (At clA a) (At clB b)
@@ -269,6 +267,9 @@ infixr 9 .:.
 (.:.) :: (GetClockProxy cl, Clock m cl) => cl -> Clocks m (Time cl) cls -> Clocks m (Time cl) (cl ': cls)
 getClassyClock .:. Clocks {getClocks} = Clocks $ ClassyClock {getClassyClock} :* getClocks
 
+clocks :: (GetClockProxy cl, Clock m cl) => cl -> Clocks m (Time cl) '[cl]
+clocks cl = cl .:. cnil
+
 cnil :: Clocks m td '[]
 cnil = Clocks Nil
 

From 0edb59369976dc848a968a357d180d30a1482b24 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Fri, 26 Jan 2024 18:23:59 +0100
Subject: [PATCH 19/25] Fix Ball example

---
 rhine-examples/src/Ball.hs | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/rhine-examples/src/Ball.hs b/rhine-examples/src/Ball.hs
index 719945cd..5f114b44 100644
--- a/rhine-examples/src/Ball.hs
+++ b/rhine-examples/src/Ball.hs
@@ -10,7 +10,8 @@ import Data.Vector.Sized as VS
 
 -- rhine
 import FRP.Rhine hiding (sn, flow, Rhine)
-import FRP.Rhine.SN.Free as Free
+import FRP.Rhine.SN.Free
+import FRP.Rhine.Rhine.Free
 
 type Ball = (Double, Double, Double)
 type BallVel = (Double, Double, Double)

From c83cb87a39219aa32edc755b5d8b14ad8e6a0a15 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Fri, 26 Jan 2024 18:24:21 +0100
Subject: [PATCH 20/25] Formatter and Rhine.feedback

---
 rhine/src/FRP/Rhine/Rhine/Free.hs | 21 ++++++++++++++++-----
 1 file changed, 16 insertions(+), 5 deletions(-)

diff --git a/rhine/src/FRP/Rhine/Rhine/Free.hs b/rhine/src/FRP/Rhine/Rhine/Free.hs
index e06e363e..81c444c8 100644
--- a/rhine/src/FRP/Rhine/Rhine/Free.hs
+++ b/rhine/src/FRP/Rhine/Rhine/Free.hs
@@ -3,15 +3,15 @@
 
 module FRP.Rhine.Rhine.Free where
 
-import FRP.Rhine.SN.Free
+import Control.Arrow.Free
+import Control.Monad.Schedule.Class
+import Control.Monad.Trans.MSF.Reader (runReaderS)
 import Data.Profunctor
+import FRP.Rhine.ClSF.Core
 import FRP.Rhine.Clock
 import FRP.Rhine.Clock.Proxy
-import FRP.Rhine.ClSF.Core
 import FRP.Rhine.ResamplingBuffer
-import Control.Monad.Schedule.Class
-import Control.Arrow.Free
-import Control.Monad.Trans.MSF.Reader (runReaderS)
+import FRP.Rhine.SN.Free
 
 data Rhine m td cls a b = Rhine
   { clocks :: Clocks m td cls
@@ -77,3 +77,14 @@ Rhine cls1 sn1 *@* Rhine cls2 sn2 =
     { clocks = appendClocks cls1 cls2
     , sn = appendClocksSN cls2 sn1 *** prependClocksSN cls1 sn2
     }
+
+feedback ::
+  (HasClock clA cls, HasClock clB cls) =>
+  ResamplingBuffer m clA clB a b ->
+  Rhine m td cls (At clB b, c) (At clA a, d) ->
+  Rhine m td cls c d
+feedback resBuf Rhine {clocks, sn} =
+  Rhine
+    { clocks
+    , sn = feedbackSN resBuf sn
+    }

From 2b7a688468ceb18fbf847e66f15d18943d90627a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Fri, 26 Jan 2024 18:25:00 +0100
Subject: [PATCH 21/25] Remove unneeded function

---
 rhine/src/FRP/Rhine/SN/Free.hs | 5 -----
 1 file changed, 5 deletions(-)

diff --git a/rhine/src/FRP/Rhine/SN/Free.hs b/rhine/src/FRP/Rhine/SN/Free.hs
index 9de1817a..3f29b84f 100644
--- a/rhine/src/FRP/Rhine/SN/Free.hs
+++ b/rhine/src/FRP/Rhine/SN/Free.hs
@@ -78,11 +78,6 @@ currently :: At cl a -> Maybe a
 currently (Present a) = Just a
 currently Absent = Nothing
 
--- Internal use in this module only
-unsafeAssumePresent :: String -> At cl a -> a
-unsafeAssumePresent _ (Present a) = a
-unsafeAssumePresent msg Absent = error msg
-
 instance Applicative (At cl) where
   pure = Present
 

From 5a4c7a643c5a7a67d99c9546c35113e00fab80a5 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Wed, 8 Nov 2023 09:01:37 +0100
Subject: [PATCH 22/25] Tags for clocks

---
 rhine/src/FRP/Rhine/SN/Free.hs | 4 ++++
 1 file changed, 4 insertions(+)

diff --git a/rhine/src/FRP/Rhine/SN/Free.hs b/rhine/src/FRP/Rhine/SN/Free.hs
index 3f29b84f..1cfc8d3d 100644
--- a/rhine/src/FRP/Rhine/SN/Free.hs
+++ b/rhine/src/FRP/Rhine/SN/Free.hs
@@ -276,6 +276,10 @@ newtype Clocks m td cls = Clocks {getClocks :: NP (ClassyClock m td) cls}
 
 type Position cl cls = NS ((:~:) cl) cls
 
+newtype TheTag cl = TheTag {getTheTag :: Tag cl}
+
+newtype Tags cls = Tags {getTags :: HSum TheTag cls}
+
 data OrderedPositions cl1 cl2 cls where
   OPHere :: Position cl2 cls -> OrderedPositions cl1 cl2 (cl1 ': cls)
   OPThere :: OrderedPositions cl1 cl2 cls -> OrderedPositions cl1 cl2 (cl ': cls)

From 6d35801c26792c3e4897d4812817c0f53ae4c5a6 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Tue, 14 Nov 2023 15:48:14 +0100
Subject: [PATCH 23/25] WIP erase one clock

---
 rhine/src/FRP/Rhine/SN/Free.hs | 18 ++++++++++++++++++
 1 file changed, 18 insertions(+)

diff --git a/rhine/src/FRP/Rhine/SN/Free.hs b/rhine/src/FRP/Rhine/SN/Free.hs
index 1cfc8d3d..c6ce7e80 100644
--- a/rhine/src/FRP/Rhine/SN/Free.hs
+++ b/rhine/src/FRP/Rhine/SN/Free.hs
@@ -256,6 +256,24 @@ eraseClockFreeSN FreeSN {getFreeSN} = runA getFreeSN eraseClockSNComponent
 -- FIXME interesting idea: Erase only some clocks, e.g. the first one of the stack.
 -- Then I need a concept between FreeSN and MSF.
 -- The advantage would be higher flexibility, and I could maye also use MonadSchedule to make the data parts concurrent
+-- FIXME I should use a TL snoc list for the reader ticks to avoid confusion?
+eraseOneClock :: FreeSN (ReaderT (Tick (cl ': cls')) m) (cl ': cls) a b -> FreeSN (ReaderT (Tick (cl ': cls')) m) cls a b
+eraseOneClock = _
+-- FIXME who knows whether cls' will have the same order as cls? I should maybe write a TL prefix thingy
+eraseOneClockComponent :: (HasClock cl cls', Monad m) => SNComponent (ReaderT (Tick cls') m) (cl ': cls) a b -> SNComponent (ReaderT (Tick cls') m) cls a b
+eraseOneClockComponent component@(Synchronous clsf) = case positionClSF clsf component of
+  PHere -> Always $ readerS $ proc (tick, a) -> do
+    case (project (proxyFromClSF clsf) tick, a) of
+      (Nothing, _) -> returnA -< Absent
+      (Just ti, Present a) -> do
+        b <- runReaderS $ runReaderS clsf -< (tick, (ti, a))
+        returnA -< Present b
+      _ -> error "eraseClockSNComponent: Internal error (Synchronous)" -< ()
+  PThere _ -> Synchronous clsf -- FIXME I should probably put the position in the SN component and only require the type class when calling synchronous
+ where
+  positionClSF :: HasClock cl cls => ClSF m cl a b -> SNComponent m cls c d -> Position cl cls
+  positionClSF _ _ = position
+
 
 infixr 9 .:.
 

From 4368b89bc0e813a7d6950f758bbf88a8c4906e6b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Wed, 29 Nov 2023 15:29:00 +0100
Subject: [PATCH 24/25] CHERRY try to translate between clock and clocks ti

---
 rhine/src/FRP/Rhine/SN/Free.hs | 17 +++++++++++++++++
 1 file changed, 17 insertions(+)

diff --git a/rhine/src/FRP/Rhine/SN/Free.hs b/rhine/src/FRP/Rhine/SN/Free.hs
index c6ce7e80..fda61b3a 100644
--- a/rhine/src/FRP/Rhine/SN/Free.hs
+++ b/rhine/src/FRP/Rhine/SN/Free.hs
@@ -5,6 +5,7 @@
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RecordWildCards #-} -- FIXME consider using lenses instead
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 
@@ -294,6 +295,22 @@ newtype Clocks m td cls = Clocks {getClocks :: NP (ClassyClock m td) cls}
 
 type Position cl cls = NS ((:~:) cl) cls
 
+instance (TimeDomain td) => Clock m (Clocks m td cls) where
+  type Time (Clocks m td cls) = td
+  type Tag (Clocks m td cls) = Tags cls
+
+clocksTimeInfoToTick :: TimeInfo (Clocks m td cls) -> Tick cls
+clocksTimeInfoToTick TimeInfo {tag = Tags {getTags = Here TheTag {getTheTag}}, ..} = Tick $ Here TimeInfo {tag = getTheTag, ..}
+clocksTimeInfoToTick TimeInfo {tag = Tags {getTags = There tag}, ..} = Tick $ There $ getTick $ clocksTimeInfoToTick TimeInfo {tag = Tags {getTags = tag}, ..}
+
+instance (TimeDomain td) => Clock m (Clocks m td cls) where
+  type Time (Clocks m td cls) = td
+  type Tag (Clocks m td cls) = Tags cls
+
+clocksTimeInfoToTick :: TimeInfo (Clocks m td cls) -> Tick cls
+clocksTimeInfoToTick TimeInfo {tag = Tags {getTags = Here TheTag {getTheTag}}, ..} = Tick $ Here TimeInfo {tag = getTheTag, ..}
+clocksTimeInfoToTick TimeInfo {tag = Tags {getTags = There tag}, ..} = Tick $ There $ getTick $ clocksTimeInfoToTick TimeInfo {tag = Tags {getTags = tag}, ..}
+
 newtype TheTag cl = TheTag {getTheTag :: Tag cl}
 
 newtype Tags cls = Tags {getTags :: HSum TheTag cls}

From aaefeaec7a52df0ce45f0a32ebc90ffa6e9abde1 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Wed, 29 Nov 2023 14:20:39 +0100
Subject: [PATCH 25/25] CHERRY erase SN in step to Rhine, but Rhine still isn't
 an Arrow

---
 rhine/src/FRP/Rhine/Rhine/Free.hs | 17 ++++++++++++++++-
 1 file changed, 16 insertions(+), 1 deletion(-)

diff --git a/rhine/src/FRP/Rhine/Rhine/Free.hs b/rhine/src/FRP/Rhine/Rhine/Free.hs
index 81c444c8..b8a813bc 100644
--- a/rhine/src/FRP/Rhine/Rhine/Free.hs
+++ b/rhine/src/FRP/Rhine/Rhine/Free.hs
@@ -15,9 +15,24 @@ import FRP.Rhine.SN.Free
 
 data Rhine m td cls a b = Rhine
   { clocks :: Clocks m td cls
-  , sn :: FreeSN m cls a b
+  , erasedSN :: MSF (ReaderT (Tick cls) m) a b
   }
 
+rhine :: Monad m => Clocks m td cls -> FreeSN m cls a b -> Rhine m td cls a b
+rhine clocks sn = Rhine
+  { clocks
+  , erasedSN = eraseClockFreeSN sn
+  }
+
+eraseClockRhine :: (Monad m, MonadSchedule m) => Rhine m td cls a b -> MSF m a b
+eraseClockRhine Rhine {clocks, erasedSN} = proc a -> do
+  ti <- runClocks clocks -< ()
+  runReaderS erasedSN -< (ti, a)
+
+flow :: (Monad m, MonadSchedule m) => Rhine m td cls () () -> m ()
+flow = reactimate . eraseClockRhine
+
+-- FIXME the following haven't been adapted to the new change yet
 instance Profunctor (Rhine m td cls) where
   dimap f g Rhine {clocks, sn} =
     Rhine