diff --git a/csound-expression-typed.cabal b/csound-expression-typed.cabal --- a/csound-expression-typed.cabal +++ b/csound-expression-typed.cabal @@ -1,5 +1,5 @@ Name: csound-expression-typed -Version: 0.2.0.0 +Version: 0.2.0.1 Cabal-Version: >= 1.22 License: BSD3 License-file: LICENSE @@ -11,7 +11,7 @@ Category: Music, Sound Maintainer: -Description: +Description: Data-Files : data/hrtf-44100-left.dat @@ -47,9 +47,9 @@ data/opcodes/MultiFX/PitchShifter.udo data/opcodes/MultiFX/Reverse.udo data/opcodes/MultiFX/RingModulator.udo - data/opcodes/MultiFX/StChorus.udo - data/opcodes/MultiFX/StereoPingPongDelay.udo - data/opcodes/Utility/Delay1k.udo + data/opcodes/MultiFX/StChorus.udo + data/opcodes/MultiFX/StereoPingPongDelay.udo + data/opcodes/Utility/Delay1k.udo Homepage: https://github.com/anton-k/csound-expression-typed @@ -63,7 +63,7 @@ Library Ghc-Options: -Wall Build-Depends: - base >= 4, base < 5, ghc-prim, containers, transformers >= 0.3, Boolean >= 0.1.0, colour >= 2.0, data-default, deepseq, + base >= 4, base < 5, ghc-prim, containers, transformers >= 0.3, Boolean >= 0.1.0, colour >= 2.0, data-default, deepseq, NumInstances, wl-pprint, csound-expression-dynamic >= 0.3.0, temporal-media >= 0.6.0, hashable Hs-Source-Dirs: src/ Exposed-Modules: @@ -76,7 +76,7 @@ Csound.Typed.Gui Csound.Typed.Gui.Cab - Csound.Typed.Types.Prim + Csound.Typed.Types.Prim Csound.Typed.Types.Evt Csound.Typed.Types.Tuple Csound.Typed.Types.Lift @@ -84,7 +84,7 @@ Csound.Typed.Types.MonoArg Csound.Typed.Types.SigSpace - Csound.Typed.Plugins + Csound.Typed.Plugins Other-Modules: Csound.Typed.GlobalState @@ -95,8 +95,8 @@ Csound.Typed.GlobalState.InstrApi Csound.Typed.GlobalState.Cache Csound.Typed.GlobalState.Elements - Csound.Typed.GlobalState.Opcodes - Csound.Typed.GlobalState.Port + Csound.Typed.GlobalState.Opcodes + Csound.Typed.GlobalState.Port Csound.Typed.InnerOpcodes Csound.Typed.Types.TupleHelpers @@ -110,7 +110,7 @@ Csound.Typed.Control.Sf2 Csound.Typed.Control.Osc Csound.Typed.Control.Channel - Csound.Typed.Control.Ref + Csound.Typed.Control.Ref Csound.Typed.Control.Instr Csound.Typed.Control.InstrRef Csound.Typed.Control.ArrayTraverse diff --git a/src/Csound/Typed/Control/Evt.hs b/src/Csound/Typed/Control/Evt.hs --- a/src/Csound/Typed/Control/Evt.hs +++ b/src/Csound/Typed/Control/Evt.hs @@ -36,9 +36,9 @@ where unEvt e = (T.eventStart e, T.eventDur e, T.eventContent e) sched :: (Arg a, Sigs b) => (a -> SE b) -> Evt (Sco a) -> b -sched instr evts = apInstr0 $ do +sched instr evts = apInstr0 $ do instrId <- saveSourceInstrCachedWithLivenessWatch (funArity instr) (insExp instr) - saveEvtInstr (arityOuts $ funArity instr) instrId (renderEvts evts) + saveEvtInstr (arityOuts $ funArity instr) instrId (renderEvts evts) -- | Triggers a procedure on the event stream. sched_ :: (Arg a) => (a -> SE ()) -> Evt (Sco a) -> SE () @@ -50,7 +50,7 @@ schedBy :: (Arg a, Sigs b, Arg c) => (a -> SE b) -> (c -> Evt (Sco a)) -> (c -> b) schedBy instr evts args = flip apInstr args $ do instrId <- saveSourceInstrCachedWithLivenessWatch (funArity instr) (insExp instr) - saveEvtInstr (arityOuts $ funArity instr) instrId (renderEvts $ evts toArg) + saveEvtInstr (arityOuts $ funArity instr) instrId (renderEvts $ evts toArg) ------------------------------------------------- -- triggereing the events @@ -64,28 +64,28 @@ evtMixInstr aliveCountRef = do chnId <- fromDep $ C.chnRefAlloc arity go aliveCountRef chnId evts - fromDep_ $ hideGEinDep $ fmap (\chn -> C.sendOut arity =<< C.readChn chn) chnId + fromDep_ $ hideGEinDep $ fmap (\chn -> C.sendOut arity =<< C.readChn chn) chnId aliveCount <- readRef aliveCountRef - fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnAlive chnId $ toGE aliveCount + fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnAlive chnId $ toGE aliveCount go :: Arg a => Ref D -> GE C.ChnRef -> Evt [(D, D, a)] -> SE () - go aliveCountRef mchnId events = + go aliveCountRef mchnId events = runEvt events $ \es -> do writeRef aliveCountRef $ int $ 2 * length es chnId <- geToSe mchnId fromDep_ $ mapM_ (event chnId) es - + event :: Arg a => C.ChnRef -> (D, D, a) -> Dep () - event chnId (start, dur, args) = hideGEinDep $ fmap C.event $ - C.Event (primInstrId instrId) <$> toGE start <*> toGE dur <*> (fmap (++ [C.chnRefId chnId]) $ toNote args) - + event chnId (start, dur, args) = hideGEinDep $ fmap C.event $ + C.Event (primInstrId instrId) <$> toGE start <*> toGE dur <*> (fmap (++ [C.chnRefId chnId]) $ toNote args) + -- | Retriggers an instrument every time an event happens. The note -- is held until the next event happens. retrigs :: (Arg a, Sigs b) => (a -> SE b) -> Evt [a] -> b retrigs instr evts = apInstr0 $ do instrId <- saveSourceInstrCachedWithLivenessWatchAndRetrig (funArity instr) (insExp instr) saveRetrigEvtInstr (arityOuts $ funArity instr) instrId evts - + saveRetrigEvtInstr :: Arg a => Int -> C.InstrId -> Evt [a] -> GE C.InstrId saveRetrigEvtInstr arity instrId evts = saveInstr $ do aliveCountRef <- newRef (10 :: D) @@ -96,24 +96,24 @@ evtMixInstr aliveCountRef retrigWatchRef = do chnId <- fromDep $ C.chnRefAlloc arity go aliveCountRef retrigWatchRef chnId evts - fromDep_ $ hideGEinDep $ fmap (\chn -> C.sendOut arity =<< C.readChn chn) chnId + fromDep_ $ hideGEinDep $ fmap (\chn -> C.sendOut arity =<< C.readChn chn) chnId aliveCount <- readRef aliveCountRef - fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnAlive chnId $ toGE aliveCount + fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnAlive chnId $ toGE aliveCount go :: Arg a => Ref D -> Ref D -> GE C.ChnRef -> Evt [a] -> SE () - go aliveCountRef retrigWatchRef mchnId events = + go aliveCountRef retrigWatchRef mchnId events = runEvt events $ \es -> do - writeRef aliveCountRef $ int $ 2 * length es + writeRef aliveCountRef $ int $ 2 * length es modifyRef retrigWatchRef (+ 1) chnId <- geToSe mchnId currentRetrig <- readRef retrigWatchRef - fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnRetrig mchnId $ toGE currentRetrig + fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnRetrig mchnId $ toGE currentRetrig fromDep_ $ mapM_ (event chnId currentRetrig) es - + event :: Arg a => C.ChnRef -> D -> a -> Dep () event chnId currentRetrig args = hideGEinDep $ fmap C.event $ do currentRetrigExp <- toGE currentRetrig - C.Event (primInstrId instrId) 0 infiniteDur <$> (fmap (++ [C.chnRefId chnId, currentRetrigExp]) $ toNote args) + C.Event (primInstrId instrId) 0 infiniteDur <$> (fmap (++ [C.chnRefId chnId, currentRetrigExp]) $ toNote args) evtLoop :: (Num a, Tuple a, Sigs a) => Maybe (Evt Unit) -> [SE a] -> [Evt Unit] -> a evtLoop = evtLoopGen True @@ -125,7 +125,7 @@ evtLoopGen mustLoop maybeOffEvt instrs evts = apInstr0 $ do (instrId, evtInstrId) <- saveSourceInstrCachedWithLivenessWatchAndRetrigAndEvtLoop (constArity instr) (insExp $ toInstrExp instr) (toSingleEvt evts) saveEvtLoopInstr mustLoop loopLength maybeOffEvt (arityOuts $ constArity instr) instrId evtInstrId - where + where loopLength = int $ lcm (length instrs) (length evts) instr = toSingleInstr instrs @@ -138,7 +138,7 @@ ref <- newRef 0 zipWithM_ (f ref n) (fmap (sig . int) [0 .. ]) as readRef ref - where + where f :: Tuple a => Ref a -> Sig -> Sig -> SE a -> SE () f ref n ix a = when1 (n ==* ix) $ writeRef ref =<< a @@ -146,7 +146,7 @@ toSingleEvt evts = do let n = mod' (fromE $ getRetrigVal 4) (sig $ int $ length evts) zipWithM_ (f n) (fmap (sig . int) [0 .. ]) evts - where + where f :: Sig -> Sig -> Evt Unit -> SE () f n ix evt = when1 (n ==* ix) $ evtLoopInstr evt @@ -157,7 +157,7 @@ saveEvtLoopInstr :: Bool -> D -> Maybe (Evt Unit) -> Int -> C.InstrId -> C.InstrId -> GE C.InstrId saveEvtLoopInstr mustLoop loopLength maybeOffEvt arity instrId evtInstrId = saveInstr $ do aliveCountRef <- newRef (10 :: D) - retrigWatchRef <- newRef (0 :: D) + retrigWatchRef <- newRef (0 :: D) evtMixInstr aliveCountRef retrigWatchRef where evtMixInstr :: Ref D -> Ref D -> SE () @@ -167,43 +167,43 @@ isOn <- fmap sig $ case maybeOffEvt of Nothing -> return 1 Just offEvt -> do - isOn <- newRef (1 :: D) + isOn <- newRef (1 :: D) runEvt offEvt $ const $ do writeRef isOn 0 modifyRef retrigWatchRef (+ 1) currentRetrig <- readRef retrigWatchRef - fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnRetrig chnId $ toGE currentRetrig - readRef isOn + fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnRetrig chnId $ toGE currentRetrig + readRef isOn masterEvt <- fmap (sigToEvt . (* isOn) . fromGE . fmap C.changed . toGE) $ readServantEvt chnId go aliveCountRef retrigWatchRef chnId masterEvt - fromDep_ $ hideGEinDep $ fmap (\chn -> C.sendOut arity =<< C.readChn chn) chnId + fromDep_ $ hideGEinDep $ fmap (\chn -> C.sendOut arity =<< C.readChn chn) chnId aliveCount <- readRef aliveCountRef - fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnAlive chnId $ toGE aliveCount + fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnAlive chnId $ toGE aliveCount - go = goBy (+ 1) + go = goBy (+ 1) goBy :: (D -> D) -> Ref D -> Ref D -> GE C.ChnRef -> Evt Unit -> SE () - goBy updateRetrig aliveCountRef retrigWatchRef mchnId events = - runEvt events $ \es -> do + goBy updateRetrig aliveCountRef retrigWatchRef mchnId events = + runEvt events $ \es -> do modifyRef retrigWatchRef updateRetrig chnId <- geToSe mchnId currentRetrig <- readRef retrigWatchRef - if not mustLoop + if not mustLoop then do when1 (sig currentRetrig >=* (sig loopLength)) $ do fromDep_ turnoff else return () - fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnRetrig mchnId $ toGE currentRetrig + fromDep_ $ hideGEinDep $ liftA2 masterUpdateChnRetrig mchnId $ toGE currentRetrig audioEvent chnId currentRetrig - evtEvent chnId currentRetrig + evtEvent chnId currentRetrig fireEventFor :: (C.ChnRef -> E -> C.Event) -> C.ChnRef -> D -> SE () fireEventFor f chnId currentRetrig = fromDep_ $ hideGEinDep $ fmap C.event $ do currentRetrigExp <- toGE currentRetrig - return $ f chnId currentRetrigExp + return $ f chnId currentRetrigExp audioEvent = fireEventFor eventForAudioInstr evtEvent = fireEventFor eventForEvtInstr @@ -214,21 +214,21 @@ chnId <- mchnId return $ initStartEvtInstr chnId >> initStartAudioInstr chnId - initStartEvtInstr chnId = C.event_i $ eventForEvtInstr chnId 0 + initStartEvtInstr chnId = C.event_i $ eventForEvtInstr chnId 0 initStartAudioInstr chnId = C.event_i $ eventForAudioInstr chnId 0 eventForEvtInstr = eventFor evtInstrId eventForAudioInstr = eventFor instrId - eventFor idx chnId currentRetrig = - C.Event (primInstrId idx) 0 infiniteDur [C.chnRefId chnId, currentRetrig] + eventFor idx chnId currentRetrig = + C.Event (primInstrId idx) 0 infiniteDur [C.chnRefId chnId, currentRetrig] readServantEvt :: GE C.ChnRef -> SE Sig readServantEvt chnId = SE $ fmap fromE $ hideGEinDep $ fmap readChnEvtLoop chnId --- | 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 +-- | 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 @@ -246,7 +246,7 @@ autoOff :: Sigs a => D -> a -> SE a autoOff dt sigs = fmap toTuple $ fromDep $ hideGEinDep $ phi =<< fromTuple sigs - where + where phi x = do dtE <- toGE dt return $ C.autoOff dtE x @@ -275,7 +275,7 @@ ------------------------------------------------------------- -- monophonic scheduling --- | Turns +-- | Turns monoSched :: Evt (Sco (D, D)) -> SE MonoArg monoSched evts = evtPort instr evts read where @@ -290,7 +290,7 @@ return $ MonoArg amp cps (ifB (gate `equalsTo` 0) 0 1) (changed [amp, cps, gate]) runSco :: Arg a => Evt (Sco a) -> ((D,D,a) -> SE ()) -> SE () -runSco evts f = runEvt (renderEvts evts) $ mapM_ f +runSco evts f = runEvt (renderEvts evts) $ mapM_ f -- | Plays the note until next note comes or something happens on the second event stream. monoSchedUntil :: Evt (D, D) -> Evt a -> SE MonoArg @@ -302,7 +302,7 @@ where go ref = either (ons ref) (const $ offs ref) - ons ref (amp, cps) = + ons ref (amp, cps) = writeRef ref $ MonoArg { monoAmp = sig amp, monoCps = sig cps, monoGate = 1, monoTrig = 1 } offs ref = modifyRef ref $ \arg -> arg { monoGate = 0 } diff --git a/src/Csound/Typed/Control/Mix.hs b/src/Csound/Typed/Control/Mix.hs --- a/src/Csound/Typed/Control/Mix.hs +++ b/src/Csound/Typed/Control/Mix.hs @@ -1,6 +1,6 @@ {-# Language FlexibleContexts, ScopedTypeVariables #-} module Csound.Typed.Control.Mix( - Mix, + Mix, sco, eff, mix, mixBy, monoSco, sco_, mix_, mixBy_, Sco, CsdEventList(..), CsdEvent @@ -30,12 +30,12 @@ toCsdEventList = id singleCsdEvent :: (D, D, a) -> Sco a -singleCsdEvent (start, duration, content) = del start $ str duration $ temp content +singleCsdEvent (start, duration, content) = del start $ str duration $ temp content -- | Special type that represents a scores of sound signals. -- If an instrument is triggered with the scores the result is wrapped --- in the value of this type. -newtype Mix a = Mix { unMix :: GE M } +-- in the value of this type. +newtype Mix a = Mix { unMix :: GE M } type Sco a = Track D a @@ -45,34 +45,34 @@ -- | Plays a bunch of notes with the given instrument. -- --- > res = sco instrument scores +-- > res = sco instrument scores sco :: (Arg a, Sigs b) => (a -> SE b) -> Sco a -> Sco (Mix b) sco instr notes = wrapSco notes $ \events -> do - events' <- traverse toNote events + events' <- traverse toNote events instrId <- saveSourceInstrCachedWithLivenessWatch (funArity instr) (insExp instr) return $ Snd instrId events' -- | Invokes a procedure for the given bunch of events. sco_ :: (Arg a) => (a -> SE ()) -> Sco a -> Sco (Mix Unit) sco_ instr notes = wrapSco notes $ \events -> do - events' <- traverse toNote events + events' <- traverse toNote events instrId <- saveSourceInstrCached_ (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. +-- | Applies an effect to the sound. Effect is applied to the sound on the give track. -- --- > res = eff effect sco +-- > res = eff effect sco -- --- * @effect@ - a function that takes a tuple of signals and produces +-- * @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'. +-- * @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 +-- 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 +-- favorite Score-generation library. You can delay it or mix with some other track and -- apply some another effect on top of it! eff :: (Sigs a, Sigs b) => (a -> SE b) -> Sco (Mix a) -> Sco (Mix b) eff ef sigs = wrapSco sigs $ \events -> do @@ -83,37 +83,37 @@ -- | Plays a bunch of notes with the given monophonic instrument. See details on type @MonoArg@. -- The scores contain the pairs of amplitude (0 to 1) and frequency (in Hz). -- --- > res = monoSco instrument scores +-- > res = monoSco instrument scores monoSco :: forall a . Sigs a => (MonoArg -> SE a) -> Sco (D, D) -> Sco (Mix a) monoSco instr notes = wrapSco notes $ \events -> do - events' <- traverse toNote events + events' <- traverse toNote events argId <- saveSourceInstrCached_ (unitExp $ fmap (const unit) $ instrMonoArg toArg) instrId <- saveEffectInstr ((funArity instr) { arityIns = 3 }) (effExp effInstr) - return $ MonoSnd instrId argId events' - where + return $ MonoSnd instrId argId events' + where instrMonoArg :: ((D, D), Port Sig3) -> SE () instrMonoArg ((amp, cps), port) = - modifyPort port $ \(_, _, notnum) -> (sig amp, sig cps, notnum + 1) + modifyPort port $ \(_, _, notnum) -> (sig amp, sig cps, notnum + 1) effInstr :: Sigs a => (Sig, Sig, Sig) -> SE a effInstr (amp, cps, notnum) = instr (MonoArg amp cps gate (changed [amp, cps, gate])) where gate = ifB (notnum ==* 0) 0 1 - + -- | Renders a scores to the sound signals. we can use it inside the other instruments. mix :: (Sigs a) => Sco (Mix a) -> a mix a = flip apInstr unit $ do key <- mixKey a durE <- toGE $ dur a - withCache (ExpDur durE) getMixKey saveMixKey key $ + withCache (ExpDur durE) getMixKey saveMixKey key $ saveMixInstr (mixArity a) =<< toEventList a' where a' = toCsdEventList a --- | Imitates a closure for a bunch of notes to be played within another instrument. +-- | Imitates a closure for a bunch of notes to be played within another instrument. mixBy :: (Arg a, Sigs b) => (a -> Sco (Mix b)) -> (a -> b) mixBy evts args = flip apInstr args $ do key <- mixKey evts durE <- toGE $ dur evts' - withCache (ExpDur durE) getMixKey saveMixKey key $ + withCache (ExpDur durE) getMixKey saveMixKey key $ saveMixInstr (mixArityFun evts) =<< (toEventList evts') where evts' = toCsdEventList $ evts toArg @@ -126,7 +126,7 @@ saveMixInstr_ =<< toEventList a' where a' = toCsdEventList a --- | Imitates a closure for a bunch of procedures to be played within another instrument. +-- | Imitates a closure for a bunch of procedures to be played within another instrument. mixBy_ :: (Arg a) => (a -> Sco (Mix Unit)) -> (a -> SE ()) mixBy_ evts args = mix_ $ evts args @@ -136,7 +136,7 @@ mixKey = liftIO . fmap (MixKey . hashStableName) . makeStableName toEventList :: Sco (Mix a) -> GE (CsdEventList M) -toEventList evts = fmap delayAndRescaleCsdEventListM $ traverse unMix $ evts +toEventList evts = fmap delayAndRescaleCsdEventListM $ traverse unMix $ evts mixArity :: Sigs b => f (Mix b) -> Int mixArity = tupleArity . proxy diff --git a/src/Csound/Typed/Control/Osc.hs b/src/Csound/Typed/Control/Osc.hs --- a/src/Csound/Typed/Control/Osc.hs +++ b/src/Csound/Typed/Control/Osc.hs @@ -1,12 +1,12 @@ --- | Open sound control +-- | Open sound control {-# Language ScopedTypeVariables #-} module Csound.Typed.Control.Osc( - OscRef, OscHost, OscPort, OscAddress, OscType, + OscRef, OscHost, OscPort, OscAddress, OscType, initOsc, listenOsc, sendOsc, OscVal, listenOscVal ) where -import Data.Boolean ((==*)) +import Data.Boolean (ifB, (==*)) import Csound.Dynamic(Rate(..)) import Csound.Typed.Types @@ -24,10 +24,10 @@ -- | Path-like string ("/foo/bar/baz") type OscAddress = String - --- | The string specifies the type of expected arguments. --- The string can contain the characters "bcdfilmst" which stand for --- Boolean, character, double, float, 32-bit integer, 64-bit integer, MIDI, + +-- | The string specifies the type of expected arguments. +-- The string can contain the characters "bcdfilmst" which stand for +-- Boolean, character, double, float, 32-bit integer, 64-bit integer, MIDI, -- string and timestamp. type OscType = String @@ -44,9 +44,9 @@ -- -- > /foo/bar/baz -- --- The latter specifies the type of expected arguments. --- The string can contain the characters "bcdfilmst" which stand for --- Boolean, character, double, float, 32-bit integer, 64-bit integer, MIDI, +-- The latter specifies the type of expected arguments. +-- The string can contain the characters "bcdfilmst" which stand for +-- Boolean, character, double, float, 32-bit integer, 64-bit integer, MIDI, -- string and timestamp. -- -- The result is an event of messages. We can run a callback on it @@ -54,7 +54,7 @@ -- -- > runEvt :: Evt a -> (a -> SE ()) -> SE () listenOsc :: forall a . Tuple a => OscRef -> OscAddress -> OscType -> Evt a -listenOsc oscRef oscAddr oscType = Evt $ \bam -> do +listenOsc oscRef oscAddr oscType = Evt $ \bam -> do resRef <- initOscRef oscType cond <- listen resRef when1 cond $ bam =<< readRef resRef @@ -63,12 +63,12 @@ listen ref = fmap (==* 1) $ csdOscListen ref oscRef oscAddr oscType csdOscListen :: Tuple a => Ref a -> OscRef -> OscAddress -> OscType -> SE Sig - csdOscListen (Ref refVars) oscHandle addr ty = - fmap fromGE $ fromDep $ hideGEinDep $ do + csdOscListen (Ref refVars) oscHandle addr ty = + fmap fromGE $ fromDep $ hideGEinDep $ do expOscHandle <- toGE $ unOscRef oscHandle expAddr <- toGE $ text addr expOscType <- toGE $ text ty - return $ C.oscListen expOscHandle expAddr expOscType refVars + return $ C.oscListen expOscHandle expAddr expOscType refVars initOscRef :: OscType -> SE (Ref a) initOscRef typeStr = fmap Ref $ newLocalVars (fmap getOscRate typeStr) (fromTuple $ (defTuple :: a)) @@ -81,22 +81,32 @@ 'f' -> Kr _ -> Kr --- | Sends OSC-messages. It takes in a name of the host computer --- (empty string is alocal machine), port on which the target +-- | Sends OSC-messages. It takes in a name of the host computer +-- (empty string is alocal machine), port on which the target -- machine is listening, OSC-addres and type. The last argument -- produces the values for OSC-messages. sendOsc :: forall a . Tuple a => OscHost -> OscPort -> OscAddress -> OscType -> Evt a -> SE () -sendOsc host port addr ty evts = runEvt evts send - where - send :: Tuple a => a -> SE () - send as = SE $ hideGEinDep $ do +sendOsc host port addr ty evts = do + flagRef <- newRef (0 :: Sig) + valRef <- newRef defTuple + runEvt evts $ \a -> do + flag <- readRef flagRef + writeRef flagRef (flag + 1) + writeRef valRef a + + flag <- readRef flagRef + value <- readRef valRef + send flag value + where + send :: Tuple a => Sig -> a -> SE () + send trig as = SE $ hideGEinDep $ do args <- fromTuple as + expTrig <- toGE trig expHost <- toGE $ text $ host expPort <- toGE $ int $ port expAddr <- toGE $ text $ addr expTy <- toGE $ text $ ty - return $ C.oscSend $ 1 : expHost : expPort : expAddr : expTy : args - + return $ C.oscSend $ expTrig : expHost : expPort : expAddr : expTy : args class Tuple a => OscVal a where getOscTypes :: a -> String @@ -146,7 +156,7 @@ -- | Listens for tuples of continuous signals read from OSC-channel. -- --- > listenOscVal ref address initValue +-- > listenOscVal ref address initValue listenOscVal :: (Tuple a, OscVal a) => OscRef -> String -> a -> SE a listenOscVal port path initVal = do ref <- getOscRef initVal diff --git a/src/Csound/Typed/GlobalState/Elements.hs b/src/Csound/Typed/GlobalState/Elements.hs --- a/src/Csound/Typed/GlobalState/Elements.hs +++ b/src/Csound/Typed/GlobalState/Elements.hs @@ -17,8 +17,8 @@ -- * Midi MidiType(..), Channel, MidiMap, MidiKey(..), saveMidiInstr, -- * Global variables - Globals(..), newPersistentGlobalVar, newClearableGlobalVar, - newPersistentGloabalArrVar, + Globals(..), newPersistentGlobalVar, newClearableGlobalVar, + newPersistentGloabalArrVar, renderGlobals, -- * Instruments Instrs(..), saveInstr, getInstrIds, -- newInstrId, saveInstrById, saveInstr, CacheName, makeCacheName, saveCachedInstr, getInstrIds, @@ -36,12 +36,12 @@ -- * Udo plugins UdoPlugin, addUdoPlugin, getUdoPluginNames, tabQueuePlugin, tabQueue2Plugin, - zdfPlugin, solinaChorusPlugin, audaciouseqPlugin, adsr140Plugin, + zdfPlugin, solinaChorusPlugin, audaciouseqPlugin, adsr140Plugin, diodePlugin, korg35Plugin, zeroDelayConvolutionPlugin, pitchShifterDelayPlugin, analogDelayPlugin, distortionPlugin, envelopeFolollowerPlugin, flangerPlugin, freqShifterPlugin, - loFiPlugin, panTremPlugin, monoTremPlugin, phaserPlugin, pitchShifterPlugin, reversePlugin, - ringModulatorPlugin, stChorusPlugin, stereoPingPongDelayPlugin, + loFiPlugin, panTremPlugin, monoTremPlugin, phaserPlugin, pitchShifterPlugin, reversePlugin, + ringModulatorPlugin, stChorusPlugin, stereoPingPongDelayPlugin, delay1kPlugin, ) where @@ -64,26 +64,26 @@ data IdMap a = IdMap { idMapContent :: M.Map a Int - , idMapNewId :: Int + , idMapNewId :: Int } deriving (Eq, Ord) -instance Default (IdMap a) where +instance Default (IdMap a) where def = IdMap def 1 saveId :: Ord a => a -> State (IdMap a) Int -saveId a = state $ \s -> +saveId a = state $ \s -> case M.lookup a (idMapContent s) of - Nothing -> + Nothing -> let newId = idMapNewId s s1 = s{ idMapContent = M.insert a newId (idMapContent s) - , idMapNewId = succ newId } + , idMapNewId = succ newId } in (newId, s1) Just n -> (n, s) newIdMapId :: State (IdMap a) Int -newIdMapId = state $ \s -> +newIdMapId = state $ \s -> let newId = idMapNewId s - s1 = s { idMapNewId = succ newId } + s1 = s { idMapNewId = succ newId } in (newId, s1) -- gens @@ -98,19 +98,19 @@ where intTab ns = Gen (length ns) (IntGenId (-2)) (fmap fromIntegral ns) Nothing saveGenId :: Ord a => a -> State (IdMap a) Int -saveGenId a = state $ \s -> +saveGenId a = state $ \s -> case M.lookup a (idMapContent s) of - Nothing -> + Nothing -> let newId = nextReadOnlyTableId $ idMapNewId s s1 = s{ idMapContent = M.insert a newId (idMapContent s) - , idMapNewId = nextReadOnlyTableId newId } + , idMapNewId = nextReadOnlyTableId newId } in (newId, s1) Just n -> (n, s) newGenId :: State GenMap Int -newGenId = state $ \s -> +newGenId = state $ \s -> let newId = idMapNewId s - s1 = s { idMapNewId = nextReadOnlyTableId newId } + s1 = s { idMapNewId = nextReadOnlyTableId newId } in (newId, s1) -- writeable gens @@ -121,24 +121,24 @@ newWriteGen = fmap int . saveWriteGenId newWriteTab :: Int -> State WriteGenMap E -newWriteTab = newWriteGen . fromSize +newWriteTab = newWriteGen . fromSize where fromSize n = Gen n (IntGenId 2) (replicate n 0) Nothing saveWriteGenId :: Gen -> State WriteGenMap Int saveWriteGenId a = state $ \s -> case s of [] -> (initId, [(initId, a)]) - (i,_):_ -> let newId = nextWriteTableId i + (i,_):_ -> let newId = nextWriteTableId i in (newId, (newId, a) : s) - where + where initId = tableWriteStep tableWriteStep :: Int tableWriteStep = 10 nextReadOnlyTableId :: Int -> Int -nextReadOnlyTableId x +nextReadOnlyTableId x | y `mod` tableWriteStep == 0 = y + 1 - | otherwise = y + | otherwise = y where y = x + 1 nextWriteTableId :: Int -> Int @@ -158,14 +158,14 @@ -- sf -data SfFluid = SfFluid +data SfFluid = SfFluid { sfId :: Int , sfVars :: [Var] } data SfSpec = SfSpec { sfName :: String , sfBank :: Int - , sfProgram :: Int + , sfProgram :: Int } deriving (Eq, Ord, Show) type SfMap = IdMap SfSpec @@ -183,14 +183,14 @@ sfInstrName n = "i_Sf_instr_" ++ show n renderSf :: Monad m => SfSpec -> Int -> DepT m () -renderSf (SfSpec name bank prog) n = verbatim $ +renderSf (SfSpec name bank prog) n = verbatim $ engineStr ++ "\n" ++ loadStr ++ "\n" ++ selectProgStr ++ "\n" - where + where engineStr = engineName ++ " fluidEngine" loadStr = insName ++ " fluidLoad \"" ++ name ++ "\", " ++ engineName ++ ", 1" - selectProgStr = "fluidProgramSelect " ++ engineName ++ ", 1, " ++ insName + selectProgStr = "fluidProgramSelect " ++ engineName ++ ", 1, " ++ insName ++ ", " ++ show bank ++ ", " ++ show prog engineName = sfEngineName n @@ -211,7 +211,7 @@ bandLimitedVar userId = Var GlobalVar Ir ("BandLim" ++ show userId) -data BandLimitedMap = BandLimitedMap +data BandLimitedMap = BandLimitedMap { simpleBandLimitedMap :: M.Map BandLimited BandLimitedId , vcoInitMap :: GenMap } deriving (Eq, Ord) @@ -229,27 +229,27 @@ UserGen gen -> userGen gen where simpleWave writeId readId = state $ \blMap -> - if (M.member x (simpleBandLimitedMap blMap)) + if (M.member x (simpleBandLimitedMap blMap)) then (SimpleBandLimitedWave readId, blMap) else (SimpleBandLimitedWave readId, blMap { simpleBandLimitedMap = M.insert x (SimpleBandLimitedWave writeId) (simpleBandLimitedMap blMap) }) - userGen gen = state $ \blMap -> + userGen gen = state $ \blMap -> let genMap = vcoInitMap blMap (newId, genMap1) = runState (saveId gen) genMap - blMap1 = blMap { vcoInitMap = genMap1 } + blMap1 = blMap { vcoInitMap = genMap1 } in (UserBandLimitedWave newId, blMap1) renderBandLimited :: Monad m => GenMap -> BandLimitedMap -> DepT m () -renderBandLimited genMap blMap = - if isEmptyBlMap blMap +renderBandLimited genMap blMap = + if isEmptyBlMap blMap then return () else render (idMapNewId genMap) (M.toList $ idMapContent $ vcoInitMap blMap) (M.toList $ simpleBandLimitedMap blMap) - where + where isEmptyBlMap m = (M.null $ simpleBandLimitedMap m) && (M.null $ idMapContent $ vcoInitMap m) render lastGenId gens vcos = do - writeVar freeVcoVar $ int (lastGenId + length gens + 100) + writeVar freeVcoVar $ int (lastGenId + length gens + 100) mapM_ (renderGen lastGenId) gens mapM_ renderVco vcos @@ -257,12 +257,12 @@ renderGen lastGenId (gen, genId) = do renderFtgen lastGenId (gen, genId) renderVcoGen genId - renderVcoVarAssignment genId + renderVcoVarAssignment genId freeVcoVar = Var GlobalVar Ir "free_vco" - ftVar n = Var GlobalVar Ir $ "vco_table_" ++ show n + ftVar n = Var GlobalVar Ir $ "vco_table_" ++ show n - renderFtgen lastGenId (g, n) = writeVar (ftVar n) $ ftgen (int $ lastGenId + n) g + renderFtgen lastGenId (g, n) = writeVar (ftVar n) $ ftgen (int $ lastGenId + n) g renderVcoGen ftId = do ft <- readVar (ftVar ftId) @@ -278,16 +278,16 @@ writeVar freeVcoVar $ vco2init [int waveId, free] UserBandLimitedWave _ -> return () - + {- renderFirstVco n (head vcos) - mapM_ renderTailVco (tail 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 @@ -300,7 +300,7 @@ vcoVar = dummyVar toVcoVar = toDummy - dummyVar = Var LocalVar Ir "ft" + dummyVar = Var LocalVar Ir "ft" toDummy = writeVar dummyVar -} @@ -318,7 +318,7 @@ Nothing -> 1 Just shape -> readShape shape phasorMaster masterCps - readShape shapeId phasor freq = tableikt phasor (vco2ft freq (bandLimitedIdToExpr shapeId)) + readShape shapeId phasor freq = tableikt phasor (vco2ft freq (bandLimitedIdToExpr shapeId)) ---------------------------------------------------------- -- Midi @@ -342,11 +342,11 @@ { globalsNewId :: Int , globalsVars :: [AllocVar] } -data AllocVar = AllocVar - { allocVarType :: GlobalVarType +data AllocVar = AllocVar + { allocVarType :: GlobalVarType , allocVar :: Var , allocVarInit :: E } - | AllocArrVar + | AllocArrVar { allocArrVar :: Var , allocArrVarSizes :: [E] } @@ -359,8 +359,8 @@ newGlobalVar :: GlobalVarType -> Rate -> E -> State Globals Var newGlobalVar ty rate initVal = state $ \s -> - let newId = globalsNewId s - var = Var GlobalVar rate ('g' : show newId) + 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) @@ -374,8 +374,8 @@ newPersistentGloabalArrVar :: Rate -> [E] -> State Globals Var newPersistentGloabalArrVar rate sizes = state $ \s -> let newId = globalsNewId s - var = Var GlobalVar rate ('g' : show newId) - s1 = s { globalsNewId = succ newId + var = Var GlobalVar rate ('g' : show newId) + s1 = s { globalsNewId = succ newId , globalsVars = AllocArrVar var sizes : globalsVars s } in (var, s1) @@ -388,7 +388,7 @@ gs = globalsVars a initAlloc x = case x of - AllocVar _ var init -> initVar var init + AllocVar _ var init -> initVar var init AllocArrVar var sizes -> initArr var sizes clearAlloc x = case x of @@ -419,11 +419,11 @@ saveInstr :: InstrBody -> State Instrs InstrId -saveInstr body = state $ \s -> +saveInstr body = state $ \s -> let h = hash body in case IM.lookup h $ instrsCache s of Just n -> (n, s) - Nothing -> + Nothing -> let newId = instrsNewId s s1 = s { instrsCache = IM.insert h (intInstrId newId) $ instrsCache s , instrsNewId = succ newId @@ -431,11 +431,11 @@ in (intInstrId newId, s1) {- -saveCachedInstr :: InstrBody -> State Instrs InstrId -saveCachedInstr name body = state $ \s -> +saveCachedInstr :: InstrBody -> State Instrs InstrId +saveCachedInstr name body = state $ \s -> case IM.lookup name $ instrsCache s of Just n -> (n, s) - Nothing -> + Nothing -> let newId = instrsNewId s s1 = s { instrsCache = IM.insert name (intInstrId newId) $ instrsCache s , instrsNewId = succ newId @@ -445,11 +445,11 @@ newInstrId :: State Instrs InstrId newInstrId = state $ \s -> let newId = instrsNewId s - s1 = s { instrsNewId = succ newId } + s1 = s { instrsNewId = succ newId } in (intInstrId newId, s1) saveInstrById :: InstrId -> InstrBody -> State Instrs () -saveInstrById instrId body = state $ \s -> +saveInstrById instrId body = state $ \s -> let s1 = s { instrsContent = (instrId, body) : instrsContent s } in ((), s1) @@ -477,20 +477,10 @@ 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" + | otherwise = ($ arity ) $ mdepT $ mopcs "inch" (replicate arity Ar, replicate arity Kr) (fmap int [1 .. arity]) sendOut :: Monad m => Int -> [E] -> DepT m () -sendOut arity sigs +sendOut arity sigs | arity == 0 = return () | otherwise = do vars <- newLocalVars (replicate arity Ar) (return $ replicate arity 0) @@ -498,7 +488,7 @@ vals <- mapM readVar vars depT_ $ opcsNoInlineArgs name [(Xr, replicate arity Ar)] vals where - name + name | arity == 1 = "out" | arity == 2 = "outs" | arity == 4 = "outq" @@ -537,7 +527,7 @@ Just a -> (a, st) Nothing -> onNothing port m globals where - onNothing port m globals = (var, (OscListenPorts m1, newGlobals)) + onNothing port m globals = (var, (OscListenPorts m1, newGlobals)) where (var, newGlobals) = runState (allocOscPortVar port) globals m1 = IM.insert port var m @@ -551,17 +541,17 @@ type MacrosInits = M.Map String MacrosInit -data MacrosInit +data MacrosInit = MacrosInitDouble { macrosInitName :: String, macrosInitValueDouble :: Double } | MacrosInitString { macrosInitName :: String, macrosInitValueString :: String } | MacrosInitInt { macrosInitName :: String, macrosInitValueInt :: Int } deriving (Show, Eq, Ord) initMacros :: MacrosInit -> State MacrosInits () -initMacros macrosInit = modify $ \xs -> M.insert (macrosInitName macrosInit) macrosInit xs +initMacros macrosInit = modify $ \xs -> M.insert (macrosInitName macrosInit) macrosInit xs -------------------------------------------------------- --- Udo plugins +-- Udo plugins newtype UdoPlugin = UdoPlugin { unUdoPlugin :: String } diff --git a/src/Csound/Typed/Types/Evt.hs b/src/Csound/Typed/Types/Evt.hs --- a/src/Csound/Typed/Types/Evt.hs +++ b/src/Csound/Typed/Types/Evt.hs @@ -1,6 +1,6 @@ {-# Language TypeFamilies, FlexibleContexts #-} module Csound.Typed.Types.Evt( - Evt(..), Bam, sync, + Evt(..), Bam, sync, boolToEvt, evtToBool, sigToEvt, stepper, filterE, filterSE, accumSE, accumE, filterAccumE, filterAccumSE, Snap, snapshot, snaps, readSnap @@ -26,12 +26,12 @@ type Bam a = a -> SE () instance Functor Evt where - fmap f a = Evt $ \bam -> runEvt a (bam . f) + 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 Unit boolToEvt b = Evt $ \bam -> when1 b $ bam unit @@ -49,7 +49,7 @@ 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 + when1 (boolSig pr) $ bam a -- | Accumulator for events with side effects. accumSE :: (Tuple s) => s -> (a -> s -> SE (b, s)) -> Evt a -> Evt b @@ -84,7 +84,7 @@ -- | 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 -> +snapshot f asig evt = Evt $ \bam -> runEvt evt $ \a -> bam (f (readSnap asig) a) readSnap :: (Tuple (Snap a), Tuple a) => a -> Snap a @@ -94,13 +94,13 @@ -- given signal. Events happens only when the signal changes. snaps :: Sig -> Evt D snaps asig = snapshot const asig trigger - where + where trigger = sigToEvt $ fromGE $ fmap C.changed $ toGE asig ------------------------------------------------------------------- --- snap +-- snap --- | A snapshot of the signal. It converts a type of the signal to the +-- | A snapshot of the signal. It converts a type of the signal to the -- type of the value in the given moment. Instances: -- -- @@ -109,7 +109,7 @@ -- > 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) @@ -130,7 +130,7 @@ 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 +-- everything about the event values. Signal equals to one when -- an event happens and zero otherwise. evtToBool :: Evt a -> SE BoolSig evtToBool evt = do @@ -151,25 +151,25 @@ -- synchronization -- | Executes actions synchronized with global tempo (in Hz). --- +-- -- > runEvtSync tempoCps evt proc sync :: (Default a, Tuple a) => Sig -> Evt a -> Evt a -sync dt evt = Evt $ \bam -> do +sync dt evt = Evt $ \bam -> do refVal <- newRef def refFire <- newRef (0 :: D) runEvt evt $ \a -> do writeRef refVal a - writeRef refFire 1 - + writeRef refFire 1 + fire <- readRef refFire when1 (metro dt ==* 1 &&* sig fire ==* 1) $ do val <- readRef refVal bam val - writeRef refFire 0 + writeRef refFire 0 where metro :: Sig -> Sig metro asig = fromGE $ fmap C.metro $ toGE asig - + diff --git a/src/Csound/Typed/Types/Prim.hs b/src/Csound/Typed/Types/Prim.hs --- a/src/Csound/Typed/Types/Prim.hs +++ b/src/Csound/Typed/Types/Prim.hs @@ -3,17 +3,18 @@ Sig(..), unSig, D(..), unD, Tab(..), unTab, Str(..), Spec(..), Wspec(..), renderTab, BoolSig(..), unBoolSig, BoolD(..), unBoolD, Unit(..), unit, Val(..), hideGE, SigOrD, Sig2, Sig3, Sig4, Sig5, Sig6, Sig7, Sig8, + Sig2_2, Sig2_3, Sig2_4, Sig2_5, Sig2_6, Sig2_7, Sig2_8, D2, D3, D4, D5, D6, -- ** Tables preTab, preStringTab, TabSize(..), TabArgs(..), updateTabSize, fromPreTab, getPreTabUnsafe, skipNorm, forceNorm, nsamp, ftlen, ftchnls, ftsr, ftcps, - TabList, tabList, fromTabList, fromTabListD, + TabList, tabList, fromTabList, fromTabListD, -- ** constructors - double, int, text, - + double, int, text, + -- ** constants idur, getSampleRate, getControlRate, getBlockSize, getZeroDbfs, @@ -25,11 +26,13 @@ -- ** numeric funs quot', rem', div', mod', ceil', floor', round', int', frac', - + -- ** logic funs when1, whens, untilDo, whileDo, boolSig, equalsTo, notEqualsTo, lessThan, greaterThan, lessThanEquals, greaterThanEquals, - whenD1, whenDs, untilDoD, whileDoD, untilBeginD + whenD1, whenDs, untilDoD, whileDoD, untilBeginD, + + module Data.NumInstances.Tuple ) where import Prelude hiding ((<*)) @@ -41,6 +44,8 @@ import qualified Data.IntMap as IM import qualified Data.Map as M +import Data.NumInstances.Tuple + import Control.Monad.Trans.Reader import Data.Default @@ -54,7 +59,7 @@ import Csound.Typed.GlobalState.Opcodes(tableK, tableI) -- | Signals -data Sig +data Sig = Sig (GE E) | PrimSig Double @@ -62,7 +67,7 @@ unSig = toGE -- | Constant numbers -data D +data D = D (GE E) | PrimD Double @@ -92,10 +97,18 @@ type Sig7 = (Sig, Sig, Sig, Sig, Sig, Sig, Sig) type Sig8 = (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) +type Sig2_2 = (Sig2, Sig2) +type Sig2_3 = (Sig2, Sig2, Sig2) +type Sig2_4 = (Sig2, Sig2, Sig2, Sig2) +type Sig2_5 = (Sig2, Sig2, Sig2, Sig2, Sig2) +type Sig2_6 = (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) +type Sig2_7 = (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) +type Sig2_8 = (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) + -- Booleans -- | A signal of booleans. -data BoolSig +data BoolSig = BoolSig (GE E) | PrimBoolSig Bool @@ -103,7 +116,7 @@ unBoolSig = toGE -- | A constant boolean value. -data BoolD +data BoolD = BoolD (GE E) | PrimBoolD Bool @@ -120,7 +133,7 @@ -- Procedures -- | Csound's empty tuple. -newtype Unit = Unit { unUnit :: GE () } +newtype Unit = Unit { unUnit :: GE () } -- | Constructs Csound's empty tuple. unit :: Unit @@ -136,7 +149,7 @@ -- tables -- | Tables (or arrays) -data Tab +data Tab = Tab (GE E) | TabPre PreTab @@ -152,11 +165,11 @@ , preTabArgs :: TabArgs } -- Table size. -data TabSize +data TabSize -- Size is fixed by the user. = SizePlain Int -- Size is relative to the renderer settings. - | SizeDegree + | SizeDegree { hasGuardPoint :: Bool , sizeDegree :: Int -- is the power of two } @@ -165,9 +178,9 @@ def = SizeDegree { hasGuardPoint = False , sizeDegree = 0 } - + -- Table arguments can be -data TabArgs +data TabArgs -- absolute = ArgsPlain (Reader Int [Double]) {- -- or relative to the table size (used for tables that implement interpolation) @@ -177,7 +190,7 @@ | FileAccess String [Double] renderPreTab :: PreTab -> GE E -renderPreTab a = (fmap D.int . saveGen) =<< fromPreTab a +renderPreTab a = (fmap D.int . saveGen) =<< fromPreTab a getPreTabUnsafe :: String -> Tab -> PreTab getPreTabUnsafe msg x = case x of @@ -200,20 +213,20 @@ defineTabSize :: Int -> TabSize -> Int defineTabSize base x = case x of SizePlain n -> n - SizeDegree guardPoint degree -> + SizeDegree guardPoint degree -> byGuardPoint guardPoint $ byDegree base degree - where byGuardPoint guardPoint + where byGuardPoint guardPoint | guardPoint = (+ 1) | otherwise = id - - byDegree zero n = 2 ^ max 0 (zero + n) + byDegree zero n = 2 ^ max 0 (zero + n) + defineTabArgs :: Int -> TabArgs -> ([Double], Maybe String) defineTabArgs size args = case args of ArgsPlain as -> (runReader as size, Nothing) FileAccess filename as -> (as, Just filename) - + -- | Skips normalization (sets table size to negative value) skipNorm :: Tab -> Tab skipNorm x = case x of @@ -247,12 +260,12 @@ ---------------------------------------------------------------------------- -- Tab of tabs --- | Container list of tables +-- | Container list of tables data TabList = TabList { unTabList :: GE E } tabList :: [Tab] -> TabList tabList xs = TabList $ saveTabs =<< mapM fromPreTab (getPreTabs xs) - where + where getPreTabs xs = case xs of [] -> [] Tab _ : as -> getPreTabs as @@ -289,7 +302,7 @@ -- constants -- | Querries a total duration of the note. It's equivallent to Csound's @p3@ field. -idur :: D +idur :: D idur = fromE $ pn 3 getSampleRate :: D @@ -337,14 +350,14 @@ hideGE :: Val a => GE a -> a hideGE = fromGE . join . fmap toGE -instance Val Sig where - fromGE = Sig - +instance Val Sig where + fromGE = Sig + toGE x = case x of Sig a -> a PrimSig d -> return $ D.double d -instance Val D where +instance Val D where fromGE = D toGE x = case x of D a -> a @@ -356,8 +369,8 @@ instance Val TabList where { fromGE = TabList; toGE = unTabList } -instance Val Tab where - fromGE = Tab +instance Val Tab where + fromGE = Tab toGE = unTab unTab :: Tab -> GE E @@ -370,13 +383,13 @@ TabPre a -> saveGen =<< fromPreTab a Tab _ -> error "table should be primitive" -instance Val BoolSig where - fromGE = BoolSig +instance Val BoolSig where + fromGE = BoolSig toGE x = case x of BoolSig a -> a PrimBoolSig b -> return $ if b then true else false -instance Val BoolD where +instance Val BoolD where fromGE = BoolD toGE x = case x of BoolD a -> a @@ -415,7 +428,7 @@ 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 +instance Default Spec where def = fromE 0 instance Default TabList where def = fromE 0 @@ -439,7 +452,7 @@ _ -> on2 exprFun xa xb -instance Num Sig where +instance Num Sig where { (+) = sigOn2 (+) (+); (*) = sigOn2 (*) (*); negate = sigOn1 negate negate ; (-) = sigOn2 (\a b -> a - b) (\a b -> a - b) ; fromInteger = PrimSig . fromInteger; abs = sigOn1 abs abs; signum = sigOn1 signum signum } @@ -454,7 +467,7 @@ (PrimD a, PrimD b) -> PrimD $ numFun a b _ -> on2 exprFun xa xb -instance Num D where +instance Num D where { (+) = dOn2 (+) (+); (*) = dOn2 (*) (*); negate = dOn1 negate negate ; (-) = dOn2 (\a b -> a - b) (\a b -> a - b) ; fromInteger = PrimD . fromInteger; abs = dOn1 abs abs; signum = dOn1 signum signum } @@ -479,7 +492,7 @@ instance IsPrim Sig where type PrimOf Sig = Double - + getPrim x = case x of PrimSig a -> Just a _ -> Nothing @@ -488,7 +501,7 @@ instance IsPrim D where type PrimOf D = Double - + getPrim x = case x of PrimD a -> Just a _ -> Nothing @@ -497,7 +510,7 @@ instance IsPrim BoolSig where type PrimOf BoolSig = Bool - + getPrim x = case x of PrimBoolSig a -> Just a _ -> Nothing @@ -506,7 +519,7 @@ instance IsPrim BoolD where type PrimOf BoolD = Bool - + getPrim x = case x of PrimBoolD a -> Just a _ -> Nothing @@ -528,8 +541,8 @@ int' = op1 (\x -> fromIntegral ((truncate x) :: Int)) intE round' = op1 (\x -> fromIntegral ((round x) :: Int)) roundE quot' = op2 (\a b -> fromIntegral $ quot ((truncate a) :: Int) ((truncate b):: Int)) quot -rem' = op2 (\a b -> fromIntegral $ rem ((truncate a) :: Int) ((truncate b):: Int)) rem -div' = op2 (\a b -> fromIntegral $ div ((truncate a) :: Int) ((truncate b):: Int)) div +rem' = op2 (\a b -> fromIntegral $ rem ((truncate a) :: Int) ((truncate b):: Int)) rem +div' = op2 (\a b -> fromIntegral $ div ((truncate a) :: Int) ((truncate b):: Int)) div mod' = op2 (\a b -> fromIntegral $ mod ((truncate a) :: Int) ((truncate b):: Int)) mod ------------------------------------------------------------------------------- @@ -539,38 +552,38 @@ boolSigOn1 = op1 boolSigOn2 :: (Bool -> Bool -> Bool) -> (E -> E -> E) -> BoolSig -> BoolSig -> BoolSig -boolSigOn2 = op2 +boolSigOn2 = op2 boolDOn1 :: (Bool -> Bool) -> (E -> E) -> BoolD -> BoolD boolDOn1 = op1 boolDOn2 :: (Bool -> Bool -> Bool) -> (E -> E -> E) -> BoolD -> BoolD -> BoolD -boolDOn2 = op2 +boolDOn2 = op2 instance Boolean BoolSig where { true = PrimBoolSig True; false = PrimBoolSig False; notB = boolSigOn1 not notB; (&&*) = boolSigOn2 (&&) (&&*); (||*) = boolSigOn2 (||) (||*) } instance Boolean BoolD where { true = PrimBoolD True; false = PrimBoolD False; notB = boolDOn1 not notB; (&&*) = boolDOn2 (&&) (&&*); (||*) = boolDOn2 (||) (||*) } -instance IfB Sig where +instance IfB Sig where ifB x a b = case x of PrimBoolSig cond -> if cond then a else b _ -> on3 ifB x a b -instance IfB D where +instance IfB D where ifB x a b = case x of PrimBoolD cond -> if cond then a else b _ -> on3 ifB x a b -instance IfB Tab where +instance IfB Tab where ifB x a b = case x of PrimBoolD cond -> if cond then a else b _ -> on3 ifB x a b -instance IfB Str where +instance IfB Str where ifB x a b = case x of PrimBoolD cond -> if cond then a else b _ -> on3 ifB x a b -instance IfB Spec where +instance IfB Spec where ifB x a b = case x of PrimBoolD cond -> if cond then a else b _ -> on3 ifB x a b @@ -599,7 +612,7 @@ ifBegin (fst a) snd a elseIfs as - elseBegin + elseBegin el foldl1 (>>) $ replicate (length bodies) ifEnd where elseIfs = mapM_ (\(p, body) -> elseBegin >> ifBegin p >> body) @@ -631,7 +644,7 @@ ifBeginD (fst a) snd a elseIfs as - elseBegin + elseBegin el foldl1 (>>) $ replicate (length bodies) ifEnd where elseIfs = mapM_ (\(p, body) -> elseBegin >> ifBeginD p >> body) @@ -699,7 +712,7 @@ notEqualsTo = (/=*) lessThan :: OrdB a => a -> a -> BooleanOf a -lessThan = (<*) +lessThan = (<*) greaterThan :: OrdB a => a -> a -> BooleanOf a greaterThan = (>*) @@ -740,85 +753,7 @@ ------------------------------------------------- -- numeric instances -instance Num Sig2 where - (a1, a2) + (b1, b2) = (a1 + b1, a2 + b2) - (a1, a2) * (b1, b2) = (a1 * b1, a2 * b2) - negate (a1, a2) = (negate a1, negate a2) - - fromInteger n = (fromInteger n, fromInteger n) - signum (a1, a2) = (signum a1, signum a2) - abs (a1, a2) = (abs a1, abs a2) - -instance Fractional Sig2 where - recip (a1, a2) = (recip a1, recip a2) - fromRational n = (fromRational n, fromRational n) - -instance Num Sig3 where - (a1, a2, a3) + (b1, b2, b3) = (a1 + b1, a2 + b2, a3 + b3) - (a1, a2, a3) * (b1, b2, b3) = (a1 * b1, a2 * b2, a3 * b3) - negate (a1, a2, a3) = (negate a1, negate a2, negate a3) - - fromInteger n = (fromInteger n, fromInteger n, fromInteger n) - signum (a1, a2, a3) = (signum a1, signum a2, signum a3) - abs (a1, a2, a3) = (abs a1, abs a2, abs a3) - -instance Fractional Sig3 where - recip (a1, a2, a3) = (recip a1, recip a2, recip a3) - fromRational n = (fromRational n, fromRational n, fromRational n) - -instance Num Sig4 where - (a1, a2, a3, a4) + (b1, b2, b3, b4) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4) - (a1, a2, a3, a4) * (b1, b2, b3, b4) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4) - negate (a1, a2, a3, a4) = (negate a1, negate a2, negate a3, negate a4) - - fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n) - signum (a1, a2, a3, a4) = (signum a1, signum a2, signum a3, signum a4) - abs (a1, a2, a3, a4) = (abs a1, abs a2, abs a3, abs a4) - -instance Fractional Sig4 where - recip (a1, a2, a3, a4) = (recip a1, recip a2, recip a3, recip a4) - fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n) - -instance Num Sig5 where - (a1, a2, a3, a4, a5) + (b1, b2, b3, b4, b5) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5) - (a1, a2, a3, a4, a5) * (b1, b2, b3, b4, b5) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4, a5 * b5) - negate (a1, a2, a3, a4, a5) = (negate a1, negate a2, negate a3, negate a4, negate a5) - - fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n) - signum (a1, a2, a3, a4, a5) = (signum a1, signum a2, signum a3, signum a4, signum a5) - abs (a1, a2, a3, a4, a5) = (abs a1, abs a2, abs a3, abs a4, abs a5) - -instance Fractional Sig5 where - recip (a1, a2, a3, a4, a5) = (recip a1, recip a2, recip a3, recip a4, recip a5) - fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n, fromRational n) - -instance Num Sig6 where - (a1, a2, a3, a4, a5, a6) + (b1, b2, b3, b4, b5, b6) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5, a6 + b6) - (a1, a2, a3, a4, a5, a6) * (b1, b2, b3, b4, b5, b6) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4, a5 * b5, a6 * b6) - negate (a1, a2, a3, a4, a5, a6) = (negate a1, negate a2, negate a3, negate a4, negate a5, negate a6) - - fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n) - signum (a1, a2, a3, a4, a5, a6) = (signum a1, signum a2, signum a3, signum a4, signum a5, signum a6) - abs (a1, a2, a3, a4, a5, a6) = (abs a1, abs a2, abs a3, abs a4, abs a5, abs a6) - -instance Fractional Sig6 where - recip (a1, a2, a3, a4, a5, a6) = (recip a1, recip a2, recip a3, recip a4, recip a5, recip a6) - fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n, fromRational n, fromRational n) - -instance Num Sig7 where - (a1, a2, a3, a4, a5, a6, a7) + (b1, b2, b3, b4, b5, b6, b7) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5, a6 + b6, a7 + b7) - (a1, a2, a3, a4, a5, a6, a7) * (b1, b2, b3, b4, b5, b6, b7) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4, a5 * b5, a6 * b6, a7 * b7) - negate (a1, a2, a3, a4, a5, a6, a7) = (negate a1, negate a2, negate a3, negate a4, negate a5, negate a6, negate a7) - - fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n) - signum (a1, a2, a3, a4, a5, a6, a7) = (signum a1, signum a2, signum a3, signum a4, signum a5, signum a6, signum a7) - abs (a1, a2, a3, a4, a5, a6, a7) = (abs a1, abs a2, abs a3, abs a4, abs a5, abs a6, abs a7) - -instance Fractional Sig7 where - recip (a1, a2, a3, a4, a5, a6, a7) = (recip a1, recip a2, recip a3, recip a4, recip a5, recip a6, recip a7) - fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n, fromRational n, fromRational n, fromRational n) - -instance Num Sig8 where +instance (Num a1, Num a2, Num a3, Num a4, Num a5, Num a6, Num a7, Num a8) => Num (a1, a2, a3, a4, a5, a6, a7, a8) where (a1, a2, a3, a4, a5, a6, a7, a8) + (b1, b2, b3, b4, b5, b6, b7, b8) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5, a6 + b6, a7 + b7, a8 + b8) (a1, a2, a3, a4, a5, a6, a7, a8) * (b1, b2, b3, b4, b5, b6, b7, b8) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4, a5 * b5, a6 * b6, a7 + b7, a8 + b8) negate (a1, a2, a3, a4, a5, a6, a7, a8) = (negate a1, negate a2, negate a3, negate a4, negate a5, negate a6, negate a7, negate a8) @@ -827,97 +762,6 @@ signum (a1, a2, a3, a4, a5, a6, a7, a8) = (signum a1, signum a2, signum a3, signum a4, signum a5, signum a6, signum a7, signum a8) abs (a1, a2, a3, a4, a5, a6, a7, a8) = (abs a1, abs a2, abs a3, abs a4, abs a5, abs a6, abs a7, abs a8) -instance Fractional Sig8 where +instance (Fractional a1, Fractional a2, Fractional a3, Fractional a4, Fractional a5, Fractional a6, Fractional a7, Fractional a8) => Fractional (a1, a2, a3, a4, a5, a6, a7, a8) where recip (a1, a2, a3, a4, a5, a6, a7, a8) = (recip a1, recip a2, recip a3, recip a4, recip a5, recip a6, recip a7, recip a8) fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n, fromRational n, fromRational n, fromRational n, fromRational n) - -instance Num (Sig8, Sig8) where - (a1, a2) + (b1, b2) = (a1 + b1, a2 + b2) - (a1, a2) * (b1, b2) = (a1 * b1, a2 * b2) - negate (a1, a2) = (negate a1, negate a2) - - fromInteger n = (fromInteger n, fromInteger n) - signum (a1, a2) = (signum a1, signum a2) - abs (a1, a2) = (abs a1, abs a2) - -instance Fractional (Sig8, Sig8) where - recip (a1, a2) = (recip a1, recip a2) - fromRational n = (fromRational n, fromRational n) - -instance Num (Sig8, Sig8, Sig8, Sig8) where - (a1, a2, a3, a4) + (b1, b2, b3, b4) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4) - (a1, a2, a3, a4) * (b1, b2, b3, b4) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4) - negate (a1, a2, a3, a4) = (negate a1, negate a2, negate a3, negate a4) - - fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n) - signum (a1, a2, a3, a4) = (signum a1, signum a2, signum a3, signum a4) - abs (a1, a2, a3, a4) = (abs a1, abs a2, abs a3, abs a4) - -instance Fractional (Sig8, Sig8, Sig8, Sig8) where - recip (a1, a2, a3, a4) = (recip a1, recip a2, recip a3, recip a4) - fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n) - -instance Num (Sig2, Sig2) where - (a1, a2) + (b1, b2) = (a1 + b1, a2 + b2) - (a1, a2) * (b1, b2) = (a1 * b1, a2 * b2) - negate (a1, a2) = (negate a1, negate a2) - - fromInteger n = (fromInteger n, fromInteger n) - signum (a1, a2) = (signum a1, signum a2) - abs (a1, a2) = (abs a1, abs a2) - -instance Fractional (Sig2, Sig2) where - recip (a1, a2) = (recip a1, recip a2) - fromRational n = (fromRational n, fromRational n) - -instance Num (Sig2, Sig2, Sig2) where - (a1, a2, a3) + (b1, b2, b3) = (a1 + b1, a2 + b2, a3 + b3) - (a1, a2, a3) * (b1, b2, b3) = (a1 * b1, a2 * b2, a3 * b3) - negate (a1, a2, a3) = (negate a1, negate a2, negate a3) - - fromInteger n = (fromInteger n, fromInteger n, fromInteger n) - signum (a1, a2, a3) = (signum a1, signum a2, signum a3) - abs (a1, a2, a3) = (abs a1, abs a2, abs a3) - -instance Fractional (Sig2, Sig2, Sig2) where - recip (a1, a2, a3) = (recip a1, recip a2, recip a3) - fromRational n = (fromRational n, fromRational n, fromRational n) - -instance Num (Sig2, Sig2, Sig2, Sig2) where - (a1, a2, a3, a4) + (b1, b2, b3, b4) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4) - (a1, a2, a3, a4) * (b1, b2, b3, b4) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4) - negate (a1, a2, a3, a4) = (negate a1, negate a2, negate a3, negate a4) - - fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n) - signum (a1, a2, a3, a4) = (signum a1, signum a2, signum a3, signum a4) - abs (a1, a2, a3, a4) = (abs a1, abs a2, abs a3, abs a4) - -instance Fractional (Sig2, Sig2, Sig2, Sig2) where - recip (a1, a2, a3, a4) = (recip a1, recip a2, recip a3, recip a4) - fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n) - -instance Num (Sig2, Sig2, Sig2, Sig2, Sig2) where - (a1, a2, a3, a4, a5) + (b1, b2, b3, b4, b5) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5) - (a1, a2, a3, a4, a5) * (b1, b2, b3, b4, b5) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4, a5 * b5) - negate (a1, a2, a3, a4, a5) = (negate a1, negate a2, negate a3, negate a4, negate a5) - - fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n) - signum (a1, a2, a3, a4, a5) = (signum a1, signum a2, signum a3, signum a4, signum a5) - abs (a1, a2, a3, a4, a5) = (abs a1, abs a2, abs a3, abs a4, abs a5) - -instance Fractional (Sig2, Sig2, Sig2, Sig2, Sig2) where - recip (a1, a2, a3, a4, a5) = (recip a1, recip a2, recip a3, recip a4, recip a5) - fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n, fromRational n) - -instance Num (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where - (a1, a2, a3, a4, a5, a6) + (b1, b2, b3, b4, b5, b6) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5, a6 + b6) - (a1, a2, a3, a4, a5, a6) * (b1, b2, b3, b4, b5, b6) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4, a5 * b5, a6 * b6) - negate (a1, a2, a3, a4, a5, a6) = (negate a1, negate a2, negate a3, negate a4, negate a5, negate a6) - - fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n) - signum (a1, a2, a3, a4, a5, a6) = (signum a1, signum a2, signum a3, signum a4, signum a5, signum a6) - abs (a1, a2, a3, a4, a5, a6) = (abs a1, abs a2, abs a3, abs a4, abs a5, abs a6) - -instance Fractional (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where - recip (a1, a2, a3, a4, a5, a6) = (recip a1, recip a2, recip a3, recip a4, recip a5, recip a6) - fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n, fromRational n, fromRational n) diff --git a/src/Csound/Typed/Types/SigSpace.hs b/src/Csound/Typed/Types/SigSpace.hs --- a/src/Csound/Typed/Types/SigSpace.hs +++ b/src/Csound/Typed/Types/SigSpace.hs @@ -1,11 +1,11 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# Language - TypeFamilies, - MultiParamTypeClasses, - FlexibleInstances, +{-# Language + TypeFamilies, + MultiParamTypeClasses, + FlexibleInstances, FlexibleContexts #-} module Csound.Typed.Types.SigSpace( - SigSpace(..), BindSig(..), mul, mul', on, uon, At(..), MixAt(..), + SigSpace(..), BindSig(..), mul, mul', on, uon, At(..), MixAt(..), cfd, genCfds, cfd4, cfds, -- * Stereo sig-space @@ -53,17 +53,17 @@ -- rescaling -- | Rescaling of the bipolar signal (-1, 1) -> (a, b) --- +-- -- > on a b biSig on :: SigSpace a => Sig -> Sig -> a -> a -on a b x = uon a b $ mapSig unipolar x +on a b x = uon a b $ mapSig unipolar x where unipolar a = 0.5 + 0.5 * a -- | Rescaling of the unipolar signal (0, 1) -> (a, b) --- +-- -- > on a b uniSig uon :: SigSpace a => Sig -> Sig -> a -> a -uon a b = mapSig (\x -> a + (b - a) * x) +uon a b = mapSig (\x -> a + (b - a) * x) -- | Crossfade. -- @@ -72,16 +72,16 @@ -- If coeff equals 0 then we get the first signal and if it equals 1 we get the second signal. cfd :: (Num a, SigSpace a) => Sig -> a -> a -> a cfd coeff a b = (1 - coeff) `mul` a + coeff `mul` b - + genCfds :: a -> (Sig -> a -> a -> a) -> [Sig] -> [a] -> a genCfds zero mixFun cs xs = case xs of [] -> zero - a:as -> foldl (\x f -> f x) a $ zipWith mix' cs as + a:as -> foldl (\x f -> f x) a $ zipWith mix' cs as where mix' c a b = mixFun c b a -- | Bilinear interpolation for four signals. -- The signals are placed in the corners of the unit square. --- The first two signals are the xy coordinates in the square. +-- The first two signals are the xy coordinates in the square. -- -- > cfd4 x y a b c d -- @@ -92,9 +92,9 @@ -- * (1, 1) is for c -- -- * (0, 1) is for d -cfd4 :: (Num a, SigSpace a) => Sig -> Sig -> a -> a -> a -> a -> a +cfd4 :: (Num a, SigSpace a) => Sig -> Sig -> a -> a -> a -> a -> a cfd4 x y a b c d = sum $ zipWith mul [(1 - x) * (1 - y), x * (1 - y) , x * y, (1 - x) * y] [a, b, c, d] - + -- | Generic crossfade for n coefficients and n+1 signals. -- -- > cfds coeffs sigs @@ -105,59 +105,29 @@ instance SigSpace Sig where mapSig = id instance BindSig Sig where bindSig = id -instance SigSpace (Sig, Sig) where mapSig f (a1, a2) = (f a1, f a2) -instance BindSig (Sig, Sig) where bindSig f (a1, a2) = (,) <$> f a1 <*> f a2 - -instance SigSpace (Sig, Sig, Sig) where mapSig f (a1, a2, a3) = (f a1, f a2, f a3) -instance BindSig (Sig, Sig, Sig) where bindSig f (a1, a2, a3) = (,,) <$> f a1 <*> f a2 <*> f a3 - -instance SigSpace (Sig, Sig, Sig, Sig) where mapSig f (a1, a2, a3, a4) = (f a1, f a2, f a3, f a4) -instance BindSig (Sig, Sig, Sig, Sig) where bindSig f (a1, a2, a3, a4) = (,,,) <$> f a1 <*> f a2 <*> f a3 <*> f a4 - -instance SigSpace (Sig, Sig, Sig, Sig, Sig) where mapSig f (a1, a2, a3, a4, a5) = (f a1, f a2, f a3, f a4, f a5) -instance BindSig (Sig, Sig, Sig, Sig, Sig) where bindSig f (a1, a2, a3, a4, a5) = (,,,,) <$> f a1 <*> f a2 <*> f a3 <*> f a4 <*> f a5 - -instance SigSpace (Sig, Sig, Sig, Sig, Sig, Sig) where mapSig f (a1, a2, a3, a4, a5, a6) = (f a1, f a2, f a3, f a4, f a5, f a6) -instance BindSig (Sig, Sig, Sig, Sig, Sig, Sig) where bindSig f (a1, a2, a3, a4, a5, a6) = (,,,,,) <$> f a1 <*> f a2 <*> f a3 <*> f a4 <*> f a5 <*> f a6 - -instance SigSpace (Sig, Sig, Sig, Sig, Sig, Sig, Sig) where mapSig f (a1, a2, a3, a4, a5, a6, a7) = (f a1, f a2, f a3, f a4, f a5, f a6, f a7) -instance BindSig (Sig, Sig, Sig, Sig, Sig, Sig, Sig) where bindSig f (a1, a2, a3, a4, a5, a6, a7) = (,,,,,,) <$> f a1 <*> f a2 <*> f a3 <*> f a4 <*> f a5 <*> f a6 <*> f a7 - -instance SigSpace (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) where mapSig f (a1, a2, a3, a4, a5, a6, a7, a8) = (f a1, f a2, f a3, f a4, f a5, f a6, f a7, f a8) -instance BindSig (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) where bindSig f (a1, a2, a3, a4, a5, a6, a7, a8) = (,,,,,,,) <$> f a1 <*> f a2 <*> f a3 <*> f a4 <*> f a5 <*> f a6 <*> f a7 <*> f a8 - -instance SigSpace (Sig2, Sig2) where mapSig f (a1, a2) = (mapSig f a1, mapSig f a2) -instance BindSig (Sig2, Sig2) where bindSig f (a1, a2) = (,) <$> bindSig f a1 <*> bindSig f a2 - -instance SigSpace (Sig2, Sig2, Sig2) where mapSig f (a1, a2, a3) = (mapSig f a1, mapSig f a2, mapSig f a3) -instance BindSig (Sig2, Sig2, Sig2) where bindSig f (a1, a2, a3) = (,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 - -instance SigSpace (Sig2, Sig2, Sig2, Sig2) where mapSig f (a1, a2, a3, a4) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4) -instance BindSig (Sig2, Sig2, Sig2, Sig2) where bindSig f (a1, a2, a3, a4) = (,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4 - -instance SigSpace (Sig2, Sig2, Sig2, Sig2, Sig2) where mapSig f (a1, a2, a3, a4, a5) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4, mapSig f a5) -instance BindSig (Sig2, Sig2, Sig2, Sig2, Sig2) where bindSig f (a1, a2, a3, a4, a5) = (,,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4 <*> bindSig f a5 +instance (SigSpace a1, SigSpace a2) => SigSpace (a1, a2) where mapSig f (a1, a2) = (mapSig f a1, mapSig f a2) +instance (BindSig a1, BindSig a2) => BindSig (a1, a2) where bindSig f (a1, a2) = (,) <$> bindSig f a1 <*> bindSig f a2 -instance SigSpace (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where mapSig f (a1, a2, a3, a4, a5, a6) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4, mapSig f a5, mapSig f a6) -instance BindSig (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where bindSig f (a1, a2, a3, a4, a5, a6) = (,,,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4 <*> bindSig f a5 <*> bindSig f a6 +instance (SigSpace a1, SigSpace a2, SigSpace a3) => SigSpace (a1, a2, a3) where mapSig f (a1, a2, a3) = (mapSig f a1, mapSig f a2, mapSig f a3) +instance (BindSig a1, BindSig a2, BindSig a3) => BindSig (a1, a2, a3) where bindSig f (a1, a2, a3) = (,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 -instance SigSpace (Sig8, Sig8) where mapSig f (a1, a2) = (mapSig f a1, mapSig f a2) -instance BindSig (Sig8, Sig8) where bindSig f (a1, a2) = (,) <$> bindSig f a1 <*> bindSig f a2 +instance (SigSpace a1, SigSpace a2, SigSpace a3, SigSpace a4) => SigSpace (a1, a2, a3, a4) where mapSig f (a1, a2, a3, a4) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4) +instance (BindSig a1, BindSig a2, BindSig a3, BindSig a4) => BindSig (a1, a2, a3, a4) where bindSig f (a1, a2, a3, a4) = (,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4 -instance SigSpace (Sig8, Sig8, Sig8, Sig8) where mapSig f (a1, a2, a3, a4) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4) -instance BindSig (Sig8, Sig8, Sig8, Sig8) where bindSig f (a1, a2, a3, a4) = (,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4 +instance (SigSpace a1, SigSpace a2, SigSpace a3, SigSpace a4, SigSpace a5) => SigSpace (a1, a2, a3, a4, a5) where mapSig f (a1, a2, a3, a4, a5) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4, mapSig f a5) +instance (BindSig a1, BindSig a2, BindSig a3, BindSig a4, BindSig a5) => BindSig (a1, a2, a3, a4, a5) where bindSig f (a1, a2, a3, a4, a5) = (,,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4 <*> bindSig f a5 -instance SigSpace (SE Sig) where mapSig f = fmap (mapSig f) -instance BindSig (SE Sig) where bindSig f = fmap (bindSig f) +instance (SigSpace a1, SigSpace a2, SigSpace a3, SigSpace a4, SigSpace a5, SigSpace a6) => SigSpace (a1, a2, a3, a4, a5, a6) where mapSig f (a1, a2, a3, a4, a5, a6) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4, mapSig f a5, mapSig f a6) +instance (BindSig a1, BindSig a2, BindSig a3, BindSig a4, BindSig a5, BindSig a6) => BindSig (a1, a2, a3, a4, a5, a6) where bindSig f (a1, a2, a3, a4, a5, a6) = (,,,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4 <*> bindSig f a5 <*> bindSig f a6 -instance SigSpace (SE (Sig, Sig)) where mapSig f = fmap (mapSig f) -instance BindSig (SE (Sig, Sig)) where bindSig f = fmap (bindSig f) +instance (SigSpace a1, SigSpace a2, SigSpace a3, SigSpace a4, SigSpace a5, SigSpace a6, SigSpace a7) => SigSpace (a1, a2, a3, a4, a5, a6, a7) where mapSig f (a1, a2, a3, a4, a5, a6, a7) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4, mapSig f a5, mapSig f a6, mapSig f a7) +instance (BindSig a1, BindSig a2, BindSig a3, BindSig a4, BindSig a5, BindSig a6, BindSig a7) => BindSig (a1, a2, a3, a4, a5, a6, a7) where bindSig f (a1, a2, a3, a4, a5, a6, a7) = (,,,,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4 <*> bindSig f a5 <*> bindSig f a6 <*> bindSig f a7 -instance SigSpace (SE (Sig, Sig, Sig)) where mapSig f = fmap (mapSig f) -instance BindSig (SE (Sig, Sig, Sig)) where bindSig f = fmap (bindSig f) +instance (SigSpace a1, SigSpace a2, SigSpace a3, SigSpace a4, SigSpace a5, SigSpace a6, SigSpace a7, SigSpace a8) => SigSpace (a1, a2, a3, a4, a5, a6, a7, a8) where mapSig f (a1, a2, a3, a4, a5, a6, a7, a8) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4, mapSig f a5, mapSig f a6, mapSig f a7, mapSig f a8) +instance (BindSig a1, BindSig a2, BindSig a3, BindSig a4, BindSig a5, BindSig a6, BindSig a7, BindSig a8) => BindSig (a1, a2, a3, a4, a5, a6, a7, a8) where bindSig f (a1, a2, a3, a4, a5, a6, a7, a8) = (,,,,,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4 <*> bindSig f a5 <*> bindSig f a6 <*> bindSig f a7 <*> bindSig f a8 -instance SigSpace (SE (Sig, Sig, Sig, Sig)) where mapSig f = fmap (mapSig f) -instance BindSig (SE (Sig, Sig, Sig, Sig)) where bindSig f = fmap (bindSig f) +instance SigSpace a => SigSpace (SE a) where mapSig f = fmap (mapSig f) +instance BindSig a => BindSig (SE a) where bindSig f = fmap (bindSig f) ---------------------------------------------------------------------------------------------------------- @@ -171,79 +141,79 @@ instance SigSpace2 (Sig, Sig) where mapSig2 = id instance BindSig2 (Sig, Sig) where bindSig2 = id -instance SigSpace2 (Sig, Sig, Sig) where +instance SigSpace2 (Sig, Sig, Sig) where mapSig2 f (a1, a2, a3) = (b1, b2, toMono (b3, b4)) where (b1, b2, b3, b4) = mapSig2 f (a1, a2, a3, a4) a4 = a3 -instance BindSig2 (Sig, Sig, Sig) where +instance BindSig2 (Sig, Sig, Sig) where bindSig2 f (a1, a2, a3) = do (b1, b2, b3, b4) <- bindSig2 f (a1, a2, a3, a4) return (b1, b2, toMono (b3, b4)) where a4 = a3 -instance SigSpace2 (Sig, Sig, Sig, Sig) where +instance SigSpace2 (Sig, Sig, Sig, Sig) where mapSig2 f (a1, a2, a3, a4) = (b1, b2, b3, b4) where (b1, b2) = f (a1, a2) (b3, b4) = f (a3, a4) -instance BindSig2 (Sig, Sig, Sig, Sig) where +instance BindSig2 (Sig, Sig, Sig, Sig) where bindSig2 f (a1, a2, a3, a4) = do (b1, b2) <- f (a1, a2) (b3, b4) <- f (a3, a4) - return (b1, b2, b3, b4) + return (b1, b2, b3, b4) -instance SigSpace2 (Sig, Sig, Sig, Sig, Sig) where +instance SigSpace2 (Sig, Sig, Sig, Sig, Sig) where mapSig2 f (a1, a2, a3, a4, a5) = (b1, b2, b3, b4, toMono (b5, b6)) - where + where (b1, b2, b3, b4, b5, b6) = mapSig2 f (a1, a2, a3, a4, a5, a6) a6 = a5 -instance BindSig2 (Sig, Sig, Sig, Sig, Sig) where +instance BindSig2 (Sig, Sig, Sig, Sig, Sig) where bindSig2 f (a1, a2, a3, a4, a5) = do (b1, b2, b3, b4, b5, b6) <- bindSig2 f (a1, a2, a3, a4, a5, a6) return (b1, b2, b3, b4, toMono (b5, b6)) where a6 = a5 -instance SigSpace2 (Sig, Sig, Sig, Sig, Sig, Sig) where +instance SigSpace2 (Sig, Sig, Sig, Sig, Sig, Sig) where mapSig2 f (a1, a2, a3, a4, a5, a6) = (b1, b2, b3, b4, b5, b6) where (b1, b2, b3, b4) = mapSig2 f (a1, a2, a3, a4) (b5, b6) = f (a5, a6) - -instance BindSig2 (Sig, Sig, Sig, Sig, Sig, Sig) where - bindSig2 f (a1, a2, a3, a4, a5, a6) = do + +instance BindSig2 (Sig, Sig, Sig, Sig, Sig, Sig) where + bindSig2 f (a1, a2, a3, a4, a5, a6) = do (b1, b2, b3, b4) <- bindSig2 f (a1, a2, a3, a4) - (b5, b6) <- f (a5, a6) + (b5, b6) <- f (a5, a6) return (b1, b2, b3, b4, b5, b6) -instance SigSpace2 (Sig, Sig, Sig, Sig, Sig, Sig, Sig) where +instance SigSpace2 (Sig, Sig, Sig, Sig, Sig, Sig, Sig) where mapSig2 f (a1, a2, a3, a4, a5, a6, a7) = (b1, b2, b3, b4, b5, b6, toMono (b7, b8)) where (b1, b2, b3, b4, b5, b6, b7, b8) = mapSig2 f (a1, a2, a3, a4, a5, a6, a7, a8) a8 = a7 -instance BindSig2 (Sig, Sig, Sig, Sig, Sig, Sig, Sig) where +instance BindSig2 (Sig, Sig, Sig, Sig, Sig, Sig, Sig) where bindSig2 f (a1, a2, a3, a4, a5, a6, a7) = do (b1, b2, b3, b4, b5, b6, b7, b8) <- bindSig2 f (a1, a2, a3, a4, a5, a6, a7, a8) return (b1, b2, b3, b4, b5, b6, toMono (b7, b8)) where a8 = a7 -instance SigSpace2 (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) where +instance SigSpace2 (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) where mapSig2 f (a1, a2, a3, a4, a5, a6, a7, a8) = (b1, b2, b3, b4, b5, b6, b7, b8) where (b1, b2, b3, b4, b5, b6) = mapSig2 f (a1, a2, a3, a4, a5, a6) (b7, b8) = f (a7, a8) -instance BindSig2 (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) where - bindSig2 f (a1, a2, a3, a4, a5, a6, a7, a8) = do +instance BindSig2 (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) where + bindSig2 f (a1, a2, a3, a4, a5, a6, a7, a8) = do (b1, b2, b3, b4, b5, b6) <- bindSig2 f (a1, a2, a3, a4, a5, a6) - (b7, b8) <- f (a7, a8) + (b7, b8) <- f (a7, a8) return (b1, b2, b3, b4, b5, b6, b7, b8) instance SigSpace2 (Sig2, Sig2) where mapSig2 f (a1, a2) = (mapSig2 f a1, mapSig2 f a2) @@ -261,6 +231,12 @@ instance SigSpace2 (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where mapSig2 f (a1, a2, a3, a4, a5, a6) = (mapSig2 f a1, mapSig2 f a2, mapSig2 f a3, mapSig2 f a4, mapSig2 f a5, mapSig2 f a6) instance BindSig2 (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where bindSig2 f (a1, a2, a3, a4, a5, a6) = (,,,,,) <$> bindSig2 f a1 <*> bindSig2 f a2 <*> bindSig2 f a3 <*> bindSig2 f a4 <*> bindSig2 f a5 <*> bindSig2 f a6 +instance SigSpace2 (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where mapSig2 f (a1, a2, a3, a4, a5, a6, a7) = (mapSig2 f a1, mapSig2 f a2, mapSig2 f a3, mapSig2 f a4, mapSig2 f a5, mapSig2 f a6, mapSig2 f a7) +instance BindSig2 (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where bindSig2 f (a1, a2, a3, a4, a5, a6, a7) = (,,,,,,) <$> bindSig2 f a1 <*> bindSig2 f a2 <*> bindSig2 f a3 <*> bindSig2 f a4 <*> bindSig2 f a5 <*> bindSig2 f a6 <*> bindSig2 f a7 + +instance SigSpace2 (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where mapSig2 f (a1, a2, a3, a4, a5, a6, a7, a8) = (mapSig2 f a1, mapSig2 f a2, mapSig2 f a3, mapSig2 f a4, mapSig2 f a5, mapSig2 f a6, mapSig2 f a7, mapSig2 f a8) +instance BindSig2 (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where bindSig2 f (a1, a2, a3, a4, a5, a6, a7, a8) = (,,,,,,,) <$> bindSig2 f a1 <*> bindSig2 f a2 <*> bindSig2 f a3 <*> bindSig2 f a4 <*> bindSig2 f a5 <*> bindSig2 f a6 <*> bindSig2 f a7 <*> bindSig2 f a8 + instance SigSpace2 (Sig8, Sig8) where mapSig2 f (a1, a2) = (mapSig2 f a1, mapSig2 f a2) instance BindSig2 (Sig8, Sig8) where bindSig2 f (a1, a2) = (,) <$> bindSig2 f a1 <*> bindSig2 f a2 @@ -491,7 +467,7 @@ at f a = join $ bindSig f a ----------------------------------------------------- --- mono to stereo +-- mono to stereo instance At Sig Sig2 Sig where type AtOut Sig Sig2 Sig = Sig2 @@ -509,9 +485,9 @@ type AtOut Sig Sig2 (SE Sig2) = SE Sig2 at f a = fmap (at f) a ---------------------------------------------------------- +--------------------------------------------------------- ---------------------------------------------------------- +--------------------------------------------------------- -- Sig2 -> Sig2 fromMono a = (a, a) @@ -558,23 +534,23 @@ -- | It applies an effect and mixes the processed signal with original one. -- The first argument is for proportion of dry/wet (original/processed). -- It's like @at@ but it allows to balance processed signal with original one. -class (SigSpace b, At a b c) => MixAt a b c where +class (SigSpace b, At a b c) => MixAt a b c where mixAt :: Sig -> (a -> b) -> c -> AtOut a b c --------------------------------------------------- -instance SigSpace a => MixAt Sig Sig a where +instance SigSpace a => MixAt Sig Sig a where mixAt k f a = mapSig (\x -> cfd k x (f x)) a ------------------------------------------------------ -- for (Sig -> SE Sig) -instance MixAt Sig (SE Sig) Sig where +instance MixAt Sig (SE Sig) Sig where mixAt k f dry = do wet <- f dry return $ cfd k dry wet -instance MixAt Sig (SE Sig) Sig2 where +instance MixAt Sig (SE Sig) Sig2 where mixAt k f (dry1, dry2) = do wet1 <- f dry1 wet2 <- f dry2 @@ -587,7 +563,7 @@ wet3 <- f dry3 return $ cfd k (dry1, dry2, dry3) (wet1, wet2, wet3) -instance MixAt Sig (SE Sig) Sig4 where +instance MixAt Sig (SE Sig) Sig4 where mixAt k f (dry1, dry2, dry3, dry4) = do wet1 <- f dry1 wet2 <- f dry2 @@ -595,7 +571,7 @@ wet4 <- f dry4 return $ cfd k (dry1, dry2, dry3, dry4) (wet1, wet2, wet3, wet4) -instance MixAt Sig (SE Sig) (SE Sig) where +instance MixAt Sig (SE Sig) (SE Sig) where mixAt k f dry = do dry1 <- dry wet1 <- f dry1 @@ -626,42 +602,42 @@ return $ cfd k (dry1, dry2, dry3, dry4) (wet1, wet2, wet3, wet4) ----------------------------------------------------- --- mono to stereo +-- mono to stereo instance MixAt Sig Sig2 Sig where mixAt k f dry = cfd k (dry, dry) wet where wet = f dry -instance MixAt Sig Sig2 (SE Sig) where +instance MixAt Sig Sig2 (SE Sig) where mixAt k f dry = fmap (\x -> cfd k (x, x) (f x)) dry -instance MixAt Sig Sig2 Sig2 where +instance MixAt Sig Sig2 Sig2 where mixAt k f dry = cfd k dry wet where wet = 0.5 * (f (fst dry) + f (snd dry)) -instance MixAt Sig Sig2 (SE Sig2) where +instance MixAt Sig Sig2 (SE Sig2) where mixAt k f dry = do (dry1, dry2) <- dry - let wet = 0.5 * (f dry1 + f dry2) + let wet = 0.5 * (f dry1 + f dry2) return $ cfd k (dry1, dry2) wet ---------------------------------------------------------- +--------------------------------------------------------- ---------------------------------------------------------- +--------------------------------------------------------- -- Sig2 -> Sig2 -instance MixAt Sig2 Sig2 Sig where +instance MixAt Sig2 Sig2 Sig where mixAt k f dry1 = cfd k dry wet - where + where dry = fromMono dry1 wet = f dry -instance MixAt Sig2 Sig2 Sig2 where +instance MixAt Sig2 Sig2 Sig2 where mixAt k f dry = cfd k dry wet where wet = f dry -instance MixAt Sig2 Sig2 (SE Sig) where +instance MixAt Sig2 Sig2 (SE Sig) where mixAt k f dry1 = do dry <- fmap fromMono dry1 let wet = f dry @@ -677,19 +653,19 @@ --------------------------------------------- -- Sig2 -> SE Sig2 -instance MixAt Sig2 (SE Sig2) Sig where +instance MixAt Sig2 (SE Sig2) Sig where mixAt k f dry1 = do wet <- f dry return $ cfd k dry wet where dry = fromMono dry1 -instance MixAt Sig2 (SE Sig2) Sig2 where +instance MixAt Sig2 (SE Sig2) Sig2 where mixAt k f dry = do wet <- f dry return $ cfd k dry wet -instance MixAt Sig2 (SE Sig2) (SE Sig) where +instance MixAt Sig2 (SE Sig2) (SE Sig) where mixAt k f dry1 = do dry <- fmap fromMono dry1 wet <- f dry diff --git a/src/Csound/Typed/Types/Tuple.hs b/src/Csound/Typed/Types/Tuple.hs --- a/src/Csound/Typed/Types/Tuple.hs +++ b/src/Csound/Typed/Types/Tuple.hs @@ -1,15 +1,15 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# Language +{-# Language TypeFamilies, FlexibleContexts, FlexibleInstances #-} module Csound.Typed.Types.Tuple( -- ** Tuple - Tuple(..), TupleMethods, makeTupleMethods, + Tuple(..), TupleMethods, makeTupleMethods, fromTuple, toTuple, tupleArity, tupleRates, defTuple, mapTuple, - + -- ** Outs - Sigs, outArity, + Sigs, outArity, Sig2s, -- *** Multiple outs multiOuts, @@ -34,6 +34,8 @@ import Data.Default import Data.Boolean +import Data.NumInstances.Tuple + import Csound.Dynamic import Csound.Typed.Types.Prim import Csound.Typed.Types.SigSpace @@ -52,7 +54,7 @@ , tupleRates_ :: a -> [Rate] , defTuple_ :: a } -fromTuple :: Tuple a => a -> GE [E] +fromTuple :: Tuple a => a -> GE [E] fromTuple = fromTuple_ tupleMethods toTuple :: Tuple a => GE [E] -> a @@ -72,9 +74,9 @@ -- | 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 +makeTupleMethods to from = TupleMethods { fromTuple_ = fromTuple . from - , toTuple_ = to . toTuple + , toTuple_ = to . toTuple , tupleArity_ = const $ tupleArity $ proxy to , tupleRates_ = tupleRates . from , defTuple_ = to defTuple } @@ -84,7 +86,7 @@ -- Tuple instances primTupleMethods :: (Val a, Default a) => Rate -> TupleMethods a -primTupleMethods rate = TupleMethods +primTupleMethods rate = TupleMethods { fromTuple_ = fmap return . toGE , toTuple_ = fromGE . fmap head , tupleArity_ = const 1 @@ -92,14 +94,14 @@ , defTuple_ = def } instance Tuple Unit where - tupleMethods = TupleMethods + 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 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 @@ -107,16 +109,16 @@ instance Tuple TabList where tupleMethods = primTupleMethods Kr -instance (Tuple a, Tuple b) => Tuple (a, b) where +instance (Tuple a, Tuple b) => Tuple (a, b) where tupleMethods = TupleMethods fromTuple' toTuple' tupleArity' tupleRates' defTuple' - where + 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) + proxy = const (undefined, undefined) toTuple' xs = (a, b) where a = toTuple $ fmap (take (tupleArity a)) xs - xsb = fmap (drop (tupleArity a)) xs + xsb = fmap (drop (tupleArity a)) xs b = toTuple $ fmap (take (tupleArity b)) xsb tupleRates' (a, b) = tupleRates a ++ tupleRates b @@ -142,31 +144,29 @@ 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 +ar1 = id; ar2 = id; ar4 = id; ar6 = id; ar8 = id --------------------------------------------------------------------------------- -- out instances -- | The tuples of signals. -class (Tuple a, Num a, Fractional a, SigSpace a, BindSig a, SigSpace2 a, BindSig2 a) => Sigs a where +class (Tuple a, Num a, Fractional a, SigSpace a, BindSig a) => Sigs a where +class (Sigs a, SigSpace2 a, BindSig2 a) => Sig2s a where instance Sigs Sig -instance Sigs Sig2 -instance Sigs Sig3 -instance Sigs Sig4 -instance Sigs Sig5 -instance Sigs Sig6 -instance Sigs Sig7 -instance Sigs Sig8 - -instance Sigs (Sig2, Sig2) -instance Sigs (Sig2, Sig2, Sig2) -instance Sigs (Sig2, Sig2, Sig2, Sig2) -instance Sigs (Sig2, Sig2, Sig2, Sig2, Sig2) -instance Sigs (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) +instance (Sigs a1, Sigs a2) => Sigs (a1, a2) +instance (Sigs a1, Sigs a2, Sigs a3) => Sigs (a1, a2, a3) +instance (Sigs a1, Sigs a2, Sigs a3, Sigs a4) => Sigs (a1, a2, a3, a4) +instance (Sigs a1, Sigs a2, Sigs a3, Sigs a4, Sigs a5) => Sigs (a1, a2, a3, a4, a5) +instance (Sigs a1, Sigs a2, Sigs a3, Sigs a4, Sigs a5, Sigs a6) => Sigs (a1, a2, a3, a4, a5, a6) +instance (Sigs a1, Sigs a2, Sigs a3, Sigs a4, Sigs a5, Sigs a6, Sigs a7) => Sigs (a1, a2, a3, a4, a5, a6, a7) +instance (Sigs a1, Sigs a2, Sigs a3, Sigs a4, Sigs a5, Sigs a6, Sigs a7, Sigs a8) => Sigs (a1, a2, a3, a4, a5, a6, a7, a8) -instance Sigs (Sig8, Sig8) -instance Sigs (Sig8, Sig8, Sig8, Sig8) +instance Sig2s Sig +instance Sig2s Sig2 +instance Sig2s Sig4 +instance Sig2s Sig6 +instance Sig2s Sig8 outArity :: Tuple a => SE a -> Int outArity = tupleArity . proxy @@ -205,10 +205,10 @@ toNote :: Arg a => a -> GE [E] toNote a = zipWithM phi (tupleRates a) =<< fromTuple a where - phi rate x = case rate of + 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" @@ -229,7 +229,7 @@ type instance BooleanOf BoolTuple = BoolSig instance IfB BoolTuple where - ifB mp (BoolTuple mas) (BoolTuple mbs) = BoolTuple $ + 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. @@ -257,7 +257,7 @@ type instance BooleanOf BoolArg = BoolD instance IfB BoolArg where - ifB mp (BoolArg mas) (BoolArg mbs) = BoolArg $ + ifB mp (BoolArg mas) (BoolArg mbs) = BoolArg $ liftA3 (\p as bs -> zipWith (ifB p) as bs) (toGE mp) mas mbs -- | @ifB@ for constants. @@ -281,11 +281,9 @@ dirtyTuple :: Tuple a => GE (MultiOut [E]) -> SE a dirtyTuple a = res - where - res = fmap (toTuple . return) $ SE + where + res = fmap (toTuple . return) $ SE $ mapM depT =<< (lift $ fmap ($ (tupleArity $ proxy res)) a) proxy :: SE a -> a proxy = const undefined - -