From c5a6ba9477f7d862b6357597ad6cfb86420bc3be Mon Sep 17 00:00:00 2001
From: Eric Conlon <37287+ejconlon@users.noreply.github.com>
Date: Sat, 17 Feb 2024 11:59:27 -0800
Subject: [PATCH] etc

---
 minipat-dirt/src/Minipat/Dirt/Attrs.hs   |  61 +++++++++-
 minipat-dirt/src/Minipat/Dirt/Boot.hs    |  12 +-
 minipat-dirt/src/Minipat/Dirt/Core.hs    | 138 +++++++++++++++++------
 minipat-dirt/src/Minipat/Dirt/Notes.hs   |   2 +-
 minipat-dirt/src/Minipat/Dirt/Osc.hs     |  61 ++++++----
 minipat-dirt/src/Minipat/Dirt/Prelude.hs |  10 +-
 minipat-dirt/src/Minipat/Dirt/Test.hs    |   6 +-
 minipat/src/Minipat/Print.hs             |  12 ++
 minipat/src/Minipat/Stream.hs            |  45 +++++---
 minipat/src/Minipat/Time.hs              |   8 ++
 minipat/test/Main.hs                     |   8 +-
 11 files changed, 273 insertions(+), 90 deletions(-)

diff --git a/minipat-dirt/src/Minipat/Dirt/Attrs.hs b/minipat-dirt/src/Minipat/Dirt/Attrs.hs
index 645192f..cb76029 100644
--- a/minipat-dirt/src/Minipat/Dirt/Attrs.hs
+++ b/minipat-dirt/src/Minipat/Dirt/Attrs.hs
@@ -5,8 +5,14 @@ module Minipat.Dirt.Attrs
   , datumProxyType
   , Attr (..)
   , Attrs
-  , attrs
+  , attrsSingleton
+  , attrsFromList
+  , attrsLookup
+  , attrsInsert
+  , attrsDelete
+  , attrsToList
   , IsAttrs (..)
+  , attrsMerge
   )
 where
 
@@ -17,6 +23,8 @@ import Data.Map.Strict qualified as Map
 import Data.Text (Text)
 import Minipat.Ast (Ident (..))
 import Minipat.Dirt.Notes (Note (..))
+import Prettyprinter (Doc, Pretty (..))
+import Prettyprinter qualified as P
 
 data Sound = Sound
   { soundIdent :: !Ident
@@ -39,16 +47,54 @@ datumProxyType = \case
   DatumProxyDouble -> DatumTypeDouble
   DatumProxyString -> DatumTypeString
 
+prettyDatum :: Datum -> Doc ann
+prettyDatum = \case
+  DatumInt32 x -> pretty x
+  DatumInt64 x -> pretty x
+  DatumFloat x -> pretty x
+  DatumDouble x -> pretty x
+  DatumString x -> pretty x
+  DatumBlob _ -> "<BLOB>"
+  DatumTime _ -> "<TIME>"
+  DatumMidi _ -> "<MIDI>"
+
 data Attr a = Attr
   { attrKey :: !Text
   , attrVal :: !a
   }
   deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)
 
-type Attrs = Map Text Datum
+newtype Attrs = Attrs {unAttrs :: Map Text Datum}
+  deriving stock (Show)
+  deriving newtype (Eq, Ord)
+
+instance Semigroup Attrs where
+  -- Flip order to allow keys on the right to win
+  Attrs m1 <> Attrs m2 = Attrs (m2 <> m1)
+
+instance Monoid Attrs where
+  mempty = Attrs Map.empty
+
+instance Pretty Attrs where
+  pretty as = P.hsep ("{" : P.punctuate "," (fmap (\(k, v) -> P.hcat [pretty k, ": ", prettyDatum v]) (attrsToList as)) ++ ["}"])
+
+attrsSingleton :: Text -> Datum -> Attrs
+attrsSingleton k v = Attrs (Map.singleton k v)
 
-attrs :: [(Text, Datum)] -> Attrs
-attrs = Map.fromList
+attrsFromList :: [(Text, Datum)] -> Attrs
+attrsFromList = Attrs . Map.fromList
+
+attrsLookup :: Text -> Attrs -> Maybe Datum
+attrsLookup k (Attrs m) = Map.lookup k m
+
+attrsInsert :: Text -> Datum -> Attrs -> Attrs
+attrsInsert k v (Attrs m) = Attrs (Map.insert k v m)
+
+attrsDelete :: Text -> Attrs -> Attrs
+attrsDelete k (Attrs m) = Attrs (Map.delete k m)
+
+attrsToList :: Attrs -> [(Text, Datum)]
+attrsToList = Map.toList . unAttrs
 
 class IsAttrs a where
   toAttrs :: a -> Attrs
@@ -57,7 +103,10 @@ instance IsAttrs Attrs where
   toAttrs = id
 
 instance (IsDatum a) => IsAttrs (Attr a) where
-  toAttrs (Attr k v) = Map.singleton k (toDatum v)
+  toAttrs (Attr k v) = attrsSingleton k (toDatum v)
 
 instance IsAttrs Note where
-  toAttrs (Note n) = Map.singleton "note" (DatumInt32 (fromInteger n))
+  toAttrs (Note n) = attrsSingleton "note" (DatumInt32 (fromInteger n))
+
+attrsMerge :: (IsAttrs a, IsAttrs b) => a -> b -> Attrs
+attrsMerge a b = toAttrs a <> toAttrs b
diff --git a/minipat-dirt/src/Minipat/Dirt/Boot.hs b/minipat-dirt/src/Minipat/Dirt/Boot.hs
index dc9642f..b84779c 100644
--- a/minipat-dirt/src/Minipat/Dirt/Boot.hs
+++ b/minipat-dirt/src/Minipat/Dirt/Boot.hs
@@ -8,6 +8,7 @@ import Minipat.Dirt.Logger qualified as L
 import Minipat.EStream (EStream)
 import Minipat.Stream (Stream)
 import Nanotime (TimeDelta)
+import Prettyprinter (Pretty)
 
 class Dirt where
   dirt :: C.St
@@ -21,6 +22,9 @@ initialize = do
 dispose :: (Dirt) => IO ()
 dispose = C.disposeSt dirt
 
+getDebug :: (Dirt) => IO Bool
+getDebug = C.getDebug dirt
+
 getCps :: (Dirt) => IO Rational
 getCps = C.getCps dirt
 
@@ -39,6 +43,9 @@ getCycle = C.getCycle dirt
 getTempo :: (Dirt) => IO Rational
 getTempo = C.getTempo dirt
 
+setDebug :: (Dirt) => Bool -> IO ()
+setDebug = C.setDebug dirt
+
 setCps :: (Dirt) => Rational -> IO ()
 setCps = C.setCps dirt
 
@@ -75,7 +82,10 @@ stop = setPlaying False
 handshake :: (Dirt) => IO ()
 handshake = C.handshake dirt
 
-peek :: (Dirt, Show a) => EStream a -> IO ()
+checkTasks :: (Dirt) => IO ()
+checkTasks = C.checkTasks dirt
+
+peek :: (Dirt, Pretty a) => EStream a -> IO ()
 peek = C.peek dirt
 
 d :: (Dirt, IsAttrs a) => Integer -> EStream a -> IO ()
diff --git a/minipat-dirt/src/Minipat/Dirt/Core.hs b/minipat-dirt/src/Minipat/Dirt/Core.hs
index 43b5081..2df4ce7 100644
--- a/minipat-dirt/src/Minipat/Dirt/Core.hs
+++ b/minipat-dirt/src/Minipat/Dirt/Core.hs
@@ -3,7 +3,7 @@
 module Minipat.Dirt.Core where
 
 import Control.Concurrent (forkFinally)
-import Control.Concurrent.Async (Async, async, cancel, waitCatch)
+import Control.Concurrent.Async (Async, async, cancel, poll, waitCatch)
 import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, tryTakeMVar, withMVar)
 import Control.Concurrent.STM (STM, atomically, retry)
 import Control.Concurrent.STM.TQueue
@@ -17,7 +17,7 @@ import Control.Concurrent.STM.TQueue
   )
 import Control.Concurrent.STM.TVar (TVar, modifyTVar', newTVarIO, readTVar, readTVarIO, stateTVar, writeTVar)
 import Control.Exception (Exception (..), SomeException, bracket, mask_, onException, throwIO)
-import Control.Monad (unless, void)
+import Control.Monad (unless, void, when)
 import Control.Monad.IO.Class (liftIO)
 import Dahdit.Midi.Osc (Datum (..), Packet)
 import Dahdit.Network (Conn (..), HostPort (..), resolveAddr, runDecoder, runEncoder, udpServerConn)
@@ -29,15 +29,17 @@ import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
 import Data.Ratio ((%))
 import Data.Sequence (Seq)
+import Data.Sequence qualified as Seq
+import Data.Text (Text)
 import Data.Text qualified as T
-import Minipat.Dirt.Attrs (Attrs)
-import Minipat.Dirt.Logger (LogAction, logError, logInfo, newLogger)
+import Minipat.Dirt.Attrs (Attrs, attrsInsert)
+import Minipat.Dirt.Logger (LogAction, logDebug, logError, logInfo, logWarn, newLogger)
 import Minipat.Dirt.Osc (PlayEnv (..), PlayErr, Timed (..), convertTape, handshakePacket, playPacket)
 import Minipat.Dirt.Resources (RelVar, acquireAsync, relVarAcquire, relVarDispose, relVarInit)
 import Minipat.EStream (EStream (..))
-import Minipat.Print (prettyPrint)
-import Minipat.Stream (Stream (..), streamRun)
-import Minipat.Time (Arc (..), bpmToCps, cpsToBpm)
+import Minipat.Print (prettyPrint, prettyPrintAll, prettyShow, prettyShowAll)
+import Minipat.Stream (Stream, streamRun, tapeToList)
+import Minipat.Time (Arc (..), CycleTime (..), bpmToCps, cpsToBpm)
 import Nanotime
   ( PosixTime (..)
   , TimeDelta
@@ -47,6 +49,7 @@ import Nanotime
   , timeDeltaFromFracSecs
   )
 import Network.Socket qualified as NS
+import Prettyprinter (Pretty)
 
 newtype NonPosTimeDeltaErr = NonPosTimeDeltaErr TimeDelta
   deriving stock (Eq, Ord, Show)
@@ -104,7 +107,9 @@ acquireAwait runVar queue act =
 data Env = Env
   { envTargetHp :: !HostPort
   , envListenHp :: !HostPort
+  , envDebug :: !Bool
   , envCps :: !Rational
+  , envGpc :: !Integer
   , envOscTimeout :: !TimeDelta
   }
   deriving stock (Eq, Ord, Show)
@@ -114,16 +119,20 @@ defaultEnv =
   Env
     { envTargetHp = HostPort (Just "127.0.0.1") 57120
     , envListenHp = HostPort (Just "127.0.0.1") 57129
+    , envDebug = False
     , envCps = 1 % 2 -- 120 bpm, 4 bpc
+    , envGpc = 8 -- Number of gens per cycle
     , envOscTimeout = timeDeltaFromFracSecs @Double 0.1
     }
 
 data Domain = Domain
-  { domCps :: !(TVar Rational)
+  { domDebug :: !(TVar Bool)
+  , domCps :: !(TVar Rational)
+  , domGpc :: !(TVar Integer)
   , domAhead :: !(TVar TimeDelta)
   , domPlaying :: !(TVar Bool)
-  , domCycle :: !(TVar Integer)
-  , domAbsCycle :: !(TVar Integer)
+  , domGenCycle :: !(TVar Integer)
+  , domAbsGenCycle :: !(TVar Integer)
   , domOrbits :: !(TVar (Map Integer (Stream Attrs)))
   , domStream :: !(TVar (Stream Attrs))
   , domQueue :: !(TQueue (Timed Packet))
@@ -133,7 +142,9 @@ data Domain = Domain
 newDomain :: IO Domain
 newDomain =
   Domain
-    <$> newTVarIO 0
+    <$> newTVarIO False
+    <*> newTVarIO 0
+    <*> newTVarIO 0
     <*> newTVarIO 0
     <*> newTVarIO False
     <*> newTVarIO 0
@@ -148,18 +159,28 @@ initDomain env = newDomain >>= \d -> d <$ reinitDomain env d
 reinitDomain :: Env -> Domain -> IO ()
 reinitDomain env dom = atomically $ do
   let cps = envCps env
-      td = timeDeltaFromFracSecs (1 / cps)
+      gpc = envGpc env
+      ahead = timeDeltaFromFracSecs (1 / (cps * fromInteger gpc))
+  writeTVar (domDebug dom) (envDebug env)
   writeTVar (domCps dom) cps
-  writeTVar (domAhead dom) td
+  writeTVar (domGpc dom) gpc
+  writeTVar (domAhead dom) ahead
   writeTVar (domPlaying dom) False
-  writeTVar (domCycle dom) 0
+  writeTVar (domGenCycle dom) 0
+  writeTVar (domAbsGenCycle dom) 0
   writeTVar (domOrbits dom) mempty
   writeTVar (domStream dom) mempty
   void (flushTQueue (domQueue dom))
 
+getDebug :: St -> IO Bool
+getDebug = readTVarIO . domDebug . stDom
+
 getCps :: St -> IO Rational
 getCps = readTVarIO . domCps . stDom
 
+getGpc :: St -> IO Integer
+getGpc = readTVarIO . domGpc . stDom
+
 getAhead :: St -> IO TimeDelta
 getAhead = readTVarIO . domAhead . stDom
 
@@ -169,36 +190,53 @@ getPlaying = readTVarIO . domPlaying . stDom
 getStream :: St -> IO (Stream Attrs)
 getStream = readTVarIO . domStream . stDom
 
-getCycle :: St -> IO Integer
-getCycle = readTVarIO . domCycle . stDom
+getGenCycle :: St -> IO Integer
+getGenCycle = readTVarIO . domGenCycle . stDom
+
+getAbsGenCycle :: St -> IO Integer
+getAbsGenCycle = readTVarIO . domAbsGenCycle . stDom
 
-getAbsCycle :: St -> IO Integer
-getAbsCycle = readTVarIO . domAbsCycle . stDom
+getCycle :: St -> IO Integer
+getCycle st = atomically $ do
+  let dom = stDom st
+  gpc <- readTVar (domGpc dom)
+  gcyc <- readTVar (domGenCycle dom)
+  pure (div gcyc gpc)
 
 getTempo :: St -> IO Rational
 getTempo = fmap (cpsToBpm 4) . getCps
 
+setDebug :: St -> Bool -> IO ()
+setDebug st = atomically . writeTVar (domDebug (stDom st))
+
 setTempo :: St -> Rational -> IO ()
 setTempo st = setCps st . bpmToCps 4
 
 setCps :: St -> 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) (timeDeltaFromFracSecs (1 / cps'))
+  writeTVar (domAhead dom) ahead'
 
 setPlaying :: St -> Bool -> IO ()
 setPlaying st x = atomically (writeTVar (domPlaying (stDom st)) x)
 
 setCycle :: St -> Integer -> IO ()
-setCycle st x = atomically (writeTVar (domCycle (stDom st)) x)
+setCycle st x = atomically $ do
+  let dom = stDom st
+  gpc <- readTVar (domGpc dom)
+  gcyc <- readTVar (domGenCycle dom)
+  let y = x * gpc + mod gcyc gpc
+  writeTVar (domGenCycle (stDom st)) y
 
 -- TODO only set orbit if not present
 updateOrbits :: St -> (Map Integer (Stream Attrs) -> Map Integer (Stream Attrs)) -> IO ()
 updateOrbits st f = atomically $ do
   let dom = stDom st
   m' <- stateTVar (domOrbits dom) (\m -> let m' = f m in (m', m'))
-  let z = foldl' (\x (o, y) -> x <> fmap (Map.insert "orbit" (DatumInt32 (fromIntegral o))) y) mempty (Map.toList m')
+  let z = foldl' (\x (o, y) -> x <> fmap (attrsInsert "orbit" (DatumInt32 (fromIntegral o))) y) mempty (Map.toList m')
   writeTVar (domStream dom) z
 
 setOrbit :: St -> Integer -> EStream Attrs -> IO ()
@@ -231,27 +269,28 @@ panic st = atomically $ do
 handshake :: St -> IO ()
 handshake st = bracket acq rel (const (pure ()))
  where
+  logger = stLogger st
   acq = do
-    logInfo (stLogger st) "Handshaking ..."
+    logInfo logger "Handshaking ..."
     withMVar (stRes st) (flip sendPacket handshakePacket . resConn)
     recvPacket st
   rel resp = do
     let ok = isRight resp
     if ok
-      then logInfo (stLogger st) "... handshake succeeded"
-      else logError (stLogger st) "... handshake FAILED"
+      then logInfo logger "... handshake succeeded"
+      else logError logger "... handshake FAILED"
     setPlaying st ok
 
-peek :: (Show a) => St -> EStream a -> IO ()
+peek :: (Pretty a) => St -> 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 = streamRun s arc
+          evs = tapeToList (streamRun s arc)
       prettyPrint arc
-      for_ evs (prettyPrint . fmap show)
+      prettyPrintAll "\n" evs
 
 clearAllOrbitsSTM :: Domain -> STM ()
 clearAllOrbitsSTM dom = do
@@ -265,18 +304,22 @@ genEventsSTM :: Domain -> PosixTime -> STM (PlayEnv, Either PlayErr (Seq (Timed
 genEventsSTM dom now = do
   ahead <- readTVar (domAhead dom)
   cps <- readTVar (domCps dom)
-  cyc <- readTVar (domCycle 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 = unStream stream (Arc (fromInteger cyc) (fromInteger cyc + 1))
+  let tape = streamRun stream arc
       origin = addTime now ahead
-      penv = PlayEnv origin cyc cps
+      penv = PlayEnv origin start cps
       mpevs = convertTape penv tape
   pure (penv, mpevs)
 
 advanceCycleSTM :: Domain -> STM ()
 advanceCycleSTM dom = do
-  modifyTVar' (domCycle dom) (+ 1)
-  modifyTVar' (domAbsCycle dom) (+ 1)
+  modifyTVar' (domGenCycle dom) (+ 1)
+  modifyTVar' (domAbsGenCycle dom) (+ 1)
 
 data OscConn = OscConn
   { ocTargetAddr :: !NS.SockAddr
@@ -298,7 +341,7 @@ data St = St
   }
 
 acqConn :: Env -> Acquire OscConn
-acqConn (Env targetHp listenHp _ _) = do
+acqConn (Env targetHp listenHp _ _ _ _) = do
   targetAddr <- liftIO (resolveAddr targetHp)
   conn <- udpServerConn Nothing listenHp
   pure (OscConn targetAddr conn)
@@ -312,6 +355,23 @@ acqSendTask conn dom = acquireAwait (domPlaying dom) (domQueue dom) (doSend conn
 newSt :: LogAction -> Env -> IO St
 newSt logger env = St logger env <$> initDomain env <*> newEmptyMVar
 
+logAsyncState :: LogAction -> Text -> Async () -> IO ()
+logAsyncState logger name task = do
+  mea <- poll task
+  case mea of
+    Nothing -> logInfo logger ("Task " <> name <> " is running")
+    Just ea ->
+      case ea of
+        Left e -> logError logger ("Task " <> name <> " failed:\n" <> T.pack (displayException e))
+        Right _ -> logWarn logger ("Task " <> name <> " not running")
+
+checkTasks :: St -> IO ()
+checkTasks st = do
+  let logger = stLogger st
+  withMVar (stRes st) $ \res -> do
+    logAsyncState logger "gen" (resGenTask res)
+    logAsyncState logger "send" (resSendTask res)
+
 initRes :: St -> IO ()
 initRes st = do
   disposeSt st
@@ -333,6 +393,16 @@ withSt f = do
   logger <- newLogger
   bracket (initSt logger defaultEnv) disposeSt f
 
+logEvents :: LogAction -> Domain -> Seq (Timed Attrs) -> 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
+    logDebug logger ("Generated @ " <> prettyShow arc <> "\n" <> prettyShowAll "\n" pevs)
+
 doGen :: LogAction -> Domain -> PosixTime -> IO ()
 doGen logger dom now = do
   mr <- atomically $ do
@@ -346,6 +416,8 @@ doGen logger dom now = do
       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 (domQueue dom) . fmap playPacket)
diff --git a/minipat-dirt/src/Minipat/Dirt/Notes.hs b/minipat-dirt/src/Minipat/Dirt/Notes.hs
index 4f46494..50508dc 100644
--- a/minipat-dirt/src/Minipat/Dirt/Notes.hs
+++ b/minipat-dirt/src/Minipat/Dirt/Notes.hs
@@ -113,7 +113,7 @@ octNoteIsMidi (OctNote moct nn) =
 -- converting to/from MIDI values.
 newtype Note = Note {unNote :: Integer}
   deriving stock (Show)
-  deriving newtype (Eq, Ord)
+  deriving newtype (Eq, Ord, Pretty)
 
 c5MidiNum :: Integer
 c5MidiNum = 72
diff --git a/minipat-dirt/src/Minipat/Dirt/Osc.hs b/minipat-dirt/src/Minipat/Dirt/Osc.hs
index 40ec5f7..c8fa44a 100644
--- a/minipat-dirt/src/Minipat/Dirt/Osc.hs
+++ b/minipat-dirt/src/Minipat/Dirt/Osc.hs
@@ -17,14 +17,15 @@ import Control.Monad.Except (throwError)
 import Dahdit.Midi.Osc (Datum (..), Msg (..), Packet (..))
 import Dahdit.Midi.OscAddr (RawAddrPat)
 import Data.Foldable (foldl')
-import Data.Map.Strict qualified as Map
 import Data.Sequence (Seq (..))
 import Data.Sequence qualified as Seq
 import Data.Text (Text)
-import Minipat.Dirt.Attrs (Attrs, IsAttrs (..))
+import Minipat.Dirt.Attrs (Attrs, IsAttrs (..), attrsDelete, attrsInsert, attrsLookup, attrsToList)
 import Minipat.Stream (Ev (..), Tape, tapeToList)
 import Minipat.Time (CycleDelta (..), CycleTime (..), Span, spanCycle, spanDelta)
-import Nanotime (PosixTime, TimeDelta (..), addTime, timeDeltaFromFracSecs, timeDeltaToNanos)
+import Nanotime (PosixTime (..), TimeDelta (..), addTime, timeDeltaFromFracSecs, timeDeltaToNanos)
+import Prettyprinter (Pretty (..))
+import Prettyprinter qualified as P
 
 data Timed a = Timed
   { timedKey :: !PosixTime
@@ -32,14 +33,16 @@ data Timed a = Timed
   }
   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]
+
 namedPayload :: Attrs -> Seq Datum
-namedPayload = foldl' go Empty . Map.toList
+namedPayload = foldl' go Empty . attrsToList
  where
   go !acc (k, v) = acc :|> DatumString k :|> v
 
 data PlayErr
   = PlayErrDupe !Text
-  | PlayErrLate
   | PlayErrCont
   deriving stock (Eq, Ord, Show)
 
@@ -49,17 +52,17 @@ type M = Either PlayErr
 
 insertSafe :: Text -> Datum -> Attrs -> M Attrs
 insertSafe k v m =
-  case Map.lookup k m of
-    Nothing -> pure (Map.insert k v m)
+  case attrsLookup k m of
+    Nothing -> pure (attrsInsert k v m)
     Just _ -> throwError (PlayErrDupe k)
 
 replaceAliases :: [(Text, Text)] -> Attrs -> M Attrs
 replaceAliases as m0 = foldM go m0 as
  where
   go !m (x, y) = do
-    case Map.lookup x m of
+    case attrsLookup x m of
       Nothing -> pure m
-      Just v -> insertSafe y v (Map.delete x m)
+      Just v -> insertSafe y v (attrsDelete x m)
 
 -- Useful params:
 -- sound - string, req - name of sound
@@ -93,15 +96,12 @@ playAliases =
   , ("s", "sound")
   ]
 
-spanCycleM :: Span -> M CycleTime
-spanCycleM = maybe (throwError PlayErrLate) pure . spanCycle
-
 spanDeltaM :: Span -> M CycleDelta
 spanDeltaM = maybe (throwError PlayErrCont) pure . spanDelta
 
 data PlayEnv = PlayEnv
   { peStart :: !PosixTime
-  , peCycle :: !Integer
+  , peCycle :: !CycleTime
   , peCps :: !Rational
   }
   deriving stock (Eq, Ord, Show)
@@ -111,20 +111,31 @@ timeDeltaToMicros td =
   let (_, ns) = timeDeltaToNanos td
   in  fromIntegral ns / 1000
 
-convertEvent :: (IsAttrs a) => PlayEnv -> Ev a -> M (Timed Attrs)
-convertEvent (PlayEnv startTime startCyc cps) (Ev sp dat) = do
-  targetCyc <- fmap unCycleTime (spanCycleM sp)
-  let cycOffset = targetCyc - fromInteger startCyc
-      onset = addTime startTime (timeDeltaFromFracSecs (cycOffset / cps))
-  deltaCyc <- fmap unCycleDelta (spanDeltaM sp)
-  let deltaTime = timeDeltaToMicros (timeDeltaFromFracSecs (deltaCyc / cps))
-  dat' <- replaceAliases playAliases (toAttrs dat)
-  dat'' <- insertSafe "delta" (DatumFloat deltaTime) dat'
-  dat''' <- insertSafe "cps" (DatumFloat (realToFrac cps)) dat''
-  pure (Timed onset dat''')
+convertEvent :: (IsAttrs a) => PlayEnv -> Ev a -> M (Maybe (Timed Attrs))
+convertEvent (PlayEnv startTime startCyc cps) (Ev sp dat) =
+  case spanCycle 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 (toAttrs dat)
+      dat'' <- insertSafe "delta" (DatumFloat deltaTime) dat'
+      dat''' <- insertSafe "cps" (DatumFloat (realToFrac cps)) dat''
+      pure (Just (Timed onset dat'''))
+
+traverseMaybe :: (Monad m) => (a -> m (Maybe b)) -> Seq a -> m (Seq b)
+traverseMaybe f = go Empty
+ where
+  go !acc = \case
+    Empty -> pure acc
+    a :<| as' -> f a >>= maybe (go acc as') (\b -> go (acc :|> b) as')
 
 convertTape :: (IsAttrs a) => PlayEnv -> Tape a -> M (Seq (Timed Attrs))
-convertTape penv = traverse (convertEvent penv) . Seq.fromList . tapeToList
+convertTape penv = traverseMaybe (convertEvent penv) . Seq.fromList . tapeToList
 
 playAddr :: RawAddrPat
 playAddr = "/dirt/play"
diff --git a/minipat-dirt/src/Minipat/Dirt/Prelude.hs b/minipat-dirt/src/Minipat/Dirt/Prelude.hs
index 4d7a4cb..41e280f 100644
--- a/minipat-dirt/src/Minipat/Dirt/Prelude.hs
+++ b/minipat-dirt/src/Minipat/Dirt/Prelude.hs
@@ -38,12 +38,13 @@ import Data.Text qualified as T
 import Looksee qualified as L
 import Minipat.Ast (Ident (..), Select (..))
 import Minipat.Classes (Flow (..))
-import Minipat.Dirt.Attrs (Attr (..), Attrs, DatumProxy (..), IsAttrs (..))
+import Minipat.Dirt.Attrs (Attr (..), Attrs, DatumProxy (..), IsAttrs (..), attrsInsert, attrsMerge)
 import Minipat.Dirt.Notes (ChordName, Note (..), OctNote (..), Octave (..), convChordName, convNoteName, octToNote)
 import Minipat.EStream
 import Minipat.Eval (evalPat)
 import Minipat.Parser (P, identP, selectP)
 import Minipat.Time (CycleDelta, CycleTime)
+import Prettyprinter (Pretty (..))
 
 type S = EStream
 
@@ -92,7 +93,7 @@ ordP m pa =
 -- General combinators
 
 setIn, (#) :: (IsAttrs a, IsAttrs b) => S a -> S b -> S Attrs
-setIn = flowInnerApply (\m1 m2 -> toAttrs m2 <> toAttrs m1)
+setIn = flowInnerApply attrsMerge
 (#) = setIn
 
 attrPat :: Text -> S a -> S (Attr a)
@@ -109,8 +110,11 @@ data Sound = Sound
   }
   deriving stock (Eq, Ord, Show)
 
+instance Pretty Sound where
+  pretty (Sound so mn) = pretty so <> maybe mempty ((":" <>) . pretty) mn
+
 instance IsAttrs Sound where
-  toAttrs (Sound so mn) = Map.insert "sound" (DatumString (unIdent so)) (maybe Map.empty toAttrs mn)
+  toAttrs (Sound so mn) = attrsInsert "sound" (DatumString (unIdent so)) (maybe mempty toAttrs mn)
 
 soundP :: P Sound
 soundP = fmap (\(Select so mn) -> Sound so mn) (selectP identP noteP)
diff --git a/minipat-dirt/src/Minipat/Dirt/Test.hs b/minipat-dirt/src/Minipat/Dirt/Test.hs
index 155a2d3..08d226c 100644
--- a/minipat-dirt/src/Minipat/Dirt/Test.hs
+++ b/minipat-dirt/src/Minipat/Dirt/Test.hs
@@ -9,7 +9,7 @@ import Data.Foldable (for_)
 import Data.Ratio ((%))
 import Data.Sequence (Seq)
 import Minipat.Classes (patFastBy)
-import Minipat.Dirt.Attrs (Attrs, attrs)
+import Minipat.Dirt.Attrs (Attrs, attrsFromList)
 import Minipat.Dirt.Core
   ( OscConn
   , Resources (..)
@@ -64,7 +64,7 @@ testPlay = do
           convertTape penv $
             tapeSingleton $
               Ev (Span (Arc 0 1) (Just (Arc 0 1))) $
-                attrs
+                attrsFromList
                   [ ("sound", DatumString "tabla")
                   , ("orbit", DatumInt32 0)
                   ]
@@ -77,7 +77,7 @@ testReal = do
   withSt $ \st -> do
     withMVar (stRes st) (sendHandshake . resConn)
     let m =
-          attrs
+          attrsFromList
             [ ("sound", DatumString "cpu")
             , ("orbit", DatumInt32 0)
             ]
diff --git a/minipat/src/Minipat/Print.hs b/minipat/src/Minipat/Print.hs
index cefa136..db3ad6e 100644
--- a/minipat/src/Minipat/Print.hs
+++ b/minipat/src/Minipat/Print.hs
@@ -3,7 +3,9 @@
 -- | General utils for pretty-printing
 module Minipat.Print
   ( prettyShow
+  , prettyShowAll
   , prettyPrint
+  , prettyPrintAll
   , prettyTup
   , prettyRat
   , pretty
@@ -15,6 +17,7 @@ module Minipat.Print
   )
 where
 
+import Data.Foldable (toList)
 import Data.Ratio (denominator, numerator)
 import Data.Text (Text)
 import Data.Text.IO qualified as TIO
@@ -22,12 +25,21 @@ import Prettyprinter (Doc, Pretty (..))
 import Prettyprinter qualified as P
 import Prettyprinter.Render.Text qualified as PRT
 
+punctuated :: (Foldable f, Pretty a) => Text -> f a -> Doc ann
+punctuated t = P.hcat . P.punctuate (pretty t) . fmap pretty . toList
+
 prettyShow :: (Pretty a) => a -> Text
 prettyShow = PRT.renderStrict . P.layoutCompact . pretty
 
+prettyShowAll :: (Foldable f, Pretty a) => Text -> f a -> Text
+prettyShowAll t = PRT.renderStrict . P.layoutCompact . punctuated t
+
 prettyPrint :: (Pretty a) => a -> IO ()
 prettyPrint = TIO.putStrLn . prettyShow
 
+prettyPrintAll :: (Foldable f, Pretty a) => Text -> f a -> IO ()
+prettyPrintAll t = TIO.putStrLn . prettyShowAll t
+
 prettyTup :: (Pretty a) => a -> a -> Doc ann
 prettyTup el1 el2 = "(" <> pretty el1 <> ", " <> pretty el2 <> ")"
 
diff --git a/minipat/src/Minipat/Stream.hs b/minipat/src/Minipat/Stream.hs
index 677ef58..a9a2727 100644
--- a/minipat/src/Minipat/Stream.hs
+++ b/minipat/src/Minipat/Stream.hs
@@ -17,7 +17,7 @@ module Minipat.Stream
   , tapeToList
   , tapeConcatMap
   , tapeFromList
-  , Stream (..)
+  , Stream
   , streamFilter
   , streamBind
   , streamApply
@@ -51,6 +51,7 @@ import Control.Monad.Identity (Identity (..))
 import Data.Foldable (foldMap', foldl', toList)
 import Data.Heap (Entry (..), Heap)
 import Data.Heap qualified as H
+import Data.Maybe (mapMaybe)
 import Data.Semigroup (Semigroup (..))
 import Data.Sequence (Seq (..))
 import Data.Sequence qualified as Seq
@@ -64,8 +65,11 @@ import Minipat.Time
   , CycleTime (..)
   , MergeStrat (..)
   , Span (..)
+  , arcIntersect
   , arcMerge
+  , arcRelevant
   , arcTimeMapMono
+  , arcWiden
   , spanSplit
   , spanTimeMapMono
   , spanWholeMapMono
@@ -144,6 +148,15 @@ tapeConcatMap f = mconcat . fmap f . tapeToList
 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 ref = Tape . H.fromList . mapMaybe go . toList . unTape
+ where
+  go (Entry s a) =
+    if arcRelevant ref (spanActive s)
+      then Just (Entry (s {spanActive = arcIntersect ref (spanActive s)}) a)
+      else Nothing
+
 newtype Stream a = Stream {unStream :: Arc -> Tape a}
 
 instance Functor Stream where
@@ -159,12 +172,12 @@ instance Monad Stream where
 -- | '(<>)' is parallel composition of streams
 instance Semigroup (Stream a) where
   Stream k1 <> Stream k2 = Stream (\arc -> k1 arc <> k2 arc)
-  sconcat ss = Stream (\arc -> sconcat (fmap (`unStream` arc) ss))
+  sconcat ss = Stream (\arc -> sconcat (fmap (`streamRun` arc) ss))
 
 -- | 'mempty' is the empty stream
 instance Monoid (Stream a) where
   mempty = Stream (const mempty)
-  mconcat ss = Stream (\arc -> mconcat (fmap (`unStream` arc) ss))
+  mconcat ss = Stream (\arc -> mconcat (fmap (`streamRun` arc) ss))
 
 instance Alternative Stream where
   empty = mempty
@@ -175,9 +188,9 @@ streamFilter f (Stream k) = Stream (tapeFilter f . k)
 
 streamBindWith :: (Maybe Arc -> Maybe Arc -> Maybe Arc) -> Stream a -> (a -> Stream b) -> Stream b
 streamBindWith g pa f = Stream $ \arc ->
-  let ta = unStream pa arc
+  let ta = streamRun pa arc
   in  flip tapeConcatMap ta $ \(Ev (Span ac wh) a) ->
-        let tb = unStream (f a) ac
+        let tb = streamRun (f a) ac
         in  tapeWholeMapMono (g wh) tb
 
 streamBind :: MergeStrat -> Stream a -> (a -> Stream b) -> Stream b
@@ -189,8 +202,12 @@ 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 -> [Ev a]
-streamRun pa arc = tapeToList (unStream pa arc)
+streamRun :: Stream a -> Arc -> Tape a
+streamRun pa arc =
+  let arc' = arcWiden arc
+  in  if arc' == arc
+        then unStream 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)
@@ -228,7 +245,7 @@ streamSeq ss = Stream $ \arc ->
       go1 (i, Span subArc _) = tapeFastBy i w (snd (go2 i subArc))
       go2 i subArc = foldl' (go3 i subArc) (0, mempty) ss
       go3 i subArc (!o, !t) (p, v) =
-        (o + v, t <> tapeLateBy (CycleDelta o) (tapeSlowBy i v (unStream p subArc)))
+        (o + v, t <> tapeLateBy (CycleDelta o) (tapeSlowBy i v (streamRun p subArc)))
   in  mconcat (fmap go1 (spanSplit arc))
 
 streamRep :: Integer -> Stream a -> Stream a
@@ -237,7 +254,7 @@ streamRep n s = Stream $ \arc ->
   -- shift and concatenate n times, then speed everything up to fit into one cycle
   let go1 (i, Span subArc _) = tapeFastBy i (fromInteger n) (go2 subArc)
       go2 subArc =
-        let t = unStream s subArc
+        let t = streamRun s subArc
         in  mconcat (fmap (\k -> tapeLateBy (fromIntegral k) t) [0 .. n - 1])
   in  mconcat (fmap go1 (spanSplit arc))
 
@@ -265,7 +282,7 @@ streamRand ss =
         let s = arcSeed arc
             i = randInt l s
             t = Seq.index ss i
-        in  unStream t arc
+        in  streamRun t arc
   in  Stream (foldMap' (f . spanActive . snd) . spanSplit)
 
 streamAlt :: Seq (Stream a) -> Stream a
@@ -274,7 +291,7 @@ streamAlt ss =
       f z arc =
         let i = mod (fromInteger (unCycle z)) l
             t = Seq.index ss i
-        in  unStream t arc
+        in  streamRun t arc
   in  Stream (foldMap' (\(z, sp) -> f z (spanActive sp)) . spanSplit)
 
 streamPar :: Seq (Stream a) -> Stream a
@@ -283,9 +300,9 @@ streamPar = foldl' (<>) mempty
 streamSwitch :: Stream a -> CycleTime -> Stream a -> Stream a
 streamSwitch sa t sb = Stream $ \arc@(Arc s e) ->
   if
-    | t <= s -> unStream sb arc
-    | t >= e -> unStream sa arc
-    | otherwise -> unStream sa (Arc s t) <> unStream sb (Arc t e)
+    | t <= s -> streamRun sb arc
+    | t >= e -> streamRun sa arc
+    | otherwise -> streamRun sa (Arc s t) <> streamRun sb (Arc t e)
 
 streamPieces :: Stream a -> Seq (CycleTime, Stream a) -> Stream a
 streamPieces x = \case
diff --git a/minipat/src/Minipat/Time.hs b/minipat/src/Minipat/Time.hs
index e7901e8..790b3b3 100644
--- a/minipat/src/Minipat/Time.hs
+++ b/minipat/src/Minipat/Time.hs
@@ -9,6 +9,8 @@ module Minipat.Time
   , cycTimeCeil
   , cycTimeMid
   , Arc (..)
+  , arcWiden
+  , arcRelevant
   , arcUnion
   , arcIntersect
   , arcMid
@@ -70,6 +72,12 @@ data Arc = Arc {arcStart :: !CycleTime, arcEnd :: !CycleTime}
 instance Pretty Arc 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))
+
+arcRelevant :: Arc -> Arc -> Bool
+arcRelevant (Arc s1 e1) (Arc s2 e2) = s2 < e1 && (e2 > s1 || (s2 == s1 && e2 == s1))
+
 arcUnion :: Arc -> Arc -> Arc
 arcUnion (Arc s1 e1) (Arc s2 e2) = Arc (min s1 s2) (max e1 e2)
 
diff --git a/minipat/test/Main.hs b/minipat/test/Main.hs
index 56ef495..5248e3a 100644
--- a/minipat/test/Main.hs
+++ b/minipat/test/Main.hs
@@ -25,7 +25,7 @@ import Minipat.Interp (interpPat)
 import Minipat.Norm (normPat)
 import Minipat.Parser (Loc, P, ParseErr, factorP, identP, identPatP, selectIdentPatP)
 import Minipat.Print (prettyShow)
-import Minipat.Stream (Ev (..), Stream, streamRun)
+import Minipat.Stream (Ev (..), Stream, streamRun, tapeToList)
 import Minipat.Time (Arc (..), CycleTime (..), Span (..))
 import Minipat.Ur (ur)
 import Prettyprinter qualified as P
@@ -418,7 +418,7 @@ runPatInterpCase :: (TestName, Maybe Arc, 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
-      actualEvs = streamRun pat arc
+      actualEvs = tapeToList (streamRun pat arc)
   actualEvs @?= evs
 
 ev :: Rational -> Rational -> x -> Ev x
@@ -643,8 +643,8 @@ testPatInterpCases =
         , "[x , y , z]"
         ,
           [ ev 0 1 "x"
-          , ev 0 1 "z"
           , ev 0 1 "y"
+          , ev 0 1 "z"
           ] -- Note this order is arbitrary, just comes from heap behavior
         )
       ,
@@ -769,7 +769,7 @@ runUrCase (n, inpLen, inpPat, inpSubPats, inpSubXforms, mayExpectStr, expectEvs)
   let inpSubXforms'' = fmap (second runXform) inpSubXforms
   actualStream :: Stream Ident <- either throwIO pure (ur (fromInteger inpLen) inpPat inpSubPats'' inpSubXforms'')
   let arc = Arc 0 (fromInteger inpLen)
-      actualEvs = streamRun actualStream arc
+      actualEvs = tapeToList (streamRun actualStream arc)
   actualEvs @?= expectEvs
 
 testUr :: TestTree