{-# Language ScopedTypeVariables #-}
module Csound.Typed.Control.Api(
    trigByName, trigByName_,
    trigByNameMidi, trigByNameMidi_,
    namedMonoMsg
) where

import Data.Boolean

import qualified Csound.Dynamic as D

import Csound.Typed.Types
import Csound.Typed.Control.Ref
import Csound.Typed.GlobalState
import Csound.Typed.GlobalState.Opcodes(eventi, Event(..), downsamp)
import Csound.Typed.InnerOpcodes
import Data.Text (Text)

import Csound.Typed.Plugins.TabQueue

-- | Creates an instrument that can be triggered by name with Csound API.
-- The arguments are determined from the structure of the input for the instrument.
--
-- With Csound API we can send messages
--
-- > i "name" time duration arg1 arg2 arg3
trigByName_ :: Arg a => Text -> (a -> SE ()) -> SE ()
trigByName_ :: forall a. Arg a => Text -> (a -> SE ()) -> SE ()
trigByName_ Text
name a -> SE ()
instr = GE () -> SE ()
forall a. GE a -> SE a
geToSe (GE () -> SE ()) -> GE () -> SE ()
forall a b. (a -> b) -> a -> b
$ Text -> InstrBody -> GE ()
saveNamedInstr Text
name (InstrBody -> GE ()) -> GE InstrBody -> GE ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (SE () -> GE InstrBody
execSE (SE () -> GE InstrBody) -> SE () -> GE InstrBody
forall a b. (a -> b) -> a -> b
$ a -> SE ()
instr a
forall a. Arg a => a
toArg)

-- | Creates an instrument that can be triggered by name with Csound API.
-- The arguments are determined from the structure of the input for the instrument.
-- If we have a tuple of arguments: @(D, D, Tab)@
-- The would be rendered to instrument arguments that strts from @p4@.
-- @p1@ is the name of teh instrument, @p2@ is the start time of the note,
-- @p3@ is the duration of the note. Then @p4@ and @p5@ are going to be doubles and @p6@
-- is an integer that denotes a functional table.
trigByName  :: (Arg a, Sigs b) => Text -> (a -> SE b) -> SE b
trigByName :: forall a b. (Arg a, Sigs b) => Text -> (a -> SE b) -> SE b
trigByName Text
name a -> SE b
instr = do
    Ref b
ref <- b -> SE (Ref b)
forall a. Tuple a => a -> SE (Ref a)
newClearableGlobalRef b
0
    Text -> (a -> SE ()) -> SE ()
forall a. Arg a => Text -> (a -> SE ()) -> SE ()
trigByName_ Text
name (Ref b -> a -> SE ()
go Ref b
ref)
    Ref b -> SE b
forall a. Tuple a => Ref a -> SE a
readRef Ref b
ref
    where go :: Ref b -> a -> SE ()
go Ref b
ref a
x = Ref b -> b -> SE ()
forall a. (Num a, Tuple a) => Ref a -> a -> SE ()
mixRef Ref b
ref (b -> SE ()) -> SE b -> SE ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a -> SE b
instr a
x


-- | It behaves just like the function @trigByNameMidi@. Only it doesn't produce an audio
-- signal. It performs some procedure on note on and stops doing the precedure on note off.
trigByNameMidi_ :: forall a . Arg a => Text -> ((D, D, a) -> SE ()) -> SE ()
trigByNameMidi_ :: forall a. Arg a => Text -> ((D, D, a) -> SE ()) -> SE ()
trigByNameMidi_ Text
name (D, D, a) -> SE ()
instr = do
    InstrId
instrId <- GE InstrId -> SE InstrId
forall a. GE a -> SE a
geToSe (GE InstrId -> SE InstrId) -> GE InstrId -> SE InstrId
forall a b. (a -> b) -> a -> b
$ SE () -> GE InstrId
saveInstr ((D, D, a) -> SE ()
instr (D, D, a)
forall a. Arg a => a
toArg)
    Text -> ((D, D, D, a) -> SE ()) -> SE ()
forall a. Arg a => Text -> (a -> SE ()) -> SE ()
trigByName_ Text
name (InstrId -> (D, D, D, a) -> SE ()
go InstrId
instrId)
    where
        go :: D.InstrId -> (D, D, D, a) -> SE ()
        go :: InstrId -> (D, D, D, a) -> SE ()
go InstrId
instrId (D
noteFlag, D
pch, D
vol, a
other) = Dep () -> SE ()
fromDep_ (Dep () -> SE ()) -> Dep () -> SE ()
forall a b. (a -> b) -> a -> b
$ GE (Dep ()) -> Dep ()
forall a. GE (Dep a) -> Dep a
hideGEinDep (GE (Dep ()) -> Dep ()) -> GE (Dep ()) -> Dep ()
forall a b. (a -> b) -> a -> b
$ do
            InstrBody
pchExpr      <- D -> GE InstrBody
forall a. Val a => a -> GE InstrBody
toGE D
pch
            let instrIdExpr :: InstrBody
instrIdExpr = InstrId -> InstrBody
D.instrIdE InstrId
instrId InstrBody -> InstrBody -> InstrBody
forall a. Num a => a -> a -> a
+ InstrBody
pchExpr InstrBody -> InstrBody -> InstrBody
forall a. Fractional a => a -> a -> a
/ InstrBody
1000
            InstrBody
noteFlagExpr <- D -> GE InstrBody
forall a. Val a => a -> GE InstrBody
toGE D
noteFlag
            [InstrBody]
args <- (D, D, a) -> GE [InstrBody]
forall a. Tuple a => a -> GE [InstrBody]
fromTuple (D
pch, D
vol, a
other)
            Dep () -> GE (Dep ())
forall a. a -> GE a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dep () -> GE (Dep ())) -> Dep () -> GE (Dep ())
forall a b. (a -> b) -> a -> b
$ do
                    IfRate -> InstrBody -> DepT GE (CodeBlock InstrBody) -> Dep ()
forall (m :: * -> *).
Monad m =>
IfRate -> InstrBody -> DepT m (CodeBlock InstrBody) -> DepT m ()
D.when1 IfRate
D.IfIr (InstrBody
noteFlagExpr InstrBody -> InstrBody -> InstrBody
forall bool.
(bool ~ BooleanOf InstrBody) =>
InstrBody -> InstrBody -> bool
forall a bool. (EqB a, bool ~ BooleanOf a) => a -> a -> bool
==* InstrBody
1) (DepT GE (CodeBlock InstrBody) -> Dep ())
-> DepT GE (CodeBlock InstrBody) -> Dep ()
forall a b. (a -> b) -> a -> b
$ do
                        Dep () -> DepT GE (CodeBlock InstrBody)
forall (m :: * -> *).
Monad m =>
DepT m () -> DepT m (CodeBlock InstrBody)
D.toBlock (Dep () -> DepT GE (CodeBlock InstrBody))
-> Dep () -> DepT GE (CodeBlock InstrBody)
forall a b. (a -> b) -> a -> b
$ Event -> Dep ()
forall (m :: * -> *). Monad m => Event -> DepT m ()
eventi (InstrBody -> InstrBody -> InstrBody -> [InstrBody] -> Event
Event InstrBody
instrIdExpr InstrBody
0 (-InstrBody
1) [InstrBody]
args)
                    IfRate -> InstrBody -> DepT GE (CodeBlock InstrBody) -> Dep ()
forall (m :: * -> *).
Monad m =>
IfRate -> InstrBody -> DepT m (CodeBlock InstrBody) -> DepT m ()
D.when1 IfRate
D.IfIr (InstrBody
noteFlagExpr InstrBody -> InstrBody -> InstrBody
forall bool.
(bool ~ BooleanOf InstrBody) =>
InstrBody -> InstrBody -> bool
forall a bool. (EqB a, bool ~ BooleanOf a) => a -> a -> bool
==* InstrBody
0) (DepT GE (CodeBlock InstrBody) -> Dep ())
-> DepT GE (CodeBlock InstrBody) -> Dep ()
forall a b. (a -> b) -> a -> b
$ do
                        Dep () -> DepT GE (CodeBlock InstrBody)
forall (m :: * -> *).
Monad m =>
DepT m () -> DepT m (CodeBlock InstrBody)
D.toBlock (Dep () -> DepT GE (CodeBlock InstrBody))
-> Dep () -> DepT GE (CodeBlock InstrBody)
forall a b. (a -> b) -> a -> b
$ Event -> Dep ()
forall (m :: * -> *). Monad m => Event -> DepT m ()
eventi (InstrBody -> InstrBody -> InstrBody -> [InstrBody] -> Event
Event (InstrBody -> InstrBody
forall a. Num a => a -> a
negate InstrBody
instrIdExpr) InstrBody
0 InstrBody
0 [InstrBody]
args)
                    Dep ()
forall (m :: * -> *). Monad m => DepT m ()
turnoff

-- | Creates an instrument that can be triggered by name with Csound API.
--
-- It's intended to be used like a midi instrument. It simulates a simplified midi protocol.
-- We can trigger notes:
--
-- > i "givenName" delay duration 1 pitchKey volumeKey auxParams     -- note on
-- > i "givenName" delay duration 0 pitchKey volumeKey auxParams     -- note off
--
-- The arguments are
--
-- > trigByNameMidi name instrument
--
-- The instrument takes a triplet of @(pitchKey, volumeKey, auxilliaryTuple)@.
-- The order does matter. Please don't pass the @volumeKey@ as the first argument.
-- The instrument expects the pitch key to be a first argument.

-- Under the hood
-- it creates held notes that are indexed by pitch. If you know the Csound it creates
-- the notes with indexes:
--
-- > i 18.pitchKey
--
-- Here the 18 is some generated integer index. And then on receiving a note a note off message for the specific key the
-- Csound procedure invokes:
--
-- > turnoff 18.pitchKey
trigByNameMidi  :: (Arg a, Sigs b) => Text -> ((D, D, a) -> SE b) -> SE b
trigByNameMidi :: forall a b. (Arg a, Sigs b) => Text -> ((D, D, a) -> SE b) -> SE b
trigByNameMidi Text
name (D, D, a) -> SE b
instr = do
    Ref b
ref <- b -> SE (Ref b)
forall a. Tuple a => a -> SE (Ref a)
newClearableGlobalRef b
0
    Text -> ((D, D, a) -> SE ()) -> SE ()
forall a. Arg a => Text -> ((D, D, a) -> SE ()) -> SE ()
trigByNameMidi_ Text
name (Ref b -> (D, D, a) -> SE ()
go Ref b
ref)
    Ref b -> SE b
forall a. Tuple a => Ref a -> SE a
readRef Ref b
ref
    where go :: Ref b -> (D, D, a) -> SE ()
go Ref b
ref (D, D, a)
x = Ref b -> b -> SE ()
forall a. (Num a, Tuple a) => Ref a -> a -> SE ()
mixRef Ref b
ref (b -> SE ()) -> SE b -> SE ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (D, D, a) -> SE b
instr (D, D, a)
x

namedMonoMsg :: Text -> SE MonoArg
namedMonoMsg :: Text -> SE MonoArg
namedMonoMsg Text
name = do
    Ref Sig
refPch <- Sig -> SE (Ref Sig)
forall a. Tuple a => a -> SE (Ref a)
newGlobalRef Sig
0
    Ref Sig
refVol <- Sig -> SE (Ref Sig)
forall a. Tuple a => a -> SE (Ref a)
newGlobalRef Sig
0
    Tab
tab <- Int -> SE Tab
newGlobalTab Int
24
    let onFlag :: BoolSig
onFlag = Tab -> BoolSig
tabQueue2_hasElements Tab
tab
    Text -> ((D, D) -> SE ()) -> ((D, D) -> SE ()) -> SE ()
trigByNameMidiCbk Text
name (Tab -> (D, D) -> SE ()
onNote Tab
tab) (Tab -> (D, D) -> SE ()
forall {b}. Tab -> (D, b) -> SE ()
offNote Tab
tab)
    BoolSig -> SE () -> SE ()
when1 BoolSig
onFlag (SE () -> SE ()) -> SE () -> SE ()
forall a b. (a -> b) -> a -> b
$ do
        let (Sig
pch, Sig
vol) = Tab -> (Sig, Sig)
tabQueue2_readLastElement Tab
tab
        Ref Sig -> Sig -> SE ()
forall a. Tuple a => Ref a -> a -> SE ()
writeRef Ref Sig
refPch Sig
pch
        Ref Sig -> Sig -> SE ()
forall a. Tuple a => Ref a -> a -> SE ()
writeRef Ref Sig
refVol Sig
vol
    BoolSig -> SE () -> SE ()
when1 (BoolSig -> BoolSig
forall b. Boolean b => b -> b
notB BoolSig
onFlag) (SE () -> SE ()) -> SE () -> SE ()
forall a b. (a -> b) -> a -> b
$ do
        Ref Sig -> Sig -> SE ()
forall a. Tuple a => Ref a -> a -> SE ()
writeRef Ref Sig
refVol Sig
0
    Sig
pchKey <- Ref Sig -> SE Sig
forall a. Tuple a => Ref a -> SE a
readRef Ref Sig
refPch
    Sig
volKey <- Ref Sig -> SE Sig
forall a. Tuple a => Ref a -> SE a
readRef Ref Sig
refVol
    let kgate :: Sig
kgate = BoolSig -> Sig -> Sig -> Sig
forall bool. (bool ~ BooleanOf Sig) => bool -> Sig -> Sig -> Sig
forall a bool. (IfB a, bool ~ BooleanOf a) => bool -> a -> a -> a
ifB BoolSig
onFlag Sig
1 Sig
0
        kamp :: Sig
kamp = Sig -> Sig
downsamp' Sig
volKey
        kcps :: Sig
kcps = Sig -> Sig
downsamp' Sig
pchKey
        trig :: Sig
trig = [Sig] -> Sig
changed [Sig
kamp, Sig
kcps]
    MonoArg -> SE MonoArg
forall a. a -> SE a
forall (m :: * -> *) a. Monad m => a -> m a
return (MonoArg -> SE MonoArg) -> MonoArg -> SE MonoArg
forall a b. (a -> b) -> a -> b
$ Sig -> Sig -> Sig -> Sig -> MonoArg
MonoArg Sig
kamp Sig
kcps Sig
kgate Sig
trig
    where
        onNote :: Tab -> (D, D) -> SE ()
onNote = Tab -> (D, D) -> SE ()
tabQueue2_append
        offNote :: Tab -> (D, b) -> SE ()
offNote Tab
tab (D
pch, b
_vol) = Tab -> D -> SE ()
tabQueue2_delete Tab
tab D
pch

trigByNameMidiCbk :: Text -> ((D, D) -> SE ())  -> ((D, D) -> SE ()) -> SE ()
trigByNameMidiCbk :: Text -> ((D, D) -> SE ()) -> ((D, D) -> SE ()) -> SE ()
trigByNameMidiCbk Text
name (D, D) -> SE ()
noteOn (D, D) -> SE ()
noteOff =
    Text -> ((D, D, D) -> SE ()) -> SE ()
forall a. Arg a => Text -> (a -> SE ()) -> SE ()
trigByName_ Text
name (D, D, D) -> SE ()
go
    where
        go :: (D, D, D) -> SE ()
        go :: (D, D, D) -> SE ()
go (D
noteFlag, D
pch, D
vol) = do
            BoolD -> SE () -> SE ()
whenD1 (D
noteFlag D -> D -> BoolD
forall bool. (bool ~ BooleanOf D) => D -> D -> bool
forall a bool. (EqB a, bool ~ BooleanOf a) => a -> a -> bool
==* D
1) (SE () -> SE ()) -> SE () -> SE ()
forall a b. (a -> b) -> a -> b
$ (D, D) -> SE ()
noteOn (D
pch, D
vol)
            BoolD -> SE () -> SE ()
whenD1 (D
noteFlag D -> D -> BoolD
forall bool. (bool ~ BooleanOf D) => D -> D -> bool
forall a bool. (EqB a, bool ~ BooleanOf a) => a -> a -> bool
==* D
0) (SE () -> SE ()) -> SE () -> SE ()
forall a b. (a -> b) -> a -> b
$ (D, D) -> SE ()
noteOff (D
pch, D
vol)
            Dep () -> SE ()
forall a. Dep a -> SE a
SE Dep ()
forall (m :: * -> *). Monad m => DepT m ()
turnoff

downsamp' :: Sig -> Sig
downsamp' :: Sig -> Sig
downsamp' Sig
a = GE InstrBody -> Sig
forall a. Val a => GE InstrBody -> a
fromGE (GE InstrBody -> Sig) -> GE InstrBody -> Sig
forall a b. (a -> b) -> a -> b
$ do
    InstrBody
a' <- Sig -> GE InstrBody
forall a. Val a => a -> GE InstrBody
toGE Sig
a
    InstrBody -> GE InstrBody
forall a. a -> GE a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBody -> GE InstrBody) -> InstrBody -> GE InstrBody
forall a b. (a -> b) -> a -> b
$ InstrBody -> InstrBody
downsamp InstrBody
a'