diff --git a/minipat-dirt/src/Minipat/Dirt/Osc.hs b/minipat-dirt/src/Minipat/Dirt/Osc.hs index f850d56..b8e8184 100644 --- a/minipat-dirt/src/Minipat/Dirt/Osc.hs +++ b/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" diff --git a/minipat-dirt/src/Minipat/Dirt/Prelude.hs b/minipat-dirt/src/Minipat/Dirt/Prelude.hs index 138e035..14c7d8f 100644 --- a/minipat-dirt/src/Minipat/Dirt/Prelude.hs +++ b/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)