From b1d3858525df901a6bb629c485a9662313dadb97 Mon Sep 17 00:00:00 2001
From: Eric Conlon <37287+ejconlon@users.noreply.github.com>
Date: Fri, 23 Feb 2024 14:53:08 -0800
Subject: [PATCH] etc

---
 BootDirt.hs                                |   2 +-
 README.md                                  |   3 +-
 minipat-dirt/minipat-dirt.cabal            |   6 +-
 minipat-dirt/package.yaml                  |   4 +
 minipat-dirt/src/Minipat/Dirt/Boot.hs      |   8 +-
 minipat-dirt/src/Minipat/Dirt/Impl.hs      | 148 ++++--
 minipat-live/src/Minipat/Live/Attrs.hs     |   4 +-
 minipat-live/src/Minipat/Live/Boot.hs      |  28 +-
 minipat-live/src/Minipat/Live/Core.hs      | 541 +++++++++++----------
 minipat-live/src/Minipat/Live/Play.hs      | 162 +++---
 minipat-live/src/Minipat/Live/Resources.hs | 102 ++--
 minipat-live/test/Main.hs                  |  73 +--
 minipat/src/Minipat/Rand.hs                |  10 +-
 minipat/src/Minipat/Stream.hs              |  44 +-
 minipat/src/Minipat/Time.hs                | 130 ++---
 minipat/test/Main.hs                       |   4 +-
 16 files changed, 676 insertions(+), 593 deletions(-)

diff --git a/BootDirt.hs b/BootDirt.hs
index 5826525..4cfca22 100644
--- a/BootDirt.hs
+++ b/BootDirt.hs
@@ -17,7 +17,7 @@ putStrLn "============================================================"
 
 dirtSt <- initialize
 
-instance LiveSt where { type LiveEnv = DirtEnv; type LiveData = DirtData; liveSt = dirtSt }
+instance LiveSt where { type LiveBackend = DirtBackend; liveSt = dirtSt }
 
 handshake
 
diff --git a/README.md b/README.md
index 96a4cc6..d1fdd60 100644
--- a/README.md
+++ b/README.md
@@ -33,4 +33,5 @@ everything set up:
 * Implement polymeters
 * Additional combinators like `arp, off, jux, |+, every, squiz, range`
 * Backends for... Plain old MIDI? Renoise?
-
+* Backend with push/pull of textual patterns
+* More meaningful `Pretty` subclasses for pattern rep or plain old logging
diff --git a/minipat-dirt/minipat-dirt.cabal b/minipat-dirt/minipat-dirt.cabal
index 5ab0da7..f339605 100644
--- a/minipat-dirt/minipat-dirt.cabal
+++ b/minipat-dirt/minipat-dirt.cabal
@@ -62,11 +62,15 @@ library
       ViewPatterns
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds
   build-depends:
-      base >=4.12 && <5
+      async
+    , base >=4.12 && <5
     , containers ==0.6.*
     , dahdit-midi >=0.5.5 && <0.6
     , dahdit-network >=0.5.2 && <0.6
+    , minipat
     , minipat-live ==0.1.*
     , nanotime >=0.3.2 && <0.4
     , network ==3.1.*
+    , stm
+    , text
   default-language: GHC2021
diff --git a/minipat-dirt/package.yaml b/minipat-dirt/package.yaml
index fa4d123..b49a40a 100644
--- a/minipat-dirt/package.yaml
+++ b/minipat-dirt/package.yaml
@@ -21,6 +21,10 @@ dependencies:
 - minipat-live >= 0.1 && < 0.2
 - nanotime >= 0.3.2 && < 0.4
 - network >= 3.1 && < 3.2
+- text
+- stm
+- minipat
+- async
 
 library:
   source-dirs: src
diff --git a/minipat-dirt/src/Minipat/Dirt/Boot.hs b/minipat-dirt/src/Minipat/Dirt/Boot.hs
index db5ce1d..375fedb 100644
--- a/minipat-dirt/src/Minipat/Dirt/Boot.hs
+++ b/minipat-dirt/src/Minipat/Dirt/Boot.hs
@@ -1,8 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Minipat.Dirt.Boot
-  ( D.DirtEnv
-  , D.DirtData
+  ( D.DirtBackend
+  , D.DirtSt
   , DirtLiveSt
   , initialize
   , handshake
@@ -15,13 +15,13 @@ import Minipat.Live.Boot
 import Minipat.Live.Core qualified as C
 import Minipat.Live.Logger qualified as L
 
-type DirtLiveSt = (LiveSt, LiveEnv ~ D.DirtEnv, LiveData ~ D.DirtData)
+type DirtLiveSt = (LiveSt, LiveBackend ~ D.DirtBackend)
 
 initialize :: IO D.DirtSt
 initialize = do
   logger <- L.newLogger
   L.logInfo logger "Initializing"
-  C.initAsyncSt logger D.dirtImpl (C.defaultEnv D.defaultDirtEnv)
+  C.initAsyncSt logger D.defaultDirtBackend C.defaultEnv
 
 handshake :: (DirtLiveSt) => IO ()
 handshake = D.handshake liveSt
diff --git a/minipat-dirt/src/Minipat/Dirt/Impl.hs b/minipat-dirt/src/Minipat/Dirt/Impl.hs
index f1a410c..2bc9bc0 100644
--- a/minipat-dirt/src/Minipat/Dirt/Impl.hs
+++ b/minipat-dirt/src/Minipat/Dirt/Impl.hs
@@ -2,77 +2,102 @@
 
 -- | Superdirt-specific implementation
 module Minipat.Dirt.Impl
-  ( DirtEnv (..)
-  , defaultDirtEnv
-  , DirtData
+  ( DirtBackend (..)
+  , defaultDirtBackend
   , DirtSt
-  , dirtImpl
   , handshake
   )
 where
 
+import Control.Concurrent.Async (Async)
+import Control.Concurrent.STM (atomically)
+import Control.Concurrent.STM.TQueue (TQueue, flushTQueue, newTQueueIO, writeTQueue)
 import Control.Exception (SomeException, bracket, throwIO)
+import Control.Monad (void)
+import Control.Monad.IO.Class (liftIO)
 import Dahdit.Midi.Osc (Datum (..), Msg (..), Packet (..))
 import Dahdit.Midi.OscAddr (RawAddrPat)
 import Dahdit.Network (Conn (..), HostPort (..), resolveAddr, runDecoder, runEncoder, udpServerConn)
 import Data.Either (isRight)
-import Data.Foldable (foldl')
+import Data.Foldable (foldl', for_)
 import Data.Sequence (Seq (..))
+import Data.Text (Text)
 import Minipat.Live.Attrs (Attrs, attrsToList)
-import Minipat.Live.Core (Env (..), Impl (..), St (..), setPlaying, withData)
-import Minipat.Live.Logger (LogAction, logError, logInfo)
-import Minipat.Live.Resources (RelVar, Timed (..), relVarAcquire, withTimeout)
-import Nanotime (TimeDelta, timeDeltaFromFracSecs)
+import Minipat.Live.Core (Backend (..), Callback (..), St (..), setPlaying, useCallback)
+import Minipat.Live.Logger (logError, logInfo)
+import Minipat.Live.Play (PlayMeta (..), WithPlayMeta (..), attrsConvert)
+import Minipat.Live.Resources (acquireAwait, relVarAcquire, withTimeout)
+import Minipat.Time (Arc (..))
+import Nanotime (PosixTime, TimeDelta, timeDeltaFromFracSecs)
 import Network.Socket qualified as NS
 
-data DirtEnv = DirtEnv
-  { deTargetHp :: !HostPort
-  , deListenHp :: !HostPort
-  , deOscTimeout :: !TimeDelta
+data OscConn = OscConn
+  { ocTargetAddr :: !NS.SockAddr
+  , ocListenConn :: !(Conn NS.SockAddr)
+  }
+
+sendPacket :: OscConn -> Packet -> IO ()
+sendPacket (OscConn targetAddr (Conn _ enc)) = runEncoder enc targetAddr
+
+recvPacket :: TimeDelta -> OscConn -> IO (Either SomeException Packet)
+recvPacket timeout (OscConn _ (Conn dec _)) =
+  withTimeout timeout (runDecoder dec >>= either throwIO pure . snd)
+
+data DirtBackend = DirtBackend
+  { dbTargetHp :: !HostPort
+  , dbListenHp :: !HostPort
+  , dbOscTimeout :: !TimeDelta
   }
   deriving stock (Eq, Ord, Show)
 
-defaultDirtEnv :: DirtEnv
-defaultDirtEnv =
-  DirtEnv
-    { deTargetHp = HostPort (Just "127.0.0.1") 57120
-    , deListenHp = HostPort (Just "127.0.0.1") 57129
-    , deOscTimeout = timeDeltaFromFracSecs @Double 0.1
+defaultDirtBackend :: DirtBackend
+defaultDirtBackend =
+  DirtBackend
+    { dbTargetHp = HostPort (Just "127.0.0.1") 57120
+    , dbListenHp = HostPort (Just "127.0.0.1") 57129
+    , dbOscTimeout = timeDeltaFromFracSecs @Double 0.1
     }
 
-data OscConn = OscConn
-  { ocTargetAddr :: !NS.SockAddr
-  , ocListenConn :: !(Conn NS.SockAddr)
+type DirtSt = St DirtBackend
+
+data DirtData = DirtData
+  { ddOscConn :: !OscConn
+  , ddEventQueue :: !(TQueue (WithPlayMeta Attrs))
+  , ddSendTask :: !(Async ())
   }
 
-type DirtData = OscConn
+pwRealStart :: WithPlayMeta a -> PosixTime
+pwRealStart (WithPlayMeta pm _) = arcStart (pmRealArc pm)
 
-type DirtSt = St DirtEnv DirtData
+instance Backend DirtBackend where
+  type BackendData DirtBackend = DirtData
+  type BackendAttrs DirtBackend = Attrs
 
-dirtInit :: LogAction -> RelVar -> DirtEnv -> IO DirtData
-dirtInit _ rv (DirtEnv targetHp listenHp _) = do
-  targetAddr <- resolveAddr targetHp
-  relVarAcquire rv $ do
-    conn <- udpServerConn Nothing listenHp
-    pure (OscConn targetAddr conn)
+  backendInit (DirtBackend targetHp listenHp _) logger getPlayingSTM rv = do
+    targetAddr <- resolveAddr targetHp
+    let acqOscConn = fmap (OscConn targetAddr) (udpServerConn Nothing listenHp)
+    oscConn <- relVarAcquire rv acqOscConn
+    eventQueue <- liftIO newTQueueIO
+    let send pw = do
+          case attrsConvert dirtAliases pw of
+            Left err -> logError logger ("Failed to convert event: " <> err)
+            Right attrs -> sendPacket oscConn (playPacket attrs)
+        acqSendTask = acquireAwait pwRealStart getPlayingSTM eventQueue send
+    sendTask <- relVarAcquire rv acqSendTask
+    pure (DirtData oscConn eventQueue sendTask)
 
-dirtSend :: LogAction -> ((OscConn -> IO ()) -> IO ()) -> Timed Attrs -> IO ()
-dirtSend _ wd = sendPacket' wd . playPacket . timedVal
+  backendSend _ _ cb evs = runCallback cb (atomically . for_ evs . writeTQueue . ddEventQueue)
 
-dirtImpl :: Impl DirtEnv OscConn
-dirtImpl = Impl dirtInit dirtSend
+  backendClear _ _ cb = runCallback cb (atomically . void . flushTQueue . ddEventQueue)
 
-sendPacket' :: ((OscConn -> IO ()) -> IO ()) -> Packet -> IO ()
-sendPacket' wd packet = wd $ \(OscConn targetAddr (Conn _ enc)) ->
-  runEncoder enc targetAddr packet
+  -- TODO really check
+  backendCheck _ _ _ = pure True
 
-sendPacket :: DirtSt -> Packet -> IO ()
-sendPacket = sendPacket' . withData
+sendPacketSt :: DirtSt -> Packet -> IO ()
+sendPacketSt st p = useCallback st (\dd -> sendPacket (ddOscConn dd) p)
 
-recvPacket :: DirtSt -> IO (Either SomeException Packet)
-recvPacket st = withData st $ \(OscConn _ (Conn dec _)) ->
-  withTimeout (deOscTimeout (envImpl (stEnv st))) $
-    runDecoder dec >>= either throwIO pure . snd
+recvPacketSt :: DirtSt -> IO (Either SomeException Packet)
+recvPacketSt st = useCallback st (recvPacket (dbOscTimeout (stBackend st)) . ddOscConn)
 
 -- | Handshake with SuperDirt
 -- On success set playing true; on error false
@@ -82,8 +107,8 @@ handshake st = bracket acq rel (const (pure ()))
   logger = stLogger st
   acq = do
     logInfo logger "Handshaking ..."
-    sendPacket st handshakePacket
-    recvPacket st
+    sendPacketSt st handshakePacket
+    recvPacketSt st
   rel resp = do
     let ok = isRight resp
     if ok
@@ -107,3 +132,36 @@ handshakeAddr = "/dirt/handshake"
 
 handshakePacket :: Packet
 handshakePacket = PacketMsg (Msg handshakeAddr Empty)
+
+-- Useful params:
+-- sound - string, req - name of sound
+-- orbit - int, opt - index of orbit
+-- cps - float, given - current cps
+-- cycle - float, given - event start in cycle time
+-- delta - float, given - microsecond length of event
+-- TODO add more aliases for params
+dirtAliases :: [(Text, Text)]
+dirtAliases =
+  [ ("lpf", "cutoff")
+  , ("lpq", "resonance")
+  , ("hpf", "hcutoff")
+  , ("hpq", "hresonance")
+  , ("bpf", "bandf")
+  , ("bpq", "bandq")
+  , ("res", "resonance")
+  , ("midi", "midinote")
+  , ("n", "note")
+  , ("oct", "octave")
+  , ("accel", "accelerate")
+  , ("leg", "legato")
+  , ("delayt", "delaytime")
+  , ("delayfb", "delayfeedback")
+  , ("phasr", "phaserrate")
+  , ("phasdp", "phaserdepth")
+  , ("tremr", "tremolorate")
+  , ("tremdp", "tremolodepth")
+  , ("dist", "distort")
+  , ("o", "orbit")
+  , ("ts", "timescale")
+  , ("s", "sound")
+  ]
diff --git a/minipat-live/src/Minipat/Live/Attrs.hs b/minipat-live/src/Minipat/Live/Attrs.hs
index 3a65dec..362e3b3 100644
--- a/minipat-live/src/Minipat/Live/Attrs.hs
+++ b/minipat-live/src/Minipat/Live/Attrs.hs
@@ -108,10 +108,10 @@ class (Semigroup q) => Squishy q a where
 squishMerge :: (Squishy q a, Squishy q b) => a -> b -> q
 squishMerge a b = squish a <> squish b
 
-instance (Semigroup q) => Squishy q q where
+instance {-# OVERLAPPABLE #-} (Semigroup q) => Squishy q q where
   squish = id
 
-instance (Monoid q, Squishy q a) => Squishy q (Maybe a) where
+instance {-# INCOHERENT #-} (Monoid q, Squishy q a) => Squishy q (Maybe a) where
   squish = maybe mempty squish
 
 instance (IsDatum a) => Squishy Attrs (Attr a) where
diff --git a/minipat-live/src/Minipat/Live/Boot.hs b/minipat-live/src/Minipat/Live/Boot.hs
index 5bb64e2..c07df06 100644
--- a/minipat-live/src/Minipat/Live/Boot.hs
+++ b/minipat-live/src/Minipat/Live/Boot.hs
@@ -2,14 +2,12 @@
 module Minipat.Live.Boot
   ( LiveSt (..)
   , dispose
-  , getDebug
   , getCps
   , getAhead
   , getPlaying
   , getStream
   , getCycle
   , getTempo
-  , setDebug
   , setCps
   , setPlaying
   , setCycle
@@ -39,25 +37,24 @@ where
 
 import Data.Kind (Type)
 import Minipat.EStream (EStream)
-import Minipat.Live.Attrs (Attrs, Squishy (..))
+import Minipat.Live.Attrs (Squishy (..))
 import Minipat.Live.Combinators
 import Minipat.Live.Core qualified as C
 import Minipat.Live.Params
+import Minipat.Live.Play (WithOrbit)
 import Minipat.Stream (Stream)
 import Nanotime (TimeDelta)
 import Prettyprinter (Pretty)
 
-class LiveSt where
-  type LiveEnv :: Type
-  type LiveData :: Type
-  liveSt :: C.St LiveEnv LiveData
+class (C.Backend LiveBackend) => LiveSt where
+  type LiveBackend :: Type
+  liveSt :: C.St LiveBackend
+
+type LiveAttrs = C.BackendAttrs LiveBackend
 
 dispose :: (LiveSt) => IO ()
 dispose = C.disposeSt liveSt
 
-getDebug :: (LiveSt) => IO Bool
-getDebug = C.getDebug liveSt
-
 getCps :: (LiveSt) => IO Rational
 getCps = C.getCps liveSt
 
@@ -67,7 +64,7 @@ getAhead = C.getAhead liveSt
 getPlaying :: (LiveSt) => IO Bool
 getPlaying = C.getPlaying liveSt
 
-getStream :: (LiveSt) => IO (Stream Attrs)
+getStream :: (LiveSt) => IO (Stream (WithOrbit LiveAttrs))
 getStream = C.getStream liveSt
 
 getCycle :: (LiveSt) => IO Integer
@@ -76,9 +73,6 @@ getCycle = C.getCycle liveSt
 getTempo :: (LiveSt) => IO Rational
 getTempo = C.getTempo liveSt
 
-setDebug :: (LiveSt) => Bool -> IO ()
-setDebug = C.setDebug liveSt
-
 setCps :: (LiveSt) => Rational -> IO ()
 setCps = C.setCps liveSt
 
@@ -91,7 +85,7 @@ setCycle = C.setCycle liveSt
 setTempo :: (LiveSt) => Rational -> IO ()
 setTempo = C.setTempo liveSt
 
-setOrbit :: (LiveSt, Squishy Attrs a) => Integer -> EStream a -> IO ()
+setOrbit :: (LiveSt, Squishy LiveAttrs a) => Integer -> EStream a -> IO ()
 setOrbit = C.setOrbit liveSt
 
 clearOrbit :: (LiveSt) => Integer -> IO ()
@@ -119,10 +113,10 @@ checkTasks = C.checkTasks liveSt
 peek :: (LiveSt, Pretty a) => EStream a -> IO ()
 peek = C.peek liveSt
 
-d :: (LiveSt, Squishy Attrs a) => Integer -> EStream a -> IO ()
+d :: (LiveSt, Squishy LiveAttrs a) => Integer -> EStream a -> IO ()
 d = setOrbit
 
-d0, d1, d2, d3, d4, d5, d6, d7 :: (LiveSt, Squishy Attrs a) => EStream a -> IO ()
+d0, d1, d2, d3, d4, d5, d6, d7 :: (LiveSt, Squishy LiveAttrs a) => EStream a -> IO ()
 d0 = d 0
 d1 = d 1
 d2 = d 2
diff --git a/minipat-live/src/Minipat/Live/Core.hs b/minipat-live/src/Minipat/Live/Core.hs
index dc08f9c..baff054 100644
--- a/minipat-live/src/Minipat/Live/Core.hs
+++ b/minipat-live/src/Minipat/Live/Core.hs
@@ -3,28 +3,28 @@
 module Minipat.Live.Core
   ( Env (..)
   , defaultEnv
-  , ImplInit
-  , ImplSend
-  , Impl (..)
+  , Callback (..)
+  , Backend (..)
   , St
   , stLogger
   , stEnv
+  , stBackend
   , initAsyncSt
   , disposeSt
-  , withData
-  , getDebug
+  , useCallback
   , getCps
   , getAhead
   , getPlaying
   , getStream
   , getCycle
+  , getCycleArc
   , getTempo
-  , setDebug
   , setCps
   , setPlaying
   , setCycle
   , setTempo
   , setOrbit
+  , setOrbit'
   , clearOrbit
   , clearAllOrbits
   , hush
@@ -38,16 +38,15 @@ module Minipat.Live.Core
 where
 
 import Control.Concurrent.Async (Async, poll)
-import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, tryTakeMVar, withMVar)
+import Control.Concurrent.MVar (MVar, modifyMVarMasked_, modifyMVar_, newMVar, withMVar)
 import Control.Concurrent.STM (STM, atomically)
-import Control.Concurrent.STM.TQueue (TQueue, flushTQueue, newTQueueIO, writeTQueue)
 import Control.Concurrent.STM.TVar (TVar, modifyTVar', newTVarIO, readTVar, readTVarIO, stateTVar, writeTVar)
-import Control.Exception (Exception (..), mask_)
-import Control.Monad (unless, void, when)
-import Dahdit.Midi.Osc (Datum (..))
+import Control.Exception (Exception (..), throwIO)
+import Control.Monad (unless, when)
 import Data.Acquire (Acquire)
-import Data.Foldable (foldl', for_)
-import Data.IORef (modifyIORef', newIORef, readIORef)
+import Data.Foldable (foldl')
+import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef)
+import Data.Kind (Type)
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
 import Data.Ratio ((%))
@@ -56,235 +55,233 @@ import Data.Sequence qualified as Seq
 import Data.Text (Text)
 import Data.Text qualified as T
 import Minipat.EStream (EStream (..))
-import Minipat.Live.Attrs (Attrs, Squishy (..), attrsDefault)
+import Minipat.Live.Attrs (Squishy (..))
 import Minipat.Live.Logger (LogAction, logDebug, logError, logInfo, logWarn, nullLogger)
-import Minipat.Live.Play (PlayEnv (..), PlayErr, playTape)
-import Minipat.Live.Resources (RelVar, Timed (..), acquireAwait, acquireLoop, relVarAcquire, relVarDispose, relVarUse)
-import Minipat.Print (prettyPrint, prettyPrintAll, prettyShow, prettyShowAll)
+import Minipat.Live.Play (PlayEnv (..), PlayErr, WithOrbit (..), WithPlayMeta, playTape)
+import Minipat.Live.Resources (RelVar, acquireLoop, relVarAcquire, relVarDispose, relVarUse)
+import Minipat.Print (prettyShow, prettyShowAll)
 import Minipat.Stream (Stream, streamRun, tapeToList)
-import Minipat.Time (Arc (..), Cycle (..), CycleTime (..), bpmToCps, cpsToBpm)
+import Minipat.Time (Arc (..), CycleArc, CycleTime (..), bpmToCps, cpsToBpm)
 import Nanotime
   ( PosixTime
   , TimeDelta
   , addTime
+  , currentTime
   , timeDeltaFromFracSecs
   )
 import Prettyprinter (Pretty)
 
 -- * Environment
 
-data CommonEnv = CommonEnv
-  { ceDebug :: !Bool
-  , ceCps :: !Rational
-  , ceGpc :: !Integer
+data Env = Env
+  { envCps :: !Rational
+  , envGpc :: !Integer
   }
   deriving stock (Eq, Ord, Show)
 
-defaultCommonEnv :: CommonEnv
-defaultCommonEnv =
-  CommonEnv
-    { ceDebug = False
-    , ceCps = 1 % 2 -- 120 bpm, 4 bpc
-    , ceGpc = 1 -- Number of gens per cycle
+defaultEnv :: Env
+defaultEnv =
+  Env
+    { envCps = 1 % 2 -- 120 bpm, 4 bpc
+    , envGpc = 16 -- Number of gens per cycle
     }
 
-data Env i = Env
-  { envCommon :: !CommonEnv
-  , envImpl :: !i
-  }
-  deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)
+-- * Callback
 
-defaultEnv :: i -> Env i
-defaultEnv = Env defaultCommonEnv
+newtype Callback d = Callback {runCallback :: forall r. (d -> IO r) -> IO r}
+  deriving stock (Functor)
 
--- * Impl
+-- * Backend
 
-type ImplInit i d = LogAction -> RelVar -> i -> IO d
+class Backend i where
+  type BackendData i :: Type
+  type BackendAttrs i :: Type
 
-type ImplSend d = LogAction -> ((d -> IO ()) -> IO ()) -> Timed Attrs -> IO ()
+  backendInit
+    :: i
+    -> LogAction
+    -> STM Bool
+    -> RelVar
+    -> IO (BackendData i)
 
-data Impl i d = Impl
-  { implInit :: !(ImplInit i d)
-  , implSend :: !(ImplSend d)
-  }
+  backendSend
+    :: i
+    -> LogAction
+    -> Callback (BackendData i)
+    -> Seq (WithPlayMeta (BackendAttrs i))
+    -> IO ()
+
+  backendClear
+    :: i
+    -> LogAction
+    -> Callback (BackendData i)
+    -> IO ()
+
+  backendCheck
+    :: i
+    -> LogAction
+    -> Callback (BackendData i)
+    -> IO Bool
+
+data UninitErr = UninitErr
+  deriving stock (Eq, Ord, Show)
+
+instance Exception UninitErr
 
 -- * State
 
-data Domain = Domain
-  { domDebug :: !(TVar Bool)
-  , domCps :: !(TVar Rational)
+data Domain q = Domain
+  { domCps :: !(TVar Rational)
   , domGpc :: !(TVar Integer)
-  , domAhead :: !(TVar TimeDelta)
   , domPlaying :: !(TVar Bool)
   , domGenCycle :: !(TVar Integer)
   , domAbsGenCycle :: !(TVar Integer)
-  , domOrbits :: !(TVar (Map Integer (Stream Attrs)))
-  , domStream :: !(TVar (Stream Attrs))
-  , domEvents :: !(TQueue (Timed Attrs))
+  , domOrbits :: !(TVar (Map Integer (Stream q)))
+  , domStream :: !(TVar (Stream (WithOrbit q)))
   }
 
-newDomain :: IO Domain
+newDomain :: IO (Domain q)
 newDomain =
   Domain
-    <$> newTVarIO False
-    <*> newTVarIO 0
-    <*> newTVarIO 0
+    <$> newTVarIO 0
     <*> newTVarIO 0
     <*> newTVarIO False
     <*> newTVarIO 0
     <*> newTVarIO 0
     <*> newTVarIO mempty
     <*> newTVarIO mempty
-    <*> newTQueueIO
 
-initDomain :: CommonEnv -> IO Domain
-initDomain ce = newDomain >>= \d -> d <$ reinitDomain ce d
+initDomain :: Env -> IO (Domain q)
+initDomain env = newDomain >>= \d -> d <$ reinitDomain env d
 
-reinitDomain :: CommonEnv -> Domain -> IO ()
-reinitDomain ce dom = atomically $ do
-  let cps = ceCps ce
-      gpc = ceGpc ce
-      ahead = timeDeltaFromFracSecs (1 / (cps * fromInteger gpc))
-  writeTVar (domDebug dom) (ceDebug ce)
+reinitDomain :: Env -> Domain q -> IO ()
+reinitDomain (Env cps gpc) dom = atomically $ do
   writeTVar (domCps dom) cps
   writeTVar (domGpc dom) gpc
-  writeTVar (domAhead dom) ahead
   writeTVar (domPlaying dom) False
   writeTVar (domGenCycle dom) 0
   writeTVar (domAbsGenCycle dom) 0
   writeTVar (domOrbits dom) mempty
   writeTVar (domStream dom) mempty
-  clearEventsSTM dom
-
-data Tasks = Tasks
-  { taskGen :: !(Async ())
-  , taskSend :: !(Async ())
-  }
 
 data Resources d = Resources
   { resRel :: !RelVar
-  , resTasks :: !(Maybe Tasks)
+  , resGenTask :: !(Maybe (Async ()))
   , resData :: !d
   }
 
-data St i d = St
+data St i = St
   { stLogger :: !LogAction
-  , stImpl :: !(Impl i d)
-  , stEnv :: !(Env i)
-  , stDom :: !Domain
-  , stRes :: !(MVar (Resources d))
+  , stBackend :: !i
+  , stEnv :: !Env
+  , stDom :: !(Domain (BackendAttrs i))
+  , stRes :: !(MVar (Maybe (Resources (BackendData i))))
   }
 
-newSt :: LogAction -> Impl i d -> Env i -> IO (St i d)
-newSt logger impl env = St logger impl env <$> initDomain (envCommon env) <*> newEmptyMVar
+newSt :: LogAction -> i -> Env -> IO (St i)
+newSt logger be env = St logger be env <$> initDomain env <*> newMVar Nothing
 
-initRes :: Bool -> St i d -> IO ()
+initRes :: (Backend i) => Bool -> St i -> IO ()
 initRes isSync st = do
   disposeSt st
   relVarUse $ \rv -> do
-    dat <- implInit (stImpl st) (stLogger st) rv (envImpl (stEnv st))
-    tasks <-
+    let getPlayingSTM = readTVar (domPlaying (stDom st))
+    dat <- backendInit (stBackend st) (stLogger st) getPlayingSTM rv
+    genTask <-
       if isSync
         then pure Nothing
         else do
-          genTask <- relVarAcquire rv (acqGenTask st)
-          sendTask <- relVarAcquire rv (acqSendTask st)
-          pure (Just (Tasks genTask sendTask))
-    putMVar (stRes st) (Resources rv tasks dat)
+          now <- currentTime
+          fmap Just (relVarAcquire rv (acqGenTask st now))
+    modifyMVar_ (stRes st) (const (pure (Just (Resources rv genTask dat))))
 
-initSt :: Bool -> LogAction -> Impl i d -> Env i -> IO (St i d)
-initSt isSync logger impl env = newSt logger impl env >>= \st -> st <$ initRes isSync st
+initSt :: (Backend i) => Bool -> LogAction -> i -> Env -> IO (St i)
+initSt isSync logger be env = newSt logger be env >>= \st -> st <$ initRes isSync st
 
-initAsyncSt :: LogAction -> Impl i d -> Env i -> IO (St i d)
+initAsyncSt :: (Backend i) => LogAction -> i -> Env -> IO (St i)
 initAsyncSt = initSt False
 
-initSyncSt :: LogAction -> Impl i d -> Env i -> IO (St i d)
+initSyncSt :: (Backend i) => LogAction -> i -> Env -> IO (St i)
 initSyncSt = initSt True
 
-stepGenSt :: St i d -> PosixTime -> IO (CycleTime, PosixTime)
+stepGenSt
+  :: St i
+  -> PosixTime
+  -> IO (CycleTime, PosixTime, Seq (WithPlayMeta (BackendAttrs i)))
 stepGenSt st now = do
-  let dom = stDom st
-  doGen (stLogger st) dom now
-  (nextCycTime, ahead) <- atomically $ do
-    nextCycTime <- getCycleTimeSTM dom
-    ahead <- readTVar (domAhead dom)
-    pure (nextCycTime, ahead)
-  let nextNow = addTime now ahead
-  pure (nextCycTime, nextNow)
-
-stepSendSt :: St i d -> IO ()
-stepSendSt st = do
-  let dom = stDom st
-      wd = withData st
-      send = implSend (stImpl st) (stLogger st) wd
-  events <- atomically (flushTQueue (domEvents dom))
-  for_ events send
-
-disposeSt :: St i d -> IO ()
-disposeSt st = mask_ (tryTakeMVar (stRes st) >>= maybe (pure ()) (relVarDispose . resRel))
-
-withData :: St i d -> (d -> IO a) -> IO a
-withData st f = withMVar (stRes st) (f . resData)
+  (penv, mresult) <- atomically (genAndAdvanceSTM (stDom st) now)
+  let cycleBounds = peCycleBounds penv
+  events <- case mresult of
+    Nothing -> pure Empty
+    Just eresult -> case eresult of
+      Left err -> Empty <$ logError (stLogger st) ("Error @ " <> prettyShow cycleBounds <> "\n" <> T.pack (displayException err))
+      Right events -> pure events
+  let nextCycTime = arcEnd cycleBounds
+      nextRealTime = peRealOrigin penv
+  pure (nextCycTime, nextRealTime, events)
+
+stepSendSt :: (Backend i) => St i -> Seq (WithPlayMeta (BackendAttrs i)) -> IO ()
+stepSendSt st = backendSend (stBackend st) (stLogger st) (mkCallback st)
+
+disposeSt :: St i -> IO ()
+disposeSt st = modifyMVarMasked_ (stRes st) $ \case
+  Nothing -> pure Nothing
+  Just res -> Nothing <$ relVarDispose (resRel res)
+
+mkCallback :: St i -> Callback (BackendData i)
+mkCallback st = Callback (useCallback st)
+
+useCallback :: St i -> (BackendData i -> IO r) -> IO r
+useCallback st f = withMVar (stRes st) (maybe (throwIO UninitErr) (f . resData))
 
 -- * Getters
 
-getDebug :: St i d -> IO Bool
-getDebug = readTVarIO . domDebug . stDom
-
-getCps :: St i d -> IO Rational
+getCps :: St i -> IO Rational
 getCps = readTVarIO . domCps . stDom
 
-getGpc :: St i d -> IO Integer
+getGpc :: St i -> IO Integer
 getGpc = readTVarIO . domGpc . stDom
 
-getAhead :: St i d -> IO TimeDelta
-getAhead = readTVarIO . domAhead . stDom
+getAhead :: St i -> IO TimeDelta
+getAhead = atomically . getAheadSTM . stDom
 
-getPlaying :: St i d -> IO Bool
+getPlaying :: St i -> IO Bool
 getPlaying = readTVarIO . domPlaying . stDom
 
-getStream :: St i d -> IO (Stream Attrs)
+getStream :: St i -> IO (Stream (WithOrbit (BackendAttrs i)))
 getStream = readTVarIO . domStream . stDom
 
-getGenCycle :: St i d -> IO Integer
+getGenCycle :: St i -> IO Integer
 getGenCycle = readTVarIO . domGenCycle . stDom
 
-getAbsGenCycle :: St i d -> IO Integer
+getAbsGenCycle :: St i -> IO Integer
 getAbsGenCycle = readTVarIO . domAbsGenCycle . stDom
 
-getCycle :: St i d -> IO Integer
+getCycle :: St i -> IO Integer
 getCycle st = atomically $ do
   let dom = stDom st
   gpc <- readTVar (domGpc dom)
   gcyc <- readTVar (domGenCycle dom)
   pure (div gcyc gpc)
 
-getCycleTime :: St i d -> IO CycleTime
-getCycleTime = atomically . getCycleTimeSTM . stDom
+getCycleArc :: St i -> IO CycleArc
+getCycleArc = atomically . getCycleArcSTM . stDom
 
-getTempo :: St i d -> IO Rational
+getTempo :: St i -> IO Rational
 getTempo = fmap (cpsToBpm 4) . getCps
 
 -- * Setters
 
-setDebug :: St i d -> Bool -> IO ()
-setDebug st = atomically . writeTVar (domDebug (stDom st))
-
-setTempo :: St i d -> Rational -> IO ()
+setTempo :: St i -> Rational -> IO ()
 setTempo st = setCps st . bpmToCps 4
 
-setCps :: St i d -> Rational -> IO ()
-setCps st cps' = atomically $ do
-  let dom = stDom st
-  gpc <- readTVar (domGpc dom)
-  let ahead' = timeDeltaFromFracSecs (1 / (cps' * fromInteger gpc))
-  writeTVar (domCps dom) cps'
-  writeTVar (domAhead dom) ahead'
+setCps :: St i -> Rational -> IO ()
+setCps st = atomically . writeTVar (domCps (stDom st))
 
-setPlaying :: St i d -> Bool -> IO ()
+setPlaying :: St i -> Bool -> IO ()
 setPlaying st x = atomically (writeTVar (domPlaying (stDom st)) x)
 
-setCycle :: St i d -> Integer -> IO ()
+setCycle :: St i -> Integer -> IO ()
 setCycle st x = atomically $ do
   let dom = stDom st
   gpc <- readTVar (domGpc dom)
@@ -292,98 +289,112 @@ setCycle st x = atomically $ do
   let y = x * gpc + mod gcyc gpc
   writeTVar (domGenCycle (stDom st)) y
 
-updateOrbits :: St i d -> (Map Integer (Stream Attrs) -> Map Integer (Stream Attrs)) -> IO ()
+updateOrbits :: St i -> (Map Integer (Stream (BackendAttrs i)) -> Map Integer (Stream (BackendAttrs i))) -> IO ()
 updateOrbits st f = atomically $ do
   let dom = stDom st
-      addOrbit = attrsDefault "orbit" . DatumInt32 . fromInteger
   m' <- stateTVar (domOrbits dom) (\m -> let m' = f m in (m', m'))
-  let z = foldl' (\x (o, y) -> x <> fmap (addOrbit o) y) mempty (Map.toList m')
+  let z = foldl' (\x (o, y) -> x <> fmap (WithOrbit o) y) mempty (Map.toList m')
   writeTVar (domStream dom) z
 
-setOrbit :: (Squishy Attrs a) => St i d -> Integer -> EStream a -> IO ()
+setOrbit :: (Squishy (BackendAttrs i) a) => St i -> Integer -> EStream a -> IO ()
 setOrbit st o es =
   case unEStream es of
-    Left e -> putStrLn (displayException e)
-    Right s -> updateOrbits st (Map.insert o (fmap squish s))
+    Left e -> logError (stLogger st) (T.pack (displayException e))
+    Right s -> setOrbit' st o s
+
+setOrbit' :: (Squishy (BackendAttrs i) a) => St i -> Integer -> Stream a -> IO ()
+setOrbit' st o s = updateOrbits st (Map.insert o (fmap squish s))
 
-clearOrbit :: St i d -> Integer -> IO ()
+clearOrbit :: St i -> Integer -> IO ()
 clearOrbit st o = updateOrbits st (Map.delete o)
 
-clearAllOrbits :: St i d -> IO ()
+clearAllOrbits :: St i -> IO ()
 clearAllOrbits st = atomically (clearAllOrbitsSTM (stDom st))
 
+clearEvents :: (Backend i) => St i -> IO ()
+clearEvents st = backendClear (stBackend st) (stLogger st) (mkCallback st)
+
 -- * Other actions
 
-hush :: St i d -> IO ()
-hush st = atomically $ do
-  let dom = stDom st
-  clearAllOrbitsSTM dom
-  clearEventsSTM dom
+hush :: (Backend i) => St i -> IO ()
+hush st = do
+  atomically (clearAllOrbitsSTM (stDom st))
+  clearEvents st
 
-panic :: St i d -> IO ()
-panic st = atomically $ do
-  let dom = stDom st
-  clearAllOrbitsSTM dom
-  clearEventsSTM dom
-  writeTVar (domPlaying dom) False
+panic :: (Backend i) => St i -> IO ()
+panic st = do
+  atomically $ do
+    let dom = stDom st
+    clearAllOrbitsSTM dom
+    writeTVar (domPlaying dom) False
+  clearEvents st
 
-peek :: (Pretty a) => St i d -> EStream a -> IO ()
+peek :: (Pretty a) => St i -> EStream a -> IO ()
 peek st es =
-  case unEStream es of
-    Left e -> putStrLn (displayException e)
-    Right s -> do
-      cyc <- fmap fromIntegral (getCycle st)
-      let arc = Arc cyc (cyc + 1)
-          evs = tapeToList (streamRun s arc)
-      prettyPrint arc
-      prettyPrintAll "\n" evs
+  let logger = stLogger st
+  in  case unEStream es of
+        Left e -> logError logger (T.pack (displayException e))
+        Right s -> do
+          cyc <- fmap fromIntegral (getCycle st)
+          let arc = Arc cyc (cyc + 1)
+              evs = tapeToList (streamRun s arc)
+          logInfo logger (prettyShow arc <> "\n" <> prettyShowAll "\n" evs)
 
 -- * Recording
 
-nullImpl :: Impl () ()
-nullImpl =
-  Impl
-    { implInit = \_ _ _ -> pure ()
-    , implSend = \_ _ _ -> pure ()
-    }
+data RecordBackend (q :: Type) = RecordBackend
+  deriving stock (Eq, Ord, Show)
+
+newtype RecordData q = RecordData {unRecordData :: IORef (Seq (WithPlayMeta q))}
+
+newRecordData :: IO (RecordData q)
+newRecordData = fmap RecordData (newIORef Empty)
+
+flushRecordData :: RecordData q -> IO (Seq (WithPlayMeta q))
+flushRecordData (RecordData r) = atomicModifyIORef' r (Empty,)
+
+instance Backend (RecordBackend q) where
+  type BackendData (RecordBackend q) = RecordData q
+  type BackendAttrs (RecordBackend q) = q
+
+  backendInit _ _ _ _ = newRecordData
+  backendSend _ _ cb vs = runCallback cb (\(RecordData r) -> modifyIORef' r (<> vs))
+  backendClear _ _ cb = runCallback cb (\(RecordData r) -> modifyIORef' r (const Empty))
+  backendCheck _ _ _ = pure True
 
 stepRecord
-  :: CommonEnv
-  -> Cycle
-  -> Cycle
+  :: Env
+  -> Integer
+  -> Integer
   -> PosixTime
-  -> (CycleTime -> PosixTime -> St () () -> IO ())
-  -> (CycleTime -> PosixTime -> Seq (Timed Attrs) -> IO ())
+  -> (CycleTime -> PosixTime -> St (RecordBackend a) -> IO ())
+  -> (CycleTime -> PosixTime -> Seq (WithPlayMeta a) -> IO ())
   -> IO PosixTime
-stepRecord ce start end now0 onEnter onLeave = go
+stepRecord env start end now0 onEnter onLeave = go
  where
   go = do
-    let env = Env ce ()
-    st <- initSyncSt nullLogger nullImpl env
-    setCycle st (unCycle start)
+    st <- initSyncSt nullLogger RecordBackend env
+    setCycle st start
     setPlaying st True
-    loop (fromInteger (unCycle end)) st now0
-  flush = fmap Seq.fromList . atomically . flushTQueue . domEvents . stDom
+    loop (fromInteger end) st now0
   loop cycEnd st !realNow = do
-    cycNow <- getCycleTime st
-    if cycNow >= cycEnd
-      then pure realNow
-      else do
-        onEnter cycNow realNow st
-        (_, realNext) <- stepGenSt st realNow
-        events <- flush st
-        onLeave cycNow realNow events
-        loop cycEnd st realNext
+    Arc cycNow _ <- getCycleArc st
+    onEnter cycNow realNow st
+    (cycNext, realNext, events) <- stepGenSt st realNow
+    onLeave cycNow realNow events
+    if cycNext >= cycEnd
+      then pure realNext
+      else loop cycEnd st realNext
 
 mergeRecord
-  :: CommonEnv
-  -> Cycle
-  -> Cycle
+  :: Env
+  -> Integer
+  -> Integer
   -> PosixTime
-  -> (St () () -> IO ())
-  -> IO (Seq (Timed Attrs), PosixTime)
+  -> (St (RecordBackend a) -> IO ())
+  -> IO (Seq (WithPlayMeta a), PosixTime)
 mergeRecord ce start end now0 onInit = do
-  let cycStart = fromInteger (unCycle start)
+  let cycStart = fromInteger start
   r <- newIORef Empty
   realEnd <-
     stepRecord
@@ -397,27 +408,31 @@ mergeRecord ce start end now0 onInit = do
   pure (tas, realEnd)
 
 simpleRecord
-  :: (St () () -> IO ())
-  -> IO (Seq (Timed Attrs))
-simpleRecord = fmap fst . mergeRecord defaultCommonEnv 0 1 0
+  :: (St (RecordBackend a) -> IO ())
+  -> IO (Seq (WithPlayMeta a))
+simpleRecord = fmap fst . mergeRecord defaultEnv 0 1 0
 
 -- Helpers
 
-getCycleTimeSTM :: Domain -> STM CycleTime
-getCycleTimeSTM dom = do
+getCycleArcSTM :: Domain q -> STM CycleArc
+getCycleArcSTM dom = do
   gpc <- readTVar (domGpc dom)
   gcyc <- readTVar (domGenCycle dom)
-  pure (CycleTime (gcyc % gpc))
+  let start = CycleTime (gcyc % gpc)
+      end = CycleTime ((gcyc + 1) % gpc)
+  pure (Arc start end)
+
+getRealOriginSTM :: Domain q -> PosixTime -> STM PosixTime
+getRealOriginSTM dom now = do
+  ahead <- getAheadSTM dom
+  pure (addTime now ahead)
 
-clearAllOrbitsSTM :: Domain -> STM ()
+clearAllOrbitsSTM :: Domain q -> STM ()
 clearAllOrbitsSTM dom = do
   writeTVar (domOrbits dom) mempty
   writeTVar (domStream dom) mempty
 
-clearEventsSTM :: Domain -> STM ()
-clearEventsSTM dom = void (flushTQueue (domEvents dom))
-
-advanceCycleSTM :: Domain -> STM ()
+advanceCycleSTM :: Domain q -> STM ()
 advanceCycleSTM dom = do
   modifyTVar' (domGenCycle dom) (+ 1)
   modifyTVar' (domAbsGenCycle dom) (+ 1)
@@ -432,72 +447,58 @@ logAsyncState logger name task = do
         Left e -> logError logger ("Task " <> name <> " failed:\n" <> T.pack (displayException e))
         Right _ -> logWarn logger ("Task " <> name <> " not running")
 
-checkTasks :: St i d -> IO ()
+checkTasks :: St i -> IO ()
 checkTasks st =
-  withMVar (stRes st) $ \res ->
-    let logger = stLogger st
-    in  case resTasks res of
-          Nothing -> logInfo logger "No tasks running"
-          Just tasks -> do
-            logAsyncState logger "gen" (taskGen tasks)
-            logAsyncState logger "send" (taskSend tasks)
-
-logEvents :: (Pretty a) => LogAction -> Domain -> Seq (Timed a) -> IO ()
+  let logger = stLogger st
+  in  withMVar (stRes st) $ \case
+        Nothing -> pure ()
+        Just res ->
+          -- TODO check backend
+          case resGenTask res of
+            Nothing -> logInfo logger "No tasks running"
+            Just genTask -> do
+              logAsyncState logger "gen" genTask
+
+logEvents :: (Pretty q) => LogAction -> Domain q -> Seq (WithPlayMeta q) -> IO ()
 logEvents logger dom pevs =
   unless (Seq.null pevs) $ do
-    gpc <- readTVarIO (domGpc dom)
-    gcyc <- readTVarIO (domGenCycle dom)
-    let start = CycleTime (gcyc % gpc)
-        end = CycleTime ((gcyc + 1) % gpc)
-        arc = Arc start end
+    arc <- atomically (getCycleArcSTM dom)
     logDebug logger ("Generated @ " <> prettyShow arc <> "\n" <> prettyShowAll "\n" pevs)
 
-genEventsSTM :: Domain -> PosixTime -> STM (PlayEnv, Either PlayErr (Seq (Timed Attrs)))
-genEventsSTM dom now = do
-  ahead <- readTVar (domAhead dom)
+getPlayEnvSTM :: Domain q -> PosixTime -> STM PlayEnv
+getPlayEnvSTM dom now = do
+  realOrigin <- getRealOriginSTM dom now
+  cycleBounds <- getCycleArcSTM dom
   cps <- readTVar (domCps dom)
-  gpc <- readTVar (domGpc dom)
-  gcyc <- readTVar (domGenCycle dom)
-  let start = CycleTime (gcyc % gpc)
-      end = CycleTime ((gcyc + 1) % gpc)
-      arc = Arc start end
-  stream <- readTVar (domStream dom)
-  let tape = streamRun stream arc
-      origin = addTime now ahead
-      penv = PlayEnv origin start cps
-      mpevs = playTape penv tape
-  pure (penv, mpevs)
-
-doGen :: LogAction -> Domain -> PosixTime -> IO ()
-doGen logger dom now = do
-  mr <- atomically $ do
-    playing <- readTVar (domPlaying dom)
+  pure (PlayEnv realOrigin cycleBounds cps)
+
+genAndAdvanceSTM :: Domain q -> PosixTime -> STM (PlayEnv, Maybe (Either PlayErr (Seq (WithPlayMeta q))))
+genAndAdvanceSTM dom now = do
+  penv <- getPlayEnvSTM dom now
+  playing <- readTVar (domPlaying dom)
+  mresult <-
     if playing
-      then fmap Just (genEventsSTM dom now)
+      then do
+        stream <- readTVar (domStream dom)
+        let arc = peCycleBounds penv
+            tape = streamRun stream arc
+            result = playTape penv tape
+        advanceCycleSTM dom
+        pure (Just result)
       else pure Nothing
-  case mr of
-    Nothing -> pure ()
-    Just (_, mpevs) ->
-      case mpevs of
-        Left err -> logError logger (T.pack ("Gen failed: " ++ show err))
-        Right pevs -> do
-          debug <- readTVarIO (domDebug dom)
-          when debug (logEvents logger dom pevs)
-          atomically $ do
-            advanceCycleSTM dom
-            for_ pevs (writeTQueue (domEvents dom))
-
-acqGenTask :: St i d -> Acquire (Async ())
-acqGenTask st =
-  let logger = stLogger st
-      dom = stDom st
-  in  acquireLoop (domAhead dom) (doGen logger dom)
+  pure (penv, mresult)
 
-acqSendTask :: St i d -> Acquire (Async ())
-acqSendTask st =
-  let logger = stLogger st
-      dom = stDom st
-      impl = stImpl st
-      wd = withData st
-      doSend = implSend impl logger wd
-  in  acquireAwait (domPlaying dom) (domEvents dom) doSend
+getAheadSTM :: Domain q -> STM TimeDelta
+getAheadSTM dom = do
+  cps <- readTVar (domCps dom)
+  gpc <- readTVar (domGpc dom)
+  pure (timeDeltaFromFracSecs (1 / (cps * fromInteger gpc)))
+
+runGenTask :: (Backend i) => St i -> PosixTime -> IO PosixTime
+runGenTask st now = do
+  (_, next, events) <- stepGenSt st now
+  stepSendSt st events
+  pure next
+
+acqGenTask :: (Backend i) => St i -> PosixTime -> Acquire (Async ())
+acqGenTask = acquireLoop . runGenTask
diff --git a/minipat-live/src/Minipat/Live/Play.hs b/minipat-live/src/Minipat/Live/Play.hs
index dc32f65..28f8292 100644
--- a/minipat-live/src/Minipat/Live/Play.hs
+++ b/minipat-live/src/Minipat/Live/Play.hs
@@ -2,6 +2,12 @@
 
 module Minipat.Live.Play
   ( PlayErr (..)
+  , PlayMeta (..)
+  , pmCycleLength
+  , pmRealLength
+  , WithOrbit (..)
+  , WithPlayMeta (..)
+  , attrsConvert
   , PlayEnv (..)
   , playEvent
   , playTape
@@ -12,77 +18,93 @@ import Control.Exception (Exception)
 import Control.Monad (foldM)
 import Control.Monad.Except (throwError)
 import Dahdit.Midi.Osc (Datum (..))
+import Data.Functor ((<&>))
 import Data.Sequence (Seq (..))
 import Data.Sequence qualified as Seq
 import Data.Text (Text)
-import Minipat.Live.Attrs (Attrs, Squishy (..), attrsDelete, attrsInsert, attrsLookup)
-import Minipat.Live.Resources (Timed (..))
+import Minipat.Live.Attrs (Attrs, attrsDefault, attrsDelete, attrsInsert, attrsLookup)
 import Minipat.Stream (Ev (..), Tape, tapeToList)
-import Minipat.Time (CycleDelta (..), CycleTime (..), Span, spanCycle, spanDelta)
-import Nanotime (PosixTime (..), TimeDelta (..), addTime, timeDeltaFromFracSecs, timeDeltaToNanos)
+import Minipat.Time
+  ( Arc (..)
+  , CycleArc
+  , CycleDelta (..)
+  , CycleSpan
+  , CycleTime (..)
+  , PosixArc
+  , arcLength
+  , spanActiveStart
+  , spanWholeLength
+  )
+import Nanotime (PosixTime, TimeDelta (..), addTime, timeDeltaFromFracSecs, timeDeltaToNanos)
+import Prettyprinter (Pretty (..))
+import Prettyprinter qualified as P
 
 data PlayErr
-  = PlayErrDupe !Text
-  | PlayErrCont
+  = -- | Error when playing continuous signals
+    PlayErrCont
   deriving stock (Eq, Ord, Show)
 
 instance Exception PlayErr
 
-type M = Either PlayErr
+data PlayMeta = PlayMeta
+  { pmOrbit :: !Integer
+  , pmRealArc :: !PosixArc
+  , pmCycleArc :: !CycleArc
+  , pmCps :: !Rational
+  }
+  deriving stock (Eq, Ord, Show)
+
+instance Pretty PlayMeta where
+  pretty pm = P.hcat [pretty (pmCycleArc pm), " d", pretty (pmOrbit pm)]
+
+pmCycleLength :: PlayMeta -> CycleDelta
+pmCycleLength = arcLength . pmCycleArc
+
+pmRealLength :: PlayMeta -> TimeDelta
+pmRealLength = arcLength . pmRealArc
 
-insertSafe :: Text -> Datum -> Attrs -> M Attrs
-insertSafe k v m =
+data WithOrbit a = WithOrbit !Integer !a
+  deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+instance (Pretty a) => Pretty (WithOrbit a) where
+  pretty (WithOrbit o a) = P.hcat ["d", pretty o, " ", pretty a]
+
+data WithPlayMeta a = WithPlayMeta !PlayMeta !a
+  deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+instance (Pretty a) => Pretty (WithPlayMeta a) where
+  pretty (WithPlayMeta pm a) = P.hsep [pretty pm, pretty a]
+
+attrsConvert :: [(Text, Text)] -> WithPlayMeta Attrs -> Either Text Attrs
+attrsConvert aliases (WithPlayMeta pm attrs) = do
+  let delta = timeDeltaToMicros (pmRealLength pm)
+      cps = realToFrac (pmCps pm)
+      orbit = pmOrbit pm
+  attrsUnalias aliases attrs
+    >>= attrsTryInsert "delta" (DatumFloat delta)
+    >>= attrsTryInsert "cps" (DatumFloat cps)
+    <&> attrsDefault "orbit" (DatumInt32 (fromInteger orbit))
+
+attrsTryInsert :: Text -> Datum -> Attrs -> Either Text Attrs
+attrsTryInsert k v m =
   case attrsLookup k m of
-    Nothing -> pure (attrsInsert k v m)
-    Just _ -> throwError (PlayErrDupe k)
+    Nothing -> Right (attrsInsert k v m)
+    Just _ -> Left ("Duplicate key: " <> k)
 
-replaceAliases :: [(Text, Text)] -> Attrs -> M Attrs
-replaceAliases as m0 = foldM go m0 as
+attrsUnalias :: [(Text, Text)] -> Attrs -> Either Text Attrs
+attrsUnalias as m0 = foldM go m0 as
  where
   go !m (x, y) = do
     case attrsLookup x m of
       Nothing -> pure m
-      Just v -> insertSafe y v (attrsDelete x m)
-
--- Useful params:
--- sound - string, req - name of sound
--- orbit - int, opt - index of orbit
--- cps - float, given - current cps
--- cycle - float, given - event start in cycle time
--- delta - float, given - microsecond length of event
--- TODO add more aliases for params
-playAliases :: [(Text, Text)]
-playAliases =
-  [ ("lpf", "cutoff")
-  , ("lpq", "resonance")
-  , ("hpf", "hcutoff")
-  , ("hpq", "hresonance")
-  , ("bpf", "bandf")
-  , ("bpq", "bandq")
-  , ("res", "resonance")
-  , ("midi", "midinote")
-  , ("n", "note")
-  , ("oct", "octave")
-  , ("accel", "accelerate")
-  , ("leg", "legato")
-  , ("delayt", "delaytime")
-  , ("delayfb", "delayfeedback")
-  , ("phasr", "phaserrate")
-  , ("phasdp", "phaserdepth")
-  , ("tremr", "tremolorate")
-  , ("tremdp", "tremolodepth")
-  , ("dist", "distort")
-  , ("o", "orbit")
-  , ("ts", "timescale")
-  , ("s", "sound")
-  ]
-
-spanDeltaM :: Span -> M CycleDelta
-spanDeltaM = maybe (throwError PlayErrCont) pure . spanDelta
+      Just v -> attrsTryInsert y v (attrsDelete x m)
+
+spanDeltaM :: CycleSpan -> Either PlayErr CycleDelta
+spanDeltaM = maybe (throwError PlayErrCont) pure . spanWholeLength
 
 data PlayEnv = PlayEnv
-  { peStart :: !PosixTime
-  , peCycle :: !CycleTime
+  { peRealOrigin :: !PosixTime
+  , peCycleBounds :: !CycleArc
   , peCps :: !Rational
   }
   deriving stock (Eq, Ord, Show)
@@ -92,21 +114,26 @@ timeDeltaToMicros td =
   let (_, ns) = timeDeltaToNanos td
   in  fromIntegral ns / 1000
 
-playEvent :: (Squishy Attrs a) => PlayEnv -> Ev a -> M (Maybe (Timed Attrs))
-playEvent (PlayEnv startTime startCyc cps) (Ev sp dat) =
-  case spanCycle sp of
+playEvent
+  :: PlayEnv
+  -> Ev (WithOrbit q)
+  -> Either PlayErr (Maybe (WithPlayMeta q))
+playEvent (PlayEnv realOrigin (Arc cycleOrigin _) cps) (Ev sp (WithOrbit orbit dat)) =
+  case spanActiveStart sp of
     Nothing ->
       -- Only emit start events
-      pure Nothing
-    Just targetCyc -> do
-      let cycOffset = targetCyc - startCyc
-          onset = addTime startTime (timeDeltaFromFracSecs (unCycleTime cycOffset / cps))
-      deltaCyc <- fmap unCycleDelta (spanDeltaM sp)
-      let deltaTime = timeDeltaToMicros (timeDeltaFromFracSecs (deltaCyc / cps))
-      dat' <- replaceAliases playAliases (squish dat)
-      dat'' <- insertSafe "delta" (DatumFloat deltaTime) dat'
-      dat''' <- insertSafe "cps" (DatumFloat (realToFrac cps)) dat''
-      pure (Just (Timed onset dat'''))
+      Right Nothing
+    Just cycleStart -> do
+      let cycleOffset = cycleStart - cycleOrigin
+          realStart = addTime realOrigin (timeDeltaFromFracSecs (unCycleTime cycleOffset / cps))
+      cycleDelta <- spanDeltaM sp
+      let cycleEnd = CycleTime (unCycleTime cycleStart + unCycleDelta cycleDelta)
+          cycleArc = Arc cycleStart cycleEnd
+          realLength = timeDeltaFromFracSecs (unCycleDelta cycleDelta / cps)
+          realEnd = addTime realStart realLength
+          realArc = Arc realStart realEnd
+          pm = PlayMeta orbit realArc cycleArc cps
+      pure (Just (WithPlayMeta pm dat))
 
 traverseMaybe :: (Monad m) => (a -> m (Maybe b)) -> Seq a -> m (Seq b)
 traverseMaybe f = go Empty
@@ -115,5 +142,8 @@ traverseMaybe f = go Empty
     Empty -> pure acc
     a :<| as' -> f a >>= maybe (go acc as') (\b -> go (acc :|> b) as')
 
-playTape :: (Squishy Attrs a) => PlayEnv -> Tape a -> M (Seq (Timed Attrs))
+playTape
+  :: PlayEnv
+  -> Tape (WithOrbit q)
+  -> Either PlayErr (Seq (WithPlayMeta q))
 playTape penv = traverseMaybe (playEvent penv) . Seq.fromList . tapeToList
diff --git a/minipat-live/src/Minipat/Live/Resources.hs b/minipat-live/src/Minipat/Live/Resources.hs
index dd34729..fd4a8e5 100644
--- a/minipat-live/src/Minipat/Live/Resources.hs
+++ b/minipat-live/src/Minipat/Live/Resources.hs
@@ -7,27 +7,21 @@ module Minipat.Live.Resources
   , withRelVar
   , acquireAsync
   , acquireLoop
-  , Timed (..)
   , acquireAwait
+  , threadDelayUntil
   , withTimeout
   )
 where
 
 import Control.Concurrent (forkFinally)
 import Control.Concurrent.Async (Async, async, cancel, waitCatch)
-import Control.Concurrent.STM (atomically, retry)
+import Control.Concurrent.STM (STM, atomically, retry)
 import Control.Concurrent.STM.TQueue (TQueue, peekTQueue, readTQueue, tryPeekTQueue)
-import Control.Concurrent.STM.TVar (TVar, readTVar, readTVarIO)
-import Control.Exception (Exception, SomeException, bracket, mask, onException, throwIO)
-import Control.Monad (unless)
-import Control.Monad.IO.Class (liftIO)
+import Control.Exception (SomeException, bracket, mask, onException)
 import Control.Monad.Trans.Resource (InternalState, closeInternalState, createInternalState)
 import Control.Monad.Trans.Resource.Internal (registerType)
 import Data.Acquire.Internal (Acquire (..), Allocated (..), mkAcquire)
-import Data.IORef (IORef, newIORef, readIORef, writeIORef)
-import Nanotime (PosixTime (..), TimeDelta, awaitDelta, currentTime, diffTime, threadDelayDelta)
-import Prettyprinter (Pretty (..))
-import Prettyprinter qualified as P
+import Nanotime (PosixTime (..), TimeDelta, currentTime, diffTime, threadDelayDelta)
 
 type RelVar = InternalState
 
@@ -54,70 +48,46 @@ withRelVar = bracket relVarInit relVarDispose
 acquireAsync :: IO a -> Acquire (Async a)
 acquireAsync act = mkAcquire (async act) cancel
 
-newtype NonPosTimeDeltaErr = NonPosTimeDeltaErr TimeDelta
-  deriving stock (Eq, Ord, Show)
-
-instance Exception NonPosTimeDeltaErr
-
-awaitTime :: TimeDelta -> IORef PosixTime -> IO PosixTime
-awaitTime delta timeVar = do
-  lastTime <- readIORef timeVar
-  nextTime <-
-    if lastTime == PosixTime 0
-      then currentTime
-      else awaitDelta lastTime delta
-  writeIORef timeVar nextTime
-  pure nextTime
-
-acquireLoop :: TVar TimeDelta -> (PosixTime -> IO ()) -> Acquire (Async ())
-acquireLoop deltaVar act = do
-  timeVar <- liftIO (newIORef (PosixTime 0))
-  let act' = do
-        delta <- readTVarIO deltaVar
-        unless (delta > 0) (throwIO (NonPosTimeDeltaErr delta))
-        time <- awaitTime delta timeVar
-        act time
-        act'
-  acquireAsync act'
-
-data Timed a = Timed
-  { timedKey :: !PosixTime
-  , timedVal :: !a
-  }
-  deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)
-
-instance (Pretty a) => Pretty (Timed a) where
-  pretty (Timed k v) = P.hsep [pretty (unPosixTime k), pretty v]
-
-acquireAwait :: TVar Bool -> TQueue (Timed a) -> (Timed a -> IO ()) -> Acquire (Async ())
-acquireAwait runVar queue act =
-  let act' = do
+acquireLoop :: (PosixTime -> IO PosixTime) -> PosixTime -> Acquire (Async ())
+acquireLoop act now0 =
+  let go now = do
+        next <- act now
+        threadDelayUntil next
+        go next
+  in  acquireAsync (go now0)
+
+acquireAwait :: (v -> PosixTime) -> STM Bool -> TQueue v -> (v -> IO ()) -> Acquire (Async ())
+acquireAwait getTime getRunning queue act =
+  let go = do
         -- Peek at the first entry and await it
-        time <- atomically $ do
-          run <- readTVar runVar
+        target <- atomically $ do
+          run <- getRunning
           if run
-            then fmap timedKey (peekTQueue queue)
+            then fmap getTime (peekTQueue queue)
             else retry
-        now <- currentTime @PosixTime
-        threadDelayDelta (diffTime time now)
-        -- If it's still there (not cleared), act on it
-        mtimed <- atomically $ do
-          run <- readTVar runVar
+        threadDelayUntil target
+        -- If something actionable is still there, act on it
+        mv <- atomically $ do
+          run <- getRunning
           if run
             then do
-              mtimed <- tryPeekTQueue queue
-              case mtimed of
-                Just timed
-                  | timedKey timed == time ->
-                      mtimed <$ readTQueue queue
+              mv <- tryPeekTQueue queue
+              case mv of
+                Just v
+                  | getTime v <= target ->
+                      mv <$ readTQueue queue
                 _ -> pure Nothing
             else pure Nothing
-        maybe (pure ()) act mtimed
-        act'
-  in  acquireAsync act'
+        maybe (pure ()) act mv
+        go
+  in  acquireAsync go
+
+threadDelayUntil :: PosixTime -> IO ()
+threadDelayUntil target =
+  currentTime >>= threadDelayDelta . diffTime target
 
 withTimeout :: TimeDelta -> IO a -> IO (Either SomeException a)
-withTimeout td act = do
+withTimeout delta act = do
   thread <- async act
-  _ <- forkFinally (threadDelayDelta td) (const (cancel thread))
+  _ <- forkFinally (threadDelayDelta delta) (const (cancel thread))
   waitCatch thread
diff --git a/minipat-live/test/Main.hs b/minipat-live/test/Main.hs
index 25874ee..e3c761c 100644
--- a/minipat-live/test/Main.hs
+++ b/minipat-live/test/Main.hs
@@ -6,40 +6,57 @@ module Main
 where
 
 import Dahdit.Midi.Osc (Datum (..))
+import Data.Ratio ((%))
 import Data.Sequence qualified as Seq
-import Minipat.Live.Attrs (attrsFromList)
+import Minipat.Live.Attrs (attrsSingleton)
 import Minipat.Live.Combinators (sound)
-import Minipat.Live.Core (setOrbit, simpleRecord)
-import Minipat.Live.Resources (Timed (..))
+import Minipat.Live.Core (Env (..), mergeRecord, setOrbit)
+import Minipat.Live.Play (PlayMeta (..), WithPlayMeta (..))
+import Minipat.Time (arcStart, bpmToCps)
+import Nanotime (PosixTime, addTime, timeDeltaFromFracSecs)
 import Test.Tasty (TestTree, defaultMain, testGroup)
 import Test.Tasty.HUnit (testCase, (@?=))
 
-testRecord :: TestTree
-testRecord = testCase "record" $ do
-  -- 2000000000 (ns) here is 2 seconds
-  -- Default 120 bpm, 1 gpc means 2 second generation delay
-  -- and 1/2 second per beat
-  -- 1000000 (us) is 1 second
-  let expected =
-        Seq.fromList
-          [ Timed 2000000000 $
-              attrsFromList
-                [ ("cps", DatumFloat 0.5)
-                , ("delta", DatumFloat 1000000.0)
-                , ("orbit", DatumInt32 1)
-                , ("sound", DatumString "bd")
-                ]
-          , Timed 3000000000 $
-              attrsFromList
-                [ ("cps", DatumFloat 0.5)
-                , ("delta", DatumFloat 1000000.0)
-                , ("orbit", DatumInt32 1)
-                , ("sound", DatumString "sd")
+data R a = R !Integer !PosixTime !a
+  deriving stock (Eq, Ord, Show)
+
+projectR :: WithPlayMeta a -> R a
+projectR (WithPlayMeta pm a) = R (pmOrbit pm) (arcStart (pmRealArc pm)) a
+
+testRecordCase :: (Integer, Integer) -> TestTree
+testRecordCase (tempo, gpc) =
+  let cps = bpmToCps 4 (fromInteger tempo)
+  in  testCase (show tempo ++ " " ++ show gpc) $ do
+        let env = Env cps gpc
+            cycStart = 0
+            cycEnd = 2
+            realStart = 0
+            ahead = timeDeltaFromFracSecs (1 / (cps * fromInteger gpc))
+            offset = addTime realStart ahead
+            time c = addTime offset (timeDeltaFromFracSecs (c / cps))
+            expectedEvs =
+              Seq.fromList
+                [ R 1 (time 0) (attrsSingleton "sound" (DatumString "bd"))
+                , R 1 (time (1 % 2)) (attrsSingleton "sound" (DatumString "sd"))
+                , R 1 (time 1) (attrsSingleton "sound" (DatumString "bd"))
+                , R 1 (time (3 % 2)) (attrsSingleton "sound" (DatumString "sd"))
                 ]
-          ]
-  actual <- simpleRecord $ \st ->
-    setOrbit st 1 (sound "bd sd")
-  actual @?= expected
+            expectedEnd = addTime (time (fromInteger cycEnd)) (negate ahead)
+        (actualEvs, actualEnd) <- mergeRecord env cycStart cycEnd realStart $ \st ->
+          setOrbit st 1 (sound "bd sd")
+        let actualEvs' = fmap projectR actualEvs
+        actualEvs' @?= expectedEvs
+        actualEnd @?= expectedEnd
+
+testRecord :: TestTree
+testRecord =
+  testGroup "record" $
+    fmap
+      testRecordCase
+      [ (120, 1)
+      , (120, 2)
+      , (120, 4)
+      ]
 
 main :: IO ()
 main =
diff --git a/minipat/src/Minipat/Rand.hs b/minipat/src/Minipat/Rand.hs
index 077504c..1c399e4 100644
--- a/minipat/src/Minipat/Rand.hs
+++ b/minipat/src/Minipat/Rand.hs
@@ -15,7 +15,7 @@ import Data.Bits (Bits (..))
 import Data.Maybe (fromMaybe)
 import Data.Ratio ((%))
 import Data.Word (Word32)
-import Minipat.Time (Arc (..), CycleTime, Span (..), arcMid)
+import Minipat.Time (Arc (..), Span (..), arcMidpoint)
 
 -- | A random seed
 newtype Seed = Seed {unSeed :: Word32}
@@ -34,18 +34,18 @@ xorshift (Seed x0) =
   in  Seed (xor x2 (shiftL x2 5))
 
 -- | Associates a random seed with a given 'Time'.
-timeSeed :: CycleTime -> Seed
+timeSeed :: (RealFrac a) => a -> Seed
 timeSeed time =
   let (_, frac) = properFraction @_ @Word32 (time / 300)
       val = truncate (frac * seedConst)
   in  xorshift (Seed val)
 
 -- | Associates a random seed with a given 'Arc'.
-arcSeed :: Arc -> Seed
-arcSeed = timeSeed . arcMid
+arcSeed :: (RealFrac a) => Arc a -> Seed
+arcSeed = timeSeed . arcMidpoint
 
 -- | Associates a random seed with a given 'Span'.
-spanSeed :: Span -> Seed
+spanSeed :: (RealFrac a) => Span a -> Seed
 spanSeed (Span arc mwhole) = arcSeed (fromMaybe arc mwhole)
 
 -- | Returns a random fractional value in [0, 1)
diff --git a/minipat/src/Minipat/Stream.hs b/minipat/src/Minipat/Stream.hs
index a9a2727..5a70502 100644
--- a/minipat/src/Minipat/Stream.hs
+++ b/minipat/src/Minipat/Stream.hs
@@ -60,25 +60,24 @@ import Minipat.Classes (Flow (..), Pattern (..), PatternUnwrap (..))
 import Minipat.Rand (arcSeed, randFrac, randInt, spanSeed)
 import Minipat.Time
   ( Arc (..)
-  , Cycle (..)
+  , CycleArc
   , CycleDelta (..)
+  , CycleSpan
   , CycleTime (..)
   , MergeStrat (..)
   , Span (..)
   , arcIntersect
   , arcMerge
   , arcRelevant
-  , arcTimeMapMono
   , arcWiden
+  , spanMapWhole
   , spanSplit
-  , spanTimeMapMono
-  , spanWholeMapMono
   )
 import Prettyprinter (Pretty (..))
 import Prettyprinter qualified as P
 
 data Ev a = Ev
-  { evSpan :: !Span
+  { evSpan :: !CycleSpan
   , evValue :: !a
   }
   deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)
@@ -86,10 +85,10 @@ data Ev a = Ev
 instance (Pretty a) => Pretty (Ev a) where
   pretty (Ev sp v) = P.hsep [pretty sp, pretty v]
 
-evCont :: (CycleTime -> a) -> Arc -> Ev a
+evCont :: (CycleTime -> a) -> CycleArc -> Ev a
 evCont f arc = Ev (Span arc Nothing) (f (arcStart arc))
 
-newtype Tape a = Tape {unTape :: Heap (Entry Span a)}
+newtype Tape a = Tape {unTape :: Heap (Entry CycleSpan a)}
   deriving stock (Show)
   deriving newtype (Eq, Ord, Semigroup, Monoid)
 
@@ -100,20 +99,20 @@ tapeNull :: Tape a -> Bool
 tapeNull = H.null . unTape
 
 -- TODO Actually sample at the given rate
-tapeCont :: Integer -> (CycleTime -> a) -> Arc -> Tape a
+tapeCont :: Integer -> (CycleTime -> a) -> CycleArc -> Tape a
 tapeCont _ f arc = tapeSingleton (evCont f arc)
 
 tapeFilter :: (a -> Bool) -> Tape a -> Tape a
 tapeFilter f = Tape . H.filter (\(Entry _ a) -> f a) . unTape
 
-tapeFastBy :: Cycle -> Rational -> Tape a -> Tape a
+tapeFastBy :: Integer -> Rational -> Tape a -> Tape a
 tapeFastBy o r =
-  let o' = fromInteger (unCycle o)
+  let o' = fromInteger o
   in  tapeTimeMapMono (\(CycleTime t) -> CycleTime ((t - o') / r + o'))
 
-tapeSlowBy :: Cycle -> Rational -> Tape a -> Tape a
+tapeSlowBy :: Integer -> Rational -> Tape a -> Tape a
 tapeSlowBy o r =
-  let o' = fromInteger (unCycle o)
+  let o' = fromInteger o
   in  tapeTimeMapMono (\(CycleTime t) -> CycleTime ((t - o') * r + o'))
 
 tapeLateBy :: CycleDelta -> Tape a -> Tape a
@@ -128,10 +127,10 @@ tapeDegradeBy r = Tape . H.filter f . unTape
   f (Entry sp _) = randFrac (spanSeed sp) < r
 
 tapeTimeMapMono :: (CycleTime -> CycleTime) -> Tape a -> Tape a
-tapeTimeMapMono f = Tape . H.mapMonotonic (\(Entry s a) -> Entry (spanTimeMapMono f s) a) . unTape
+tapeTimeMapMono f = Tape . H.mapMonotonic (\(Entry s a) -> Entry (fmap f s) a) . unTape
 
-tapeWholeMapMono :: (Maybe Arc -> Maybe Arc) -> Tape a -> Tape a
-tapeWholeMapMono f = Tape . H.mapMonotonic (\(Entry s a) -> Entry (spanWholeMapMono f s) a) . unTape
+tapeWholeMapMono :: (Maybe CycleArc -> Maybe CycleArc) -> Tape a -> Tape a
+tapeWholeMapMono f = Tape . H.mapMonotonic (\(Entry s a) -> Entry (spanMapWhole f s) a) . unTape
 
 tapeSingleton :: Ev a -> Tape a
 tapeSingleton (Ev s a) = Tape (H.singleton (Entry s a))
@@ -149,7 +148,7 @@ tapeFromList :: [Ev a] -> Tape a
 tapeFromList = Tape . H.fromList . fmap (\(Ev s a) -> Entry s a)
 
 -- Keep only relevant events (narrowing active arcs)
-tapeRelevant :: Arc -> Tape a -> Tape a
+tapeRelevant :: CycleArc -> Tape a -> Tape a
 tapeRelevant ref = Tape . H.fromList . mapMaybe go . toList . unTape
  where
   go (Entry s a) =
@@ -157,7 +156,7 @@ tapeRelevant ref = Tape . H.fromList . mapMaybe go . toList . unTape
       then Just (Entry (s {spanActive = arcIntersect ref (spanActive s)}) a)
       else Nothing
 
-newtype Stream a = Stream {unStream :: Arc -> Tape a}
+newtype Stream a = Stream {unStream :: CycleArc -> Tape a}
 
 instance Functor Stream where
   fmap f (Stream k) = Stream (fmap f . k)
@@ -186,7 +185,7 @@ instance Alternative Stream where
 streamFilter :: (a -> Bool) -> Stream a -> Stream a
 streamFilter f (Stream k) = Stream (tapeFilter f . k)
 
-streamBindWith :: (Maybe Arc -> Maybe Arc -> Maybe Arc) -> Stream a -> (a -> Stream b) -> Stream b
+streamBindWith :: (Maybe CycleArc -> Maybe CycleArc -> Maybe CycleArc) -> Stream a -> (a -> Stream b) -> Stream b
 streamBindWith g pa f = Stream $ \arc ->
   let ta = streamRun pa arc
   in  flip tapeConcatMap ta $ \(Ev (Span ac wh) a) ->
@@ -196,13 +195,14 @@ streamBindWith g pa f = Stream $ \arc ->
 streamBind :: MergeStrat -> Stream a -> (a -> Stream b) -> Stream b
 streamBind = streamBindWith . arcMerge
 
-streamApplyWith :: (Maybe Arc -> Maybe Arc -> Maybe Arc) -> (a -> b -> c) -> Stream a -> Stream b -> Stream c
+streamApplyWith
+  :: (Maybe CycleArc -> Maybe CycleArc -> Maybe CycleArc) -> (a -> b -> c) -> Stream a -> Stream b -> Stream c
 streamApplyWith g f pa = streamBindWith g (fmap f pa) . flip fmap
 
 streamApply :: MergeStrat -> (a -> b -> c) -> Stream a -> Stream b -> Stream c
 streamApply = streamApplyWith . arcMerge
 
-streamRun :: Stream a -> Arc -> Tape a
+streamRun :: Stream a -> CycleArc -> Tape a
 streamRun pa arc =
   let arc' = arcWiden arc
   in  if arc' == arc
@@ -210,7 +210,7 @@ streamRun pa arc =
         else tapeRelevant arc (unStream pa arc')
 
 streamTimeMapInv :: (CycleTime -> CycleTime) -> (CycleTime -> CycleTime) -> Stream a -> Stream a
-streamTimeMapInv onTape onArc (Stream k) = Stream (tapeTimeMapMono onTape . k . arcTimeMapMono onArc)
+streamTimeMapInv onTape onArc (Stream k) = Stream (tapeTimeMapMono onTape . k . fmap onArc)
 
 streamAdjust :: (a -> Stream b -> Stream c) -> Stream a -> Stream b -> Stream c
 streamAdjust f pa pb = streamBind MergeStratInner pa (`f` pb)
@@ -289,7 +289,7 @@ streamAlt :: Seq (Stream a) -> Stream a
 streamAlt ss =
   let l = Seq.length ss
       f z arc =
-        let i = mod (fromInteger (unCycle z)) l
+        let i = mod (fromInteger z) l
             t = Seq.index ss i
         in  streamRun t arc
   in  Stream (foldMap' (\(z, sp) -> f z (spanActive sp)) . spanSplit)
diff --git a/minipat/src/Minipat/Time.hs b/minipat/src/Minipat/Time.hs
index 790b3b3..35e74d0 100644
--- a/minipat/src/Minipat/Time.hs
+++ b/minipat/src/Minipat/Time.hs
@@ -2,43 +2,54 @@
 
 -- | Time is a cube with four corners
 module Minipat.Time
-  ( CycleTime (..)
+  ( midpoint
+  , Measurable (..)
+  , CycleTime (..)
   , CycleDelta (..)
-  , Cycle (..)
-  , cycTimeFloor
-  , cycTimeCeil
-  , cycTimeMid
   , Arc (..)
+  , CycleArc
+  , PosixArc
+  , arcMidpoint
   , arcWiden
   , arcRelevant
   , arcUnion
   , arcIntersect
-  , arcMid
-  , arcTimeMapMono
+  , arcLength
   , MergeStrat (..)
   , arcMerge
   , Span (..)
+  , CycleSpan
+  , PosixSpan
   , spanCover
   , spanSplit
-  , spanCycle
-  , spanDelta
-  , spanTimeMapMono
-  , spanWholeMapMono
+  , spanActiveStart
+  , spanWholeLength
+  , spanMapWhole
   , spanIsStart
   , bpmToCps
   , cpsToBpm
   , deltaToCycle
   , cycleToDelta
-  , relDelta
+  , relativeDelta
   )
 where
 
 import Data.Maybe (fromMaybe)
 import Minipat.Print (prettyRat, prettyTup)
-import Nanotime (TimeDelta, timeDeltaFromFracSecs, timeDeltaToFracSecs)
+import Nanotime (PosixTime, TimeDelta, diffTime, timeDeltaFromFracSecs, timeDeltaToFracSecs)
 import Prettyprinter (Pretty (..))
 import Prettyprinter qualified as P
 
+midpoint :: (Fractional a) => a -> a -> a
+midpoint s e = s + (e - s) / 2
+
+class Measurable b a | a -> b where
+  -- | `measure start end` is `end - start`
+  measure :: a -> a -> b
+
+instance Measurable TimeDelta PosixTime where
+  measure s e = diffTime e s
+
 newtype CycleTime = CycleTime {unCycleTime :: Rational}
   deriving stock (Show)
   deriving newtype (Eq, Ord, Num, Fractional, Real, RealFrac)
@@ -53,46 +64,36 @@ newtype CycleDelta = CycleDelta {unCycleDelta :: Rational}
 instance Pretty CycleDelta where
   pretty = prettyRat . unCycleDelta
 
-newtype Cycle = Cycle {unCycle :: Integer}
-  deriving stock (Show)
-  deriving newtype (Eq, Ord, Num, Pretty)
-
-cycTimeFloor :: CycleTime -> Cycle
-cycTimeFloor = Cycle . floor . unCycleTime
+instance Measurable CycleDelta CycleTime where
+  measure s e = CycleDelta (unCycleTime e - unCycleTime s)
 
-cycTimeCeil :: CycleTime -> Cycle
-cycTimeCeil = (+ 1) . cycTimeFloor
+data Arc a = Arc {arcStart :: !a, arcEnd :: !a}
+  deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)
 
-cycTimeMid :: CycleTime -> CycleTime -> CycleTime
-cycTimeMid s e = s + (e - s) / 2
+type CycleArc = Arc CycleTime
 
-data Arc = Arc {arcStart :: !CycleTime, arcEnd :: !CycleTime}
-  deriving stock (Eq, Ord, Show)
+type PosixArc = Arc PosixTime
 
-instance Pretty Arc where
+instance (Pretty a) => Pretty (Arc a) where
   pretty (Arc s e) = prettyTup s e
 
-arcWiden :: Arc -> Arc
-arcWiden (Arc s e) = Arc (fromInteger (floor (unCycleTime s))) (fromInteger (floor (unCycleTime e) + 1))
+arcWiden :: (RealFrac a) => Arc a -> Arc a
+arcWiden (Arc s e) = Arc (fromInteger (floor s)) (fromInteger (floor e) + 1)
 
-arcRelevant :: Arc -> Arc -> Bool
+arcRelevant :: (Ord a) => Arc a -> Arc a -> Bool
 arcRelevant (Arc s1 e1) (Arc s2 e2) = s2 < e1 && (e2 > s1 || (s2 == s1 && e2 == s1))
 
-arcUnion :: Arc -> Arc -> Arc
+arcUnion :: (Ord a) => Arc a -> Arc a -> Arc a
 arcUnion (Arc s1 e1) (Arc s2 e2) = Arc (min s1 s2) (max e1 e2)
 
-arcIntersect :: Arc -> Arc -> Arc
+arcIntersect :: (Ord a) => Arc a -> Arc a -> Arc a
 arcIntersect (Arc s1 e1) (Arc s2 e2) =
   let s3 = max s1 s2
       e3 = min e1 e2
   in  Arc s3 (max s3 e3)
 
-arcMid :: Arc -> CycleTime
-arcMid (Arc s e) = cycTimeMid s e
-
--- | Map a monotonic function over cycle times
-arcTimeMapMono :: (CycleTime -> CycleTime) -> Arc -> Arc
-arcTimeMapMono f (Arc s e) = Arc (f s) (f e)
+arcMidpoint :: (Fractional a) => Arc a -> a
+arcMidpoint (Arc s e) = midpoint s e
 
 -- | Strategy for merging arcs
 data MergeStrat
@@ -102,42 +103,45 @@ data MergeStrat
   deriving stock (Eq, Ord, Show, Enum, Bounded)
 
 -- | Merges arcs according to the given strategy
-arcMerge :: MergeStrat -> Maybe Arc -> Maybe Arc -> Maybe Arc
+arcMerge :: (Ord a) => MergeStrat -> Maybe (Arc a) -> Maybe (Arc a) -> Maybe (Arc a)
 arcMerge = \case
   MergeStratInner -> (\_ x -> x)
   MergeStratOuter -> const
   MergeStratMixed -> liftA2 arcIntersect
 
-data Span = Span
-  { spanActive :: !Arc
-  , spanWhole :: !(Maybe Arc)
+arcLength :: (Measurable b a) => Arc a -> b
+arcLength (Arc s e) = measure s e
+
+data Span a = Span
+  { spanActive :: !(Arc a)
+  , spanWhole :: !(Maybe (Arc a))
   }
-  deriving stock (Eq, Ord, Show)
+  deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)
 
-instance Pretty Span where
-  pretty (Span ac wh) = P.hsep (pretty ac : maybe [] (pure . pretty) wh)
+type CycleSpan = Span CycleTime
 
--- | Map a monotonic function over all cycle times
-spanTimeMapMono :: (CycleTime -> CycleTime) -> Span -> Span
-spanTimeMapMono f (Span ac wh) = Span (arcTimeMapMono f ac) (fmap (arcTimeMapMono f) wh)
+type PosixSpan = Span PosixTime
+
+instance (Pretty a) => Pretty (Span a) where
+  pretty (Span ac wh) = P.hsep (pretty ac : maybe [] (pure . pretty) wh)
 
 -- | Map a monotonic function over whole cycle times
-spanWholeMapMono :: (Maybe Arc -> Maybe Arc) -> Span -> Span
-spanWholeMapMono f (Span ac wh) = Span ac (f wh)
+spanMapWhole :: (Maybe (Arc a) -> Maybe (Arc a)) -> Span a -> Span a
+spanMapWhole f (Span ac wh) = Span ac (f wh)
 
 -- | Returns the 'Arc' covering the whole event
 -- (or just the active arc if non-discrete)
-spanCover :: Span -> Arc
+spanCover :: Span a -> Arc a
 spanCover (Span ac wh) = fromMaybe ac wh
 
 -- | Splits an 'Arc' into single-cycle spans
-spanSplit :: Arc -> [(Cycle, Span)]
+spanSplit :: (RealFrac a) => Arc a -> [(Integer, Span a)]
 spanSplit (Arc s0 e) =
-  let ef = cycTimeFloor e
+  let ef = floor e
       go s =
-        let sf = cycTimeFloor s
-            si = fromInteger (unCycle sf)
-            sc = fromInteger (unCycle (cycTimeCeil s))
+        let sf = floor s
+            si = fromInteger sf
+            sc = fromInteger (floor s + 1)
             wh = Just (Arc si sc)
         in  if sf == ef || sc == e
               then [(sf, Span (Arc s e) wh)]
@@ -145,19 +149,19 @@ spanSplit (Arc s0 e) =
   in  go s0
 
 -- | The start of the 'Span' in cycle time, if active
-spanCycle :: Span -> Maybe CycleTime
-spanCycle = \case
+spanActiveStart :: (Eq a) => Span a -> Maybe a
+spanActiveStart = \case
   sp@(Span _ (Just (Arc sw _))) | spanIsStart sp -> Just sw
   _ -> Nothing
 
 -- | The length of the whole event in cycle time, if discrete
-spanDelta :: Span -> Maybe CycleDelta
-spanDelta = \case
-  Span _ (Just (Arc sw ew)) -> Just (CycleDelta (unCycleTime (ew - sw)))
+spanWholeLength :: (Measurable b a) => Span a -> Maybe b
+spanWholeLength = \case
+  Span _ (Just arc) -> Just (arcLength arc)
   _ -> Nothing
 
 -- | True if active start aligns with whole start
-spanIsStart :: Span -> Bool
+spanIsStart :: (Eq a) => Span a -> Bool
 spanIsStart (Span (Arc sa _) mwh) =
   case mwh of
     Nothing -> True
@@ -181,5 +185,5 @@ cycleToDelta :: Rational -> CycleTime -> TimeDelta
 cycleToDelta cps = timeDeltaFromFracSecs . (/ cps) . unCycleTime
 
 -- | Given CPS return relative time from origin to target
-relDelta :: Rational -> CycleTime -> CycleTime -> TimeDelta
-relDelta cps origin target = timeDeltaFromFracSecs (unCycleTime (target - origin) / cps)
+relativeDelta :: Rational -> CycleTime -> CycleTime -> TimeDelta
+relativeDelta cps start end = timeDeltaFromFracSecs (unCycleTime (end - start) / cps)
diff --git a/minipat/test/Main.hs b/minipat/test/Main.hs
index a2097d9..14a29dc 100644
--- a/minipat/test/Main.hs
+++ b/minipat/test/Main.hs
@@ -26,7 +26,7 @@ import Minipat.Norm (normPat)
 import Minipat.Parser (Loc, P, ParseErr, factorP, identP, identPatP, selectIdentPatP)
 import Minipat.Print (prettyShow)
 import Minipat.Stream (Ev (..), Stream, streamRun, tapeToList)
-import Minipat.Time (Arc (..), CycleTime (..), Span (..))
+import Minipat.Time (Arc (..), CycleArc, CycleTime (..), Span (..))
 import Minipat.Ur (ur)
 import Prettyprinter qualified as P
 import System.IO (BufferMode (..), hSetBuffering, stdout)
@@ -414,7 +414,7 @@ testPatNormCases =
             )
           ]
 
-runPatInterpCase :: (TestName, Maybe Arc, Text, [Ev Ident]) -> TestTree
+runPatInterpCase :: (TestName, Maybe CycleArc, Text, [Ev Ident]) -> TestTree
 runPatInterpCase (n, mayArc, patStr, evs) = testCase n $ do
   pat <- either throwIO pure (evalPat identP patStr)
   let arc = fromMaybe (Arc 0 1) mayArc