Process.hs

{-# LANGUAGE BangPatterns #-}

module Zwirn.Doux.Process where

import Control.Concurrent (MVar, forkIO, modifyMVar_, threadDelay)
import Control.Concurrent.MVar (readMVar)
import Control.Monad (void)
import Data.Bifunctor (Bifunctor (..))
import Data.List
import qualified Data.Map as Map
import qualified Data.Text as T
import Data.Tuple (swap)
import Data.Word (Word64)
import Sound.Doux.Engine
import Sound.Tidal.Clock
import qualified Sound.Tidal.Clock as Clock
import Sound.Tidal.Link (Micros, SessionState, clock)
import Zwirn.Core.Query (findAllValuesWithTimePrec, findAllValuesWithTimeStatePrec)
import qualified Zwirn.Core.Time as Z
import Zwirn.Core.Types (ToList (..), Value (..), unzwirn)
import Zwirn.Language.Evaluate (Expression (..), ExpressionMap, toExp)
import Zwirn.Language.Evaluate.Expression (Zwirn)
import Zwirn.Language.Play

tickAction ::
  Doux ->
  MVar PlayMap ->
  MVar ActionMap ->
  MVar BusMap ->
  MVar ExpressionMap ->
  Time ->
  (Time, Time) ->
  Double ->
  ClockConfig ->
  ClockRef ->
  (SessionState, SessionState) ->
  IO ()
tickAction d pMV acMV busMV stMV prec (star, end) nudge cconf cref (ss, _) = do
  vs <- processPlayMap prec (star, end) pMV stMV
  bs <- processBusMap prec (star, end) busMV stMV
  as <- processActionMap prec (star, end) acMV stMV
  mapM_ (tickAndSend d False nudge cconf cref ss) vs
  mapM_ (tickAndSendBus d nudge cconf cref ss) bs
  mapM_ (execAction nudge cconf cref ss) as
  updateTempo cconf cref stMV

processPlayMap :: Time -> (Time, Time) -> MVar PlayMap -> MVar ExpressionMap -> IO [(Z.Time, Expression)]
processPlayMap prec (star, end) pMV stMV = do
  pm <- readMVar pMV
  let ps = resolvePlayMap pm
  st <- readMVar stMV

  let (enst, vs) = mapAccumL (\ !s (Targeted _ p) -> swap $ findAllValuesWithTimeStatePrec (Z.Time prec 0) (Z.Time (align prec star) 1, Z.Time (align prec end) 1) s p) st ps
  modifyMVar_ stMV (const $ return enst)
  return $ concat vs

processBusMap :: Time -> (Time, Time) -> MVar BusMap -> MVar ExpressionMap -> IO [(Int, Z.Time, Expression)]
processBusMap prec (star, end) busMV stMV = do
  bm <- readMVar busMV
  let bs = Map.toList bm
  st <- readMVar stMV

  return $ concatMap (\(i, Targeted _ p) -> map (\(x, y) -> (i, x, y)) $ findAllValuesWithTimePrec (Z.Time prec 0) (Z.Time (align prec star) 1, Z.Time (align prec end) 1) st p) bs

processActionMap :: Time -> (Time, Time) -> MVar ActionMap -> MVar ExpressionMap -> IO [(Z.Time, IO ())]
processActionMap prec (star, end) zMV stMV = do
  pm <- readMVar zMV
  let ps = Map.elems pm
  st <- readMVar stMV

  let (_, vs) = mapAccumL (\ !s p -> swap $ findAllValuesWithTimeStatePrec (Z.Time prec 0) (Z.Time (align prec star) 1, Z.Time (align prec end) 1) s p) st ps

  return $ map (second expressionToAction) (concat vs)

align :: Time -> Time -> Time
align prec t = fromIntegral (floor $ t / prec :: Int) * prec

expressionToPath :: Expression -> IO String
expressionToPath (ENum x) = return $ show x
expressionToPath (EText x) = return $ T.unpack x
expressionToPath (EMap x) = do
  xs <- mapM (\(k, v) -> (\y -> T.unpack k ++ "/" ++ y) <$> expressionToPath v) $ Map.toList x
  return $ intercalate "/" xs
expressionToPath (EAction x) = forkIO x >> return ""
expressionToPath _ = return ""

expressionToAction :: Expression -> IO ()
expressionToAction (EAction x) = x
expressionToAction _ = return ()

expressionToPathSound :: Expression -> Double -> IO (Maybe (String, String))
expressionToPathSound (EMap m) gate = case Map.lookup "s" gm of
  Just s -> do
    samp <- expressionToPath s
    rest <- expressionToPath (EMap $ Map.delete "s" gm)
    return $ Just ("sound/" ++ samp, rest)
  Nothing -> return Nothing
  where
    gm =
      Map.alter altGate "gate"
        . Map.alter altOrbitFx "feedback"
        . Map.alter altOrbitFx "verb"
        . Map.alter altOrbitFx "delay"
        . Map.alter altOrbitFx "comb"
        $ m
    altGate (Just x) = Just x
    altGate Nothing = Just (ENum gate)
    altOrbitFx (Just x) = Just x
    altOrbitFx Nothing = Just (ENum 0)
expressionToPathSound (EAction x) _ = forkIO x >> return Nothing
expressionToPathSound _ _ = return Nothing

tickAndSend :: Doux -> Bool -> Double -> ClockConfig -> ClockRef -> SessionState -> (Z.Time, Expression) -> IO ()
tickAndSend d immediate nudge cconf cref ss (Z.Time r s, ex) = do
  let onBeat = Clock.cyclesToBeat cconf (fromRational r)

  on <- Clock.timeAtBeat cconf ss onBeat
  tic <- scheduleAtLink d cref nudge on
  cps <- getCPS cconf cref

  let gate = fromRational $ 1 / (cps * s) :: Double

  mpath <- expressionToPathSound ex gate

  case mpath of
    Just (sound, path) -> if immediate then void (eval d (sound ++ "/" ++ path)) else void (eval d (sound ++ "/tick/" ++ show tic ++ "/" ++ path))
    Nothing -> return ()

tickAndSendBus :: Doux -> Double -> ClockConfig -> ClockRef -> SessionState -> (Int, Z.Time, Expression) -> IO ()
tickAndSendBus d nudge cconf cref ss (bus, t, ex) = do
  let onBeat = Clock.cyclesToBeat cconf ((\(Z.Time r _) -> fromRational r :: Double) t)

  on <- Clock.timeAtBeat cconf ss onBeat
  tic <- scheduleAtLink d cref nudge on

  path <- expressionToPath ex

  void (eval d ("tick/" ++ show tic ++ "/" ++ path ++ "/voice/" ++ show bus))

-- | execAction runs actions in the action map. this is quite inefficient, since for every action a separate green thread is spawned
-- | eventually we should probably have a separate thread for running actions that reacts to a queue
execAction :: Double -> ClockConfig -> ClockRef -> SessionState -> (Z.Time, IO ()) -> IO ()
execAction nudge cconf cref ss (t, action) = do
  let onBeat = Clock.cyclesToBeat cconf ((\(Z.Time r _) -> fromRational r :: Double) t)
  on <- Clock.timeAtBeat cconf ss onBeat
  nowLink <- clock (rAbletonLink cref)
  let delay = max 0 (on - nowLink - round (nudge * 1000))
  void $ forkIO $ do
    threadDelay (fromIntegral delay)
    action

updateTempo :: ClockConfig -> ClockRef -> MVar ExpressionMap -> IO ()
updateTempo cconf cref stMV = do
  bpm <- realToFrac <$> Clock.getBPM cref
  cps <- realToFrac <$> Clock.getCPS cconf cref
  modifyMVar_ stMV (return . Map.insert "_cps" (toExp (pure cps :: Zwirn Double)) . Map.insert "_tempo" (toExp (pure bpm :: Zwirn Double)))

tickActionOnce ::
  Doux ->
  MVar PlayMap ->
  MVar ExpressionMap ->
  Time ->
  (Time, Time) ->
  Double ->
  ClockConfig ->
  ClockRef ->
  (SessionState, SessionState) ->
  IO ()
tickActionOnce d pMV stMV _ (star, _) nudge cconf cref (ss, _) = do
  vs <- processPlayMapOnce star pMV stMV
  mapM_ (tickAndSend d True nudge cconf cref ss) vs

scheduleAtLink :: Doux -> ClockRef -> Double -> Micros -> IO Word64
scheduleAtLink doux cref nudge targetLinkTime = do
  liveTick <- currentTick doux
  nowLink <- clock (rAbletonLink cref)
  sr <- sampleRate doux
  let deltaMicros = targetLinkTime - nowLink
      deltaTicks = round (fromIntegral deltaMicros * realToFrac sr / 1000000 :: Double)
      nudgeTicks = round (nudge * 1000 * realToFrac sr / 1000000) :: Word64
      actual = if liveTick + deltaTicks > nudgeTicks then liveTick + deltaTicks - nudgeTicks else liveTick + deltaTicks
  return actual

processPlayMapOnce :: Time -> MVar PlayMap -> MVar ExpressionMap -> IO [(Z.Time, Expression)]
processPlayMapOnce star pMV stMV = do
  pm <- readMVar pMV
  let ps = resolvePlayMap pm
  st <- readMVar stMV

  let func !s (Targeted _ p) = (s, map (\(v, _) -> (Z.Time star (Z.tDiff $ time v), value v)) $ toList $ unzwirn p (Z.Time star 1) s)
      (enst, vs) = mapAccumL func st ps
  modifyMVar_ stMV (const $ return enst)
  return $ concat vs