csound-expression-typed (empty) → 0.0.0
raw patch · 27 files changed
+3017/−0 lines, 27 filesdep +Booleandep +basedep +containerssetup-changed
Dependencies added: Boolean, base, containers, csound-expression-dynamic, data-default, ghc-prim, stable-maps, transformers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- csound-expression-typed.cabal +62/−0
- src/Csound/Typed.hs +9/−0
- src/Csound/Typed/Control.hs +48/−0
- src/Csound/Typed/Control/Evt.hs +140/−0
- src/Csound/Typed/Control/Instr.hs +51/−0
- src/Csound/Typed/Control/Midi.hs +60/−0
- src/Csound/Typed/Control/Mix.hs +119/−0
- src/Csound/Typed/Control/SERef.hs +30/−0
- src/Csound/Typed/Control/Vco.hs +40/−0
- src/Csound/Typed/GlobalState.hs +18/−0
- src/Csound/Typed/GlobalState/Cache.hs +140/−0
- src/Csound/Typed/GlobalState/Elements.hs +271/−0
- src/Csound/Typed/GlobalState/GE.hs +203/−0
- src/Csound/Typed/GlobalState/Instr.hs +79/−0
- src/Csound/Typed/GlobalState/Opcodes.hs +189/−0
- src/Csound/Typed/GlobalState/Options.hs +119/−0
- src/Csound/Typed/GlobalState/SE.hs +63/−0
- src/Csound/Typed/Render.hs +87/−0
- src/Csound/Typed/Types.hs +71/−0
- src/Csound/Typed/Types/Evt.hs +150/−0
- src/Csound/Typed/Types/Lift.hs +240/−0
- src/Csound/Typed/Types/MixSco.hs +76/−0
- src/Csound/Typed/Types/Prim.hs +412/−0
- src/Csound/Typed/Types/Tuple.hs +278/−0
- src/Csound/Typed/Types/TupleHelpers.hs +30/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Anton Kholomiov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Anton Kholomiov nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ csound-expression-typed.cabal view
@@ -0,0 +1,62 @@+Name: csound-expression-typed+Version: 0.0.0+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+Build-Type: Simple+Category: Music, Sound+Maintainer: <anton.kholomiov@gmail.com>++Description: ++Homepage: https://github.com/anton-k/csound-expression-typed+Bug-Reports: https://github.com/anton-k/csound-expression-typed/issues++Source-repository head+ Type: git+ Location: https://github.com/anton-k/csound-expression-typed+++Library+ Ghc-Options: -Wall+ Build-Depends:+ base >= 4, base < 5, ghc-prim, containers, transformers, Boolean >= 0.1.0, data-default,+ stable-maps >= 0.0.3.3, csound-expression-dynamic+ Hs-Source-Dirs: src/+ Exposed-Modules:+ Csound.Typed++ Csound.Typed.Types+ Csound.Typed.Control+ Csound.Typed.Render+++ Csound.Typed.Types.Prim+ Csound.Typed.Types.Evt+ Csound.Typed.Types.Tuple+ Csound.Typed.Types.Lift++ Other-Modules:+ Csound.Typed.GlobalState+ Csound.Typed.GlobalState.Options+ Csound.Typed.GlobalState.GE+ Csound.Typed.GlobalState.SE+ Csound.Typed.GlobalState.Instr+ Csound.Typed.GlobalState.Cache+ Csound.Typed.GlobalState.Elements+ Csound.Typed.GlobalState.Opcodes++ Csound.Typed.Types.TupleHelpers+ Csound.Typed.Types.MixSco++ Csound.Typed.Control.Evt+ Csound.Typed.Control.Vco+ Csound.Typed.Control.Mix+ Csound.Typed.Control.Midi+ Csound.Typed.Control.SERef+ Csound.Typed.Control.Instr+
+ src/Csound/Typed.hs view
@@ -0,0 +1,9 @@+module Csound.Typed(+ module Csound.Typed.Types,+ module Csound.Typed.Control,+ module Csound.Typed.Render +) where++import Csound.Typed.Types+import Csound.Typed.Control+import Csound.Typed.Render
+ src/Csound/Typed/Control.hs view
@@ -0,0 +1,48 @@+module Csound.Typed.Control (+ -- * SE+ module Csound.Typed.GlobalState.SE,+ -- ** SE reference+ module Csound.Typed.Control.SERef,+ -- * Global settings+ instr0, getIns,+ -- * Score+ module Csound.Typed.Control.Mix,+ -- * Midi+ module Csound.Typed.Control.Midi,+ -- * Events+ module Csound.Typed.Control.Evt,+ -- * Band-limited oscillators+ module Csound.Typed.Control.Vco+) where++import Csound.Typed.GlobalState.SE++import Csound.Typed.Control.SERef++import Csound.Typed.Control.Evt+import Csound.Typed.Control.Mix+import Csound.Typed.Control.Midi+import Csound.Typed.Control.Vco++import Csound.Typed.Types+import Csound.Typed.GlobalState++instr0 :: Tuple a => SE a -> SE a+instr0 a = return $ toTuple $ saveIns0 ins0Arity (tupleRates $ proxy a) ins0Exp+ where+ ins0Exp = execGEinSE $ fmap fromTuple a++ ins0Arity = tupleArity $ proxy a++ proxy :: Tuple a => SE a -> a+ proxy = const (toTuple $ return $ repeat undefined)++getIns :: Sigs a => SE a+getIns = res+ where + res = fmap toTuple $ fromDep $ getIn (tupleArity $ proxy res) ++ proxy :: SE a -> a+ proxy = const undefined++
+ src/Csound/Typed/Control/Evt.hs view
@@ -0,0 +1,140 @@+{-# Language FlexibleContexts #-}+module Csound.Typed.Control.Evt(+ trig, sched, schedHarp, + trigBy, schedBy, schedHarpBy,+ trig_, sched_,+) where++import System.Mem.StableName++import Control.Applicative+import Control.Monad.IO.Class++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++-------------------------------------------------+-- triggereing the events++-- | 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)+trig :: (Arg a, Sigs b) => (a -> SE b) -> Evt (D, D, a) -> b+trig instr evts = apInstr0 $ do+ key <- evtKey evts instr+ withCache InfiniteDur getEvtKey saveEvtKey key $ do+ cacheName <- liftIO $ C.makeCacheName instr+ instrId <- saveSourceInstrCached cacheName (funArity instr) (insExp instr)+ saveEvtInstr (arityOuts $ funArity instr) instrId evts++-- | A closure to trigger an instrument inside the body of another instrument.+trigBy :: (Arg a, Sigs b, Arg c) => (a -> SE b) -> (c -> Evt (D, D, a)) -> (c -> b)+trigBy instr evts args = flip apInstr args $ do+ key <- evtKey evts instr+ withCache InfiniteDur getEvtKey saveEvtKey key $ do + cacheName <- liftIO $ C.makeCacheName instr+ instrId <- saveSourceInstrCached cacheName (funArity instr) (insExp instr)+ saveEvtInstr (arityOuts $ funArity instr) instrId (evts toArg) ++saveEvtInstr :: Arg a => Int -> C.InstrId -> Evt (D, D, a) -> GE C.InstrId+saveEvtInstr arity instrId evts = saveInstr evtMixInstr+ where+ evtMixInstr :: SE ()+ evtMixInstr = do+ chnId <- fromDep $ C.chnRefAlloc arity+ go chnId evts+ fromDep_ $ hideGEinDep $ fmap (\chn -> C.sendOut arity =<< C.readChn chn) chnId ++ go :: Arg a => GE C.ChnRef -> Evt (D, D, a) -> SE ()+ go mchnId es = + runEvt es $ \(start, dur, args) -> fromDep_ $ hideGEinDep $ do+ chnId <- mchnId+ e <- C.Event instrId <$> toGE start <*> toGE dur <*> (fmap (++ [C.chnRefId chnId]) $ toNote args) + return $ C.event e ++-- | It's like the function @trig@, but delay is set to zero.+sched :: (Arg a, Sigs b) => (a -> SE b) -> Evt (D, a) -> b+sched instr evts = apInstr0 $ do+ key <- evtKey evts instr+ withCache InfiniteDur getEvtKey saveEvtKey key $ do+ cacheName <- liftIO $ C.makeCacheName instr+ instrId <- saveSourceInstrCached cacheName (funArity instr) (insExp instr)+ saveEvtInstr (arityOuts $ funArity instr) instrId (fmap phi evts) + where phi (a, b) = (0, a, b)+ +-- | A closure to trigger an instrument inside the body of another instrument.+schedBy :: (Arg a, Sigs b, Arg c) => (a -> SE b) -> (c -> Evt (D, 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 <- saveSourceInstrCached cacheName (funArity instr) (insExp instr)+ saveEvtInstr (arityOuts $ funArity instr) instrId (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.+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 <- saveSourceInstrCached cacheName (funArity instr) (insExp $ (autoOff turnOffTime =<< ) . instr)+ saveEvtInstr (arityOuts $ funArity instr) instrId (fmap phi evts)+ where phi a = (0, -1, 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 <- saveSourceInstrCached cacheName (funArity instr) (insExp $ (autoOff turnOffTime =<< ) . instr)+ saveEvtInstr (arityOuts $ funArity instr) instrId (fmap phi $ evts toArg)+ where phi a = (0, -1, a)++autoOff :: Sigs a => D -> a -> SE a+autoOff dt sigs = fmap toTuple $ fromDep $ hideGEinDep $ phi =<< fromTuple sigs+ where + phi x = do+ dtE <- toGE dt+ return $ C.autoOff dtE x++-----------------------------------------------------------------------++-- | Triggers a procedure on the event stream.+trig_ :: (Arg a) => (a -> SE ()) -> Evt (D, D, a) -> SE ()+trig_ 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.+sched_ :: (Arg a) => (a -> SE ()) -> Evt (D, 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 $ 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 $ \(start, dur, args) -> fromDep_ $ 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+
+ src/Csound/Typed/Control/Instr.hs view
@@ -0,0 +1,51 @@+-- | Converts to low-level instruments+module Csound.Typed.Control.Instr(+ Arity(..), InsExp, EffExp,+ funArity, constArity, + insExp, effExp, masterExp, midiExp, unitExp, + apInstr, apInstr0+) where++import Csound.Dynamic(InstrId)+import qualified Csound.Typed.GlobalState.Elements as C++import Csound.Typed.Types+import Csound.Typed.GlobalState++funProxy :: (a -> f b) -> (a, b)+funProxy = const (msg, msg)+ where msg = error "I'm a Csound.Typed.Control.Instr.funProxy"++funArity :: (Tuple a, Tuple b) => (a -> SE b) -> Arity+funArity instr = Arity (tupleArity a) (tupleArity b)+ where (a, b) = funProxy instr++constArity :: (Tuple a) => SE a -> Arity+constArity a = Arity 0 (outArity a)+ +insExp :: (Arg a, Tuple b) => (a -> SE b) -> InsExp +insExp instr = execGEinSE $ fmap fromTuple $ instr toArg++effExp :: (Tuple a, Tuple b) => (a -> SE b) -> EffExp+effExp instr = execGEinSE . fmap fromTuple . instr . toTuple . return ++masterExp :: (Tuple a) => SE a -> InsExp+masterExp = execGEinSE . fmap fromTuple++midiExp :: (Tuple a) => (Msg -> SE a) -> InsExp+midiExp instr = execGEinSE $ fmap fromTuple $ instr Msg++unitExp :: SE Unit -> UnitExp+unitExp = execGEinSE . fmap unUnit++apInstr :: (Arg a, Sigs b) => GE InstrId -> a -> b+apInstr instrIdGE args = res+ where + res = toTuple $ do+ instrId <- instrIdGE+ argList <- fromTuple args+ return $ C.subinstr (tupleArity res) instrId argList++apInstr0 :: (Sigs b) => GE InstrId -> b+apInstr0 instrId = apInstr instrId unit+
+ src/Csound/Typed/Control/Midi.hs view
@@ -0,0 +1,60 @@+{-# Language FlexibleContexts #-}+module Csound.Typed.Control.Midi(+ Msg, Channel,+ midi, midin, pgmidi, + midi_, midin_, pgmidi_+) where++import System.Mem.StableName++import Control.Applicative+import Control.Monad.IO.Class+import Csound.Typed.Types+import Csound.Typed.GlobalState+import Csound.Typed.Control.Instr++-- | Triggers a midi-instrument (aka Csound's massign) for all channels. +-- It's useful to test a single instrument.+midi :: (Sigs a) => (Msg -> SE a) -> a+midi = midin 0++-- | Triggers a midi-instrument (aka Csound's massign) on the specified channel. +midin :: (Sigs a) => Channel -> (Msg -> SE a) -> a+midin n f = genMidi Massign n f++-- | Triggers a midi-instrument (aka Csound's pgmassign) on the specified programm bank. +pgmidi :: (Sigs a) => Maybe Int -> Channel -> (Msg -> SE a) -> a+pgmidi mchn n f = genMidi (Pgmassign mchn) n f ++genMidi :: (Sigs a) => MidiType -> Channel -> (Msg -> SE a) -> a+genMidi midiType chn instr = toTuple $ do + key <- midiKey midiType chn instr+ withCache InfiniteDur getMidiKey saveMidiKey key $+ saveMidiInstr midiType chn (constArity $ instr Msg) (midiExp 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++-- | 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)++genMidi_ :: MidiType -> Channel -> (Msg -> SE ()) -> SE ()+genMidi_ midiType chn instr = fromDep_ $ hideGEinDep $ do+ key <- midiKey midiType chn instr+ withCache InfiniteDur getMidiProcKey saveMidiProcKey key $ + saveMidiInstr_ midiType chn (unitExp $ fmap (const unit) $ instr Msg)++-----------------------------------------------------------------++midiKey :: MidiType -> Channel -> a -> GE MidiKey+midiKey ty chn a = liftIO $ MidiKey ty chn . hashStableName <$> makeStableName a +
+ src/Csound/Typed/Control/Mix.hs view
@@ -0,0 +1,119 @@+{-# Language FlexibleContexts #-}+module Csound.Typed.Control.Mix(+ Mix, + sco, eff, mix, mixBy,+ sco_, mix_, mixBy_,+ CsdSco(..), CsdEventList(..), CsdEvent+) where++import Control.Monad.IO.Class+import Data.Traversable+import System.Mem.StableName++import Csound.Dynamic hiding (Instr)+import qualified Csound.Typed.GlobalState.Elements as C++import Csound.Typed.Types+import Csound.Typed.Types.MixSco+import Csound.Typed.GlobalState+import Csound.Typed.Control.Instr++-- | 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)+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 instr notes = wrapSco notes $ \events -> do+ events' <- traverse toNote events+ cacheName <- liftIO $ C.makeCacheName instr+ instrId <- saveSourceInstrCached 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_ instr notes = wrapSco notes $ \events -> do+ events' <- traverse toNote events+ cacheName <- liftIO $ C.makeCacheName instr+ instrId <- saveSourceInstrCached_ cacheName (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. +--+-- > res = eff effect sco +--+-- * @effect@ - a function that takes a tuple of signals and produces +-- a tuple of signals.+--+-- * @sco@ - something that is constructed with 'Csound.Base.sco' or +-- 'Csound.Base.eff'. +--+-- With the function 'Csound.Base.eff' you can apply a reverb or adjust the +-- level of the signal. It functions like a mixing board but unlike mixing +-- 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 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 a = flip apInstr unit $ do+ key <- mixKey a+ withCache (NumDur $ csdEventListDur a') 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 evts args = flip apInstr args $ do+ key <- mixKey evts+ withCache (NumDur $ csdEventListDur evts') 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_ a = fromDep_ $ hideGEinDep $ do+ key <- mixKey a+ withCache (NumDur $ csdEventListDur a') 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_ evts args = mix_ $ evts args++----------------------------------------------------------++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++mixArity :: Sigs b => f (Mix b) -> Int+mixArity = tupleArity . proxy+ where+ proxy :: f (Mix b) -> b+ proxy = const undefined++mixArityFun :: Sigs b => (a -> f (Mix b)) -> Int+mixArityFun = tupleArity . proxy+ where+ proxy :: (a -> f (Mix b)) -> b+ proxy = const undefined
+ src/Csound/Typed/Control/SERef.hs view
@@ -0,0 +1,30 @@+module Csound.Typed.Control.SERef where++import Control.Monad+import Control.Monad.Trans.Class+import Csound.Dynamic hiding (newLocalVars)++import Csound.Typed.Types.Tuple+import Csound.Typed.GlobalState++-- | It describes a reference to mutable values.+data SERef a = SERef + { writeSERef :: a -> SE ()+ , readSERef :: SE a }++-- | Allocates a new mutable value and initializes it with value. +-- A reference can contain a tuple of variables.+newSERef :: Tuple a => a -> SE (SERef a)+newSERef t = do+ vars <- newLocalVars (tupleRates t) (fromTuple t)+ let wr a = fromDep_ $ (zipWithM_ writeVar vars) =<< lift (fromTuple a)+ re = fmap toTuple $ fromDep $ mapM readVar vars+ return (SERef wr re)++-- | 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)+
+ src/Csound/Typed/Control/Vco.hs view
@@ -0,0 +1,40 @@+-- | Band-limited oscillators+module Csound.Typed.Control.Vco(+ saw, isaw, pulse, tri, sqr, blosc +) where++import Csound.Typed.GlobalState+import Csound.Typed.Types++-- | A sawtooth.+saw :: Sig -> Sig+saw = wave Saw++-- | Integrated sawtooth: 4 * x * (1 - x).+isaw :: Sig -> Sig+isaw = wave IntegratedSaw++-- | A triangle wave.+tri :: Sig -> Sig+tri = wave Triangle++-- | Pulse (not normalized).+pulse :: Sig -> Sig +pulse = wave Pulse++-- | A square wave.+sqr :: Sig -> Sig+sqr = wave Square++-- | A band-limited oscillator with user defined waveform (it's stored in the table).+blosc :: Tab -> Sig -> Sig+blosc tab cps = hideGE $ do+ gen <- fromPreTab $ getPreTabUnsafe "blosc: tab should be primitive, not an expression." tab+ return $ wave (UserGen gen) cps++wave :: BandLimited -> Sig -> Sig+wave waveType cps = fromGE $ do+ expr <- toGE cps+ waveId <- saveBandLimitedWave waveType+ return $ readBandLimited waveId expr+
+ src/Csound/Typed/GlobalState.hs view
@@ -0,0 +1,18 @@+module Csound.Typed.GlobalState (+ 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,+ -- * Reexports dynamic+ BandLimited(..), readBandLimited, renderBandLimited,+ Instrs(..), IdMap(..),+ getIn, chnUpdateUdo, renderGlobals+) where++import Csound.Typed.GlobalState.Options+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
+ src/Csound/Typed/GlobalState/Cache.hs view
@@ -0,0 +1,140 @@+module Csound.Typed.GlobalState.Cache(+ Cache(..), HashKey,++ -- * Midi+ -- ** Functions+ CacheMidi, MidiKey(..), Channel, MidiType(..),+ saveMidiKey, getMidiKey,+ -- ** Procedures+ CacheMidiProc, + saveMidiProcKey, getMidiProcKey,+ -- * 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 + { cacheMidi :: CacheMidi + , cacheMidiProc :: CacheMidiProc m+ , cacheMix :: CacheMix+ , cacheMixProc :: CacheMixProc m+ , cacheEvt :: CacheEvt+ , cacheEvtProc :: CacheEvtProc m }++instance Default (Cache m) where+ def = Cache def def 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++----------------------------------------------------------+-- Midi++type Channel = Int++data MidiType = Massign | Pgmassign (Maybe Int)+ deriving (Eq, Ord)++data MidiKey = MidiKey MidiType Channel HashKey+ deriving (Eq, Ord)++-- Midi functions++type CacheMidi = M.Map MidiKey [E]++getMidiKey :: GetKey m MidiKey [E]+getMidiKey = getKeyMap cacheMidi++saveMidiKey :: SaveKey m MidiKey [E]+saveMidiKey = saveKeyMap cacheMidi (\a x -> x { cacheMidi = a })++-- Midi procedures++type CacheMidiProc m = M.Map MidiKey (DepT m ())++getMidiProcKey :: GetKey m MidiKey (DepT m ())+getMidiProcKey = getKeyMap cacheMidiProc++saveMidiProcKey :: SaveKey m MidiKey (DepT m ())+saveMidiProcKey = saveKeyMap cacheMidiProc (\a x -> x { cacheMidiProc = a })++----------------------------------------------------------+-- 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 })+
+ src/Csound/Typed/GlobalState/Elements.hs view
@@ -0,0 +1,271 @@+{-# Language DeriveFunctor #-}+module Csound.Typed.GlobalState.Elements(+ -- * Identifiers+ IdMap(..), saveId, newIdMapId,+ -- ** Gens+ GenMap, newGen, newGenId,+ -- ** Band-limited waveforms+ BandLimited(..), BandLimitedMap, + saveBandLimited, renderBandLimited,+ readBandLimited, readBandLimitedConstCps,+ -- ** String arguments+ StringMap, newString,+ -- * Global variables+ Globals(..), newPersistentGlobalVar, newClearableGlobalVar, + renderGlobals,+ -- * Instruments+ Instrs(..), saveInstr, CacheName, makeCacheName, saveCachedInstr,+ -- * Src+ InstrBody, getIn, sendOut, sendChn, sendGlobal, + Event(..),+ ChnRef(..), chnRefFromParg, chnRefAlloc, readChn, writeChn, chnUpdateUdo,+ subinstr, subinstr_, event_i, event, safeOut, autoOff+) where+++import Control.Monad.Trans.State.Strict+import Control.Monad(zipWithM_)+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()++import Csound.Typed.GlobalState.Opcodes++-- tables of identifiers++data IdMap a = IdMap+ { idMapContent :: M.Map a Int+ , idMapNewId :: Int }++instance Default (IdMap a) where + def = IdMap def 1++saveId :: Ord a => a -> State (IdMap a) Int+saveId a = state $ \s -> + case M.lookup a (idMapContent s) of+ Nothing -> + let newId = idMapNewId s+ s1 = s{ idMapContent = M.insert a newId (idMapContent s)+ , idMapNewId = succ newId } + in (newId, s1)+ Just n -> (n, s)++newIdMapId :: State (IdMap a) Int+newIdMapId = state $ \s -> + let newId = idMapNewId s+ s1 = s { idMapNewId = succ newId } + in (newId, s1)++-- gens++type GenMap = IdMap Gen++newGen :: Gen -> State GenMap E+newGen = fmap int . saveId++newGenId :: State GenMap Int+newGenId = newIdMapId++-- strings++type StringMap = IdMap String++newString :: String -> State StringMap Prim+newString = fmap PrimInt . saveId++-- band-limited waveforms (used with vco2init)++data BandLimited = Saw | Pulse | Square | Triangle | IntegratedSaw | UserGen Gen+ deriving (Eq, Ord)++type BandLimitedMap = M.Map BandLimited Int++saveBandLimited :: BandLimited -> State (GenMap, BandLimitedMap) Int+saveBandLimited x = case x of+ Saw -> simpleWave 1 0+ IntegratedSaw -> simpleWave 2 1+ Pulse -> simpleWave 4 2+ Square -> simpleWave 8 3+ Triangle -> simpleWave 16 4+ UserGen _ -> userGen + where+ simpleWave writeId readId = state $ \s@(genMap, blMap) ->+ if (M.member x blMap) + then (readId, s)+ else (readId, (genMap, M.insert x writeId blMap))++ userGen = state $ \s@(genMap, blMap) -> case M.lookup x blMap of+ Just n -> (n, s)+ Nothing -> + let (newId, genMap1) = runState newGenId genMap+ blMap1 = M.insert x newId blMap+ in (negate newId, (genMap1, blMap1)) ++renderBandLimited :: Monad m => GenMap -> BandLimitedMap -> DepT m ()+renderBandLimited genMap blMap = case M.toList blMap of+ [] -> return ()+ as -> render (idMapNewId genMap) (getUserGens as) as+ where + render n gens vcos = do+ mapM_ renderGen gens+ renderFirstVco n (head vcos)+ mapM_ renderTailVco (tail vcos) ++ getUserGens as = phi =<< as+ where phi (x, gId) = case x of+ UserGen g -> [(g, gId)]+ _ -> []+ + renderGen (g, n) = toDummy $ ftgen (int n) g++ renderFirstVco n x = renderVco (int n) x+ renderTailVco x = renderVco (readOnlyVar vcoVar) x++ renderVco ftId (wave, waveId) = toVcoVar $ vco2init $ case wave of+ UserGen _ -> [ int waveId, ftId, 1.05, -1, -1, int $ negate waveId ]+ _ -> [ int waveId, ftId ]++ vcoVar = dummyVar+ toVcoVar = toDummy++ dummyVar = Var LocalVar Ir "ft" ++ toDummy = writeVar dummyVar++readBandLimited :: Int -> E -> E+readBandLimited n cps = oscilikt 1 cps (vco2ft cps (int n))++readBandLimitedConstCps :: Int -> E -> E+readBandLimitedConstCps n cps = oscili 1 cps (vco2ift cps (int n))+ +-- global variables++data Globals = Globals+ { globalsNewId :: Int+ , globalsVars :: [AllocVar] }++data AllocVar = AllocVar + { allocVarType :: GlobalVarType + , allocVar :: Var+ , allocVarInit :: E }++data GlobalVarType = PersistentGlobalVar | ClearableGlobalVar+ deriving (Eq)++instance Default Globals where+ def = Globals def def++newGlobalVar :: GlobalVarType -> Rate -> E -> State Globals Var+newGlobalVar ty rate initVal = state $ \s ->+ let newId = globalsNewId s + var = Var GlobalVar rate ('g' : show newId) + s1 = s { globalsNewId = succ newId+ , globalsVars = AllocVar ty var initVal : globalsVars s }+ in (var, s1)++newPersistentGlobalVar :: Rate -> E -> State Globals Var+newPersistentGlobalVar = newGlobalVar PersistentGlobalVar++newClearableGlobalVar :: Rate -> E -> State Globals Var+newClearableGlobalVar = newGlobalVar ClearableGlobalVar+ +renderGlobals :: Monad m => Globals -> (DepT m (), DepT m ())+renderGlobals a = (initAll, clear)+ where+ initAll = mapM_ (\x -> initVar (allocVar x) (allocVarInit x)) gs+ clear = mapM_ (\x -> writeVar (allocVar x) (allocVarInit x)) clearable+ clearable = filter ((== ClearableGlobalVar) . allocVarType) gs+ gs = globalsVars a++-----------------------------------------------------------------+-- instrs++data Instrs = Instrs+ { instrsCache :: DM.Map InstrId+ , instrsNewId :: Int+ , instrsContent :: [(InstrId, InstrBody)]+ }++instance Default Instrs where+ def = Instrs DM.empty 17 []++type CacheName = DM.DynamicStableName++makeCacheName :: a -> IO CacheName+makeCacheName = DM.makeDynamicStableName ++-----------------------------------------------------------------+--+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 ->+ let newId = instrsNewId s+ s1 = s { instrsNewId = succ newId+ , instrsContent = (intInstrId newId, body) : instrsContent s }+ in (intInstrId newId, s1)++-----------------------------------------------------------------+-- sound sources++getIn :: Monad m => Int -> DepT m [E]+getIn arity+ | arity == 0 = return []+ | otherwise = ($ arity ) $ mdepT $ mopcs name (replicate arity Ar, []) []+ where+ name+ | arity == 1 = "in"+ | arity == 2 = "ins"+ | arity == 4 = "inq"+ | arity == 6 = "inh"+ | arity == 8 = "ino"+ | arity == 16 = "inx"+ | arity == 32 = "in32"+ | otherwise = "ins"++sendOut :: Monad m => Int -> [E] -> DepT m ()+sendOut arity sigs + | arity == 0 = return ()+ | otherwise = do+ vars <- newLocalVars (replicate arity Ar) (return $ replicate arity 0)+ zipWithM_ writeVar vars sigs+ vals <- mapM readVar vars+ depT_ $ opcsNoInlineArgs name [(Xr, replicate arity Ar)] vals+ where+ name + | arity == 1 = "out"+ | arity == 2 = "outs"+ | arity == 4 = "outq"+ | arity == 6 = "outh"+ | arity == 8 = "outo"+ | arity == 16 = "outx"+ | arity == 32 = "out32"+ | otherwise = "outc"++sendGlobal :: Monad m => Int -> [E] -> State Globals ([E], DepT m ())+sendGlobal arityOuts sigs = do+ vars <- mapM (uncurry newClearableGlobalVar) $ replicate arityOuts (Ar, 0)+ return (fmap readOnlyVar vars, zipWithM_ (appendVarBy (+)) vars sigs)++sendChn :: Monad m => Int -> Int -> [E] -> DepT m ()+sendChn arityIns arityOuts sigs = writeChn (chnRefFromParg (4 + arityIns) arityOuts) sigs++-- guis+++
+ src/Csound/Typed/GlobalState/GE.hs view
@@ -0,0 +1,203 @@+module Csound.Typed.GlobalState.GE(+ GE, Dep, History(..), withOptions, withHistory, getOptions, evalGE, execGE,+ -- * Globals+ onGlobals, + -- * Midi+ MidiAssign(..), Msg(..), renderMidiAssign, saveMidi, + -- * Instruments+ saveAlwaysOnInstr, onInstr, saveUserInstr0, getSysExpr,+ -- * Total duration+ TotalDur(..), getTotalDur, setDuration, setDurationToInfinite,+ -- * GEN routines+ saveGen,+ -- * Band-limited waves+ saveBandLimitedWave,+ -- * Strings+ saveStr,+ -- * Cache+ GetCache, SetCache, withCache+) where++import Control.Applicative+import Control.Monad+import Data.Default++import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.Reader++import Csound.Dynamic ++import Csound.Typed.GlobalState.Options+import Csound.Typed.GlobalState.Cache+import Csound.Typed.GlobalState.Elements++type Dep a = DepT GE a++-- global side effects+newtype GE a = GE { unGE :: ReaderT Options (StateT History IO) a }++runGE :: GE a -> Options -> History -> IO (a, History)+runGE (GE f) opt hist = runStateT (runReaderT f opt) hist++evalGE :: Options -> GE a -> IO a+evalGE options a = fmap fst $ runGE a options def++execGE :: Options -> GE a -> IO History+execGE options a = fmap snd $ runGE a options def++instance Functor GE where+ fmap f = GE . fmap f . unGE++instance Applicative GE where+ pure = return+ (<*>) = ap++instance Monad GE where+ return = GE . return+ ma >>= mf = GE $ unGE ma >>= unGE . mf++instance MonadIO GE where+ liftIO = GE . liftIO . liftIO+ +data History = History+ { genMap :: GenMap+ , stringMap :: StringMap+ , globals :: Globals+ , instrs :: Instrs+ , midis :: [MidiAssign]+ , totalDur :: Maybe TotalDur+ , alwaysOnInstrs :: [InstrId]+ , userInstr0 :: Dep ()+ , bandLimitedMap :: BandLimitedMap+ , cache :: Cache GE }++instance Default History where+ def = History def def def def def def def (return ()) def def++data Msg = Msg+data MidiAssign = MidiAssign MidiType Channel InstrId+ +renderMidiAssign :: Monad m => MidiAssign -> DepT m ()+renderMidiAssign (MidiAssign ty chn instrId) = case ty of+ Massign -> massign chn instrId+ Pgmassign mn -> pgmassign chn instrId mn+ where+ massign n instr = depT_ $ opcs "massign" [(Xr, [Ir,Ir])] [int n, prim $ PrimInstrId instr]+ pgmassign pgm instr mchn = depT_ $ opcs "pgmassign" [(Xr, [Ir,Ir,Ir])] ([int pgm, prim $ PrimInstrId instr] ++ maybe [] (return . int) mchn)++data TotalDur = NumDur Double | InfiniteDur+ deriving (Eq, Ord)++getTotalDur :: Options -> (Maybe TotalDur) -> Double+getTotalDur _ = toDouble . maybe InfiniteDur id + where + toDouble x = case x of+ NumDur d -> d+ InfiniteDur -> infiniteDur+ infiniteDur = 7 * 24 * 60 * 60 -- a week++saveStr :: String -> GE E+saveStr = fmap prim . onStringMap . newString+ where onStringMap = onHistory stringMap (\val h -> h{ stringMap = val })++saveGen :: Gen -> GE E+saveGen = onGenMap . newGen+ where onGenMap = onHistory genMap (\val h -> h{ genMap = val })++saveBandLimitedWave :: BandLimited -> GE Int+saveBandLimitedWave = onBandLimitedMap . saveBandLimited+ where onBandLimitedMap = onHistory + (\a -> (genMap a, bandLimitedMap a)) + (\(gm, blm) h -> h { genMap = gm, bandLimitedMap = blm})++setDurationToInfinite :: GE ()+setDurationToInfinite = setTotalDur InfiniteDur++setDuration :: Double -> GE ()+setDuration = setTotalDur . NumDur++setTotalDur :: TotalDur -> GE ()+setTotalDur = onTotalDur . modify . const . Just+ where onTotalDur = onHistory totalDur (\a h -> h { totalDur = a })++saveMidi :: MidiAssign -> GE ()+saveMidi ma = onMidis $ modify (ma: )+ where onMidis = onHistory midis (\a h -> h { midis = a })++saveUserInstr0 :: Dep () -> GE ()+saveUserInstr0 expr = onUserInstr0 $ modify ( >> expr)+ where onUserInstr0 = onHistory userInstr0 (\a h -> h { userInstr0 = a })++getSysExpr :: GE (Dep ())+getSysExpr = withHistory $ clearGlobals . globals+ where clearGlobals = snd . renderGlobals++saveAlwaysOnInstr :: InstrId -> GE ()+saveAlwaysOnInstr instrId = onAlwaysOnInstrs $ modify (instrId : )+ where onAlwaysOnInstrs = onHistory alwaysOnInstrs (\a h -> h { alwaysOnInstrs = a })++{-+setMasterInstrId :: InstrId -> GE ()+setMasterInstrId masterId = onMasterInstrId $ put masterId+ where onMasterInstrId = onHistory masterInstrId (\a h -> h { masterInstrId = a })+-}+----------------------------------------------------------------------+-- state modifiers++withOptions :: (Options -> a) -> GE a+withOptions f = GE $ asks f++getOptions :: GE Options+getOptions = withOptions id++withHistory :: (History -> a) -> GE a+withHistory f = GE $ lift $ fmap f get++modifyHistory :: (History -> History) -> GE ()+modifyHistory = GE . lift . modify++-- update fields++onHistory :: (History -> a) -> (a -> History -> History) -> State a b -> GE b+onHistory getter setter st = GE $ ReaderT $ \_ -> StateT $ \history -> + let (res, s1) = runState st (getter history)+ in return (res, setter s1 history) ++type UpdField a b = State a b -> GE b++onInstr :: UpdField Instrs a+onInstr = onHistory instrs (\a h -> h { instrs = a })++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++
+ src/Csound/Typed/GlobalState/Instr.hs view
@@ -0,0 +1,79 @@+module Csound.Typed.GlobalState.Instr where++import Control.Monad++import Csound.Dynamic+import qualified Csound.Typed.GlobalState.Elements as C++import Csound.Typed.Types.MixSco+import Csound.Typed.GlobalState.GE+import Csound.Typed.GlobalState.SE+import Csound.Typed.GlobalState.Options+import Csound.Typed.GlobalState.Cache++data Arity = Arity+ { arityIns :: Int+ , arityOuts :: Int }++type InsExp = SE [E]+type EffExp = [E] -> SE [E]+type UnitExp = SE ()++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++saveSourceInstrCached :: C.CacheName -> Arity -> InsExp -> GE InstrId+saveSourceInstrCached cacheName arity instr = saveCachedInstr cacheName $ toOut =<< instr+ where toOut = SE . C.sendChn (arityIns arity) (arityOuts arity)++saveSourceInstrCached_ :: C.CacheName -> UnitExp -> GE InstrId+saveSourceInstrCached_ cacheName instr = saveCachedInstr cacheName instr++saveEffectInstr :: Arity -> EffExp -> GE InstrId+saveEffectInstr arity eff = saveInstr $ setOuts =<< eff =<< getIns+ where + setOuts = SE . C.writeChn (C.chnRefFromParg 5 (arityOuts arity))+ getIns = SE $ C.readChn $ C.chnRefFromParg 4 (arityIns arity)++saveMixInstr :: Int -> CsdEventList M -> GE InstrId+saveMixInstr arity a = do+ setDuration $ csdEventListDur a+ saveInstr $ SE $ C.sendOut arity =<< renderMixSco arity a++saveMixInstr_ :: CsdEventList M -> GE (DepT GE ())+saveMixInstr_ a = do+ setDuration $ csdEventListDur a+ return $ renderMixSco_ a++saveMasterInstr :: Arity -> InsExp -> GE ()+saveMasterInstr arity sigs = do+ gainLevel <- fmap defGain getOptions + saveAlwaysOnInstr =<< + (saveInstr $ (SE . C.sendOut (arityOuts arity) . C.safeOut gainLevel) =<< sigs)+ expr2 <- getSysExpr + saveAlwaysOnInstr =<< saveInstr (SE expr2)++saveMidiInstr :: MidiType -> Channel -> Arity -> InsExp -> GE [E]+saveMidiInstr midiType channel arity instr = do+ setDurationToInfinite+ vars <- onGlobals $ sequence $ replicate (arityOuts arity) (C.newClearableGlobalVar Ar 0)+ let expr = (SE . zipWithM_ (appendVarBy (+)) vars) =<< instr+ instrId <- saveInstr expr+ saveMidi $ MidiAssign midiType channel instrId+ return $ fmap readOnlyVar vars ++saveMidiInstr_ :: MidiType -> Channel -> UnitExp -> GE (Dep ())+saveMidiInstr_ midiType channel instr = do+ instrId <- onInstr . C.saveInstr =<< execSE instr+ saveMidi $ MidiAssign midiType channel instrId+ return $ return ()++saveIns0 :: Int -> [Rate] -> SE [E] -> GE [E]+saveIns0 arity rates as = do+ vars <- onGlobals $ zipWithM C.newPersistentGlobalVar rates (replicate arity 0)+ saveUserInstr0 $ unSE $ (SE . zipWithM_ writeVar vars) =<< as + return $ fmap readOnlyVar vars+
+ src/Csound/Typed/GlobalState/Opcodes.hs view
@@ -0,0 +1,189 @@+module Csound.Typed.GlobalState.Opcodes(+ sprintf,+ -- * channel opcodes+ ChnRef(..), chnRefFromParg, chnRefAlloc, readChn, writeChn, + chnUpdateUdo,+ -- * trigger an instrument+ Event(..), event, event_i, appendChn, subinstr, subinstr_,+ -- * output+ out, outs, safeOut, autoOff,+ -- * vco2+ oscili, oscilikt, vco2ft, vco2ift, vco2init, ftgen+) where++import Control.Monad(zipWithM_)+import Data.Boolean++import Csound.Dynamic++-- channels++data ChnRef = ChnRef + { chnRefId :: E+ , chnRefNames :: [E] }++chnRefFromParg :: Int -> Int -> ChnRef+chnRefFromParg pargId arity = ChnRef (pn pargId) $ fmap (flip chnName (pn pargId)) [1 .. arity]++chnRefAlloc :: Monad m => Int -> DepT m ChnRef+chnRefAlloc arity = do+ chnId <- freeChn+ return $ ChnRef chnId $ fmap (flip chnName chnId) [1 .. arity]+ +readChn :: Monad m => ChnRef -> DepT m [E]+readChn ref = do+ res <- mapM chnget $ chnRefNames ref+ clearChn ref+ return res++writeChn :: Monad m => ChnRef -> [E] -> DepT m ()+writeChn ref sigs = zipWithM_ chnmix sigs $ chnRefNames ref+ +clearChn :: Monad m => ChnRef -> DepT m ()+clearChn = mapM_ chnclear . chnRefNames++-- | +-- > chnName outputPortNumber freeChnId+chnName :: Int -> E -> E+chnName name chnId = sprintf formatString [chnId]+ where formatString = str $ 'p' : show name ++ "_" ++ "%d"++sprintf :: E -> [E] -> E+sprintf a as = opcs "sprintf" [(Sr, Sr:repeat Ir)] (a:as)++chnmix :: Monad m => E -> E -> DepT m ()+chnmix asig name = do+ var <- newLocalVar Ar (return 0)+ writeVar var asig+ val <- readVar var+ depT_ $ opcsNoInlineArgs "chnmix" [(Xr, [Ar, Sr])] [val, name]++chnget :: Monad m => E -> DepT m E+chnget name = depT $ opcs "chnget" [(Ar, [Sr])] [name]++chnclear :: Monad m => E -> DepT m ()+chnclear name = depT_ $ opcs "chnclear" [(Xr, [Sr])] [name]++chnUpdateUdo :: Monad m => DepT m ()+chnUpdateUdo = verbatim $ unlines [+ "giPort init 1",+ "opcode " ++ chnUpdateOpcodeName ++ ", i, 0",+ "xout giPort",+ "giPort = giPort + 1",+ "endop"]+++chnUpdateOpcodeName :: String+chnUpdateOpcodeName = "FreePort"++freeChn :: Monad m => DepT m E+freeChn = depT $ opcs chnUpdateOpcodeName [(Ir, [])] []++-- trigger++data Event = Event+ { eventInstrId :: InstrId+ , eventStart :: E+ , eventDur :: E+ , eventArgs :: [E] }++event :: Monad m => Event -> DepT m ()+event = eventBy "event" Kr++event_i :: Monad m => Event -> DepT m ()+event_i = eventBy "event_i" Ir++eventBy :: Monad m => String -> Rate -> Event -> DepT m ()+eventBy name rate a = depT_ $ opcs name [(Xr, repeat rate)] + (str "i" : (prim (PrimInstrId $ eventInstrId a)) : (eventStart a) : (eventDur a) : (eventArgs a))++appendChn :: E -> Event -> Event+appendChn chn a = a { eventArgs = eventArgs a ++ [chn] }++subinstr :: Int -> InstrId -> [E] -> [E]+subinstr outArity instrId args = ( $ outArity) $ mopcs "subinstr" + (repeat Ar, Ir : repeat Kr) + (prim (PrimInstrId instrId) : args)++subinstr_ :: Monad m => InstrId -> [E] -> DepT m ()+subinstr_ instrId args = depT_ $ head $ ($ 1) $ mopcs "subinstr" + (repeat Ar, Ir : repeat Kr)+ (prim (PrimInstrId instrId) : args)++-- output++out :: Monad m => E -> DepT m ()+out a = depT_ $ opcsNoInlineArgs "out" [(Xr, [Ar])] [a]++outs :: Monad m => [E] -> DepT m ()+outs as = depT_ $ opcsNoInlineArgs "outs" [(Xr, repeat Ar)] as++-- safe out++-- clipps values by 0dbfs+safeOut :: Double -> [E] -> [E] +safeOut gainLevel = fmap (( * double gainLevel) . clip)+ where clip x = opcs "clip" [(Ar, [Ar, Ir, Ir])] [x, 0, readOnlyVar (VarVerbatim Ir "0dbfs")]++autoOff :: Monad m => E -> [E] -> DepT m [E]+autoOff dt a = do+ ihold + when1 (trig a)+ turnoff+ return a+ where+ trig = (<* eps) . (env + ) . setRate Kr . flip follow dt . l2 ++ eps = 1e-5++ l2 :: [E] -> E+ l2 xs = sqrt $ sum $ zipWith (*) xs xs ++ env = linseg [1, dt/2, 1, dt/2, 0, 1, 0]++follow :: E -> E -> E+follow asig dt = opcs "follow" [(Ar, [Ar, Ir])] [asig, dt]++turnoff :: Monad m => DepT m ()+turnoff = depT_ $ opcs "turnoff" [(Xr, [])] []++ihold :: Monad m => DepT m ()+ihold = depT_ $ opcs "ihold" [(Xr, [])] []++linseg :: [E] -> E+linseg = opcs "linseg" [(Kr, repeat Ir)]++-- vco2++-- ares oscilikt xamp, xcps, kfn [, iphs] [, istor]+-- kres oscilikt kamp, kcps, kfn [, iphs] [, istor]+oscilikt :: E -> E -> E -> E+oscilikt amp cps fn = opcs "oscilikt" + [ (Ar, [Xr, Xr, Kr, Ir, Ir])+ , (Kr, [Kr, Kr, Kr, Ir, Ir])] + [amp, cps, fn]++-- ares oscili xamp, xcps, ifn [, iphs]+-- kres oscili kamp, kcps, ifn [, iphs]+oscili :: E -> E -> E -> E+oscili amp cps fn = opcs "oscili"+ [ (Ar, [Xr, Xr, Ir, Ir, Ir])+ , (Kr, [Kr, Kr, Ir, Ir, Ir])] + [amp, cps, fn]++-- kfn vco2ft kcps, iwave [, inyx]+vco2ft :: E -> E -> E+vco2ft cps iwave = opcs "vco2ft" [(Kr, [Kr, Ir, Ir])] [cps, iwave]++vco2ift :: E -> E -> E+vco2ift cps iwave = opcs "vco2ift" [(Kr, [Ir, Ir, Ir])] [cps, iwave]++ftgen :: E -> Gen -> E+ftgen n g = opcs "ftgen" [(Ir, repeat Ir)]+ $ [n, 0, int $ genSize g, int $ genId g]+ ++ (maybe [] (return . str) $ genFile g)+ ++ (fmap double $ genArgs g)++vco2init :: [E] -> E+vco2init = opcs "vco2init" [(Ir, repeat Ir)]+
+ src/Csound/Typed/GlobalState/Options.hs view
@@ -0,0 +1,119 @@+module Csound.Typed.GlobalState.Options (+ Options(..),+ defGain, defSampleRate, defBlockSize, defTabFi,+ -- ** Table fidelity+ TabFi(..), fineFi, coarseFi,+ -- *** Gen identifiers+ -- | Low level Csound integer identifiers for tables. These names can be used in the function 'Csound.Base.fineFi'+ idWavs, idMp3s, idDoubles, idSines, idSines3, idSines2,+ idPartials, idSines4, idBuzzes, idConsts, idLins, idCubes,+ idExps, idSplines, idStartEnds, idPolys, idChebs1, idChebs2, idBessels, idWins+) where++import Control.Applicative+import Data.Monoid+import Data.Default+import qualified Data.IntMap as IM++import Csound.Dynamic hiding (csdFlags)++-- | Csound options. The default values are+--+-- > flags = def -- the only flag set by default is "no-displays" +-- > -- to supress the display of the tables+-- > sampleRate = 44100+-- > blockSize = 64+-- > gain = 0.5+-- > tabFi = fineFi 13 [(idLins, 11), (idExps, 11), (idConsts, 9), (idSplines, 11), (idStartEnds, 12)] }+data Options = Options + { csdFlags :: Flags -- ^ Csound command line flags+ , csdSampleRate :: Maybe Int -- ^ The sample rate+ , csdBlockSize :: Maybe Int -- ^ The number of audio samples in one control step+ , csdGain :: Maybe Double -- ^ A gain of the final output+ , csdTabFi :: Maybe TabFi -- ^ Default fidelity of the arrays+ }+ +instance Default Options where+ def = Options def def def def def++instance Monoid Options where+ mempty = def+ mappend a b = Options+ { csdFlags = mappend (csdFlags a) (csdFlags b)+ , csdSampleRate = csdSampleRate a <|> csdSampleRate b+ , csdBlockSize = csdBlockSize a <|> csdBlockSize b+ , csdGain = csdGain a <|> csdGain b+ , csdTabFi = csdTabFi a <|> csdTabFi b }++defGain :: Options -> Double+defGain = maybe 0.5 id . csdGain++defSampleRate :: Options -> Int+defSampleRate = maybe 44100 id . csdSampleRate++defBlockSize :: Options -> Int+defBlockSize = maybe 64 id . csdBlockSize++defTabFi :: Options -> TabFi+defTabFi = maybe def id . csdTabFi+ +-- | Table size fidelity (how many points in the table by default).+data TabFi = TabFi+ { tabFiBase :: Int+ , tabFiGens :: IM.IntMap Int }++instance Default TabFi where+ def = fineFi 13 [(idLins, 11), (idExps, 11), (idConsts, 9), (idSplines, 11), (idStartEnds, 12)]+ ++-- | Sets different table size for different GEN-routines. +--+-- > fineFi n ps +--+-- where +-- +-- * @n@ is the default value for table size (size is a @n@ power of 2) for all gen routines that are not listed in the next argument @ps@.+--+-- * @ps@ is a list of pairs @(genRoutineId, tableSizeDegreeOf2)@ that sets the given table size for a +-- given GEN-routine.+--+-- with this function we can set lower table sizes for tables that are usually used in the envelopes.+fineFi :: Int -> [(Int, Int)] -> TabFi+fineFi n xs = TabFi n (IM.fromList xs)++-- | Sets the same table size for all tables. +--+-- > coarseFi n+--+-- where @n@ is a degree of 2. For example, @n = 10@ sets size to 1024 points for all tables by default.+coarseFi :: Int -> TabFi+coarseFi n = TabFi n IM.empty++idWavs, idMp3s, idDoubles, idSines, idSines3, idSines2,+ idPartials, idSines4, idBuzzes, idConsts, idLins, idCubes,+ idExps, idSplines, idStartEnds, idPolys, idChebs1, idChebs2, idBessels, idWins :: Int+++-- Human readable Csound identifiers for GEN-routines++idWavs = 1+idDoubles = 2+idSines = 10+idSines3 = 9+idSines2 = 9+idPartials = 9+idSines4 = 19+idBuzzes = 11+idConsts = 17+idLins = 7+idCubes = 6+idExps = 5+idStartEnds = 16+idSplines = 8 +idPolys = 3+idChebs1 = 13+idChebs2 = 14+idBessels = 12+idWins = 20+idMp3s = 49+
+ src/Csound/Typed/GlobalState/SE.hs view
@@ -0,0 +1,63 @@+module Csound.Typed.GlobalState.SE(+ SE(..), LocalHistory(..), + runSE, execSE, evalSE, execGEinSE, hideGEinDep, + fromDep, fromDep_, + newLocalVar, newLocalVars +) where++import Control.Applicative+import Control.Monad+import Control.Monad.Trans.Class++import Csound.Dynamic hiding (newLocalVar, newLocalVars)+import qualified Csound.Dynamic as D(newLocalVar, newLocalVars)+import Csound.Typed.GlobalState.GE++-- | The Csound's @IO@-monad. All values that produce side effects are wrapped+-- in the @SE@-monad.+newtype SE a = SE { unSE :: Dep a }++instance Functor SE where+ fmap f = SE . fmap f . unSE++instance Applicative SE where+ pure = return+ (<*>) = ap++instance Monad SE where+ return = SE . return+ ma >>= mf = SE $ unSE ma >>= unSE . mf++runSE :: SE a -> GE (a, LocalHistory)+runSE = runDepT . unSE++execSE :: SE () -> GE InstrBody+execSE a = execDepT $ unSE a++execGEinSE :: SE (GE a) -> SE a+execGEinSE (SE sa) = SE $ do+ ga <- sa+ a <- lift ga+ return a++hideGEinDep :: GE (Dep a) -> Dep a+hideGEinDep = join . lift++fromDep :: Dep a -> SE (GE a)+fromDep = fmap return . SE ++fromDep_ :: Dep () -> SE ()+fromDep_ = SE+ +evalSE :: SE a -> GE a+evalSE = fmap fst . runSE++----------------------------------------------------------------------+-- allocation of the local vars++newLocalVars :: [Rate] -> GE [E] -> SE [Var]+newLocalVars rs vs = SE $ D.newLocalVars rs vs++newLocalVar :: Rate -> GE E -> SE Var+newLocalVar rate val = SE $ D.newLocalVar rate val+
+ src/Csound/Typed/Render.hs view
@@ -0,0 +1,87 @@+module Csound.Typed.Render(+ renderOut, renderOutBy, + renderEff, renderEffBy,+ renderOut_, renderOutBy_, + -- * Options+ module Csound.Typed.GlobalState.Options,+ module Csound.Dynamic.Types.Flags+) where++import qualified Data.Map as M+import Data.Default+import Data.Maybe+import Data.Tuple+import Control.Monad++import Csound.Dynamic hiding (csdFlags)+import Csound.Typed.Types+import Csound.Typed.GlobalState+import Csound.Typed.GlobalState.Options+import Csound.Typed.Control.Instr+import Csound.Typed.Control(getIns)+import Csound.Dynamic.Types.Flags++toCsd :: Tuple a => Options -> SE a -> GE Csd+toCsd options sigs = do + saveMasterInstr (constArity sigs) (masterExp sigs)+ join $ withHistory $ renderHistory (outArity sigs) options++renderOut_ :: SE () -> IO String+renderOut_ = renderOutBy_ def ++renderOutBy_ :: Options -> SE () -> IO String+renderOutBy_ options sigs = evalGE options $ fmap renderCsd $ toCsd options (fmap (const unit) sigs)++renderOut :: Sigs a => SE a -> IO String+renderOut = renderOutBy def++renderOutBy :: Sigs a => Options -> SE a -> IO String+renderOutBy options sigs = evalGE options $ fmap renderCsd $ toCsd options sigs++renderEff :: (Sigs a, Sigs b) => (a -> SE b) -> IO String+renderEff = renderEffBy def++renderEffBy :: (Sigs a, Sigs b) => Options -> (a -> SE b) -> IO String+renderEffBy options eff = renderOutBy options $ eff =<< getIns++renderHistory :: Int -> Options -> History -> GE Csd+renderHistory nchnls opt hist = do+ instr0 <- execDepT $ getInstr0 nchnls opt hist+ let orc = Orc instr0 (fmap (uncurry Instr) $ instrsContent $ instrs hist) + return $ Csd flags orc sco+ where+ flags = reactOnMidi hist $ csdFlags opt+ sco = Sco (Just $ getTotalDur opt $ totalDur hist) + (renderGens $ genMap hist) $+ (fmap alwaysOn $ alwaysOnInstrs hist)++ renderGens = fmap swap . M.toList . idMapContent ++getInstr0 :: Int -> Options -> History -> Dep ()+getInstr0 nchnls opt hist = do+ globalConstants+ midiAssigns+ initGlobals+ renderBandLimited (genMap hist) (bandLimitedMap hist)+ userInstr0 hist+ chnUpdateUdo + where+ globalConstants = do+ setSr $ defSampleRate opt+ setKsmps $ defBlockSize opt+ setNchnls (max 1 nchnls)+ setZeroDbfs 1++ midiAssigns = mapM_ renderMidiAssign $ midis hist++ initGlobals = fst $ renderGlobals $ globals $ hist++reactOnMidi :: History -> Flags -> Flags+reactOnMidi h flags+ | midiIsActive h && midiDeviceIsEmpty flags = setMidiDevice flags+ | otherwise = flags+ where+ midiIsActive = not . null . midis+ midiDeviceIsEmpty = isNothing . midiDevice . midiRT+ setMidiDevice x = x { midiRT = (midiRT x) { midiDevice = Just "a" } }+
+ src/Csound/Typed/Types.hs view
@@ -0,0 +1,71 @@+module Csound.Typed.Types(+ -- * Primitives+ module Csound.Typed.Types.Prim,+ module Csound.Typed.Types.Lift,+ -- * Init values+ -- | In Csound we can supply an opcodes with initialization arguments.+ -- They are optional. To imitate this functionality in haskell we+ -- can use these functions.+ withInits, withDs, withSigs, withTabs, withD, withSig, withTab, withSeed,+ -- * Tuples+ module Csound.Typed.Types.Tuple, + -- * Events+ module Csound.Typed.Types.Evt+) where++import Control.Applicative+import qualified Csound.Dynamic as D++import Csound.Typed.Types.Prim+import Csound.Typed.Types.Tuple+import Csound.Typed.Types.Evt+import Csound.Typed.Types.Lift++import Csound.Typed.GlobalState(evalSE, SE)++-- appends inits++-- | Appends initialisation arguments. It's up to user to supply arguments with the right types. For example:+--+-- > oscil 0.5 440 sinWave `withInits` (0.5 :: D)+withInits :: (Val a, Tuple b) => a -> b -> a+withInits a b = genWithInits a (fromTuple b)++-- | A special case of @withInits@. Here all inits are numbers. +withDs :: Val a => a -> [D] -> a+withDs a ds = genWithInits a (mapM toGE ds)++-- | Appends an init value which is a number.+withD :: Val a => a -> D -> a+withD = withInits++-- | A special case of @withInits@. Here all inits are signals. +withSigs :: Val a => a -> [Sig] -> a+withSigs a sigs = genWithInits a (mapM toGE sigs)++-- | Appends an init value which is a signal.+withSig :: Val a => a -> Sig -> a+withSig = withInits++-- | A special case of @withInits@. Here all inits are arrays. +withTabs :: Val a => a -> [Tab] -> a+withTabs a tabs = genWithInits a (mapM toGE tabs)++-- | Appends an init value which is a table.+withTab :: Val a => a -> Tab -> a+withTab = withInits++-- | Applies a seed to the random value. +-- It's equivalent to the @withD@ but it has a special +-- meaning of canceling the side effect. When random+-- opcode is provided with seed value it's no longer+-- contains a side effect so we don't need to restrict it.+withSeed :: SE Sig -> D -> Sig+withSeed a d = hideGE $ evalSE $ fmap (flip withD d) a++genWithInits :: (Val a) => a -> GE [E] -> a+genWithInits a vals = fromGE $ liftA2 D.withInits (toGE a) vals++++
+ src/Csound/Typed/Types/Evt.hs view
@@ -0,0 +1,150 @@+{-# Language TypeFamilies, FlexibleContexts #-}+module Csound.Typed.Types.Evt(+ Evt(..), Bam, + boolToEvt, evtToBool, sigToEvt, stepper,+ filterE, filterSE, accumSE, accumE, filterAccumE, filterAccumSE,+ Snap, snapshot, snaps, readSnap+) where++import Data.Monoid++import Data.Boolean++import qualified Csound.Dynamic as C++import Csound.Typed.Types.Prim+import Csound.Typed.Types.Tuple+import Csound.Typed.GlobalState+import Csound.Typed.Control.SERef++-- | A stream of events. We can convert a stream of events to+-- the procedure with the function @runEvt@. It waits for events+-- and invokes the given procedure when the event happens.+data Evt a = Evt { runEvt :: Bam a -> SE () }++-- | A procedure. Something that takes a value and suddenly bams with it.+type Bam a = a -> SE ()++instance Functor Evt where+ fmap f a = Evt $ \bam -> runEvt a (bam . f) ++instance Monoid (Evt a) where+ mempty = Evt $ const $ return ()+ mappend a b = Evt $ \bam -> runEvt a bam >> runEvt b bam+ +-- | Converts booleans to events.+boolToEvt :: BoolSig -> Evt ()+boolToEvt b = Evt $ \bam -> when1 b $ bam ()++-- | Triggers an event when signal equals to 1.+sigToEvt :: Sig -> Evt ()+sigToEvt = boolToEvt . ( ==* 1) . kr++-- | Filters events with predicate.+filterE :: (a -> BoolD) -> Evt a -> Evt a+filterE pr evt = Evt $ \bam -> runEvt evt $ \a ->+ when1 (boolSig $ pr a) $ bam a++-- | Filters events with effectful predicate.+filterSE :: (a -> SE BoolD) -> Evt a -> Evt a+filterSE mpr evt = Evt $ \bam -> runEvt evt $ \a -> do+ pr <- mpr a+ when1 (boolSig pr) $ bam a ++-- | Accumulator for events with side effects.+accumSE :: (Tuple s) => s -> (a -> s -> SE (b, s)) -> Evt a -> Evt b+accumSE s0 update evt = Evt $ \bam -> do+ (readSt, writeSt) <- sensorsSE s0+ runEvt evt $ \a -> do+ s1 <- readSt+ (b, s2) <- update a s1+ bam b+ writeSt s2++-- | Accumulator for events.+accumE :: (Tuple s) => s -> (a -> s -> (b, s)) -> Evt a -> Evt b+accumE s0 update = accumSE s0 (\a s -> return $ update a s)++-- | Accumulator for events with side effects and filtering. Event triggers+-- only if the first element in the tripplet is true.+filterAccumSE :: (Tuple s) => s -> (a -> s -> SE (BoolD, b, s)) -> Evt a -> Evt b+filterAccumSE s0 update evt = Evt $ \bam -> do+ (readSt, writeSt) <- sensorsSE s0+ runEvt evt $ \a -> do+ s1 <- readSt+ (isOn, b, s2) <- update a s1+ when1 (boolSig isOn) $ bam b+ writeSt s2++-- | Accumulator with filtering. It can skip the events from the event stream.+-- If the third element of the triple equals to 1 then we should include the+-- event in the resulting stream. If the element equals to 0 we skip the event.+filterAccumE :: (Tuple s) => s -> (a -> s -> (BoolD, b, s)) -> Evt a -> Evt b+filterAccumE s0 update = filterAccumSE s0 $ \a s -> return $ update a s++-- | Get values of some signal at the given events.+snapshot :: (Tuple a, Tuple (Snap a)) => (Snap a -> b -> c) -> a -> Evt b -> Evt c+snapshot f asig evt = Evt $ \bam -> runEvt evt $ \a -> + bam (f (readSnap asig) a)++readSnap :: (Tuple (Snap a), Tuple a) => a -> Snap a+readSnap = toTuple . fromTuple++-- | Constructs an event stream that contains values from the+-- given signal. Events happens only when the signal changes.+snaps :: Sig -> Evt D+snaps asig = snapshot const asig trigger+ where + trigger = sigToEvt $ fromGE $ fmap changed $ toGE asig+ changed x = C.opcs "changed" [(C.Kr, [C.Kr])] [x]++-------------------------------------------------------------------+-- snap ++-- | A snapshot of the signal. It converts a type of the signal to the +-- type of the value in the given moment. Instances:+--+--+-- > type instance Snap D = D+-- > type instance Snap Str = Str+-- > type instance Snap Tab = Tab+-- >+-- > type instance Snap Sig = D+-- > +-- > type instance Snap (a, b) = (Snap a, Snap b)+-- > type instance Snap (a, b, c) = (Snap a, Snap b, Snap c)+-- > type instance Snap (a, b, c, d) = (Snap a, Snap b, Snap c, Snap d)+-- > type instance Snap (a, b, c, d, e) = (Snap a, Snap b, Snap c, Snap d, Snap e)+-- > type instance Snap (a, b, c, d, e, f) = (Snap a, Snap b, Snap c, Snap d, Snap e, Snap f)+type family Snap a :: *++type instance Snap D = D+type instance Snap Str = Str+type instance Snap Tab = Tab++type instance Snap Sig = D++type instance Snap (a, b) = (Snap a, Snap b)+type instance Snap (a, b, c) = (Snap a, Snap b, Snap c)+type instance Snap (a, b, c, d) = (Snap a, Snap b, Snap c, Snap d)+type instance Snap (a, b, c, d, e) = (Snap a, Snap b, Snap c, Snap d, Snap e)+type instance Snap (a, b, c, d, e, f) = (Snap a, Snap b, Snap c, Snap d, Snap e, Snap f)++-- | Converts an event to boolean signal. It forgets+-- everything about the event values. Signal equals to one when +-- 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+ 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 +
+ src/Csound/Typed/Types/Lift.hs view
@@ -0,0 +1,240 @@+{-# Language FlexibleInstances #-}+module Csound.Typed.Types.Lift(+ GE, E,+ -- * Lifters+ -- ** Pure single+ PureSingle, pureSingle,++ -- ** Dirty single+ DirtySingle, dirtySingle,++ -- ** Procedure+ Procedure, procedure,++ -- ** Pure multi + PureMulti, Pm, fromPm, pureMulti,++ -- ** Dirty multi+ DirtyMulti, Dm, fromDm, dirtyMulti+ +) where++import Control.Applicative++import Csound.Dynamic+import Csound.Typed.Types.Prim+import Csound.Typed.Types.Tuple+import Csound.Typed.GlobalState+ +pureSingle :: PureSingle a => ([E] -> E) -> a+pureSingle = pureSingleGE . return+ +dirtySingle :: DirtySingle a => ([E] -> Dep E) -> a+dirtySingle = dirtySingleGE . return+ +procedure :: Procedure a => ([E] -> Dep ()) -> a+procedure = procedureGE . return++newtype Pm = Pm (GE (MultiOut [E]))++pureMulti :: PureMulti a => ([E] -> MultiOut [E]) -> a+pureMulti = pureMultiGE . return++newtype Dm = Dm (GE (MultiOut (Dep [E])))++dirtyMulti :: DirtyMulti a => ([E] -> MultiOut (Dep [E])) -> a+dirtyMulti = dirtyMultiGE . return++class PureSingle a where+ pureSingleGE :: GE ([E] -> E) -> a++class DirtySingle a where+ dirtySingleGE :: GE ([E] -> Dep E) -> a++class Procedure a where+ procedureGE :: GE ([E] -> Dep ()) -> a+ +class PureMulti a where+ pureMultiGE :: GE ([E] -> MultiOut [E]) -> a+ +class DirtyMulti a where+ dirtyMultiGE :: GE ([E] -> MultiOut (Dep [E])) -> a++-- multi out helpers++fromPm :: Tuple a => Pm -> a+fromPm (Pm a) = res+ where res = toTuple $ fmap ( $ tupleArity res) a++fromDm :: Tuple a => Dm -> SE a+fromDm (Dm a) = res+ where + res = fmap toTuple $ fromDep $ hideGEinDep $ fmap ( $ (tupleArity $ proxy res)) a++ proxy :: SE a -> a+ proxy = const undefined++-- pure single++instance PureSingle (GE E) where+ pureSingleGE = fmap ($ [])++instance PureSingle b => PureSingle (GE E -> b) where+ pureSingleGE mf = \ma -> pureSingleGE $ (\f a as -> f (a:as)) <$> mf <*> ma++instance PureSingle b => PureSingle (GE [E] -> b) where+ pureSingleGE mf = \mas -> pureSingleGE $ (\f as bs -> f (as ++ bs)) <$> mf <*> mas+ +ps0 :: (Val a) => GE ([E] -> E) -> a+ps0 = fromGE . pureSingleGE++ps1 :: (Val a, PureSingle b) => GE ([E] -> E) -> (a -> b)+ps1 f = pureSingleGE f . toGE++pss :: (Val a, PureSingle b) => GE ([E] -> E) -> ([a] -> b)+pss f = pureSingleGE f . mapM toGE++instance PureSingle Sig where pureSingleGE = ps0+instance PureSingle D where pureSingleGE = ps0+instance PureSingle Str where pureSingleGE = ps0+instance PureSingle Tab where pureSingleGE = ps0+instance PureSingle Spec where pureSingleGE = ps0+instance PureSingle Wspec where pureSingleGE = ps0++instance (PureSingle b) => PureSingle (Sig -> b) where pureSingleGE = ps1+instance (PureSingle b) => PureSingle (D -> b) where pureSingleGE = ps1+instance (PureSingle b) => PureSingle (Str -> b) where pureSingleGE = ps1+instance (PureSingle b) => PureSingle (Tab -> b) where pureSingleGE = ps1+instance (PureSingle b) => PureSingle (Spec -> b) where pureSingleGE = ps1+instance (PureSingle b) => PureSingle (Wspec -> b) where pureSingleGE = ps1++instance (PureSingle b) => PureSingle ([Sig] -> b) where pureSingleGE = pss+instance (PureSingle b) => PureSingle ([D] -> b) where pureSingleGE = pss++instance (PureSingle b) => PureSingle (Msg -> b) where pureSingleGE f = const $ pureSingleGE f++-- dirty single++instance DirtySingle (SE (GE E)) where+ dirtySingleGE = fromDep . hideGEinDep . fmap ($ [])+ +instance DirtySingle b => DirtySingle (GE E -> b) where+ dirtySingleGE mf = \ma -> dirtySingleGE $ (\f a as -> f (a:as)) <$> mf <*> ma+ +instance DirtySingle b => DirtySingle (GE [E] -> b) where+ dirtySingleGE mf = \mas -> dirtySingleGE $ (\f as bs -> f (as ++ bs)) <$> mf <*> mas++ds0 :: (Val a) => GE ([E] -> Dep E) -> SE a+ds0 = fmap fromGE . dirtySingleGE++ds1 :: (Val a, DirtySingle b) => GE ([E] -> Dep E) -> (a -> b)+ds1 f = dirtySingleGE f . toGE++dss :: (Val a, DirtySingle b) => GE ([E] -> Dep E) -> ([a] -> b)+dss f = dirtySingleGE f . mapM toGE++instance DirtySingle (SE Sig) where dirtySingleGE = ds0+instance DirtySingle (SE D) where dirtySingleGE = ds0+instance DirtySingle (SE Str) where dirtySingleGE = ds0+instance DirtySingle (SE Tab) where dirtySingleGE = ds0+instance DirtySingle (SE Spec) where dirtySingleGE = ds0+instance DirtySingle (SE Wspec) where dirtySingleGE = ds0++instance (DirtySingle b) => DirtySingle (Sig -> b) where dirtySingleGE = ds1+instance (DirtySingle b) => DirtySingle (D -> b) where dirtySingleGE = ds1+instance (DirtySingle b) => DirtySingle (Str -> b) where dirtySingleGE = ds1+instance (DirtySingle b) => DirtySingle (Tab -> b) where dirtySingleGE = ds1+instance (DirtySingle b) => DirtySingle (Spec -> b) where dirtySingleGE = ds1+instance (DirtySingle b) => DirtySingle (Wspec -> b) where dirtySingleGE = ds1++instance (DirtySingle b) => DirtySingle ([Sig] -> b) where dirtySingleGE = dss+instance (DirtySingle b) => DirtySingle ([D] -> b) where dirtySingleGE = dss++instance (DirtySingle b) => DirtySingle (Msg -> b) where dirtySingleGE f = const $ dirtySingleGE f++-- procedure++instance Procedure (SE ()) where+ procedureGE = fromDep_ . hideGEinDep . fmap ($ [])++instance Procedure b => Procedure (GE E -> b) where+ procedureGE mf = \ma -> procedureGE $ (\f a as -> f (a:as)) <$> mf <*> ma+ +instance Procedure b => Procedure (GE [E] -> b) where+ procedureGE mf = \mas -> procedureGE $ (\f as bs -> f (as ++ bs)) <$> mf <*> mas+ +pr1 :: (Val a, Procedure b) => GE ([E] -> Dep ()) -> a -> b+pr1 f = procedureGE f . toGE++prs :: (Val a, Procedure b) => GE ([E] -> Dep ()) -> ([a] -> b)+prs f = procedureGE f . mapM toGE++instance (Procedure b) => Procedure (Sig -> b) where procedureGE = pr1+instance (Procedure b) => Procedure (D -> b) where procedureGE = pr1+instance (Procedure b) => Procedure (Str -> b) where procedureGE = pr1+instance (Procedure b) => Procedure (Tab -> b) where procedureGE = pr1+instance (Procedure b) => Procedure (Spec -> b) where procedureGE = pr1+instance (Procedure b) => Procedure (Wspec -> b) where procedureGE = pr1++instance (Procedure b) => Procedure ([Sig] -> b) where procedureGE = prs+instance (Procedure b) => Procedure ([D] -> b) where procedureGE = prs++instance (Procedure b) => Procedure (Msg -> b) where procedureGE f = const $ procedureGE f++-- pure multi++instance PureMulti Pm where+ pureMultiGE = Pm . fmap ($ [])++instance PureMulti b => PureMulti (GE E -> b) where+ pureMultiGE mf = \ma -> pureMultiGE $ (\f a as -> f (a:as)) <$> mf <*> ma+ +instance PureMulti b => PureMulti (GE [E] -> b) where+ pureMultiGE mf = \mas -> pureMultiGE $ (\f as bs -> f (as ++ bs)) <$> mf <*> mas++pm1 :: (Val a, PureMulti b) => GE ([E] -> MultiOut [E]) -> (a -> b)+pm1 f = pureMultiGE f . toGE++pms :: (Val a, PureMulti b) => GE ([E] -> MultiOut [E]) -> ([a] -> b)+pms f = pureMultiGE f . mapM toGE ++instance (PureMulti b) => PureMulti (Sig -> b) where pureMultiGE = pm1+instance (PureMulti b) => PureMulti (D -> b) where pureMultiGE = pm1+instance (PureMulti b) => PureMulti (Str -> b) where pureMultiGE = pm1+instance (PureMulti b) => PureMulti (Tab -> b) where pureMultiGE = pm1+instance (PureMulti b) => PureMulti (Spec -> b) where pureMultiGE = pm1+instance (PureMulti b) => PureMulti (Wspec -> b) where pureMultiGE = pm1++instance (PureMulti b) => PureMulti ([Sig] -> b) where pureMultiGE = pms+instance (PureMulti b) => PureMulti ([D] -> b) where pureMultiGE = pms++instance (PureMulti b) => PureMulti (Msg -> b) where pureMultiGE f = const $ pureMultiGE f++-- dirty multi++instance DirtyMulti Dm where+ dirtyMultiGE = Dm . fmap ($ [])++instance DirtyMulti b => DirtyMulti (GE E -> b) where+ dirtyMultiGE mf = \ma -> dirtyMultiGE $ (\f a as -> f (a:as)) <$> mf <*> ma++instance DirtyMulti b => DirtyMulti (GE [E] -> b) where+ dirtyMultiGE mf = \mas -> dirtyMultiGE $ (\f as bs -> f (as ++ bs)) <$> mf <*> mas++dm1 :: (Val a, DirtyMulti b) => GE ([E] -> MultiOut (Dep [E])) -> (a -> b)+dm1 f = dirtyMultiGE f . toGE++dms :: (Val a, DirtyMulti b) => GE ([E] -> MultiOut (Dep [E])) -> ([a] -> b)+dms f = dirtyMultiGE f . mapM toGE++instance (DirtyMulti b) => DirtyMulti (Sig -> b) where dirtyMultiGE = dm1+instance (DirtyMulti b) => DirtyMulti (D -> b) where dirtyMultiGE = dm1+instance (DirtyMulti b) => DirtyMulti (Str -> b) where dirtyMultiGE = dm1+instance (DirtyMulti b) => DirtyMulti (Tab -> b) where dirtyMultiGE = dm1+instance (DirtyMulti b) => DirtyMulti (Spec -> b) where dirtyMultiGE = dm1+instance (DirtyMulti b) => DirtyMulti (Wspec -> b) where dirtyMultiGE = dm1++instance (DirtyMulti b) => DirtyMulti ([Sig] -> b) where dirtyMultiGE = dms+instance (DirtyMulti b) => DirtyMulti ([D] -> b) where dirtyMultiGE = dms++instance (DirtyMulti b) => DirtyMulti (Msg -> b) where dirtyMultiGE f = const $ dirtyMultiGE f
+ src/Csound/Typed/Types/MixSco.hs view
@@ -0,0 +1,76 @@+module Csound.Typed.Types.MixSco(+ M(..), delayAndRescaleCsdEventListM, renderMixSco, renderMixSco_+) where++import Control.Monad++import Csound.Dynamic+import Csound.Typed.GlobalState.Elements++data M + = Snd InstrId (CsdEventList [E])+ | Eff InstrId (CsdEventList M) Int ++delayAndRescaleCsdEventListM :: CsdEventList M -> CsdEventList M+delayAndRescaleCsdEventListM = delayCsdEventListM . rescaleCsdEventListM++delayCsdEventListM :: CsdEventList M -> CsdEventList M+delayCsdEventListM es = + es { csdEventListNotes = fmap delayCsdEventM $ csdEventListNotes es }++delayCsdEventM :: CsdEvent M -> CsdEvent M+delayCsdEventM (start, dur, evt) = (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 }++rescaleCsdEventM :: CsdEvent M -> CsdEvent M+rescaleCsdEventM (start, dur, evt) = (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+ where localDur = case x of+ Snd _ evts -> csdEventListDur evts+ Eff _ evts _ -> csdEventListDur evts++renderMixSco :: Monad m => Int -> CsdEventList M -> DepT m [E]+renderMixSco arity evts = do+ chnId <- chnRefAlloc arity+ go chnId evts+ readChn chnId+ where + go :: Monad m => ChnRef -> CsdEventList M -> DepT m ()+ go outId xs = mapM_ (onEvent outId) $ csdEventListNotes xs++ 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++ onSnd instrId outId es = forM_ (csdEventListNotes es) $ \(start, dur, args) ->+ event_i $ Event instrId (double start) (double dur) (args ++ [chnRefId outId])++ onEff 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++renderMixSco_ :: Monad m => CsdEventList M -> DepT m ()+renderMixSco_ evts = mapM_ onEvent $ csdEventListNotes evts+ where+ onEvent :: Monad m => CsdEvent M -> DepT m ()+ 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++ onEff instrId start dur es = do+ event_i $ Event instrId (double start) (double dur) []+ renderMixSco_ es+
+ src/Csound/Typed/Types/Prim.hs view
@@ -0,0 +1,412 @@+{-# Language TypeFamilies #-}+module Csound.Typed.Types.Prim(+ Sig(..), D(..), Tab(..), unTab, Str(..), Spec(..), Wspec(..), + BoolSig(..), BoolD(..), Unit(..), unit, Val(..), hideGE, SigOrD,++ -- ** Tables+ preTab, TabSize(..), TabArgs(..), updateTabSize,+ fromPreTab, getPreTabUnsafe, skipNorm, forceNorm,++ -- ** constructors+ double, int, text, + + -- ** constants+ idur, getSampleRate, getControlRate, getBlockSize, getZeroDbfs,++ -- ** converters+ ar, kr, ir, sig,++ -- ** lifters+ on0, on1, on2, on3,++ -- ** numeric funs+ quot', rem', div', mod', ceil', floor', round', int', frac',+ + -- ** logic funs+ when1, whens, boolSig+) where++import Control.Applicative hiding ((<*))+import Control.Monad+import Control.Monad.Trans.Class+import Data.Monoid+import qualified Data.IntMap as IM++import Data.Default+import Data.Boolean++import Csound.Dynamic hiding (double, int, str, when1, whens, ifBegin, ifEnd, elseBegin, elseIfBegin)+import qualified Csound.Dynamic as D(double, int, str, ifBegin, ifEnd, elseBegin, elseIfBegin)+import Csound.Typed.GlobalState++-- | Signals+newtype Sig = Sig { unSig :: GE E }++-- | Constant numbers+newtype D = D { unD :: GE E }++-- | Strings+newtype Str = Str { unStr :: GE E }++-- | Spectrum. It's @fsig@ in the Csound.+newtype Spec = Spec { unSpec :: GE E }++-- | Another type for spectrum. It's @wsig@ in the Csound.+newtype Wspec = Wspec { unWspec :: GE E }++-- Booleans++-- | A signal of booleans.+newtype BoolSig = BoolSig { unBoolSig :: GE E }++-- | A constant boolean value.+newtype BoolD = BoolD { unBoolD :: GE E }++type instance BooleanOf Sig = BoolSig++type instance BooleanOf D = BoolD+type instance BooleanOf Str = BoolD+type instance BooleanOf Tab = BoolD+type instance BooleanOf Spec = BoolD++-- Procedures++-- | Csound's empty tuple.+newtype Unit = Unit { unUnit :: GE () } ++-- | Constructs Csound's empty tuple.+unit :: Unit+unit = Unit $ return ()++instance Monoid Unit where+ mempty = Unit (return ())+ mappend a b = Unit $ (unUnit a) >> (unUnit b)++-- tables++-- | Tables (or arrays)+data Tab + = Tab (GE E)+ | TabPre PreTab++preTab :: TabSize -> Int -> TabArgs -> Tab+preTab size gen args = TabPre $ PreTab size gen args++data PreTab = PreTab+ { preTabSize :: TabSize+ , preTabGen :: Int+ , preTabArgs :: TabArgs }++-- Table size.+data TabSize + -- Size is fixed by the user.+ = SizePlain Int+ -- Size is relative to the renderer settings.+ | SizeDegree + { hasGuardPoint :: Bool+ , sizeDegree :: Int -- is the power of two+ }++instance Default TabSize where+ def = SizeDegree+ { hasGuardPoint = False+ , sizeDegree = 0 }+ +-- Table arguments can be+data TabArgs + -- absolute+ = ArgsPlain [Double]+ -- or relative to the table size (used for tables that implement interpolation)+ | ArgsRelative [Double]+ -- GEN 16 uses unusual interpolation scheme, so we need a special case+ | ArgsGen16 [Double]+ | FileAccess String [Double]++renderTab :: PreTab -> GE E+renderTab a = saveGen =<< fromPreTab a ++getPreTabUnsafe :: String -> Tab -> PreTab+getPreTabUnsafe msg x = case x of+ TabPre a -> a+ _ -> error msg++fromPreTab :: PreTab -> GE Gen+fromPreTab a = withOptions $ \opt -> go (defTabFi opt) a+ where+ go :: TabFi -> PreTab -> Gen+ go tabFi tab = Gen size (preTabGen tab) args file+ where size = defineTabSize (getTabSizeBase tabFi tab) (preTabSize tab)+ (args, file) = defineTabArgs size (preTabArgs tab)++getTabSizeBase :: TabFi -> PreTab -> Int+getTabSizeBase tf tab = IM.findWithDefault (tabFiBase tf) (preTabGen tab) (tabFiGens tf)++defineTabSize :: Int -> TabSize -> Int+defineTabSize base x = case x of+ SizePlain n -> n+ SizeDegree guardPoint degree -> + byGuardPoint guardPoint $+ byDegree base degree+ where byGuardPoint guardPoint + | guardPoint = (+ 1)+ | otherwise = id+ + byDegree zero n = 2 ^ max 0 (zero + n) ++defineTabArgs :: Int -> TabArgs -> ([Double], Maybe String)+defineTabArgs size args = case args of+ ArgsPlain as -> (as, Nothing)+ ArgsRelative as -> (fromRelative size as, Nothing)+ ArgsGen16 as -> (formRelativeGen16 size as, Nothing)+ FileAccess filename as -> (as, Just filename)+ where fromRelative n as = substEvens (mkRelative n $ getEvens as) as+ getEvens xs = case xs of+ [] -> []+ _:[] -> []+ _:b:as -> b : getEvens as+ + substEvens evens xs = case (evens, xs) of+ ([], as) -> as+ (_, []) -> []+ (e:es, a:_:as) -> a : e : substEvens es as+ _ -> error "table argument list should contain even number of elements"+ + mkRelative n as = fmap ((fromIntegral :: (Int -> Double)) . round . (s * )) as+ where s = fromIntegral n / sum as+ + -- special case. subst relatives for Gen16+ formRelativeGen16 n as = substGen16 (mkRelative n $ getGen16 as) as++ getGen16 xs = case xs of+ _:durN:_:rest -> durN : getGen16 rest+ _ -> xs++ substGen16 durs xs = case (durs, xs) of + ([], as) -> as+ (_, []) -> []+ (d:ds, valN:_:typeN:rest) -> valN : d : (typeN * d) : substGen16 ds rest+ (_, _) -> xs++-- | Skips normalization (sets table size to negative value)+skipNorm :: Tab -> Tab+skipNorm x = case x of+ Tab _ -> error "you can skip normalization only for primitive tables (made with gen-routines)"+ TabPre a -> TabPre $ a{ preTabGen = negate $ abs $ preTabGen a }++-- | Force normalization (sets table size to positive value).+-- Might be useful to restore normalization for table 'Csound.Tab.doubles'.+forceNorm :: Tab -> Tab+forceNorm x = case x of+ Tab _ -> error "you can force normalization only for primitive tables (made with gen-routines)"+ TabPre a -> TabPre $ a{ preTabGen = abs $ preTabGen a }++----------------------------------------------------------------------------+-- change table size++updateTabSize :: (TabSize -> TabSize) -> Tab -> Tab+updateTabSize phi x = case x of+ Tab _ -> error "you can change size only for primitive tables (made with gen-routines)"+ TabPre a -> TabPre $ a{ preTabSize = phi $ preTabSize a }++-------------------------------------------------------------------------------+-- constructors++-- | Constructs a number.+double :: Double -> D+double = fromE . D.double++-- | Constructs an integer.+int :: Int -> D+int = fromE . D.int++-- | Constructs a string.+text :: String -> Str+text = fromE . D.str++-------------------------------------------------------------------------------+-- constants++-- | Querries a total duration of the note. It's equivallent to Csound's @p3@ field.+idur :: D +idur = fromE $ pn 3++getSampleRate :: D+getSampleRate = fromE $ readOnlyVar (VarVerbatim Ir "sr")++getControlRate :: D+getControlRate = fromE $ readOnlyVar (VarVerbatim Ir "kr")++getBlockSize :: D+getBlockSize = fromE $ readOnlyVar (VarVerbatim Ir "ksmps")++getZeroDbfs :: D+getZeroDbfs = fromE $ readOnlyVar (VarVerbatim Ir "0dbfs")++-------------------------------------------------------------------------------+-- converters++-- | Sets a rate of the signal to audio rate.+ar :: Sig -> Sig+ar = on1 $ setRate Ar++-- | Sets a rate of the signal to control rate.+kr :: Sig -> Sig+kr = on1 $ setRate Kr++-- | Converts a signal to the number (initial value of the signal).+ir :: Sig -> D+ir = on1 $ setRate Ir++-- | Makes a constant signal from the number.+sig :: D -> Sig+sig = on1 $ setRate Kr++-------------------------------------------------------------------------------+-- single wrapper++-- | Contains all Csound values.+class Val a where+ fromGE :: GE E -> a+ toGE :: a -> GE E++ fromE :: E -> a+ fromE = fromGE . return++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 Str where { fromGE = Str ; toGE = unStr }+instance Val Spec where { fromGE = Spec ; toGE = unSpec }+instance Val Wspec where { fromGE = Wspec ; toGE = unWspec}++instance Val Tab where + fromGE = Tab + toGE = unTab++unTab :: Tab -> GE E+unTab x = case x of+ Tab a -> a+ TabPre a -> renderTab a++instance Val BoolSig where { fromGE = BoolSig ; toGE = unBoolSig }+instance Val BoolD where { fromGE = BoolD ; toGE = unBoolD }++class Val a => SigOrD a where++instance SigOrD Sig where+instance SigOrD D where++on0 :: Val a => E -> a+on0 = fromE++on1 :: (Val a, Val b) => (E -> E) -> (a -> b)+on1 f a = fromGE $ fmap f $ toGE a++on2 :: (Val a, Val b, Val c) => (E -> E -> E) -> (a -> b -> c)+on2 f a b = fromGE $ liftA2 f (toGE a) (toGE b)++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)++-------------------------------------------------------------------------------+-- defaults++instance Default Sig where def = 0+instance Default D where def = 0+instance Default Tab where def = fromE 0+instance Default Str where def = text ""+instance Default Spec where def = fromE 0 ++-------------------------------------------------------------------------------+-- monoid++instance Monoid Sig where { mempty = on0 mempty ; mappend = on2 mappend }+instance Monoid D where { mempty = on0 mempty ; mappend = on2 mappend }++-------------------------------------------------------------------------------+-- numeric++instance Num Sig where + { (+) = on2 (+); (*) = on2 (*); negate = on1 negate; (-) = on2 (\a b -> a - b) + ; fromInteger = on0 . fromInteger; abs = on1 abs; signum = on1 signum }++instance Num D where + { (+) = on2 (+); (*) = on2 (*); negate = on1 negate; (-) = on2 (\a b -> a - b) + ; fromInteger = on0 . fromInteger; abs = on1 abs; signum = on1 signum }++instance Fractional Sig where { (/) = on2 (/); fromRational = on0 . fromRational }+instance Fractional D where { (/) = on2 (/); fromRational = on0 . 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 }++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 }++ceil', floor', frac', 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++-------------------------------------------------------------------------------+-- 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 (||*) }++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++instance EqB Sig where { (==*) = on2 (==*); (/=*) = on2 (/=*) }+instance EqB D where { (==*) = on2 (==*); (/=*) = on2 (/=*) }++instance OrdB Sig where { (<*) = on2 (<*) ; (>*) = on2 (>*); (<=*) = on2 (<=*); (>=*) = on2 (>=*) }+instance OrdB D where { (<*) = on2 (<*) ; (>*) = on2 (>*); (<=*) = on2 (<=*); (>=*) = on2 (>=*) }++-- | Invokes the given procedure if the boolean signal is true.+when1 :: BoolSig -> SE () -> SE ()+when1 p body = do+ ifBegin p+ 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.+whens :: [(BoolSig, SE ())] -> SE () -> SE ()+whens bodies el = case bodies of+ [] -> el+ a:as -> do+ ifBegin (fst a)+ snd a+ elseIfs as+ elseBegin + el+ ifEnd+ where elseIfs = mapM_ (\(p, body) -> elseIfBegin p >> body)++ifBegin :: BoolSig -> SE ()+ifBegin a = fromDep_ $ D.ifBegin =<< lift (toGE a)++ifEnd :: SE ()+ifEnd = fromDep_ D.ifEnd++elseBegin :: SE ()+elseBegin = fromDep_ D.elseBegin++elseIfBegin :: BoolSig -> SE ()+elseIfBegin a = fromDep_ $ D.elseIfBegin =<< lift (toGE a)++-- | Creates a constant boolean signal.+boolSig :: BoolD -> BoolSig+boolSig = fromGE . toGE+
+ src/Csound/Typed/Types/Tuple.hs view
@@ -0,0 +1,278 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# Language + TypeFamilies,+ FlexibleContexts,+ FlexibleInstances #-}+module Csound.Typed.Types.Tuple(+ -- ** Tuple+ Tuple(..), TupleMethods, makeTupleMethods, + fromTuple, toTuple, tupleArity, tupleRates, defTuple,++ -- ** Outs+ Sigs, outArity, ++ -- *** Multiple outs+ multiOuts,+ ar1, ar2, ar4, ar6, ar8,++ -- ** Arguments+ Arg, arg, toNote, argArity, toArg,++ -- ** Logic functions+ ifTuple, guardedTuple, caseTuple,+ ifArg, guardedArg, caseArg,++ -- ** Constructors+ pureTuple, dirtyTuple+) where+++import Control.Arrow+import Control.Applicative+import Control.Monad+import Control.Monad.Trans.Class+import Data.Default+import Data.Boolean++import Csound.Dynamic+import Csound.Typed.Types.Prim+import Csound.Typed.GlobalState+import Csound.Typed.Types.TupleHelpers++-- | A tuple of Csound values.+class Tuple a where+ tupleMethods :: TupleMethods a++data TupleMethods a = TupleMethods+ { fromTuple_ :: a -> GE [E]+ , toTuple_ :: GE [E] -> a+ , tupleArity_ :: a -> Int+ , tupleRates_ :: a -> [Rate]+ , defTuple_ :: a }++fromTuple :: Tuple a => a -> GE [E] +fromTuple = fromTuple_ tupleMethods++toTuple :: Tuple a => GE [E] -> a+toTuple = toTuple_ tupleMethods++tupleArity :: Tuple a => a -> Int+tupleArity = tupleArity_ tupleMethods++tupleRates :: Tuple a => a -> [Rate]+tupleRates = tupleRates_ tupleMethods++defTuple :: Tuple a => a+defTuple = defTuple_ tupleMethods++-- | 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+makeTupleMethods to from = TupleMethods + { fromTuple_ = fromTuple . from+ , toTuple_ = to . toTuple + , tupleArity_ = const $ tupleArity $ proxy to+ , tupleRates_ = tupleRates . from+ , defTuple_ = to defTuple }+ where proxy :: (a -> b) -> a+ proxy = undefined++-- Tuple instances++primTupleMethods :: (Val a, Default a) => Rate -> TupleMethods a+primTupleMethods rate = TupleMethods + { fromTuple_ = fmap return . toGE+ , toTuple_ = fromGE . fmap head+ , tupleArity_ = const 1+ , tupleRates_ = const [rate]+ , defTuple_ = def }++instance Tuple Unit where+ tupleMethods = TupleMethods + { fromTuple_ = \x -> unUnit x >> (return [])+ , toTuple_ = \es -> Unit $ es >> return ()+ , tupleArity_ = const 0+ , tupleRates_ = const []+ , defTuple_ = Unit $ return () }++instance Tuple Sig where tupleMethods = primTupleMethods Ar +instance Tuple D where tupleMethods = primTupleMethods Kr+instance Tuple Tab where tupleMethods = primTupleMethods Kr+instance Tuple Str where tupleMethods = primTupleMethods Sr+instance Tuple Spec where tupleMethods = primTupleMethods Fr++instance (Tuple a, Tuple b) => Tuple (a, b) where + tupleMethods = TupleMethods fromTuple' toTuple' tupleArity' tupleRates' defTuple'+ where + fromTuple' (a, b) = liftA2 (++) (fromTuple a) (fromTuple b)+ tupleArity' x = let (a, b) = proxy x in tupleArity a + tupleArity b+ where proxy :: (a, b) -> (a, b)+ proxy = const (undefined, undefined) + toTuple' xs = (a, b)+ where a = toTuple $ fmap (take (tupleArity a)) xs+ xsb = fmap (drop (tupleArity a)) xs + b = toTuple $ fmap (take (tupleArity b)) xsb++ tupleRates' (a, b) = tupleRates a ++ tupleRates b+ defTuple' = (defTuple, defTuple)++instance (Tuple a, Tuple b, Tuple c) => Tuple (a, b, c) where tupleMethods = makeTupleMethods cons3 split3+instance (Tuple a, Tuple b, Tuple c, Tuple d) => Tuple (a, b, c, d) where tupleMethods = makeTupleMethods cons4 split4+instance (Tuple a, Tuple b, Tuple c, Tuple d, Tuple e) => Tuple (a, b, c, d, e) where tupleMethods = makeTupleMethods cons5 split5+instance (Tuple a, Tuple b, Tuple c, Tuple d, Tuple e, Tuple f) => Tuple (a, b, c, d, e, f) where tupleMethods = makeTupleMethods cons6 split6+instance (Tuple a, Tuple b, Tuple c, Tuple d, Tuple e, Tuple f, Tuple g) => Tuple (a, b, c, d, e, f, g) where tupleMethods = makeTupleMethods cons7 split7+instance (Tuple a, Tuple b, Tuple c, Tuple d, Tuple e, Tuple f, Tuple g, Tuple h) => Tuple (a, b, c, d, e, f, g, h) where tupleMethods = makeTupleMethods cons8 split8++-------------------------------------------------------------------------------+-- multiple outs++multiOuts :: Tuple a => E -> a+multiOuts expr = res+ where res = toTuple $ return $ mo (tupleArity res) expr++ar1 :: Sig -> Sig+ar2 :: (Sig, Sig) -> (Sig, Sig)+ar4 :: (Sig, Sig, Sig, Sig) -> (Sig, Sig, Sig, Sig)+ar6 :: (Sig, Sig, Sig, Sig, Sig, Sig) -> (Sig, Sig, Sig, Sig, Sig, Sig)+ar8 :: (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) -> (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig)++ar1 = id; ar2 = id; ar4 = id; ar6 = id; ar8 = id ++---------------------------------------------------------------------------------+-- out instances++-- | The tuples of signals.+class (Tuple a) => Sigs a where++instance Sigs Sig+instance Sigs (Sig, Sig)+instance Sigs (Sig, Sig, Sig, Sig)+instance Sigs (Sig, Sig, Sig, Sig, Sig, Sig)+instance Sigs (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig)+instance Sigs ( (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig)+ , (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) )++instance Sigs ( (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig)+ , (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig)+ , (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig)+ , (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) )++outArity :: Tuple a => SE a -> Int+outArity = tupleArity . proxy+ where+ proxy :: SE a -> a+ proxy = const undefined++---------------------------------------------------------------------------+-- Arguments++class (Tuple a) => Arg a where++instance Arg Unit+instance Arg D+instance Arg Str+instance Arg Tab++instance (Arg a, Arg b) => Arg (a, b)+instance (Arg a, Arg b, Arg c) => Arg (a, b, c)+instance (Arg a, Arg b, Arg c, Arg d) => Arg (a, b, c, d)+instance (Arg a, Arg b, Arg c, Arg d, Arg e) => Arg (a, b, c, d, e)+instance (Arg a, Arg b, Arg c, Arg d, Arg e, Arg f) => Arg (a, b, c, d, e, f)+instance (Arg a, Arg b, Arg c, Arg d, Arg e, Arg f, Arg h) => Arg (a, b, c, d, e, f, h)+instance (Arg a, Arg b, Arg c, Arg d, Arg e, Arg f, Arg h, Arg g) => Arg (a, b, c, d, e, f, h, g)++arg :: Arg a => Int -> a+arg n = toTuple $ return $ fmap pn [n ..]++toArg :: Arg a => a+toArg = arg 4++argArity :: Arg a => a -> Int+argArity = tupleArity++toNote :: Arg a => a -> GE [E]+toNote a = zipWithM phi (tupleRates a) =<< fromTuple a+ where+ phi rate x = case rate of + Sr -> saveStr $ getStringUnsafe x+ _ -> return x+ + getStringUnsafe x = case getPrimUnsafe x of+ PrimString y -> y+ _ -> error "Arg(Str):getStringUnsafe value is not a string"++-------------------------------------------------------------------------+-- logic functions++-- tuples++newtype BoolTuple = BoolTuple { unBoolTuple :: GE [E] }++toBoolTuple :: Tuple a => a -> BoolTuple+toBoolTuple = BoolTuple . fromTuple++fromBoolTuple :: Tuple a => BoolTuple -> a+fromBoolTuple = toTuple . unBoolTuple++type instance BooleanOf BoolTuple = BoolSig++instance IfB BoolTuple where+ ifB mp (BoolTuple mas) (BoolTuple mbs) = BoolTuple $ + liftA3 (\p as bs -> zipWith (ifB p) as bs) (toGE mp) mas mbs++-- | @ifB@ for tuples of csound values.+ifTuple :: (Tuple a) => BoolSig -> a -> a -> a+ifTuple p a b = fromBoolTuple $ ifB p (toBoolTuple a) (toBoolTuple b)++-- | @guardedB@ for tuples of csound values.+guardedTuple :: (Tuple b) => [(BoolSig, b)] -> b -> b+guardedTuple bs b = fromBoolTuple $ guardedB undefined (fmap (second toBoolTuple) bs) (toBoolTuple b)++-- | @caseB@ for tuples of csound values.+caseTuple :: (Tuple b) => a -> [(a -> BoolSig, b)] -> b -> b+caseTuple a bs other = fromBoolTuple $ caseB a (fmap (second toBoolTuple) bs) (toBoolTuple other)++-- arguments++newtype BoolArg = BoolArg { unBoolArg :: GE [E] }++toBoolArg :: (Arg a, Tuple a) => a -> BoolArg+toBoolArg = BoolArg . fromTuple++fromBoolArg :: (Arg a, Tuple a) => BoolArg -> a+fromBoolArg = toTuple . unBoolArg++type instance BooleanOf BoolArg = BoolD++instance IfB BoolArg where+ ifB mp (BoolArg mas) (BoolArg mbs) = BoolArg $ + liftA3 (\p as bs -> zipWith (ifB p) as bs) (toGE mp) mas mbs++-- | @ifB@ for constants.+ifArg :: (Arg a, Tuple a) => BoolD -> a -> a -> a+ifArg p a b = fromBoolArg $ ifB p (toBoolArg a) (toBoolArg b)++-- | @guardedB@ for constants.+guardedArg :: (Tuple b, Arg b) => [(BoolD, b)] -> b -> b+guardedArg bs b = fromBoolArg $ guardedB undefined (fmap (second toBoolArg) bs) (toBoolArg b)++-- | @caseB@ for constants.+caseArg :: (Tuple b, Arg b) => a -> [(a -> BoolD, b)] -> b -> b+caseArg a bs other = fromBoolArg $ caseB a (fmap (second toBoolArg) bs) (toBoolArg other)++-----------------------------------------------------------+-- tuple constructors++pureTuple :: Tuple a => GE (MultiOut [E]) -> a+pureTuple a = res+ where res = toTuple $ fmap ($ tupleArity res) a++dirtyTuple :: Tuple a => GE (MultiOut [E]) -> SE a+dirtyTuple a = res+ where + res = fmap (toTuple . return) $ SE + $ mapM depT =<< (lift $ fmap ($ (tupleArity $ proxy res)) a)++ proxy :: SE a -> a+ proxy = const undefined+ +
+ src/Csound/Typed/Types/TupleHelpers.hs view
@@ -0,0 +1,30 @@+module Csound.Typed.Types.TupleHelpers where++cons3 :: (a, (b, c)) -> (a, b, c)+cons4 :: (a, (b, c, d)) -> (a, b, c, d)+cons5 :: (a, (b, c, d, e)) -> (a, b, c, d, e)+cons6 :: (a, (b, c, d, e, f)) -> (a, b, c, d, e, f)+cons7 :: (a, (b, c, d, e, f, g)) -> (a, b, c, d, e, f, g)+cons8 :: (a, (b, c, d, e, f, g, h)) -> (a, b, c, d, e, f, g, h)++cons3 (a, (b, c)) = (a, b, c)+cons4 (a, (b, c, d)) = (a, b, c, d)+cons5 (a, (b, c, d, e)) = (a, b, c, d, e)+cons6 (a, (b, c, d, e, f)) = (a, b, c, d, e, f)+cons7 (a, (b, c, d, e, f, g)) = (a, b, c, d, e, f, g)+cons8 (a, (b, c, d, e, f, g, h)) = (a, b, c, d, e, f, g, h)++split3 :: (a, b, c) -> (a, (b, c)) +split4 :: (a, b, c, d) -> (a, (b, c, d)) +split5 :: (a, b, c, d, e) -> (a, (b, c, d, e)) +split6 :: (a, b, c, d, e, f) -> (a, (b, c, d, e, f)) +split7 :: (a, b, c, d, e, f, g) -> (a, (b, c, d, e, f, g)) +split8 :: (a, b, c, d, e, f, g, h) -> (a, (b, c, d, e, f, g, h)) ++split3 (a, b, c) = (a, (b, c)) +split4 (a, b, c, d) = (a, (b, c, d)) +split5 (a, b, c, d, e) = (a, (b, c, d, e)) +split6 (a, b, c, d, e, f) = (a, (b, c, d, e, f)) +split7 (a, b, c, d, e, f, g) = (a, (b, c, d, e, f, g)) +split8 (a, b, c, d, e, f, g, h) = (a, (b, c, d, e, f, g, h)) +