diff --git a/minipat-dirt/src/Minipat/Dirt/Prelude.hs b/minipat-dirt/src/Minipat/Dirt/Prelude.hs index 79d32e3..5b8ae50 100644 --- a/minipat-dirt/src/Minipat/Dirt/Prelude.hs +++ b/minipat-dirt/src/Minipat/Dirt/Prelude.hs @@ -6,7 +6,7 @@ import Control.Applicative (empty) import Control.Concurrent (forkFinally) import Control.Concurrent.Async (async, cancel, waitCatch) import Control.Concurrent.STM (atomically) -import Control.Concurrent.STM.TVar (TVar, newTVarIO, readTVar, writeTVar) +import Control.Concurrent.STM.TVar (TVar, modifyTVar', newTVarIO, readTVar, readTVarIO, writeTVar) import Control.Exception (SomeException, bracket, throwIO) import Control.Monad.IO.Class (liftIO) import Dahdit.Midi.Osc (Datum (..), Packet) @@ -19,7 +19,7 @@ import Minipat.Dirt.Osc qualified as O import Minipat.Dirt.Ref (Ref, ReleaseVar) import Minipat.Dirt.Ref qualified as R import Minipat.Time qualified as T -import Nanotime (PosixTime (..), TimeDelta, currentTime, threadDelayDelta, timeDeltaFromFracSecs) +import Nanotime (PosixTime (..), TimeDelta, TimeLike (..), threadDelayDelta, timeDeltaFromFracSecs) import Network.Socket qualified as NS data Env = Env @@ -74,8 +74,34 @@ reinitDomain env dom = do writeTVar (domCycle dom) 0 writeTVar (domPat dom) empty +getDawn :: St -> IO PosixTime +getDawn = readTVarIO . domDawn . stDom + +getCps :: St -> IO Rational +getCps = readTVarIO . domCps . stDom + +getAhead :: St -> IO TimeDelta +getAhead = readTVarIO . domAhead . stDom + +getPlaying :: St -> IO Bool +getPlaying = readTVarIO . domPlaying . stDom + +getPat :: St -> IO (B.Pat O.OscMap) +getPat = readTVarIO . domPat . stDom + +getCycle :: St -> IO Integer +getCycle = readTVarIO . domCycle . stDom + setCps :: St -> Rational -> IO () -setCps = undefined -- NOTE have to change dawn + ahead +setCps st cps' = atomically $ do + let dom = stDom st + dawn <- readTVar (domDawn dom) + cps <- readTVar (domCps dom) + cyc <- readTVar (domCycle dom) + let dawn' = addTime dawn (timeDeltaFromFracSecs (fromInteger cyc * (cps' - cps))) + writeTVar (domDawn dom) dawn' + writeTVar (domCps dom) cps' + writeTVar (domAhead dom) (timeDeltaFromFracSecs (1 / cps')) setPlaying :: St -> Bool -> IO () setPlaying st x = atomically (writeTVar (domPlaying (stDom st)) x) @@ -84,13 +110,32 @@ setPat :: St -> B.Pat O.OscMap -> IO () setPat st x = atomically (writeTVar (domPat (stDom st)) x) setCycle :: St -> Integer -> IO () -setCycle st x = +setCycle st cyc' = atomically $ do let dom = stDom st - in atomically $ do - dawn <- readTVar (domDawn dom) - cps <- readTVar (domCps dom) - cyc <- readTVar (domCycle dom) - error "TODO" + dawn <- readTVar (domDawn dom) + cps <- readTVar (domCps dom) + cyc <- readTVar (domCycle dom) + let dawn' = addTime dawn (timeDeltaFromFracSecs (cps * fromInteger (cyc' - cyc))) + writeTVar (domDawn dom) dawn' + writeTVar (domCycle dom) cyc' + +data Record = Record + { recDawn :: !PosixTime + , recCps :: !Rational + , recTape :: !(B.Tape O.OscMap) + } + deriving stock (Eq, Ord, Show) + +advanceCycle :: St -> IO Record +advanceCycle st = atomically $ do + let dom = stDom st + dawn <- readTVar (domDawn dom) + cps <- readTVar (domCps dom) + cyc <- fmap fromInteger (readTVar (domCycle dom)) + pat <- readTVar (domPat dom) + let tape = B.unPat pat (T.Arc cyc (cyc + 1)) + modifyTVar' (domCycle dom) (+ 1) + pure (Record dawn cps tape) data OscConn = OscConn { ocTargetAddr :: !NS.SockAddr @@ -185,9 +230,24 @@ testPlay = do testLoop :: IO () testLoop = do - tdv <- newTVarIO (timeDeltaFromFracSecs @Double 0.5) withSt $ \st -> do + let tdv = domAhead (stDom st) _ <- R.refLoop (stRel st) tdv $ do putStrLn "hello" pure Nothing threadDelayDelta (timeDeltaFromFracSecs @Double 2) + +testRecord :: IO () +testRecord = do + withSt $ \st -> do + setPat st $ + pure $ + Map.fromList + [ ("s", DatumString "tabla") + ] + let tdv = domAhead (stDom st) + _ <- R.refLoop (stRel st) tdv $ do + r <- advanceCycle st + print r + pure Nothing + threadDelayDelta (timeDeltaFromFracSecs @Double 3)