{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-}

module Sound.Tidal.Stream.Process where

{-
    Process.hs - Tidal's thingie for turning patterns into OSC streams
    Copyright (C) 2020, Alex McLean and contributors

    This library is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this library.  If not, see <http://www.gnu.org/licenses/>.
-}

import Control.Applicative ((<|>))
import Control.Concurrent.MVar
  ( MVar,
    modifyMVar_,
    newMVar,
    putMVar,
    readMVar,
    takeMVar,
  )
import qualified Control.Exception as E
import Control.Monad (forM_, when)
import Data.Coerce (coerce)
import Data.List (sortOn)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, fromJust, fromMaybe)
import qualified Sound.Osc.Fd as O
import qualified Sound.Tidal.Clock as Clock
import Sound.Tidal.Core (stack, (#))
import Sound.Tidal.ID (ID (fromID))
import qualified Sound.Tidal.Link as Link
import Sound.Tidal.Params (pS)
import Sound.Tidal.Pattern
import Sound.Tidal.Pattern.Types (patternTimeID)
import Sound.Tidal.Show ()
import Sound.Tidal.Stream.Target (send)
import Sound.Tidal.Stream.Types
import Sound.Tidal.Utils ((!!!))
import System.IO (hPutStrLn, stderr)

data ProcessedEvent = ProcessedEvent
  { ProcessedEvent -> Bool
peHasOnset :: Bool,
    ProcessedEvent -> Event ValueMap
peEvent :: Event ValueMap,
    ProcessedEvent -> Double
peCps :: Double,
    ProcessedEvent -> Micros
peDelta :: Link.Micros,
    ProcessedEvent -> Rational
peCycle :: Time,
    ProcessedEvent -> Micros
peOnWholeOrPart :: Link.Micros,
    ProcessedEvent -> Double
peOnWholeOrPartOsc :: O.Time,
    ProcessedEvent -> Micros
peOnPart :: Link.Micros,
    ProcessedEvent -> Double
peOnPartOsc :: O.Time
  }

-- | Query the current pattern (contained in argument @stream :: Stream@)
-- for the events in the current arc (contained in argument @st :: T.State@),
-- translate them to OSC messages, and send these.
--
-- If an exception occurs during sending,
-- this functions prints a warning and continues, because
-- the likely reason is that the backend (supercollider) isn't running.
--
-- If any exception occurs before or outside sending
-- (e.g., while querying the pattern, while computing a message),
-- this function prints a warning and resets the current pattern
-- to the previous one (or to silence if there isn't one) and continues,
-- because the likely reason is that something is wrong with the current pattern.
doTick ::
  MVar ValueMap -> -- pattern state
  MVar PlayMap -> -- currently playing
  MVar (ControlPattern -> ControlPattern) -> -- current global fx
  [Cx] -> -- target addresses
  (Time, Time) -> -- current arc
  Double -> -- nudge
  Clock.ClockConfig -> -- config of the clock
  Clock.ClockRef -> -- reference to the clock
  (Link.SessionState, Link.SessionState) -> -- second session state is for keeping track of tempo changes
  IO ()
doTick :: MVar ValueMap
-> MVar PlayMap
-> MVar (ControlPattern -> ControlPattern)
-> [Cx]
-> (Rational, Rational)
-> Double
-> ClockConfig
-> ClockRef
-> (SessionState, SessionState)
-> IO ()
doTick MVar ValueMap
stateMV MVar PlayMap
playMV MVar (ControlPattern -> ControlPattern)
globalFMV [Cx]
cxs (Rational
st, Rational
end) Double
nudge ClockConfig
cconf ClockRef
cref (SessionState
ss, SessionState
temposs) =
  (SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
E.handle SomeException -> IO ()
handleException (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    MVar ValueMap -> (ValueMap -> IO ValueMap) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar ValueMap
stateMV ((ValueMap -> IO ValueMap) -> IO ())
-> (ValueMap -> IO ValueMap) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ValueMap
sMap -> do
      pMap <- MVar PlayMap -> IO PlayMap
forall a. MVar a -> IO a
readMVar MVar PlayMap
playMV
      sGlobalF <- readMVar globalFMV
      bpm <- Clock.getTempo ss
      let cps = ClockConfig -> Double -> Double
Clock.beatToCycles ClockConfig
cconf (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
bpm) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
60
          cycleLatency = Double -> Rational
forall a. Real a => a -> Rational
toRational (Double -> Rational) -> Double -> Rational
forall a b. (a -> b) -> a -> b
$ Double
nudge Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
cps
          patstack = Rational -> ControlPattern -> ControlPattern
forall a. Rational -> Pattern a -> Pattern a
rotR Rational
cycleLatency (ControlPattern -> ControlPattern)
-> ControlPattern -> ControlPattern
forall a b. (a -> b) -> a -> b
$ ControlPattern -> ControlPattern
sGlobalF (ControlPattern -> ControlPattern)
-> ControlPattern -> ControlPattern
forall a b. (a -> b) -> a -> b
$ PlayMap -> ControlPattern
playStack PlayMap
pMap
          sMap' = PatId -> Value -> ValueMap -> ValueMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PatId
"_cps" (Double -> Value
VF (Double -> Value) -> Double -> Value
forall a b. (a -> b) -> a -> b
$ Double -> Double
forall a b. Coercible a b => a -> b
coerce Double
cps) ValueMap
sMap
          -- First the state is used to query the pattern
          es =
            (Event ValueMap -> Rational)
-> [Event ValueMap] -> [Event ValueMap]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (ArcF Rational -> Rational
forall a. ArcF a -> a
start (ArcF Rational -> Rational)
-> (Event ValueMap -> ArcF Rational) -> Event ValueMap -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event ValueMap -> ArcF Rational
forall a b. EventF a b -> a
part) ([Event ValueMap] -> [Event ValueMap])
-> [Event ValueMap] -> [Event ValueMap]
forall a b. (a -> b) -> a -> b
$
              ControlPattern -> State -> [Event ValueMap]
forall a. Pattern a -> State -> [Event a]
query
                ControlPattern
patstack
                ( State
                    { arc :: ArcF Rational
arc = Rational -> Rational -> ArcF Rational
forall a. a -> a -> ArcF a
Arc Rational
st Rational
end,
                      controls :: ValueMap
controls = ValueMap
sMap'
                    }
                )
          -- Then it's passed through the events
          (sMap'', es') = resolveState sMap' es
      tes <- processCps cconf cref (ss, temposs) es'
      -- For each OSC target
      forM_ cxs $ \cx :: Cx
cx@(Cx Target
target Udp
_ [OSC]
oscs AddrInfo
_ Maybe AddrInfo
_ Maybe (MVar [Int])
bussesMV) -> do
        busses <- (MVar [Int] -> IO [Int]) -> Maybe (MVar [Int]) -> IO (Maybe [Int])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM MVar [Int] -> IO [Int]
forall a. MVar a -> IO a
readMVar Maybe (MVar [Int])
bussesMV
        -- Latency is configurable per target.
        -- Latency is only used when sending events live.
        let latency = Target -> Double
oLatency Target
target
            ms = (ProcessedEvent -> [(Double, Bool, Message)])
-> [ProcessedEvent] -> [(Double, Bool, Message)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\ProcessedEvent
e -> (OSC -> [(Double, Bool, Message)])
-> [OSC] -> [(Double, Bool, Message)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe [Int] -> ProcessedEvent -> OSC -> [(Double, Bool, Message)]
toOSC Maybe [Int]
busses ProcessedEvent
e) [OSC]
oscs) [ProcessedEvent]
tes
        -- send the events to the OSC target
        forM_ ms $ \(Double, Bool, Message)
m ->
          Cx -> Double -> Double -> (Double, Bool, Message) -> IO ()
send Cx
cx Double
latency Double
0 (Double, Bool, Message)
m IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(SomeException
e :: E.SomeException) ->
            Handle -> PatId -> IO ()
hPutStrLn Handle
stderr (PatId -> IO ()) -> PatId -> IO ()
forall a b. (a -> b) -> a -> b
$ PatId
"Failed to send. Is the '" PatId -> PatId -> PatId
forall a. [a] -> [a] -> [a]
++ Target -> PatId
oName Target
target PatId -> PatId -> PatId
forall a. [a] -> [a] -> [a]
++ PatId
"' target running? " PatId -> PatId -> PatId
forall a. [a] -> [a] -> [a]
++ SomeException -> PatId
forall a. Show a => a -> PatId
show SomeException
e
      return sMap''
  where
    handleException :: E.SomeException -> IO ()
    handleException :: SomeException -> IO ()
handleException SomeException
e = do
      Handle -> PatId -> IO ()
hPutStrLn Handle
stderr (PatId -> IO ()) -> PatId -> IO ()
forall a b. (a -> b) -> a -> b
$ PatId
"Failed to Stream.doTick: " PatId -> PatId -> PatId
forall a. [a] -> [a] -> [a]
++ SomeException -> PatId
forall a. Show a => a -> PatId
show SomeException
e
      Handle -> PatId -> IO ()
hPutStrLn Handle
stderr PatId
"Return to previous pattern."
      MVar PlayMap -> IO ()
setPreviousPatternOrSilence MVar PlayMap
playMV

processCps :: Clock.ClockConfig -> Clock.ClockRef -> (Link.SessionState, Link.SessionState) -> [Event ValueMap] -> IO [ProcessedEvent]
processCps :: ClockConfig
-> ClockRef
-> (SessionState, SessionState)
-> [Event ValueMap]
-> IO [ProcessedEvent]
processCps ClockConfig
cconf ClockRef
cref (SessionState
ss, SessionState
temposs) = (Event ValueMap -> IO ProcessedEvent)
-> [Event ValueMap] -> IO [ProcessedEvent]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Event ValueMap -> IO ProcessedEvent
processEvent
  where
    processEvent :: Event ValueMap -> IO ProcessedEvent
    processEvent :: Event ValueMap -> IO ProcessedEvent
processEvent Event ValueMap
e = do
      let wope :: ArcF Rational
wope = Event ValueMap -> ArcF Rational
forall a. Event a -> ArcF Rational
wholeOrPart Event ValueMap
e
          partStartCycle :: Rational
partStartCycle = ArcF Rational -> Rational
forall a. ArcF a -> a
start (ArcF Rational -> Rational) -> ArcF Rational -> Rational
forall a b. (a -> b) -> a -> b
$ Event ValueMap -> ArcF Rational
forall a b. EventF a b -> a
part Event ValueMap
e
          partStartBeat :: Double
partStartBeat = ClockConfig -> Double -> Double
Clock.cyclesToBeat ClockConfig
cconf (Rational -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Rational
partStartCycle)
          onCycle :: Rational
onCycle = ArcF Rational -> Rational
forall a. ArcF a -> a
start ArcF Rational
wope
          onBeat :: Double
onBeat = ClockConfig -> Double -> Double
Clock.cyclesToBeat ClockConfig
cconf (Rational -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Rational
onCycle)
          offCycle :: Rational
offCycle = ArcF Rational -> Rational
forall a. ArcF a -> a
stop ArcF Rational
wope
          offBeat :: Double
offBeat = ClockConfig -> Double -> Double
Clock.cyclesToBeat ClockConfig
cconf (Rational -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Rational
offCycle)
      on <- ClockConfig -> SessionState -> Double -> IO Micros
Clock.timeAtBeat ClockConfig
cconf SessionState
ss Double
onBeat
      onPart <- Clock.timeAtBeat cconf ss partStartBeat
      when
        (eventHasOnset e)
        ( do
            let cps' = PatId -> ValueMap -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PatId
"cps" (Event ValueMap -> ValueMap
forall a b. EventF a b -> b
value Event ValueMap
e) Maybe Value -> (Value -> Maybe Double) -> Maybe Double
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Maybe Double
getF
            maybe (return ()) ((\Rational
newCps -> Rational -> Micros -> ClockConfig -> SessionState -> IO ()
Clock.setTempoCPS Rational
newCps Micros
on ClockConfig
cconf SessionState
temposs) . toRational) cps'
        )
      off <- Clock.timeAtBeat cconf ss offBeat
      bpm <- Clock.getTempo ss
      wholeOrPartOsc <- Clock.linkToOscTime cref on
      onPartOsc <- Clock.linkToOscTime cref onPart
      let cps = ClockConfig -> Double -> Double
Clock.beatToCycles ClockConfig
cconf (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
bpm) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
60
      let delta = Micros
off Micros -> Micros -> Micros
forall a. Num a => a -> a -> a
- Micros
on
      return $!
        ProcessedEvent
          { peHasOnset = eventHasOnset e,
            peEvent = e,
            peCps = cps,
            peDelta = delta,
            peCycle = onCycle,
            peOnWholeOrPart = on,
            peOnWholeOrPartOsc = wholeOrPartOsc,
            peOnPart = onPart,
            peOnPartOsc = onPartOsc
          }

toOSC :: Maybe [Int] -> ProcessedEvent -> OSC -> [(Double, Bool, O.Message)]
toOSC :: Maybe [Int] -> ProcessedEvent -> OSC -> [(Double, Bool, Message)]
toOSC Maybe [Int]
maybeBusses ProcessedEvent
pe osc :: OSC
osc@(OSC PatId
_ Args
_) =
  [Maybe (Double, Bool, Message)] -> [(Double, Bool, Message)]
forall a. [Maybe a] -> [a]
catMaybes (Maybe (Double, Bool, Message)
playmsg Maybe (Double, Bool, Message)
-> [Maybe (Double, Bool, Message)]
-> [Maybe (Double, Bool, Message)]
forall a. a -> [a] -> [a]
: [Maybe (Double, Bool, Message)]
busmsgs)
  where
    -- playmap is a ValueMap where the keys don't start with ^ and are not ""
    -- busmap is a ValueMap containing the rest of the keys from the event value
    -- The partition is performed in order to have special handling of bus ids.

    (ValueMap
playmap, ValueMap
busmap) = (PatId -> Value -> Bool) -> ValueMap -> (ValueMap, ValueMap)
forall k a. (k -> a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partitionWithKey (\PatId
k Value
_ -> PatId -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null PatId
k Bool -> Bool -> Bool
|| PatId -> Char
forall a. HasCallStack => [a] -> a
head PatId
k Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'^') (ValueMap -> (ValueMap, ValueMap))
-> ValueMap -> (ValueMap, ValueMap)
forall a b. (a -> b) -> a -> b
$ ProcessedEvent -> ValueMap
val ProcessedEvent
pe
    -- Map in bus ids where needed.
    --
    -- Bus ids are integers
    -- If busses is empty, the ids to send are directly contained in the the values of the busmap.
    -- Otherwise, the ids to send are contained in busses at the indices of the values of the busmap.
    -- Both cases require that the values of the busmap are only ever integers,
    -- that is, they are Values with constructor VI
    -- (but perhaps we should explicitly crash with an error message if it contains something else?).
    -- Map.mapKeys tail is used to remove ^ from the keys.
    -- In case (value e) has the key "", we will get a crash here.
    playmap' :: ValueMap
playmap' = ValueMap -> ValueMap -> ValueMap
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union ((PatId -> PatId) -> ValueMap -> ValueMap
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys (Int -> PatId -> PatId
forall a. Int -> [a] -> [a]
drop Int
1) (ValueMap -> ValueMap) -> ValueMap -> ValueMap
forall a b. (a -> b) -> a -> b
$ (Value -> Value) -> ValueMap -> ValueMap
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\Value
v -> PatId -> Value
VS (Char
'c' Char -> PatId -> PatId
forall a. a -> [a] -> [a]
: Int -> PatId
forall a. Show a => a -> PatId
show (Int -> Int
toBus (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Value -> Maybe Int
getI Value
v))) ValueMap
busmap) ValueMap
playmap
    val :: ProcessedEvent -> ValueMap
val = Event ValueMap -> ValueMap
forall a b. EventF a b -> b
value (Event ValueMap -> ValueMap)
-> (ProcessedEvent -> Event ValueMap) -> ProcessedEvent -> ValueMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessedEvent -> Event ValueMap
peEvent
    -- Only events that start within the current nowArc are included
    playmsg :: Maybe (Double, Bool, Message)
playmsg
      | ProcessedEvent -> Bool
peHasOnset ProcessedEvent
pe = do
          -- If there is already cps in the event, the union will preserve that.
          let extra :: ValueMap
extra =
                [(PatId, Value)] -> ValueMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                  [ (PatId
"cps", Double -> Value
VF (ProcessedEvent -> Double
peCps ProcessedEvent
pe)),
                    (PatId
"delta", Double -> Value
VF (Micros -> Double -> Double
Clock.addMicrosToOsc (ProcessedEvent -> Micros
peDelta ProcessedEvent
pe) Double
0)),
                    (PatId
"cycle", Double -> Value
VF (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (ProcessedEvent -> Rational
peCycle ProcessedEvent
pe)))
                  ]
              addExtra :: ValueMap
addExtra = ValueMap -> ValueMap -> ValueMap
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union ValueMap
playmap' ValueMap
extra
              ts :: Double
ts = ProcessedEvent -> Double
peOnWholeOrPartOsc ProcessedEvent
pe Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
nudge -- + latency
          vs <- OSC -> Event ValueMap -> Maybe [Datum]
toData OSC
osc ((ProcessedEvent -> Event ValueMap
peEvent ProcessedEvent
pe) {value = addExtra})
          mungedPath <- substitutePath (path osc) playmap'
          return
            ( ts,
              False, -- bus message ?
              O.Message mungedPath vs
            )
      | Bool
otherwise = Maybe (Double, Bool, Message)
forall a. Maybe a
Nothing
    toBus :: Int -> Int
toBus Int
n
      | Just [Int]
busses <- Maybe [Int]
maybeBusses, (Bool -> Bool
not (Bool -> Bool) -> ([Int] -> Bool) -> [Int] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [Int]
busses = [Int]
busses [Int] -> Int -> Int
forall a. [a] -> Int -> a
!!! Int
n
      | Bool
otherwise = Int
n
    busmsgs :: [Maybe (Double, Bool, Message)]
busmsgs =
      ((PatId, Value) -> Maybe (Double, Bool, Message))
-> [(PatId, Value)] -> [Maybe (Double, Bool, Message)]
forall a b. (a -> b) -> [a] -> [b]
map
        ( \(PatId
k, Value
b) -> do
            k' <- if Bool -> Bool
not (PatId -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null PatId
k) Bool -> Bool -> Bool
&& PatId -> Char
forall a. HasCallStack => [a] -> a
head PatId
k Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'^' then PatId -> Maybe PatId
forall a. a -> Maybe a
Just (Int -> PatId -> PatId
forall a. Int -> [a] -> [a]
drop Int
1 PatId
k) else Maybe PatId
forall a. Maybe a
Nothing
            v <- Map.lookup k' playmap
            bi <- getI b
            return
              ( tsPart,
                True, -- bus message ?
                O.Message "/c_set" [O.int32 (toBus bi), toDatum v]
              )
        )
        (ValueMap -> [(PatId, Value)]
forall k a. Map k a -> [(k, a)]
Map.toList ValueMap
busmap)
      where
        tsPart :: Double
tsPart = ProcessedEvent -> Double
peOnPartOsc ProcessedEvent
pe Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
nudge -- + latency
    nudge :: Double
nudge = Maybe Double -> Double
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Double -> Double) -> Maybe Double -> Double
forall a b. (a -> b) -> a -> b
$ Value -> Maybe Double
getF (Value -> Maybe Double) -> Value -> Maybe Double
forall a b. (a -> b) -> a -> b
$ Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe (Double -> Value
VF Double
0) (Maybe Value -> Value) -> Maybe Value -> Value
forall a b. (a -> b) -> a -> b
$ PatId -> ValueMap -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PatId
"nudge" ValueMap
playmap
toOSC Maybe [Int]
_ ProcessedEvent
pe (OSCContext PatId
oscpath) =
  (((Int, Int), (Int, Int)) -> (Double, Bool, Message))
-> [((Int, Int), (Int, Int))] -> [(Double, Bool, Message)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, Int), (Int, Int)) -> (Double, Bool, Message)
cToM ([((Int, Int), (Int, Int))] -> [(Double, Bool, Message)])
-> [((Int, Int), (Int, Int))] -> [(Double, Bool, Message)]
forall a b. (a -> b) -> a -> b
$ Context -> [((Int, Int), (Int, Int))]
contextPosition (Context -> [((Int, Int), (Int, Int))])
-> Context -> [((Int, Int), (Int, Int))]
forall a b. (a -> b) -> a -> b
$ Event ValueMap -> Context
forall a b. EventF a b -> Context
context (Event ValueMap -> Context) -> Event ValueMap -> Context
forall a b. (a -> b) -> a -> b
$ ProcessedEvent -> Event ValueMap
peEvent ProcessedEvent
pe
  where
    cToM :: ((Int, Int), (Int, Int)) -> (Double, Bool, O.Message)
    cToM :: ((Int, Int), (Int, Int)) -> (Double, Bool, Message)
cToM ((Int
x, Int
y), (Int
x', Int
y')) =
      ( Double
ts,
        Bool
False, -- bus message ?
        PatId -> [Datum] -> Message
O.Message PatId
oscpath ([Datum] -> Message) -> [Datum] -> Message
forall a b. (a -> b) -> a -> b
$ PatId -> Datum
O.string PatId
ident Datum -> [Datum] -> [Datum]
forall a. a -> [a] -> [a]
: Micros -> Datum
forall n. Real n => n -> Datum
O.float (ProcessedEvent -> Micros
peDelta ProcessedEvent
pe) Datum -> [Datum] -> [Datum]
forall a. a -> [a] -> [a]
: Double -> Datum
forall n. Real n => n -> Datum
O.float Double
cyc Datum -> [Datum] -> [Datum]
forall a. a -> [a] -> [a]
: (Int -> Datum) -> [Int] -> [Datum]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Datum
forall n. Integral n => n -> Datum
O.int32 [Int
x, Int
y, Int
x', Int
y']
      )
    cyc :: Double
    cyc :: Double
cyc = Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double) -> Rational -> Double
forall a b. (a -> b) -> a -> b
$ ProcessedEvent -> Rational
peCycle ProcessedEvent
pe
    nudge :: Double
nudge = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0 (Maybe Double -> Double) -> Maybe Double -> Double
forall a b. (a -> b) -> a -> b
$ PatId -> ValueMap -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PatId
"nudge" (Event ValueMap -> ValueMap
forall a b. EventF a b -> b
value (Event ValueMap -> ValueMap) -> Event ValueMap -> ValueMap
forall a b. (a -> b) -> a -> b
$ ProcessedEvent -> Event ValueMap
peEvent ProcessedEvent
pe) Maybe Value -> (Value -> Maybe Double) -> Maybe Double
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Maybe Double
getF
    ident :: PatId
ident = PatId -> Maybe PatId -> PatId
forall a. a -> Maybe a -> a
fromMaybe PatId
"unknown" (Maybe PatId -> PatId) -> Maybe PatId -> PatId
forall a b. (a -> b) -> a -> b
$ PatId -> ValueMap -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PatId
"_id_" (Event ValueMap -> ValueMap
forall a b. EventF a b -> b
value (Event ValueMap -> ValueMap) -> Event ValueMap -> ValueMap
forall a b. (a -> b) -> a -> b
$ ProcessedEvent -> Event ValueMap
peEvent ProcessedEvent
pe) Maybe Value -> (Value -> Maybe PatId) -> Maybe PatId
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Maybe PatId
getS
    ts :: Double
ts = ProcessedEvent -> Double
peOnWholeOrPartOsc ProcessedEvent
pe Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
nudge -- + latency

toData :: OSC -> Event ValueMap -> Maybe [O.Datum]
toData :: OSC -> Event ValueMap -> Maybe [Datum]
toData (OSC {args :: OSC -> Args
args = ArgList [(PatId, Maybe Value)]
as}) Event ValueMap
e = ([Value] -> [Datum]) -> Maybe [Value] -> Maybe [Datum]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Value -> Datum) -> [Value] -> [Datum]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Datum
toDatum) (Maybe [Value] -> Maybe [Datum]) -> Maybe [Value] -> Maybe [Datum]
forall a b. (a -> b) -> a -> b
$ ((PatId, Maybe Value) -> Maybe Value)
-> [(PatId, Maybe Value)] -> Maybe [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(PatId
n, Maybe Value
v) -> PatId -> ValueMap -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PatId
n (Event ValueMap -> ValueMap
forall a b. EventF a b -> b
value Event ValueMap
e) Maybe Value -> Maybe Value -> Maybe Value
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Value
v) [(PatId, Maybe Value)]
as
toData (OSC {args :: OSC -> Args
args = Named [PatId]
rqrd}) Event ValueMap
e
  | [PatId] -> Bool
hasRequired [PatId]
rqrd = [Datum] -> Maybe [Datum]
forall a. a -> Maybe a
Just ([Datum] -> Maybe [Datum]) -> [Datum] -> Maybe [Datum]
forall a b. (a -> b) -> a -> b
$ ((PatId, Value) -> [Datum]) -> [(PatId, Value)] -> [Datum]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(PatId
n, Value
v) -> [PatId -> Datum
O.string PatId
n, Value -> Datum
toDatum Value
v]) ([(PatId, Value)] -> [Datum]) -> [(PatId, Value)] -> [Datum]
forall a b. (a -> b) -> a -> b
$ ValueMap -> [(PatId, Value)]
forall k a. Map k a -> [(k, a)]
Map.toList (ValueMap -> [(PatId, Value)]) -> ValueMap -> [(PatId, Value)]
forall a b. (a -> b) -> a -> b
$ Event ValueMap -> ValueMap
forall a b. EventF a b -> b
value Event ValueMap
e
  | Bool
otherwise = Maybe [Datum]
forall a. Maybe a
Nothing
  where
    hasRequired :: [PatId] -> Bool
hasRequired [] = Bool
True
    hasRequired [PatId]
xs = (PatId -> Bool) -> [PatId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (PatId -> [PatId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PatId]
ks) [PatId]
xs
    ks :: [PatId]
ks = ValueMap -> [PatId]
forall k a. Map k a -> [k]
Map.keys (Event ValueMap -> ValueMap
forall a b. EventF a b -> b
value Event ValueMap
e)
toData OSC
_ Event ValueMap
_ = Maybe [Datum]
forall a. Maybe a
Nothing

toDatum :: Value -> O.Datum
toDatum :: Value -> Datum
toDatum (VF Double
x) = Double -> Datum
forall n. Real n => n -> Datum
O.float Double
x
toDatum (VN Note
x) = Note -> Datum
forall n. Real n => n -> Datum
O.float Note
x
toDatum (VI Int
x) = Int -> Datum
forall n. Integral n => n -> Datum
O.int32 Int
x
toDatum (VS PatId
x) = PatId -> Datum
O.string PatId
x
toDatum (VR Rational
x) = Double -> Datum
forall n. Real n => n -> Datum
O.float (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
x :: Double)
toDatum (VB Bool
True) = Int -> Datum
forall n. Integral n => n -> Datum
O.int32 (Int
1 :: Int)
toDatum (VB Bool
False) = Int -> Datum
forall n. Integral n => n -> Datum
O.int32 (Int
0 :: Int)
toDatum (VX [Word8]
xs) = Blob -> Datum
O.Blob (Blob -> Datum) -> Blob -> Datum
forall a b. (a -> b) -> a -> b
$ [Word8] -> Blob
O.blob_pack [Word8]
xs
toDatum Value
_ = PatId -> Datum
forall a. HasCallStack => PatId -> a
error PatId
"toDatum: unhandled value"

substitutePath :: String -> ValueMap -> Maybe String
substitutePath :: PatId -> ValueMap -> Maybe PatId
substitutePath PatId
str ValueMap
cm = PatId -> Maybe PatId
parse PatId
str
  where
    parse :: PatId -> Maybe PatId
parse [] = PatId -> Maybe PatId
forall a. a -> Maybe a
Just []
    parse (Char
'{' : PatId
xs) = PatId -> Maybe PatId
parseWord PatId
xs
    parse (Char
x : PatId
xs) = do
      xs' <- PatId -> Maybe PatId
parse PatId
xs
      return (x : xs')
    parseWord :: PatId -> Maybe PatId
parseWord PatId
xs
      | PatId -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null PatId
b = ValueMap -> PatId -> Maybe PatId
getString ValueMap
cm PatId
a
      | Bool
otherwise = do
          v <- ValueMap -> PatId -> Maybe PatId
getString ValueMap
cm PatId
a
          xs' <- parse (drop 1 b)
          return $ v ++ xs'
      where
        (PatId
a, PatId
b) = (Char -> Bool) -> PatId -> (PatId, PatId)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'}') PatId
xs

getString :: ValueMap -> String -> Maybe String
getString :: ValueMap -> PatId -> Maybe PatId
getString ValueMap
cm PatId
s = (Value -> PatId
simpleShow (Value -> PatId) -> Maybe Value -> Maybe PatId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PatId -> ValueMap -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PatId
param ValueMap
cm) Maybe PatId -> Maybe PatId -> Maybe PatId
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> PatId -> Maybe PatId
defaultValue PatId
dflt
  where
    (PatId
param, PatId
dflt) = (Char -> Bool) -> PatId -> (PatId, PatId)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=') PatId
s
    simpleShow :: Value -> String
    simpleShow :: Value -> PatId
simpleShow (VS PatId
str) = PatId
str
    simpleShow (VI Int
i) = Int -> PatId
forall a. Show a => a -> PatId
show Int
i
    simpleShow (VF Double
f) = Double -> PatId
forall a. Show a => a -> PatId
show Double
f
    simpleShow (VN Note
n) = Note -> PatId
forall a. Show a => a -> PatId
show Note
n
    simpleShow (VR Rational
r) = Rational -> PatId
forall a. Show a => a -> PatId
show Rational
r
    simpleShow (VB Bool
b) = Bool -> PatId
forall a. Show a => a -> PatId
show Bool
b
    simpleShow (VX [Word8]
xs) = [Word8] -> PatId
forall a. Show a => a -> PatId
show [Word8]
xs
    simpleShow (VState ValueMap -> (ValueMap, Value)
_) = PatId -> PatId
forall a. Show a => a -> PatId
show PatId
"<stateful>"
    simpleShow (VPattern Pattern Value
_) = PatId -> PatId
forall a. Show a => a -> PatId
show PatId
"<pattern>"
    simpleShow (VList [Value]
_) = PatId -> PatId
forall a. Show a => a -> PatId
show PatId
"<list>"
    defaultValue :: String -> Maybe String
    defaultValue :: PatId -> Maybe PatId
defaultValue (Char
'=' : PatId
dfltVal) = PatId -> Maybe PatId
forall a. a -> Maybe a
Just PatId
dfltVal
    defaultValue PatId
_ = Maybe PatId
forall a. Maybe a
Nothing

playStack :: PlayMap -> ControlPattern
playStack :: PlayMap -> ControlPattern
playStack PlayMap
pMap = [ControlPattern] -> ControlPattern
forall a. [Pattern a] -> Pattern a
stack ([ControlPattern] -> ControlPattern)
-> (PlayMap -> [ControlPattern]) -> PlayMap -> ControlPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PlayState -> ControlPattern) -> [PlayState] -> [ControlPattern]
forall a b. (a -> b) -> [a] -> [b]
map PlayState -> ControlPattern
psPattern ([PlayState] -> [ControlPattern])
-> (PlayMap -> [PlayState]) -> PlayMap -> [ControlPattern]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PlayState -> Bool) -> [PlayState] -> [PlayState]
forall a. (a -> Bool) -> [a] -> [a]
filter PlayState -> Bool
active ([PlayState] -> [PlayState])
-> (PlayMap -> [PlayState]) -> PlayMap -> [PlayState]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlayMap -> [PlayState]
forall k a. Map k a -> [a]
Map.elems (PlayMap -> ControlPattern) -> PlayMap -> ControlPattern
forall a b. (a -> b) -> a -> b
$ PlayMap
pMap
  where
    active :: PlayState -> Bool
active PlayState
pState =
      if PlayMap -> Bool
forall k. Map k PlayState -> Bool
hasSolo PlayMap
pMap
        then PlayState -> Bool
psSolo PlayState
pState
        else Bool -> Bool
not (PlayState -> Bool
psMute PlayState
pState)

hasSolo :: Map.Map k PlayState -> Bool
hasSolo :: forall k. Map k PlayState -> Bool
hasSolo = (PlayState -> Bool) -> [PlayState] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any PlayState -> Bool
psSolo ([PlayState] -> Bool)
-> (Map k PlayState -> [PlayState]) -> Map k PlayState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k PlayState -> [PlayState]
forall k a. Map k a -> [a]
Map.elems

onSingleTick :: Clock.ClockConfig -> Clock.ClockRef -> MVar ValueMap -> MVar PlayMap -> MVar (ControlPattern -> ControlPattern) -> [Cx] -> ControlPattern -> IO ()
onSingleTick :: ClockConfig
-> ClockRef
-> MVar ValueMap
-> MVar PlayMap
-> MVar (ControlPattern -> ControlPattern)
-> [Cx]
-> ControlPattern
-> IO ()
onSingleTick ClockConfig
clockConfig ClockRef
clockRef MVar ValueMap
stateMV MVar PlayMap
_ MVar (ControlPattern -> ControlPattern)
globalFMV [Cx]
cxs ControlPattern
pat = do
  pMapMV <-
    PlayMap -> IO (MVar PlayMap)
forall a. a -> IO (MVar a)
newMVar (PlayMap -> IO (MVar PlayMap)) -> PlayMap -> IO (MVar PlayMap)
forall a b. (a -> b) -> a -> b
$
      PatId -> PlayState -> PlayMap
forall k a. k -> a -> Map k a
Map.singleton
        PatId
"fake"
        ( PlayState
            { psPattern :: ControlPattern
psPattern = ControlPattern
pat,
              psMute :: Bool
psMute = Bool
False,
              psSolo :: Bool
psSolo = Bool
False,
              psHistory :: [ControlPattern]
psHistory = []
            }
        )
  Clock.clockOnce (doTick stateMV pMapMV globalFMV cxs) clockConfig clockRef

-- Used for Tempo callback
updatePattern :: Stream -> ID -> Time -> ControlPattern -> IO ()
updatePattern :: Stream -> ID -> Rational -> ControlPattern -> IO ()
updatePattern Stream
stream ID
k !Rational
t ControlPattern
pat = do
  let x :: [Event ValueMap]
x = ControlPattern -> ArcF Rational -> [Event ValueMap]
forall a. Pattern a -> ArcF Rational -> [Event a]
queryArc ControlPattern
pat (Rational -> Rational -> ArcF Rational
forall a. a -> a -> ArcF a
Arc Rational
0 Rational
0)
  pMap <- [Event ValueMap] -> IO PlayMap -> IO PlayMap
forall a b. a -> b -> b
seq [Event ValueMap]
x (IO PlayMap -> IO PlayMap) -> IO PlayMap -> IO PlayMap
forall a b. (a -> b) -> a -> b
$ MVar PlayMap -> IO PlayMap
forall a. MVar a -> IO a
takeMVar (Stream -> MVar PlayMap
sPMapMV Stream
stream)
  let playState = Maybe PlayState -> PlayState
updatePS (Maybe PlayState -> PlayState) -> Maybe PlayState -> PlayState
forall a b. (a -> b) -> a -> b
$ PatId -> PlayMap -> Maybe PlayState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ID -> PatId
fromID ID
k) PlayMap
pMap
  putMVar (sPMapMV stream) $ Map.insert (fromID k) playState pMap
  where
    updatePS :: Maybe PlayState -> PlayState
updatePS (Just PlayState
playState) = do PlayState
playState {psPattern = pat', psHistory = pat : psHistory playState}
    updatePS Maybe PlayState
Nothing = ControlPattern -> Bool -> Bool -> [ControlPattern] -> PlayState
PlayState ControlPattern
pat' Bool
False Bool
False [ControlPattern
pat']
    patControls :: ValueMap
patControls = PatId -> Value -> ValueMap
forall k a. k -> a -> Map k a
Map.singleton PatId
patternTimeID (Rational -> Value
VR Rational
t)
    pat' :: ControlPattern
pat' =
      (ValueMap -> ValueMap) -> ControlPattern -> ControlPattern
forall a. (ValueMap -> ValueMap) -> Pattern a -> Pattern a
withQueryControls (ValueMap -> ValueMap -> ValueMap
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union ValueMap
patControls) (ControlPattern -> ControlPattern)
-> ControlPattern -> ControlPattern
forall a b. (a -> b) -> a -> b
$
        ControlPattern
pat ControlPattern -> ControlPattern -> ControlPattern
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# PatId -> Pattern PatId -> ControlPattern
pS PatId
"_id_" (PatId -> Pattern PatId
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PatId -> Pattern PatId) -> PatId -> Pattern PatId
forall a b. (a -> b) -> a -> b
$ ID -> PatId
fromID ID
k)

setPreviousPatternOrSilence :: MVar PlayMap -> IO ()
setPreviousPatternOrSilence :: MVar PlayMap -> IO ()
setPreviousPatternOrSilence MVar PlayMap
playMV =
  MVar PlayMap -> (PlayMap -> IO PlayMap) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar PlayMap
playMV ((PlayMap -> IO PlayMap) -> IO ())
-> (PlayMap -> IO PlayMap) -> IO ()
forall a b. (a -> b) -> a -> b
$
    PlayMap -> IO PlayMap
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
      (PlayMap -> IO PlayMap)
-> (PlayMap -> PlayMap) -> PlayMap -> IO PlayMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PlayState -> PlayState) -> PlayMap -> PlayMap
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map
        ( \PlayState
pMap -> case PlayState -> [ControlPattern]
psHistory PlayState
pMap of
            ControlPattern
_ : ControlPattern
p : [ControlPattern]
ps -> PlayState
pMap {psPattern = p, psHistory = p : ps}
            [ControlPattern]
_ -> PlayState
pMap {psPattern = silence, psHistory = [silence]}
        )