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
-> (E -> State Instrs InstrId) -> E -> GE InstrId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> State Instrs InstrId
C.saveInstr (E -> GE InstrId) -> GE E -> GE InstrId
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SE () -> GE E
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
    [E] -> SE ()
toOut ([E] -> 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 :: [E] -> SE ()
toOut = Dep () -> SE ()
forall a. Dep a -> SE a
SE (Dep () -> SE ()) -> ([E] -> Dep ()) -> [E] -> SE ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> [E] -> Dep ()
forall (m :: * -> *). Monad m => Int -> Int -> [E] -> 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
    [E] -> SE ()
toOut ([E] -> 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 :: [E] -> SE ()
toOut = Dep () -> SE ()
forall a. Dep a -> SE a
SE (Dep () -> SE ()) -> ([E] -> Dep ()) -> [E] -> SE ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> [E] -> Dep ()
forall (m :: * -> *). Monad m => Int -> Int -> [E] -> 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 a b. SE a -> SE b -> SE b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Arity -> SE ()
retrigWatch Arity
evtInstrArity SE () -> SE () -> SE ()
forall a b. SE a -> SE b -> SE b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Arity -> SE ()
livenessWatch Arity
evtInstrArity)
    (InstrId, InstrId) -> GE (InstrId, InstrId)
forall a. a -> GE a
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
$ [E] -> SE ()
toOut ([E] -> SE ()) -> InsExp -> SE ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< InsExp
instr
    where toOut :: [E] -> SE ()
toOut = Dep () -> SE ()
forall a. Dep a -> SE a
SE (Dep () -> SE ()) -> ([E] -> Dep ()) -> [E] -> SE ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> [E] -> Dep ()
forall (m :: * -> *). Monad m => Int -> Int -> [E] -> 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 a b. SE a -> SE b -> SE b
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
$ [E] -> SE ()
setOuts ([E] -> 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 :: [E] -> SE ()
setOuts = Dep () -> SE ()
forall a. Dep a -> SE a
SE (Dep () -> SE ()) -> ([E] -> Dep ()) -> [E] -> SE ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChnRef -> [E] -> Dep ()
forall (m :: * -> *). Monad m => ChnRef -> [E] -> DepT m ()
C.writeChn (Int -> Int -> ChnRef
C.chnRefFromParg Int
5 (Arity -> Int
arityOuts Arity
arity))
        getIns :: InsExp
getIns  = Dep [E] -> InsExp
forall a. Dep a -> SE a
SE (Dep [E] -> InsExp) -> Dep [E] -> InsExp
forall a b. (a -> b) -> a -> b
$ ChnRef -> Dep [E]
forall (m :: * -> *). Monad m => ChnRef -> DepT m [E]
C.readChn  (ChnRef -> Dep [E]) -> ChnRef -> Dep [E]
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
    E -> GE ()
setDuration (E -> GE ()) -> GE E -> GE ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Sig -> GE E
forall a. Val a => a -> GE E
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 -> [E] -> Dep ()
forall (m :: * -> *). Monad m => Int -> [E] -> DepT m ()
C.sendOut Int
arity ([E] -> Dep ()) -> Dep [E] -> Dep ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> CsdEventList M -> Dep [E]
renderMixSco Int
arity CsdEventList M
a

saveMixInstr_ :: CsdEventList M -> GE (DepT GE ())
saveMixInstr_ :: CsdEventList M -> GE (Dep ())
saveMixInstr_ CsdEventList M
a = do
    E -> GE ()
setDuration (E -> GE ()) -> GE E -> GE ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Sig -> GE E
forall a. Val a => a -> GE E
toGE (CsdEventList M -> Sig
forall a. CsdEventList a -> Sig
csdEventListDur CsdEventList M
a)
    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
$ 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 a b. (a -> b) -> GE a -> GE b
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 ()) -> ([E] -> Dep ()) -> [E] -> SE ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [E] -> Dep ()
forall (m :: * -> *). Monad m => Int -> [E] -> DepT m ()
C.sendOut (Arity -> Int
arityOuts Arity
arity) ([E] -> Dep ()) -> ([E] -> [E]) -> [E] -> Dep ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> [E] -> [E]
C.safeOut Double
gainLevel) ([E] -> 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 [E]
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)
forall (m :: * -> *) a. Monad m => [m a] -> m [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 -> E -> StateT Globals Identity Var
C.newClearableGlobalVar Rate
Ar E
0)
    let expr :: SE ()
expr = (Dep () -> SE ()
forall a. Dep a -> SE a
SE (Dep () -> SE ()) -> ([E] -> Dep ()) -> [E] -> SE ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var -> E -> Dep ()) -> [Var] -> [E] -> Dep ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ ((E -> E -> E) -> Var -> E -> Dep ()
forall (m :: * -> *).
Monad m =>
(E -> E -> E) -> Var -> E -> DepT m ()
appendVarBy E -> E -> E
forall a. Num a => a -> a -> a
(+)) [Var]
vars) ([E] -> 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
    [E] -> GE [E]
forall a. a -> GE a
forall (m :: * -> *) a. Monad m => a -> m a
return ([E] -> GE [E]) -> [E] -> GE [E]
forall a b. (a -> b) -> a -> b
$ (Var -> E) -> [Var] -> [E]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Var -> E
readOnlyVar [Var]
vars

saveMidiMap :: GE ()
saveMidiMap :: GE ()
saveMidiMap = do
    MidiMap GE
m <- (History -> MidiMap GE) -> GE History -> GE (MidiMap GE)
forall a b. (a -> b) -> GE a -> GE b
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 [E]
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 -> E -> StateT Globals Identity Var)
-> [Rate] -> [E] -> StateT Globals Identity [Var]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Rate -> E -> StateT Globals Identity Var
C.newPersistentGlobalVar [Rate]
rates (Int -> E -> [E]
forall a. Int -> a -> [a]
replicate Int
arity E
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 ()) -> ([E] -> Dep ()) -> [E] -> SE ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var -> E -> Dep ()) -> [Var] -> [E] -> Dep ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ Var -> E -> Dep ()
forall (m :: * -> *). Monad m => Var -> E -> DepT m ()
writeVar [Var]
vars) ([E] -> SE ()) -> InsExp -> SE ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< InsExp
as
    [E] -> GE [E]
forall a. a -> GE a
forall (m :: * -> *) a. Monad m => a -> m a
return ([E] -> GE [E]) -> [E] -> GE [E]
forall a b. (a -> b) -> a -> b
$ (Var -> E) -> [Var] -> [E]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Var -> E
readOnlyVar [Var]
vars

terminatorInstr :: GE (SE ())
terminatorInstr :: GE (SE ())
terminatorInstr = do
    [InstrId]
ids <- (History -> [InstrId]) -> GE History -> GE [InstrId]
forall a b. (a -> b) -> GE a -> GE b
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 a. a -> GE a
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
$ ((E -> Dep ()) -> [E] -> Dep ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ E -> Dep ()
forall (m :: * -> *). Monad m => E -> DepT m ()
turnoff2 ([E] -> Dep ()) -> [E] -> Dep ()
forall a b. (a -> b) -> a -> b
$ (InstrId -> E) -> [InstrId] -> [E]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap InstrId -> E
instrIdE [InstrId]
ids) Dep () -> Dep () -> Dep ()
forall a b. DepT GE a -> DepT GE b -> DepT GE b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Dep ()
forall (m :: * -> *). Monad m => DepT m ()
exitnow