module Csound.Typed.GlobalState.Instr where

import Control.Monad
import Data.Map

import Csound.Dynamic
import qualified Csound.Typed.GlobalState.Elements as C

import Csound.Typed.Types.MixSco
import Csound.Typed.Types.Prim
import Csound.Typed.GlobalState.GE
import Csound.Typed.GlobalState.SE
import Csound.Typed.GlobalState.Options
import Csound.Typed.GlobalState.Opcodes(turnoff2, exitnow, servantUpdateChnAlive, servantUpdateChnRetrig)
import Csound.Typed.GlobalState.Elements(getInstrIds)

data Arity = Arity
    { Arity -> Int
arityIns      :: Int
    , Arity -> Int
arityOuts     :: Int }

type InsExp = SE [E]
type EffExp = [E] -> SE [E]
type UnitExp = SE ()

saveInstr :: SE () -> GE InstrId
saveInstr :: SE () -> GE InstrId
saveInstr SE ()
a = UpdField Instrs InstrId
forall a. UpdField Instrs a
onInstr UpdField Instrs InstrId
-> (InstrBody -> State Instrs InstrId) -> InstrBody -> GE InstrId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstrBody -> State Instrs InstrId
C.saveInstr (InstrBody -> GE InstrId) -> GE InstrBody -> GE InstrId
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SE () -> GE InstrBody
execSE SE ()
a

livenessWatch :: Arity -> SE ()
livenessWatch :: Arity -> SE ()
livenessWatch Arity
arity = Dep () -> SE ()
fromDep_ (Dep () -> SE ()) -> Dep () -> SE ()
forall a b. (a -> b) -> a -> b
$ Int -> Dep ()
forall (m :: * -> *). Monad m => Int -> DepT m ()
servantUpdateChnAlive (Int -> Int
C.chnPargId (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Arity -> Int
arityIns Arity
arity)

retrigWatch :: Arity -> SE ()
retrigWatch :: Arity -> SE ()
retrigWatch Arity
arity = Dep () -> SE ()
fromDep_ (Dep () -> SE ()) -> Dep () -> SE ()
forall a b. (a -> b) -> a -> b
$ Int -> Dep ()
forall (m :: * -> *). Monad m => Int -> DepT m ()
servantUpdateChnRetrig (Int -> Int
C.chnPargId (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Arity -> Int
arityIns Arity
arity)

saveSourceInstrCachedWithLivenessWatch :: Arity -> InsExp -> GE InstrId
saveSourceInstrCachedWithLivenessWatch :: Arity -> InsExp -> GE InstrId
saveSourceInstrCachedWithLivenessWatch Arity
arity InsExp
instr = SE () -> GE InstrId
saveInstr (SE () -> GE InstrId) -> SE () -> GE InstrId
forall a b. (a -> b) -> a -> b
$ do
    [InstrBody] -> SE ()
toOut ([InstrBody] -> SE ()) -> InsExp -> SE ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< InsExp
instr
    Arity -> SE ()
livenessWatch Arity
arity
    where toOut :: [InstrBody] -> SE ()
toOut = Dep () -> SE ()
forall a. Dep a -> SE a
SE (Dep () -> SE ())
-> ([InstrBody] -> Dep ()) -> [InstrBody] -> SE ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> [InstrBody] -> Dep ()
forall (m :: * -> *).
Monad m =>
Int -> Int -> [InstrBody] -> DepT m ()
C.sendChn (Arity -> Int
arityIns Arity
arity) (Arity -> Int
arityOuts Arity
arity)

saveSourceInstrCachedWithLivenessWatchAndRetrig :: Arity -> InsExp -> GE InstrId
saveSourceInstrCachedWithLivenessWatchAndRetrig :: Arity -> InsExp -> GE InstrId
saveSourceInstrCachedWithLivenessWatchAndRetrig Arity
arity InsExp
instr = SE () -> GE InstrId
saveInstr (SE () -> GE InstrId) -> SE () -> GE InstrId
forall a b. (a -> b) -> a -> b
$ do
    [InstrBody] -> SE ()
toOut ([InstrBody] -> SE ()) -> InsExp -> SE ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< InsExp
instr
    Arity -> SE ()
retrigWatch Arity
arity
    Arity -> SE ()
livenessWatch Arity
arity
    where toOut :: [InstrBody] -> SE ()
toOut = Dep () -> SE ()
forall a. Dep a -> SE a
SE (Dep () -> SE ())
-> ([InstrBody] -> Dep ()) -> [InstrBody] -> SE ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> [InstrBody] -> Dep ()
forall (m :: * -> *).
Monad m =>
Int -> Int -> [InstrBody] -> DepT m ()
C.sendChn (Arity -> Int
arityIns Arity
arity) (Arity -> Int
arityOuts Arity
arity)

saveSourceInstrCachedWithLivenessWatchAndRetrigAndEvtLoop :: Arity -> InsExp -> UnitExp -> GE (InstrId, InstrId)
saveSourceInstrCachedWithLivenessWatchAndRetrigAndEvtLoop :: Arity -> InsExp -> SE () -> GE (InstrId, InstrId)
saveSourceInstrCachedWithLivenessWatchAndRetrigAndEvtLoop Arity
arity InsExp
instr SE ()
evtInstr = do
    InstrId
instrId <- Arity -> InsExp -> GE InstrId
saveSourceInstrCachedWithLivenessWatchAndRetrig Arity
arity InsExp
instr
    InstrId
evtInstrId <- SE () -> GE InstrId
saveInstr (SE ()
evtInstr SE () -> SE () -> SE ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Arity -> SE ()
retrigWatch Arity
evtInstrArity SE () -> SE () -> SE ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Arity -> SE ()
livenessWatch Arity
evtInstrArity)
    (InstrId, InstrId) -> GE (InstrId, InstrId)
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrId
instrId, InstrId
evtInstrId)
    where
        evtInstrArity :: Arity
evtInstrArity = Int -> Int -> Arity
Arity Int
0 Int
0

saveSourceInstrCached :: Arity -> InsExp -> GE InstrId
saveSourceInstrCached :: Arity -> InsExp -> GE InstrId
saveSourceInstrCached Arity
arity InsExp
instr = SE () -> GE InstrId
saveInstr (SE () -> GE InstrId) -> SE () -> GE InstrId
forall a b. (a -> b) -> a -> b
$ [InstrBody] -> SE ()
toOut ([InstrBody] -> SE ()) -> InsExp -> SE ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< InsExp
instr
    where toOut :: [InstrBody] -> SE ()
toOut = Dep () -> SE ()
forall a. Dep a -> SE a
SE (Dep () -> SE ())
-> ([InstrBody] -> Dep ()) -> [InstrBody] -> SE ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> [InstrBody] -> Dep ()
forall (m :: * -> *).
Monad m =>
Int -> Int -> [InstrBody] -> DepT m ()
C.sendChn (Arity -> Int
arityIns Arity
arity) (Arity -> Int
arityOuts Arity
arity)

saveSourceInstrCached_ :: UnitExp -> GE InstrId
saveSourceInstrCached_ :: SE () -> GE InstrId
saveSourceInstrCached_ SE ()
instr = SE () -> GE InstrId
saveInstr SE ()
instr

saveSourceInstrCachedWithLivenessWatch_ :: Arity -> UnitExp -> GE InstrId
saveSourceInstrCachedWithLivenessWatch_ :: Arity -> SE () -> GE InstrId
saveSourceInstrCachedWithLivenessWatch_ Arity
arity SE ()
instr = SE () -> GE InstrId
saveInstr (SE () -> GE InstrId) -> SE () -> GE InstrId
forall a b. (a -> b) -> a -> b
$
    SE ()
instr SE () -> SE () -> SE ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Arity -> SE ()
livenessWatch Arity
arity

saveEffectInstr :: Arity -> EffExp -> GE InstrId
saveEffectInstr :: Arity -> EffExp -> GE InstrId
saveEffectInstr Arity
arity EffExp
eff = SE () -> GE InstrId
saveInstr (SE () -> GE InstrId) -> SE () -> GE InstrId
forall a b. (a -> b) -> a -> b
$ [InstrBody] -> SE ()
setOuts ([InstrBody] -> SE ()) -> InsExp -> SE ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< EffExp
eff EffExp -> InsExp -> InsExp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< InsExp
getIns
    where
        setOuts :: [InstrBody] -> SE ()
setOuts = Dep () -> SE ()
forall a. Dep a -> SE a
SE (Dep () -> SE ())
-> ([InstrBody] -> Dep ()) -> [InstrBody] -> SE ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChnRef -> [InstrBody] -> Dep ()
forall (m :: * -> *). Monad m => ChnRef -> [InstrBody] -> DepT m ()
C.writeChn (Int -> Int -> ChnRef
C.chnRefFromParg Int
5 (Arity -> Int
arityOuts Arity
arity))
        getIns :: InsExp
getIns  = Dep [InstrBody] -> InsExp
forall a. Dep a -> SE a
SE (Dep [InstrBody] -> InsExp) -> Dep [InstrBody] -> InsExp
forall a b. (a -> b) -> a -> b
$ ChnRef -> Dep [InstrBody]
forall (m :: * -> *). Monad m => ChnRef -> DepT m [InstrBody]
C.readChn  (ChnRef -> Dep [InstrBody]) -> ChnRef -> Dep [InstrBody]
forall a b. (a -> b) -> a -> b
$ Int -> Int -> ChnRef
C.chnRefFromParg Int
4 (Arity -> Int
arityIns  Arity
arity)

saveMixInstr :: Int -> CsdEventList M -> GE InstrId
saveMixInstr :: Int -> CsdEventList M -> GE InstrId
saveMixInstr Int
arity CsdEventList M
a = do
    InstrBody -> GE ()
setDuration (InstrBody -> GE ()) -> GE InstrBody -> GE ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Sig -> GE InstrBody
forall a. Val a => a -> GE InstrBody
toGE (CsdEventList M -> Sig
forall a. CsdEventList a -> Sig
csdEventListDur CsdEventList M
a)
    SE () -> GE InstrId
saveInstr (SE () -> GE InstrId) -> SE () -> GE InstrId
forall a b. (a -> b) -> a -> b
$ Dep () -> SE ()
forall a. Dep a -> SE a
SE (Dep () -> SE ()) -> Dep () -> SE ()
forall a b. (a -> b) -> a -> b
$ Int -> [InstrBody] -> Dep ()
forall (m :: * -> *). Monad m => Int -> [InstrBody] -> DepT m ()
C.sendOut Int
arity ([InstrBody] -> Dep ()) -> Dep [InstrBody] -> Dep ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> CsdEventList M -> Dep [InstrBody]
renderMixSco Int
arity CsdEventList M
a

saveMixInstr_ :: CsdEventList M -> GE (DepT GE ())
saveMixInstr_ :: CsdEventList M -> GE (Dep ())
saveMixInstr_ CsdEventList M
a = do
    InstrBody -> GE ()
setDuration (InstrBody -> GE ()) -> GE InstrBody -> GE ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Sig -> GE InstrBody
forall a. Val a => a -> GE InstrBody
toGE (CsdEventList M -> Sig
forall a. CsdEventList a -> Sig
csdEventListDur CsdEventList M
a)
    Dep () -> GE (Dep ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Dep () -> GE (Dep ())) -> Dep () -> GE (Dep ())
forall a b. (a -> b) -> a -> b
$ CsdEventList M -> Dep ()
renderMixSco_ CsdEventList M
a

saveMasterInstr :: Arity -> InsExp -> GE ()
saveMasterInstr :: Arity -> InsExp -> GE ()
saveMasterInstr Arity
arity InsExp
sigs = do
    Double
gainLevel <- (Options -> Double) -> GE Options -> GE Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Options -> Double
defGain GE Options
getOptions
    InstrId -> GE ()
saveAlwaysOnInstr (InstrId -> GE ()) -> GE InstrId -> GE ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (SE () -> GE InstrId
saveInstr (SE () -> GE InstrId) -> SE () -> GE InstrId
forall a b. (a -> b) -> a -> b
$ (Dep () -> SE ()
forall a. Dep a -> SE a
SE (Dep () -> SE ())
-> ([InstrBody] -> Dep ()) -> [InstrBody] -> SE ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [InstrBody] -> Dep ()
forall (m :: * -> *). Monad m => Int -> [InstrBody] -> DepT m ()
C.sendOut (Arity -> Int
arityOuts Arity
arity) ([InstrBody] -> Dep ())
-> ([InstrBody] -> [InstrBody]) -> [InstrBody] -> Dep ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> [InstrBody] -> [InstrBody]
C.safeOut Double
gainLevel) ([InstrBody] -> SE ()) -> InsExp -> SE ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< InsExp
sigs)

saveMidiInstr :: C.MidiType -> C.Channel -> Arity -> InsExp -> GE [E]
saveMidiInstr :: MidiType -> Int -> Arity -> InsExp -> GE [InstrBody]
saveMidiInstr MidiType
midiType Int
channel Arity
arity InsExp
instr = do
    GE ()
setDurationToInfinite
    [Var]
vars <- UpdField Globals [Var]
forall a. UpdField Globals a
onGlobals UpdField Globals [Var] -> UpdField Globals [Var]
forall a b. (a -> b) -> a -> b
$ [StateT Globals Identity Var] -> StateT Globals Identity [Var]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([StateT Globals Identity Var] -> StateT Globals Identity [Var])
-> [StateT Globals Identity Var] -> StateT Globals Identity [Var]
forall a b. (a -> b) -> a -> b
$ Int -> StateT Globals Identity Var -> [StateT Globals Identity Var]
forall a. Int -> a -> [a]
replicate (Arity -> Int
arityOuts Arity
arity) (Rate -> InstrBody -> StateT Globals Identity Var
C.newClearableGlobalVar Rate
Ar InstrBody
0)
    let expr :: SE ()
expr = (Dep () -> SE ()
forall a. Dep a -> SE a
SE (Dep () -> SE ())
-> ([InstrBody] -> Dep ()) -> [InstrBody] -> SE ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var -> InstrBody -> Dep ()) -> [Var] -> [InstrBody] -> Dep ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ ((InstrBody -> InstrBody -> InstrBody) -> Var -> InstrBody -> Dep ()
forall (m :: * -> *).
Monad m =>
(InstrBody -> InstrBody -> InstrBody)
-> Var -> InstrBody -> DepT m ()
appendVarBy InstrBody -> InstrBody -> InstrBody
forall a. Num a => a -> a -> a
(+)) [Var]
vars) ([InstrBody] -> SE ()) -> InsExp -> SE ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< InsExp
instr
    InstrId
instrId <- SE () -> GE InstrId
saveInstr SE ()
expr
    MidiAssign -> GE ()
saveMidi (MidiAssign -> GE ()) -> MidiAssign -> GE ()
forall a b. (a -> b) -> a -> b
$ MidiType -> Int -> InstrId -> MidiAssign
MidiAssign MidiType
midiType Int
channel InstrId
instrId
    [InstrBody] -> GE [InstrBody]
forall (m :: * -> *) a. Monad m => a -> m a
return ([InstrBody] -> GE [InstrBody]) -> [InstrBody] -> GE [InstrBody]
forall a b. (a -> b) -> a -> b
$ (Var -> InstrBody) -> [Var] -> [InstrBody]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Var -> InstrBody
readOnlyVar [Var]
vars

saveMidiMap :: GE ()
saveMidiMap :: GE ()
saveMidiMap = do
    MidiMap GE
m <- (History -> MidiMap GE) -> GE History -> GE (MidiMap GE)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap History -> MidiMap GE
midiMap GE History
getHistory
    ((MidiKey, Dep ()) -> GE ()) -> [(MidiKey, Dep ())] -> GE ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(C.MidiKey MidiType
midiType Int
channel, Dep ()
instrExpr) -> MidiType -> Int -> SE () -> GE ()
saveMidiInstr_ MidiType
midiType Int
channel (Dep () -> SE ()
forall a. Dep a -> SE a
SE Dep ()
instrExpr)) ([(MidiKey, Dep ())] -> GE ()) -> [(MidiKey, Dep ())] -> GE ()
forall a b. (a -> b) -> a -> b
$ MidiMap GE -> [(MidiKey, Dep ())]
forall k a. Map k a -> [(k, a)]
toList MidiMap GE
m

saveMidiInstr_ :: C.MidiType -> C.Channel -> UnitExp -> GE ()
saveMidiInstr_ :: MidiType -> Int -> SE () -> GE ()
saveMidiInstr_ MidiType
midiType Int
channel SE ()
instr = do
    InstrId
instrId <- SE () -> GE InstrId
saveInstr SE ()
instr
    MidiAssign -> GE ()
saveMidi (MidiAssign -> GE ()) -> MidiAssign -> GE ()
forall a b. (a -> b) -> a -> b
$ MidiType -> Int -> InstrId -> MidiAssign
MidiAssign MidiType
midiType Int
channel InstrId
instrId

saveIns0 :: Int -> [Rate] -> SE [E] -> GE [E]
saveIns0 :: Int -> [Rate] -> InsExp -> GE [InstrBody]
saveIns0 Int
arity [Rate]
rates InsExp
as = do
    [Var]
vars <- UpdField Globals [Var]
forall a. UpdField Globals a
onGlobals UpdField Globals [Var] -> UpdField Globals [Var]
forall a b. (a -> b) -> a -> b
$ (Rate -> InstrBody -> StateT Globals Identity Var)
-> [Rate] -> [InstrBody] -> StateT Globals Identity [Var]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Rate -> InstrBody -> StateT Globals Identity Var
C.newPersistentGlobalVar [Rate]
rates (Int -> InstrBody -> [InstrBody]
forall a. Int -> a -> [a]
replicate Int
arity InstrBody
0)
    Dep () -> GE ()
saveUserInstr0 (Dep () -> GE ()) -> Dep () -> GE ()
forall a b. (a -> b) -> a -> b
$ SE () -> Dep ()
forall a. SE a -> Dep a
unSE (SE () -> Dep ()) -> SE () -> Dep ()
forall a b. (a -> b) -> a -> b
$ (Dep () -> SE ()
forall a. Dep a -> SE a
SE (Dep () -> SE ())
-> ([InstrBody] -> Dep ()) -> [InstrBody] -> SE ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var -> InstrBody -> Dep ()) -> [Var] -> [InstrBody] -> Dep ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ Var -> InstrBody -> Dep ()
forall (m :: * -> *). Monad m => Var -> InstrBody -> DepT m ()
writeVar [Var]
vars) ([InstrBody] -> SE ()) -> InsExp -> SE ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< InsExp
as
    [InstrBody] -> GE [InstrBody]
forall (m :: * -> *) a. Monad m => a -> m a
return ([InstrBody] -> GE [InstrBody]) -> [InstrBody] -> GE [InstrBody]
forall a b. (a -> b) -> a -> b
$ (Var -> InstrBody) -> [Var] -> [InstrBody]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Var -> InstrBody
readOnlyVar [Var]
vars

terminatorInstr :: GE (SE ())
terminatorInstr :: GE (SE ())
terminatorInstr = do
    [InstrId]
ids <- (History -> [InstrId]) -> GE History -> GE [InstrId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Instrs -> [InstrId]
getInstrIds (Instrs -> [InstrId])
-> (History -> Instrs) -> History -> [InstrId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. History -> Instrs
instrs) GE History
getHistory
    SE () -> GE (SE ())
forall (m :: * -> *) a. Monad m => a -> m a
return (SE () -> GE (SE ())) -> SE () -> GE (SE ())
forall a b. (a -> b) -> a -> b
$ Dep () -> SE ()
fromDep_ (Dep () -> SE ()) -> Dep () -> SE ()
forall a b. (a -> b) -> a -> b
$ ((InstrBody -> Dep ()) -> [InstrBody] -> Dep ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ InstrBody -> Dep ()
forall (m :: * -> *). Monad m => InstrBody -> DepT m ()
turnoff2 ([InstrBody] -> Dep ()) -> [InstrBody] -> Dep ()
forall a b. (a -> b) -> a -> b
$ (InstrId -> InstrBody) -> [InstrId] -> [InstrBody]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap InstrId -> InstrBody
instrIdE [InstrId]
ids) Dep () -> Dep () -> Dep ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Dep ()
forall (m :: * -> *). Monad m => DepT m ()
exitnow