diff --git a/csound-expression-typed.cabal b/csound-expression-typed.cabal --- a/csound-expression-typed.cabal +++ b/csound-expression-typed.cabal @@ -1,12 +1,12 @@ Name: csound-expression-typed -Version: 0.0.7.7 +Version: 0.0.7.8 Cabal-Version: >= 1.6 License: BSD3 License-file: LICENSE Author: Anton Kholomiov Synopsis: typed core for the library csound-expression Stability: Experimental -Tested-With: GHC==7.6 +Tested-With: GHC==7.10 Build-Type: Simple Category: Music, Sound Maintainer: @@ -25,7 +25,7 @@ Ghc-Options: -Wall Build-Depends: base >= 4, base < 5, ghc-prim, containers, transformers >= 0.3, Boolean >= 0.1.0, colour >= 2.0, data-default, deepseq, - wl-pprint, stable-maps >= 0.0.3.3, csound-expression-dynamic >= 0.1.4.3, temporal-media >= 0.6.0 + wl-pprint, csound-expression-dynamic >= 0.1.4.3, temporal-media >= 0.6.1 Hs-Source-Dirs: src/ Exposed-Modules: Csound.Typed @@ -46,8 +46,7 @@ Csound.Typed.GlobalState.Options Csound.Typed.GlobalState.GE Csound.Typed.GlobalState.SE - Csound.Typed.GlobalState.Instr - Csound.Typed.GlobalState.Cache + Csound.Typed.GlobalState.Instr Csound.Typed.GlobalState.Elements Csound.Typed.GlobalState.Opcodes @@ -61,7 +60,7 @@ Csound.Typed.Control.Sf2 Csound.Typed.Control.Osc Csound.Typed.Control.Channel - Csound.Typed.Control.SERef + Csound.Typed.Control.Ref Csound.Typed.Control.Instr Csound.Typed.Gui.Gui diff --git a/src/Csound/Typed/Control.hs b/src/Csound/Typed/Control.hs --- a/src/Csound/Typed/Control.hs +++ b/src/Csound/Typed/Control.hs @@ -2,7 +2,7 @@ -- * SE module Csound.Typed.GlobalState.SE, -- ** SE reference - module Csound.Typed.Control.SERef, + module Csound.Typed.Control.Ref, -- * Global settings instr0, getIns, setDur, -- * Misc @@ -24,7 +24,7 @@ ) where import Csound.Typed.GlobalState.SE -import Csound.Typed.Control.SERef +import Csound.Typed.Control.Ref import Csound.Typed.Control.Evt import Csound.Typed.Control.Mix diff --git a/src/Csound/Typed/Control/Evt.hs b/src/Csound/Typed/Control/Evt.hs --- a/src/Csound/Typed/Control/Evt.hs +++ b/src/Csound/Typed/Control/Evt.hs @@ -4,8 +4,6 @@ retrigs, evtLoop, evtLoopOnce ) where -import System.Mem.StableName - import Data.Boolean import Control.Applicative @@ -22,7 +20,7 @@ import Csound.Typed.Control.Instr import Csound.Typed.Control.Mix(Sco) -import Csound.Typed.Control.SERef +import Csound.Typed.Control.Ref import Csound.Typed.Constants(infiniteDur) renderEvts :: Evt (Sco a) -> Evt [(D, D, a)] @@ -30,52 +28,43 @@ where unEvt e = (T.eventStart e, T.eventDur e, T.eventContent e) sched :: (Arg a, Sigs b) => (a -> SE b) -> Evt (Sco a) -> b -sched instr evts = apInstr0 $ do - key <- evtKey evts instr - withCache InfiniteDur getEvtKey saveEvtKey key $ do - cacheName <- liftIO $ C.makeCacheName instr - instrId <- saveSourceInstrCachedWithLivenessWatch cacheName (funArity instr) (insExp instr) - saveEvtInstr (arityOuts $ funArity instr) instrId (renderEvts evts) +sched instr evts = apInstr0 $ do + instrId <- saveSourceInstrWithLivenessWatch (funArity instr) (insExp instr) + saveEvtInstr (arityOuts $ funArity instr) instrId (renderEvts evts) where unEvt e = (T.eventStart e, T.eventDur e, T.eventContent e) -- | Triggers a procedure on the event stream. sched_ :: (Arg a) => (a -> SE ()) -> Evt (Sco a) -> SE () sched_ instr evts = fromDep_ $ hideGEinDep $ do - key <- evtKey evts instr - withCache InfiniteDur getEvtProcKey saveEvtProcKey key $ do - cacheName <- liftIO $ C.makeCacheName instr - instrId <- saveSourceInstrCached_ cacheName (unitExp $ fmap (const unit) $ instr toArg) - return $ saveEvtInstr_ instrId (renderEvts evts) + instrId <- saveSourceInstr_ (unitExp $ fmap (const unit) $ instr toArg) + return $ saveEvtInstr_ instrId (renderEvts evts) -- | A closure to trigger an instrument inside the body of another instrument. schedBy :: (Arg a, Sigs b, Arg c) => (a -> SE b) -> (c -> Evt (Sco a)) -> (c -> b) schedBy instr evts args = flip apInstr args $ do - key <- evtKey evts instr - withCache InfiniteDur getEvtKey saveEvtKey key $ do - cacheName <- liftIO $ C.makeCacheName instr - instrId <- saveSourceInstrCachedWithLivenessWatch cacheName (funArity instr) (insExp instr) - saveEvtInstr (arityOuts $ funArity instr) instrId (renderEvts $ evts toArg) + instrId <- saveSourceInstrWithLivenessWatch (funArity instr) (insExp instr) + saveEvtInstr (arityOuts $ funArity instr) instrId (renderEvts $ evts toArg) ------------------------------------------------- -- triggereing the events saveEvtInstr :: Arg a => Int -> C.InstrId -> Evt [(D, D, a)] -> GE C.InstrId saveEvtInstr arity instrId evts = saveInstr $ do - aliveCountRef <- newSERef (10 :: D) + aliveCountRef <- newRef (10 :: D) evtMixInstr aliveCountRef where - evtMixInstr :: SERef D -> SE () + evtMixInstr :: Ref D -> SE () evtMixInstr aliveCountRef = do chnId <- fromDep $ C.chnRefAlloc arity go aliveCountRef chnId evts fromDep_ $ hideGEinDep $ fmap (\chn -> C.sendOut arity =<< C.readChn chn) chnId - aliveCount <- readSERef aliveCountRef + aliveCount <- readRef aliveCountRef fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnAlive chnId $ toGE aliveCount - go :: Arg a => SERef D -> GE C.ChnRef -> Evt [(D, D, a)] -> SE () + go :: Arg a => Ref D -> GE C.ChnRef -> Evt [(D, D, a)] -> SE () go aliveCountRef mchnId events = runEvt events $ \es -> do - writeSERef aliveCountRef $ int $ 2 * length es + writeRef aliveCountRef $ int $ 2 * length es chnId <- geToSe mchnId fromDep_ $ mapM_ (event chnId) es @@ -86,34 +75,31 @@ -- | Retriggers an instrument every time an event happens. The note -- is held until the next event happens. retrigs :: (Arg a, Sigs b) => (a -> SE b) -> Evt [a] -> b -retrigs instr evts = apInstr0 $ do - key <- evtKey evts instr - withCache InfiniteDur getEvtKey saveEvtKey key $ do - cacheName <- liftIO $ C.makeCacheName instr - instrId <- saveSourceInstrCachedWithLivenessWatchAndRetrig cacheName (funArity instr) (insExp instr) - saveRetrigEvtInstr (arityOuts $ funArity instr) instrId evts +retrigs instr evts = apInstr0 $ do + instrId <- saveSourceInstrWithLivenessWatchAndRetrig (funArity instr) (insExp instr) + saveRetrigEvtInstr (arityOuts $ funArity instr) instrId evts saveRetrigEvtInstr :: Arg a => Int -> C.InstrId -> Evt [a] -> GE C.InstrId saveRetrigEvtInstr arity instrId evts = saveInstr $ do - aliveCountRef <- newSERef (10 :: D) - retrigWatchRef <- newSERef (0 :: D) + aliveCountRef <- newRef (10 :: D) + retrigWatchRef <- newRef (0 :: D) evtMixInstr aliveCountRef retrigWatchRef where - evtMixInstr :: SERef D -> SERef D -> SE () + evtMixInstr :: Ref D -> Ref D -> SE () evtMixInstr aliveCountRef retrigWatchRef = do chnId <- fromDep $ C.chnRefAlloc arity go aliveCountRef retrigWatchRef chnId evts fromDep_ $ hideGEinDep $ fmap (\chn -> C.sendOut arity =<< C.readChn chn) chnId - aliveCount <- readSERef aliveCountRef + aliveCount <- readRef aliveCountRef fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnAlive chnId $ toGE aliveCount - go :: Arg a => SERef D -> SERef D -> GE C.ChnRef -> Evt [a] -> SE () + go :: Arg a => Ref D -> Ref D -> GE C.ChnRef -> Evt [a] -> SE () go aliveCountRef retrigWatchRef mchnId events = runEvt events $ \es -> do - writeSERef aliveCountRef $ int $ 2 * length es - modifySERef retrigWatchRef (+ 1) + writeRef aliveCountRef $ int $ 2 * length es + modifyRef retrigWatchRef (+ 1) chnId <- geToSe mchnId - currentRetrig <- readSERef retrigWatchRef + currentRetrig <- readRef retrigWatchRef fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnRetrig mchnId $ toGE currentRetrig fromDep_ $ mapM_ (event chnId currentRetrig) es @@ -130,11 +116,8 @@ evtLoopGen :: (Num a, Tuple a, Sigs a) => Bool -> Maybe (Evt Unit) -> [SE a] -> [Evt Unit] -> a evtLoopGen mustLoop maybeOffEvt instrs evts = apInstr0 $ do - key <- evtKey evts instr - withCache InfiniteDur getEvtKey saveEvtKey key $ do - cacheName <- liftIO $ C.makeCacheName instr - (instrId, evtInstrId) <- saveSourceInstrCachedWithLivenessWatchAndRetrigAndEvtLoop cacheName (constArity instr) (insExp $ toInstrExp instr) (toSingleEvt evts) - saveEvtLoopInstr mustLoop loopLength maybeOffEvt (arityOuts $ constArity instr) instrId evtInstrId + (instrId, evtInstrId) <- saveSourceInstrWithLivenessWatchAndRetrigAndEvtLoop (constArity instr) (insExp $ toInstrExp instr) (toSingleEvt evts) + saveEvtLoopInstr mustLoop loopLength maybeOffEvt (arityOuts $ constArity instr) instrId evtInstrId where loopLength = int $ lcm (length instrs) (length evts) instr = toSingleInstr instrs @@ -142,20 +125,22 @@ toInstrExp :: a -> (Unit -> a) toInstrExp = const - toSingleInstr :: (Num a, Tuple a) => [SE a] -> SE a + toSingleInstr :: (Sigs a, Num a, Tuple a) => [SE a] -> SE a toSingleInstr as = do let n = mod' (fromE $ getRetrigVal 4) (sig $ int $ length as) - ref <- newSERef 0 + ref <- newRef 0 zipWithM_ (f ref n) (fmap (sig . int) [0 .. ]) as - readSERef ref + readRef ref where - f ref n ix a = when1 (n ==* ix) $ writeSERef ref =<< a + f :: Tuple a => Ref a -> Sig -> Sig -> SE a -> SE () + f ref n ix a = when1 (n ==* ix) $ writeRef ref =<< a toSingleEvt :: [Evt Unit] -> SE () toSingleEvt evts = do let n = mod' (fromE $ getRetrigVal 4) (sig $ int $ length evts) - zipWithM_ (f n) (fmap (sig . int) [0 .. ]) evts + zipWithM_ (f n) (fmap (sig . int) [0 .. ]) evts where + f :: Sig -> Sig -> Evt Unit -> SE () f n ix evt = when1 (n ==* ix) $ evtLoopInstr evt evtLoopInstr :: Evt Unit -> SE () @@ -164,39 +149,39 @@ saveEvtLoopInstr :: Bool -> D -> Maybe (Evt Unit) -> Int -> C.InstrId -> C.InstrId -> GE C.InstrId saveEvtLoopInstr mustLoop loopLength maybeOffEvt arity instrId evtInstrId = saveInstr $ do - aliveCountRef <- newSERef (10 :: D) - retrigWatchRef <- newSERef (0 :: D) + aliveCountRef <- newRef (10 :: D) + retrigWatchRef <- newRef (0 :: D) evtMixInstr aliveCountRef retrigWatchRef where - evtMixInstr :: SERef D -> SERef D -> SE () + evtMixInstr :: Ref D -> Ref D -> SE () evtMixInstr aliveCountRef retrigWatchRef = do chnId <- fromDep $ C.chnRefAlloc arity initStartInstrs chnId isOn <- fmap sig $ case maybeOffEvt of Nothing -> return 1 Just offEvt -> do - isOn <- newSERef (1 :: D) + isOn <- newRef (1 :: D) runEvt offEvt $ const $ do - writeSERef isOn 0 - modifySERef retrigWatchRef (+ 1) - currentRetrig <- readSERef retrigWatchRef + writeRef isOn 0 + modifyRef retrigWatchRef (+ 1) + currentRetrig <- readRef retrigWatchRef fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnRetrig chnId $ toGE currentRetrig - readSERef isOn + readRef isOn masterEvt <- fmap (sigToEvt . (* isOn) . fromGE . fmap C.changed . toGE) $ readServantEvt chnId go aliveCountRef retrigWatchRef chnId masterEvt fromDep_ $ hideGEinDep $ fmap (\chn -> C.sendOut arity =<< C.readChn chn) chnId - aliveCount <- readSERef aliveCountRef + aliveCount <- readRef aliveCountRef fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnAlive chnId $ toGE aliveCount go = goBy (+ 1) - goBy :: (D -> D) -> SERef D -> SERef D -> GE C.ChnRef -> Evt Unit -> SE () + goBy :: (D -> D) -> Ref D -> Ref D -> GE C.ChnRef -> Evt Unit -> SE () goBy updateRetrig aliveCountRef retrigWatchRef mchnId events = runEvt events $ \es -> do - modifySERef retrigWatchRef updateRetrig + modifyRef retrigWatchRef updateRetrig chnId <- geToSe mchnId - currentRetrig <- readSERef retrigWatchRef + currentRetrig <- readRef retrigWatchRef if not mustLoop then do when1 (sig currentRetrig >=* (sig loopLength)) $ do @@ -241,21 +226,15 @@ -- for some seconds (specified in the first argument) then it's turned off. schedHarp :: (Arg a, Sigs b) => D -> (a -> SE b) -> Evt [a] -> b schedHarp turnOffTime instr evts = apInstr0 $ do - key <- evtKey evts instr - withCache InfiniteDur getEvtKey saveEvtKey key $ do - cacheName <- liftIO $ C.makeCacheName instr - instrId <- saveSourceInstrCachedWithLivenessWatch cacheName (funArity instr) (insExp $ (autoOff turnOffTime =<< ) . instr) - saveEvtInstr (arityOuts $ funArity instr) instrId (fmap (fmap phi) evts) + instrId <- saveSourceInstrWithLivenessWatch (funArity instr) (insExp $ (autoOff turnOffTime =<< ) . instr) + saveEvtInstr (arityOuts $ funArity instr) instrId (fmap (fmap phi) evts) where phi a = (0, infiniteDur, a) -- | A closure to trigger an instrument inside the body of another instrument. schedHarpBy :: (Arg a, Sigs b, Arg c) => D -> (a -> SE b) -> (c -> Evt [a]) -> (c -> b) schedHarpBy turnOffTime instr evts args = flip apInstr args $ do - key <- evtKey evts instr - withCache InfiniteDur getEvtKey saveEvtKey key $ do - cacheName <- liftIO $ C.makeCacheName instr - instrId <- saveSourceInstrCachedWithLivenessWatch cacheName (funArity instr) (insExp $ (autoOff turnOffTime =<< ) . instr) - saveEvtInstr (arityOuts $ funArity instr) instrId (fmap (fmap phi) $ evts toArg) + instrId <- saveSourceInstrWithLivenessWatch (funArity instr) (insExp $ (autoOff turnOffTime =<< ) . instr) + saveEvtInstr (arityOuts $ funArity instr) instrId (fmap (fmap phi) $ evts toArg) where phi a = (0, infiniteDur, a) autoOff :: Sigs a => D -> a -> SE a @@ -269,13 +248,6 @@ saveEvtInstr_ :: Arg a => C.InstrId -> Evt [(D, D, a)] -> Dep () saveEvtInstr_ instrId evts = unSE $ runEvt evts $ \es -> fromDep_ $ mapM_ event es where event (start, dur, args) = hideGEinDep $ fmap C.event $ C.Event instrId <$> toGE start <*> toGE dur <*> toNote args - -------------------------------------------------------------------- - -evtKey :: a -> b -> GE EvtKey -evtKey a b = liftIO $ EvtKey <$> hash a <*> hash b - where hash x = hashStableName <$> makeStableName x - ------------------------------------------------------------------- -- sample level triggering diff --git a/src/Csound/Typed/Control/Midi.hs b/src/Csound/Typed/Control/Midi.hs --- a/src/Csound/Typed/Control/Midi.hs +++ b/src/Csound/Typed/Control/Midi.hs @@ -11,48 +11,67 @@ import Control.Applicative import Control.Monad import Control.Monad.IO.Class + +import Csound.Dynamic + import Csound.Typed.Types import Csound.Typed.GlobalState import Csound.Typed.Control.Instr -import Csound.Typed.Control.SERef +import Csound.Typed.Control.Ref +import qualified Csound.Typed.GlobalState.Opcodes as C(midiVolumeFactor) + -- | Triggers a midi-instrument (aka Csound's massign) for all channels. -- It's useful to test a single instrument. midi :: (Num a, Sigs a) => (Msg -> SE a) -> SE a -midi = fromProcMidi midi_ +midi = fromProcMidi midiWithInstrId_ -- | Triggers a midi-instrument (aka Csound's massign) on the specified channel. midin :: (Num a, Sigs a) => Channel -> (Msg -> SE a) -> SE a -midin n = fromProcMidi (midin_ n) +midin n = fromProcMidi (midinWithInstrId_ n) -- | Triggers a midi-instrument (aka Csound's pgmassign) on the specified programm bank. pgmidi :: (Num a, Sigs a) => Maybe Int -> Channel -> (Msg -> SE a) -> SE a -pgmidi mchn n = fromProcMidi (pgmidi_ mchn n) +pgmidi mchn n = fromProcMidi (pgmidiWithInstrId_ mchn n) -fromProcMidi :: (Num a, Sigs a) => ((Msg -> SE ()) -> SE ()) -> (Msg -> SE a) -> SE a +fromProcMidi :: (Num a, Sigs a) => ((InstrId -> Msg -> SE ()) -> SE ()) -> (Msg -> SE a) -> SE a fromProcMidi procMidi f = do - ref <- newGlobalSERef 0 - procMidi (mixSERef ref <=< f) - res <- readSERef ref - writeSERef ref 0 + ref <- newGlobalRef 0 + procMidi (\instrId -> mixRef ref . scaleMidiVolumeFactor instrId <=< f) + res <- readRef ref + writeRef ref 0 return res ----------------------------------------------------------------- -- | Triggers a midi-procedure (aka Csound's massign) for all channels. +midiWithInstrId_ :: (InstrId -> Msg -> SE ()) -> SE () +midiWithInstrId_ = midinWithInstrId_ 0 + +-- | Triggers a midi-procedure (aka Csound's pgmassign) on the given channel. +midinWithInstrId_ :: Channel -> (InstrId -> Msg -> SE ()) -> SE () +midinWithInstrId_ chn instr = genMidi_ Massign chn instr + +-- | Triggers a midi-procedure (aka Csound's pgmassign) on the given programm bank. +pgmidiWithInstrId_ :: Maybe Int -> Channel -> (InstrId -> Msg -> SE ()) -> SE () +pgmidiWithInstrId_ mchn chn instr = genMidi_ (Pgmassign mchn) chn instr + +----------------------------------------------------------------- + +-- | Triggers a midi-procedure (aka Csound's massign) for all channels. midi_ :: (Msg -> SE ()) -> SE () midi_ = midin_ 0 -- | Triggers a midi-procedure (aka Csound's pgmassign) on the given channel. midin_ :: Channel -> (Msg -> SE ()) -> SE () -midin_ = genMidi_ Massign +midin_ chn instr = genMidi_ Massign chn (const instr) -- | Triggers a midi-procedure (aka Csound's pgmassign) on the given programm bank. pgmidi_ :: Maybe Int -> Channel -> (Msg -> SE ()) -> SE () -pgmidi_ mchn = genMidi_ (Pgmassign mchn) +pgmidi_ mchn chn instr = genMidi_ (Pgmassign mchn) chn (const instr) -genMidi_ :: MidiType -> Channel -> (Msg -> SE ()) -> SE () -genMidi_ midiType chn instr = geToSe $ saveToMidiInstr midiType chn (unSE $ instr Msg) +genMidi_ :: MidiType -> Channel -> (InstrId -> Msg -> SE ()) -> SE () +genMidi_ midiType chn instr = geToSe $ saveToMidiInstr midiType chn (\instrId -> unSE $ instr instrId Msg) ----------------------------------------------------------------- -- midi ctrls @@ -61,3 +80,9 @@ initMidiCtrl chno ctrlno val = geToSe $ saveMidiCtrl =<< (MidiCtrl <$> toGE chno <*> toGE ctrlno <*> toGE val) + +----------------------------------------------------------------- +-- midi volume factor + +scaleMidiVolumeFactor :: Sigs a => InstrId -> a -> a +scaleMidiVolumeFactor instrId = mapTuple (C.midiVolumeFactor instrId * ) diff --git a/src/Csound/Typed/Control/Mix.hs b/src/Csound/Typed/Control/Mix.hs --- a/src/Csound/Typed/Control/Mix.hs +++ b/src/Csound/Typed/Control/Mix.hs @@ -9,8 +9,6 @@ import Control.Applicative import Control.Monad.IO.Class import Data.Traversable -import System.Mem.StableName - import Temporal.Media import Csound.Dynamic hiding (Instr, Sco, str) @@ -43,17 +41,15 @@ -- > res = sco instrument scores sco :: (Arg a, Sigs b) => (a -> SE b) -> Sco a -> Sco (Mix b) sco instr notes = wrapSco notes $ \events -> do - events' <- traverse toNote events - cacheName <- liftIO $ C.makeCacheName instr - instrId <- saveSourceInstrCachedWithLivenessWatch cacheName (funArity instr) (insExp instr) + events' <- traverse toNote events + instrId <- saveSourceInstrWithLivenessWatch (funArity instr) (insExp instr) return $ Snd instrId events' -- | Invokes a procedure for the given bunch of events. sco_ :: (Arg a) => (a -> SE ()) -> Sco a -> Sco (Mix Unit) sco_ instr notes = wrapSco notes $ \events -> do - events' <- traverse toNote events - cacheName <- liftIO $ C.makeCacheName instr - instrId <- saveSourceInstrCached_ cacheName (unitExp $ fmap (const unit) $ instr toArg) + events' <- traverse toNote events + instrId <- saveSourceInstr_ (unitExp $ fmap (const unit) $ instr toArg) return $ Snd instrId events' -- | Applies an effect to the sound. Effect is applied to the sound on the give track. @@ -79,29 +75,23 @@ -- | Renders a scores to the sound signals. we can use it inside the other instruments. mix :: (Sigs a) => Sco (Mix a) -> a -mix a = flip apInstr unit $ do - key <- mixKey a - durE <- toGE $ dur a - withCache (ExpDur durE) getMixKey saveMixKey key $ - saveMixInstr (mixArity a) =<< toEventList a' +mix a = flip apInstr unit $ do + setDuration =<< (toGE $ dur a) + saveMixInstr (mixArity a) =<< toEventList a' where a' = toCsdEventList a -- | Imitates a closure for a bunch of notes to be played within another instrument. mixBy :: (Arg a, Sigs b) => (a -> Sco (Mix b)) -> (a -> b) -mixBy evts args = flip apInstr args $ do - key <- mixKey evts - durE <- toGE $ dur evts' - withCache (ExpDur durE) getMixKey saveMixKey key $ - saveMixInstr (mixArityFun evts) =<< (toEventList evts') +mixBy evts args = flip apInstr args $ do + setDuration =<< (toGE $ dur evts') + saveMixInstr (mixArityFun evts) =<< (toEventList evts') where evts' = toCsdEventList $ evts toArg -- | Converts a bunch of procedures scheduled with scores to a single procedure. mix_ :: Sco (Mix Unit) -> SE () -mix_ a = fromDep_ $ hideGEinDep $ do - key <- mixKey a - durE <- toGE $ dur a - withCache (ExpDur durE) getMixProcKey saveMixProcKey key $ - saveMixInstr_ =<< toEventList a' +mix_ a = fromDep_ $ hideGEinDep $ do + setDuration =<< (toGE $ dur a) + saveMixInstr_ =<< toEventList a' where a' = toCsdEventList a -- | Imitates a closure for a bunch of procedures to be played within another instrument. @@ -109,9 +99,6 @@ mixBy_ evts args = mix_ $ evts args ---------------------------------------------------------- - -mixKey :: a -> GE MixKey -mixKey = liftIO . fmap (MixKey . hashStableName) . makeStableName toEventList :: Sco (Mix a) -> GE (CsdEventList M) toEventList evts = fmap delayAndRescaleCsdEventListM $ traverse unMix $ evts diff --git a/src/Csound/Typed/Control/Osc.hs b/src/Csound/Typed/Control/Osc.hs --- a/src/Csound/Typed/Control/Osc.hs +++ b/src/Csound/Typed/Control/Osc.hs @@ -11,7 +11,7 @@ import Csound.Typed.GlobalState hiding (oscInit, oscListen, oscSend) import qualified Csound.Typed.GlobalState as C(oscInit, oscListen, oscSend) -import Csound.Typed.Control.SERef +import Csound.Typed.Control.Ref newtype OscRef = OscRef { unOscRef :: D } @@ -36,9 +36,9 @@ initOsc :: OscPort -> SE OscRef initOsc port = do oscRef <- fmap fromGE $ fromDep $ C.oscInit (fromIntegral port) - varRef <- newGlobalSERef (0 :: D) - writeSERef varRef oscRef - ihandle <- readSERef varRef + varRef <- newGlobalRef (0 :: D) + writeRef varRef oscRef + ihandle <- readRef varRef return $ OscRef ihandle -- | Listens for the OSC-messages. The first argument is OSC-reference. @@ -59,25 +59,25 @@ listenOsc :: forall a . Tuple a => OscRef -> OscAddress -> OscType -> Evt a listenOsc oscRef oscAddr oscType = Evt $ \bam -> do (readCond, writeCond) <- sensorsSE (0 :: Sig) - resRef <- newSERef (defTuple :: a) + resRef <- newRef (defTuple :: a) writeCond =<< listen resRef readCond >>= (\cond -> whileDo (cond ==* 1) $ do - bam =<< readSERef resRef + bam =<< readRef resRef writeCond =<< listen resRef) where - listen :: Tuple a => SERef a -> SE Sig + listen :: Tuple a => Ref a -> SE Sig listen ref = csdOscListen ref oscRef oscAddr oscType - csdOscListen :: Tuple a => SERef a -> OscRef -> OscAddress -> OscType -> SE Sig + csdOscListen :: Tuple a => Ref a -> OscRef -> OscAddress -> OscType -> SE Sig csdOscListen resRef oscHandle addr ty = do - args <- readSERef resRef + args <- readRef resRef res <- fmap fromGE $ fromDep $ hideGEinDep $ do expArgs <- fromTuple args expOscHandle <- toGE $ unOscRef oscHandle expAddr <- toGE $ text addr expOscType <- toGE $ text ty return $ C.oscListen $ expOscHandle : expAddr : expOscType : expArgs - writeSERef resRef args + writeRef resRef args return res -- | Sends OSC-messages. It takes in a name of the host computer diff --git a/src/Csound/Typed/Control/Ref.hs b/src/Csound/Typed/Control/Ref.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Control/Ref.hs @@ -0,0 +1,59 @@ +module Csound.Typed.Control.Ref where + +import Control.DeepSeq(deepseq) + +import Control.Monad +import Csound.Dynamic hiding (newLocalVars) + +import Csound.Typed.Types.Tuple +import Csound.Typed.GlobalState.SE + +-- | It describes a reference to mutable values. +newtype Ref a = Ref [Var] + +writeRef :: Tuple a => Ref a -> a -> SE () +writeRef (Ref vars) a = fromDep_ $ hideGEinDep $ do + vals <- fromTuple a + return $ zipWithM_ writeVar vars vals + +-- (zipWithM_ writeVar vars) =<< lift (fromTuple a) +--writeVar :: Var -> E -> Dep () +--[Var] (GE [E]) + +readRef :: Tuple a => Ref a -> SE a +readRef (Ref vars) = SE $ fmap (toTuple . return) $ mapM readVar vars + +-- | Allocates a new local (it is visible within the instrument) mutable value and initializes it with value. +-- A reference can contain a tuple of variables. +newRef :: Tuple a => a -> SE (Ref a) +newRef t = fmap Ref $ newLocalVars (tupleRates t) (fromTuple t) + +-- | Adds the given signal to the value that is contained in the +-- reference. +mixRef :: (Num a, Tuple a) => Ref a -> a -> SE () +mixRef ref asig = modifyRef ref (+ asig) + +-- | Modifies the Ref value with given function. +modifyRef :: Tuple a => Ref a -> (a -> a) -> SE () +modifyRef ref f = do + v <- readRef ref + writeRef ref (f v) + +-- | An alias for the function @newRef@. It returns not the reference +-- to mutable value but a pair of reader and writer functions. +sensorsSE :: Tuple a => a -> SE (SE a, a -> SE ()) +sensorsSE a = do + ref <- newRef a + return $ (readRef ref, writeRef ref) + +-- | Allocates a new global mutable value and initializes it with value. +-- A reference can contain a tuple of variables. +newGlobalRef :: Tuple a => a -> SE (Ref a) +newGlobalRef t = fmap Ref $ newGlobalVars (tupleRates t) (fromTuple t) + +-- | An alias for the function @newRef@. It returns not the reference +-- to mutable value but a pair of reader and writer functions. +globalSensorsSE :: Tuple a => a -> SE (SE a, a -> SE ()) +globalSensorsSE a = do + ref <- newRef a + return $ (readRef ref, writeRef ref) diff --git a/src/Csound/Typed/Control/SERef.hs b/src/Csound/Typed/Control/SERef.hs deleted file mode 100644 --- a/src/Csound/Typed/Control/SERef.hs +++ /dev/null @@ -1,63 +0,0 @@ -module Csound.Typed.Control.SERef where - -import Control.DeepSeq(deepseq) - -import Control.Monad -import Csound.Dynamic hiding (newLocalVars) - -import Csound.Typed.Types.Tuple -import Csound.Typed.GlobalState.SE - --- | It describes a reference to mutable values. -newtype SERef a = SERef [Var] -{- - { writeSERef :: a -> SE () - , readSERef :: SE a } --} - -writeSERef :: Tuple a => SERef a -> a -> SE () -writeSERef (SERef vars) a = fromDep_ $ hideGEinDep $ do - vals <- fromTuple a - return $ zipWithM_ writeVar vars vals - --- (zipWithM_ writeVar vars) =<< lift (fromTuple a) ---writeVar :: Var -> E -> Dep () ---[Var] (GE [E]) - -readSERef :: Tuple a => SERef a -> SE a -readSERef (SERef vars) = SE $ fmap (toTuple . return) $ mapM readVar vars - --- | Allocates a new local (it is visible within the instrument) mutable value and initializes it with value. --- A reference can contain a tuple of variables. -newSERef :: Tuple a => a -> SE (SERef a) -newSERef t = fmap SERef $ newLocalVars (tupleRates t) (fromTuple t) - --- | Adds the given signal to the value that is contained in the --- reference. -mixSERef :: (Num a, Tuple a) => SERef a -> a -> SE () -mixSERef ref asig = modifySERef ref (+ asig) - --- | Modifies the SERef value with given function. -modifySERef :: Tuple a => SERef a -> (a -> a) -> SE () -modifySERef ref f = do - v <- readSERef ref - writeSERef ref (f v) - --- | An alias for the function @newSERef@. It returns not the reference --- to mutable value but a pair of reader and writer functions. -sensorsSE :: Tuple a => a -> SE (SE a, a -> SE ()) -sensorsSE a = do - ref <- newSERef a - return $ (readSERef ref, writeSERef ref) - --- | Allocates a new global mutable value and initializes it with value. --- A reference can contain a tuple of variables. -newGlobalSERef :: Tuple a => a -> SE (SERef a) -newGlobalSERef t = fmap SERef $ newGlobalVars (tupleRates t) (fromTuple t) - --- | An alias for the function @newSERef@. It returns not the reference --- to mutable value but a pair of reader and writer functions. -globalSensorsSE :: Tuple a => a -> SE (SE a, a -> SE ()) -globalSensorsSE a = do - ref <- newSERef a - return $ (readSERef ref, writeSERef ref) diff --git a/src/Csound/Typed/GlobalState.hs b/src/Csound/Typed/GlobalState.hs --- a/src/Csound/Typed/GlobalState.hs +++ b/src/Csound/Typed/GlobalState.hs @@ -2,8 +2,7 @@ module Csound.Typed.GlobalState.Options, module Csound.Typed.GlobalState.GE, module Csound.Typed.GlobalState.SE, - module Csound.Typed.GlobalState.Instr, - module Csound.Typed.GlobalState.Cache, + module Csound.Typed.GlobalState.Instr, -- * Reexports dynamic BandLimited(..), readBandLimited, renderBandLimited, Instrs(..), IdMap(..), getInstrIds, @@ -27,6 +26,5 @@ import Csound.Typed.GlobalState.GE import Csound.Typed.GlobalState.SE import Csound.Typed.GlobalState.Instr -import Csound.Typed.GlobalState.Cache import Csound.Typed.GlobalState.Elements import Csound.Typed.GlobalState.Opcodes diff --git a/src/Csound/Typed/GlobalState/Cache.hs b/src/Csound/Typed/GlobalState/Cache.hs deleted file mode 100644 --- a/src/Csound/Typed/GlobalState/Cache.hs +++ /dev/null @@ -1,99 +0,0 @@ -module Csound.Typed.GlobalState.Cache( - Cache(..), HashKey, - -- * Mix - -- ** Functions - CacheMix, MixKey(..), - saveMixKey, getMixKey, - -- ** Procedures - CacheMixProc, - saveMixProcKey, getMixProcKey, - -- * Evt - -- ** Functions - CacheEvt, EvtKey(..), - saveEvtKey, getEvtKey, - -- ** Procedures - CacheEvtProc, - saveEvtProcKey, getEvtProcKey -) where - -import qualified Data.Map as M -import Data.Default - -import Csound.Dynamic - -data Cache m = Cache - { cacheMix :: CacheMix - , cacheMixProc :: CacheMixProc m - , cacheEvt :: CacheEvt - , cacheEvtProc :: CacheEvtProc m } - -instance Default (Cache m) where - def = Cache def def def def - -type HashKey = Int - -type GetKey m a b = a -> Cache m -> Maybe b -type SaveKey m a b = a -> b -> Cache m -> Cache m - -getKeyMap :: (Ord key) => (Cache m -> M.Map key val) -> GetKey m key val -getKeyMap f key x = M.lookup key $ f x - -saveKeyMap :: (Ord key) => (Cache m -> M.Map key val) -> (M.Map key val -> Cache m -> Cache m) -> SaveKey m key val -saveKeyMap getter setter key val cache = setter (M.insert key val $ getter cache) cache - ----------------------------------------------------------- --- Mix - --- Mix functions - -newtype MixKey = MixKey HashKey - deriving (Eq, Ord) - -type MixVal = InstrId - -type CacheMix = M.Map MixKey MixVal - -getMixKey :: GetKey m MixKey MixVal -getMixKey = getKeyMap cacheMix - -saveMixKey :: SaveKey m MixKey MixVal -saveMixKey = saveKeyMap cacheMix (\a x -> x { cacheMix = a }) - --- Mix procedures - -type CacheMixProc m = M.Map MixKey (DepT m ()) - -getMixProcKey :: GetKey m MixKey (DepT m ()) -getMixProcKey = getKeyMap cacheMixProc - -saveMixProcKey :: SaveKey m MixKey (DepT m ()) -saveMixProcKey = saveKeyMap cacheMixProc (\a x -> x { cacheMixProc = a }) - ----------------------------------------------------------- --- Evt - --- Evt functions - -data EvtKey = EvtKey HashKey HashKey - deriving (Eq, Ord) - -type EvtVal = InstrId - -type CacheEvt = M.Map EvtKey EvtVal - -getEvtKey :: GetKey m EvtKey EvtVal -getEvtKey = getKeyMap cacheEvt - -saveEvtKey :: SaveKey m EvtKey EvtVal -saveEvtKey = saveKeyMap cacheEvt (\a x -> x { cacheEvt = a }) - --- Evt procedures - -type CacheEvtProc m = M.Map EvtKey (DepT m ()) - -getEvtProcKey :: GetKey m EvtKey (DepT m ()) -getEvtProcKey = getKeyMap cacheEvtProc - -saveEvtProcKey :: SaveKey m EvtKey (DepT m ()) -saveEvtProcKey = saveKeyMap cacheEvtProc (\a x -> x { cacheEvtProc = a }) - diff --git a/src/Csound/Typed/GlobalState/Elements.hs b/src/Csound/Typed/GlobalState/Elements.hs --- a/src/Csound/Typed/GlobalState/Elements.hs +++ b/src/Csound/Typed/GlobalState/Elements.hs @@ -18,7 +18,7 @@ Globals(..), newPersistentGlobalVar, newClearableGlobalVar, renderGlobals, -- * Instruments - Instrs(..), saveInstr, CacheName, makeCacheName, saveCachedInstr, getInstrIds, + Instrs(..), newInstrId, saveInstrById, saveInstr, getInstrIds, -- * Src InstrBody, getIn, sendOut, sendChn, sendGlobal, chnPargId, Event(..), @@ -29,12 +29,10 @@ import Control.Monad.Trans.State.Strict import Control.Monad(zipWithM_) +import Control.Applicative(liftA2) import Data.Default import qualified Data.Map as M -import qualified System.Mem.StableName.Dynamic as DM -import qualified System.Mem.StableName.Dynamic.Map as DM - import Csound.Dynamic.Types import Csound.Dynamic.Build import Csound.Dynamic.Build.Numeric() @@ -201,10 +199,10 @@ data MidiKey = MidiKey MidiType Channel deriving (Show, Eq, Ord) -type MidiMap m = M.Map MidiKey (DepT m ()) +type MidiMap m = M.Map MidiKey (InstrId -> DepT m ()) -saveMidiInstr :: Monad m => MidiType -> Channel -> DepT m () -> MidiMap m -> MidiMap m -saveMidiInstr ty chn body = M.insertWith (flip (>>)) (MidiKey ty chn) body +saveMidiInstr :: Monad m => MidiType -> Channel -> (InstrId -> DepT m ()) -> MidiMap m -> MidiMap m +saveMidiInstr ty chn body = M.insertWith (liftA2 $ flip (>>)) (MidiKey ty chn) body -- global variables @@ -250,41 +248,35 @@ -- instrs data Instrs = Instrs - { instrsCache :: DM.Map InstrId - , instrsNewId :: Int + { instrsNewId :: Int , instrsContent :: [(InstrId, InstrBody)] } instance Default Instrs where - def = Instrs DM.empty 18 [] - -type CacheName = DM.DynamicStableName - -makeCacheName :: a -> IO CacheName -makeCacheName = DM.makeDynamicStableName + def = Instrs 18 [] getInstrIds :: Instrs -> [InstrId] getInstrIds = fmap fst . instrsContent ----------------------------------------------------------------- -- -saveCachedInstr :: CacheName -> InstrBody -> State Instrs InstrId -saveCachedInstr name body = state $ \s -> - case DM.lookup name $ instrsCache s of - Just n -> (n, s) - Nothing -> - let newId = instrsNewId s - s1 = s { instrsCache = DM.insert name (intInstrId newId) $ instrsCache s - , instrsNewId = succ newId - , instrsContent = (intInstrId newId, body) : instrsContent s } - in (intInstrId newId, s1) -saveInstr :: InstrBody -> State Instrs InstrId -saveInstr body = state $ \s -> +newInstrId :: State Instrs InstrId +newInstrId = state $ \s -> let newId = instrsNewId s - s1 = s { instrsNewId = succ newId - , instrsContent = (intInstrId newId, body) : instrsContent s } + s1 = s { instrsNewId = succ newId } in (intInstrId newId, s1) + +saveInstrById :: InstrId -> InstrBody -> State Instrs () +saveInstrById instrId body = state $ \s -> + let s1 = s { instrsContent = (instrId, body) : instrsContent s } + in ((), s1) + +saveInstr :: InstrBody -> State Instrs InstrId +saveInstr body = do + newId <- newInstrId + saveInstrById newId body + return newId ----------------------------------------------------------------- -- sound sources diff --git a/src/Csound/Typed/GlobalState/GE.hs b/src/Csound/Typed/GlobalState/GE.hs --- a/src/Csound/Typed/GlobalState/GE.hs +++ b/src/Csound/Typed/GlobalState/GE.hs @@ -10,7 +10,7 @@ saveAlwaysOnInstr, onInstr, saveUserInstr0, getSysExpr, -- * Total duration TotalDur(..), pureGetTotalDurForF0, getTotalDurForTerminator, - setDurationForce, setDuration, setDurationToInfinite, + setDurationForce, setDuration, setDurationToInfinite, -- * Notes addNote, -- * GEN routines @@ -21,8 +21,6 @@ saveBandLimitedWave, -- * Strings saveStr, - -- * Cache - GetCache, SetCache, withCache, -- * Guis newGuiHandle, saveGuiRoot, saveDefKeybdPanel, appendToGui, newGuiVar, getPanels, guiHandleToVar, @@ -46,7 +44,6 @@ import Csound.Dynamic import Csound.Typed.GlobalState.Options -import Csound.Typed.GlobalState.Cache import Csound.Typed.GlobalState.Elements import Csound.Typed.Constants(infiniteDur) @@ -94,12 +91,11 @@ , alwaysOnInstrs :: [InstrId] , notes :: [(InstrId, CsdEvent)] , userInstr0 :: Dep () - , bandLimitedMap :: BandLimitedMap - , cache :: Cache GE + , bandLimitedMap :: BandLimitedMap , guis :: Guis } instance Default History where - def = History def def def def def def def def def def def def (return ()) def def def + def = History def def def def def def def def def def def def (return ()) def def data Msg = Msg data MidiAssign = MidiAssign MidiType Channel InstrId @@ -179,7 +175,7 @@ saveMidi ma = onMidis $ modify (ma: ) where onMidis = onHistory midis (\a h -> h { midis = a }) -saveToMidiInstr :: MidiType -> Channel -> Dep () -> GE () +saveToMidiInstr :: MidiType -> Channel -> (InstrId -> Dep ()) -> GE () saveToMidiInstr ty chn expr = onMidiMap (saveMidiInstr ty chn expr) where onMidiMap = modifyHistoryField midiMap (\a h -> h { midiMap = a }) @@ -255,33 +251,6 @@ onGlobals :: UpdField Globals a onGlobals = onHistory globals (\a h -> h { globals = a }) - ----------------------------------------------------------------------- --- cache - --- midi functions - -type GetCache a b = a -> Cache GE -> Maybe b - -fromCache :: GetCache a b -> a -> GE (Maybe b) -fromCache f key = withHistory $ f key . cache - -type SetCache a b = a -> b -> Cache GE -> Cache GE - -toCache :: SetCache a b -> a -> b -> GE () -toCache f key val = modifyHistory $ \h -> h { cache = f key val (cache h) } - -withCache :: TotalDur -> GetCache key val -> SetCache key val -> key -> GE val -> GE val -withCache dur lookupResult saveResult key getResult = do - ma <- fromCache lookupResult key - res <- case ma of - Just a -> return a - Nothing -> do - r <- getResult - toCache saveResult key r - return r - setTotalDur dur - return res -------------------------------------------------------- -- guis diff --git a/src/Csound/Typed/GlobalState/Instr.hs b/src/Csound/Typed/GlobalState/Instr.hs --- a/src/Csound/Typed/GlobalState/Instr.hs +++ b/src/Csound/Typed/GlobalState/Instr.hs @@ -11,7 +11,6 @@ import Csound.Typed.GlobalState.GE import Csound.Typed.GlobalState.SE import Csound.Typed.GlobalState.Options -import Csound.Typed.GlobalState.Cache import Csound.Typed.GlobalState.Opcodes(turnoff2, exitnow, servantUpdateChnAlive, servantUpdateChnRetrig) import Csound.Typed.GlobalState.Elements(getInstrIds) @@ -26,45 +25,42 @@ saveInstr :: SE () -> GE InstrId saveInstr a = onInstr . C.saveInstr =<< execSE a -saveCachedInstr :: C.CacheName -> SE () -> GE InstrId -saveCachedInstr cacheName a = onInstr . C.saveCachedInstr cacheName =<< execSE a - livenessWatch :: Arity -> SE () livenessWatch arity = fromDep_ $ servantUpdateChnAlive (C.chnPargId $ arityIns arity) retrigWatch :: Arity -> SE () retrigWatch arity = fromDep_ $ servantUpdateChnRetrig (C.chnPargId $ arityIns arity) -saveSourceInstrCachedWithLivenessWatch :: C.CacheName -> Arity -> InsExp -> GE InstrId -saveSourceInstrCachedWithLivenessWatch cacheName arity instr = saveCachedInstr cacheName $ do +saveSourceInstrWithLivenessWatch :: Arity -> InsExp -> GE InstrId +saveSourceInstrWithLivenessWatch arity instr = saveInstr $ do toOut =<< instr livenessWatch arity where toOut = SE . C.sendChn (arityIns arity) (arityOuts arity) -saveSourceInstrCachedWithLivenessWatchAndRetrig :: C.CacheName -> Arity -> InsExp -> GE InstrId -saveSourceInstrCachedWithLivenessWatchAndRetrig cacheName arity instr = saveCachedInstr cacheName $ do +saveSourceInstrWithLivenessWatchAndRetrig :: Arity -> InsExp -> GE InstrId +saveSourceInstrWithLivenessWatchAndRetrig arity instr = saveInstr $ do toOut =<< instr retrigWatch arity livenessWatch arity where toOut = SE . C.sendChn (arityIns arity) (arityOuts arity) -saveSourceInstrCachedWithLivenessWatchAndRetrigAndEvtLoop :: C.CacheName -> Arity -> InsExp -> UnitExp -> GE (InstrId, InstrId) -saveSourceInstrCachedWithLivenessWatchAndRetrigAndEvtLoop cacheName arity instr evtInstr = do - instrId <- saveSourceInstrCachedWithLivenessWatchAndRetrig cacheName arity instr +saveSourceInstrWithLivenessWatchAndRetrigAndEvtLoop :: Arity -> InsExp -> UnitExp -> GE (InstrId, InstrId) +saveSourceInstrWithLivenessWatchAndRetrigAndEvtLoop arity instr evtInstr = do + instrId <- saveSourceInstrWithLivenessWatchAndRetrig arity instr evtInstrId <- saveInstr (evtInstr >> retrigWatch evtInstrArity >> livenessWatch evtInstrArity) return (instrId, evtInstrId) where evtInstrArity = Arity 0 0 -saveSourceInstrCached :: C.CacheName -> Arity -> InsExp -> GE InstrId -saveSourceInstrCached cacheName arity instr = saveCachedInstr cacheName $ toOut =<< instr +saveSourceInstr :: Arity -> InsExp -> GE InstrId +saveSourceInstr arity instr = saveInstr $ toOut =<< instr where toOut = SE . C.sendChn (arityIns arity) (arityOuts arity) -saveSourceInstrCached_ :: C.CacheName -> UnitExp -> GE InstrId -saveSourceInstrCached_ cacheName instr = saveCachedInstr cacheName instr +saveSourceInstr_ :: UnitExp -> GE InstrId +saveSourceInstr_ instr = saveInstr instr -saveSourceInstrCachedWithLivenessWatch_ :: C.CacheName -> Arity -> UnitExp -> GE InstrId -saveSourceInstrCachedWithLivenessWatch_ cacheName arity instr = saveCachedInstr cacheName $ +saveSourceInstrWithLivenessWatch_ :: Arity -> UnitExp -> GE InstrId +saveSourceInstrWithLivenessWatch_ arity instr = saveInstr $ instr >> livenessWatch arity saveEffectInstr :: Arity -> EffExp -> GE InstrId @@ -100,11 +96,13 @@ saveMidiMap :: GE () saveMidiMap = do m <- fmap midiMap getHistory - mapM_ (\(C.MidiKey midiType channel, instrExpr) -> saveMidiInstr_ midiType channel (SE instrExpr)) $ toList m + mapM_ (\(C.MidiKey midiType channel, instrExpr) -> saveMidiInstr_ midiType channel (SE . instrExpr)) $ toList m -saveMidiInstr_ :: C.MidiType -> C.Channel -> UnitExp -> GE () +saveMidiInstr_ :: C.MidiType -> C.Channel -> (InstrId -> UnitExp) -> GE () saveMidiInstr_ midiType channel instr = do - instrId <- onInstr . C.saveInstr =<< execSE instr + instrId <- onInstr C.newInstrId + onInstr . C.saveInstrById instrId =<< execSE (instr instrId) + -- instrId <- onInstr . C.saveInstr =<< execSE instr saveMidi $ MidiAssign midiType channel instrId saveIns0 :: Int -> [Rate] -> SE [E] -> GE [E] diff --git a/src/Csound/Typed/GlobalState/Opcodes.hs b/src/Csound/Typed/GlobalState/Opcodes.hs --- a/src/Csound/Typed/GlobalState/Opcodes.hs +++ b/src/Csound/Typed/GlobalState/Opcodes.hs @@ -16,14 +16,21 @@ oscInit, oscListen, oscSend, -- * channels chnGet, chnSet, + -- * metro + metro, -- * times times, -- * Fluid fluidEngine, fluidLoad, fluidProgramSelect, -- * Soundfonts - sfSetList + sfSetList, + -- * Midi + midiVolumeFactor ) where + +import Prelude hiding ((<*)) + import Control.Monad(zipWithM_, forM_) import Data.Boolean @@ -297,6 +304,12 @@ chnSet r val chn = depT_ $ opcs "chnset" [(Xr, [r, Sr])] [val, chn] ----------------------------------------------------------- +-- metro + +metro :: E -> E +metro a = opcs "metro" [(Kr, [Kr])] [a] + +----------------------------------------------------------- -- times times :: Monad m => DepT m E @@ -333,3 +346,15 @@ sfplist sf forM_ presets $ \(bank, prog, index) -> sfpreset bank prog sf index +----------------------------------------------------------- +-- midi volume factor (normalize by number of notes) + +midiVolumeFactor :: InstrId -> E +midiVolumeFactor idx = flip port 0.0015 $ ifB (n ==* 0) 1 (recip n) + where n = sqrt (active idx) + +active :: InstrId -> E +active instrId = opcs "active" [(Kr, [Ir])] [instrIdE instrId] + +port :: E -> E -> E +port a b = opcs "port" [(Kr, [Kr, Ir])] [a, b] diff --git a/src/Csound/Typed/GlobalState/Options.hs b/src/Csound/Typed/GlobalState/Options.hs --- a/src/Csound/Typed/GlobalState/Options.hs +++ b/src/Csound/Typed/GlobalState/Options.hs @@ -11,7 +11,6 @@ ) where import Control.Applicative -import Data.Monoid import Data.Default import qualified Data.IntMap as IM @@ -46,7 +45,7 @@ , csdTabFi = csdTabFi a <|> csdTabFi b } defGain :: Options -> Double -defGain = maybe 0.5 id . csdGain +defGain = maybe 0.8 id . csdGain defSampleRate :: Options -> Int defSampleRate = maybe 44100 id . csdSampleRate diff --git a/src/Csound/Typed/Gui/BoxModel.hs b/src/Csound/Typed/Gui/BoxModel.hs --- a/src/Csound/Typed/Gui/BoxModel.hs +++ b/src/Csound/Typed/Gui/BoxModel.hs @@ -6,9 +6,9 @@ appendContext, cascade, boundingRect, zeroRect ) where +import Control.Monad import Control.Monad.Trans.State.Strict import Data.Default -import Data.Monoid data Interval = Interval { start :: Int @@ -54,6 +54,10 @@ | Ver Offset [Scene ctx a] | Context ctx (Scene ctx a) deriving (Show, Functor) + +instance Applicative (Scene ctx) where + pure = return + (<*>) = ap instance Monad (Scene ctx) where return = Prim diff --git a/src/Csound/Typed/Types/Evt.hs b/src/Csound/Typed/Types/Evt.hs --- a/src/Csound/Typed/Types/Evt.hs +++ b/src/Csound/Typed/Types/Evt.hs @@ -13,7 +13,7 @@ import Csound.Typed.Types.Prim import Csound.Typed.Types.Tuple import Csound.Typed.GlobalState -import Csound.Typed.Control.SERef +import Csound.Typed.Control.Ref import qualified Csound.Typed.GlobalState.Opcodes as C @@ -134,18 +134,18 @@ -- an event happens and zero otherwise. evtToBool :: Evt a -> SE BoolSig evtToBool evt = do - var <- newSERef (double 0) - writeSERef var (double 0) - runEvt evt $ const $ writeSERef var (double 1) - asig <- readSERef var + var <- newRef (double 0) + writeRef var (double 0) + runEvt evt $ const $ writeRef var (double 1) + asig <- readRef var return $ boolSig $ asig ==* (double 1) -- | Converts events to signals. stepper :: Tuple a => a -> Evt a -> SE a stepper v0 evt = do - (readSt, writeSt) <- sensorsSE v0 - runEvt evt $ \a -> writeSt a - readSt + ref <- newGlobalRef v0 + runEvt evt $ \a -> writeRef ref a + readRef ref ------------------------------------------------------------- -- synchronization @@ -153,29 +153,23 @@ -- | Executes actions synchronized with global tempo (in Hz). -- -- > runEvtSync tempoCps evt proc -sync :: (Default a, Tuple a) => D -> Evt a -> Evt a -sync dt evt = Evt $ \bam -> do - initGlobalTime <- times - refCounter <- newSERef $ frac' $ initGlobalTime * dt - refVal <- newSERef def - refFire <- newSERef (0 :: D) +sync :: (Default a, Tuple a) => Sig -> Evt a -> Evt a +sync dt evt = Evt $ \bam -> do + refVal <- newRef def + refFire <- newRef (0 :: D) runEvt evt $ \a -> do - writeSERef refVal a - writeSERef refFire 1 - - updCounter <- readSERef refCounter - writeSERef refCounter (updCounter - 1 / getControlRate) - - counter <- readSERef refCounter - fire <- readSERef refFire - when1 (sig counter <=* 0 &&* sig fire ==* 1) $ do - val <- readSERef refVal + writeRef refVal a + writeRef refFire 1 + + fire <- readRef refFire + when1 (metro dt ==* 1 &&* sig fire ==* 1) $ do + val <- readRef refVal bam val - writeSERef refFire 0 - - when1 (sig counter <=* 0) $ do - writeSERef refCounter (1 / dt) - where - times = fmap D $ fromDep C.times + writeRef refFire 0 + where + metro :: Sig -> Sig + metro asig = fromGE $ fmap C.metro $ toGE asig + + diff --git a/src/Csound/Typed/Types/MixSco.hs b/src/Csound/Typed/Types/MixSco.hs --- a/src/Csound/Typed/Types/MixSco.hs +++ b/src/Csound/Typed/Types/MixSco.hs @@ -11,7 +11,7 @@ import Csound.Typed.GlobalState.Opcodes import Csound.Typed.GlobalState.GE import Csound.Typed.GlobalState.SE -import Csound.Typed.Control.SERef +import Csound.Typed.Control.Ref import Csound.Typed.Types.Prim import qualified Temporal.Media as T @@ -61,21 +61,21 @@ renderMixSco :: Int -> CsdEventList M -> Dep [E] renderMixSco arity evts = do chnId <- chnRefAlloc arity - aliveCountRef <- unSE $ newSERef (10 :: D) + aliveCountRef <- unSE $ newRef (10 :: D) go aliveCountRef chnId evts readChn chnId where - go :: SERef D -> ChnRef -> CsdEventList M -> Dep () + go :: Ref D -> ChnRef -> CsdEventList M -> Dep () go aliveCountRef outId xs = do mapM_ (onEvent aliveCountRef outId) notes - unSE $ writeSERef aliveCountRef $ int $ 2 * length notes - aliveCount <- unSE $ readSERef aliveCountRef + unSE $ writeRef aliveCountRef $ int $ 2 * length notes + aliveCount <- unSE $ readRef aliveCountRef hideGEinDep $ liftA2 masterUpdateChnAlive (return chnId) $ toGE aliveCount where notes = csdEventListNotes xs chnId = outId - onEvent :: SERef D -> ChnRef -> (D, D, M) -> Dep () + onEvent :: Ref D -> ChnRef -> (D, D, M) -> Dep () onEvent aliveCountRef outId (start, dur, x) = case x of Snd instrId es -> onSnd aliveCountRef instrId outId es Eff instrId es arityIn -> onEff aliveCountRef instrId start dur outId es arityIn diff --git a/src/Csound/Typed/Types/Prim.hs b/src/Csound/Typed/Types/Prim.hs --- a/src/Csound/Typed/Types/Prim.hs +++ b/src/Csound/Typed/Types/Prim.hs @@ -24,9 +24,12 @@ quot', rem', div', mod', ceil', floor', round', int', frac', -- ** logic funs - when1, whens, untilDo, whileDo, boolSig + when1, whens, untilDo, whileDo, boolSig, + equalsTo, notEqualsTo, lessThan, greaterThan, lessThanEquals, greaterThanEquals ) where +import Prelude hiding ((<*)) + import Control.Applicative hiding ((<*)) import Control.Monad import Control.Monad.Trans.Class @@ -591,6 +594,26 @@ boolSig x = case x of PrimBoolD b -> PrimBoolSig b BoolD a -> BoolSig a + +infix 4 `equalsTo`, `notEqualsTo`, `lessThan`, `lessThanEquals`, `greaterThanEquals`, `greaterThan` + +equalsTo :: EqB a => a -> a -> BooleanOf a +equalsTo = (==*) + +notEqualsTo :: EqB a => a -> a -> BooleanOf a +notEqualsTo = (/=*) + +lessThan :: OrdB a => a -> a -> BooleanOf a +lessThan = (<*) + +greaterThan :: OrdB a => a -> a -> BooleanOf a +greaterThan = (>*) + +lessThanEquals :: OrdB a => a -> a -> BooleanOf a +lessThanEquals = (<=*) + +greaterThanEquals :: OrdB a => a -> a -> BooleanOf a +greaterThanEquals = (>=*) ---------------------------------------------- diff --git a/src/Csound/Typed/Types/Tuple.hs b/src/Csound/Typed/Types/Tuple.hs --- a/src/Csound/Typed/Types/Tuple.hs +++ b/src/Csound/Typed/Types/Tuple.hs @@ -6,7 +6,7 @@ module Csound.Typed.Types.Tuple( -- ** Tuple Tuple(..), TupleMethods, makeTupleMethods, - fromTuple, toTuple, tupleArity, tupleRates, defTuple, + fromTuple, toTuple, tupleArity, tupleRates, defTuple, mapTuple, Sig2, Sig3, Sig4, Sig5, Sig6, Sig8, @@ -67,6 +67,9 @@ defTuple :: Tuple a => a defTuple = defTuple_ tupleMethods + +mapTuple :: Tuple a => (E -> E) -> a -> a +mapTuple f a = toTuple (fmap (fmap f) $ fromTuple a) -- | Defines instance of type class 'Tuple' for a new type in terms of an already defined one. makeTupleMethods :: (Tuple a) => (a -> b) -> (b -> a) -> TupleMethods b