diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/csound-expression-typed.cabal b/csound-expression-typed.cabal new file mode 100644 --- /dev/null +++ b/csound-expression-typed.cabal @@ -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: + +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 + diff --git a/src/Csound/Typed.hs b/src/Csound/Typed.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed.hs @@ -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 diff --git a/src/Csound/Typed/Control.hs b/src/Csound/Typed/Control.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Control.hs @@ -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 + + diff --git a/src/Csound/Typed/Control/Evt.hs b/src/Csound/Typed/Control/Evt.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Control/Evt.hs @@ -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 + diff --git a/src/Csound/Typed/Control/Instr.hs b/src/Csound/Typed/Control/Instr.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Control/Instr.hs @@ -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 + diff --git a/src/Csound/Typed/Control/Midi.hs b/src/Csound/Typed/Control/Midi.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Control/Midi.hs @@ -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 + diff --git a/src/Csound/Typed/Control/Mix.hs b/src/Csound/Typed/Control/Mix.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Control/Mix.hs @@ -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 diff --git a/src/Csound/Typed/Control/SERef.hs b/src/Csound/Typed/Control/SERef.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Control/SERef.hs @@ -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) + diff --git a/src/Csound/Typed/Control/Vco.hs b/src/Csound/Typed/Control/Vco.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Control/Vco.hs @@ -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 + diff --git a/src/Csound/Typed/GlobalState.hs b/src/Csound/Typed/GlobalState.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/GlobalState.hs @@ -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 diff --git a/src/Csound/Typed/GlobalState/Cache.hs b/src/Csound/Typed/GlobalState/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/GlobalState/Cache.hs @@ -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 }) + diff --git a/src/Csound/Typed/GlobalState/Elements.hs b/src/Csound/Typed/GlobalState/Elements.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/GlobalState/Elements.hs @@ -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 + + + diff --git a/src/Csound/Typed/GlobalState/GE.hs b/src/Csound/Typed/GlobalState/GE.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/GlobalState/GE.hs @@ -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 + + diff --git a/src/Csound/Typed/GlobalState/Instr.hs b/src/Csound/Typed/GlobalState/Instr.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/GlobalState/Instr.hs @@ -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 + diff --git a/src/Csound/Typed/GlobalState/Opcodes.hs b/src/Csound/Typed/GlobalState/Opcodes.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/GlobalState/Opcodes.hs @@ -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)] + diff --git a/src/Csound/Typed/GlobalState/Options.hs b/src/Csound/Typed/GlobalState/Options.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/GlobalState/Options.hs @@ -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 + diff --git a/src/Csound/Typed/GlobalState/SE.hs b/src/Csound/Typed/GlobalState/SE.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/GlobalState/SE.hs @@ -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 + diff --git a/src/Csound/Typed/Render.hs b/src/Csound/Typed/Render.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Render.hs @@ -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" } } + diff --git a/src/Csound/Typed/Types.hs b/src/Csound/Typed/Types.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Types.hs @@ -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 + + + + diff --git a/src/Csound/Typed/Types/Evt.hs b/src/Csound/Typed/Types/Evt.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Types/Evt.hs @@ -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 + diff --git a/src/Csound/Typed/Types/Lift.hs b/src/Csound/Typed/Types/Lift.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Types/Lift.hs @@ -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 diff --git a/src/Csound/Typed/Types/MixSco.hs b/src/Csound/Typed/Types/MixSco.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Types/MixSco.hs @@ -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 + diff --git a/src/Csound/Typed/Types/Prim.hs b/src/Csound/Typed/Types/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Types/Prim.hs @@ -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 + diff --git a/src/Csound/Typed/Types/Tuple.hs b/src/Csound/Typed/Types/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Types/Tuple.hs @@ -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 + + diff --git a/src/Csound/Typed/Types/TupleHelpers.hs b/src/Csound/Typed/Types/TupleHelpers.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Types/TupleHelpers.hs @@ -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)) +