etc

minipat-dirt/src/Minipat/Dirt/Osc.hs

@@ -5,18 +5,17 @@ module Minipat.Dirt.Osc where
 import Control.Exception (Exception)
 import Control.Monad (foldM)
 import Control.Monad.Except (throwError)
-import Control.Monad.State.Strict (MonadState (..), StateT, execStateT)
-import Control.Monad.Trans (lift)
 import Dahdit.Midi.Osc (Datum (..), Msg (..), Packet (..))
 import Dahdit.Midi.OscAddr (RawAddrPat)
 import Data.Foldable (foldl')
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
 import Data.Sequence (Seq (..))
+import Data.Sequence qualified as Seq
 import Data.Text (Text)
 import Minipat.Base qualified as B
 import Minipat.Time qualified as T
-import Nanotime (PosixTime, TimeDelta, addTime)
+import Nanotime (PosixTime, TimeDelta, addTime, timeDeltaFromFracSecs)
 
 type OscMap = Map Text Datum
 
@@ -87,70 +86,46 @@ spanCycleM = maybe (throwError OscErrLate) (pure . (/ 1000)) . T.spanCycle
 spanDeltaM :: T.Span -> M Rational
 spanDeltaM = maybe (throwError OscErrCont) pure . T.spanDelta
 
-modSt :: (Monad m) => (s -> m s) -> StateT s m ()
-modSt f = get >>= lift . f >>= put
-
-datFloat :: Rational -> Datum
-datFloat = DatumFloat . fromRational
+data PlayEnv = PlayEnv
+  { peStart :: !PosixTime
+  , peCycle :: !Integer
+  , peCps :: !Rational
+  }
+  deriving stock (Eq, Ord, Show)
 
-evToPayload :: Rational -> B.Ev OscMap -> M OscMap
-evToPayload _cps (B.Ev _sp dat0) = flip execStateT dat0 $ do
-  modSt $ replaceAliases playAliases
+data PlayEvent = PlayEvent
+  { peOnset :: !PosixTime
+  , peLength :: !TimeDelta
+  , peData :: !OscMap
+  }
+  deriving stock (Eq, Ord, Show)
 
--- modSt $ insertSafe "cps" (datFloat cps)
--- modSt $ \dat -> do
---   cyc <- spanCycleM sp
---   insertSafe "cycle" (datFloat cyc) dat
--- modSt $ \dat -> do
---   del <- spanDeltaM sp
---   insertSafe "delta" (datFloat del) dat
+convertEvent :: PlayEnv -> B.Ev OscMap -> M PlayEvent
+convertEvent (PlayEnv startTime startCyc cps) (B.Ev sp dat) = do
+  target <- spanCycleM sp
+  let cycOffset = target - fromInteger startCyc
+      onset = addTime startTime (timeDeltaFromFracSecs (cps * cycOffset))
+  delta <- spanDeltaM sp
+  let len = timeDeltaFromFracSecs (cps * delta)
+  dat' <- replaceAliases playAliases dat
+  pure (PlayEvent onset len dat')
 
--- Each time delta is against origin
-tapeToPayloads :: Rational -> B.Tape OscMap -> M (Maybe (Rational, Seq (TimeDelta, OscMap)))
-tapeToPayloads cps tape = go1
- where
-  go1 = case B.tapeToList tape of
-    [] -> pure Nothing
-    evs@(B.Ev sp _ : _) -> do
-      origin <- spanCycleM sp
-      go2 origin Empty evs
-  go2 !origin !acc = \case
-    [] -> pure (Just (origin, acc))
-    ev@(B.Ev sp _) : evs' -> do
-      target <- spanCycleM sp
-      let td = T.relDelta cps origin target
-      pl <- evToPayload cps ev
-      go2 origin (acc :|> (td, pl)) evs'
+convertTape :: PlayEnv -> B.Tape OscMap -> M (Seq PlayEvent)
+convertTape penv = traverse (convertEvent penv) . Seq.fromList . B.tapeToList
 
 playAddr :: RawAddrPat
 playAddr = "/dirt/play"
 
-data PlayRecord = PlayRecord
-  { prDawn :: !PosixTime
-  , prCps :: !Rational
-  , prTape :: !(B.Tape OscMap)
-  }
-  deriving stock (Eq, Ord, Show)
-
 data TimedPacket = TimedPacket
   { tpTime :: !PosixTime
   , tpPacket :: !Packet
   }
   deriving stock (Eq, Ord, Show)
 
-playPackets :: PlayRecord -> M (Seq TimedPacket)
-playPackets (PlayRecord dawn cps tape) = go1
- where
-  go1 = do
-    flip fmap (tapeToPayloads cps tape) $ \case
-      Nothing -> Empty
-      Just (originCy, pls) ->
-        let originTm = addTime dawn (T.cycleToDelta cps originCy)
-        in  fmap (go2 originTm) pls
-  go2 originTm (td, pl) =
-    let tm = addTime originTm td
-        pkt = PacketMsg (Msg playAddr (namedPayload pl))
-    in  TimedPacket tm pkt
+playPacket :: PlayEvent -> TimedPacket
+playPacket (PlayEvent time _ dat) =
+  let pkt = PacketMsg (Msg playAddr (namedPayload dat))
+  in  TimedPacket time pkt
 
 handshakeAddr :: RawAddrPat
 handshakeAddr = "/dirt/handshake"

minipat-dirt/src/Minipat/Dirt/Prelude.hs

@@ -17,6 +17,7 @@ import Data.Acquire (Acquire)
 import Data.Foldable (for_)
 import Data.Map.Strict qualified as Map
 import Data.Ratio ((%))
+import Data.Sequence (Seq)
 import Minipat.Base qualified as B
 import Minipat.Dirt.Osc qualified as O
 import Minipat.Dirt.Ref (Ref, RelVar)
@@ -111,15 +112,20 @@ setPat st x = atomically (writeTVar (domPat (stDom st)) x)
 setCycle :: St -> Integer -> IO ()
 setCycle st x = atomically (writeTVar (domCycle (stDom st)) x)
 
-advanceCycle :: Domain -> PosixTime -> STM O.PlayRecord
-advanceCycle dom now = do
+readEvents :: Domain -> PosixTime -> STM (O.PlayEnv, Either O.OscErr (Seq O.PlayEvent))
+readEvents dom now = do
+  ahead <- readTVar (domAhead dom)
   cps <- readTVar (domCps dom)
-  cyc <- fmap fromInteger (readTVar (domCycle dom))
+  cyc <- readTVar (domCycle dom)
   pat <- readTVar (domPat dom)
-  let tape = B.unPat pat (T.Arc cyc (cyc + 1))
-      dawn = addTime now (negate (timeDeltaFromFracSecs (cps * cyc)))
-  modifyTVar' (domCycle dom) (+ 1)
-  pure (O.PlayRecord dawn cps tape)
+  let tape = B.unPat pat (T.Arc (fromInteger cyc) (fromInteger cyc + 1))
+      origin = addTime now ahead
+      penv = O.PlayEnv origin cyc cps
+      mpevs = O.convertTape penv tape
+  pure (penv, mpevs)
+
+advanceCycle :: Domain -> STM ()
+advanceCycle dom = modifyTVar' (domCycle dom) (+ 1)
 
 data OscConn = OscConn
   { ocTargetAddr :: !NS.SockAddr
@@ -183,24 +189,29 @@ runGenTask dom = do
   mr <- atomically $ do
     playing <- readTVar (domPlaying dom)
     if playing
-      then fmap Just (advanceCycle dom now)
+      then fmap Just (readEvents dom now)
       else pure Nothing
   case mr of
     Nothing -> pure ()
-    Just r ->
-      case O.playPackets r of
+    Just (_, mpevs) ->
+      case mpevs of
         Left err -> throwIO err
-        Right tps -> for_ tps (atomically . writeTQueue (domQueue dom))
+        Right pevs -> atomically $ do
+          advanceCycle dom
+          for_ pevs (writeTQueue (domQueue dom) . O.playPacket)
   pure Nothing
 
 runSendTask :: Ref OscConn -> Domain -> IO ()
 runSendTask conn dom = go
  where
   go = do
-    O.TimedPacket tm pkt <- atomically (readTQueue (domQueue dom))
+    tp@(O.TimedPacket tm pkt) <- atomically (readTQueue (domQueue dom))
     now <- currentTime
-    threadDelayDelta (diffTime now tm)
+    print now
+    print tp
+    threadDelayDelta (diffTime tm now)
     sendPacket conn pkt
+    go
 
 sendPacket :: Ref OscConn -> Packet -> IO ()
 sendPacket conn pkt = R.refUse conn $ \case
@@ -224,12 +235,13 @@ recvPkt st = R.refUse (stConn st) $ \case
 sendHandshake :: Ref OscConn -> IO ()
 sendHandshake conn = sendPacket conn O.handshakePacket
 
-sendPlay :: Ref OscConn -> O.PlayRecord -> IO ()
-sendPlay conn pr =
-  case O.playPackets pr of
+sendPlay :: Ref OscConn -> Either O.OscErr (Seq O.PlayEvent) -> IO ()
+sendPlay conn mpevs =
+  case mpevs of
     Left err -> throwIO err
-    Right tps ->
-      for_ tps $ \tp@(O.TimedPacket tm pkt) -> do
+    Right pevs ->
+      for_ pevs $ \pev -> do
+        let tp@(O.TimedPacket tm pkt) = O.playPacket pev
         print tp
         now <- currentTime
         threadDelayDelta (diffTime now tm)
@@ -253,8 +265,9 @@ testPlay = do
     dawn <- currentTime
     putStrLn ("sending play @ " <> show dawn)
     let cps = 1 % 2
+        penv = O.PlayEnv dawn 0 cps
     sendPlay (stConn st) $
-      O.PlayRecord dawn cps $
+      O.convertTape penv $
         B.tapeSingleton $
           B.Ev (T.Span (T.Arc 0 1) (Just (T.Arc 0 1))) $
             Map.fromList
@@ -275,15 +288,16 @@ testLoop = do
 testRecord :: IO ()
 testRecord = do
   withSt $ \st -> do
+    let dom = stDom st
     setPat st $
       pure $
         Map.fromList
           [ ("s", DatumString "tabla")
           ]
-    let tdv = domAhead (stDom st)
+    let tdv = domAhead dom
     _ <- R.refCreate (stRel st) $ R.acquireLoop tdv $ do
       now <- currentTime
-      r <- atomically (advanceCycle (stDom st) now)
+      r <- atomically (readEvents dom now <* advanceCycle dom)
       print r
       pure Nothing
     threadDelayDelta (timeDeltaFromFracSecs @Double 3)