{-# Language FlexibleContexts #-}
module Csound.Control.Midi(
MidiChn(..), MidiFun, toMidiFun, toMidiFun_,
Msg, Channel, midi, midin, pgmidi, ampCps,
midi_, midin_, pgmidi_,
monoMsg, holdMsg, trigNamedMono, genMonoMsg, smoothMonoArg,
genFilteredMonoMsg, genFilteredMonoMsgTemp,
monoMsgTemp, holdMsgTemp, genMonoMsgTemp,
midiKeyOn, midiKeyOff,
cpsmidi, ampmidi, initc7, ctrl7, midiCtrl7, midiCtrl, umidiCtrl,
ampmidinn,
ampCps', cpsmidi', cpsmidi'D, cpsmidi'Sig,
tryMidi, tryMidi', MidiInstr(..), MidiInstrTemp(..)
) where
import Data.Boolean
import Csound.Typed
import Csound.Typed.Opcode hiding (initc7)
import Csound.Control.Overload
import Csound.Control.Instr(alwaysOn)
import Csound.Control.Evt(Tick)
import Csound.Types
import Csound.Tuning
data MidiChn = ChnAll | Chn Int | Pgm (Maybe Int) Int
deriving (Show, Eq)
type MidiFun a = (Msg -> SE a) -> SE a
toMidiFun :: Sigs a => MidiChn -> MidiFun a
toMidiFun x = case x of
ChnAll -> midi
Chn n -> midin n
Pgm a b -> pgmidi a b
toMidiFun_ :: MidiChn -> MidiFun ()
toMidiFun_ x = case x of
ChnAll -> midi_
Chn n -> midin_ n
Pgm a b -> pgmidi_ a b
ampCps :: Msg -> (D, D)
ampCps msg = (ampmidi msg 1, cpsmidi msg)
ampmidinn :: (D, D) -> D -> D
ampmidinn (volMin, volMax) volKey = ampdbfs (volMin + ir (ampmidid volKey (volMax - volMin)))
ampCps' :: Temp -> Msg -> (D, D)
ampCps' temp msg = (ampmidi msg 1, cpsmidi' temp msg)
cpsmidi' :: Temp -> Msg -> D
cpsmidi' (Temp t) msg = cpstmid msg t
cpsmidi'D :: Temp -> D -> D
cpsmidi'D (Temp t) key = cpstuni key t
cpsmidi'Sig :: Temp -> Sig -> Sig
cpsmidi'Sig (Temp t) key = cpstun 1 key t
monoMsg :: MidiChn -> D -> D -> SE (Sig, Sig)
monoMsg = smoothMonoMsg cpsmidi
monoMsgTemp :: Temp -> MidiChn -> D -> D -> SE (Sig, Sig)
monoMsgTemp tm = smoothMonoMsg (cpsmidi' tm)
genMonoMsg :: MidiChn -> SE MonoArg
genMonoMsg chn = genAmpCpsSig cpsmidi (toMidiFun chn)
genMonoMsgTemp :: Temp -> MidiChn -> SE MonoArg
genMonoMsgTemp tm chn = genAmpCpsSig (cpsmidi' tm) (toMidiFun chn)
smoothMonoArg :: D -> MonoArg -> MonoArg
smoothMonoArg time arg = arg { monoAmp = port (monoAmp arg) time, monoCps = port (monoCps arg) time }
smoothMonoMsg :: (Msg -> D) -> MidiChn -> D -> D -> SE (Sig, Sig)
smoothMonoMsg key2cps chn portTime relTime = do
(MonoArg amp cps status _) <- genAmpCpsSig key2cps (toMidiFun chn)
return (port amp portTime * port status relTime, port cps portTime)
genFilteredMonoMsg :: MidiChn -> (D -> BoolD) -> SE MonoArg
genFilteredMonoMsg chn cond = filteredGenAmpCpsSig cpsmidi (toMidiFun chn) cond
genFilteredMonoMsgTemp :: Temp -> MidiChn -> (D -> BoolD) -> SE MonoArg
genFilteredMonoMsgTemp tm chn cond = filteredGenAmpCpsSig (cpsmidi' tm) (toMidiFun chn) cond
holdMsg :: MidiChn -> D -> SE (Sig, Sig)
holdMsg = genHoldMsg cpsmidi
holdMsgTemp :: Temp -> MidiChn -> D -> SE (Sig, Sig)
holdMsgTemp tm = genHoldMsg (cpsmidi' tm)
genHoldMsg :: (Msg -> D) -> MidiChn -> D -> SE (Sig, Sig)
genHoldMsg key2cps channel portTime = do
(amp, cps) <- genHoldAmpCpsSig key2cps (toMidiFun_ channel)
return (port amp portTime, port cps portTime)
genAmpCpsSig :: (Msg -> D) -> ((Msg -> SE Sig) -> SE Sig) -> SE MonoArg
genAmpCpsSig key2cps midiFun = do
ref <- newGlobalRef ((0, 0) :: (Sig, Sig))
status <- midiFun (instr ref)
(amp, cps) <- readRef ref
return $ makeMonoArg (amp, cps) status
where
makeMonoArg (amp, cps) status = MonoArg kamp kcps resStatus retrig
where
kamp = downsamp amp
kcps = downsamp cps
kstatus = downsamp status
resStatus = ifB (kstatus ==* 0) 0 1
retrig = changed [kamp, kcps, kstatus]
instr :: Ref (Sig, Sig) -> Msg -> SE Sig
instr hNote msg = do
writeRef hNote (sig $ ampmidi msg 1, sig $ key2cps msg)
return 1
filteredGenAmpCpsSig :: (Msg -> D) -> ((Msg -> SE Sig) -> SE Sig) -> (D -> BoolD) -> SE MonoArg
filteredGenAmpCpsSig key2cps midiFun cond = do
ref <- newGlobalRef ((0, 0) :: (Sig, Sig))
status <- midiFun (instr ref)
(amp, cps) <- readRef ref
return $ makeMonoArg (amp, cps) status
where
makeMonoArg (amp, cps) status = MonoArg kamp kcps resStatus retrig
where
kamp = downsamp amp
kcps = downsamp cps
kstatus = downsamp status
resStatus = ifB (kstatus ==* 0) 0 1
retrig = changed [kamp, kcps, kstatus]
instr :: Ref (Sig, Sig) -> Msg -> SE Sig
instr hNote msg = do
resRef <- newRef 0
whenElseD (cond $ key2cps msg)
(do
writeRef hNote (sig $ ampmidi msg 1, sig $ key2cps msg)
writeRef resRef 1)
(do
writeRef resRef 0)
readRef resRef
genHoldAmpCpsSig :: (Msg -> D) -> ((Msg -> SE ()) -> SE ()) -> SE (Sig, Sig)
genHoldAmpCpsSig key2cps midiFun = do
ref <- newGlobalRef ((0, 0) :: (Sig, Sig))
midiFun (instr ref)
(amp, cps) <- readRef ref
return (downsamp amp, downsamp cps)
where
instr :: Ref (Sig, Sig) -> Msg -> SE ()
instr hNote msg = do
writeRef hNote (sig $ ampmidi msg 1, sig $ key2cps msg)
trigNamedMono :: String -> SE MonoArg
trigNamedMono name = namedMonoMsg name
namedAmpCpsSig:: String -> SE (Sig, Sig, Sig)
namedAmpCpsSig name = do
ref <- newGlobalRef ((0, 0) :: (Sig, Sig))
statusRef <- newGlobalRef (0 :: Sig)
status <- trigByNameMidi name (instr statusRef ref)
writeRef statusRef status
let resStatus = ifB (downsamp status ==* 0) 0 1
(amp, cps) <- readRef ref
return (downsamp amp, downsamp cps, resStatus)
where
instr :: Ref Sig -> Ref (Sig, Sig) -> (D, D, Unit) -> SE Sig
instr statusRef hNote (pitchKey, volKey, _) = do
curId <- readRef statusRef
myIdRef <- newRef (ir curId)
myId <- readRef myIdRef
when1 (curId ==* (sig $ myId + 1)) $ do
writeRef hNote (sig volKey, sig pitchKey)
return 1
midiKeyOn :: MidiChn -> D -> SE (Evt D)
midiKeyOn = midiKeyOnBy . toMidiFun
midiKeyOff :: MidiChn -> D -> SE Tick
midiKeyOff = midiKeyOffBy . toMidiFun
midiKeyOnBy :: MidiFun Sig -> D -> SE (Evt D)
midiKeyOnBy midiFun key = do
chRef <- newGlobalRef (0 :: Sig)
evtRef <- newGlobalRef (0 :: Sig)
writeRef chRef =<< midiFun instr
alwaysOn $ do
a <- readRef chRef
writeRef evtRef $ diff a
evtSig <- readRef evtRef
return $ filterE ( >* 0) $ snaps evtSig
where
instr msg = do
print' [notnum msg]
return $ ifB (boolSig $ notnum msg ==* key) (sig $ ampmidi msg 1) 0
midiKeyOffBy :: MidiFun Sig -> D -> SE Tick
midiKeyOffBy midiFun key = do
chRef <- newGlobalRef (0 :: Sig)
evtRef <- newGlobalRef (0 :: Sig)
writeRef chRef =<< midiFun instr
alwaysOn $ do
a <- readRef chRef
writeRef evtRef $ diff a
evtSig <- readRef evtRef
return $ fmap (const unit) $ filterE ( `lessThan` 0) $ snaps evtSig
where
instr msg = do
print' [notnum msg]
return $ ifB (boolSig $ notnum msg ==* key) (sig $ ampmidi msg 1) 0
initc7 :: D -> D -> D -> SE ()
initc7 = initMidiCtrl
midiCtrl7 :: D -> D -> D -> D -> D -> SE Sig
midiCtrl7 chno ctrlno ival imin imax = do
initc7 chno ctrlno ival
return $ ctrl7 chno ctrlno imin imax
midiCtrl :: D -> D -> D -> SE Sig
midiCtrl chno ctrlno ival = midiCtrl7 chno ctrlno ival (-1) 1
umidiCtrl :: D -> D -> D -> SE Sig
umidiCtrl chno ctrlno ival = midiCtrl7 chno ctrlno ival 0 1
tryMidi :: (MidiInstr a, Sigs (MidiInstrOut a)) => a -> SE (MidiInstrOut a)
tryMidi x = midi $ onMsg x
tryMidi' :: (MidiInstrTemp a, Sigs (MidiInstrOut a)) => Temp -> a -> SE (MidiInstrOut a)
tryMidi' tm x = midi $ onMsg' tm x