Process.hs

{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Use mapMaybe" #-}

module Zwirn.Stream.Process where

import Control.Concurrent.MVar (MVar, modifyMVar_, readMVar)
import Data.Bifunctor (first)
import Data.List (mapAccumL)
import qualified Data.Map as Map
import Data.Maybe (catMaybes)
import qualified Data.Text as T
import Data.Tuple (swap)
import qualified Sound.Osc as O
import qualified Sound.Osc.Transport.Fd.Udp as O
import Sound.Tidal.Clock
import qualified Sound.Tidal.Clock as Clock
import Sound.Tidal.Link
import Zwirn.Core.Lib.Core (apply)
import Zwirn.Core.Query
import qualified Zwirn.Core.Time as Z
import Zwirn.Language.Evaluate.Expression
import Zwirn.Stream.Target
import Zwirn.Stream.Types

tickAction ::
  MVar PlayMap -> -- maps from channels to expressions
  MVar ActionMap -> -- maps from channels to expressions
  MVar BusMap -> -- maps from busses to expressions
  MVar ExpressionMap -> -- state map
  MVar [Int] -> -- bus mapping
  TargetMap -> -- targets
  O.Udp -> -- local address
  Time -> -- precision
  (Time, Time) -> -- arc of the current tick
  Double -> -- nudge
  ClockConfig -> -- configuration of the clock
  ClockRef -> -- reference to the clock
  (SessionState, SessionState) ->
  IO ()
tickAction zMV actionMapMV busMapMV stMV bussesMV targetMap local prec (star, end) nudge cconf cref (ss, _) = do
  cps <- Clock.getCPS cconf cref
  vs <- processPlayMap prec (star, end) cps zMV stMV
  bs <- processBusMap prec (star, end) busMapMV stMV bussesMV
  processActionMap prec (star, end) cps actionMapMV stMV
  mapM_ (stampAndSend targetMap False local nudge cconf cref ss) vs
  mapM_ (stampAndSend targetMap True local nudge cconf cref ss . (\(Targeted ts (t, m)) -> Targeted ts (t, Just m))) bs

processPlayMap :: Time -> (Time, Time) -> Time -> MVar PlayMap -> MVar ExpressionMap -> IO [Targeted (Z.Time, Maybe (T.Text -> O.Message))]
processPlayMap prec (star, end) cps zMV stMV = do
  pm <- readMVar zMV
  let ps = resolvePlayMap pm
  st <- readMVar stMV

  let (enst, vs) = mapAccumL (\ !s (Targeted ts p) -> swap $ first (Targeted ts) $ 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)
  let func (t, ex) = expressionToMessage (fromIntegral (floor t :: Int)) (realToFrac cps) ex >>= \m -> return (t, m)

  concat <$> mapM (\targ -> (\(Targeted ts xs) -> mapM (fmap (Targeted ts) . func) xs) targ) vs

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

  let (enst, 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

  modifyMVar_ stMV (const $ return enst)
  mapM_ (\(t, ex) -> expressionToMessage (fromIntegral (floor t :: Int)) (realToFrac cps) ex >>= \m -> return (t, m)) (concat vs)

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

  concat <$> mapM (\(i, Targeted ts x) -> map (Targeted ts) <$> busToMessage prec (star, end) busses st (i, x)) bs

busToMessage :: Time -> (Time, Time) -> [Int] -> ExpressionMap -> (Int, Zwirn Expression) -> IO [(Z.Time, T.Text -> O.Message)]
busToMessage prec (star, end) busses st (i, p) = do
  let vs = findAllValuesWithTimePrec (Z.Time prec 0) (Z.Time (align prec star) 1, Z.Time (align prec end) 1) st p

  mapM (\(t, ex) -> busExpressionToMessage (toBus busses i) ex >>= \m -> return (t, m)) vs

toBus :: [Int] -> Int -> Int
toBus [] i = i
toBus xs i = xs !! (i `mod` length xs)

applyFx :: Targeted (PlayState, Zwirn Expression, Maybe (Zwirn (Zwirn Expression -> Zwirn Expression))) -> Targeted (Zwirn Expression)
applyFx (Targeted ts (_, x, Nothing)) = Targeted ts x
applyFx (Targeted ts (_, x, Just fx)) = Targeted ts (apply fx x)

resolvePlayMap :: PlayMap -> [Targeted (Zwirn Expression)]
resolvePlayMap pm = if null ss then map applyFx rs else map applyFx ss
  where
    ps = Map.elems pm
    ss = filter (\(Targeted _ (x, _, _)) -> x == Solo) ps
    rs = filter (\(Targeted _ (x, _, _)) -> x == Normal) ps

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

----------------------------------------------------------
-------------- expressions --> osc messages --------------
----------------------------------------------------------

expressionToMessage :: Double -> Double -> Expression -> IO (Maybe (T.Text -> O.Message))
expressionToMessage cyc cps ex = do
  os <- expressionToOSC ex
  let additionalData = [O.string "cps", O.float cps, O.string "cycle", O.float cyc]
  if null os
    then return Nothing
    else return $ Just $ \pat -> O.message (T.unpack pat) (additionalData ++ os)

busExpressionToMessage :: Int -> Expression -> IO (T.Text -> O.Message)
busExpressionToMessage bus ex = do
  os <- expressionToOSC ex
  return $ \path -> O.message (T.unpack path) (O.int32 bus : os)

expressionToOSC :: Expression -> IO [O.Datum]
expressionToOSC (ENum n) = return [O.float n]
expressionToOSC (EText n) = return [O.string $ T.unpack n]
expressionToOSC (EMap m) = concat <$> mapM (\(k, v) -> expressionToOSC v >>= \xs -> return $ O.string (T.unpack k) : xs) (Map.toList m)
expressionToOSC (EAction a) = a >> return []
expressionToOSC _ = return []

----------------------------------------------
-------------- sending messages --------------
----------------------------------------------

defaultLatency :: Double
defaultLatency = 0.2

stampAndSend :: TargetMap -> Bool -> O.Udp -> Double -> ClockConfig -> ClockRef -> SessionState -> Targeted (Z.Time, Maybe (T.Text -> O.Message)) -> IO ()
stampAndSend _ _ _ _ _ _ _ (Targeted _ (_, Nothing)) = return ()
stampAndSend targetMap bus local nudge cconf cref ss (Targeted ts (t, Just msg)) = do
  let onBeat = Clock.cyclesToBeat cconf ((\(Z.Time r _) -> fromRational r :: Double) t)
  let targs = catMaybes $ map (`Map.lookup` targetMap) ts
  let getBusTargets (Target _ path _ (Just addr)) = [(path, addr)]
      getBusTargets (Target _ _ _ Nothing) = []
  let addrs = if bus then concatMap getBusTargets targs else map (\x -> (tOSCPath x, tAddress x)) targs

  on <- Clock.timeAtBeat cconf ss onBeat
  onOSC <- Clock.linkToOscTime cref on

  mapM_ (\(path, addr) -> sendMessage addr local defaultLatency nudge (onOSC, msg path)) addrs

sendMessage :: RemoteAddress -> O.Udp -> Double -> Double -> (Double, O.Message) -> IO ()
sendMessage remote local latency extraLatency (time, m) = sendBndl $ O.Bundle timeWithLatency [m]
  where
    timeWithLatency = time - latency + extraLatency
    sendBndl bndl = O.sendTo local (O.Packet_Bundle bndl) remote

-------------------------------------------------
------------------- utilities -------------------
-------------------------------------------------

updateState :: MVar ExpressionMap -> [ExpressionMap] -> IO ()
updateState _ [] = return ()
updateState stmv (st : _) = modifyMVar_ stmv (const $ return st)