-- Copyright 2021 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE CPP #-}
module Perform.Sc.Play (
    State(..)
    , play
    -- * stop
    , force_stop
    -- * thru
    , osc_thru
    , note_on, note_off
    , set_control, pitch_change
    -- * initialize
    , version
    , add_default_group
    , initialize_patch
    , sync
#ifdef TESTING
    , module Perform.Sc.Play
#endif
) where
import qualified Control.Exception as Exception
import qualified Data.Bits as Bits
import qualified Data.ByteString as ByteString
import qualified Data.Int as Int
import qualified Data.Map as Map
import qualified Data.Time as Time

import qualified Network.Socket as Socket
import qualified Network.Socket.ByteString as Socket.ByteString
import qualified Vivid.OSC as OSC
import           Vivid.OSC (OSCDatum(..))

import qualified Util.Control as Control
import qualified Util.Exceptions as Exceptions
import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Network as Network
import qualified Util.Num as Num
import qualified Util.Texts as Texts
import qualified Util.Thread as Thread

import qualified Derive.Controls as Controls
import qualified Derive.LEvent as LEvent
import qualified Derive.ScoreT as ScoreT

import qualified Perform.Midi.MSignal as MSignal
import qualified Perform.Pitch as Pitch
import qualified Perform.Sc.Note as Note
import qualified Perform.Sc.Patch as Patch
import qualified Perform.Transport as Transport

import           Global
import           Types


-- | Talk to sclang IDE.  Use with OSCFunc.trace(true).
lang_port :: Socket.PortNumber
lang_port :: PortNumber
lang_port = PortNumber
57120

-- | sclang starts the server with this port by default.  This is hardcoded for
-- now, but could be configured if necessary.
server_port :: Socket.PortNumber
server_port :: PortNumber
server_port = PortNumber
57110

data State = State {
    -- | Communicate into the player.
    State -> PlayControl
_play_control :: !Transport.PlayControl
    -- | Communicate out from the player.
    , State -> ActivePlayers
_players :: !Transport.ActivePlayers
    }

-- * NodeId

newtype NodeId = NodeId Int.Int32
    deriving (NodeId -> NodeId -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NodeId -> NodeId -> Bool
$c/= :: NodeId -> NodeId -> Bool
== :: NodeId -> NodeId -> Bool
$c== :: NodeId -> NodeId -> Bool
Eq, Int -> NodeId -> ShowS
[NodeId] -> ShowS
NodeId -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [NodeId] -> ShowS
$cshowList :: [NodeId] -> ShowS
show :: NodeId -> FilePath
$cshow :: NodeId -> FilePath
showsPrec :: Int -> NodeId -> ShowS
$cshowsPrec :: Int -> NodeId -> ShowS
Show)

node_ids_from :: NodeId -> [NodeId]
node_ids_from :: NodeId -> [NodeId]
node_ids_from (NodeId Int32
start) =
    Int32 -> NodeId
NodeId Int32
start forall a. a -> [a] -> [a]
: NodeId -> [NodeId]
node_ids_from (Int32 -> NodeId
NodeId Int32
next)
    where next :: Int32
next = if Int32
start forall a. Eq a => a -> a -> Bool
== forall a. Bounded a => a
maxBound then Int32
min_node_id else Int32
start forall a. Num a => a -> a -> a
+ Int32
1

-- I can't choose 1 because that's the default group.  I don't know if
-- there's some cutoff for
min_node_id :: Int.Int32
min_node_id :: Int32
min_node_id = Int32
10

-- * play

-- | Start a thread to stream a list of WriteMessages.
play :: State -> Note.PlayNotes -> Maybe RealTime
    -- ^ If given, loop back to the beginning when this time is reached.
    -> IO ()
play :: State -> PlayNotes -> Maybe RealTime -> IO ()
play State
state PlayNotes
pnotes Maybe RealTime
repeat_at_ = do
    UTCTime
now <- IO UTCTime
Time.getCurrentTime
    ActivePlayers -> IO ()
Transport.player_started (State -> ActivePlayers
_players State
state)
    let start_id :: NodeId
start_id = UTCTime -> NodeId
time_to_id UTCTime
now
    -- repeat_at_ has already had the shift and stretch applied, which is
    -- confusing.  TODO stop doing that.  But on the other hand, all the other
    -- stuff in PlayArgs had shift and stretch applied...
    let repeat_at :: Maybe RealTime
repeat_at = (forall a. Num a => a -> a -> a
+ PlayNotes -> RealTime
Note.shift PlayNotes
pnotes) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Fractional a => a -> a -> a
/ PlayNotes -> RealTime
Note.stretch PlayNotes
pnotes) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            Maybe RealTime
repeat_at_
    FilePath -> IO () -> IO ThreadId
Thread.startLogged FilePath
"render sc" forall a b. (a -> b) -> a -> b
$
        State -> [LEvent OSCBundle] -> IO ()
player_thread State
state (RealTime
-> UTCTime
-> NodeId
-> PlayNotes
-> Maybe RealTime
-> [LEvent OSCBundle]
convert RealTime
tweak UTCTime
now NodeId
start_id PlayNotes
pnotes Maybe RealTime
repeat_at)
            forall a b. IO a -> IO b -> IO a
`Exception.finally` ActivePlayers -> IO ()
Transport.player_stopped (State -> ActivePlayers
_players State
state)
    forall (m :: * -> *) a. Monad m => a -> m a
return ()

convert :: RealTime -> Time.UTCTime -> NodeId -> Note.PlayNotes
    -> Maybe RealTime -> [LEvent.LEvent OSC.OSCBundle]
convert :: RealTime
-> UTCTime
-> NodeId
-> PlayNotes
-> Maybe RealTime
-> [LEvent OSCBundle]
convert RealTime
tweak UTCTime
now NodeId
start_id PlayNotes
pnotes Maybe RealTime
repeat_at =
    UTCTime -> [LEvent (RealTime, OSC)] -> [LEvent OSCBundle]
to_bundles UTCTime
now forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first RealTime -> RealTime
place)) forall a b. (a -> b) -> a -> b
$
    NodeId -> [LEvent (RealTime, Note)] -> [LEvent (RealTime, OSC)]
notes_to_osc NodeId
start_id forall a b. (a -> b) -> a -> b
$
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RealTime
0,))) (RealTime -> RealTime -> [LEvent Note] -> [LEvent (RealTime, Note)]
cycle_messages (PlayNotes -> RealTime
Note.shift PlayNotes
pnotes)) Maybe RealTime
repeat_at forall a b. (a -> b) -> a -> b
$
    PlayNotes -> [LEvent Note]
Note.notes PlayNotes
pnotes
    where
    place :: RealTime -> RealTime
place = (forall a. Num a => a -> a -> a
* PlayNotes -> RealTime
Note.stretch PlayNotes
pnotes) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract (PlayNotes -> RealTime
Note.shift PlayNotes
pnotes forall a. Num a => a -> a -> a
- RealTime
tweak)

cycle_messages :: RealTime -> RealTime -> [LEvent.LEvent Note.Note]
    -> [LEvent.LEvent (RealTime, Note.Note)]
cycle_messages :: RealTime -> RealTime -> [LEvent Note] -> [LEvent (RealTime, Note)]
cycle_messages RealTime
start RealTime
repeat_at [LEvent Note]
notes
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LEvent (RealTime, Note)]
chunk = []
    | Bool
otherwise = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ [LEvent (RealTime, Note)]
chunk forall a. a -> [a] -> [a]
: [[LEvent (RealTime, Note)]]
chunks
    where
    chunk :: [LEvent (RealTime, Note)]
chunk = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RealTime
0,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> Note -> Note
trim_note RealTime
repeat_at)) forall a b. (a -> b) -> a -> b
$
        forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall d. (d -> Bool) -> LEvent d -> Bool
LEvent.log_or ((forall a. Ord a => a -> a -> Bool
<RealTime
repeat_at) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> RealTime
Note.start)) [LEvent Note]
notes
    chunks :: [[LEvent (RealTime, Note)]]
chunks = forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> a -> [a]
iterate forall {c}. [LEvent (RealTime, c)] -> [LEvent (RealTime, c)]
shift [LEvent (RealTime, Note)]
stripped
    shift :: [LEvent (RealTime, c)] -> [LEvent (RealTime, c)]
shift = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a. Num a => a -> a -> a
+ (RealTime
repeat_at forall a. Num a => a -> a -> a
- RealTime
start))))
    stripped :: [LEvent (RealTime, Note)]
stripped = forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> LEvent a
LEvent.Event (forall d. [LEvent d] -> [d]
LEvent.events_of [LEvent (RealTime, Note)]
chunk)

trim_note :: RealTime -> Note.Note -> Note.Note
trim_note :: RealTime -> Note -> Note
trim_note RealTime
end Note
note =
    Note
note { controls :: Map ControlId Signal
Note.controls = forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey ControlId -> Signal -> Signal
trim (Note -> Map ControlId Signal
Note.controls Note
note) }
    where
    trim :: ControlId -> Signal -> Signal
trim ControlId
control Signal
sig
        | forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True ((forall a. Ord a => a -> a -> Bool
<=RealTime
end) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ Signal -> Maybe (RealTime, UnboxedY)
MSignal.last Signal
sig = Signal
sig
        | ControlId
control forall a. Eq a => a -> a -> Bool
== ControlId
Note.gate_id =
            forall (v :: * -> *) y.
Vector v (Sample y) =>
RealTime -> v (Sample y) -> v (Sample y)
MSignal.drop_at_after RealTime
end Signal
sig forall a. Semigroup a => a -> a -> a
<> [(RealTime, UnboxedY)] -> Signal
MSignal.from_pairs [(RealTime
end, UnboxedY
0)]
        | Bool
otherwise = forall (v :: * -> *) y.
Vector v (Sample y) =>
RealTime -> v (Sample y) -> v (Sample y)
MSignal.drop_at_after RealTime
end Signal
sig

-- | For some reason, sc sound winds up slightly before MIDI, but I can't be
-- bothered to track down why.  This delays the OSC by enough to sound close
-- enough to MIDI attacks.
tweak :: RealTime
tweak :: RealTime
tweak = RealTime
0.03

-- | This is a silly solution to a silly problem.  NodeIds are 31-bit (must be
-- positive) numbers to uniquely identify a note.  In an imperative language
-- it's easy to get a unique supply by incrementing, but to do that here I'd
-- have to involve streams, or unsafePerformIO, or give up the nice lazy list
-- structure.  So I'll use the lower bits of milliseconds to pick IDs that are
-- unlikely to collide with whatever note happens to be decaying since the last
-- play.  /noid is supposed to be used for this, but it doesn't work on groups,
-- so without knowing everyone's decay time, I can't know how many IDs to
-- remember to cancel.
time_to_id :: Time.UTCTime -> NodeId
time_to_id :: UTCTime -> NodeId
time_to_id UTCTime
now = Int32 -> NodeId
NodeId forall a b. (a -> b) -> a -> b
$ Int32
min_node_id forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
ms forall a. Bits a => a -> a -> a
Bits..&. Integer
0xffffff)
    where ms :: Integer
ms = DiffTime -> Integer
Time.diffTimeToPicoseconds (UTCTime -> DiffTime
Time.utctDayTime UTCTime
now) forall a. Integral a => a -> a -> a
`div` Integer
1000000

player_thread :: State -> [LEvent.LEvent OSC.OSCBundle] -> IO ()
player_thread :: State -> [LEvent OSCBundle] -> IO ()
player_thread State
state [LEvent OSCBundle]
bundles = do
    State -> [LEvent OSCBundle] -> IO ()
play_loop State
state [LEvent OSCBundle]
bundles
        forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch` \(SomeException
exc :: Exception.SomeException) ->
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (Text
"player died: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt SomeException
exc) -- game over

play_loop :: State -> [LEvent.LEvent OSC.OSCBundle] -> IO ()
play_loop :: State -> [LEvent OSCBundle] -> IO ()
play_loop State
state = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall state a. state -> ((state -> a) -> state -> a) -> a
Control.loop1 forall a b. (a -> b) -> a -> b
$ \[LEvent OSCBundle] -> IO ()
loop [LEvent OSCBundle]
bundles -> do
    UTCTime
now <- IO UTCTime
Time.getCurrentTime
    let until :: UTCTime
until = NominalDiffTime -> UTCTime -> UTCTime
Time.addUTCTime (NominalDiffTime
write_ahead forall a. Num a => a -> a -> a
* NominalDiffTime
2) UTCTime
now
    let (([OSCBundle]
chunk, [Msg]
logs), [LEvent OSCBundle]
rest) = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall d. [LEvent d] -> ([d], [Msg])
LEvent.partition forall a b. (a -> b) -> a -> b
$
            forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((forall a. Ord a => a -> a -> Bool
<= UTCTime -> Timestamp
OSC.timestampFromUTC UTCTime
until) forall b c a. (b -> c) -> (a -> b) -> a -> c
. LEvent OSCBundle -> Timestamp
ltime_of) [LEvent OSCBundle]
bundles
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write [Msg]
logs
    -- unless (null chunk) $ do
    --     putStrLn "osc chunk: "
    --     mapM_ print chunk
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (PortNumber -> ByteString -> IO ()
send PortNumber
server_port forall b c a. (b -> c) -> (a -> b) -> a -> c
. OSCBundle -> ByteString
OSC.encodeOSCBundle) [OSCBundle]
chunk
    let timeout :: NominalDiffTime
timeout = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LEvent OSCBundle]
rest
            then forall b a. b -> (a -> b) -> Maybe a -> b
maybe UTCTime
now (Timestamp -> UTCTime
OSC.timestampToUTC forall b c a. (b -> c) -> (a -> b) -> a -> c
. OSCBundle -> Timestamp
time_of) (forall a. [a] -> Maybe a
Lists.last [OSCBundle]
chunk)
                UTCTime -> UTCTime -> NominalDiffTime
`Time.diffUTCTime` UTCTime
now
            else NominalDiffTime
write_ahead
    Bool
stop <- NominalDiffTime -> PlayControl -> IO Bool
Transport.poll_stop_player NominalDiffTime
timeout (State -> PlayControl
_play_control State
state)
    case (Bool
stop, [LEvent OSCBundle]
rest) of
        (Bool
True, [LEvent OSCBundle]
_) -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ OSC -> IO ()
send_osc [OSC]
stop_all
        (Bool
_, []) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (Bool, [LEvent OSCBundle])
_ -> [LEvent OSCBundle] -> IO ()
loop [LEvent OSCBundle]
rest
    where
    ltime_of :: LEvent OSCBundle -> Timestamp
ltime_of (LEvent.Log Msg
_) = UnboxedY -> Timestamp
OSC.Timestamp UnboxedY
0
    ltime_of (LEvent.Event OSCBundle
e) = OSCBundle -> Timestamp
time_of OSCBundle
e
    time_of :: OSCBundle -> Timestamp
time_of (OSC.OSCBundle Timestamp
ts [Either ByteString OSC]
_) = Timestamp
ts

write_ahead :: Time.NominalDiffTime
write_ahead :: NominalDiffTime
write_ahead = NominalDiffTime
1


-- * perform

to_bundles :: Time.UTCTime -> [LEvent.LEvent (RealTime, OSC.OSC)]
    -> [LEvent.LEvent OSC.OSCBundle]
to_bundles :: UTCTime -> [LEvent (RealTime, OSC)] -> [LEvent OSCBundle]
to_bundles UTCTime
start = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a} {a}.
Real a =>
(a, [LEvent (a, OSC)]) -> [LEvent OSCBundle]
make forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a. Eq key => (a -> key) -> [a] -> [(key, [a])]
Lists.keyedGroupAdjacent forall x. LEvent (RealTime, x) -> RealTime
time_of
    where
    make :: (a, [LEvent (a, OSC)]) -> [LEvent OSCBundle]
make (a
time, [LEvent (a, OSC)]
events) =
        forall a b. (a -> b) -> [a] -> [b]
map forall a. Msg -> LEvent a
LEvent.Log [Msg]
logs forall a. [a] -> [a] -> [a]
++ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(a, OSC)]
oscs then []
            else [forall a. a -> LEvent a
LEvent.Event forall a b. (a -> b) -> a -> b
$ UTCTime -> [OSC] -> OSCBundle
bundle UTCTime
t forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(a, OSC)]
oscs]
        where
        t :: UTCTime
t = NominalDiffTime -> UTCTime -> UTCTime
Time.addUTCTime (forall a b. (Real a, Fractional b) => a -> b
realToFrac a
time) UTCTime
start
        ([(a, OSC)]
oscs, [Msg]
logs) = forall d. [LEvent d] -> ([d], [Msg])
LEvent.partition [LEvent (a, OSC)]
events

notes_to_osc :: NodeId -> [LEvent.LEvent (RealTime, Note.Note)]
    -> [LEvent.LEvent (RealTime, OSC.OSC)]
notes_to_osc :: NodeId -> [LEvent (RealTime, Note)] -> [LEvent (RealTime, OSC)]
notes_to_osc NodeId
start_id =
    forall k a. Ord k => (a -> k) -> [[a]] -> [a]
Lists.mergeAscLists forall x. LEvent (RealTime, x) -> RealTime
time_of forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall {t} {a}. (t -> [a]) -> LEvent t -> [LEvent a]
apply (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry NodeId -> (RealTime, Note) -> [(RealTime, OSC)]
note_to_osc))
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. [a] -> [LEvent x] -> [LEvent (a, x)]
LEvent.zip [NodeId]
node_ids
    where
    node_ids :: [NodeId]
node_ids = NodeId -> [NodeId]
node_ids_from NodeId
start_id
    apply :: (t -> [a]) -> LEvent t -> [LEvent a]
apply t -> [a]
f = \case
        LEvent.Event t
e -> forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> LEvent a
LEvent.Event (t -> [a]
f t
e)
        LEvent.Log Msg
a -> [forall a. Msg -> LEvent a
LEvent.Log Msg
a]

time_of :: LEvent.LEvent (RealTime, x) -> RealTime
time_of :: forall x. LEvent (RealTime, x) -> RealTime
time_of (LEvent.Log Msg
_) = -RealTime
1forall a. Fractional a => a -> a -> a
/RealTime
0
time_of (LEvent.Event (RealTime
t, x
_)) = RealTime
t

note_to_osc :: NodeId -> (RealTime, Note.Note) -> [(RealTime, OSC.OSC)]
note_to_osc :: NodeId -> (RealTime, Note) -> [(RealTime, OSC)]
note_to_osc NodeId
node_id (RealTime
offset, Note.Note ByteString
patch RealTime
start Map ControlId Signal
controls) =
    forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (RealTime
offset+)) forall a b. (a -> b) -> a -> b
$ (RealTime
start, ByteString -> NodeId -> [(ControlId, UnboxedY)] -> OSC
s_new ByteString
patch NodeId
node_id [(ControlId, UnboxedY)]
initial)
        forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((forall a. Ord a => a -> a -> Bool
<=RealTime
start) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (NodeId -> Map ControlId Signal -> [(RealTime, OSC)]
control_oscs NodeId
node_id Map ControlId Signal
controls)
    where initial :: [(ControlId, UnboxedY)]
initial = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (RealTime -> Signal -> UnboxedY
MSignal.at RealTime
start)) (forall k a. Map k a -> [(k, a)]
Map.toAscList Map ControlId Signal
controls)

-- | Precondition: signals have already been trimmed to the right time range.
control_oscs :: NodeId -> Map Note.ControlId MSignal.Signal
    -> [(RealTime, OSC.OSC)]
control_oscs :: NodeId -> Map ControlId Signal -> [(RealTime, OSC)]
control_oscs NodeId
node_id =
    forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (NodeId -> [(ControlId, UnboxedY)] -> OSC
n_set NodeId
node_id)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => [(a, b)] -> [(a, NonNull b)]
Lists.groupAdjacentFst
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> k) -> [[a]] -> [a]
Lists.mergeLists forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {a}. (a, Signal) -> [(RealTime, (a, UnboxedY))]
extract forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toAscList
    where
    extract :: (a, Signal) -> [(RealTime, (a, UnboxedY))]
extract (a
control, Signal
sig) =
        [(RealTime
x, (a
control, UnboxedY
y)) | (RealTime
x, UnboxedY
y) <- Signal -> [(RealTime, UnboxedY)]
MSignal.to_pairs Signal
sig]

s_new :: Note.PatchName -> NodeId -> [(Note.ControlId, Double)] -> OSC.OSC
s_new :: ByteString -> NodeId -> [(ControlId, UnboxedY)] -> OSC
s_new ByteString
name (NodeId Int32
node_id) [(ControlId, UnboxedY)]
controls = ByteString -> [OSCDatum] -> OSC
OSC.OSC ByteString
"/s_new" forall a b. (a -> b) -> a -> b
$
    [ ByteString -> OSCDatum
OSC_S ByteString
name
    , Int32 -> OSCDatum
OSC_I Int32
node_id
    , Int32 -> OSCDatum
OSC_I (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Enum a => a -> Int
fromEnum AddAction
Head))
    , let NodeId Int32
id = NodeId
default_group in Int32 -> OSCDatum
OSC_I Int32
id
    ] forall a. [a] -> [a] -> [a]
++ [(ControlId, UnboxedY)] -> [OSCDatum]
controls_to_osc [(ControlId, UnboxedY)]
controls

-- | sclang sets up this as the default group.  I think if I launch scsynth
-- standalone I'll have to create it.
default_group :: NodeId
default_group :: NodeId
default_group = Int32 -> NodeId
NodeId Int32
1

n_set :: NodeId -> [(Note.ControlId, Double)] -> OSC.OSC
n_set :: NodeId -> [(ControlId, UnboxedY)] -> OSC
n_set (NodeId Int32
node_id) [(ControlId, UnboxedY)]
controls = ByteString -> [OSCDatum] -> OSC
OSC.OSC ByteString
"/n_set" forall a b. (a -> b) -> a -> b
$
    Int32 -> OSCDatum
OSC_I Int32
node_id forall a. a -> [a] -> [a]
: [(ControlId, UnboxedY)] -> [OSCDatum]
controls_to_osc [(ControlId, UnboxedY)]
controls

clear_sched :: OSC.OSC
clear_sched :: OSC
clear_sched = ByteString -> [OSCDatum] -> OSC
OSC.OSC ByteString
"/clearSched" []

s_noid :: NodeId -> OSC.OSC
s_noid :: NodeId -> OSC
s_noid (NodeId Int32
id) = ByteString -> [OSCDatum] -> OSC
OSC.OSC ByteString
"/s_noid" [Int32 -> OSCDatum
OSC_I Int32
id]

controls_to_osc :: [(Note.ControlId, Double)] -> [OSCDatum]
controls_to_osc :: [(ControlId, UnboxedY)] -> [OSCDatum]
controls_to_osc [(ControlId, UnboxedY)]
controls =
    [ OSCDatum
a | (Note.ControlId Int32
control, UnboxedY
val) <- [(ControlId, UnboxedY)]
controls
    , OSCDatum
a <- [Int32 -> OSCDatum
OSC_I Int32
control, Float -> OSCDatum
OSC_F (UnboxedY -> Float
Num.d2f UnboxedY
val)]
    ]

bundle :: Time.UTCTime -> [OSC.OSC] -> OSC.OSCBundle
bundle :: UTCTime -> [OSC] -> OSCBundle
bundle UTCTime
time = Timestamp -> [Either ByteString OSC] -> OSCBundle
OSC.OSCBundle (UTCTime -> Timestamp
OSC.timestampFromUTC UTCTime
time) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right

data AddAction = Head | Tail | Before | After | Replace
    deriving (AddAction -> AddAction -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AddAction -> AddAction -> Bool
$c/= :: AddAction -> AddAction -> Bool
== :: AddAction -> AddAction -> Bool
$c== :: AddAction -> AddAction -> Bool
Eq, Eq AddAction
AddAction -> AddAction -> Bool
AddAction -> AddAction -> Ordering
AddAction -> AddAction -> AddAction
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: AddAction -> AddAction -> AddAction
$cmin :: AddAction -> AddAction -> AddAction
max :: AddAction -> AddAction -> AddAction
$cmax :: AddAction -> AddAction -> AddAction
>= :: AddAction -> AddAction -> Bool
$c>= :: AddAction -> AddAction -> Bool
> :: AddAction -> AddAction -> Bool
$c> :: AddAction -> AddAction -> Bool
<= :: AddAction -> AddAction -> Bool
$c<= :: AddAction -> AddAction -> Bool
< :: AddAction -> AddAction -> Bool
$c< :: AddAction -> AddAction -> Bool
compare :: AddAction -> AddAction -> Ordering
$ccompare :: AddAction -> AddAction -> Ordering
Ord, Int -> AddAction -> ShowS
[AddAction] -> ShowS
AddAction -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [AddAction] -> ShowS
$cshowList :: [AddAction] -> ShowS
show :: AddAction -> FilePath
$cshow :: AddAction -> FilePath
showsPrec :: Int -> AddAction -> ShowS
$cshowsPrec :: Int -> AddAction -> ShowS
Show, Int -> AddAction
AddAction -> Int
AddAction -> [AddAction]
AddAction -> AddAction
AddAction -> AddAction -> [AddAction]
AddAction -> AddAction -> AddAction -> [AddAction]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: AddAction -> AddAction -> AddAction -> [AddAction]
$cenumFromThenTo :: AddAction -> AddAction -> AddAction -> [AddAction]
enumFromTo :: AddAction -> AddAction -> [AddAction]
$cenumFromTo :: AddAction -> AddAction -> [AddAction]
enumFromThen :: AddAction -> AddAction -> [AddAction]
$cenumFromThen :: AddAction -> AddAction -> [AddAction]
enumFrom :: AddAction -> [AddAction]
$cenumFrom :: AddAction -> [AddAction]
fromEnum :: AddAction -> Int
$cfromEnum :: AddAction -> Int
toEnum :: Int -> AddAction
$ctoEnum :: Int -> AddAction
pred :: AddAction -> AddAction
$cpred :: AddAction -> AddAction
succ :: AddAction -> AddAction
$csucc :: AddAction -> AddAction
Enum, AddAction
forall a. a -> a -> Bounded a
maxBound :: AddAction
$cmaxBound :: AddAction
minBound :: AddAction
$cminBound :: AddAction
Bounded)

-- * stop

stop_all :: [OSC.OSC]
stop_all :: [OSC]
stop_all =
    [ OSC
clear_sched
    , NodeId -> [(ControlId, UnboxedY)] -> OSC
n_set NodeId
default_group [(ControlId
Note.gate_id, UnboxedY
0)]
    ]

force_stop :: IO ()
force_stop :: IO ()
force_stop = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ OSC -> IO ()
send_osc
    [ OSC
clear_sched
    , NodeId -> OSC
g_freeAll NodeId
default_group
    ]

g_freeAll :: NodeId -> OSC.OSC
g_freeAll :: NodeId -> OSC
g_freeAll (NodeId Int32
id) = ByteString -> [OSCDatum] -> OSC
OSC.OSC ByteString
"/g_freeAll" [Int32 -> OSCDatum
OSC_I Int32
id]

-- * thru

-- Like MIDI thru, this is a vertical slice of convert and play for just a
-- single event, which is actually below the 'Note.Note' level.

-- | This is InputNote.NoteId, but I don't want a bunch of deps for a newtype
-- Int.
type NoteId = Int
type Triggered = Bool

note_to_node :: NoteId -> NodeId
note_to_node :: Int -> NodeId
note_to_node = Int32 -> NodeId
NodeId forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+Int32
min_node_id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral

osc_thru :: [OSC.OSC] -> IO ()
osc_thru :: [OSC] -> IO ()
osc_thru = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ OSC -> IO ()
send_osc

note_on :: Patch.Patch -> Triggered -> NoteId -> Pitch.NoteNumber -> Double
    -> [OSC.OSC]
note_on :: Patch -> Bool -> Int -> NoteNumber -> UnboxedY -> [OSC]
note_on Patch
patch Bool
triggered Int
note_id NoteNumber
nn UnboxedY
dyn =
    ( ByteString -> NodeId -> [(ControlId, UnboxedY)] -> OSC
s_new (Patch -> ByteString
Patch.name Patch
patch) (Int -> NodeId
note_to_node Int
note_id) forall a b. (a -> b) -> a -> b
$
        (ControlId
Note.gate_id, UnboxedY
1) forall a. a -> [a] -> [a]
: forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {t}. (Control, t) -> Maybe (ControlId, t)
convert
            [ (Control
Patch.c_pitch, NoteNumber -> UnboxedY
Pitch.nn_to_double NoteNumber
nn)
            , (Control
Controls.dynamic, UnboxedY
dyn)
            ]
    ) forall a. a -> [a] -> [a]
: if Bool
triggered
        -- TODO Should osc_thru should put a bit of space in between these?
        -- Or is separate packets enough separation for sc?
        then [NodeId -> [(ControlId, UnboxedY)] -> OSC
n_set (Int -> NodeId
note_to_node Int
note_id) [(ControlId
Note.gate_id, UnboxedY
0)]]
        else []
    where
    convert :: (Control, t) -> Maybe (ControlId, t)
convert (Control
control, t
val) =
        (, t
val) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
control (Patch -> Map Control ControlId
Patch.controls Patch
patch)

note_off :: Triggered -> NoteId -> [OSC.OSC]
note_off :: Bool -> Int -> [OSC]
note_off Bool
triggered Int
note_id = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ if Bool
triggered then []
        else [NodeId -> [(ControlId, UnboxedY)] -> OSC
n_set (Int -> NodeId
note_to_node Int
note_id) [(ControlId
Note.gate_id, UnboxedY
0)]]
    , [NodeId -> OSC
s_noid (Int -> NodeId
note_to_node Int
note_id)]
    ]

set_control :: Patch.Patch -> NoteId -> ScoreT.Control -> Double -> [OSC.OSC]
set_control :: Patch -> Int -> Control -> UnboxedY -> [OSC]
set_control Patch
patch Int
note_id Control
control UnboxedY
val =
    case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
control (Patch -> Map Control ControlId
Patch.controls Patch
patch) of
        Maybe ControlId
Nothing -> []
        Just ControlId
c -> [NodeId -> [(ControlId, UnboxedY)] -> OSC
n_set (Int -> NodeId
note_to_node Int
note_id) [(ControlId
c, UnboxedY
val)]]

pitch_change :: Patch.Patch -> NoteId -> Pitch.NoteNumber -> [OSC.OSC]
pitch_change :: Patch -> Int -> NoteNumber -> [OSC]
pitch_change Patch
patch Int
note_id NoteNumber
nn =
    case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
Patch.c_pitch (Patch -> Map Control ControlId
Patch.controls Patch
patch) of
        Maybe ControlId
Nothing -> []
        Just ControlId
c -> [NodeId -> [(ControlId, UnboxedY)] -> OSC
n_set (Int -> NodeId
note_to_node Int
note_id) [(ControlId
c, NoteNumber -> UnboxedY
Pitch.nn_to_double NoteNumber
nn)]]

-- * initialize

-- | Left error if a valid server wasn't detected, Right msg if it was.
version :: IO (Either Text Text)
version :: IO (Either Text Text)
version = PortNumber -> OSC -> IO (Maybe (Either FilePath OSC))
query PortNumber
server_port (ByteString -> [OSCDatum] -> OSC
OSC.OSC ByteString
"/version" []) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    Maybe (Either FilePath OSC)
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"scsynth not running on " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt PortNumber
server_port
    Just (Left FilePath
err) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
        Text
"unparseable response from scsynth on " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt PortNumber
server_port forall a. Semigroup a => a -> a -> a
<> Text
": "
        forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
txt FilePath
err
    Just (Right (OSC.OSC ByteString
"/version.reply"
            (OSC_S ByteString
name : OSC_I Int32
major : OSC_I Int32
minor : OSC_S ByteString
patch : [OSCDatum]
_))) ->
        forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
            [ forall a. Textlike a => a -> Text
Texts.toText ByteString
name, Text
" ", forall a. Show a => a -> Text
showt Int32
major, Text
".", forall a. Show a => a -> Text
showt Int32
minor
            , forall a. Textlike a => a -> Text
Texts.toText ByteString
patch
            ]
    Just (Right OSC
osc) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
        Text
"unexpected response from scsynth on " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt PortNumber
server_port forall a. Semigroup a => a -> a -> a
<> Text
": "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt OSC
osc

-- | The sclang IDE does this, but I have to do it myself for a standalone
-- scserver.
add_default_group :: IO ()
add_default_group :: IO ()
add_default_group = OSC -> IO ()
send_osc forall a b. (a -> b) -> a -> b
$ ByteString -> [OSCDatum] -> OSC
OSC.OSC ByteString
"/g_new"
    [Int32 -> OSCDatum
OSC_I Int32
id, Int32 -> OSCDatum
OSC_I (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Enum a => a -> Int
fromEnum AddAction
Head)), Int32 -> OSCDatum
OSC_I Int32
0]
    where
    NodeId Int32
id = NodeId
default_group

initialize_patch :: Patch.Patch -> IO ()
initialize_patch :: Patch -> IO ()
initialize_patch = FilePath -> IO ()
load_patch forall b c a. (b -> c) -> (a -> b) -> a -> c
. Patch -> FilePath
Patch.filename

-- | Wait for patches to load.
sync :: IO ()
sync :: IO ()
sync = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ PortNumber -> OSC -> IO (Maybe (Either FilePath OSC))
query PortNumber
server_port (ByteString -> [OSCDatum] -> OSC
OSC.OSC ByteString
"/sync" [])

load_patch :: FilePath -> IO ()
load_patch :: FilePath -> IO ()
load_patch = OSC -> IO ()
send_osc forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> OSC
d_load

d_load :: FilePath -> OSC.OSC
d_load :: FilePath -> OSC
d_load FilePath
path = ByteString -> [OSCDatum] -> OSC
OSC.OSC ByteString
"/d_load" [ByteString -> OSCDatum
OSC_S (forall a. Textlike a => a -> ByteString
Texts.toByteString FilePath
path)]

-- | Unfortunately this is kind of useless, because scsynth doesn't let you
-- unload all, and doesn't seem to have any way to see what's loaded.
d_free :: Note.PatchName -> OSC.OSC
d_free :: ByteString -> OSC
d_free ByteString
name = ByteString -> [OSCDatum] -> OSC
OSC.OSC ByteString
"/d_free" [ByteString -> OSCDatum
OSC_S (forall a. Textlike a => a -> ByteString
Texts.toByteString ByteString
name)]


-- * low level

send_osc :: OSC.OSC -> IO ()
send_osc :: OSC -> IO ()
send_osc = PortNumber -> ByteString -> IO ()
send PortNumber
server_port forall b c a. (b -> c) -> (a -> b) -> a -> c
. OSC -> ByteString
OSC.encodeOSC

send :: Socket.PortNumber -> ByteString.ByteString -> IO ()
send :: PortNumber -> ByteString -> IO ()
send PortNumber
port ByteString
bytes = forall a. Addr -> (Socket -> IO a) -> IO a
Network.withConnection (PortNumber -> Addr
Network.UDP PortNumber
port) forall a b. (a -> b) -> a -> b
$ \Socket
socket ->
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Socket -> ByteString -> IO Int
Socket.ByteString.send Socket
socket ByteString
bytes

-- | Send an OSC and expect a response.  Nothing if there was no server.
-- Otherwise, this could hang if the server does, throw an IO exception, or
-- return Left if the response couldn't be parsed.
query :: Socket.PortNumber -> OSC.OSC -> IO (Maybe (Either String OSC.OSC))
query :: PortNumber -> OSC -> IO (Maybe (Either FilePath OSC))
query PortNumber
port OSC
osc = forall a. Addr -> (Socket -> IO a) -> IO a
Network.withConnection (PortNumber -> Addr
Network.UDP PortNumber
port) forall a b. (a -> b) -> a -> b
$ \Socket
socket -> do
    Socket -> ByteString -> IO Int
Socket.ByteString.send Socket
socket forall a b. (a -> b) -> a -> b
$ OSC -> ByteString
OSC.encodeOSC OSC
osc
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Either FilePath OSC
OSC.decodeOSC forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEnoent (Socket -> Int -> IO ByteString
Socket.ByteString.recv Socket
socket Int
4096)