csound-expression-typed 0.0.7.3.1 → 0.0.7.4

raw patch · 10 files changed

+354/−173 lines, 10 filesdep +temporal-mediadep ~csound-expression-dynamicPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: temporal-media

Dependency ranges changed: csound-expression-dynamic

API changes (from Hackage documentation)

Files

• csound-expression-typed.cabal +2/−2
• src/Csound/Typed/Control/Evt.hs +33/−58
• src/Csound/Typed/Control/Mix.hs +30/−20
• src/Csound/Typed/Control/SERef.hs +1/−2
• src/Csound/Typed/GlobalState/GE.hs +7/−9
• src/Csound/Typed/GlobalState/Instr.hs +3/−2
• src/Csound/Typed/Gui/Widget.hs +3/−3
• src/Csound/Typed/Types/MixSco.hs +64/−29
• src/Csound/Typed/Types/Prim.hs +209/−47
• src/Csound/Typed/Types/Tuple.hs +2/−1

@@ -1,5 +1,5 @@ Name:          csound-expression-typed-Version:       0.0.7.3.1+Version:       0.0.7.4 Cabal-Version: >= 1.6 License:       BSD3 License-file:  LICENSE@@ -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.1+        wl-pprint, stable-maps >= 0.0.3.3, csound-expression-dynamic >= 0.1.4.2, temporal-media >= 0.5.0   Hs-Source-Dirs:      src/   Exposed-Modules:     Csound.Typed

@@ -1,8 +1,7 @@ {-# Language FlexibleContexts #-} module Csound.Typed.Control.Evt(-    trigs, scheds, schedHarps, retrigs, evtLoop, evtLoopOnce,-    trigsBy, schedsBy, schedHarpsBy,-    trigs_, scheds_,+    sched, sched_, schedBy, schedHarp, schedHarpBy,+    retrigs, evtLoop, evtLoopOnce     ) where  import System.Mem.StableName@@ -13,40 +12,53 @@ import Control.Monad import Control.Monad.IO.Class +import qualified Temporal.Media as T(render, Event(..))+ import qualified Csound.Dynamic as C import qualified Csound.Typed.GlobalState.Elements as C  import Csound.Typed.Types import Csound.Typed.GlobalState import Csound.Typed.Control.Instr+import Csound.Typed.Control.Mix(Sco)  import Csound.Typed.Control.SERef import Csound.Typed.Constants(infiniteDur) ----------------------------------------------------- triggereing the events+renderEvts :: Evt (Sco a) -> Evt [(D, D, a)]+renderEvts = fmap (fmap unEvt . T.render)+    where unEvt e = (T.eventStart e, T.eventDur e, T.eventContent e) --- | Triggers an instrument with an event stream. The event stream--- contains triples:------ > (delay_after_event_is_fired, duration_of_the_event, argument_for_the_instrument)-trigs :: (Arg a, Sigs b) => (a -> SE b) -> Evt [(D, D, a)] -> b-trigs instr evts = apInstr0 $ do+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 evts+        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)+ -- | A closure to trigger an instrument inside the body of another instrument.-trigsBy :: (Arg a, Sigs b, Arg c) => (a -> SE b) -> (c -> Evt [(D, D, a)]) -> (c -> b)-trigsBy instr evts args = flip apInstr args $ do+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 (evts toArg)  +        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)@@ -71,6 +83,8 @@         event chnId (start, dur, args) = hideGEinDep $ fmap C.event $              C.Event instrId <$> toGE start <*> toGE dur <*> (fmap (++ [C.chnRefId chnId]) $ toNote args)              +-- | 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@@ -220,32 +234,13 @@         readServantEvt :: GE C.ChnRef -> SE Sig         readServantEvt chnId = SE $ fmap fromE $ hideGEinDep $ fmap readChnEvtLoop chnId --- | It's like the function @trigs@, but delay is set to zero.-scheds :: (Arg a, Sigs b) => (a -> SE b) -> Evt [(D, a)] -> b-scheds 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 (fmap (fmap phi) evts)  -    where phi (a, b) = (0, a, b)-     --- | A closure to trigger an instrument inside the body of another instrument.-schedsBy :: (Arg a, Sigs b, Arg c) => (a -> SE b) -> (c -> Evt [(D, a)]) -> (c -> b)-schedsBy 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 (fmap (fmap phi) $ evts toArg)  -    where phi (a, b) = (0, a, b)  -- | An instrument is triggered with event stream and delay time is set to zero  -- (event fires immediately) and duration is set to inifinite time. The note is  -- held while the instrument is producing something. If the instrument is silent -- for some seconds (specified in the first argument) then it's turned off.-schedHarps :: (Arg a, Sigs b) => D -> (a -> SE b) -> Evt [a] -> b-schedHarps turnOffTime instr evts = apInstr0 $ do+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@@ -254,8 +249,8 @@     where phi a = (0, infiniteDur, a)  -- | A closure to trigger an instrument inside the body of another instrument.-schedHarpsBy :: (Arg a, Sigs b, Arg c) => D -> (a -> SE b) -> (c -> Evt [a]) -> (c -> b)-schedHarpsBy turnOffTime instr evts args = flip apInstr args $ do+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@@ -270,26 +265,6 @@             dtE <- toGE dt             return $ C.autoOff dtE x ---------------------------------------------------------------------------- | Triggers a procedure on the event stream.-trigs_ :: (Arg a) => (a -> SE ()) -> Evt [(D, D, a)] -> SE ()-trigs_ 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 evts---- | Triggers a procedure on the event stream. A delay time is set to zero.-scheds_ :: (Arg a) => (a -> SE ()) -> Evt [(D, a)] -> SE ()-scheds_ 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 $ fmap (fmap phi) evts-    where phi (a, b) = (0, a, b)  saveEvtInstr_ :: Arg a => C.InstrId -> Evt [(D, D, a)] -> Dep () saveEvtInstr_ instrId evts = unSE $ runEvt evts $ \es -> fromDep_ $ mapM_ event es

@@ -3,14 +3,17 @@     Mix,      sco, eff, mix, mixBy,     sco_, mix_, mixBy_,-    CsdSco(..), CsdEventList(..), CsdEvent+    Sco, CsdEventList(..), CsdEvent ) where +import Control.Applicative import Control.Monad.IO.Class import Data.Traversable import System.Mem.StableName -import Csound.Dynamic hiding (Instr)+import Temporal.Media++import Csound.Dynamic hiding (Instr, Sco, str) import qualified Csound.Typed.GlobalState.Elements as C  import Csound.Typed.Types@@ -18,27 +21,35 @@ import Csound.Typed.GlobalState hiding (notes) import Csound.Typed.Control.Instr +toCsdEventList :: Sco a -> CsdEventList a+toCsdEventList = id++singleCsdEvent :: (D, D, a) -> Sco a+singleCsdEvent (start, duration, content) = del start $ str duration $ temp content + -- | Special type that represents a scores of sound signals. -- If an instrument is triggered with the scores the result is wrapped -- in the value of this type.  newtype Mix a = Mix { unMix :: GE M }  -wrapSco :: (CsdSco f) => f a -> (CsdEventList a -> GE M) -> f (Mix b)+type Sco a = Track D a++wrapSco :: Sco a -> (CsdEventList a -> GE M) -> Sco (Mix b) wrapSco notes getContent = singleCsdEvent (0, csdEventListDur evts, Mix $ getContent evts)     where evts = toCsdEventList notes  -- | Plays a bunch of notes with the given instrument. -- -- > res = sco instrument scores -sco :: (CsdSco f, Arg a, Sigs b) => (a -> SE b) -> f a -> f (Mix b)+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 <- saveSourceInstrCached cacheName (funArity instr) (insExp instr)+    instrId <- saveSourceInstrCachedWithLivenessWatch cacheName (funArity instr) (insExp instr)     return $ Snd instrId events'  -- | Invokes a procedure for the given bunch of events.-sco_ :: (CsdSco f, Arg a) => (a -> SE ()) -> f a -> f (Mix Unit)+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@@ -60,42 +71,41 @@ -- board it produces the value that you can arrange with functions from your -- favorite Score-generation library. You can delay it or mix with some other track and  -- apply some another effect on top of it!-eff :: (CsdSco f, Sigs a, Sigs b) => (a -> SE b) -> f (Mix a) -> f (Mix b)+eff :: (Sigs a, Sigs b) => (a -> SE b) -> Sco (Mix a) -> Sco (Mix b) eff ef sigs = wrapSco sigs $ \events -> do     notes <- traverse unMix events     instrId <- saveEffectInstr (funArity ef) (effExp ef)     return $ Eff instrId notes (arityIns $ funArity ef)  -- | Renders a scores to the sound signals. we can use it inside the other instruments.--- Warning: if we use a score that lasts for an hour in the note that lasts for 5 seconds--- all the events would be generated, though we will hear only first five seconds.--- So the semantics is good but implementation is inefficient for such a cases --- (consider event streams for such cases). -mix :: (Sigs a, CsdSco f) => f (Mix a) -> a+mix :: (Sigs a) => Sco (Mix a) -> a mix a = flip apInstr unit $ do     key <- mixKey a-    withCache (NumDur $ csdEventListDur a') getMixKey saveMixKey key $ +    durE <- toGE $ dur a+    withCache (ExpDur durE) getMixKey saveMixKey key $          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, CsdSco f) => (a -> f (Mix b)) -> (a -> b)+mixBy :: (Arg a, Sigs b) => (a -> Sco (Mix b)) -> (a -> b) mixBy evts args = flip apInstr args $ do     key <- mixKey evts-    withCache (NumDur $ csdEventListDur evts') getMixKey saveMixKey key $ +    durE <- toGE $ dur evts'+    withCache (ExpDur durE) getMixKey saveMixKey key $          saveMixInstr (mixArityFun evts) =<< (toEventList evts')     where evts' = toCsdEventList $ evts toArg  -- | Converts a bunch of procedures scheduled with scores to a single procedure.-mix_ :: (CsdSco f) => f (Mix Unit) -> SE ()+mix_ :: Sco (Mix Unit) -> SE () mix_ a = fromDep_ $ hideGEinDep $ do     key <- mixKey a-    withCache (NumDur $ csdEventListDur a') getMixProcKey saveMixProcKey key $+    durE <- toGE $ dur a+    withCache (ExpDur durE) getMixProcKey saveMixProcKey key $         saveMixInstr_ =<< toEventList a'     where a' = toCsdEventList a  -- | Imitates a closure for a bunch of procedures to be played within another instrument. -mixBy_ :: (Arg a, CsdSco f) => (a -> f (Mix Unit)) -> (a -> SE ())+mixBy_ :: (Arg a) => (a -> Sco (Mix Unit)) -> (a -> SE ()) mixBy_ evts args = mix_ $ evts args  ----------------------------------------------------------@@ -103,8 +113,8 @@ mixKey :: a -> GE MixKey mixKey = liftIO . fmap (MixKey . hashStableName) . makeStableName -toEventList :: (CsdSco f) => f (Mix a) -> GE (CsdEventList M)-toEventList evts = fmap delayAndRescaleCsdEventListM $ traverse unMix $ toCsdEventList $ evts+toEventList :: Sco (Mix a) -> GE (CsdEventList M)+toEventList evts = fmap delayAndRescaleCsdEventListM $ traverse unMix $ evts      mixArity :: Sigs b => f (Mix b) -> Int mixArity = tupleArity . proxy

@@ -3,11 +3,10 @@ import Control.DeepSeq(deepseq)  import Control.Monad-import Control.Monad.Trans.Class import Csound.Dynamic hiding (newLocalVars)  import Csound.Typed.Types.Tuple-import Csound.Typed.GlobalState+import Csound.Typed.GlobalState.SE  -- | It describes a reference to mutable values. newtype SERef a = SERef [Var]

@@ -92,7 +92,7 @@     , midiCtrls         :: [MidiCtrl]     , totalDur          :: Maybe TotalDur     , alwaysOnInstrs    :: [InstrId]-    , notes             :: [(InstrId, CsdEvent Note)]+    , notes             :: [(InstrId, CsdEvent)]     , userInstr0        :: Dep ()     , bandLimitedMap    :: BandLimitedMap     , cache             :: Cache GE@@ -119,7 +119,7 @@         initc7 :: Monad m => E -> E -> E -> DepT m ()         initc7 a b c = depT_ $ opcs "initc7" [(Xr, [Ir, Ir, Ir])] [a, b, c] -data TotalDur = ExpDur E | NumDur Double | InfiniteDur+data TotalDur = ExpDur E | InfiniteDur  getTotalDurForTerminator :: GE E getTotalDurForTerminator = fmap (getTotalDurForTerminator' . totalDur) getHistory@@ -127,23 +127,21 @@ pureGetTotalDurForF0 :: Maybe TotalDur -> Double pureGetTotalDurForF0 = toDouble . maybe InfiniteDur id       where-        toDouble x = case x of-            NumDur d    -> d+        toDouble x = case x of                         _           -> infiniteDur   getTotalDurForTerminator' :: Maybe TotalDur -> E getTotalDurForTerminator' = toExpr . maybe InfiniteDur id     where-        toExpr x = case x of-            NumDur d    -> double d+        toExpr x = case x of                         InfiniteDur -> infiniteDur             ExpDur e    -> e              setDurationToInfinite :: GE () setDurationToInfinite = setTotalDur InfiniteDur -setDuration :: Double -> GE ()-setDuration = setTotalDur . NumDur+setDuration :: E -> GE ()+setDuration = setTotalDur . ExpDur  setDurationForce :: E -> GE () setDurationForce = setTotalDur . ExpDur @@ -205,7 +203,7 @@ saveAlwaysOnInstr instrId = onAlwaysOnInstrs $ modify (instrId : )     where onAlwaysOnInstrs = onHistory alwaysOnInstrs (\a h -> h { alwaysOnInstrs = a }) -addNote :: InstrId -> CsdEvent Note -> GE ()+addNote :: InstrId -> CsdEvent -> GE () addNote instrId evt = modifyHistory $ \h -> h { notes = (instrId, evt) : notes h }  

@@ -7,6 +7,7 @@ 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@@ -74,12 +75,12 @@  saveMixInstr :: Int -> CsdEventList M -> GE InstrId saveMixInstr arity a = do-    setDuration $ csdEventListDur a+    setDuration =<< toGE (csdEventListDur a)     saveInstr $ SE $ C.sendOut arity =<< renderMixSco arity a  saveMixInstr_ :: CsdEventList M -> GE (DepT GE ()) saveMixInstr_ a = do-    setDuration $ csdEventListDur a+    setDuration =<< toGE (csdEventListDur a)     return $ renderMixSco_ a  saveMasterInstr :: Arity -> InsExp -> GE ()

@@ -482,11 +482,11 @@ -- set gui value  flSetVal :: Sig -> Sig -> D -> SE ()-flSetVal trig val handle = SE $ (depT_ =<<) $ lift $ f <$> unSig trig <*> unSig val <*> unD handle+flSetVal trig val handle = SE $ (depT_ =<<) $ lift $ f <$> toGE trig <*> toGE val <*> toGE handle     where f a b c = opcs "FLsetVal" [(Xr, [Kr, Kr, Ir])] [a, b, c]  flPrintk2 :: Sig -> D -> SE ()-flPrintk2 val handle = SE $ (depT_ =<<) $ lift $ f <$> unSig val <*> unD handle+flPrintk2 val handle = SE $ (depT_ =<<) $ lift $ f <$> toGE val <*> toGE handle     where f a b = opcs "FLprintk2" [(Xr, [Kr, Ir])] [a, b]  -- | This opcode outputs a trigger signal that informs when any one of its k-rate @@ -496,7 +496,7 @@ -- -- doc: <http://www.csounds.com/manual/html/changed.html> changed :: [Sig] -> Sig-changed = Sig . fmap f . mapM unSig+changed = Sig . fmap f . mapM toGE     where f = opcs "changed" [(Kr, repeat Kr)]  

@@ -1,12 +1,35 @@ module Csound.Typed.Types.MixSco(-    M(..), delayAndRescaleCsdEventListM, renderMixSco, renderMixSco_+    M(..), CsdEventList, csdEventListDur, csdEventListNotes,+    delayAndRescaleCsdEventListM, renderMixSco, renderMixSco_ ) where +import Control.Applicative import Control.Monad -import Csound.Dynamic+import Csound.Dynamic hiding (int) import Csound.Typed.GlobalState.Elements+import Csound.Typed.GlobalState.Opcodes+import Csound.Typed.GlobalState.GE+import Csound.Typed.GlobalState.SE+import Csound.Typed.Control.SERef+import Csound.Typed.Types.Prim +import qualified Temporal.Media as T++type CsdEventList a = T.Track D a++csdEventListNotes :: CsdEventList a -> [(D, D, a)]+csdEventListNotes a = fmap (\(T.Event start dur content) -> (start, dur, content)) $ T.render a++csdEventListDur :: CsdEventList a -> D+csdEventListDur = T.dur++rescaleCsdEventList :: D -> CsdEventList a -> CsdEventList a+rescaleCsdEventList = T.str++delayCsdEventList :: D -> CsdEventList a -> CsdEventList a+delayCsdEventList = T.del+ data M      = Snd InstrId (CsdEventList [E])     | Eff InstrId (CsdEventList M) Int   @@ -15,21 +38,19 @@ delayAndRescaleCsdEventListM = delayCsdEventListM . rescaleCsdEventListM  delayCsdEventListM :: CsdEventList M -> CsdEventList M-delayCsdEventListM es = -    es { csdEventListNotes = fmap delayCsdEventM $ csdEventListNotes es }+delayCsdEventListM = T.mapEvents delayCsdEventM     -delayCsdEventM :: CsdEvent M -> CsdEvent M-delayCsdEventM (start, dur, evt) = (start, dur, phi evt)+delayCsdEventM :: T.Event D M -> T.Event D M+delayCsdEventM (T.Event start dur evt) = T.Event start dur (phi evt)     where phi x = case x of             Snd n evts          -> Snd n $ delayCsdEventList start evts             Eff n evts arityIn  -> Eff n (delayCsdEventListM $ delayCsdEventList start evts) arityIn          rescaleCsdEventListM :: CsdEventList M -> CsdEventList M-rescaleCsdEventListM es = -    es { csdEventListNotes = fmap rescaleCsdEventM $ csdEventListNotes es }+rescaleCsdEventListM = T.mapEvents rescaleCsdEventM     -rescaleCsdEventM :: CsdEvent M -> CsdEvent M-rescaleCsdEventM (start, dur, evt) = (start, dur, phi evt)+rescaleCsdEventM :: T.Event D M -> T.Event D M+rescaleCsdEventM (T.Event start dur evt) = T.Event start dur (phi evt)     where phi x = case x of             Snd n evts          -> Snd n $ rescaleCsdEventList (dur/localDur) evts             Eff n evts arityIn  -> Eff n (rescaleCsdEventListM $ rescaleCsdEventList (dur/localDur) evts) arityIn@@ -37,40 +58,54 @@                     Snd _ evts   -> csdEventListDur evts                     Eff _ evts _ -> csdEventListDur evts -renderMixSco :: Monad m => Int -> CsdEventList M -> DepT m [E]+renderMixSco :: Int -> CsdEventList M -> Dep [E] renderMixSco arity evts = do-    chnId <- chnRefAlloc arity-    go chnId evts+    chnId <- chnRefAlloc arity  +    aliveCountRef <- unSE $ newSERef (10 :: D)  +    go aliveCountRef chnId evts         readChn chnId     where -        go :: Monad m => ChnRef -> CsdEventList M -> DepT m ()-        go outId xs = mapM_ (onEvent outId) $ csdEventListNotes xs+        go :: SERef 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+            hideGEinDep $ liftA2 masterUpdateChnAlive (return chnId) $ toGE aliveCount +            where +                notes = csdEventListNotes xs+                chnId = outId -        onEvent :: Monad m => ChnRef -> CsdEvent M -> DepT m ()-        onEvent outId (start, dur, x) = case x of-            Snd instrId es          -> onSnd instrId outId es-            Eff instrId es arityIn  -> onEff instrId start dur outId es arityIn+        onEvent :: SERef 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 -        onSnd instrId outId es = forM_ (csdEventListNotes es) $ \(start, dur, args) ->-            event_i $ Event instrId (double start) (double dur) (args ++ [chnRefId outId])+        onSnd _ instrId outId es = forM_ (csdEventListNotes es) $ \(start, dur, args) -> +            mkEvent instrId start dur (args ++ [chnRefId outId]) -        onEff instrId start dur outId es arityIn = do+        onEff aliveCountRef instrId start dur outId es arityIn = do             inId <- chnRefAlloc arityIn-            event_i $ Event instrId (double start) (double dur) [chnRefId inId, chnRefId outId]-            go inId es+            mkEvent instrId start dur [chnRefId inId, chnRefId outId]            +            go aliveCountRef inId es -renderMixSco_ :: Monad m => CsdEventList M -> DepT m ()+renderMixSco_ :: CsdEventList M -> Dep () renderMixSco_ evts = mapM_ onEvent $ csdEventListNotes evts     where-        onEvent :: Monad m => CsdEvent M -> DepT m ()+        onEvent :: (D, D, M) -> Dep ()         onEvent (start, dur, x) = case x of             Snd instrId es      -> onSnd instrId es             Eff instrId es _    -> onEff instrId start dur es -        onSnd instrId es = forM_ (csdEventListNotes es) $ \(start, dur, args) ->-            event_i $ Event instrId (double start) (double dur) args+        onSnd instrId es = forM_ (csdEventListNotes es) $ \(start, dur, args) -> +            mkEvent instrId start dur args          onEff instrId start dur es = do-            event_i $ Event instrId (double start) (double dur) []+            mkEvent instrId start dur []              renderMixSco_ es ++mkEvent :: InstrId -> D -> D -> [E] -> Dep ()+mkEvent instrId startD durD args =  hideGEinDep $ do+        start <- toGE startD+        dur   <- toGE durD+        return $ event_i $ Event instrId start dur args

@@ -1,7 +1,7 @@-{-# Language TypeFamilies, FlexibleInstances #-}+{-# Language TypeFamilies, FlexibleInstances, FlexibleContexts, ScopedTypeVariables, Rank2Types #-} module Csound.Typed.Types.Prim(-    Sig(..), D(..), Tab(..), unTab, Str(..), Spec(..), Wspec(..), -    BoolSig(..), BoolD(..), Unit(..), unit, Val(..), hideGE, SigOrD,+    Sig(..), unSig, D(..), unD, Tab(..), unTab, Str(..), Spec(..), Wspec(..), +    BoolSig(..), unBoolSig, BoolD(..), unBoolD, Unit(..), unit, Val(..), hideGE, SigOrD,      -- ** Tables     preTab, TabSize(..), TabArgs(..), updateTabSize,@@ -38,14 +38,26 @@  import Csound.Dynamic hiding (double, int, str, when1, whens, ifBegin, ifEnd, elseBegin, untilBegin, untilEnd, untilDo) import qualified Csound.Dynamic as D(double, int, str, ifBegin, ifEnd, elseBegin, untilBegin, untilEnd)-import Csound.Typed.GlobalState+import Csound.Typed.GlobalState.GE+import Csound.Typed.GlobalState.SE+import Csound.Typed.GlobalState.Options  -- | Signals-newtype Sig  = Sig  { unSig :: GE E }+data Sig  +    = Sig  (GE E)+    | PrimSig Double +unSig :: Sig -> GE E+unSig = toGE+ -- | Constant numbers-newtype D    = D    { unD   :: GE E }+data D    +    = D  (GE E)+    | PrimD Double +unD :: D -> GE E+unD = toGE+ -- | Strings newtype Str  = Str  { unStr :: GE E } @@ -58,11 +70,21 @@ -- Booleans  -- | A signal of booleans.-newtype BoolSig = BoolSig { unBoolSig :: GE E }+data BoolSig +    = BoolSig (GE E)+    | PrimBoolSig Bool +unBoolSig :: BoolSig -> GE E+unBoolSig = toGE+ -- | A constant boolean value.-newtype BoolD   = BoolD   { unBoolD   :: GE E }+data BoolD   +    = BoolD (GE E)+    | PrimBoolD Bool +unBoolD :: BoolD -> GE E+unBoolD = toGE+ type instance BooleanOf Sig  = BoolSig  type instance BooleanOf D    = BoolD@@ -217,11 +239,11 @@  -- | Constructs a number. double :: Double -> D-double = fromE . D.double+double = PrimD  -- | Constructs an integer. int :: Int -> D-int = fromE . D.int+int =  PrimD . fromIntegral  -- | Constructs a string. text :: String -> Str@@ -279,8 +301,19 @@ hideGE :: Val a => GE a -> a hideGE = fromGE . join . fmap toGE -instance Val Sig    where { fromGE = Sig    ; toGE = unSig  }-instance Val D      where { fromGE = D      ; toGE = unD    }+instance Val Sig    where +    fromGE = Sig    +    +    toGE x = case x of+        Sig a       -> a+        PrimSig d   -> return $ D.double d++instance Val D      where +    fromGE  = D+    toGE x  = case x of+        D a     -> a+        PrimD d -> return $ D.double d+ instance Val Str    where { fromGE = Str    ; toGE = unStr  } instance Val Spec   where { fromGE = Spec   ; toGE = unSpec } instance Val Wspec  where { fromGE = Wspec  ; toGE = unWspec}@@ -294,11 +327,21 @@         Tab a -> a         TabPre a -> renderTab a -instance Val BoolSig where { fromGE = BoolSig ; toGE = unBoolSig }-instance Val BoolD   where { fromGE = BoolD   ; toGE = unBoolD   }+instance Val BoolSig where +    fromGE = BoolSig +    toGE x = case x of+        BoolSig a -> a+        PrimBoolSig b -> return $ if b then 1 else 0 -class Val a => SigOrD a where+instance Val BoolD   where +    fromGE = BoolD+    toGE x = case x of+        BoolD a -> a+        PrimBoolD b -> return $ if b then 1 else 0    ++class (IsPrim a, RealFrac (PrimOf a), Val a) => SigOrD a where+ instance SigOrD Sig where instance SigOrD D   where @@ -314,6 +357,14 @@ on3 :: (Val a, Val b, Val c, Val d) => (E -> E -> E -> E) -> (a -> b -> c -> d) on3 f a b c = fromGE $ liftA3 f (toGE a) (toGE b) (toGE c) +op1 :: (Val a, Val b, IsPrim a, IsPrim b) => (PrimOf a -> PrimOf b) -> (E -> E) -> (a -> b)+op1 primFun exprFun x = maybe (on1 exprFun x) (fromPrim . primFun) (getPrim x)++op2 :: (Val a, Val b, Val c, IsPrim a, IsPrim b, IsPrim c) => (PrimOf a -> PrimOf b -> PrimOf c) -> (E -> E -> E) -> (a -> b -> c)+op2 primFun exprFun xa xb = case (getPrim xa, getPrim xb) of+    (Just a, Just b) -> fromPrim $ primFun a b+    _                -> on2 exprFun xa xb+ ------------------------------------------------------------------------------- -- defaults @@ -332,57 +383,167 @@ ------------------------------------------------------------------------------- -- numeric +sigOn1 :: (Double -> Double) -> (E -> E) -> (Sig -> Sig)+sigOn1 numFun exprFun x = case x of+    PrimSig a -> PrimSig $ numFun a+    _         -> on1 exprFun x++sigOn2 :: (Double -> Double -> Double) -> (E -> E -> E) -> (Sig -> Sig -> Sig)+sigOn2 numFun exprFun xa xb = case (xa, xb) of+    (PrimSig a, PrimSig b) -> PrimSig $ numFun a b+    _                      -> on2 exprFun xa xb++ instance Num Sig where -    { (+) = on2 (+); (*) = on2 (*); negate = on1 negate; (-) = on2 (\a b -> a - b)   -    ; fromInteger = on0 . fromInteger; abs = on1 abs; signum = on1 signum }+    { (+) = sigOn2 (+) (+); (*) = sigOn2 (*) (*); negate = sigOn1 negate negate+    ; (-) = sigOn2 (\a b -> a - b) (\a b -> a - b)+    ; fromInteger = PrimSig . fromInteger; abs = sigOn1 abs abs; signum = sigOn1 signum signum } +dOn1 :: (Double -> Double) -> (E -> E) -> (D -> D)+dOn1 numFun exprFun x = case x of+    PrimD a -> PrimD $ numFun a+    _         -> on1 exprFun x++dOn2 :: (Double -> Double -> Double) -> (E -> E -> E) -> (D -> D -> D)+dOn2 numFun exprFun xa xb = case (xa, xb) of+    (PrimD a, PrimD b) -> PrimD $ numFun a b+    _                      -> on2 exprFun xa xb+ instance Num D where -    { (+) = on2 (+); (*) = on2 (*); negate = on1 negate; (-) = on2 (\a b -> a - b)   -    ; fromInteger = on0 . fromInteger; abs = on1 abs; signum = on1 signum }+    { (+) = dOn2 (+) (+); (*) = dOn2 (*) (*); negate = dOn1 negate negate+    ; (-) = dOn2 (\a b -> a - b) (\a b -> a - b)+    ; fromInteger = PrimD . fromInteger; abs = dOn1 abs abs; signum = dOn1 signum signum } -instance Fractional Sig  where { (/) = on2 (/);    fromRational = on0 . fromRational }-instance Fractional D    where { (/) = on2 (/);    fromRational = on0 . fromRational }+instance Fractional Sig  where { (/) = sigOn2 (/) (/);  fromRational = PrimSig . fromRational }+instance Fractional D    where { (/) = dOn2 (/) (/);    fromRational = PrimD . fromRational }  instance Floating Sig where-    { pi = on0 pi;  exp = on1 exp;  sqrt = on1 sqrt; log = on1 log;  logBase = on2 logBase; (**) = on2 (**)-    ;  sin = on1 sin;  tan = on1 tan;  cos = on1 cos; sinh = on1 sinh; tanh = on1 tanh; cosh = on1 cosh-    ; asin = on1 asin; atan = on1 atan;  acos = on1 acos ; asinh = on1 asinh; acosh = on1 acosh; atanh = on1 atanh }+    { pi = PrimSig pi;  exp = sigOn1 exp exp;  sqrt = sigOn1 sqrt sqrt; log = sigOn1 log log; logBase = sigOn2 logBase logBase; (**) = sigOn2 (**) (**)+    ; sin = sigOn1 sin sin;  tan = sigOn1 tan tan;  cos = sigOn1 cos cos; sinh = sigOn1 sinh sinh; tanh = sigOn1 tanh tanh; cosh = sigOn1 cosh cosh+    ; asin = sigOn1 asin asin; atan = sigOn1 atan atan;  acos = sigOn1 acos acos ; asinh = sigOn1 asinh asinh; acosh = sigOn1 acosh acosh; atanh = sigOn1 atanh atanh }  instance Floating D where-    { pi = on0 pi;  exp = on1 exp;  sqrt = on1 sqrt; log = on1 log;  logBase = on2 logBase; (**) = on2 (**)-    ;  sin = on1 sin;  tan = on1 tan;  cos = on1 cos; sinh = on1 sinh; tanh = on1 tanh; cosh = on1 cosh-    ; asin = on1 asin; atan = on1 atan;  acos = on1 acos ; asinh = on1 asinh; acosh = on1 acosh; atanh = on1 atanh }+    { pi = PrimD pi;  exp = dOn1 exp exp;  sqrt = dOn1 sqrt sqrt; log = dOn1 log log;  logBase = dOn2 logBase logBase; (**) = dOn2 (**) (**)+    ; sin = dOn1 sin sin;  tan = dOn1 tan tan;  cos = dOn1 cos cos; sinh = dOn1 sinh sinh; tanh = dOn1 tanh tanh; cosh = dOn1 cosh cosh+    ; asin = dOn1 asin asin; atan = dOn1 atan atan;  acos = dOn1 acos acos ; asinh = dOn1 asinh asinh; acosh = dOn1 acosh acosh; atanh = dOn1 atanh atanh } -ceil', floor', frac', int', round' :: SigOrD a => a -> a+class IsPrim a where+    type PrimOf a :: *+    getPrim :: a -> Maybe (PrimOf a)+    fromPrim :: PrimOf a -> a++instance IsPrim Sig where+    type PrimOf Sig = Double+    +    getPrim x = case x of+        PrimSig a -> Just a+        _         -> Nothing++    fromPrim = PrimSig++instance IsPrim D where+    type PrimOf D = Double+    +    getPrim x = case x of+        PrimD a -> Just a+        _         -> Nothing++    fromPrim = PrimD++instance IsPrim BoolSig where+    type PrimOf BoolSig = Bool+    +    getPrim x = case x of+        PrimBoolSig a -> Just a+        _         -> Nothing++    fromPrim = PrimBoolSig++instance IsPrim BoolD where+    type PrimOf BoolD = Bool+    +    getPrim x = case x of+        PrimBoolD a -> Just a+        _         -> Nothing++    fromPrim = PrimBoolD+++ceil', floor', int', round' :: SigOrD a => a -> a quot', rem', div', mod' :: SigOrD a => a -> a -> a -ceil' = on1 ceilE;    floor' = on1 floorE;  frac' = on1 fracE;  int' = on1 intE;    round' = on1 roundE-quot' = on2 quot; rem' = on2 rem;   div' = on2 div;   mod' = on2 mod+frac' :: (SigOrD a) => a -> a+frac' a = op1 (\x -> proxySnd a (properFraction x)) fracE a+    where+        proxySnd :: SigOrD a => a -> (Int, PrimOf a) -> PrimOf a+        proxySnd _ x = snd x +ceil' = op1 (\x -> fromIntegral ((ceiling x) :: Int)) ceilE+floor' = op1 (\x -> fromIntegral ((floor x) :: Int)) floorE+int' = op1 (\x -> fromIntegral ((truncate x) :: Int)) intE+round' = op1 (\x -> fromIntegral ((round x) :: Int)) roundE+quot' = op2 (\a b -> fromIntegral $ quot ((truncate a) :: Int) ((truncate b):: Int)) quot+rem' = op2 (\a b -> fromIntegral $ rem ((truncate a) :: Int) ((truncate b):: Int)) rem  +div' = op2 (\a b -> fromIntegral $ div ((truncate a) :: Int) ((truncate b):: Int)) div   +mod' = op2 (\a b -> fromIntegral $ mod ((truncate a) :: Int) ((truncate b):: Int)) mod+ ------------------------------------------------------------------------------- -- logic -instance Boolean BoolSig  where { true = on0 true;  false = on0 false;  notB = on1 notB;  (&&*) = on2 (&&*);  (||*) = on2 (||*) }-instance Boolean BoolD    where { true = on0 true;  false = on0 false;  notB = on1 notB;  (&&*) = on2 (&&*);  (||*) = on2 (||*) }+boolSigOn1 :: (Bool -> Bool) -> (E -> E) -> BoolSig -> BoolSig+boolSigOn1 = op1 -instance IfB Sig  where ifB = on3 ifB-instance IfB D    where ifB = on3 ifB-instance IfB Tab  where ifB = on3 ifB-instance IfB Str  where ifB = on3 ifB-instance IfB Spec where ifB = on3 ifB+boolSigOn2 :: (Bool -> Bool -> Bool) -> (E -> E -> E) -> BoolSig -> BoolSig -> BoolSig+boolSigOn2 = op2  -instance EqB Sig  where { (==*) = on2 (==*);    (/=*) = on2 (/=*) }-instance EqB D    where { (==*) = on2 (==*);    (/=*) = on2 (/=*) }+boolDOn1 :: (Bool -> Bool) -> (E -> E) -> BoolD -> BoolD+boolDOn1 = op1 -instance OrdB Sig where { (<*)  = on2 (<*) ;    (>*)  = on2 (>*);     (<=*) = on2 (<=*);    (>=*) = on2 (>=*) }-instance OrdB D   where { (<*)  = on2 (<*) ;    (>*)  = on2 (>*);     (<=*) = on2 (<=*);    (>=*) = on2 (>=*) }+boolDOn2 :: (Bool -> Bool -> Bool) -> (E -> E -> E) -> BoolD -> BoolD -> BoolD+boolDOn2 = op2  +instance Boolean BoolSig  where { true = PrimBoolSig True;  false = PrimBoolSig False;  notB = boolSigOn1 not notB;  (&&*) = boolSigOn2 (&&) (&&*);  (||*) = boolSigOn2 (||) (||*) }+instance Boolean BoolD    where { true = PrimBoolD   True;  false = PrimBoolD   False;  notB = boolDOn1   not notB;  (&&*) = boolDOn2   (&&) (&&*);  (||*) = boolDOn2   (||) (||*) }++instance IfB Sig  where +    ifB x a b = case x of+        PrimBoolSig cond -> if cond then a else b+        _                -> on3 ifB x a b++instance IfB D    where +    ifB x a b = case x of+        PrimBoolD cond -> if cond then a else b+        _              -> on3 ifB x a b++instance IfB Tab  where +    ifB x a b = case x of+        PrimBoolD cond -> if cond then a else b+        _              -> on3 ifB x a b++instance IfB Str  where +    ifB x a b = case x of+        PrimBoolD cond -> if cond then a else b+        _              -> on3 ifB x a b++instance IfB Spec where +    ifB x a b = case x of+        PrimBoolD cond -> if cond then a else b+        _              -> on3 ifB x a b++instance EqB Sig  where { (==*) = op2 (==) (==*);    (/=*) = op2 (/=) (/=*) }+instance EqB D    where { (==*) = op2 (==) (==*);    (/=*) = op2 (/=) (/=*) }++instance OrdB Sig where { (<*)  = op2 (<) (<*) ;    (>*)  = op2 (>) (>*);     (<=*) = op2 (<=) (<=*);    (>=*) = op2 (>=) (>=*) }+instance OrdB D   where { (<*)  = op2 (<) (<*) ;    (>*)  = op2 (>) (>*);     (<=*) = op2 (<=) (<=*);    (>=*) = op2 (>=) (>=*) }+ -- | Invokes the given procedure if the boolean signal is true. when1 :: BoolSig -> SE () -> SE ()-when1 p body = do-    ifBegin p-    body-    ifEnd+when1 xp body = case xp of+    PrimBoolSig p -> if p then body else return ()+    _             -> do+        ifBegin xp+        body+        ifEnd  -- | The chain of @when1@s. Tests all the conditions in sequence -- if everything is false it invokes the procedure given in the second argument.@@ -427,8 +588,9 @@  -- | Creates a constant boolean signal. boolSig :: BoolD -> BoolSig-boolSig = fromGE . toGE-+boolSig x = case x of+    PrimBoolD b -> PrimBoolSig b+    BoolD a     -> BoolSig a  ---------------------------------------------- 

@@ -38,7 +38,8 @@  import Csound.Dynamic import Csound.Typed.Types.Prim-import Csound.Typed.GlobalState+import Csound.Typed.GlobalState.GE+import Csound.Typed.GlobalState.SE import Csound.Typed.Types.TupleHelpers  -- | A tuple of Csound values.