diff --git a/csound-expression.cabal b/csound-expression.cabal --- a/csound-expression.cabal +++ b/csound-expression.cabal @@ -1,5 +1,5 @@ Name: csound-expression -Version: 5.1.0 +Version: 5.2.0 Cabal-Version: >= 1.6 License: BSD3 License-file: LICENSE @@ -79,8 +79,8 @@ Ghc-Options: -Wall Build-Depends: base >= 4, base < 5, process, data-default, Boolean >= 0.1.0, colour >= 2.0, transformers >= 0.3, containers, - csound-expression-typed >= 0.1.0.0, csound-expression-dynamic >= 0.2.0, temporal-media >= 0.6.1, - csound-expression-opcodes >= 0.0.3.1 + csound-expression-typed >= 0.2.0.0, csound-expression-dynamic >= 0.3.0, temporal-media >= 0.6.1, + csound-expression-opcodes >= 0.0.3.2 Hs-Source-Dirs: src/ Exposed-Modules: Csound.Base @@ -96,6 +96,7 @@ Csound.Air.Wav Csound.Air.Spec Csound.Air.Fx + Csound.Air.Fx.FxBox Csound.Air.Live Csound.Air.Seg Csound.Air.Sampler @@ -135,5 +136,4 @@ Csound.Control.Overload Csound.Control.Overload.Outs Csound.Control.Overload.MidiInstr - Csound.Control.Overload.SpecInstr - + Csound.Control.Overload.SpecInstr diff --git a/src/Csound/Air.hs b/src/Csound/Air.hs --- a/src/Csound/Air.hs +++ b/src/Csound/Air.hs @@ -26,6 +26,7 @@ -- | Effects: reverbs, choruses, delays etc. module Csound.Air.Fx, + module Csound.Air.Fx.FxBox, -- | Widgets to make live performances. module Csound.Air.Live, @@ -65,6 +66,7 @@ import Csound.Air.Granular.Morpheus import Csound.Air.Spec import Csound.Air.Fx +import Csound.Air.Fx.FxBox import Csound.Air.Live import Csound.Air.Looper import Csound.Air.Patch diff --git a/src/Csound/Air/Envelope.hs b/src/Csound/Air/Envelope.hs --- a/src/Csound/Air/Envelope.hs +++ b/src/Csound/Air/Envelope.hs @@ -4,7 +4,7 @@ leg, xeg, -- ADSR with retrigger for mono-synths - adsr140, + adsr140, trigTab, -- * Relative duration onIdur, lindur, expdur, linendur, onDur, lindurBy, expdurBy, linendurBy, @@ -36,7 +36,6 @@ seqAdsr, xseqAdsr, seqAdsr_, xseqAdsr_, seqPat, seqAsc, seqDesc, seqHalf - ) where import Control.Monad @@ -52,7 +51,8 @@ import Csound.Tab(lins, exps, gp) import Csound.Air.Wave(oscBy) import Csound.Air.Filter(slide) -import Csound.Typed.Plugins(adsr140) +import Csound.Typed.Plugins(adsr140, delay1k) +import Csound.Control.Evt(evtToTrig) -- | Linear adsr envelope generator with release -- @@ -892,3 +892,23 @@ where human1 (n, a) | mod n 2 == 1 = rndValD drVal a | otherwise = rndValD drTime a + + +----------------------------------------------------- +-- Trigger envelopes + +-- | Triggers the table based envelope when the trigger signal equals to 1 +-- and plays for dur seconds: +-- +-- > trigTab table dur trigger +trigTab :: Tab -> Sig -> Sig -> Sig +trigTab ifn kdur ktrig = + tablei (lineto ktrig (kdur * delay1 ktrig)) ifn `withD` 1 + + +-- | Triggers the table based envelope when the something happens on the event stream +-- and plays for dur seconds: +-- +-- > trigTabEvt table dur trigger +trigTabEvt :: Tab -> Sig -> Evt a -> Sig +trigTabEvt ifn kdur ktrig = trigTab ifn kdur (evtToTrig ktrig) diff --git a/src/Csound/Air/Filter.hs b/src/Csound/Air/Filter.hs --- a/src/Csound/Air/Filter.hs +++ b/src/Csound/Air/Filter.hs @@ -14,7 +14,7 @@ -- * Filter order ResonFilter, FlatFilter, - filt, flatFilt, + filt, flatFilt, toReson, -- * Specific filters @@ -76,6 +76,8 @@ multiStatevar, multiSvfilter ) where +import Control.Applicative + import Csound.Typed import Csound.Typed.Plugins import Csound.SigSpace(bat) @@ -168,6 +170,10 @@ -- -- > f centerFreq q asig type FlatFilter = Sig -> Sig -> Sig + +-- | Makes fake resonant filter from flat filter. The resulting filter just ignores the resonance. +toReson :: FlatFilter -> ResonFilter +toReson filter = \cfq res -> filter cfq -- | Applies a filter n-times. The n is given in the first rgument. filt :: Int -> ResonFilter -> ResonFilter diff --git a/src/Csound/Air/Fx.hs b/src/Csound/Air/Fx.hs --- a/src/Csound/Air/Fx.hs +++ b/src/Csound/Air/Fx.hs @@ -18,7 +18,7 @@ -- * Delays MaxDelayTime, DelayTime, Feedback, Balance, - echo, fdelay, fvdelay, fvdelays, funDelays, tabDelay, + echo, fvdelay, fvdelays, funDelays, tabDelay, PingPongSpec(..), pingPong, pingPong', csdPingPong, -- * Distortion @@ -36,17 +36,25 @@ phase1, harmPhase, powerPhase, -- * Effects with unit parameters - fxDistort, fxDistort2, stChorus2, fxPhaser, fxPhaser2, - fxFlanger, fxFlanger2, analogDelay, analogDelay2, fxEcho, fxEcho2, - fxFilter, fxFilter2, - fxWhite, fxWhite2, fxPink, fxPink2, equalizer, equalizer2, eq4, eq7, + -- | Implemented by Iain McCurdy's Csound code. + + DriveSig, SensitivitySig, BaseCps, Resonance, TimeSig, BitsReductionSig, FoldoverSig, + TremWaveSig, RatioSig, FftSize, + + fxDistort, stChorus2, fxPhaser, + fxFlanger, analogDelay, fxEcho, fxFilter, + fxWhite, fxPink, equalizer, eq4, eq7, fxGain, + fxAnalogDelay, fxDistortion, fxFollower, fxReverse, fxLoFi, fxChorus2, fxAutoPan, fxTrem, fxPitchShifter, fxFreqShifter, {- , + fxRingModulator, , -} + fxCompress, + -- Eq audaciousEq, -- * Misc - trackerSplice + trackerSplice, pitchShifterDelay ) where @@ -61,8 +69,14 @@ import Csound.Air.Wave(Lfo, unipolar, oscBy, utri, white, pink) import Csound.Air.Filter -import Csound.Typed.Plugins +import Csound.Typed.Plugins hiding(pitchShifterDelay, + fxAnalogDelay, fxDistortion, fxEnvelopeFollower, fxFlanger, fxFreqShifter, fxLoFi, + fxPanTrem, fxPhaser, fxPitchShifter, fxReverse, fxRingModulator, fxChorus2) +import qualified Csound.Typed.Plugins as P(pitchShifterDelay, + fxAnalogDelay, fxDistortion, fxEnvelopeFollower, fxFlanger, fxFreqShifter, fxLoFi, + fxPanTrem, fxPhaser, fxPitchShifter, fxReverse, fxRingModulator, fxChorus2, fxPingPong) + -- | Mono version of the cool reverberation opcode reverbsc. -- -- > reverbsc1 asig feedbackLevel cutOffFreq @@ -216,24 +230,14 @@ -- | The simplest delay with feedback. Arguments are: delay length and decay ratio. -- -- > echo delayLength ratio -echo :: MaxDelayTime -> Feedback -> Sig -> SE Sig -echo len fb = fdelay len fb 1 - --- | Delay with feedback. --- --- > fdelay delayLength decayRatio balance -fdelay :: MaxDelayTime -> Feedback -> Balance -> Sig -> SE Sig -fdelay len = fvdelay len (sig len) +echo :: MaxDelayTime -> Feedback -> Sig -> Sig +echo len fb x = x + flanger x (sig len) fb `withD` (len + 0.005) -- | Delay with feedback. -- -- > fdelay maxDelayLength delayLength feedback balance -fvdelay :: MaxDelayTime -> DelayTime -> Feedback -> Balance -> Sig -> SE Sig -fvdelay len dt fb mx a = do - _ <- delayr len - aDel <- deltap3 dt - delayw $ a + fb * aDel - return $ a + (aDel * mx) +fvdelay :: MaxDelayTime -> DelayTime -> Feedback -> Sig -> Sig +fvdelay len dt fb a = a + flanger a dt fb `withD` len -- | Multitap delay. Arguments are: max delay length, list of pairs @(delayLength, decayRatio)@, -- balance of mixed signal with processed signal. @@ -293,25 +297,31 @@ def = PingPongSpec { pingPongMaxTime = 5, pingPongDamp = 3500, - pingPongWidth = 0.3 + pingPongWidth = 0.6 } -- | Ping-pong delay. -- -- > pingPong delayTime feedback mixLevel -pingPong :: DelayTime -> Feedback -> Balance -> Sig2 -> SE Sig2 +pingPong :: DelayTime -> Feedback -> Balance -> Sig2 -> Sig2 pingPong delTime feedback mixLevel (ainL, ainR) = pingPong' def delTime feedback mixLevel (ainL, ainR) -- | Ping-pong delay with miscellaneous arguments. -- -- > pingPong' spec delayTime feedback mixLevel -pingPong' :: PingPongSpec -> DelayTime -> Feedback -> Balance -> Sig2 -> SE Sig2 +pingPong' :: PingPongSpec -> DelayTime -> Feedback -> Balance -> Sig2 -> Sig2 pingPong' (PingPongSpec maxTime damp width) delTime feedback mixLevel (ainL, ainR) = csdPingPong maxTime delTime damp feedback width mixLevel (ainL, ainR) -- | Ping-pong delay defined in csound style. All arguments are present (nothing is hidden). -- -- > csdPingPong maxTime delTime damp feedback width mixLevel (ainL, ainR) +csdPingPong :: MaxDelayTime -> DelayTime -> Sig -> Feedback -> Sig -> Balance -> Sig2 -> Sig2 +csdPingPong maxTime delTime damp feedback width mixLevel (ainL, ainR) = P.fxPingPong maxTime mixLevel width damp delTime feedback (ainL, ainR) + +-- fxPingPong iMaxDelTime kmix kwidth ktone ktime kfeedback (ainL, ainR) = ... + +{- substituted with Csound UDO implementation csdPingPong :: MaxDelayTime -> DelayTime -> Sig -> Feedback -> Sig -> Balance -> Sig2 -> SE Sig2 csdPingPong maxTime delTime damp feedback width mixLevel (ainL, ainR) = do afirst <- offsetDelay ainL @@ -336,6 +346,7 @@ widthControl afirst (atapL, atapR) = (afirst + atapL + (1 - width) * atapR, atapR + (1 - width) * atapL) mixControl (atapL ,atapR) = (cfd mixLevel ainL atapL, cfd mixLevel ainR atapR) +-} type DepthSig = Sig type RateSig = Sig @@ -426,14 +437,8 @@ kLPF = logScale 700 (200, 12000) ktone --- | Stereo distortion. -fxDistort2 :: Feedback -> Sig -> ToneSig -> Sig2 -> Sig2 -fxDistort2 klevel kdrive ktone (al, ar) = (fx al, fx ar) - where fx = fxDistort klevel kdrive ktone - -- Stereo chorus - -- | Stereo chorus. -- -- > stChorus2 mix rate depth width sigIn @@ -452,70 +457,13 @@ aoutL = 0.6 * (aChoL + al) aoutR = 0.6 * (aChoR + ar) --- Phaser - --- | Phaser --- --- > fxPhaser mix rate depth freq feedback sigIn -fxPhaser ::Balance -> Feedback -> RateSig -> DepthSig -> Sig -> Sig -> Sig -fxPhaser kmix fb krate' kdepth kfreq ain = fxWet kmix ain aout - where - krate = expScale 10 (0.01, 14) krate' - klfo = kdepth * utri krate - aout = phaser1 ain (cpsoct $ klfo + kfreq) 8 fb - --- | Stereo phaser. -fxPhaser2 :: Balance -> Feedback -> RateSig -> DepthSig -> Sig -> Sig2 -> Sig2 -fxPhaser2 kmix fb krate kdepth kfreq (al, ar) = (fx al, fx ar) - where fx = fxPhaser kmix fb krate kdepth kfreq - --- Flanger - --- | Flanger --- --- > fxFlanger mix feedback rate depth delay sigIn -fxFlanger :: Balance -> Feedback -> RateSig -> DepthSig -> DelayTime -> Sig -> Sig -fxFlanger kmix kfback krate' kdepth kdelay' ain = fxWet kmix ain aout - where - krate = expScale 50 (0.001, 14) krate' - kdelay = expScale 200 (0.0001, 0.1) kdelay' - ilfoshape = setSize 131072 $ sines4 [(0.5, 1, 180, 1)] - kporttime = linseg [0, 0.001, 0.1] - adlt = interp $ portk kdelay kporttime - kdep = portk (kdepth*0.01) kporttime - amod = oscili kdep krate ilfoshape - adelsig = flanger ain (adlt + amod) kfback `withD` 1.2 - aout = mean [ain, adelsig] - --- | Stereo flanger -fxFlanger2 :: Balance -> Feedback -> RateSig -> DepthSig -> DelayTime -> Sig2 -> Sig2 -fxFlanger2 kmix kfback krate kdepth kdelay (al ,ar) = (fx al, fx ar) - where fx = fxFlanger kmix kfback krate kdepth kdelay - -- Analog delay -- | Analog delay. -- -- > analogDelay mix feedback time tone sigIn -analogDelay :: Balance -> Feedback -> DelayTime -> ToneSig -> Sig -> SE Sig -analogDelay kmix kfback ktime ktone' ain = do - aBuffer <- delayr 5 - atap <- deltap3 aTime - let atap1 = tone (clip atap 0 1) kTone - delayw $ ain + atap1*kfback - return $ ain*kDry + atap1 * kWet - where - ktone = expScale 4 (100, 12000) ktone' - (kDry, kWet) = dryWetMix kmix - kporttime = linseg [0,0.001,0.1] - kTime = portk ktime (kporttime*3) - kTone = portk ktone kporttime - aTime = interp kTime - --- | Stereo analog delay. -analogDelay2 :: Balance -> Feedback -> DelayTime -> ToneSig -> Sig2 -> SE Sig2 -analogDelay2 kmix kfback ktime ktone = bindSig fx - where fx = analogDelay kmix kfback ktime ktone +analogDelay :: Balance -> Feedback -> DelayTime -> ToneSig -> Sig -> Sig +analogDelay kmix kfback ktime ktone ain = P.fxAnalogDelay kmix kfback ktime ktone ain -- Filter @@ -531,11 +479,6 @@ kgain = scale kgain' 20 0 scaleFreq x = expScale 4 (20, 20000) x --- | Stereo filter effect (a pair of butterworth low and high pass filters). -fxFilter2 :: Sig -> Sig -> Sig -> Sig2 -> Sig2 -fxFilter2 kLPF kHPF kgain (al, ar) = (fx al, fx ar) - where fx = fxFilter kLPF kHPF kgain - -- Equalizer -- | Equalizer @@ -555,26 +498,20 @@ kgain = table gain iGainCurve `withD` 1 ain = kgain * ain0 --- | Stereo equalizer. -equalizer2 :: [(Sig, Sig)] -> Sig -> Sig2 -> Sig2 -equalizer2 fs gain (al, ar) = (fx al, fx ar) - where fx = equalizer fs gain - -- | Equalizer with frequencies: 100, 200, 400, 800, 1600, 3200, 6400 -eq7 :: [Sig] -> Sig -> Sig2 -> Sig2 -eq7 gs = equalizer2 (zip gs $ fmap (100 * ) [1, 2, 4, 8, 16, 32, 64]) +eq7 :: [Sig] -> Sig -> Sig -> Sig +eq7 gs = equalizer (zip gs $ fmap (100 * ) [1, 2, 4, 8, 16, 32, 64]) -- | Equalizer with frequencies: 100, 400, 1600, 6400 -eq4 :: [Sig] -> Sig -> Sig2 -> Sig2 -eq4 gs = equalizer2 (zip gs $ fmap (100 * ) [1, 4, 16, 64]) +eq4 :: [Sig] -> Sig -> Sig -> Sig +eq4 gs = equalizer (zip gs $ fmap (100 * ) [1, 4, 16, 64]) -- | Gain -- -- > fxGain gain sigIn -fxGain :: Sig -> Sig2 -> Sig2 +fxGain :: SigSpace a => Sig -> a -> a fxGain = mul - -- Noise -- | Adds filtered white noize to the signal @@ -586,11 +523,6 @@ return $ ain + 0.5 * depth * blp cps noise where cps = expScale 4 (20, 20000) freq --- | Adds filtered white noize to the stereo signal -fxWhite2 ::Sig -> Sig -> Sig2 -> SE Sig2 -fxWhite2 freq depth = bindSig fx - where fx = fxWhite freq depth - -- | Adds filtered pink noize to the signal -- -- > fxWhite lfoFreq depth sigIn @@ -600,30 +532,17 @@ return $ ain + 0.5 * depth * blp cps noise where cps = expScale 4 (20, 20000) freq --- | Adds filtered pink noize to the stereo signal -fxPink2 ::Sig -> Sig -> Sig2 -> SE Sig2 -fxPink2 freq depth = bindSig fx - where fx = fxPink freq depth - -- Echo -- | Simplified delay -- -- > fxEcho maxDelayLength delTime feedback sigIn -fxEcho :: D -> Sig -> Sig -> Sig -> SE Sig -fxEcho maxLen ktime fback = fvdelay (5 * maxLen) (sig maxLen * 0.95 * kTime) fback 1 +fxEcho :: D -> Sig -> Sig -> Sig -> Sig +fxEcho maxLen ktime fback = fvdelay (5 * maxLen) (sig maxLen * 0.95 * kTime) fback where kporttime = linseg [0,0.001,0.1] kTime = portk ktime (kporttime*3) --- | Simplified stereo delay. -fxEcho2 :: D -> Sig -> Sig -> Sig2 -> SE Sig2 -fxEcho2 maxLen ktime fback = bindSig fx - where fx = fxEcho maxLen ktime fback - - - - -- | Instrument plays an input signal in different modes. -- The segments of signal can be played back and forth. -- @@ -695,3 +614,247 @@ -- | Mean value. mean :: Fractional a => [a] -> a mean xs = sum xs / (fromIntegral $ length xs) + +--------------------------------------------------- +-- rename the arguments and comment + +-- | PitchShifterDelay +-- +-- A pitch shifter effect that employs delay lines +-- +-- > pitchShifterDelay maxDelayTime delayTime (feedback1, feedback2) transposeRatio ain +-- +-- Arguments +-- +-- * @maxDelayTime @ -- maximum delay time (kdlt should not exceed this value) +-- +-- * @transposeRatio @ -- pitch transposition (in semitones) +-- +-- * @delayTime @ -- delay time employed by the pitch shifter effect (should be within the range ksmps/sr and imaxdlt) +-- +-- * @feedback1 @ -- feedback using method 1 (output from delay taps are fed back directly into their own buffers before enveloping and mixing) +-- +-- * @feedback2 @ -- feedback using method 2 (enveloped and mixed output from both taps is fed back into both buffers)-- +-- +-- * @ain @ -- input audio to be pitch shifted +pitchShifterDelay :: MaxDelayTime -> (Feedback, Feedback) -> DelayTime -> Sig -> Sig -> Sig +pitchShifterDelay maxDelayTime (fb1, fb2) dlt ratio ain = P.pitchShifterDelay maxDelayTime (fb1, fb2) dlt ratio ain + +-- | Delay line with low-pass filter in the feedback chain. +-- The filter adds natural decay to the echoes. +-- +-- > fxAnalogDelay mixRatio delayTime feedback toneRatio ain +-- +-- Note that the center frequency of the filter is measured in normalized units (form 0 to 1). +fxAnalogDelay :: Balance -> DelayTime -> Feedback -> ToneSig -> Sig -> Sig +fxAnalogDelay kmix kdelay kfback ktone ain = P.fxAnalogDelay kmix kdelay kfback ktone ain + +type DriveSig = Sig + +-- | Distortion unit with low-pass filter. +-- +-- > fxDistortion driveLevel toneRatio ain +-- +-- Note that the center frequency of the filter is measured in normalized units (form 0 to 1). +fxDistortion :: DriveSig -> ToneSig -> Sig -> Sig +fxDistortion kdrive ktone ain = P.fxDistortion 1 kdrive ktone ain + +type SensitivitySig = Sig +type BaseCps = Sig +type Resonance = Sig + +-- | Envelope follower. +-- +-- > fxFollower sensitivity baseFrequencyRatio resonance ain +-- +-- Arguments: +-- +-- * @sensitivity @ -- sensitivity of the envelope follower (suggested range: 0 to 1) +-- +-- * @baseFrequencyRatio @ -- base frequency of the filter before modulation by the input dynamics (range: 0 to 1) +-- +-- ; @resonance @ -- resonance of the lowpass filter (suggested range: 0 to 1) +fxFollower :: SensitivitySig -> BaseCps -> Resonance -> Sig -> Sig +fxFollower ksens kbaseFreq kreson = P.fxEnvelopeFollower ksens kbaseFreq (0.99 * kreson) + +type TimeSig = Sig + +-- | An effect that reverses an audio stream in chunks +-- +-- > fxReverse time +-- +-- @time@ -- the size of the chunck in seconds. +fxReverse :: TimeSig -> Sig -> Sig +fxReverse ktime = P.fxReverse ktime + +-- | A flanger effect following the typical design of a so called 'stomp box' +-- +-- > fxFlanger rate depth delayTime feedback ain = +-- +-- Arguments +-- +-- * @rate @ -- rate control of the lfo of the effect *NOT IN HERTZ* (range 0 to 1) +-- +-- * @depth @ -- depth of the lfo of the effect (range 0 to 1) +-- +-- * @delayTime @ -- static delay offset of the flanging effect (range 0 to 1) +-- +-- * @feedback @ -- feedback and therefore intensity of the effect (range 0 to 1) +-- +-- * @ain @ -- input audio to which the flanging effect will be applied +fxFlanger :: RateSig -> DepthSig -> DelayTime -> Feedback -> Sig -> Sig +fxFlanger krate kdepth kdelay kfback ain = P.fxFlanger krate kdepth kdelay kfback ain + +-- | Phaser +-- +-- An phase shifting effect that mimics the design of a so called 'stomp box' +-- +-- > fxPhaser rate depth freq fback ain +-- +-- Arguments: +-- +-- * @rate @ -- rate of lfo of the effect (range 0 to 1) +-- +-- * @depth @ -- depth of lfo of the effect (range 0 to 1) +-- +-- * @freq @ -- centre frequency of the phase shifting effect in octaves (suggested range 6 to 11) +-- +-- * @fback @ -- feedback and therefore intensity of the effect (range 0 to 1) +-- +-- * @ain @ -- input audio to be pitch shifted +fxPhaser :: RateSig -> DepthSig -> BaseCps -> Feedback -> Sig -> Sig +fxPhaser krate kdepth cps kfback ain = P.fxPhaser krate kdepth (6 + 5 * cps) kfback ain + +type BitsReductionSig = Sig +type FoldoverSig = Sig + +-- | LoFi +-- +-- 'Low Fidelity' distorting effects of bit reduction and downsampling (foldover) +-- +-- > fxLoFi bits fold ain = ... +-- +-- Arguments +-- +-- * @bits @ -- bit depth reduction (range 0 to 1) +-- +-- * @fold @ -- amount of foldover (range 0 to 1) +-- +-- * @ain @ -- input audio to have low fidelity distortion effects applied +fxLoFi :: BitsReductionSig -> FoldoverSig -> Sig -> Sig +fxLoFi kbits kfold ain = P.fxLoFi (0.6 * kbits) kfold ain + +-- | Stereo Chorus +-- +-- A stereo chorus effect +-- +-- > fxChorus2 rate depth width (ainLeft, ainRight) +-- +-- Arguments +-- +-- * @rate @ -- rate control of the lfo of the effect *NOT IN HERTZ* (range 0 to 1) +-- +-- * @depth @ -- depth of the lfo of the effect (range 0 to 1) +-- +-- * @width @ -- width of stereo widening (range 0 to 1) +-- +-- * @ainX @ -- input stereo signal +fxChorus2 :: RateSig -> DepthSig -> WidthSig -> Sig2 -> Sig2 +fxChorus2 krate kdepth kwidth ain = P.fxChorus2 krate kdepth kwidth ain + +type TremWaveSig = Sig + +-- | Auto pan +-- +-- > fxAutoPan wave rate depth ain +-- +-- ; Arguments: +-- +-- * @wave @ -- waveform used by the lfo (0=sine 1=triangle 2=square) +-- +-- * @rate @ -- rate control of the lfo of the effect *NOT IN HERTZ* (range 0 to 1) +-- +-- * @depth @ -- depth of the lfo of the effect (range 0 to 1) +-- +-- * @mode @ -- mode of the effect (0=auto-panning 1=tremolo) +-- +-- * @ain @ -- input stereo audio +fxAutoPan :: TremWaveSig -> DepthSig -> RateSig -> Sig2 -> Sig2 +fxAutoPan tremWave kdepth krate = P.fxPanTrem kdepth krate 0 tremWave + +-- | Tremolo +-- +-- tremolo effect +-- +-- > fxTrem wave rate depth ain +-- +-- ; Arguments: +-- +-- * @wave @ -- waveform used by the lfo (0=sine 1=triangle 2=square) +-- +-- * @rate @ -- rate control of the lfo of the effect *NOT IN HERTZ* (range 0 to 1) +-- +-- * @depth @ -- depth of the lfo of the effect (range 0 to 1) +-- +-- * @mode @ -- mode of the effect (0=auto-panning 1=tremolo) +-- +-- * @ain @ -- input stereo audio +fxTrem :: TremWaveSig -> DepthSig -> RateSig -> Sig2 -> Sig2 +fxTrem tremWave kdepth krate = P.fxPanTrem kdepth krate 1 tremWave + +type RatioSig = Sig +type FftSize = D + +-- | PitchShifter +-- +-- A pitch shifter effect based on FFT technology +-- +-- > fxPitchShifter fftSize mixRatio transposeRatio feedback ain +-- +-- Arguments +-- +-- * @fftSize @ -- size for FFT analysis (good values 1024, 512, 256, 2048), the higher values introduce latency but lower values are less accurate. +-- +-- * @mix @ -- dry / wet mix of the output signal (range 0 to 1) +-- +-- * @transpose@ -- pitch ratio +-- +-- * @feedback @ -- control of the amount of output signal fed back into the input of the effect (suggested range 0 to 1) +-- +-- * @ain @ -- input audio to be pitch shifted +fxPitchShifter :: FftSize -> Balance -> RatioSig -> Feedback -> Sig -> Sig +fxPitchShifter ifftSize kmix ratio kfback = P.fxPitchShifter ifftSize kmix ratio kfback + +-- | FreqShifter +-- ; ---------------- +-- ; A frequency shifter effect using the hilbert filter +-- ; +-- ; aout FreqShifter adry,kmix,kfreq,kmult,kfback +-- ; +-- ; Performance +-- ; ----------- +-- ; adry -- input audio to be frequency shifted +-- ; kmix -- dry / wet mix of the output signal (range 0 to 1) +-- ; kfreq -- frequency of frequency shifter effect (suggested range -1000 to 1000) +-- ; kmult -- multiplier of frequency value for fine tuning control (suggested range -1 to 1) +-- ; kfback -- control of the amount of output signal fed back into the input of the effect (suggested range 0 to 1) +fxFreqShifter :: Balance -> Sig -> Sig -> Feedback -> Sig -> Sig +fxFreqShifter kmix freq kmul kfback = P.fxFreqShifter kmix freq kmul kfback + + +-- | Compressor. All arguments are relative (range in 0 to 1). +-- +-- > fxCompress thresh (loknee, hiknee) ratio (att, rel) gain ain +fxCompress :: Sig -> (Sig, Sig) -> Sig -> (Sig, Sig) -> Sig -> Sig -> Sig +fxCompress thresh (loknee, hiknee) ratio (att, rel) gain x = gain' * compress x x thresh' loknee' hiknee' ratio' att' rel' 0.05 + where + gain' = ampdb $ onLin (-36, 36) gain + thresh' = onLin (0, 120) thresh + att' = onExp (0, 1) att + rel' = onExp (0, 1) rel + ratio' = onExp (1, 30000) ratio + loknee' = onLin (0, 120) loknee + hiknee' = onLin (0, 120) hiknee + + onLin (min, max) val = min + val * (max - min) + onExp (min, max) val = scale (expcurve val 4) max min diff --git a/src/Csound/Air/Fx/FxBox.hs b/src/Csound/Air/Fx/FxBox.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Air/Fx/FxBox.hs @@ -0,0 +1,1166 @@ +{-# Language FlexibleContexts #-} + +-- | A friendly family of effects. These functions are kindly provided by Iain McCurdy (designed in Csound). +module Csound.Air.Fx.FxBox( + adele, pongy, tort, fowler, revsy, flan, phasy, crusher, chory, pany, oscPany, triPany, sqrPany, tremy, oscTremy, triTremy, sqrTremy, ringo, EnvelopeModSig, + + -- * Presets + -- | For all presets we have 5 levels of strength. They are signified by numbers from 1 to 5. Also for some effects (delay and distortion) + -- we have miscellaneous way to alter preset by suffix b (means bright) and m (means muffled). It alters the tone color of the effect. + + -- ** Analog Delay + adele1, adele2, adele3, adele4, adele5, + -- *** Bright + adele1b, adele2b, adele3b, adele4b, adele5b, + -- *** Muted + adele1m, adele2m, adele3m, adele4m, adele5m, + + -- ** Ping Pong Delay + pongy1, pongy2, pongy3, pongy4, pongy5, + + -- *** Bright + pongy1b, pongy2b, pongy3b, pongy4b, pongy5b, + + -- *** Muted + pongy1m, pongy2m, pongy3m, pongy4m, pongy5m, + + -- ** Distortion + tort1, tort2, tort3, tort4, tort5, + + -- *** Bright + tort1b, tort2b, tort3b, tort4b, tort5b, + + -- *** Muted + tort1m, tort2m, tort3m, tort4m, tort5m, + + -- ** Envelope follower + fowler', + fowler1, fowler2, fowler3, fowler4, fowler5, + + -- ** Flanger + flan', + flan1, flan2, flan3, flan4, flan5, + + -- ** Phaser + phasy', + phasy1, phasy2, phasy3, phasy4, phasy5, + + -- ** Chorus + chory', + chory1, chory2, chory3, chory4, chory5, + + -- ** Auto Pan + oscPany', + oscPany1, oscPany2, oscPany3, oscPany4, oscPany5, + + triPany', + triPany1, triPany2, triPany3, triPany4, triPany5, + + sqrPany', + sqrPany1, sqrPany2, sqrPany3, sqrPany4, sqrPany5, + + -- ** Tremolo + oscTremy', + oscTremy1, oscTremy2, oscTremy3, oscTremy4, oscTremy5, + + triTremy', + triTremy1, triTremy2, triTremy3, triTremy4, triTremy5, + + sqrTremy', + sqrTremy1, sqrTremy2, sqrTremy3, sqrTremy4, sqrTremy5, + + -- ** Ring modulation + ringo', + ringo1, ringo2, ringo3, ringo4, ringo5, + + -- * Presets with UIs + -- | If we use prefix @ui@ we can create an image of our effect that looks like guitar stompbox. + -- + -- Let's take a distortion fr instance: + -- + -- > type FxFun = Sig2 -> SE Sig2 + -- > + -- > uiTort2 :: Source FxFun + -- + -- We can combine the effects with functions: + -- + -- > fxHor, fxVer :: [Source FxFun] -> Source FxFun + -- > + -- > fxMatrix :: Int -> [Source FxFun] -> Source FxFun + -- > fxMatrix numberOfColumns fxs = ... + -- + -- All these functions stack the effects in the list + -- and align visuals. The visuals can be stacked horizontally, vertically + -- or placed on a square grid. + -- + -- Let's create a chain of effects and apply it to the input signal: + -- + -- > > let pedals ain = lift1 (\f -> f ain) $ fxHor [uiFlan1, uiAdele2 0.25 0.5, uiHall 0.2, uiGain 0.4] + -- > + -- > > vdac $ pedals =<< (atMidi $ dryPatch vibraphone) + -- + -- With @uiGain@ we can change the volume of the output. + + + -- ** Reverb + + -- *** Rooms + uiRoom, uiRoom1, uiRoom2, uiRoom3, uiRoom4, uiRoom5, + + -- ** Chambers + uiChamber, uiChamber1, uiChamber2, uiChamber3, uiChamber4, uiChamber5, + + -- *** Halls + uiHall, uiHall1, uiHall2, uiHall3, uiHall4, uiHall5, + + -- *** Caves + uiCave, uiCave1, uiCave2, uiCave3, uiCave4, uiCave5, + + -- ** Mono Reverb + + -- *** Rooms + uiMonoRoom, uiRoom1m, uiRoom2m, uiRoom3m, uiRoom4m, uiRoom5m, + + -- ** Chambers + uiMonoChamber, uiChamber1m, uiChamber2m, uiChamber3m, uiChamber4m, uiChamber5m, + + -- *** Halls + uiMonoHall, uiHall1m, uiHall2m, uiHall3m, uiHall4m, uiHall5m, + + -- *** Caves + uiMonoCave, uiCave1m, uiCave2m, uiCave3m, uiCave4m, uiCave5m, + + -- ** Delay + uiAdele1, uiAdele2, uiAdele3, uiAdele4, uiAdele5, + uiAdele1b, uiAdele2b, uiAdele3b, uiAdele4b, uiAdele5b, + uiAdele1m, uiAdele2m, uiAdele3m, uiAdele4m, uiAdele5m, + + -- ** Ping Pong Delay + uiPongy1, uiPongy2, uiPongy3, uiPongy4, uiPongy5, + uiPongy1b, uiPongy2b, uiPongy3b, uiPongy4b, uiPongy5b, + uiPongy1m, uiPongy2m, uiPongy3m, uiPongy4m, uiPongy5m, + + -- ** Distortion + uiTort1, uiTort2, uiTort3, uiTort4, uiTort5, + uiTort1b, uiTort2b, uiTort3b, uiTort4b, uiTort5b, + uiTort1m, uiTort2m, uiTort3m, uiTort4m, uiTort5m, + + -- ** Envelope follower + uiFowler', + uiFowler1, uiFowler2, uiFowler3, uiFowler4, uiFowler5, + + -- ** Flanger + uiFlan', uiFlan1, uiFlan2, uiFlan3, uiFlan4, uiFlan5, + + -- ** Phaser + uiPhasy', uiPhasy1, uiPhasy2, uiPhasy3, uiPhasy4, uiPhasy5, + + -- ** Chorus + uiChory', uiChory1, uiChory2, uiChory3, uiChory4, uiChory5, + + -- ** Auto Pan + uiOscPany', uiTriPany', uiSqrPany', + uiOscPany1, uiOscPany2, uiOscPany3, uiOscPany4, uiOscPany5, + uiTriPany1, uiTriPany2, uiTriPany3, uiTriPany4, uiTriPany5, + uiSqrPany1, uiSqrPany2, uiSqrPany3, uiSqrPany4, uiSqrPany5, + + -- ** Tremolo + uiOscTremy', uiTriTremy', uiSqrTremy', + uiOscTremy1, uiOscTremy2, uiOscTremy3, uiOscTremy4, uiOscTremy5, + uiTriTremy1, uiTriTremy2, uiTriTremy3, uiTriTremy4, uiTriTremy5, + uiSqrTremy1, uiSqrTremy2, uiSqrTremy3, uiSqrTremy4, uiSqrTremy5, + + -- ** Reverse + uiRevsy, + + -- ** LoFi + uiCrusher, + + -- ** Ring modulation + uiRingo', uiRingo1, uiRingo2, uiRingo3, uiRingo4, uiRingo5 + + -- ** Compressor + -- | TODO + + +) where + +import Data.Default + +import Csound.Typed +import Csound.Typed.Opcode(ampdb, scale, expcurve, compress) +import Csound.Typed.Gui + +import Csound.SigSpace + +import qualified Csound.Typed.Plugins as P(pitchShifterDelay, + fxAnalogDelay, fxDistortion, fxEnvelopeFollower, fxFlanger, fxFreqShifter, fxLoFi, + fxPanTrem, fxMonoTrem, fxPhaser, fxPitchShifter, fxReverse, fxRingModulator, fxChorus2) + +import Csound.Air.Patch(Fx, Fx1, Fx2) +import Csound.Air.Fx(Balance, DelayTime, Feedback, ToneSig, SensitivitySig, + BaseCps, Resonance, DepthSig, RateSig, TremWaveSig, FoldoverSig, BitsReductionSig, + DriveSig, TimeSig, WidthSig, + rever2, pingPong, pingPong', PingPongSpec(..)) + +import Csound.Air.Live(fxBox, fxColor) +import Csound.Air.Wav(toMono) +import Csound.Air.Misc(fromMono) + +import qualified Data.Colour as C +import qualified Data.Colour.SRGB as C + + +-- | Analog Delay line with low-pass filter in the feedback chain. +-- The filter adds natural decay to the echoes. +-- +-- > adele mixRatio delayTime feedback toneRatio ain +-- +-- Note that the center frequency of the filter is measured in normalized units (form 0 to 1). +adele :: Sigs a => Balance -> DelayTime -> Feedback -> ToneSig -> a -> a +adele kmix kdelay kfback ktone = mapSig $ P.fxAnalogDelay kmix kdelay kfback ktone + +size1, size2, size3, size4, size5 :: Fractional a => a + +size1 = 0.1 +size2 = 0.25 +size3 = 0.5 +size4 = 0.75 +size5 = 0.95 + +-- | Distortion unit with low-pass filter. +-- +-- > tort driveLevel toneRatio ain +-- +-- Note that the center frequency of the filter is measured in normalized units (form 0 to 1). +tort :: Sigs a => DriveSig -> ToneSig -> a -> a +tort kdrive ktone = mapSig $ P.fxDistortion 1 kdrive ktone + +-- | Envelope follower. +-- +-- > fowler sensitivity baseFrequencyRatio resonance ain +-- +-- Arguments: +-- +-- * @sensitivity @ -- sensitivity of the envelope follower (suggested range: 0 to 1) +-- +-- * @baseFrequencyRatio @ -- base frequency of the filter before modulation by the input dynamics (range: 0 to 1) +-- +-- * @resonance @ -- resonance of the lowpass filter (suggested range: 0 to 1) +fowler :: Sigs a => SensitivitySig -> BaseCps -> Resonance -> a -> a +fowler ksens kbaseFreq kreson = mapSig $ P.fxEnvelopeFollower ksens kbaseFreq (0.99 * kreson) + +-- | An effect that reverses an audio stream in chunks +-- +-- > revsy time +-- +-- @time@ -- the size of the chunck in seconds. +revsy :: Sigs a => TimeSig -> a -> a +revsy ktime = mapSig $ P.fxReverse ktime + + +-- | A flanger effect following the typical design of a so called 'stomp box' +-- +-- > flan rate depth delayTime feedback ain = +-- +-- Arguments +-- +-- * @rate @ -- rate control of the lfo of the effect *NOT IN HERTZ* (range 0 to 1) +-- +-- * @depth @ -- depth of the lfo of the effect (range 0 to 1) +-- +-- * @delayTime @ -- static delay offset of the flanging effect (range 0 to 1) +-- +-- * @feedback @ -- feedback and therefore intensity of the effect (range 0 to 1) +-- +-- * @ain @ -- input audio to which the flanging effect will be applied +flan :: Sigs a => RateSig -> DepthSig -> DelayTime -> Feedback -> a -> a +flan krate kdepth kdelay kfback = mapSig $ P.fxFlanger krate kdepth kdelay kfback + + +-- | Phaser +-- +-- An phase shifting effect that mimics the design of a so called 'stomp box' +-- +-- > phasy rate depth freq fback ain +-- +-- Arguments: +-- +-- * @rate @ -- rate of lfo of the effect (range 0 to 1) +-- +-- * @depth @ -- depth of lfo of the effect (range 0 to 1) +-- +-- * @freq @ -- centre frequency of the phase shifting effect in octaves (suggested range 0 to 1) +-- +-- * @fback @ -- feedback and therefore intensity of the effect (range 0 to 1) +-- +-- * @ain @ -- input audio to be pitch shifted +phasy :: Sigs a => RateSig -> DepthSig -> BaseCps -> Feedback -> a -> a +phasy krate kdepth cps kfback = mapSig $ P.fxPhaser krate kdepth (6 + 5 * cps) kfback + +-- | LoFi (Bit Crusher) +-- +-- 'Low Fidelity' distorting effects of bit reduction and downsampling (foldover) +-- +-- > crusher bits fold ain = ... +-- +-- Arguments +-- +-- * @bits @ -- bit depth reduction (range 0 to 1) +-- +-- * @fold @ -- amount of foldover (range 0 to 1) +-- +-- * @ain @ -- input audio to have low fidelity distortion effects applied +crusher :: Sigs a => BitsReductionSig -> FoldoverSig -> a -> a +crusher kbits kfold = mapSig $ P.fxLoFi (0.6 * kbits) kfold + +-- | Stereo Chorus +-- +-- A stereo chorus effect +-- +-- > chory rate depth width (ainLeft, ainRight) +-- +-- Arguments +-- +-- * @rate @ -- rate control of the lfo of the effect *NOT IN HERTZ* (range 0 to 1) +-- +-- * @depth @ -- depth of the lfo of the effect (range 0 to 1) +-- +-- * @width @ -- width of stereo widening (range 0 to 1) +-- +-- * @ainX @ -- input stereo signal +chory :: RateSig -> DepthSig -> WidthSig -> Sig2 -> Sig2 +chory krate kdepth kwidth ain = P.fxChorus2 krate kdepth kwidth ain + + +-- | Auto pan +-- +-- > pany wave rate depth ain +-- +-- ; Arguments: +-- +-- * @wave @ -- waveform used by the lfo (0=sine 1=triangle 2=square) +-- +-- * @rate @ -- rate control of the lfo of the effect *NOT IN HERTZ* (range 0 to 1) +-- +-- * @depth @ -- depth of the lfo of the effect (range 0 to 1) +-- +-- * @ain @ -- input stereo audio +pany :: TremWaveSig -> DepthSig -> RateSig -> Sig2 -> Sig2 +pany tremWave kdepth krate = P.fxPanTrem kdepth krate 0 tremWave + +-- | Sine auto pan +-- +-- > oscPany = pany 0 +oscPany ::DepthSig -> RateSig -> Sig2 -> Sig2 +oscPany = pany 0 + +-- | Triangle auto pan +-- +-- > triPany = pany 1 +triPany ::DepthSig -> RateSig -> Sig2 -> Sig2 +triPany = pany 1 + +-- | Square auto pan +-- +-- > sqrPany = pany 2 +sqrPany ::DepthSig -> RateSig -> Sig2 -> Sig2 +sqrPany = pany 2 + + +-- | Tremolo +-- +-- tremolo effect +-- +-- > tremy wave rate depth ain +-- +-- ; Arguments: +-- +-- * @wave @ -- waveform used by the lfo (0=sine 1=triangle 2=square) +-- +-- * @rate @ -- rate control of the lfo of the effect *NOT IN HERTZ* (range 0 to 1) +-- +-- * @depth @ -- depth of the lfo of the effect (range 0 to 1) +-- +-- * @ain @ -- input stereo audio +tremy :: Sigs a => TremWaveSig -> DepthSig -> RateSig -> a -> a +tremy tremWave kdepth krate = mapSig $ P.fxMonoTrem kdepth krate tremWave + +-- | Sine tremolo +-- +-- > oscTremy = tremy 0 +oscTremy :: Sigs a => DepthSig -> RateSig -> a -> a +oscTremy = tremy 0 + +-- | Triangle tremolo +-- +-- > triTremy = tremy 1 +triTremy :: Sigs a => DepthSig -> RateSig -> a -> a +triTremy = tremy 1 + +-- | Square tremolo +-- +-- > sqrTremy = tremy 2 +sqrTremy :: Sigs a => DepthSig -> RateSig -> a -> a +sqrTremy = tremy 2 + +-- ringo + +type EnvelopeModSig = Sig + +-- | RingModulator +-- +-- An ring modulating effect with an envelope follower +-- +-- > ringo balance rate envelopeMod ain +-- +-- * @balance @ -- dry / wet mix of the output signal (range 0 to 1) +-- ; @rate @ -- frequency of thew ring modulator *NOT IN HERTZ* (range 0 to 1) +-- ; @envelopeMod @ -- amount of dynamic envelope following modulation of frequency (range 0 to 1) +-- * @ain @ -- input audio to be pitch shifted +ringo :: Sigs a => Balance -> RateSig -> EnvelopeModSig -> a -> a +ringo balance rate envelopeMod = mapSig $ \ain -> P.fxRingModulator ain balance rate envelopeMod + +--------------------------------------------------------------------- +-- Presets + +-- Analog Delay + +adeleBy :: Sigs a => ToneSig -> Feedback -> Balance -> DelayTime -> a -> a +adeleBy tone size balance delTime = adele balance delTime size tone + +adeleBy_ :: Sigs a => Feedback -> Balance -> DelayTime -> a -> a +adeleBy_ = adeleBy 0.5 + +adele1, adele2, adele3, adele4, adele5 :: Sigs a => Balance -> DelayTime -> a -> a + +adele1 = adeleBy_ size1 +adele2 = adeleBy_ size2 +adele3 = adeleBy_ size3 +adele4 = adeleBy_ size4 +adele5 = adeleBy_ size5 + +adeleByB :: Sigs a => Feedback -> Balance -> DelayTime -> a -> a +adeleByB = adeleBy 0.8 + +adele1b, adele2b, adele3b, adele4b, adele5b :: Sigs a => Balance -> DelayTime -> a -> a + +adele1b = adeleByB size1 +adele2b = adeleByB size2 +adele3b = adeleByB size3 +adele4b = adeleByB size4 +adele5b = adeleByB size5 + +adeleByM :: Sigs a => Feedback -> Balance -> DelayTime -> a -> a +adeleByM = adeleBy 0.2 + +adele1m, adele2m, adele3m, adele4m, adele5m :: Sigs a => Balance -> DelayTime -> a -> a + +adele1m = adeleByM size1 +adele2m = adeleByM size2 +adele3m = adeleByM size3 +adele4m = adeleByM size4 +adele5m = adeleByM size5 + +-- Ping Pong delay + +-- | Ping-pong delay +-- +-- > pongy kmix delayTime feedback tone ain +pongy :: Sigs a => Balance -> DelayTime -> Feedback -> ToneSig -> WidthSig -> a -> a +pongy balance delTime fbk tone width = mapSig2 (pingPong' (def { pingPongDamp = absTone, pingPongWidth = width }) delTime fbk balance) + where absTone = scale (expcurve tone 4) 12000 100 + +pongyBy :: Sigs a => ToneSig -> Feedback -> Balance -> DelayTime -> WidthSig -> a -> a +pongyBy tone size balance delTime width = pongy balance delTime size tone width + +pongyBy_ :: Sigs a => Feedback -> Balance -> DelayTime -> WidthSig -> a -> a +pongyBy_ = pongyBy 0.5 + +pongy1, pongy2, pongy3, pongy4, pongy5 :: Sigs a => Balance -> DelayTime -> WidthSig -> a -> a + +pongy1 = pongyBy_ size1 +pongy2 = pongyBy_ size2 +pongy3 = pongyBy_ size3 +pongy4 = pongyBy_ size4 +pongy5 = pongyBy_ size5 + +pongyByB :: Sigs a => Feedback -> Balance -> DelayTime -> WidthSig -> a -> a +pongyByB = pongyBy 0.8 + +pongy1b, pongy2b, pongy3b, pongy4b, pongy5b :: Sigs a => Balance -> DelayTime -> WidthSig -> a -> a + +pongy1b = pongyByB size1 +pongy2b = pongyByB size2 +pongy3b = pongyByB size3 +pongy4b = pongyByB size4 +pongy5b = pongyByB size5 + +pongyByM :: Sigs a => Feedback -> Balance -> DelayTime -> WidthSig -> a -> a +pongyByM = pongyBy 0.2 + +pongy1m, pongy2m, pongy3m, pongy4m, pongy5m :: Sigs a => Balance -> DelayTime -> WidthSig -> a -> a + +pongy1m = pongyByM size1 +pongy2m = pongyByM size2 +pongy3m = pongyByM size3 +pongy4m = pongyByM size4 +pongy5m = pongyByM size5 + +-- Distortion + +tortBy :: Sigs a => ToneSig -> DriveSig -> a -> a +tortBy tone drive = tort drive tone + +tortBy_ :: Sigs a => DriveSig -> a -> a +tortBy_ = tortBy 0.5 + +tort1, tort2, tort3, tort4, tort5 :: Sigs a => a -> a + +tort1 = tortBy_ size1 +tort2 = tortBy_ size2 +tort3 = tortBy_ size3 +tort4 = tortBy_ size4 +tort5 = tortBy_ size5 + +tortByB :: Sigs a => DriveSig -> a -> a +tortByB = tortBy 0.85 + +tort1b, tort2b, tort3b, tort4b, tort5b :: Sigs a => a -> a + +tort1b = tortByB size1 +tort2b = tortByB size2 +tort3b = tortByB size3 +tort4b = tortByB size4 +tort5b = tortByB size5 + +tortByM :: Sigs a => DriveSig -> a -> a +tortByM = tortBy 0.2 + +tort1m, tort2m, tort3m, tort4m, tort5m :: Sigs a => a -> a + +tort1m = tortByM size1 +tort2m = tortByM size2 +tort3m = tortByM size3 +tort4m = tortByM size4 +tort5m = tortByM size5 + +-- Envelope follower + +fowler' :: Sigs a => Sig -> a -> a +fowler' size = fowler size size size + +fowler1, fowler2, fowler3, fowler4, fowler5 :: Sigs a => a -> a + +fowler1 = fowler' size1 +fowler2 = fowler' size2 +fowler3 = fowler' size3 +fowler4 = fowler' size4 +fowler5 = fowler' size5 + +-- Flanger + +flan' :: Sigs a => Sig -> a -> a +flan' size = flan size size size size + +flan1, flan2, flan3, flan4, flan5 :: Sigs a => a -> a + +flan1 = flan' size1 +flan2 = flan' size2 +flan3 = flan' size3 +flan4 = flan' size4 +flan5 = flan' size5 + +-- Phaser + +-- phasy :: RateSig -> DepthSig -> BaseCps -> Feedback -> Sig -> Sig + +phasy' :: Sigs a => Sig -> a -> a +phasy' size = phasy size size size size + +phasy1, phasy2, phasy3, phasy4, phasy5 :: Sigs a => a -> a + +phasy1 = phasy' size1 +phasy2 = phasy' size2 +phasy3 = phasy' size3 +phasy4 = phasy' size4 +phasy5 = phasy' size5 + +-- Chorus + +chory' :: Sigs a => Sig -> a -> a +chory' size = mapSig2 (chory size size size) + +chory1, chory2, chory3, chory4, chory5 :: Sigs a => a -> a + +chory1 = chory' size1 +chory2 = chory' size2 +chory3 = chory' size3 +chory4 = chory' size4 +chory5 = chory' size5 + +-- Auto Pan + +-- pany :: TremWaveSig -> DepthSig -> RateSig -> Sig2 -> Sig2 + +oscPany' :: Sigs a => Sig -> a -> a +oscPany' size = mapSig2 (oscPany size size) + +oscPany1, oscPany2, oscPany3, oscPany4, oscPany5 :: Sigs a => a -> a + +oscPany1 = oscPany' size1 +oscPany2 = oscPany' size2 +oscPany3 = oscPany' size3 +oscPany4 = oscPany' size4 +oscPany5 = oscPany' size5 + +triPany' :: Sigs a => Sig -> a -> a +triPany' size = mapSig2 (triPany size size) + +triPany1, triPany2, triPany3, triPany4, triPany5 :: Sigs a => a -> a + +triPany1 = triPany' size1 +triPany2 = triPany' size2 +triPany3 = triPany' size3 +triPany4 = triPany' size4 +triPany5 = triPany' size5 + +sqrPany' :: Sigs a => Sig -> a -> a +sqrPany' size = mapSig2 (sqrPany size size) + +sqrPany1, sqrPany2, sqrPany3, sqrPany4, sqrPany5 :: Sigs a => a -> a + +sqrPany1 = sqrPany' size1 +sqrPany2 = sqrPany' size2 +sqrPany3 = sqrPany' size3 +sqrPany4 = sqrPany' size4 +sqrPany5 = sqrPany' size5 + +-- Tremolo + +oscTremy' :: Sigs a => Sig -> a -> a +oscTremy' size = oscTremy size size + +oscTremy1, oscTremy2, oscTremy3, oscTremy4, oscTremy5 :: Sigs a => a -> a + +oscTremy1 = oscTremy' size1 +oscTremy2 = oscTremy' size2 +oscTremy3 = oscTremy' size3 +oscTremy4 = oscTremy' size4 +oscTremy5 = oscTremy' size5 + +triTremy' :: Sigs a => Sig -> a -> a +triTremy' size = triTremy size size + +triTremy1, triTremy2, triTremy3, triTremy4, triTremy5 :: Sigs a => a -> a + +triTremy1 = triTremy' size1 +triTremy2 = triTremy' size2 +triTremy3 = triTremy' size3 +triTremy4 = triTremy' size4 +triTremy5 = triTremy' size5 + + +sqrTremy' :: Sigs a => Sig -> a -> a +sqrTremy' size = sqrTremy size size + +sqrTremy1, sqrTremy2, sqrTremy3, sqrTremy4, sqrTremy5 :: Sigs a => a -> a + +sqrTremy1 = sqrTremy' size1 +sqrTremy2 = sqrTremy' size2 +sqrTremy3 = sqrTremy' size3 +sqrTremy4 = sqrTremy' size4 +sqrTremy5 = sqrTremy' size5 + +-- Ring modulation + +ringo' :: Sigs a => Sig -> a -> a +ringo' size = ringo size size size + +ringo1, ringo2, ringo3, ringo4, ringo5 :: Sigs a => a -> a + +ringo1 = ringo' size1 +ringo2 = ringo' size2 +ringo3 = ringo' size3 +ringo4 = ringo' size4 +ringo5 = ringo' size5 + +---------------------------------------------------------- +-- UI + +setAll :: Double -> [String] -> [(String, Double)] +setAll size names = fmap (\s -> (s, size)) names + + +-- colors + +tortColor = red +fowlerColor = maroon +adeleColor = blue +pongColor = orange +flanColor = purple +revsyColor = lime +phasyColor = yellow +crusherColor = fuchsia +choryColor = navy +panyColor = aqua +tremyColor = green +ringoColor = maroon +reverbColor = olive + +paintTo = fxColor . C.sRGB24read + +red = "#FF4136" +maroon = "#85144b" +blue = "#0074D9" +aqua = "#7FDBFF" +teal = "#39CCCC" +navy = "#001f3f" +orange = "#FF851B" +lime = "#01FF70" +green = "#2ECC40" +yellow = "#FFDC00" +purple = "#B10DC9" +fuchsia = "#F012BE" +olive = "#3D9970" + +-- Analog Delay + +uiAdeleBy :: Sigs a => Double -> Double -> Double -> Double -> Source (Fx a) +uiAdeleBy initTone initFeedback initBalance initDelayTime = mapSource bindSig $ paintTo adeleColor $ fxBox "Delay" fx True [("balance", initBalance), ("del time", initDelayTime), ("fbk", initFeedback), ("tone", initTone)] + where + fx [balance, delayTime, feedback, tone] = return . adele balance delayTime feedback tone + +uiAdeleBy_ :: Sigs a => Double -> Double -> Double -> Source (Fx a) +uiAdeleBy_ = uiAdeleBy 0.5 + +uiAdele1, uiAdele2, uiAdele3, uiAdele4, uiAdele5 :: Sigs a => Double -> Double -> Source (Fx a) + +uiAdele1 = uiAdeleBy_ size1 +uiAdele2 = uiAdeleBy_ size2 +uiAdele3 = uiAdeleBy_ size3 +uiAdele4 = uiAdeleBy_ size4 +uiAdele5 = uiAdeleBy_ size5 + +uiAdeleByB :: Sigs a => Double -> Double -> Double -> Source (Fx a) +uiAdeleByB = uiAdeleBy 0.8 + +uiAdele1b, uiAdele2b, uiAdele3b, uiAdele4b, uiAdele5b :: Sigs a => Double -> Double -> Source (Fx a) + +uiAdele1b = uiAdeleByB size1 +uiAdele2b = uiAdeleByB size2 +uiAdele3b = uiAdeleByB size3 +uiAdele4b = uiAdeleByB size4 +uiAdele5b = uiAdeleByB size5 + +uiAdeleByM :: Sigs a => Double -> Double -> Double -> Source (Fx a) +uiAdeleByM = uiAdeleBy 0.2 + +uiAdele1m, uiAdele2m, uiAdele3m, uiAdele4m, uiAdele5m :: Sigs a => Double -> Double -> Source (Fx a) + +uiAdele1m = uiAdeleByM size1 +uiAdele2m = uiAdeleByM size2 +uiAdele3m = uiAdeleByM size3 +uiAdele4m = uiAdeleByM size4 +uiAdele5m = uiAdeleByM size5 + +-- Ping-pong delay + +uiPongyBy :: Sigs a => Double -> Double -> Double -> Double -> Double -> Source (Fx a) +uiPongyBy initTone initWidth initFeedback initBalance initDelayTime = mapSource bindSig $ paintTo adeleColor $ fxBox "Ping-pong" fx True [("balance", initBalance), ("del time", initDelayTime), ("fbk", initFeedback), ("tone", initTone), ("width", initWidth)] + where + fx [balance, delayTime, feedback, tone, width] = return . pongy balance delayTime feedback tone width + +defWidth = 0.7 + +uiPongyBy_ :: Sigs a => Double -> Double -> Double -> Source (Fx a) +uiPongyBy_ = uiPongyBy 0.5 defWidth + +uiPongy1, uiPongy2, uiPongy3, uiPongy4, uiPongy5 :: Sigs a => Double -> Double -> Source (Fx a) + +uiPongy1 = uiPongyBy_ size1 +uiPongy2 = uiPongyBy_ size2 +uiPongy3 = uiPongyBy_ size3 +uiPongy4 = uiPongyBy_ size4 +uiPongy5 = uiPongyBy_ size5 + +uiPongyByB :: Sigs a => Double -> Double -> Double -> Source (Fx a) +uiPongyByB = uiPongyBy 0.8 defWidth + +uiPongy1b, uiPongy2b, uiPongy3b, uiPongy4b, uiPongy5b :: Sigs a => Double -> Double -> Source (Fx a) + +uiPongy1b = uiPongyByB size1 +uiPongy2b = uiPongyByB size2 +uiPongy3b = uiPongyByB size3 +uiPongy4b = uiPongyByB size4 +uiPongy5b = uiPongyByB size5 + +uiPongyByM :: Sigs a => Double -> Double -> Double -> Source (Fx a) +uiPongyByM = uiPongyBy 0.2 defWidth + +uiPongy1m, uiPongy2m, uiPongy3m, uiPongy4m, uiPongy5m :: Sigs a => Double -> Double -> Source (Fx a) + +uiPongy1m = uiPongyByM size1 +uiPongy2m = uiPongyByM size2 +uiPongy3m = uiPongyByM size3 +uiPongy4m = uiPongyByM size4 +uiPongy5m = uiPongyByM size5 + +-- Distortion + +uiTortBy :: Sigs a => Double -> Double -> Source (Fx a) +uiTortBy initTone initDrive = mapSource bindSig $ paintTo tortColor $ fxBox "Distort" fx True [("drive", initDrive), ("tone", initTone)] + where + fx [drive, tone] = return . tort drive tone + +uiTortBy_ :: Sigs a => Double -> Source (Fx a) +uiTortBy_ = uiTortBy 0.5 + +uiTort1, uiTort2, uiTort3, uiTort4, uiTort5 :: Sigs a => Source (Fx a) + +uiTort1 = uiTortBy_ size1 +uiTort2 = uiTortBy_ size2 +uiTort3 = uiTortBy_ size3 +uiTort4 = uiTortBy_ size4 +uiTort5 = uiTortBy_ size5 + +uiTortByB :: Sigs a => Double -> Source (Fx a) +uiTortByB = uiTortBy 0.85 + +uiTort1b, uiTort2b, uiTort3b, uiTort4b, uiTort5b :: Sigs a => Source (Fx a) + +uiTort1b = uiTortByB size1 +uiTort2b = uiTortByB size2 +uiTort3b = uiTortByB size3 +uiTort4b = uiTortByB size4 +uiTort5b = uiTortByB size5 + +uiTortByM :: Sigs a => Double -> Source (Fx a) +uiTortByM = uiTortBy 0.2 + +uiTort1m, uiTort2m, uiTort3m, uiTort4m, uiTort5m :: Sigs a => Source (Fx a) + +uiTort1m = uiTortByM size1 +uiTort2m = uiTortByM size2 +uiTort3m = uiTortByM size3 +uiTort4m = uiTortByM size4 +uiTort5m = uiTortByM size5 + +-- Envelope follower + +uiFowler' :: Sigs a => Source (Fx a) +uiFowler' = mapSource bindSig $ paintTo fowlerColor $ fxBox "Follower" fx True [("size", size1)] + where + fx [size] = return . fowler' size + +uiFowlerBy :: Sigs a => Double -> Source (Fx a) +uiFowlerBy size = mapSource bindSig $ paintTo fowlerColor $ fxBox "Follower" fx True [("sense", size), ("freq", size), ("reson", size)] + where + fx [sense, freq, resonance] = return . fowler sense freq resonance + +uiFowler1, uiFowler2, uiFowler3, uiFowler4, uiFowler5 :: Sigs a => Source (Fx a) + +uiFowler1 = uiFowlerBy size1 +uiFowler2 = uiFowlerBy size2 +uiFowler3 = uiFowlerBy size3 +uiFowler4 = uiFowlerBy size4 +uiFowler5 = uiFowlerBy size5 + +-- Flanger + +uiFlan' :: Sigs a => Source (Fx a) +uiFlan' = mapSource bindSig $ paintTo flanColor $ fxBox "Flanger" fx True [("size", size1)] + where + fx [size] = return . flan' size + +uiFlanBy :: Sigs a => Double -> Source (Fx a) +uiFlanBy size = mapSource bindSig $ paintTo flanColor $ fxBox "Flanger" fx True $ setAll size ["rate", "depth", "del time", "fbk"] + where + fx [rate, depth, delayTime, fbk] = return . flan rate depth delayTime fbk + +uiFlan1, uiFlan2, uiFlan3, uiFlan4, uiFlan5 :: Sigs a => Source (Fx a) + +uiFlan1 = uiFlanBy size1 +uiFlan2 = uiFlanBy size2 +uiFlan3 = uiFlanBy size3 +uiFlan4 = uiFlanBy size4 +uiFlan5 = uiFlanBy size5 + +-- Phaser + +-- phasy :: RateSig -> DepthSig -> BaseCps -> Feedback -> Sig -> Sig + +uiPhasy' :: Sigs a => Source (Fx a) +uiPhasy' = mapSource bindSig $ paintTo phasyColor $ fxBox "Phaser" fx True $ [("size", size1)] + where + fx [x] = return . phasy' x + +uiPhasyBy :: Sigs a => Double -> Source (Fx a) +uiPhasyBy size = mapSource bindSig $ paintTo phasyColor $ fxBox "Phaser" fx True $ setAll size ["rate", "depth", "cps", "fbk"] + where + fx [rate, depth, cps, fbk] = return . phasy rate depth cps fbk + +uiPhasy1, uiPhasy2, uiPhasy3, uiPhasy4, uiPhasy5 :: Sigs a => Source (Fx a) + +uiPhasy1 = uiPhasyBy size1 +uiPhasy2 = uiPhasyBy size2 +uiPhasy3 = uiPhasyBy size3 +uiPhasy4 = uiPhasyBy size4 +uiPhasy5 = uiPhasyBy size5 + +-- Chorus + +uiChory' :: Sigs a => Source (Fx a) +uiChory' = paintTo choryColor $ fxBox "Chorus" fx True [("size", size1)] + where + fx [size] = return . chory' size + +uiChoryBy :: Sigs a => Double -> Source (Fx a) +uiChoryBy size = paintTo choryColor $ fxBox "Chorus" fx True $ setAll size ["rate", "depth", "width"] + where + fx [rate, depth, width] = return . mapSig2 (chory rate depth width) + +uiChory1, uiChory2, uiChory3, uiChory4, uiChory5 :: Sigs a => Source (Fx a) + +uiChory1 = uiChoryBy size1 +uiChory2 = uiChoryBy size2 +uiChory3 = uiChoryBy size3 +uiChory4 = uiChoryBy size4 +uiChory5 = uiChoryBy size5 + +-- Auto Pan + +-- pany :: TremWaveSig -> DepthSig -> RateSig -> Sig2 -> Sig2 + +genUiPany' :: (Sig -> Sig2 -> Sig2) -> Source Fx2 +genUiPany' mkPany = paintTo panyColor $ fxBox "Pan" fx True [("size", size1)] + where + fx [size] = return . mkPany size + +uiOscPany', uiTriPany', uiSqrPany' :: Source Fx2 + +uiOscPany' = genUiPany' oscPany' +uiTriPany' = genUiPany' triPany' +uiSqrPany' = genUiPany' sqrPany' + +genUiPanyBy :: Sig -> Double -> Source Fx2 +genUiPanyBy wave size = paintTo panyColor $ fxBox "Pan" fx True $ setAll size ["depth", "rate"] + where + fx [depth, rate] = return . pany wave depth rate + +uiOscPanyBy, uiTriPanyBy, uiSqrPanyBy :: Double -> Source Fx2 + +uiOscPanyBy = genUiPanyBy 0 +uiTriPanyBy = genUiPanyBy 1 +uiSqrPanyBy = genUiPanyBy 2 + +uiOscPany1, uiOscPany2, uiOscPany3, uiOscPany4, uiOscPany5, + uiTriPany1, uiTriPany2, uiTriPany3, uiTriPany4, uiTriPany5, + uiSqrPany1, uiSqrPany2, uiSqrPany3, uiSqrPany4, uiSqrPany5 :: Source Fx2 + +uiOscPany1 = uiOscPanyBy size1 +uiOscPany2 = uiOscPanyBy size2 +uiOscPany3 = uiOscPanyBy size3 +uiOscPany4 = uiOscPanyBy size4 +uiOscPany5 = uiOscPanyBy size5 + +uiTriPany1 = uiTriPanyBy size1 +uiTriPany2 = uiTriPanyBy size2 +uiTriPany3 = uiTriPanyBy size3 +uiTriPany4 = uiTriPanyBy size4 +uiTriPany5 = uiTriPanyBy size5 + +uiSqrPany1 = uiSqrPanyBy size1 +uiSqrPany2 = uiSqrPanyBy size2 +uiSqrPany3 = uiSqrPanyBy size3 +uiSqrPany4 = uiSqrPanyBy size4 +uiSqrPany5 = uiSqrPanyBy size5 + +-- Tremolo + +genUiTremy' :: Sigs a => (Sig -> Sig -> Sig) -> Source (Fx a) +genUiTremy' mkTremy = mapSource bindSig $ paintTo tremyColor $ fxBox "Tremolo" fx True [("size", size1)] + where + fx [size] = return . mkTremy size + +uiOscTremy', uiTriTremy', uiSqrTremy' :: Sigs a => Source (Fx a) + +uiOscTremy' = genUiTremy' oscTremy' +uiTriTremy' = genUiTremy' triTremy' +uiSqrTremy' = genUiTremy' sqrTremy' + +genUiTremyBy :: Sigs a => Sig -> Double -> Source (Fx a) +genUiTremyBy wave size = mapSource bindSig $ paintTo tremyColor $ fxBox "Tremolo" fx True $ setAll size ["depth", "rate"] + where + fx [depth, rate] = return . tremy wave depth rate + +uiOscTremyBy, uiTriTremyBy, uiSqrTremyBy :: Sigs a => Double -> Source (Fx a) + +uiOscTremyBy = genUiTremyBy 0 +uiTriTremyBy = genUiTremyBy 1 +uiSqrTremyBy = genUiTremyBy 2 + +uiOscTremy1, uiOscTremy2, uiOscTremy3, uiOscTremy4, uiOscTremy5, + uiTriTremy1, uiTriTremy2, uiTriTremy3, uiTriTremy4, uiTriTremy5, + uiSqrTremy1, uiSqrTremy2, uiSqrTremy3, uiSqrTremy4, uiSqrTremy5 :: Sigs a => Source (Fx a) + +uiOscTremy1 = uiOscTremyBy size1 +uiOscTremy2 = uiOscTremyBy size2 +uiOscTremy3 = uiOscTremyBy size3 +uiOscTremy4 = uiOscTremyBy size4 +uiOscTremy5 = uiOscTremyBy size5 + +uiTriTremy1 = uiTriTremyBy size1 +uiTriTremy2 = uiTriTremyBy size2 +uiTriTremy3 = uiTriTremyBy size3 +uiTriTremy4 = uiTriTremyBy size4 +uiTriTremy5 = uiTriTremyBy size5 + +uiSqrTremy1 = uiSqrTremyBy size1 +uiSqrTremy2 = uiSqrTremyBy size2 +uiSqrTremy3 = uiSqrTremyBy size3 +uiSqrTremy4 = uiSqrTremyBy size4 +uiSqrTremy5 = uiSqrTremyBy size5 + +-- Ring modulation + +uiRingo' :: Sigs a => Source (Fx a) +uiRingo' = mapSource bindSig $ paintTo ringoColor $ fxBox "Ringo" fx True [("size", size1)] + where + fx [size] = return . ringo' size + +uiRingoBy :: Sigs a => Double -> Source (Fx a) +uiRingoBy size = mapSource bindSig $ paintTo ringoColor $ fxBox "Ring Mod" fx True $ setAll size ["mix", "rate", "env mod"] + where + fx [balance, rate, envMod] = return . ringo balance rate envMod + +uiRingo1, uiRingo2, uiRingo3, uiRingo4, uiRingo5 :: Sigs a => Source (Fx a) + +uiRingo1 = uiRingoBy size1 +uiRingo2 = uiRingoBy size2 +uiRingo3 = uiRingoBy size3 +uiRingo4 = uiRingoBy size4 +uiRingo5 = uiRingoBy size5 + +-- Crusher + +uiCrusher :: Sigs a => Double -> Double -> Source (Fx a) +uiCrusher initReduction initFoldover = mapSource bindSig $ paintTo revsyColor $ fxBox "LoFi" fx True [("redux", initReduction), ("foldover", initFoldover)] + where + fx [redux, foldover] = return . crusher redux foldover + +-- Reverse + +uiRevsy :: Sigs a => Double -> Source (Fx a) +uiRevsy initTime = mapSource bindSig $ paintTo revsyColor $ fxBox "Reverse" fx True [("time", initTime)] + where + fx [time] = return . revsy time + +------------------------------------------------------------ +-- Reverbs + +uiRevBy :: Sigs a => Double -> Double -> Source (Fx a) +uiRevBy initFeedback initMix = paintTo reverbColor $ fxBox "Reverb" fx True [("mix", initMix), ("fbk", initFeedback)] + where + fx [balance, feedback] = \asig -> return $ mapSig2 (\x -> mul (1 - balance) x + mul balance (rever2 feedback x)) asig + +uiRoom :: Sigs a => Double -> Source (Fx a) +uiRoom = uiRevBy 0.6 + +uiRoom1, uiRoom2, uiRoom3, uiRoom4, uiRoom5 :: Sigs a => Source (Fx a) + +uiRoom1 = uiRoom size1 +uiRoom2 = uiRoom size2 +uiRoom3 = uiRoom size3 +uiRoom4 = uiRoom size4 +uiRoom5 = uiRoom size5 + +uiChamber :: Sigs a => Double -> Source (Fx a) +uiChamber = uiRevBy 0.8 + +uiChamber1, uiChamber2, uiChamber3, uiChamber4, uiChamber5 :: Sigs a => Source (Fx a) + +uiChamber1 = uiChamber size1 +uiChamber2 = uiChamber size2 +uiChamber3 = uiChamber size3 +uiChamber4 = uiChamber size4 +uiChamber5 = uiChamber size5 + +uiHall :: Sigs a => Double -> Source (Fx a) +uiHall = uiRevBy 0.9 + +uiHall1, uiHall2, uiHall3, uiHall4, uiHall5 :: Sigs a => Source (Fx a) + +uiHall1 = uiHall size1 +uiHall2 = uiHall size2 +uiHall3 = uiHall size3 +uiHall4 = uiHall size4 +uiHall5 = uiHall size5 + +uiCave :: Sigs a => Double -> Source (Fx a) +uiCave = uiRevBy 0.99 + +uiCave1, uiCave2, uiCave3, uiCave4, uiCave5 :: Sigs a => Source (Fx a) + +uiCave1 = uiCave size1 +uiCave2 = uiCave size2 +uiCave3 = uiCave size3 +uiCave4 = uiCave size4 +uiCave5 = uiCave size5 + +------------------------------------------------------------ +-- Mono Reverbs + +rever1 :: Sig -> Sig -> Sig +rever1 fbk = toMono . rever2 fbk . fromMono + +uiMonoRevBy :: Double -> Double -> Source Fx1 +uiMonoRevBy initFeedback initMix = paintTo reverbColor $ fxBox "Reverb" fx True [("mix", initMix), ("fbk", initFeedback)] + where + fx [balance, feedback] = \asig -> return $ mixAt balance (rever1 feedback) asig + +uiMonoRoom :: Double -> Source Fx1 +uiMonoRoom = uiMonoRevBy 0.6 + +uiRoom1m, uiRoom2m, uiRoom3m, uiRoom4m, uiRoom5m :: Source Fx1 + +uiRoom1m = uiMonoRoom size1 +uiRoom2m = uiMonoRoom size2 +uiRoom3m = uiMonoRoom size3 +uiRoom4m = uiMonoRoom size4 +uiRoom5m = uiMonoRoom size5 + +uiMonoChamber :: Double -> Source Fx1 +uiMonoChamber = uiMonoRevBy 0.8 + +uiChamber1m, uiChamber2m, uiChamber3m, uiChamber4m, uiChamber5m :: Source Fx1 + +uiChamber1m = uiMonoChamber size1 +uiChamber2m = uiMonoChamber size2 +uiChamber3m = uiMonoChamber size3 +uiChamber4m = uiMonoChamber size4 +uiChamber5m = uiMonoChamber size5 + +uiMonoHall :: Double -> Source Fx1 +uiMonoHall = uiMonoRevBy 0.9 + +uiHall1m, uiHall2m, uiHall3m, uiHall4m, uiHall5m :: Source Fx1 + +uiHall1m = uiMonoHall size1 +uiHall2m = uiMonoHall size2 +uiHall3m = uiMonoHall size3 +uiHall4m = uiMonoHall size4 +uiHall5m = uiMonoHall size5 + +uiMonoCave :: Double -> Source Fx1 +uiMonoCave = uiMonoRevBy 0.99 + +uiCave1m, uiCave2m, uiCave3m, uiCave4m, uiCave5m :: Source Fx1 + +uiCave1m = uiMonoCave size1 +uiCave2m = uiMonoCave size2 +uiCave3m = uiMonoCave size3 +uiCave4m = uiMonoCave size4 +uiCave5m = uiMonoCave size5 + + diff --git a/src/Csound/Air/Granular.hs b/src/Csound/Air/Granular.hs --- a/src/Csound/Air/Granular.hs +++ b/src/Csound/Air/Granular.hs @@ -184,7 +184,7 @@ , partikkelDisttab = setSize 32768 $ lins [0, 1, 1] , partikkelSync = 0 , partikkelEnv2amt = 1 - , partikkelEnv2tab = setSize 4096 $ winSync [1] + , partikkelEnv2tab = setSize 4096 $ winSync , partikkelEnv_attack = noTab , partikkelEnv_decay = noTab , partikkelSustain_amount = 0 diff --git a/src/Csound/Air/Live.hs b/src/Csound/Air/Live.hs --- a/src/Csound/Air/Live.hs +++ b/src/Csound/Air/Live.hs @@ -1,12 +1,14 @@ -{-# Language TypeSynonymInstances, FlexibleInstances #-} +{-# Language ScopedTypeVariables, TypeFamilies, TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-} -- | UIs for live performances module Csound.Air.Live ( -- * Mixer mixer, hmixer, mixMono, -- * Effects - FxFun, FxUI(..), fxBox, uiBox, - fxColor, fxVer, fxHor, fxSca, fxApp, + fxBox, uiBox, + fxColor, fxVer, fxHor, fxGrid, fxSca, fxMap, fxApply, atFx, + fxHorMS, fxVerMS, fxGridMS, + fromMonoFx, -- * Instrument choosers hinstrChooser, vinstrChooser, @@ -14,9 +16,9 @@ -- hpatchChooser, vpatchChooser, -- ** Fx units - uiDistort, uiChorus, uiFlanger, uiPhaser, uiDelay, uiEcho, - uiFilter, uiReverb, uiGain, uiWhite, uiPink, uiFx, uiRoom, - uiHall, uiCave, uiSig, uiMix, uiMidi, + uiDistort, uiChorus, uiFlanger, uiPhaser, uiDelay, uiEcho, uiFilter, uiReverb, + uiGain, uiCompress, uiWhite, uiPink, uiFx, uiDry, + uiSig, uiMix, uiMidi, -- uiPatch, -- * Static widgets @@ -31,6 +33,7 @@ import Data.Colour import Data.Boolean import qualified Data.Colour.Names as C +import qualified Data.Colour.SRGB as C import Csound.Typed import Csound.Typed.Gui @@ -48,22 +51,15 @@ ---------------------------------------------------------------------- -- mixer --- | The stereo signal processing function. -type FxFun = Sig2 -> SE Sig2 - -instance SigSpace FxFun where - mapSig f g = fmap (mapSig f) . g - - -- | Widget that represents a mixer. -mixer :: [(String, SE Sig2)] -> Source Sig2 +mixer :: (Sigs a) => [(String, SE a)] -> Source a mixer = genMixer (ver, hor) -- | Widget that represents a mixer with horizontal grouping of elements. -hmixer :: [(String, SE Sig2)] -> Source Sig2 +hmixer :: (Sigs a) => [(String, SE a)] -> Source a hmixer = genMixer (hor, ver) -genMixer :: ([Gui] -> Gui, [Gui] -> Gui) -> [(String, SE Sig2)] -> Source Sig2 +genMixer :: (Sigs a) => ([Gui] -> Gui, [Gui] -> Gui) -> [(String, SE a)] -> Source a genMixer (parentGui, childGui) as = source $ do gTags <- mapM box names (gs, vols) <- fmap unzip $ mapM (const $ defSlider "") names @@ -76,7 +72,7 @@ (gMasterTag : gTags) (gMaster : gs) (gMasterMute : gMutes) muteVols = zipWith appMute mutes vols masterMuteVol = appMute masterMute masterVol - res <- mul masterMuteVol $ mean $ zipWith mul muteVols sigs + res <- fmap (mul masterMuteVol . mean) $ zipWithM (\v ain -> fmap (mul v) ain) muteVols sigs return (g, res) where (names, sigs) = unzip as @@ -93,30 +89,11 @@ ---------------------------------------------------------------------- -- effects -class FxUI a where - applyFxArgs :: a -> [Sig] -> Sig2 -> SE Sig2 - arityFx :: a -> Int - -instance FxUI (Sig2 -> Sig2) where - applyFxArgs f _ x = return $ f x - arityFx = const 0 - -instance FxUI FxFun where - applyFxArgs f _ x = f x - arityFx = const 0 - -instance FxUI a => FxUI (Sig -> a) where - applyFxArgs f (a:as) x = applyFxArgs (f a) as x - arityFx f = 1 + arityFx (proxy f) - where - proxy :: (a -> b) -> b - proxy _ = undefined - -- | Creates a widget that represents a stereo signal processing function. -- The parameters of the widget are updated with sliders. -- For example let's create a simple gain widget. It can be encoded like this: -- --- > uiGain :: Bool -> Double -> Source FxFun +-- > uiGain :: Double -> Source FxFun -- > uiGain isOn gain = fxBox "Gain" fx isOn [("gain", gain)] -- > where -- > fx :: Sig -> Sig2 -> Sig2 @@ -136,21 +113,22 @@ -- -- It's cool to set the color of the widget with @fxColor@ function. -- we can make our widgets much more intersting to look at. -fxBox :: FxUI a => String -> a -> Bool -> [(String, Double)] -> Source FxFun +-- fxBox :: forall a. (FxUI a, Num (FxArg a), Tuple (FxArg a)) => String -> a -> Bool -> [(String, Double)] -> Source (Fx (FxArg a)) +fxBox :: forall a. Sigs a => String -> ([Sig] -> Fx a) -> Bool -> [(String, Double)] -> Source (Fx a) fxBox name fx onOff args = source $ do (gOff0, off) <- toggleSig name onOff let gOff = setFontSize 25 gOff0 offRef <- newGlobalRef (0 :: Sig) writeRef offRef off - let (names, initVals) = unzip $ take (arityFx fx) args + let (names, initVals) = unzip args (gs, as) <- fmap unzip $ mapM (\(name, initVal) -> slider name (linSpan 0 1) initVal) $ zip names initVals let f x = do - ref <- newRef (0 :: Sig, 0 :: Sig) + ref <- newRef (0 :: a) goff <- readRef offRef writeRef ref x when1 (goff ==* 1) $ do x2 <- readRef ref - writeRef ref =<< applyFxArgs fx as x2 + writeRef ref =<< fx as x2 res <- readRef ref return res let gui = setBorder UpBoxBorder $ go (length names) gOff gs @@ -163,12 +141,12 @@ where f xs = uiGroupGui gOff (ver xs) -- | Creates an FX-box from the given visual representation. --- It insertes a big On/Off button atop of the GUI. -uiBox :: String -> Source FxFun -> Bool -> Source FxFun +-- It inserts a big On/Off button atop of the GUI. +uiBox :: (Sigs a) => String -> Source (Fx a) -> Bool -> Source (Fx a) uiBox name fx onOff = mapGuiSource (setBorder UpBoxBorder) $ vlift2' uiOnOffSize uiBoxSize go off fx where off = mapGuiSource (setFontSize 25) $ toggleSig name onOff - go off fx arg = mul off $ fx arg + go off fx arg = fmap (mul off) $ fx arg uiOnOffSize = 1.7 uiBoxSize = 8 @@ -187,125 +165,171 @@ -- combine effects -fxGroup :: ([Gui] -> Gui) -> [Source FxFun] -> Source FxFun +fxGroupMS :: ([Gui] -> Gui) -> [Source Fx1] -> Maybe (Source (Sig -> SE Sig2)) -> [Source Fx2] -> Source (Sig -> SE Sig2) +fxGroupMS guiGroup as bridge bs = do + (gsA, fA) <- getChain as + (gsB, fB) <- getChain bs + case bridge of + Nothing -> return $ (guiGroup $ gsA ++ gsB, fA >=> fB . fromMono) + Just widget -> do + (gBridge, fBridge) <- widget + return $ (guiGroup $ gsA ++ gBridge : gsB, fA >=> fBridge >=> fB) + where + getChain xs = do + (gs, fs) <- fmap unzip $ sequence xs + return (gs, foldl (\a b -> a >=> b) return fs) + +fxGroup :: ([Gui] -> Gui) -> [Source (Fx a)] -> Source (Fx a) fxGroup guiGroup as = do (gs, fs) <- fmap unzip $ sequence as return (guiGroup gs, foldl (\a b -> a >=> b) return fs) -- | Scales the gui for signal processing widgets. -fxSca :: Double -> Source FxFun -> Source FxFun +fxSca :: Double -> Source (Fx a) -> Source (Fx a) fxSca d a = fxGroup (\xs -> sca d $ head xs) [a] -- | Groups the signal processing widgets. -- The functions are composed the visuals are --- grouped horizontaly. -fxHor :: [Source FxFun] -> Source FxFun +-- grouped horizontally. +fxHor :: [Source (Fx a)] -> Source (Fx a) fxHor = fxGroup hor -- | Groups the signal processing widgets. -- The functions are composed the visuals are --- grouped verticaly. -fxVer :: [Source FxFun] -> Source FxFun +-- grouped vertically. +fxVer :: [Source (Fx a)] -> Source (Fx a) fxVer = fxGroup ver +-- | Creates a matrix of fx-boxes. +-- +-- > fxGrid columnsSize fxs +-- +-- first argument is a number of columns in each row. +fxGrid :: Int -> [Source (Fx a)] -> Source (Fx a) +fxGrid columnsSize fxs = fxGroup (grid columnsSize) fxs + +-- | @fxHor@ for chain that starts with mono effects and proceeds with stereo effects. +-- The second argument can contain The transition widget (mono to stereo effect) or it can be empty. +-- If it's empty automatic conversion will be inserted. +fxHorMS :: [Source Fx1] -> Maybe (Source (Sig -> SE Sig2)) -> [Source Fx2] -> Source (Sig -> SE Sig2) +fxHorMS = fxGroupMS hor + +-- | @fxVer@ for chain that starts with mono effects and proceeds with stereo effects. +-- The second argument can contain The transition widget (mono to stereo effect) or it can be empty. +-- If it's empty automatic conversion will be inserted. +fxVerMS :: [Source Fx1] -> Maybe (Source (Sig -> SE Sig2)) -> [Source Fx2] -> Source (Sig -> SE Sig2) +fxVerMS = fxGroupMS ver + +-- | Creates a matrix of fx-boxes. Stacks a list of mono and stereo FXs. +-- +-- > fxGrid columnsSize monoFxs maybeBridge stereoFxs +-- +-- first argument is a number of columns in each row. +fxGridMS :: Int -> [Source Fx1] -> Maybe (Source (Sig -> SE Sig2)) -> [Source Fx2] -> Source (Sig -> SE Sig2) +fxGridMS columnSize = fxGroupMS (grid columnSize) + +-- | Applies FX with UI to the input argument. +fxApply :: Source (a -> SE b) -> a -> Source b +fxApply fx a = joinSource $ lift1 (\f -> f a) fx + -- | Applies a function to a signal processing function. -fxApp :: FxFun -> Source FxFun -> Source FxFun -fxApp f = mapSource (>=> f) +fxMap :: Fx a -> Source (Fx a) -> Source (Fx a) +fxMap f = mapSource (>=> f) +-- | Applies FX to the Patch. +atFx :: Source (Fx a) -> Patch a -> Source (Patch a) +atFx uiFx patch = lift1 (\fx -> addPostFx 1 fx patch) uiFx + -- | The distortion widget. The arguments are -- -- > uiDistort isOn levelOfDistortion drive tone -uiDistort :: Bool -> Double -> Double -> Double -> Source FxFun -uiDistort isOn level drive tone = sourceColor2 C.red $ fxBox "Distortion" fxDistort2 isOn +uiDistort :: Sigs a => Bool -> Double -> Double -> Double -> Source (Fx a) +uiDistort isOn level drive tone = mapSource bindSig $ sourceColor2 C.red $ fxBox "Distortion" (\[level, drive, tone] -> return . fxDistort level drive tone) isOn [("level", level), ("drive", drive), ("tone", tone)] + -- | The chorus widget. The arguments are -- -- > uiChorus isOn mix rate depth width -uiChorus :: Bool -> Double -> Double -> Double -> Double -> Source FxFun -uiChorus isOn mix rate depth width = sourceColor2 C.coral $ fxBox "Chorus" stChorus2 isOn +uiChorus :: Bool -> Double -> Double -> Double -> Double -> Source Fx2 +uiChorus isOn mix rate depth width = sourceColor2 C.coral $ fxBox "Chorus" (\[mix, rate, depth, width] -> return . stChorus2 mix rate depth width) isOn [("mix",mix), ("rate",rate), ("depth",depth), ("width",width)] +uiDry :: (Sigs a) => Source (Fx a) +uiDry = fxBox "Thru" (\[] -> return) True [] + -- | The flanger widget. The arguments are -- --- > uiFlanger isOn mix feedback rate depth delay -uiFlanger :: Bool -> Double -> Double -> Double -> Double -> Double -> Source FxFun -uiFlanger isOn mix fback rate depth delay = sourceColor2 C.indigo $ fxBox "Flanger" fxFlanger2 isOn - [("mix", mix), ("fback", fback), ("rate",rate), ("depth",depth), ("delay",delay)] +-- > uiFlanger isOn rate depth delay feedback +uiFlanger :: Sigs a => Bool -> Double -> Double -> Double -> Double -> Source (Fx a) +uiFlanger isOn rate depth delay fback = mapSource bindSig $ sourceColor2 C.indigo $ fxBox "Flanger" (\[fback, rate, depth, delay] -> return . fxFlanger fback rate depth delay) isOn + [("rate",rate), ("depth",depth), ("delay",delay), ("fback", fback)] + -- | The phaser widget. The arguments are -- -- > uiPhaser isOn mix feedback rate depth frequency -uiPhaser :: Bool -> Double -> Double -> Double -> Double -> Double -> Source FxFun -uiPhaser isOn mix fback rate depth freq = sourceColor2 C.orange $ fxBox "Phaser" fxPhaser2 isOn - [("mix", mix), ("fback", fback), ("rate",rate), ("depth",depth), ("freq", freq)] +uiPhaser :: Sigs a => Bool -> Double -> Double -> Double -> Double -> Source (Fx a) +uiPhaser isOn rate depth freq fback = mapSource bindSig $ sourceColor2 C.orange $ fxBox "Phaser" (\[rate, depth, frequency, feedback] -> return . fxPhaser rate depth frequency feedback) isOn + [("rate",rate), ("depth",depth), ("freq", freq), ("fback", fback)] -- | The delay widget. The arguments are -- -- > uiDelay isOn mix feedback delayTime tone -uiDelay :: Bool -> Double -> Double -> Double -> Double -> Source FxFun -uiDelay isOn mix fback time tone = sourceColor2 C.dodgerblue $ fxBox "Delay" analogDelay2 isOn +uiDelay :: Sigs a => Bool -> Double -> Double -> Double -> Double -> Source (Fx a) +uiDelay isOn mix fback time tone = mapSource bindSig $ sourceColor2 C.dodgerblue $ fxBox "Delay" (\[mix, fback, time, tone] -> return . analogDelay mix fback time tone) isOn [("mix",mix), ("fback",fback), ("time",time), ("tone",tone)] + -- | The simplified delay widget. The arguments are -- -- > uiEcho isOn maxDelayTime delayTime feedback -uiEcho :: Bool -> D -> Double -> Double -> Source FxFun -uiEcho isOn maxDelTime time fback = sourceColor2 C.deepskyblue $ fxBox "Echo" (fxEcho2 maxDelTime) isOn +uiEcho :: Sigs a => Bool -> D -> Double -> Double -> Source (Fx a) +uiEcho isOn maxDelTime time fback = mapSource bindSig $ sourceColor2 C.deepskyblue $ fxBox "Echo" (\[time, fback] -> return . fxEcho maxDelTime time fback) isOn [("time", time), ("fback", fback)] + -- | The pair of low and high pass filters -- -- > uiFilter isOn lowPassfrequency highPassFrequency gain -uiFilter :: Bool -> Double -> Double -> Double -> Source FxFun -uiFilter isOn lpf hpf gain = fxBox "Filter" fxFilter2 isOn +uiFilter :: Sigs a => Bool -> Double -> Double -> Double -> Source (Fx a) +uiFilter isOn lpf hpf gain = mapSource bindSig $ fxBox "Filter" (\[lpf, hpf, gain] -> return . fxFilter lpf hpf gain) isOn [("lpf",lpf), ("hpf",hpf), ("gain",gain)] + -- | The reverb widget. The arguments are: -- -- > uiReverb mix depth -uiReverb :: Bool -> Double -> Double -> Source FxFun -uiReverb isOn mix depth = sourceColor2 C.forestgreen $ fxBox "Reverb" (\mix depth asig -> mul (1 - mix) asig + mul mix (rever2 depth asig)) isOn +uiReverb :: Bool -> Double -> Double -> Source Fx2 +uiReverb isOn mix depth = sourceColor2 C.forestgreen $ fxBox "Reverb" (\[mix, depth] asig -> return $ cfd mix asig (rever2 depth asig)) isOn [("mix", mix), ("depth", depth)] --- | The gain widget. The arguments are +-- | The gain widget, it's set to on by default. The arguments are -- --- > uiGain isOn amountOfGain -uiGain :: Bool -> Double -> Source FxFun -uiGain isOn gain = sourceColor2 C.black $ fxBox "Gain" fxGain isOn [("gain", gain)] +-- > uiGain amountOfGain +uiGain :: Sigs a => Double -> Source (Fx a) +uiGain gain = mapSource bindSig $ sourceColor2 C.black $ fxBox "Gain" (\[vol] -> return . fxGain vol) True [("gain", gain)] -- | The filtered white noize widget. The arguments are -- -- > uiWhite isOn centerFreqOfFilter amountOfNoize -uiWhite :: Bool -> Double -> Double -> Source FxFun -uiWhite isOn freq depth = sourceColor2 C.dimgray $ fxBox "White" fxWhite2 isOn +uiWhite :: Sigs a => Bool -> Double -> Double -> Source (Fx a) +uiWhite isOn freq depth = mapSource bindSig $ sourceColor2 C.dimgray $ fxBox "White" (\[freq, depth] -> fxWhite freq depth) isOn [("freq", freq), ("depth", depth)] -- | The filtered pink noize widget. The arguments are -- -- > uiPink isOn centerFreqOfFilter amountOfNoize -uiPink :: Bool -> Double -> Double -> Source FxFun -uiPink isOn freq depth = sourceColor2 C.deeppink $ fxBox "Pink" fxPink2 isOn +uiPink :: Sigs a => Bool -> Double -> Double -> Source (Fx a) +uiPink isOn freq depth = mapSource bindSig $ sourceColor2 C.deeppink $ fxBox "Pink" (\[freq, depth] -> fxPink freq depth) isOn [("freq", freq), ("depth", depth)] -- | The constructor for signal processing functions with no arguments (controlls). -uiFx :: FxUI a => String -> a -> Bool -> Source FxFun -uiFx name f isOn = fxBox name f isOn [] - --- | The reverb for room. -uiRoom :: Bool -> Source FxFun -uiRoom isOn = sourceColor2 C.limegreen $ uiFx "Room" smallRoom2 isOn - --- | The reverb for hall. -uiHall :: Bool -> Source FxFun -uiHall isOn = sourceColor2 C.mediumseagreen $ uiFx "Hall" largeHall2 isOn - --- | The reverb for magic cave. -uiCave :: Bool -> Source FxFun -uiCave isOn = sourceColor2 C.darkviolet $ uiFx "Cave" magicCave2 isOn +uiFx :: Sigs a => String -> Fx a -> Bool -> Source (Fx a) +uiFx name f isOn = fxBox name (\[] -> f) isOn [] -- | Midi chooser implemented as FX-box. -uiMidi :: [(String, Msg -> SE Sig2)] -> Int -> Source FxFun +uiMidi :: (Sigs a) => [(String, Msg -> SE a)] -> Int -> Source (Fx a) uiMidi xs initVal = sourceColor2 C.forestgreen $ uiBox "Midi" fx True where fx = lift1 (\aout arg -> return $ aout + arg) $ vmidiChooser xs initVal @@ -317,7 +341,7 @@ -} -- | the widget for mixing in a signal to the signal. -uiSig :: String -> Bool -> Source Sig2 -> Source FxFun +uiSig :: (Sigs a) => String -> Bool -> Source a -> Source (Fx a) uiSig name onOff widget = source $ do (gs, asig) <- widget (gOff0, off) <- toggleSig name onOff @@ -327,7 +351,7 @@ -- | A mixer widget represented as an effect. -- The effect sums the signals with given wieghts. -uiMix :: Bool -> [(String, SE Sig2)] -> Source FxFun +uiMix :: (Sigs a) => Bool -> [(String, SE a)] -> Source (Fx a) uiMix onOff as = sourceColor2 C.blue $ uiSig "Mix" onOff (mixer as) ---------------------------------------------------------------------- @@ -432,3 +456,22 @@ fxs = fmap getPatchFx patches -} + + +------------------------------- + + +-- | Compressor +-- +-- > uiCompress thresh loknee hiknee ratio att rel gain +uiCompress :: Sigs a => Double -> Double -> Double -> Double -> Double -> Double -> Double -> Source (Fx a) +uiCompress initThresh initLoknee initHiknee initRatio initAtt initRel initGain = mapSource bindSig $ paintTo orange $ fxBox "Compress" fx True + [("thresh", initThresh), ("loknee", initLoknee), ("hiknee", initHiknee), ("ratio", initRatio), ("att", initAtt), ("rel", initRel), ("gain", initGain)] + where + fx [thresh, loknee, hiknee, ratio, att, rel, gain] = return . fxCompress thresh (loknee, hiknee) ratio (att, rel) gain + + paintTo = fxColor . C.sRGB24read + orange = "#FF851B" + +fromMonoFx :: Sigs a => (Sig -> Sig) -> Fx a +fromMonoFx f = \asig2 -> bindSig (return . f) asig2 diff --git a/src/Csound/Air/Looper.hs b/src/Csound/Air/Looper.hs --- a/src/Csound/Air/Looper.hs +++ b/src/Csound/Air/Looper.hs @@ -56,8 +56,8 @@ -- See the docs for the type @LoopSpec@. data LoopSpec = LoopSpec { loopMixVal :: [Sig] - , loopPrefx :: [FxFun] - , loopPostfx :: [FxFun] + , loopPrefx :: [Fx2] + , loopPostfx :: [Fx2] , loopPrefxVal :: [Sig] , loopPostfxVal :: [Sig] , loopInitInstr :: Int @@ -215,7 +215,7 @@ maxDel = 3 - f :: Tick -> Sig -> Sig -> (D, Int, Sig) -> (Sig, FxFun, Sig, FxFun, Sig) -> (Ref Sig, Ref Sig, a) -> SE Sig2 + f :: Tick -> Sig -> Sig -> (D, Int, Sig) -> (Sig, Fx2, Sig, Fx2, Sig) -> (Ref Sig, Ref Sig, a) -> SE Sig2 f delEvt thr x (t, n, repeatFadeWeight) (mixCoeff, preFx, preCoeff, postFx, postCoeff) (delRef, silRef, instr) = do silVal <- readRef silRef runEvt delEvt $ \_ -> do @@ -230,7 +230,7 @@ let playEcho dId = mul (smooth 0.05 $ ifB dId 1 0) $ mul (smooth 0.1 silVal) $ at (echo (dt * t) (ifB dId repeatFadeWeight 0)) $ ifB dId echoSig 0 - mul mixCoeff $ mixAt postCoeff postFx $ sum [ sum $ fmap playEcho [d0, d1, d2] + mul mixCoeff $ mixAt postCoeff postFx $ sum [ return $ sum $ fmap playEcho [d0, d1, d2] , playSf 1] where playSf thrVal = mixAt preCoeff preFx $ playInstr (isCurrent &&* thr ==* thrVal) instr diff --git a/src/Csound/Air/Misc.hs b/src/Csound/Air/Misc.hs --- a/src/Csound/Air/Misc.hs +++ b/src/Csound/Air/Misc.hs @@ -19,7 +19,7 @@ lpJoy, -- * Effects - delaySig, + delaySig, delay1k, -- * Wave shaper wshaper, genSaturator, saturator, mildSaturator, hardSaturator, hardSaturator2, @@ -56,6 +56,7 @@ import Csound.SigSpace import Csound.IO(writeSndBy) import Csound.Options(setRates) +import Csound.Typed.Plugins(delay1k) -------------------------------------------------------------------------- -- patterns @@ -417,8 +418,8 @@ testDrone3 cps = atNote (deepPad caveOvertonePad) (0.8, cps) testDrone4 cps = atNote (deepPad pwEnsemble) (0.8, cps) -pwEnsemble = withSmallHall $ PolySynt def $ at fromMono . mul 0.55 . onCps impPwEnsemble -nightPad = withLargeHall $ PolySynt def $ mul 0.48 . at fromMono . onCps (mul (fadeOut 1) . impNightPad 0.5) +pwEnsemble = withSmallHall $ polySynt $ at fromMono . mul 0.55 . onCps impPwEnsemble +nightPad = withLargeHall $ polySynt $ mul 0.48 . at fromMono . onCps (mul (fadeOut 1) . impNightPad 0.5) data RazorPad = RazorPad { razorPadSpeed :: Sig } @@ -426,14 +427,14 @@ def = RazorPad 0.5 razorPad = razorPad' def -razorPad' (RazorPad speed) = withLargeHall' 0.35 $ PolySynt def $ at fromMono . mul 0.6 . onCps (uncurry $ impRazorPad speed) +razorPad' (RazorPad speed) = withLargeHall' 0.35 $ polySynt $ at fromMono . mul 0.6 . onCps (uncurry $ impRazorPad speed) -overtonePad = withLargeHall' 0.35 $ PolySynt def overtoneInstr +overtonePad = withLargeHall' 0.35 $ polySynt overtoneInstr overtoneInstr :: CsdNote D -> SE Sig2 overtoneInstr = mul 0.65 . at fromMono . mixAt 0.25 (mlp 1500 0.1) . onCps (\cps -> mul (fades 0.25 1.2) (tibetan 11 0.012 cps) + mul (fades 0.25 1) (tibetan 13 0.015 (cps * 0.5))) -caveOvertonePad = FxChain (fx1 0.2 (magicCave2 . mul 0.8)) $ PolySynt def overtoneInstr +caveOvertonePad = FxChain (fx1 0.2 (magicCave2 . mul 0.8)) $ polySynt overtoneInstr -- implem @@ -487,8 +488,8 @@ giwave :: Tab giwave = sines [1, 0.5, 0.33, 0.25, 0.0, 0.1, 0.1, 0.1] -fx1 :: Sig -> (a -> a) -> [FxSpec a] -fx1 dw f = [FxSpec dw (return . f)] +fx1 :: Sig -> (a -> a) -> [GenFxSpec a] +fx1 dw f = [return $ FxSpec dw (return . f)] -- | The magic cave reverb (stereo). magicCave2 :: Sig2 -> Sig2 diff --git a/src/Csound/Air/Patch.hs b/src/Csound/Air/Patch.hs --- a/src/Csound/Air/Patch.hs +++ b/src/Csound/Air/Patch.hs @@ -1,10 +1,11 @@ -{-# Language ScopedTypeVariables #-} +{-# Language ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances #-} -- | Patches. module Csound.Air.Patch( - CsdNote, Instr, Fx, Fx1, Fx2, FxSpec(..), DryWetRatio, + CsdNote, Instr, MonoInstr, Fx, Fx1, Fx2, FxSpec(..), DryWetRatio, Patch1, Patch2, Patch(..), PolySyntSpec(..), MonoSyntSpec(..), - polySynt, monoSynt, + SyntSkin, GenInstr, GenMonoInstr, GenFxSpec, + polySynt, monoSynt, adsrMono, adsrMonoFilter, fxSpec, polySyntFilter, monoSyntFilter, fxSpecFilter, mapPatchInstr, mapMonoPolyInstr, transPatch, dryPatch, getPatchFx, setFxMix, setFxMixes, @@ -14,8 +15,7 @@ atMidi, -- * Events - atSched, - atSchedUntil, + atSched, atSchedUntil, atSchedHarp, -- * Sco atSco, @@ -26,6 +26,11 @@ -- * Fx addInstrFx, addPreFx, addPostFx, + -- ** Specific fx + fxSig, fxSigMix, fxSig2, fxSigMix2, + mapFx, mapFx', bindFx, bindFx', + mapPreFx, mapPreFx', bindPreFx, bindPreFx', + -- * Pads harmonPatch, deepPad, @@ -44,7 +49,7 @@ sfPatch, sfPatchHall, -- * Monosynt params - onMonoSyntSpec, setMonoSharp, setMonoHold, + onMonoSyntSpec, setMonoSlide, setMonoSharp, -- * Csound API patchByNameMidi, @@ -62,16 +67,45 @@ import Control.Applicative import Control.Arrow(second) +import Control.Monad.Trans.Reader import Csound.Typed import Csound.SigSpace import Csound.Control.Midi import Csound.Control.Instr +import Csound.Control.Evt(impulse) import Csound.Control.Sf import Csound.Air.Fx +import Csound.Air.Filter(ResonFilter, mlp) import Csound.Typed.Opcode(cpsmidinn, ampdb) import Csound.Tuning import Csound.Types +import Csound.SigSpace +import Csound.IO + +-- | Common parameters for patches. We use this type to parametrize the patch with some tpyes of arguments +-- that we'd like to be able to change after patch is already constructed. For instance the filter type can greatly +-- change the character of the patch. So by making patches depend on filter type we can let the user to change +-- the filter type and leave the algorithm the same. It's like changing between trademarks. Moog sound vs Korg sound. +-- +-- The instruments in the patches depend on the @SyntSkin@ through the @Reader@ data type. +-- +-- If user doesn't supply any syntSkin value the default is used (`mlp` -- moog low pass filter). Right now +-- the data type is just a synonym for filter but it can become a data type with more parameters in the future releases. +type SyntSkin = ResonFilter + +-- | Generic polyphonic instrument. It depends on @SyntSkin@. +type GenInstr a b = Reader SyntSkin (Instr a b) + +-- | Generic FX. It depends on @SyntSkin@. +type GenFxSpec a = Reader SyntSkin (FxSpec a) + +-- | Generic monophonic instrument. It depends on @SyntSkin@. +type GenMonoInstr a = Reader SyntSkin (MonoInstr a) + +-- | Data type for monophonic instruments. +type MonoInstr a = MonoArg -> SE a + -- | A simple csound note (good for playing with midi-keyboard). -- It's a pair of amplitude (0 to 1) and freuqncy (Hz). type CsdNote a = (a, a) @@ -105,23 +139,15 @@ -- -- * Chn -- midi channel to listen on -- --- * Hold -- to hold the note or not --- -- * SlideTime -- time of transition between notes --- --- * SyntRelease -- time of release data MonoSyntSpec = MonoSyntSpec - { monoSyntChn :: MidiChn - , monoSyntHold :: Bool - , monoSyntSlideTime :: D - , monoSyntRelease :: D } + { monoSyntChn :: MidiChn + , monoSyntSlideTime :: Maybe D } instance Default MonoSyntSpec where def = MonoSyntSpec - { monoSyntChn = ChnAll - , monoSyntHold = False - , monoSyntSlideTime = 0.01 - , monoSyntRelease = 0.1 } + { monoSyntChn = ChnAll + , monoSyntSlideTime = Just 0.008 } data PolySyntSpec = PolySyntSpec { polySyntChn :: MidiChn } @@ -131,8 +157,12 @@ -- | The patch can be: -- --- * a plain monophonic or polyphonic synthesizer +-- * a monophonic synt -- +-- * polyphonic synt +-- +-- * set of common parameters (@SyntSkin@) +-- -- * patch with chain of effects, -- -- * split on keyboard with certain frequency @@ -140,24 +170,61 @@ -- * layer of patches. That is a several patches that sound at the same time. -- the layer is a patch and the weight of volume for a given patch. data Patch a - = MonoSynt MonoSyntSpec (Instr Sig a) - | PolySynt PolySyntSpec (Instr D a) - | FxChain [FxSpec a] (Patch a) + = MonoSynt MonoSyntSpec (GenMonoInstr a) -- (GenInstr Sig a) + | PolySynt PolySyntSpec (GenInstr D a) + | SetSkin SyntSkin (Patch a) + | FxChain [GenFxSpec a] (Patch a) | SplitPatch (Patch a) D (Patch a) | LayerPatch [(Sig, Patch a)] +smoothMonoSpec spec = maybe id smoothMonoArg (monoSyntSlideTime spec) + +-- | Constructor for polyphonic synthesizer. It expects a function from notes to signals. polySynt :: (Instr D a) -> Patch a -polySynt = PolySynt def +polySynt = PolySynt def . return -monoSynt :: (Instr Sig a) -> Patch a -monoSynt = MonoSynt def +-- | Constructor for polyphonic synthesizer with flexible choice of the low-pass filter. +-- If we use the filter from the first argument user lately can change it to some another filter. It defaults to mlp. +polySyntFilter :: (ResonFilter -> Instr D a) -> Patch a +polySyntFilter instr = PolySynt def $ reader instr +-- | Constructor for monophonic synth with envelope generator. The envelope generator is synced with note triggering. +-- So it restarts itself when the note is retriggered. The envelope generator is a simple ADSR gennerator see the type @MonoAdsr@. +adsrMono :: (MonoAdsr -> Instr Sig a) -> Patch a +adsrMono f = monoSynt (adsrMonoSynt f) + +-- | Constructor for monophonic synth with envelope generator and flexible choice of filter. It's just like @adsrMono@ +-- but the user lately can change filter provided in the first argument to some another filter. +adsrMonoFilter :: (ResonFilter -> MonoAdsr -> Instr Sig a) -> Patch a +adsrMonoFilter f = monoSyntFilter (\filter -> adsrMonoSynt (f filter)) + +-- | Constructor for monophonic synthesizer. The instrument is defned on the raw monophonic aruments (see @MonoArg@). +monoSynt :: (MonoInstr a) -> Patch a +monoSynt = MonoSynt def . return + +-- | Constructor for monophonic synthesizer with flexible filter choice. +monoSyntFilter :: (ResonFilter -> MonoInstr a) -> Patch a +monoSyntFilter instr = MonoSynt def $ reader instr + +-- | Constructor for FX-specification. +-- +-- > fxSpec dryWetRatio fxFun +fxSpec :: Sig -> Fx a -> GenFxSpec a +fxSpec ratio fx = return $ FxSpec ratio fx + +-- | Constructor for FX-specification with flexible filter choice. +-- +-- > fxSpec dryWetRatio fxFun +fxSpecFilter :: Sig -> (ResonFilter -> Fx a) -> GenFxSpec a +fxSpecFilter ratio fx = reader $ \resonFilter -> FxSpec ratio (fx resonFilter) + -- Maps all monophonic and polyphonic patches within the given patch. -mapMonoPolyInstr :: (Instr Sig a -> Instr Sig a) -> (Instr D a -> Instr D a) -> Patch a -> Patch a +mapMonoPolyInstr :: (MonoInstr a -> MonoInstr a) -> (Instr D a -> Instr D a) -> Patch a -> Patch a mapMonoPolyInstr mono poly x = case x of - MonoSynt spec instr -> MonoSynt spec (mono instr) - PolySynt spec instr -> PolySynt spec (poly instr) + MonoSynt spec instr -> MonoSynt spec (fmap mono instr) + PolySynt spec instr -> PolySynt spec (fmap poly instr) + SetSkin skin p -> SetSkin skin (rec p) FxChain fxs p -> FxChain fxs (rec p) LayerPatch xs -> LayerPatch (mapSnd rec xs) SplitPatch a dt b -> SplitPatch (rec a) dt (rec b) @@ -168,7 +235,8 @@ mapPatchInstr :: (Instr D a -> Instr D a) -> Patch a -> Patch a mapPatchInstr f x = case x of MonoSynt _ _ -> x - PolySynt spec instr -> PolySynt spec $ f instr + PolySynt spec instr -> PolySynt spec $ fmap f instr + SetSkin skin p -> SetSkin skin (rec p) FxChain fxs p -> FxChain fxs $ rec p LayerPatch xs -> LayerPatch (mapSnd rec xs) SplitPatch a dt b -> SplitPatch (rec a) dt (rec b) @@ -180,6 +248,7 @@ dryPatch x = case x of MonoSynt spec instr -> x PolySynt spec instr -> x + SetSkin skin p -> SetSkin skin (dryPatch p) FxChain _ p -> dryPatch p SplitPatch a dt b -> SplitPatch (dryPatch a) dt (dryPatch b) LayerPatch xs -> LayerPatch $ mapSnd dryPatch xs @@ -191,7 +260,7 @@ -- | Sets the dryWet ratios for the chain of the effects wwithin the patch. setFxMixes :: [Sig] -> Patch a -> Patch a setFxMixes ks p = case p of - FxChain fxs x -> FxChain (zipFirst (\k x -> x { fxMix = k }) ks fxs) x + FxChain fxs x -> FxChain (zipFirst (\k x -> fmap (\t -> t { fxMix = k }) x) ks fxs) x _ -> p where zipFirst f xs ys = case (xs, ys) of @@ -204,11 +273,12 @@ instance SigSpace a => SigSpace (Patch a) where mapSig f x = case x of - MonoSynt spec instr -> MonoSynt spec $ fmap (mapSig f) . instr - PolySynt spec instr -> PolySynt spec $ fmap (mapSig f) . instr + MonoSynt spec instr -> MonoSynt spec $ fmap (fmap (mapSig f) . ) $ instr + PolySynt spec instr -> PolySynt spec $ fmap (fmap (mapSig f) . ) $ instr + SetSkin skin p -> SetSkin skin $ mapSig f p FxChain fxs p -> FxChain fxs $ mapSig f p SplitPatch a dt b -> SplitPatch (mapSig f a) dt (mapSig f b) - LayerPatch xs -> FxChain [FxSpec 1 (return . mapSig f)] $ LayerPatch xs + LayerPatch xs -> FxChain [return $ FxSpec 1 (return . mapSig f)] $ LayerPatch xs mapSnd :: (a -> b) -> [(c, a)] -> [(c, b)] mapSnd f = fmap (second f) @@ -217,20 +287,27 @@ wet (FxSpec k fx) asig = fmap ((mul (1 - k) asig + ) . mul k) $ fx asig -- | Renders the effect chain to a single function. -getPatchFx :: (SigSpace a, Sigs a) => [FxSpec a] -> Fx a -getPatchFx xs = foldr (<=<) return $ fmap wet xs +getPatchFx :: (SigSpace a, Sigs a) => Maybe SyntSkin -> [GenFxSpec a] -> Fx a +getPatchFx maybeSkin xs = foldr (<=<) return $ fmap (wet . flip runSkin maybeSkin) xs -- | Plays a patch with a single infinite note. atNote :: (SigSpace a, Sigs a) => Patch a -> CsdNote D -> SE a -atNote p note@(amp, cps) = case p of - MonoSynt spec instr -> instr (sig amp, sig cps) - PolySynt spec instr -> instr note - FxChain fxs p -> getPatchFx fxs =<< rec p - LayerPatch xs -> onLayered xs rec - SplitPatch a t b -> getSplit (cps `lessThan` t) (rec a) (rec b) - where - rec x = atNote x note +atNote p note = go Nothing p note + where + go maybeSkin p note@(amp, cps) = case p of + MonoSynt spec instr -> (runSkin instr maybeSkin) (MonoArg (sig amp) (sig cps) 1 (impulse 0)) + PolySynt spec instr -> (runSkin instr maybeSkin) note + SetSkin skin p -> newSkin skin p + FxChain fxs p -> getPatchFx maybeSkin fxs =<< rec p + LayerPatch xs -> onLayered xs rec + SplitPatch a t b -> getSplit (cps `lessThan` t) (rec a) (rec b) + where + rec x = go maybeSkin x note + newSkin skin x = go (Just skin) x note +runSkin :: Reader SyntSkin a -> Maybe SyntSkin -> a +runSkin instr maybeSkin = runReader instr $ maybe mlp id maybeSkin + getSplit :: (Num a, Tuple a) => BoolD -> SE a -> SE a -> SE a getSplit cond a b = do ref <- newRef 0 @@ -250,59 +327,66 @@ -- | Plays a patch with midi. atMidi :: (SigSpace a, Sigs a) => Patch a -> SE a -atMidi x = case x of - MonoSynt spec instr -> monoSynt spec instr - PolySynt spec instr -> midiChn (polySyntChn spec) (instr . ampCps) - FxChain fxs p -> getPatchFx fxs =<< atMidi p - LayerPatch xs -> onLayered xs atMidi - SplitPatch a dt b -> genMidiSplitPatch ampCps a dt b - where - monoSynt spec instr = instr =<< getArg +atMidi x = go Nothing x + where + go maybeSkin x = case x of + MonoSynt spec instr -> monoSynt spec (runSkin instr maybeSkin) + PolySynt spec instr -> midiChn (polySyntChn spec) ((runSkin instr maybeSkin) . ampCps) + SetSkin skin p -> newSkin skin p + FxChain fxs p -> getPatchFx maybeSkin fxs =<< rec p + LayerPatch xs -> onLayered xs rec + SplitPatch a dt b -> genMidiSplitPatch maybeSkin ampCps a dt b where - getArg - | monoSyntHold spec = holdMsg chn port - | otherwise = monoMsg chn port rel + newSkin skin p = go (Just skin) p + rec = go maybeSkin - port = monoSyntSlideTime spec - rel = monoSyntRelease spec - chn = monoSyntChn spec + monoSynt spec instr = instr =<< getArg + where + getArg = fmap (smoothMonoSpec spec) $ genMonoMsg chn + chn = monoSyntChn spec -- | Plays a patch with midi with given temperament (see @Csound.Tuning@). atMidiTemp :: (SigSpace a, Sigs a) => Temp -> Patch a -> SE a -atMidiTemp tm x = case x of - MonoSynt spec instr -> monoSynt spec instr - PolySynt spec instr -> midiChn (polySyntChn spec) (instr . ampCps' tm) - FxChain fxs p -> getPatchFx fxs =<< atMidiTemp tm p - LayerPatch xs -> onLayered xs (atMidiTemp tm) - SplitPatch a cps b -> genMidiSplitPatch (ampCps' tm) a cps b - where - monoSynt spec instr = instr =<< getArg +atMidiTemp tm x = go Nothing x + where + go maybeSkin x = case x of + MonoSynt spec instr -> monoSynt spec (runSkin instr maybeSkin) + PolySynt spec instr -> midiChn (polySyntChn spec) ((runSkin instr maybeSkin) . ampCps' tm) + SetSkin skin p -> newSkin skin p + FxChain fxs p -> getPatchFx maybeSkin fxs =<< rec p + LayerPatch xs -> onLayered xs rec + SplitPatch a cps b -> genMidiSplitPatch maybeSkin (ampCps' tm) a cps b where - getArg - | monoSyntHold spec = holdMsgTemp tm chn port - | otherwise = monoMsgTemp tm chn port rel + newSkin skin p = go (Just skin) p + rec = go maybeSkin - port = monoSyntSlideTime spec - rel = monoSyntRelease spec - chn = monoSyntChn spec + monoSynt spec instr = instr =<< getArg + where + getArg = fmap (smoothMonoSpec spec) $ genMonoMsgTemp tm chn + chn = monoSyntChn spec -genMidiSplitPatch :: (SigSpace a, Sigs a) => (Msg -> (D, D)) -> Patch a -> D -> Patch a -> SE a -genMidiSplitPatch midiArg = genSplitPatch $ \chn instr -> midiChn chn (instr . midiArg) -genSplitPatch :: (SigSpace a, Sigs a) => (MidiChn -> (CsdNote D -> SE a) -> SE a) -> Patch a -> D -> Patch a -> SE a -genSplitPatch playInstr a dt b = liftA2 (+) (leftSplit dt a) (rightSplit dt b) +genMidiSplitPatch :: (SigSpace a, Sigs a) => Maybe SyntSkin -> (Msg -> (D, D)) -> Patch a -> D -> Patch a -> SE a +genMidiSplitPatch maybeSkin midiArg = genSplitPatch maybeSkin playMonoInstr playInstr where - leftSplit dt a = onCondPlay ( `lessThan` dt) a - rightSplit dt a = onCondPlay ( `greaterThanEquals` dt) a + playMonoInstr chn cond instr = instr =<< genFilteredMonoMsg chn cond + playInstr chn instr = midiChn chn (instr . midiArg) - onCondPlay cond x = case x of - MonoSynt spec instr -> error "Split doesn't work for monophonic synths. Pleas use only polyphonic synths." - PolySynt spec instr -> playInstr (polySyntChn spec) (restrictPolyInstr cond instr) - FxChain fxs p -> getPatchFx fxs =<< onCondPlay cond p - LayerPatch xs -> onLayered xs (onCondPlay cond) +genSplitPatch :: (SigSpace a, Sigs a) => Maybe SyntSkin -> (MidiChn -> (D -> BoolD) -> MonoInstr a -> SE a) -> (MidiChn -> (CsdNote D -> SE a) -> SE a) -> Patch a -> D -> Patch a -> SE a +genSplitPatch maybeSkin playMonoInstr playInstr a dt b = liftA2 (+) (leftSplit maybeSkin dt a) (rightSplit maybeSkin dt b) + where + leftSplit maybeSkin dt a = onCondPlay maybeSkin ( `lessThan` dt) ( `lessThan` (sig dt)) a + rightSplit maybeSkin dt a = onCondPlay maybeSkin ( `greaterThanEquals` dt) ( `greaterThanEquals` (sig dt)) a + + onCondPlay maybeSkin cond condSig x = case x of + MonoSynt spec instr -> playMonoInstr (monoSyntChn spec) cond (runSkin instr maybeSkin) + PolySynt spec instr -> playInstr (polySyntChn spec) (restrictPolyInstr cond (runSkin instr maybeSkin)) + SetSkin skin p -> onCondPlay (Just skin) cond condSig p + FxChain fxs p -> getPatchFx maybeSkin fxs =<< onCondPlay maybeSkin cond condSig p + LayerPatch xs -> onLayered xs (onCondPlay maybeSkin cond condSig) SplitPatch a dt b -> liftA2 (+) - (onCondPlay (\x -> cond x &&* (x `lessThan` dt)) a) - (onCondPlay (\x -> cond x &&* (x `greaterThanEquals` dt)) b) + (onCondPlay maybeSkin (\x -> cond x &&* (x `lessThan` dt)) (\x -> condSig x &&* (x `lessThan` (sig dt))) a) + (onCondPlay maybeSkin (\x -> cond x &&* (x `greaterThanEquals` dt)) (\x -> condSig x &&* (x `greaterThanEquals` (sig dt) )) b) restrictPolyInstr :: (Sigs a) => (D -> BoolD) -> (CsdNote D -> SE a) -> CsdNote D -> SE a restrictPolyInstr cond instr note@(amp, cps) = do @@ -312,57 +396,86 @@ (writeRef ref 0) readRef ref +restrictMonoInstr :: (Sigs a) => (Sig -> BoolSig) -> MonoInstr a -> MonoInstr a +restrictMonoInstr cond instr arg = instr $ arg { monoGate = monoGate arg * gate2 } + where + cps = monoCps arg + gate2 = ifB (cond cps) 1 0 + -------------------------------------------------------------- -- sched -- | Plays a patch with event stream. atSched :: (SigSpace a, Sigs a) => Patch a -> Evt (Sco (CsdNote D)) -> SE a -atSched x evt = case x of - MonoSynt _ instr -> error "atSched is not defined for monophonic synthesizers" - PolySynt _ instr -> playInstr instr - FxChain fxs p -> getPatchFx fxs =<< atSched p evt - LayerPatch xs -> onLayered xs (\patch -> atSched patch evt) - SplitPatch a t b -> genSplitPatch (const playInstr) a t b - where playInstr instr = return $ sched instr evt - +atSched x evt = go Nothing x evt + where + go maybeSkin x evt = case x of + MonoSynt spec instr -> (runSkin instr maybeSkin) =<< (fmap (smoothMonoSpec spec) $ monoSched evt) + PolySynt _ instr -> playInstr (runSkin instr maybeSkin) + SetSkin skin p -> newSkin skin p + FxChain fxs p -> getPatchFx maybeSkin fxs =<< rec p + LayerPatch xs -> onLayered xs rec + SplitPatch a t b -> genSplitPatch maybeSkin (const $ const playMonoInstr) (const playInstr) a t b + where + rec x = go maybeSkin x evt + newSkin skin x = go (Just skin) x evt + playInstr instr = return $ sched instr evt + playMonoInstr instr = instr =<< monoSched evt -- | Plays a patch with event stream with stop-note event stream. atSchedUntil :: (SigSpace a, Sigs a) => Patch a -> Evt (CsdNote D) -> Evt b -> SE a -atSchedUntil x evt stop = case x of - MonoSynt _ instr -> error "atSchedUntil is not defined for monophonic synthesizers" - PolySynt _ instr -> playInstr instr - FxChain fxs p -> getPatchFx fxs =<< atSchedUntil p evt stop - LayerPatch xs -> onLayered xs (\patch -> atSchedUntil patch evt stop) - SplitPatch a cps b -> genSplitPatch (const playInstr) a cps b - where playInstr instr = return $ schedUntil instr evt stop +atSchedUntil x evt stop = go Nothing x evt stop + where + go maybeSkin x evt stop = case x of + MonoSynt _ instr -> playMonoInstr (runSkin instr maybeSkin) + PolySynt _ instr -> playInstr (runSkin instr maybeSkin) + SetSkin skin p -> newSkin skin p + FxChain fxs p -> getPatchFx maybeSkin fxs =<< rec p + LayerPatch xs -> onLayered xs rec + SplitPatch a cps b -> genSplitPatch maybeSkin (const $ const playMonoInstr) (const playInstr) a cps b + where + rec x = go maybeSkin x evt stop + newSkin skin x = go (Just skin) x evt stop + playInstr instr = return $ schedUntil instr evt stop + playMonoInstr instr = instr =<< monoSchedUntil evt stop +-- | Plays notes indefinetely (it's more useful for monophonic synthesizers). +atSchedHarp :: (SigSpace a, Sigs a) => Patch a -> Evt (CsdNote D) -> SE a +atSchedHarp x evt = atSchedUntil x evt mempty + -------------------------------------------------------------- -- sco -- | Plays a patch with scores. -atSco :: (SigSpace a, Sigs a) => Patch a -> Sco (CsdNote D) -> Sco (Mix a) -atSco x sc = case x of - MonoSynt _ instr -> error "atSco is not defined for monophonic synthesizers" - PolySynt _ instr -> sco instr sc - FxChain fxs p -> eff (getPatchFx fxs) $atSco p sc - LayerPatch xs -> har $ fmap (\(vol, p) -> atSco (mul vol p) sc) xs - SplitPatch a cps b -> undefined --- eff (getPatchFx p) $ sco (patchInstr p) sc +atSco :: forall a . (SigSpace a, Sigs a) => Patch a -> Sco (CsdNote D) -> Sco (Mix a) +atSco x sc = go Nothing x sc + where + go maybeSkin x sc = case x of + MonoSynt _ instr -> monoSco (runSkin instr maybeSkin) sc + PolySynt _ instr -> sco (runSkin instr maybeSkin) sc + SetSkin skin p -> newSkin skin p + FxChain fxs p -> eff (getPatchFx maybeSkin fxs) $ rec p + LayerPatch xs -> har $ fmap (\(vol, p) -> rec (mul vol p)) xs + SplitPatch a cps b -> scoSplitPatch maybeSkin a cps b sc + where + rec x = go maybeSkin x sc + newSkin skin x = go (Just skin) x sc -scoSplitPatch :: (SigSpace a, Sigs a) => Patch a -> D -> Patch a -> Sco (CsdNote D) -> Sco (Mix a) -scoSplitPatch a dt b sc = har [leftSplit dt a, rightSplit dt b] - where - leftSplit dt a = onCondPlay ( `lessThan` dt) a - rightSplit dt a = onCondPlay ( `greaterThanEquals` dt) a + scoSplitPatch :: Maybe SyntSkin -> Patch a -> D -> Patch a -> Sco (CsdNote D) -> Sco (Mix a) + scoSplitPatch maybeSkin a dt b sc = har [leftSplit maybeSkin dt a, rightSplit maybeSkin dt b] + where + leftSplit maybeSkin dt a = onCondPlay maybeSkin ( `lessThan` dt) a + rightSplit maybeSkin dt a = onCondPlay maybeSkin ( `greaterThanEquals` dt) a - onCondPlay cond x = case x of - MonoSynt spec instr -> error "Split doesn't work for monophonic synths. Pleas use only polyphonic synths." - PolySynt spec instr -> sco (restrictPolyInstr cond instr) sc - FxChain fxs p -> eff (getPatchFx fxs) $ atSco p sc - LayerPatch xs -> har $ fmap (\(vol, p) -> atSco (mul vol p) sc) xs - SplitPatch a dt b -> har - [ onCondPlay (\x -> cond x &&* (x `lessThan` dt)) a - , onCondPlay (\x -> cond x &&* (x `greaterThanEquals` dt)) b ] + onCondPlay maybeSkin cond x = case x of + MonoSynt spec instr -> error "Split doesn't work for monophonic synths with Scores. Please use only polyphonic synths in this case." + PolySynt spec instr -> sco (restrictPolyInstr cond (runSkin instr maybeSkin)) sc + SetSkin skin p -> onCondPlay (Just skin) cond p + FxChain fxs p -> eff (getPatchFx maybeSkin fxs) $ go maybeSkin p sc + LayerPatch xs -> har $ fmap (\(vol, p) -> go maybeSkin (mul vol p) sc) xs + SplitPatch a dt b -> har + [ onCondPlay maybeSkin (\x -> cond x &&* (x `lessThan` dt)) a + , onCondPlay maybeSkin (\x -> cond x &&* (x `greaterThanEquals` dt)) b ] onLayered :: (SigSpace a, Sigs a) => [(Sig, Patch a)] -> (Patch a -> SE a) -> SE a onLayered xs f = fmap sum $ mapM (\(vol, p) -> fmap (mul vol) $ f p) xs @@ -374,6 +487,7 @@ onMonoSyntSpec f x = case x of MonoSynt spec instr -> MonoSynt (f spec) instr PolySynt spec instr -> PolySynt spec instr + SetSkin skin p -> SetSkin skin $ onMonoSyntSpec f p FxChain fxs p -> FxChain fxs $ onMonoSyntSpec f p LayerPatch xs -> LayerPatch $ mapSnd (onMonoSyntSpec f) xs SplitPatch a cps b -> SplitPatch (onMonoSyntSpec f a) cps (onMonoSyntSpec f b) @@ -383,6 +497,7 @@ setMidiChn chn x = case x of MonoSynt spec instr -> MonoSynt (spec { monoSyntChn = chn }) instr PolySynt spec instr -> PolySynt (spec { polySyntChn = chn }) instr + SetSkin skin p -> SetSkin skin $ go p FxChain fxs p -> FxChain fxs $ go p LayerPatch xs -> LayerPatch $ mapSnd go xs SplitPatch a cps b -> SplitPatch (go a) cps (go b) @@ -391,16 +506,22 @@ -- | Sets the monophonic to sharp transition and quick release. setMonoSharp :: Patch a -> Patch a -setMonoSharp = onMonoSyntSpec (\x -> x { monoSyntSlideTime = 0.005, monoSyntRelease = 0.05 }) +setMonoSharp = setMonoSlide 0.004 --- | Sets the monophonic patch to hold mode. All notes are held. -setMonoHold :: Patch a -> Patch a -setMonoHold = onMonoSyntSpec (\x -> x { monoSyntHold = True }) +-- | Sets the slide time for pitch and amplitude of monophomic synthesizers. +setMonoSlide :: D -> Patch a -> Patch a +setMonoSlide slideTime = onMonoSyntSpec (\x -> x { monoSyntSlideTime = Just slideTime }) -- | Transpose the patch by a given ratio. We can use the functions semitone, cent to calculate the ratio. transPatch :: D -> Patch a -> Patch a -transPatch k = mapMonoPolyInstr (\instr -> instr . second ( * sig k)) (\instr -> instr . second ( * k)) +transPatch k = mapMonoPolyInstr (transMonoInstr k) (transPolyInstr k) +transMonoInstr :: D -> MonoInstr a -> MonoInstr a +transMonoInstr k instr = \arg -> instr (arg { monoCps = sig k * monoCps arg }) + +transPolyInstr :: D -> Instr D a -> Instr D a +transPolyInstr k instr = \(amp, cps) -> instr (amp, k * cps) + -- | Adds an effect to the patch's instrument. addInstrFx :: Fx a -> Patch a -> Patch a addInstrFx f p = mapPatchInstr (\instr -> f <=< instr) p @@ -410,19 +531,20 @@ addPreFx dw f p = case p of FxChain fxs (PolySynt spec instr) -> FxChain (addFx fxs) (PolySynt spec instr) FxChain fxs (MonoSynt spec instr) -> FxChain (addFx fxs) (MonoSynt spec instr) + SetSkin skin p -> SetSkin skin $ addPreFx dw f p PolySynt spec instr -> FxChain fxSpec $ PolySynt spec instr MonoSynt spec instr -> FxChain fxSpec $ MonoSynt spec instr LayerPatch xs -> LayerPatch $ mapSnd (addPreFx dw f) xs SplitPatch a cps b -> SplitPatch (addPreFx dw f a) cps (addPreFx dw f b) where addFx xs = xs ++ fxSpec - fxSpec = [FxSpec dw f] + fxSpec = [return $ FxSpec dw f] -- | Appends an effect after patch's effect. addPostFx :: DryWetRatio -> Fx a -> Patch a -> Patch a addPostFx dw f p = case p of - FxChain fxs rest -> FxChain (fxSpec : fxs) rest - _ -> FxChain [fxSpec] p + FxChain fxs rest -> FxChain (return fxSpec : fxs) rest + _ -> FxChain [return fxSpec] p where fxSpec = FxSpec dw f -------------------------------------------------------------- @@ -430,9 +552,10 @@ -- | Plays a patch when the condition signal is satisfied. Can be useful for switches. patchWhen :: (Sigs a) => BoolSig -> Patch a -> Patch a patchWhen cond x = case x of - MonoSynt spec instr -> MonoSynt spec (playWhen cond instr) - PolySynt spec instr -> PolySynt spec (playWhen cond instr) - FxChain fxs p -> FxChain (fmap (mapFun (playWhen cond)) fxs) (rec p) + MonoSynt spec instr -> MonoSynt spec (fmap (playWhen cond) instr) + PolySynt spec instr -> PolySynt spec (fmap (playWhen cond) instr) + SetSkin skin p -> SetSkin skin $ rec p + FxChain fxs p -> FxChain (fmap (fmap $ mapFun (playWhen cond)) fxs) (rec p) LayerPatch xs -> LayerPatch $ mapSnd rec xs SplitPatch a cps b -> SplitPatch (rec a) cps (rec b) where @@ -450,18 +573,19 @@ harmonPatch :: (SigSpace b, Sigs b) => [Sig] -> [D] -> Patch b -> Patch b harmonPatch amps freqs = tfmInstr monoTfm polyTfm where - monoTfm instr = \(amp, cps) -> fmap sum $ zipWithM (\a f -> fmap (mul a) $ instr (amp, cps * f)) amps (fmap sig freqs) - polyTfm instr = \(amp, cps) -> fmap sum $ zipWithM (\a f -> fmap (mul a) $ instr (amp, cps * f)) amps freqs + monoTfm instr = \arg -> fmap sum $ zipWithM (\a f -> fmap (mul a) $ transMonoInstr f instr arg) amps freqs + polyTfm instr = \arg -> fmap sum $ zipWithM (\a f -> fmap (mul a) $ transPolyInstr f instr arg) amps freqs -- | Adds an octave below note for a given patch to make the sound deeper. deepPad :: (SigSpace b, Sigs b) => Patch b -> Patch b deepPad = harmonPatch (fmap (* 0.75) [1, 0.5]) [1, 0.5] -- | Transforms instrument functions for polyphonic and monophonic patches. -tfmInstr :: ((CsdNote Sig -> SE b) -> (CsdNote Sig -> SE b)) -> ((CsdNote D -> SE b) -> (CsdNote D -> SE b)) -> Patch b -> Patch b +tfmInstr :: (MonoInstr b -> MonoInstr b) -> ((CsdNote D -> SE b) -> (CsdNote D -> SE b)) -> Patch b -> Patch b tfmInstr monoTfm polyTfm x = case x of - MonoSynt spec instr -> MonoSynt spec $ monoTfm instr - PolySynt spec instr -> PolySynt spec $ polyTfm instr + MonoSynt spec instr -> MonoSynt spec $ fmap monoTfm instr + PolySynt spec instr -> PolySynt spec $ fmap polyTfm instr + SetSkin skin p -> SetSkin skin $ rec p FxChain fxs p -> FxChain fxs $ rec p SplitPatch a cps b -> SplitPatch (rec a) cps (rec b) LayerPatch xs -> LayerPatch $ mapSnd rec xs @@ -508,7 +632,7 @@ -- | Sound font patch. sfPatch :: Sf -> Patch2 -sfPatch sf = PolySynt def $ \(amp, cps) -> return $ sfCps sf 0.5 amp cps +sfPatch sf = polySynt $ \(amp, cps) -> return $ sfCps sf 0.5 amp cps ------------------------------------------------ -- Csound API @@ -531,28 +655,33 @@ patchByNameMidiTemp tm = genPatchByNameMidi (cpsmidi'Sig tm) (cpsmidi'D tm) genPatchByNameMidi :: forall a . (SigSpace a, Sigs a) => (Sig -> Sig) -> (D -> D) -> String -> Patch a -> SE a -genPatchByNameMidi monoKey2cps polyKey2cps name x = case x of - MonoSynt spec instr -> monoSynt spec instr - PolySynt spec instr -> polySynt spec instr - FxChain fxs p -> getPatchFx fxs =<< rec p - LayerPatch xs -> onLayered xs rec - SplitPatch a cps b -> splitPatch a cps b - where - rec = genPatchByNameMidi monoKey2cps polyKey2cps name - - monoSynt spec instr = instr =<< fmap convert (trigNamedMono portTime relTime name) +genPatchByNameMidi monoKey2cps polyKey2cps name x = go Nothing x + where + go maybeSkin x = case x of + MonoSynt spec instr -> monoSynt spec (runSkin instr maybeSkin) + PolySynt spec instr -> polySynt spec (runSkin instr maybeSkin) + SetSkin skin p -> newSkin skin p + FxChain fxs p -> getPatchFx maybeSkin fxs =<< rec p + LayerPatch xs -> onLayered xs rec + SplitPatch a cps b -> splitPatch a cps b where - convert (vol, pch) = (vel2ampSig vol, monoKey2cps pch) - portTime = monoSyntSlideTime spec - relTime = monoSyntRelease spec + rec = go maybeSkin + newSkin skin = go (Just skin) - polySynt spec instr = trigByNameMidi name go - where - go :: (D, D, Unit) -> SE a - go (pitch, vol, _) = instr (vel2amp vol, polyKey2cps pitch) + monoSynt spec instr = instr =<< (fmap (smoothMonoSpec spec . convert) $ trigNamedMono name) + where + convert arg = arg { monoAmp = vel2ampSig (monoAmp arg), monoCps = monoKey2cps (monoCps arg) } - splitPatch a cps b = genSplitPatch polySynt a cps b + polySynt spec instr = trigByNameMidi name go + where + go :: (D, D, Unit) -> SE a + go (pitch, vol, _) = instr (vel2amp vol, polyKey2cps pitch) + splitPatch a cps b = genSplitPatch maybeSkin playMonoInstr playInstr a cps b + + playMonoInstr chn cond instr = monoSynt (def { monoSyntChn = chn }) instr + playInstr chn instr = polySynt (def { polySyntChn = chn }) instr + vel2amp :: D -> D vel2amp vol = ((vol / 64) ** 2) / 2 @@ -636,3 +765,63 @@ vel2ampSig vol = ((vol / 64) ** 2) / 2 -} + + +-------------------------------------------------- +-- special functions to add effects + +-- | Make an effect out of a pure function. +fxSig :: SigSpace a => (Sig -> Sig) -> GenFxSpec a +fxSig f = fxSpec 1 (return . mapSig f) + +-- | Make an effect out of a pure function and specify dry/wet ratio. +fxSigMix :: SigSpace a => Sig -> (Sig -> Sig) -> GenFxSpec a +fxSigMix ratio f = fxSpec ratio (return . mapSig f) + +-- | Make an effect out of a stereo pure function. +fxSig2 :: (Sig2 -> Sig2) -> GenFxSpec Sig2 +fxSig2 f = fxSpec 1 (return . f) + +-- | Make an effect out of a stereo pure function and specify dry/wet ratio. +fxSigMix2 :: Sig -> (Sig2 -> Sig2) -> GenFxSpec Sig2 +fxSigMix2 ratio f = fxSpec ratio (return . f) + + +-- | Adds post fx with pure signal function. +mapFx :: SigSpace a => (Sig -> Sig) -> Patch a -> Patch a +mapFx f = addPostFx 1 (return . mapSig f) + +-- | Adds post fx with pure signal function and specifies dry/wet ratio. +mapFx' :: SigSpace a => Sig -> (Sig -> Sig) -> Patch a -> Patch a +mapFx' rate f = addPostFx rate (return . mapSig f) + +-- | Adds post fx with effectful signal function. +bindFx :: BindSig a => (Sig -> SE Sig) -> Patch a -> Patch a +bindFx f = addPostFx 1 (bindSig f) + +-- | Adds post fx with effectful signal function and specifies dry/wet ratio. +bindFx' :: BindSig a => Sig -> (Sig -> SE Sig) -> Patch a -> Patch a +bindFx' rate f = addPostFx rate (bindSig f) + + +-- | Adds pre fx with pure signal function. +mapPreFx :: SigSpace a => (Sig -> Sig) -> Patch a -> Patch a +mapPreFx f = addPreFx 1 (return . mapSig f) + +-- | Adds pre fx with pure signal function and specifies dry/wet ratio. +mapPreFx' :: SigSpace a => Sig -> (Sig -> Sig) -> Patch a -> Patch a +mapPreFx' rate f = addPreFx rate (return . mapSig f) + +-- | Adds pre fx with effectful signal function. +bindPreFx :: BindSig a => (Sig -> SE Sig) -> Patch a -> Patch a +bindPreFx f = addPreFx 1 (bindSig f) + +-- | Adds pre fx with effectful signal function and specifies dry/wet ratio. +bindPreFx' :: BindSig a => Sig -> (Sig -> SE Sig) -> Patch a -> Patch a +bindPreFx' rate f = addPreFx rate (bindSig f) + +instance RenderCsd Patch1 where + renderCsdBy opt p = renderCsdBy opt (atMidi p) + +instance RenderCsd Patch2 where + renderCsdBy opt p = renderCsdBy opt (atMidi p) diff --git a/src/Csound/Air/Wav.hs b/src/Csound/Air/Wav.hs --- a/src/Csound/Air/Wav.hs +++ b/src/Csound/Air/Wav.hs @@ -15,7 +15,7 @@ -- Loads the sample in the table and plays it back from RAM. The sample should be short. The size of the table is limited. -- It's up to 6 minutes for 44100 sample rate, 5 minutes for 48000 and 2.8 minutes for 96000. LoopMode(..), ramSnd, ramSnd1, - ramTab, mincer, + ramTab, mincer, temposcal, Phsr(..), lphase, relPhsr, sndPhsr, phsrBounce, phsrOnce, ram, ram1, @@ -26,8 +26,11 @@ -- ** Simple audio reading functions (Mono) - readRam1, loopRam1, readSeg1, loopSeg1, readRel1, loopRel1, + readRam1, loopRam1, readSeg1, loopSeg1, readRel1, loopRel1, + -- ** Scaling audio files + scaleDrum, scaleHarm, scaleDrum1, scaleHarm1, scaleWav1, scaleWav, + -- * Writing sound files SampleFormat(..), writeSigs, writeWav, writeAiff, writeWav1, writeAiff1, @@ -52,7 +55,7 @@ import Csound.Typed import Csound.Typed.Opcode -import Csound.Tab(mp3s, wavs, WavChn(..), Mp3Chn(..)) +import Csound.Tab(mp3s, mp3Left, wavs, wavLeft, WavChn(..), Mp3Chn(..)) import Csound.Control.Instr(withDur, sched) import Csound.SigSpace(mapSig) @@ -295,6 +298,25 @@ mincer b1 b2 b3 b4 b5 = Sig $ f <$> unSig b1 <*> unSig b2 <*> unSig b3 <*> unTab b4 <*> unSig b5 where f a1 a2 a3 a4 a5 = opcs "mincer" [(Ar,[Ar,Kr,Kr,Kr,Kr,Ir,Ir])] [a1,a2,a3,a4,a5] +-- | temposcal — Phase-locked vocoder processing with onset detection/processing, 'tempo-scaling'. +-- +-- temposcal implements phase-locked vocoder processing using function tables containing +-- sampled-sound sources, with GEN01, and temposcal will accept deferred allocation tables. +-- +-- This opcode allows for time and frequency-independent scaling. Time is advanced internally, +-- but controlled by a tempo scaling parameter; when an onset is detected, timescaling is +-- momentarily stopped to avoid smearing of attacks. The quality of the effect is generally +-- improved with phase locking switched on. +-- +-- temposcal will also scale pitch, independently of frequency, using a transposition factor (k-rate). +-- +-- > asig temposcal ktimescal, kamp, kpitch, ktab, klock [,ifftsize, idecim, ithresh] +-- +-- csound doc: +temposcal :: Sig -> Sig -> Sig -> Tab -> Sig -> Sig +temposcal b1 b2 b3 b4 b5 = Sig $ f <$> unSig b1 <*> unSig b2 <*> unSig b3 <*> unTab b4 <*> unSig b5 + where f a1 a2 a3 a4 a5 = opcs "temposcal" [(Ar,[Kr,Kr,Kr,Kr,Kr,Ir,Ir,Ir])] [a1,a2,a3,a4,a5] + -- | Mincer. We can playback a table and scale by tempo and pitch. -- -- > mincer fidelity table pointer pitch @@ -454,7 +476,7 @@ readRam :: Fidelity -> TempoSig-> PitchSig -> String -> Sig2 readRam winSize tempo pitch file = ram winSize (phsrOnce $ sndPhsr file tempo) pitch --- | Loop over file and scales it by tempo and pitch. +-- | Loop over file and scales it by tempo and pitch (it's based on mincer opcode). loopRam :: Fidelity -> TempoSig-> PitchSig -> String -> Sig2 loopRam winSize tempo pitch file = ram winSize (sndPhsr file tempo) pitch @@ -503,3 +525,37 @@ -- | The mono version of loopRel. loopRel1 :: Fidelity -> (Sig, Sig) -> TempoSig-> PitchSig -> String -> Sig loopRel1 winSize (kmin, kmax) tempo pitch file = ram1 winSize (relPhsr file kmin kmax tempo) pitch + +------------------------------------ +-- scaling tempo/pitch based on temposcale + +-- | ScaleWav function with fidelity set for drum-loops. +scaleDrum :: TempoSig -> PitchSig -> String -> Sig2 +scaleDrum = scaleWav (-2) + +-- | ScaleWav function with fidelity set for hormonical-loops. +scaleHarm :: TempoSig -> PitchSig -> String -> Sig2 +scaleHarm = scaleWav 0 + +-- | ScaleWav1 function with fidelity set for drum-loops. +scaleDrum1 :: TempoSig -> PitchSig -> String -> Sig +scaleDrum1 = scaleWav1 (-2) + +-- | ScaleWav1 function with fidelity set for hormonical-loops. +scaleHarm1 :: TempoSig -> PitchSig -> String -> Sig +scaleHarm1 = scaleWav1 0 + +-- | Scaling mono audio files (accepts both midi and wav). It's based on temposcal Csound opcode. +scaleWav1 :: Fidelity -> TempoSig -> PitchSig -> String -> Sig +scaleWav1 winSizePowerOfTwo tempo pitch filename = go $ if mp3 then mp3Left filename else wavLeft filename + where + go = simpleTempoScale winSizePowerOfTwo tempo pitch + mp3 = isMp3 filename + + +-- | Scaling stereo audio files (accepts both midi and wav). It's based on temposcal Csound opcode. +scaleWav :: Fidelity -> TempoSig -> PitchSig -> String -> Sig2 +scaleWav winSizePowerOfTwo tempo pitch filename = (go $ mkTab False 0 filename, go $ mkTab False 1 filename) + where go = simpleTempoScale winSizePowerOfTwo tempo pitch + +simpleTempoScale winSizePowerOfTwo tempo pitch t = temposcal tempo 1 pitch t 1 `withD` (2 ** (winSizePowerOfTwo + 11)) diff --git a/src/Csound/Air/Wave.hs b/src/Csound/Air/Wave.hs --- a/src/Csound/Air/Wave.hs +++ b/src/Csound/Air/Wave.hs @@ -1,6 +1,8 @@ -- | Basic waveforms that are used most often. -- A waveform function takes in a time varied frequency (in Hz). module Csound.Air.Wave ( + Wave, + -- * Bipolar osc, oscBy, saw, isaw, pulse, sqr, pw, tri, ramp, blosc, @@ -54,6 +56,8 @@ import Csound.Typed.Opcode hiding (lfo) import Csound.Tab(setSize, elins, sine, cosine, sines4, triTab, pwTab, sawTab, sqrTab) import Csound.SigSpace + +type Wave = Sig -> SE Sig -- | A pure tone (sine wave). osc :: Sig -> Sig diff --git a/src/Csound/Base.hs b/src/Csound/Base.hs --- a/src/Csound/Base.hs +++ b/src/Csound/Base.hs @@ -51,4 +51,5 @@ lpshold, loopseg, loopxseg, partikkel, syncgrain, granule, sndwarp, sndwarpst, fof2, line, delay, - metro, dust) + metro, dust, + duserrnd, cuserrnd, urd) diff --git a/src/Csound/Control/Evt.hs b/src/Csound/Control/Evt.hs --- a/src/Csound/Control/Evt.hs +++ b/src/Csound/Control/Evt.hs @@ -3,10 +3,10 @@ Evt(..), Bam, Tick, -- * Core functions - boolToEvt, evtToBool, sigToEvt, evtToSig, stepper, + boolToEvt, evtToBool, evtToTrig, sigToEvt, evtToSig, stepper, filterE, filterSE, accumSE, accumE, filterAccumE, filterAccumSE, - Snap, snapshot, snaps, snaps2, sync, syncBpm, + Snap, snapshot, readSnap, snaps, snaps2, sync, syncBpm, -- * Opcodes metro, gaussTrig, dust, metroSig, dustSig, dustSig2, impulseE, changedE, triggerE, loadbang, impulse, metroE, @@ -37,12 +37,19 @@ type Tick = Evt Unit +-- | Converts event stream to signal. The first argument is initial value. It holds the value while nothing happens. +-- If the event happens it overwrites the current value of the output signal. evtToSig :: D -> (Evt D) -> Sig evtToSig initVal evts = retrigs (return . sig) $ fmap return $ devt initVal loadbang <> evts +-- | Converts an event stream to boolean signal. It's True when something happens and False otherwise. evtToBool :: Evt a -> BoolSig evtToBool a = ( ==* 1) $ changed $ return $ evtToSig 0 $ cycleE [1, 0] a +-- | Creates a trigger signal out of event stream. It equals to 1 when something happens and 0 otherwise. +evtToTrig :: Evt a -> Sig +evtToTrig = (\b -> ifB b 1 0) . evtToBool + -- | Constant event stream. It produces the same value (the first argument) -- all the time. devt :: D -> Evt a -> Evt D @@ -179,16 +186,16 @@ -- > randSkip prob -- -- where @prob@ is probability of includinng the element in the output stream. -randSkip :: D -> Evt a -> Evt a -randSkip d = filterSE (const $ fmap (<=* d) $ random (0::D) 1) +randSkip :: Sig -> Evt a -> Evt a +randSkip d = filterSE (const $ fmap (<=* ir d) $ random (0::D) 1) -- | Skips elements at random. -- -- > randSkip probFun -- -- It behaves just like @randSkip@, but probability depends on the value. -randSkipBy :: (a -> D) -> Evt a -> Evt a -randSkipBy d = filterSE (\x -> fmap (<=* d x) $ random (0::D) 1) +randSkipBy :: (a -> Sig) -> Evt a -> Evt a +randSkipBy d = filterSE (\x -> fmap (<=* ir (d x)) $ random (0::D) 1) -- | When something happens on the given event stream resulting -- event stream contains an application of some unary function to the @@ -226,7 +233,7 @@ oneOf vals evt = listAt vals $ randInts (0, int $ length vals) evt -- | Represents a values with frequency of occurence. -type Rnds a = [(D, a)] +type Rnds a = [(Sig, a)] -- | Constructs an event stream that contains values from the @@ -239,9 +246,9 @@ accs = accumWeightList $ fmap fst rnds vals = fmap snd rnds -takeByWeight :: (Tuple a, Arg a) => [D] -> [a] -> D -> a +takeByWeight :: (Tuple a, Arg a) => [Sig] -> [a] -> D -> a takeByWeight accumWeights vals at = - guardedArg (zipWith (\w val -> (at `lessThan` w, val)) accumWeights vals) (last vals) + guardedArg (zipWith (\w val -> (at `lessThan` ir w, val)) accumWeights vals) (last vals) accumWeightList :: Num a => [a] -> [a] accumWeightList = go 0 diff --git a/src/Csound/Control/Gui.hs b/src/Csound/Control/Gui.hs --- a/src/Csound/Control/Gui.hs +++ b/src/Csound/Control/Gui.hs @@ -59,7 +59,7 @@ widget, sink, source, display, sinkSource, sinkSlice, sourceSlice, mapSource, mapGuiSource, mhor, mver, msca, - joinSource, + joinSource, fromSource, fromSourceSE, resizeSource, -- * Panels panel, win, panels, panelBy, @@ -72,18 +72,18 @@ -- * Lifters -- | An easy way to combine visuals for sound sources. - hlifts, vlifts, + hlifts, vlifts, gridLifts, lift1, hlift2, vlift2, hlift3, vlift3, hlift4, vlift4, hlift5, vlift5, -- ** Lifters with visual scaling - hlifts', vlifts', + hlifts', vlifts', hlift2', vlift2', hlift3', vlift3', hlift4', vlift4', hlift5', vlift5', -- * Monadic binds hbind, vbind, happly, vapply, hmapM, vmapM, - hbind', vbind', happly', vapply', hmapM', vmapM' + hbind', vbind', happly', vapply', hmapM', vmapM', gridMapM ) where import Control.Monad @@ -128,6 +128,23 @@ v <- mv return (g, v) +fromSource :: Source a -> SE a +fromSource a = do + (gui, asig) <- a + panel gui + return asig + +fromSourceSE :: Source (SE a) -> SE a +fromSourceSE = join . fromSource + +-- | Resizes all default minimal sizes for all elements in the source. +-- It affects the total sizes of the widgets. So for example if our UI is too big +-- and it doesn't fir to the screen we can make it smaller by scaling: +-- +-- > resizeSource (0.75, 0.5) uiSource +resizeSource :: (Double, Double) -> Source a -> Source a +resizeSource scaleXY = mapGuiSource $ resizeGui scaleXY + ---------------------------------------------------------------------------------- -- easy grouppings for GUIs @@ -139,6 +156,11 @@ vlifts :: ([a] -> b) -> [Source a] -> Source b vlifts = genLifts ver +-- | Groups a list of Source-widgets. The visuals are put on the grid. +-- The first argument is numer of elements i each row. +gridLifts :: Int -> ([a] -> b) -> [Source a] -> Source b +gridLifts rowLength = genLifts (grid rowLength) + -- | Groups a list of Source-widgets. The visuals are horizontally aligned. -- It uses the list of proportions. hlifts' :: [Double] -> ([a] -> b) -> [Source a] -> Source b @@ -315,17 +337,26 @@ (gb, b) <- mf a return (gui ga gb, b) +-- | Creates a list of sources with mapping a function and stacks them horizontally. hmapM :: (a -> Source b) -> [a] -> Source [b] hmapM = genMapM hor +-- | Creates a list of sources with mapping a function and stacks them vertically. vmapM :: (a -> Source b) -> [a] -> Source [b] vmapM = genMapM ver +-- | It's like @hmapM@ but we can supply the list of relative sizes. hmapM' :: [Double] -> (a -> Source b) -> [a] -> Source [b] hmapM' ks = genMapM (\xs -> hor $ zipWith sca ks xs) +-- | It's like @hvapM@ but we can supply the list of relative sizes. vmapM' :: [Double] -> (a -> Source b) -> [a] -> Source [b] vmapM' ks = genMapM (\xs -> ver $ zipWith sca ks xs) + +-- | Creates a list of sources with mapping a function and puts them on the grid. +-- The first argument is the number of items in the row. +gridMapM :: Int -> (a -> Source b) -> [a] -> Source [b] +gridMapM rowLength = genMapM (grid rowLength) genMapM :: ([Gui] -> Gui) -> (a -> Source b) -> [a] -> Source [b] genMapM gui f xs = source $ do diff --git a/src/Csound/Control/Gui/Layout.hs b/src/Csound/Control/Gui/Layout.hs --- a/src/Csound/Control/Gui/Layout.hs +++ b/src/Csound/Control/Gui/Layout.hs @@ -10,9 +10,27 @@ -- of the rectangles (by scaling one side of the rectangle). In place of rectangle -- we can put an empty space. module Csound.Control.Gui.Layout ( - hor, ver, space, sca, horSca, verSca, - padding, margin + hor, ver, space, sca, horSca, verSca, grid, + padding, margin, ScaleFactor, resizeGui, ) where import Csound.Typed.Gui + + +-- | Layouts the widgets in grid. The first argument is the number of widgets in the row. +-- +-- > grid rowLength widgets +grid :: Int -> [Gui] -> Gui +grid columnSize guis = ver $ fmap hor $ splitList columnSize guis + where + splitList n xs = case splitAt n xs of + (res, []) -> [res ++ spaceTail xs] + (as,rest) -> as : splitList n rest + + spaceTail xs = replicate n space + where n = getMissingToEven (length xs) + + getMissingToEven total = case total `mod` columnSize of + 0 -> 0 + n -> columnSize - n diff --git a/src/Csound/Control/Instr.hs b/src/Csound/Control/Instr.hs --- a/src/Csound/Control/Instr.hs +++ b/src/Csound/Control/Instr.hs @@ -73,7 +73,7 @@ -- the time domain (stretching the timeline) you can do it in the Mix-version -- (after the invokation of the instrument). All notes are rescaled all the -- way down the Score-structure. - Sco, Mix, sco, mix, eff, + Sco, Mix, sco, mix, eff, monoSco, mixLoop, sco_, mix_, mixLoop_, mixBy, infiniteDur, @@ -84,7 +84,7 @@ sched, retrig, schedHarp, schedUntil, schedToggle, sched_, schedUntil_, schedBy, schedHarpBy, - withDur, + withDur, monoSched, -- * Api -- | We can create named instruments. then we can trigger the named instruments with Csound API. @@ -101,14 +101,19 @@ -- * Overload -- | Converters to make it easier a construction of the instruments. - Outs(..), onArg, AmpInstr(..), CpsInstr(..) + Outs(..), onArg, AmpInstr(..), CpsInstr(..), + + -- * Imperative instruments + InstrRef, newInstr, scheduleEvent, turnoff2, negateInstrRef, addFracInstrRef, + newOutInstr, noteOn, noteOff ) where +import Control.Applicative import Control.Monad.Trans.Class import Csound.Dynamic hiding (str, Sco(..), when1, alwaysOn) -import Csound.Typed -import Csound.Typed.Opcode hiding (initc7) +import Csound.Typed +import Csound.Typed.Opcode hiding (initc7, turnoff2) import Csound.Control.Overload import Temporal.Media(Event(..), mapEvents) diff --git a/src/Csound/Control/Midi.hs b/src/Csound/Control/Midi.hs --- a/src/Csound/Control/Midi.hs +++ b/src/Csound/Control/Midi.hs @@ -5,10 +5,11 @@ Msg, Channel, midi, midin, pgmidi, ampCps, midi_, midin_, pgmidi_, -- * Mono-midi synth - monoMsg, holdMsg, trigNamedMono, + monoMsg, holdMsg, trigNamedMono, genMonoMsg, smoothMonoArg, + genFilteredMonoMsg, genFilteredMonoMsgTemp, -- ** Custom temperament - monoMsgTemp, holdMsgTemp, + monoMsgTemp, holdMsgTemp, genMonoMsgTemp, -- * Midi event streams midiKeyOn, midiKeyOff, -- * Reading midi note parameters @@ -29,6 +30,7 @@ import Csound.Control.Overload import Csound.Control.Instr(alwaysOn) import Csound.Control.Evt(Tick) +import Csound.Types import Csound.Tuning @@ -89,7 +91,7 @@ -- -- > monoMsg channel portamentoTime releaseTime monoMsg :: MidiChn -> D -> D -> SE (Sig, Sig) -monoMsg = genMonoMsg cpsmidi +monoMsg = smoothMonoMsg cpsmidi -- | Produces midi amplitude and frequency as a signal. -- The signal fades out when nothing is pressed. @@ -99,13 +101,40 @@ -- -- > monoMsgTemp temperament channel portamentoTime releaseTime monoMsgTemp :: Temp -> MidiChn -> D -> D -> SE (Sig, Sig) -monoMsgTemp tm = genMonoMsg (cpsmidi' tm) +monoMsgTemp tm = smoothMonoMsg (cpsmidi' tm) -genMonoMsg :: (Msg -> D) -> MidiChn -> D -> D -> SE (Sig, Sig) -genMonoMsg key2cps chn portTime relTime = do - (amp, cps, status) <- genAmpCpsSig key2cps (toMidiFun chn) +-- | Produces an argument for monophonic midi-synth. +-- The signal fades out when nothing is pressed. +-- It can be used in mono-synths. +-- +-- > genMonoMsg channel +genMonoMsg :: MidiChn -> SE MonoArg +genMonoMsg chn = genAmpCpsSig cpsmidi (toMidiFun chn) + +-- | Just like mono @genMonoMsg@ but also we can alter the temperament. The temperament spec goes first. +-- +-- > genMonoMsgTemp temperament channel +genMonoMsgTemp :: Temp -> MidiChn -> SE MonoArg +genMonoMsgTemp tm chn = genAmpCpsSig (cpsmidi' tm) (toMidiFun chn) + +smoothMonoArg :: D -> MonoArg -> MonoArg +smoothMonoArg time arg = arg { monoAmp = port (monoAmp arg) time, monoCps = port (monoCps arg) time } + +smoothMonoMsg :: (Msg -> D) -> MidiChn -> D -> D -> SE (Sig, Sig) +smoothMonoMsg key2cps chn portTime relTime = do + (MonoArg amp cps status _) <- genAmpCpsSig key2cps (toMidiFun chn) return (port amp portTime * port status relTime, port cps portTime) + +genFilteredMonoMsg :: MidiChn -> (D -> BoolD) -> SE MonoArg +genFilteredMonoMsg chn cond = filteredGenAmpCpsSig cpsmidi (toMidiFun chn) cond + +-- | Just like mono @genMonoMsg@ but also we can alter the temperament. The temperament spec goes first. +-- +-- > genMonoMsgTemp temperament channel +genFilteredMonoMsgTemp :: Temp -> MidiChn -> (D -> BoolD) -> SE MonoArg +genFilteredMonoMsgTemp tm chn cond = filteredGenAmpCpsSig (cpsmidi' tm) (toMidiFun chn) cond + -- | Produces midi amplitude and frequency as a signal and holds the -- last value till the next one is present. -- It can be used in mono-synths. Arguments are portamento time @@ -132,19 +161,53 @@ return (port amp portTime, port cps portTime) -genAmpCpsSig :: (Msg -> D) -> ((Msg -> SE Sig) -> SE Sig) -> SE (Sig, Sig, Sig) + +genAmpCpsSig :: (Msg -> D) -> ((Msg -> SE Sig) -> SE Sig) -> SE MonoArg genAmpCpsSig key2cps midiFun = do - ref <- newGlobalRef ((0, 0) :: (Sig, Sig)) - status <- midiFun (instr ref) - let resStatus = ifB (downsamp status ==* 0) 0 1 - (amp, cps) <- readRef ref - return (downsamp amp, downsamp cps, resStatus) - where - instr :: Ref (Sig, Sig) -> Msg -> SE Sig - instr hNote msg = do - writeRef hNote (sig $ ampmidi msg 1, sig $ key2cps msg) - return 1 + ref <- newGlobalRef ((0, 0) :: (Sig, Sig)) + status <- midiFun (instr ref) + (amp, cps) <- readRef ref + return $ makeMonoArg (amp, cps) status + where + makeMonoArg (amp, cps) status = MonoArg kamp kcps resStatus retrig + where + kamp = downsamp amp + kcps = downsamp cps + kstatus = downsamp status + resStatus = ifB (kstatus ==* 0) 0 1 + retrig = changed [kamp, kcps, kstatus] + instr :: Ref (Sig, Sig) -> Msg -> SE Sig + instr hNote msg = do + writeRef hNote (sig $ ampmidi msg 1, sig $ key2cps msg) + return 1 + +filteredGenAmpCpsSig :: (Msg -> D) -> ((Msg -> SE Sig) -> SE Sig) -> (D -> BoolD) -> SE MonoArg +filteredGenAmpCpsSig key2cps midiFun cond = do + ref <- newGlobalRef ((0, 0) :: (Sig, Sig)) + status <- midiFun (instr ref) + (amp, cps) <- readRef ref + return $ makeMonoArg (amp, cps) status + where + makeMonoArg (amp, cps) status = MonoArg kamp kcps resStatus retrig + where + kamp = downsamp amp + kcps = downsamp cps + kstatus = downsamp status + resStatus = ifB (kstatus ==* 0) 0 1 + retrig = changed [kamp, kcps, kstatus] + + instr :: Ref (Sig, Sig) -> Msg -> SE Sig + instr hNote msg = do + resRef <- newRef 0 + whenElseD (cond $ key2cps msg) + (do + writeRef hNote (sig $ ampmidi msg 1, sig $ key2cps msg) + writeRef resRef 1) + (do + writeRef resRef 0) + readRef resRef + genHoldAmpCpsSig :: (Msg -> D) -> ((Msg -> SE ()) -> SE ()) -> SE (Sig, Sig) genHoldAmpCpsSig key2cps midiFun = do ref <- newGlobalRef ((0, 0) :: (Sig, Sig)) @@ -165,8 +228,8 @@ -- > i "givenName" 0 pitchKey volumeKey -- note off -- -- The output is a pair of signals @(midiVolume, midiPitch)@. -trigNamedMono :: D -> D -> String -> SE (Sig, Sig) -trigNamedMono portTime relTime name = namedMonoMsg portTime relTime name +trigNamedMono :: String -> SE MonoArg +trigNamedMono name = namedMonoMsg name namedAmpCpsSig:: String -> SE (Sig, Sig, Sig) namedAmpCpsSig name = do diff --git a/src/Csound/Control/Osc.hs b/src/Csound/Control/Osc.hs --- a/src/Csound/Control/Osc.hs +++ b/src/Csound/Control/Osc.hs @@ -1,7 +1,25 @@ -- | Open Sound Control. module Csound.Control.Osc( - initOsc, listenOsc, sendOsc + OscHost, OscPort, OscAddress, OscType, + -- * Server + initOsc, listenOsc, ListenOsc, OscVal, + listenOscVal, listenOscSig, listenOscSig2, + -- * Client + sendOsc ) where import Csound.Typed +type ListenOsc a = OscAddress -> a -> SE a + +-- | Listens for continuous signal from OSC-channel +-- +-- > listenOscSig host address initValue +listenOscSig :: OscRef -> OscAddress -> Sig -> SE Sig +listenOscSig = listenOscVal + +-- | Listens for pair of continuous signals from OSC-channel +-- +-- > listenOscSig2 host address initValue +listenOscSig2 :: OscRef -> OscAddress -> Sig2 -> SE Sig2 +listenOscSig2 = listenOscVal diff --git a/src/Csound/Control/SE.hs b/src/Csound/Control/SE.hs --- a/src/Csound/Control/SE.hs +++ b/src/Csound/Control/SE.hs @@ -1,6 +1,7 @@ module Csound.Control.SE( SE, Ref, writeRef, readRef, modifyRef, mixRef, newRef, sensorsSE, newGlobalRef, globalSensorsSE, - newCtrlRef, newGlobalCtrlRef, newClearableGlobalRef, newTab, newGlobalTab + newCtrlRef, newGlobalCtrlRef, newClearableGlobalRef, newTab, newGlobalTab, + whileRef, whileRef ) where import Csound.Typed.Control diff --git a/src/Csound/IO.hs b/src/Csound/IO.hs --- a/src/Csound/IO.hs +++ b/src/Csound/IO.hs @@ -38,12 +38,36 @@ csd, csdBy, -- * Render and run with cabbage - runCabbage, runCabbageBy + runCabbage, runCabbageBy, + + -- * Aliases for type inference + -- | Sometimes the type class @RenderCsd@ is too whide for us. + -- It cn be hard to use in the interpreter without explicit signatures. + -- There are functions to help the type inference. + -- ** For processing inputs + onCard1, onCard2, onCard4, onCard6, onCard8, + + -- * Config with command line arguments + -- | With the functions we can add global config parameters to the rendered file. + -- We can supply different parameters with @--omacro@ flag. + -- + -- An example: + -- + -- > dac $ osc (sig $ readMacrosDouble "FREQ" 440) + -- + -- Here we define frequency as a global parameter. It's available by name @"FREQ"@. + -- If we run the program with no flags it would play the default 440 Hz. But we can change that like this: + -- + -- > csound tmp.csd --omacro:FREQ=330 + -- + -- We can update the macro-arguments with flag @--omacro:NAME=VALUE@. + readMacrosString, readMacrosDouble, readMacrosInt ) where import System.Process import qualified Control.Exception as E +import Control.Monad import Data.Monoid import Data.Default import Csound.Typed @@ -129,6 +153,9 @@ instance (Sigs a) => RenderCsd (a -> Sig2) where renderCsdBy opt f = renderEffBy opt (return . f) +instance (Sigs a) => RenderCsd (a -> Sig3) where + renderCsdBy opt f = renderEffBy opt (return . f) + instance (Sigs a) => RenderCsd (a -> Sig4) where renderCsdBy opt f = renderEffBy opt (return . f) @@ -153,94 +180,155 @@ instance (Sigs a) => RenderCsd (a -> (Sig8, Sig8, Sig8, Sig8)) where renderCsdBy opt f = renderEffBy opt (return . f) -instance (Sigs a, Sigs b) => RenderCsd (a -> SE b) where +instance (Sigs a) => RenderCsd (a -> SE Sig) where renderCsdBy opt f = renderEffBy opt f +instance (Sigs a) => RenderCsd (a -> SE Sig2) where + renderCsdBy opt f = renderEffBy opt f + +instance (Sigs a) => RenderCsd (a -> SE Sig3) where + renderCsdBy opt f = renderEffBy opt f + +instance (Sigs a) => RenderCsd (a -> SE Sig4) where + renderCsdBy opt f = renderEffBy opt f + +instance (Sigs a) => RenderCsd (a -> SE Sig5) where + renderCsdBy opt f = renderEffBy opt f + +instance (Sigs a) => RenderCsd (a -> SE Sig6) where + renderCsdBy opt f = renderEffBy opt f + +instance (Sigs a) => RenderCsd (a -> SE (Sig2, Sig2)) where + renderCsdBy opt f = renderEffBy opt f + +instance (Sigs a) => RenderCsd (a -> SE (Sig2, Sig2, Sig2)) where + renderCsdBy opt f = renderEffBy opt f + +instance (Sigs a) => RenderCsd (a -> SE Sig8) where + renderCsdBy opt f = renderEffBy opt f + +instance (Sigs a) => RenderCsd (a -> SE (Sig2, Sig2, Sig2, Sig2)) where + renderCsdBy opt f = renderEffBy opt f + +instance (Sigs a) => RenderCsd (a -> SE (Sig8, Sig8)) where + renderCsdBy opt f = renderEffBy opt f + +instance (Sigs a) => RenderCsd (a -> SE (Sig8, Sig8, Sig8, Sig8)) where + renderCsdBy opt f = renderEffBy opt f + +instance (Sigs a) => RenderCsd (a -> Source Sig) where + renderCsdBy opt f = renderEffBy opt (fromSource . f) + +instance (Sigs a) => RenderCsd (a -> Source Sig2) where + renderCsdBy opt f = renderEffBy opt (fromSource . f) + +instance (Sigs a) => RenderCsd (a -> Source Sig3) where + renderCsdBy opt f = renderEffBy opt (fromSource . f) + +instance (Sigs a) => RenderCsd (a -> Source Sig4) where + renderCsdBy opt f = renderEffBy opt (fromSource . f) + +instance (Sigs a) => RenderCsd (a -> Source (Sig2, Sig2)) where + renderCsdBy opt f = renderEffBy opt (fromSource . f) + +instance (Sigs a) => RenderCsd (a -> Source Sig6) where + renderCsdBy opt f = renderEffBy opt (fromSource . f) + +instance (Sigs a) => RenderCsd (a -> Source (Sig2, Sig2, Sig2)) where + renderCsdBy opt f = renderEffBy opt (fromSource . f) + +instance (Sigs a) => RenderCsd (a -> Source Sig8) where + renderCsdBy opt f = renderEffBy opt (fromSource . f) + +instance (Sigs a) => RenderCsd (a -> Source (Sig2, Sig2, Sig2, Sig2)) where + renderCsdBy opt f = renderEffBy opt (fromSource . f) + +instance (Sigs a) => RenderCsd (a -> Source (Sig8, Sig8)) where + renderCsdBy opt f = renderEffBy opt (fromSource . f) + +instance (Sigs a) => RenderCsd (a -> Source (Sig8, Sig8, Sig8, Sig8)) where + renderCsdBy opt f = renderEffBy opt (fromSource . f) + +instance (Sigs a) => RenderCsd (a -> Source (SE Sig)) where + renderCsdBy opt f = renderEffBy opt (fromSourceSE . f) + +instance (Sigs a) => RenderCsd (a -> Source (SE Sig2)) where + renderCsdBy opt f = renderEffBy opt (fromSourceSE . f) + +instance (Sigs a) => RenderCsd (a -> Source (SE Sig3)) where + renderCsdBy opt f = renderEffBy opt (fromSourceSE . f) + +instance (Sigs a) => RenderCsd (a -> Source (SE Sig4)) where + renderCsdBy opt f = renderEffBy opt (fromSourceSE . f) + +instance (Sigs a) => RenderCsd (a -> Source (SE Sig5)) where + renderCsdBy opt f = renderEffBy opt (fromSourceSE . f) + +instance (Sigs a) => RenderCsd (a -> Source (SE Sig6)) where + renderCsdBy opt f = renderEffBy opt (fromSourceSE . f) + +instance (Sigs a) => RenderCsd (a -> Source (SE (Sig2, Sig2))) where + renderCsdBy opt f = renderEffBy opt (fromSourceSE . f) + +instance (Sigs a) => RenderCsd (a -> Source (SE (Sig2, Sig2, Sig2))) where + renderCsdBy opt f = renderEffBy opt (fromSourceSE . f) + +instance (Sigs a) => RenderCsd (a -> Source (SE Sig8)) where + renderCsdBy opt f = renderEffBy opt (fromSourceSE . f) + +instance (Sigs a) => RenderCsd (a -> Source (SE (Sig2, Sig2, Sig2, Sig2))) where + renderCsdBy opt f = renderEffBy opt (fromSourceSE . f) + +instance (Sigs a) => RenderCsd (a -> Source (SE (Sig8, Sig8))) where + renderCsdBy opt f = renderEffBy opt (fromSourceSE . f) + +instance (Sigs a) => RenderCsd (a -> Source (SE (Sig8, Sig8, Sig8, Sig8))) where + renderCsdBy opt f = renderEffBy opt (fromSourceSE . f) + instance RenderCsd (Source Sig) where - renderCsdBy opt a = renderCsdBy opt res - where res = do - (gui, asig) <- a - panel gui - return asig + renderCsdBy opt a = renderCsdBy opt (fromSource a) instance RenderCsd (Source Sig2) where - renderCsdBy opt a = renderCsdBy opt res - where res = do - (gui, asig) <- a - panel gui - return asig + renderCsdBy opt a = renderCsdBy opt (fromSource a) instance RenderCsd (Source Sig4) where - renderCsdBy opt a = renderCsdBy opt res - where res = do - (gui, asig) <- a - panel gui - return asig + renderCsdBy opt a = renderCsdBy opt (fromSource a) instance RenderCsd (Source (Sig2, Sig2)) where renderCsdBy opt a = renderCsdBy opt $ mapSource (\((a1, a2), (b1, b2)) -> (a1, a2, b1, b2)) a instance RenderCsd (Source Sig6) where - renderCsdBy opt a = renderCsdBy opt res - where res = do - (gui, asig) <- a - panel gui - return asig + renderCsdBy opt a = renderCsdBy opt (fromSource a) instance RenderCsd (Source (Sig2, Sig2, Sig2)) where renderCsdBy opt a = renderCsdBy opt $ mapSource (\((a1, a2), (b1, b2), (c1, c2)) -> (a1, a2, b1, b2, c1, c2)) a instance RenderCsd (Source Sig8) where - renderCsdBy opt a = renderCsdBy opt res - where res = do - (gui, asig) <- a - panel gui - return asig + renderCsdBy opt a = renderCsdBy opt (fromSource a) instance RenderCsd (Source (Sig2, Sig2, Sig2, Sig2)) where renderCsdBy opt a = renderCsdBy opt $ mapSource (\((a1, a2), (b1, b2), (c1, c2), (d1, d2)) -> (a1, a2, b1, b2, c1, c2, d1, d2)) a instance RenderCsd (Source (SE Sig)) where - renderCsdBy opt a = renderCsdBy opt res - where res = do - (gui, asig) <- a - panel gui - asig + renderCsdBy opt a = renderCsdBy opt (fromSourceSE a) instance RenderCsd (Source (SE Sig2)) where - renderCsdBy opt a = renderCsdBy opt res - where res = do - (gui, asig) <- a - panel gui - asig + renderCsdBy opt a = renderCsdBy opt (fromSourceSE a) instance RenderCsd (Source (SE Sig4)) where - renderCsdBy opt a = renderCsdBy opt res - where res = do - (gui, asig) <- a - panel gui - asig + renderCsdBy opt a = renderCsdBy opt (fromSourceSE a) instance RenderCsd (Source (SE (Sig2, Sig2))) where renderCsdBy opt a = renderCsdBy opt $ mapSource (fmap $ \((a1, a2), (b1, b2)) -> (a1, a2, b1, b2)) a - instance RenderCsd (Source (SE Sig6)) where - renderCsdBy opt a = renderCsdBy opt res - where res = do - (gui, asig) <- a - panel gui - asig + renderCsdBy opt a = renderCsdBy opt (fromSourceSE a) instance RenderCsd (Source (SE (Sig2, Sig2, Sig2))) where renderCsdBy opt a = renderCsdBy opt $ mapSource (fmap $ \((a1, a2), (b1, b2), (c1, c2)) -> (a1, a2, b1, b2, c1, c2)) a instance RenderCsd (Source (SE Sig8)) where - renderCsdBy opt a = renderCsdBy opt res - where res = do - (gui, asig) <- a - panel gui - asig + renderCsdBy opt a = renderCsdBy opt (fromSourceSE a) instance RenderCsd (Source (SE (Sig2, Sig2, Sig2, Sig2))) where renderCsdBy opt a = renderCsdBy opt $ mapSource (fmap $ \((a1, a2), (b1, b2), (c1, c2), (d1, d2)) -> (a1, a2, b1, b2, c1, c2, d1, d2)) a @@ -382,3 +470,25 @@ writeCsdBy opt "tmp.csd" a runWithUserInterrupt $ "Cabbage " ++ "tmp.csd" where opt = opt' <> setCabbage + +------------------------------ + +-- | Alias to process inputs of single input audio-card. +onCard1 :: (Sig -> a) -> (Sig -> a) +onCard1= id + +-- | Alias to process inputs of stereo input audio-card. +onCard2 :: (Sig2 -> a) -> (Sig2 -> a) +onCard2= id + +-- | Alias to process inputs of audio-card with 4 inputs. +onCard4 :: (Sig4 -> a) -> (Sig4 -> a) +onCard4= id + +-- | Alias to process inputs of audio-card with 6 inputs. +onCard6 :: (Sig6 -> a) -> (Sig6 -> a) +onCard6= id + +-- | Alias to process inputs of audio-card with 8 inputs. +onCard8 :: (Sig8 -> a) -> (Sig8 -> a) +onCard8= id diff --git a/src/Csound/Options.hs b/src/Csound/Options.hs --- a/src/Csound/Options.hs +++ b/src/Csound/Options.hs @@ -9,7 +9,7 @@ setDac, setAdc, setDacBy, setAdcBy, setThru, setSilent, setMidiDevice, setMa, setMessageLevel, noTrace, - setCabbage, + setCabbage, -- * Flags -- | Csound's command line flags. See original documentation for @@ -34,7 +34,7 @@ Displays(..), DisplayMode(..), -- * Performance Configuration and Control - Config(..) + Config(..) ) where import Data.Monoid @@ -61,6 +61,13 @@ setJack :: String -> Options setJack name = def { csdFlags = def { rtaudio = Just $ Jack name "input" "output" } } + +-- | Defines a header for a Jacko opcodes. The Jacko opcodes allow for greater flexibility +-- with definition of Jack-client. See the Csound docs for details and the datatype @Jacko@. +-- +-- > csound doc: +setJacko :: Jacko -> Options +setJacko jackoSpec = def { csdJacko = Just jackoSpec } setCoreAudio :: Options setCoreAudio = def { csdFlags = def { rtaudio = Just $ CoreAudio } } diff --git a/src/Csound/SigSpace.hs b/src/Csound/SigSpace.hs --- a/src/Csound/SigSpace.hs +++ b/src/Csound/SigSpace.hs @@ -6,8 +6,10 @@ FlexibleContexts #-} module Csound.SigSpace( SigSpace(..), BindSig(..), mul, mul', on, uon, At(..), MixAt(..), bat, bmixAt, - cfd, cfd4, cfds, cfdSpec, cfdSpec4, cfdsSpec, - wsum + cfd, cfd4, cfds, cfdSpec, cfdSpec4, cfdsSpec, wsum, + + -- * Stereo sig space + SigSpace2(..), BindSig2(..), mul2, mul2' ) where import Control.Monad @@ -17,73 +19,6 @@ import Csound.Types import Csound.Typed.Opcode(pvscross, pvscale, pvsmix, balance) --- | A class for easy way to process the outputs of the instruments. -class SigSpace a where - mapSig :: (Sig -> Sig) -> a -> a - --- | A class for easy way to process the outputs of the instruments. -class SigSpace a => BindSig a where - bindSig :: (Sig -> SE Sig) -> a -> SE a - --- | Scaling the sound. -mul :: SigSpace a => Sig -> a -> a -mul k = mapSig (k * ) - --- | Scaling the sound with effectful signal. -mul' :: BindSig a => SE Sig -> a -> SE a -mul' k = bindSig (\x -> fmap (* x) k) - --- 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 - 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) - --- | Crossfade. --- --- > cfd coeff sig1 sig2 --- --- 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 - 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. --- --- > cfd4 x y a b c d --- --- * (0, 0) is for a --- --- * (1, 0) is for b --- --- * (1, 1) is for c --- --- * (0, 1) is for d -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 -cfds :: (Num a, SigSpace a) => [Sig] -> [a] -> a -cfds = genCfds 0 cfd - -- | Spectral crossfade. cfdSpec :: Sig -> Spec -> Spec -> Spec cfdSpec coeff a b = pvscross a b (1 - coeff) coeff @@ -105,468 +40,11 @@ wsum :: (Num a, SigSpace a) => [(Sig, a)] -> a wsum = sum . fmap (uncurry mul) -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 (SE Sig) where mapSig f = fmap (mapSig f) -instance BindSig (SE Sig) where bindSig f = fmap (bindSig f) - -instance SigSpace (SE (Sig, Sig)) where mapSig f = fmap (mapSig f) -instance BindSig (SE (Sig, Sig)) where bindSig f = fmap (bindSig f) - -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 (SE (Sig, Sig, Sig, Sig)) where mapSig f = fmap (mapSig f) -instance BindSig (SE (Sig, Sig, Sig, Sig)) where bindSig f = fmap (bindSig f) - ------------------------------------------------------ --- numeric instances - --- Num - -instance Num (SE Sig) where - (+) = liftA2 (+) - (*) = liftA2 (*) - negate = fmap negate - - fromInteger = return . fromInteger - signum = fmap signum - abs = fmap abs - -instance Num (SE (Sig, Sig)) where - (+) = liftA2 (+) - (*) = liftA2 (*) - negate = fmap negate - - fromInteger = return . fromInteger - signum = fmap signum - abs = fmap abs - -instance Num (SE (Sig, Sig, Sig)) where - (+) = liftA2 (+) - (*) = liftA2 (*) - negate = fmap negate - - fromInteger = return . fromInteger - signum = fmap signum - abs = fmap abs - -instance Num (SE (Sig, Sig, Sig, Sig)) where - (+) = liftA2 (+) - (*) = liftA2 (*) - negate = fmap negate - - fromInteger = return . fromInteger - signum = fmap signum - abs = fmap abs - -instance Num (a -> Sig) where - (+) = liftA2 (+) - (*) = liftA2 (*) - negate = fmap negate - - fromInteger = return . fromInteger - signum = fmap signum - abs = fmap abs - -instance Num (a -> (Sig, Sig)) where - (+) = liftA2 (+) - (*) = liftA2 (*) - negate = fmap negate - - fromInteger = return . fromInteger - signum = fmap signum - abs = fmap abs - -instance Num (a -> (Sig, Sig, Sig)) where - (+) = liftA2 (+) - (*) = liftA2 (*) - negate = fmap negate - - fromInteger = return . fromInteger - signum = fmap signum - abs = fmap abs - -instance Num (a -> (Sig, Sig, Sig, Sig)) where - (+) = liftA2 (+) - (*) = liftA2 (*) - negate = fmap negate - - fromInteger = return . fromInteger - signum = fmap signum - abs = fmap abs - - -instance Num (a -> SE Sig) where - (+) = liftA2 (+) - (*) = liftA2 (*) - negate = fmap negate - - fromInteger = return . fromInteger - signum = fmap signum - abs = fmap abs - -instance Num (a -> SE (Sig, Sig)) where - (+) = liftA2 (+) - (*) = liftA2 (*) - negate = fmap negate - - fromInteger = return . fromInteger - signum = fmap signum - abs = fmap abs - -instance Num (a -> SE (Sig, Sig, Sig)) where - (+) = liftA2 (+) - (*) = liftA2 (*) - negate = fmap negate - - fromInteger = return . fromInteger - signum = fmap signum - abs = fmap abs - -instance Num (a -> SE (Sig, Sig, Sig, Sig)) where - (+) = liftA2 (+) - (*) = liftA2 (*) - negate = fmap negate - - fromInteger = return . fromInteger - signum = fmap signum - abs = fmap abs - --- Fractional - -instance Fractional (Sig, Sig) where - (a1, a2) / (b1, b2) = (a1 / b1, a2 / b2) - fromRational a = (fromRational a, fromRational a) - -instance Fractional (Sig, Sig, Sig) where - (a1, a2, a3) / (b1, b2, b3) = (a1 / b1, a2 / b2, a3 / b3) - fromRational a = (fromRational a, fromRational a, fromRational a) - -instance Fractional (Sig, Sig, Sig, Sig) where - (a1, a2, a3, a4) / (b1, b2, b3, b4) = (a1 / b1, a2 / b2, a3 / b3, a4 / b4) - fromRational a = (fromRational a, fromRational a, fromRational a, fromRational a) - -instance Fractional (SE Sig) where - (/) = liftA2 (/) - fromRational = return . fromRational - -instance Fractional (SE (Sig, Sig)) where - (/) = liftA2 (/) - fromRational = return . fromRational - -instance Fractional (SE (Sig, Sig, Sig)) where - (/) = liftA2 (/) - fromRational = return . fromRational - -instance Fractional (SE (Sig, Sig, Sig, Sig)) where - (/) = liftA2 (/) - fromRational = return . fromRational - -instance Fractional (a -> SE Sig) where - (/) = liftA2 (/) - fromRational = return . fromRational - -instance Fractional (a -> SE (Sig, Sig)) where - (/) = liftA2 (/) - fromRational = return . fromRational - -instance Fractional (a -> SE (Sig, Sig, Sig)) where - (/) = liftA2 (/) - fromRational = return . fromRational - -instance Fractional (a -> SE (Sig, Sig, Sig, Sig)) where - (/) = liftA2 (/) - fromRational = return . fromRational - -instance Fractional (a -> Sig) where - (/) = liftA2 (/) - fromRational = return . fromRational - -instance Fractional (a -> (Sig, Sig)) where - (/) = liftA2 (/) - fromRational = return . fromRational - -instance Fractional (a -> (Sig, Sig, Sig)) where - (/) = liftA2 (/) - fromRational = return . fromRational - -instance Fractional (a -> (Sig, Sig, Sig, Sig)) where - (/) = liftA2 (/) - fromRational = return . fromRational - ------------------------------------------------------------------------ ------------------------------------------------------------------------ - -class SigSpace b => At a b c where - type AtOut a b c :: * - at :: (a -> b) -> c -> AtOut a b c - -- | It applies an effect and balances the processed signal by original one. bat :: At Sig a b => (Sig -> a) -> b -> AtOut Sig a b bat f = at (\x -> mapSig ( `balance` x) $ f x) -instance SigSpace a => At Sig Sig a where - type AtOut Sig Sig a = a - at f a = mapSig f a - ------------------------------------------------------- --- for (Sig -> SE Sig) - -instance At Sig (SE Sig) Sig where - type AtOut Sig (SE Sig) Sig = SE Sig - at f a = f a - -instance At Sig (SE Sig) Sig2 where - type AtOut Sig (SE Sig) Sig2 = SE Sig2 - at f a = bindSig f a - -instance At Sig (SE Sig) Sig3 where - type AtOut Sig (SE Sig) Sig3 = SE Sig3 - at f a = bindSig f a - -instance At Sig (SE Sig) Sig4 where - type AtOut Sig (SE Sig) Sig4 = SE Sig4 - at f a = bindSig f a - -instance At Sig (SE Sig) (SE Sig) where - type AtOut Sig (SE Sig) (SE Sig) = SE Sig - at f a = join $ bindSig f a - -instance At Sig (SE Sig) (SE Sig2) where - type AtOut Sig (SE Sig) (SE Sig2) = SE Sig2 - at f a = join $ bindSig f a - -instance At Sig (SE Sig) (SE Sig3) where - type AtOut Sig (SE Sig) (SE Sig3) = SE Sig3 - at f a = join $ bindSig f a - -instance At Sig (SE Sig) (SE Sig4) where - type AtOut Sig (SE Sig) (SE Sig4) = SE Sig4 - at f a = join $ bindSig f a - ------------------------------------------------------ --- mono to stereo - -instance At Sig Sig2 Sig where - type AtOut Sig Sig2 Sig = Sig2 - at f a = f a - -instance At Sig Sig2 (SE Sig) where - type AtOut Sig Sig2 (SE Sig) = SE Sig2 - at f a = fmap f a - -instance At Sig Sig2 Sig2 where - type AtOut Sig Sig2 Sig2 = Sig2 - at f a = 0.5 * (f (fst a) + f (snd a)) - -instance At Sig Sig2 (SE Sig2) where - type AtOut Sig Sig2 (SE Sig2) = SE Sig2 - at f a = fmap (at f) a - ---------------------------------------------------------- - ---------------------------------------------------------- --- Sig2 -> Sig2 - -fromMono a = (a, a) - -instance At Sig2 Sig2 Sig where - type AtOut Sig2 Sig2 Sig = Sig2 - at f a = f $ fromMono a - -instance At Sig2 Sig2 Sig2 where - type AtOut Sig2 Sig2 Sig2 = Sig2 - at f a = f a - -instance At Sig2 Sig2 (SE Sig) where - type AtOut Sig2 Sig2 (SE Sig) = SE Sig2 - at f a = fmap (f . fromMono) a - -instance At Sig2 Sig2 (SE Sig2) where - type AtOut Sig2 Sig2 (SE Sig2) = SE Sig2 - at f a = fmap f a - ---------------------------------------------- --- Sig2 -> SE Sig2 - -instance At Sig2 (SE Sig2) Sig where - type AtOut Sig2 (SE Sig2) Sig = SE Sig2 - at f a = f $ fromMono a - -instance At Sig2 (SE Sig2) Sig2 where - type AtOut Sig2 (SE Sig2) Sig2 = SE Sig2 - at f a = f a - -instance At Sig2 (SE Sig2) (SE Sig) where - type AtOut Sig2 (SE Sig2) (SE Sig) = SE Sig2 - at f a = (f . fromMono) =<< a - -instance At Sig2 (SE Sig2) (SE Sig2) where - type AtOut Sig2 (SE Sig2) (SE Sig2) = SE Sig2 - at f a = f =<< a - ------------------------------------------------------------------------ ------------------------------------------------------------------------ --- MixAt - --- | 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 - mixAt :: Sig -> (a -> b) -> c -> AtOut a b c - -- | It applies an effect and balances the processed signal by original one. -- Also it applies an effect and mixes the processed balanced signal with original one. bmixAt :: MixAt Sig a b => Sig -> (Sig -> a) -> b -> AtOut Sig a b bmixAt k f = mixAt k (\x -> mapSig ( `balance` x) $ f x) - ---------------------------------------------------- - -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 - mixAt k f dry = do - wet <- f dry - return $ cfd k dry wet - -instance MixAt Sig (SE Sig) Sig2 where - mixAt k f (dry1, dry2) = do - wet1 <- f dry1 - wet2 <- f dry2 - return $ cfd k (dry1, dry2) (wet1, wet2) - -instance MixAt Sig (SE Sig) Sig3 where - mixAt k f (dry1, dry2, dry3) = do - wet1 <- f dry1 - wet2 <- f dry2 - wet3 <- f dry3 - return $ cfd k (dry1, dry2, dry3) (wet1, wet2, wet3) - -instance MixAt Sig (SE Sig) Sig4 where - mixAt k f (dry1, dry2, dry3, dry4) = do - wet1 <- f dry1 - wet2 <- f dry2 - wet3 <- f dry3 - wet4 <- f dry4 - return $ cfd k (dry1, dry2, dry3, dry4) (wet1, wet2, wet3, wet4) - -instance MixAt Sig (SE Sig) (SE Sig) where - mixAt k f dry = do - dry1 <- dry - wet1 <- f dry1 - return $ cfd k dry1 wet1 - -instance MixAt Sig (SE Sig) (SE Sig2) where - mixAt k f dry = do - (dry1, dry2) <- dry - wet1 <- f dry1 - wet2 <- f dry2 - return $ cfd k (dry1, dry2) (wet1, wet2) - -instance MixAt Sig (SE Sig) (SE Sig3) where - mixAt k f dry = do - (dry1, dry2, dry3) <- dry - wet1 <- f dry1 - wet2 <- f dry2 - wet3 <- f dry3 - return $ cfd k (dry1, dry2, dry3) (wet1, wet2, wet3) - -instance MixAt Sig (SE Sig) (SE Sig4) where - mixAt k f dry = do - (dry1, dry2, dry3, dry4) <- dry - wet1 <- f dry1 - wet2 <- f dry2 - wet3 <- f dry3 - wet4 <- f dry4 - return $ cfd k (dry1, dry2, dry3, dry4) (wet1, wet2, wet3, wet4) - ------------------------------------------------------ --- 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 - mixAt k f dry = fmap (\x -> cfd k (x, x) (f x)) dry - -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 - mixAt k f dry = do - (dry1, dry2) <- dry - let wet = 0.5 * (f dry1 + f dry2) - return $ cfd k (dry1, dry2) wet - ---------------------------------------------------------- - ---------------------------------------------------------- --- Sig2 -> Sig2 - -instance MixAt Sig2 Sig2 Sig where - mixAt k f dry1 = cfd k dry wet - where - dry = fromMono dry1 - wet = f dry - -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 - mixAt k f dry1 = do - dry <- fmap fromMono dry1 - let wet = f dry - return $ cfd k dry wet - -instance MixAt Sig2 Sig2 (SE Sig2) where - mixAt k f drySe = do - dry <- drySe - let wet = f dry - return $ cfd k dry wet - - ---------------------------------------------- --- Sig2 -> SE Sig2 - -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 - mixAt k f dry = do - wet <- f dry - return $ cfd k dry wet - -instance MixAt Sig2 (SE Sig2) (SE Sig) where - mixAt k f dry1 = do - dry <- fmap fromMono dry1 - wet <- f dry - return $ cfd k dry wet - -instance MixAt Sig2 (SE Sig2) (SE Sig2) where - mixAt k f drySe = do - dry <- drySe - wet <- f dry - return $ cfd k dry wet diff --git a/src/Csound/Tab.hs b/src/Csound/Tab.hs --- a/src/Csound/Tab.hs +++ b/src/Csound/Tab.hs @@ -23,14 +23,22 @@ -- * Read from files WavChn(..), Mp3Chn(..), wavs, wavLeft, wavRight, mp3s, mp3Left, mp3Right, mp3m, + readNumFile, readTrajectoryFile, readPvocex, readMultichannel, -- * (In)Harmonic series PartialStrength, PartialNumber, PartialPhase, PartialDC, sines, sines3, sines2, sines1, sines4, buzzes, bwSines, bwOddSines, + mixOnTab, mixTabs, + tabSines1, tabSines2, + -- * Wavelets + waveletTab, rescaleWaveletTab, + -- ** Special cases sine, cosine, sigmoid, sigmoidRise, sigmoidFall, tanhSigmoid, triTab, sawTab, sqrTab, pwTab, + tanhTab, rescaleTanhTab, expTab, rescaleExpTab, soneTab, rescaleSoneTab, + fareyTab, -- * Interpolants -- | All funtions have the same shape of arguments: @@ -59,20 +67,40 @@ -- > lins [0, 1, 1, 3, 0] -- -- all these expressions are equivalent. - consts, lins, cubes, exps, splines, startEnds, + consts, lins, cubes, exps, splines, startEnds, tabseg, bpLins, bpExps, -- ** Equally spaced interpolants - econsts, elins, ecubes, eexps, esplines, estartEnds, + econsts, elins, ecubes, eexps, esplines, estartEnds, etabseg, -- * Polynomials polys, chebs1, chebs2, bessels, + + -- * Random values + + -- ** Distributions + uniDist, linDist, triDist, expDist, biexpDist, gaussDist, + cauchyDist, pcauchyDist, betaDist, weibullDist, poissonDist, + tabDist, + -- *** Distributions with levels + uniDist', linDist', triDist', expDist', biexpDist', gaussDist', + cauchyDist', pcauchyDist', betaDist', weibullDist', poissonDist', + -- ** Rand values and ranges + randDist, rangeDist, + + -- * Windows winHamming, winHanning, winBartlett, winBlackman, - winHarris, winGaussian, winKaiser, winRectangle, winSync, + winHarris, winGauss, winKaiser, winRectangle, winSync, -- * Padsynth padsynth, PadsynthSpec(..), PadsynthShape(..), defPadsynthSpec, + -- * Harmonics + tabHarmonics, + + -- * Normalize table + normTab, NormTabSpec(..), scaleTab, + -- * Low level Csound definition. gen, @@ -101,16 +129,71 @@ tablewa, tablew, readTab, readTable, readTable3, readTablei, -- ** Table Reading with Dynamic Selection - tableikt, tablekt, tablexkt + tableikt, tablekt, tablexkt, + + -- ** random generators from tables + cuserrnd, duserrnd + + -- * Appendix (original GEN identifiers lookup) + -- | We can find the CE name of the GEN routine by it's integer id. + -- + -- * GEN01 — wavs, wavLeft, wavRight -- Transfers data from a soundfile into a function table. + -- * GEN02 — doubles -- Transfers data from immediate pfields into a function table. + -- * GEN03 — polys -- Generates a stored function table by evaluating a polynomial. + -- * GEN04 — normTab -- Generates a normalizing function. + -- * GEN05 — exps -- Constructs functions from segments of exponential curves. + -- * GEN06 — cubes -- Generates a function comprised of segments of cubic polynomials. + -- * GEN07 — lins -- Constructs functions from segments of straight lines. + -- * GEN08 — splines -- Generate a piecewise cubic spline curve. + -- * GEN09 — sines2, sines3 -- Generate composite waveforms made up of weighted sums of simple sinusoids. + -- * GEN10 — sines -- Generate composite waveforms made up of weighted sums of simple sinusoids. + -- * GEN11 — buzzes -- Generates an additive set of cosine partials. + -- * GEN12 — bessels -- Generates the log of a modified Bessel function of the second kind. + -- * GEN13 — chebs1 -- Stores a polynomial whose coefficients derive from the Chebyshev polynomials of the first kind. + -- * GEN14 — chebs2 -- Stores a polynomial whose coefficients derive from Chebyshevs of the second kind. + -- * GEN15 — (not implemented yet) -- Creates two tables of stored polynomial functions. + -- * GEN16 — startEnds -- Creates a table from a starting value to an ending value. + -- * GEN17 — consts -- Creates a step function from given x-y pairs. + -- * GEN18 — tabseg -- Writes composite waveforms made up of pre-existing waveforms. + -- * GEN19 — sines4 -- Generate composite waveforms made up of weighted sums of simple sinusoids. + -- * GEN20 — wins -- Generates functions of different windows. + -- * GEN21 — dist, uniDist, linDist, triDist, expDist, biexpDist, gaussDist, cauchyDist, pcauchyDist, betaDist, weibullDist, poissonDist -- Generates tables of different random distributions. + -- * GEN23 — readNumFile -- Reads numeric values from a text file. + -- * GEN24 — readNumTab -- Reads numeric values from another allocated function-table and rescales them. + -- * GEN25 — bpExps -- Construct functions from segments of exponential curves in breakpoint fashion. + -- * GEN27 — bpLins -- Construct functions from segments of straight lines in breakpoint fashion. + -- * GEN28 — readTrajectoryFile -- Reads a text file which contains a time-tagged trajectory. + -- * GEN30 — tabHarmonics -- Generates harmonic partials by analyzing an existing table. + -- * GEN31 — mixOnTab -- Mixes any waveform specified in an existing table. + -- * GEN32 — mixTabs -- Mixes any waveform, resampled with either FFT or linear interpolation. + -- * GEN33 — mixSines1 -- Generate composite waveforms by mixing simple sinusoids. + -- * GEN34 — mixSines2 -- Generate composite waveforms by mixing simple sinusoids. + -- * GEN40 — tabDist -- Generates a random distribution using a distribution histogram. + -- * GEN41 — randDist -- Generates a random list of numerical pairs. + -- * GEN42 — rangeDist Generates a random distribution of discrete ranges of values. + -- * GEN43 — readPvocex -- Loads a PVOCEX file containing a PV analysis. + -- * GEN49 — mp3s -- Transfers data from an MP3 soundfile into a function table. + -- * GEN51 — (see module Csound.Tuning) This subroutine fills a table with a fully customized micro-tuning scale, in the manner of Csound opcodes cpstun, cpstuni and cpstmid. + -- * GEN52 — readMultichannel -- Creates an interleaved multichannel table from the specified source tables, in the format expected by the ftconv opcode. + -- * GENtanh — tanhTab, rescaleTanhTab Generate a table with values on the tanh function. + -- * GENexp — expTab, rescaleExpTab Generate a table with values on the exp function. + -- * GENsone — soneTab Generate a table with values of the sone function. + -- * GENquadbezier — (not implemented yet) Generate a table with values from a quadratic Bézier function. + -- * GENfarey — fareyTab -- Fills a table with the Farey Sequence Fn of the integer n. + -- * GENwave — waveletTab -- Generates a compactly supported wavelet function. + -- * GENpadsynth — pdsynth, bwSines Generate a sample table using the padsynth algorithm. ) where import Control.Applicative hiding ((<*)) +import Control.Arrow(second) import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader import Csound.Dynamic hiding (int, when1, whens) import Data.Default import Csound.Typed import Csound.Typed.Opcode(ftgentmp, ftgenonce) +import Data.Maybe -- | The default table. It's rendered to @(-1)@ in the Csound. noTab :: Tab @@ -223,10 +306,10 @@ mp3m file = mp3s file 0 Mp3Mono interp :: Int -> [Double] -> Tab -interp genId as = preTab def genId (ArgsRelative as) +interp genId as = preTab def genId (relativeArgs as) plains :: Int -> [Double] -> Tab -plains genId as = preTab def genId (ArgsPlain as) +plains genId as = preTab def genId (ArgsPlain $ return as) insertOnes :: [Double] -> [Double] insertOnes xs = case xs of @@ -381,7 +464,7 @@ -- -- * dur - duration of the segment startEnds :: [Double] -> Tab -startEnds as = preTab def idStartEnds (ArgsGen16 as) +startEnds as = preTab def idStartEnds (relativeArgsGen16 as) -- | Equally spaced interpolation for the function @startEnds@ -- @@ -397,6 +480,29 @@ a:b:as -> a : 1 : b : insertOnes16 as _ -> xs + +-- | Linear segments in breakpoint fashion: +-- +-- > bpLins [x1, y1, x2, y2, ..., xN, yN] +-- +-- csound docs: +-- +-- All x1, x2, .. should belong to the interval [0, 1]. The actual values are rescaled to fit the table size. +bpLins :: [Double] -> Tab +bpLins xs = preTab def idLinsBreakPoints $ bpRelativeArgs xs + + +-- | Exponential segments in breakpoint fashion: +-- +-- > bpExps [x1, y1, x2, y2, ..., xN, yN] +-- +-- csound docs: +-- +-- All x1, x2, .. should belong to the interval [0, 1]. The actual values are rescaled to fit the table size. +bpExps :: [Double] -> Tab +bpExps xs = preTab def idExpsBreakPoints $ bpRelativeArgs xs + + type PartialNumber = Double type PartialStrength = Double type PartialPhase = Double @@ -522,20 +628,51 @@ chebs2 :: Double -> Double -> [Double] -> Tab chebs2 xint xamp hs = plains idChebs2 (xint : xamp : hs) -winHamming, winHanning, winBartlett, winBlackman, - winHarris, winGaussian, winKaiser, winRectangle, winSync :: [Double] -> Tab +-- | The Hamming window. The peak equals to 1. +winHamming :: Tab +winHamming = wins Hamming [1] +-- | The Hanning window. The peak equals to 1. +winHanning :: Tab +winHanning = wins Hanning [1] -winHamming = wins Hamming -winHanning = wins Hanning -winBartlett = wins Bartlett -winBlackman = wins Blackman -winHarris = wins Harris -winRectangle = wins Rectangle -winSync = wins Sync -winGaussian = wins Gaussian -winKaiser = wins Kaiser +-- | The Bartlett window. The peak equals to 1. +winBartlett :: Tab +winBartlett = wins Bartlett [1] + +-- | The Blackman window. The peak equals to 1. +winBlackman :: Tab +winBlackman = wins Blackman [1] + +-- | The Harris window. The peak equals to 1. +winHarris :: Tab +winHarris = wins Harris [1] + +-- | The Rectangle window. The peak equals to 1. +winRectangle :: Tab +winRectangle = wins Rectangle [1] + +-- | The Sync window. The peak equals to 1. +winSync :: Tab +winSync = wins Sync [1] + +-- | This creates a function that contains a Gaussian window with a maximum value of 1. +-- The extra argument specifies how broad the window is, as the standard deviation of the curve; +-- in this example the s.d. is 2. The default value is 1. +-- +-- > winGauss 2 +winGauss :: Double -> Tab +winGauss a = wins Gaussian [1, a] + +-- | This creates a function that contains a Kaiser window with a maximum value of 1. +-- The extra argument specifies how "open" the window is, for example a value of 0 results +-- in a rectangular window and a value of 10 in a Hamming like window. +-- +-- > winKaiser openness +winKaiser :: Double -> Tab +winKaiser openness = wins Kaiser [1, openness] + data WinType = Hamming | Hanning | Bartlett | Blackman | Harris | Gaussian | Kaiser | Rectangle | Sync @@ -595,7 +732,7 @@ -- 261.625565 25.0 1.0 1.0 2.0 1.0 1.0 0.5 0.0 0.2 plainStringTab :: String -> [Double] -> Tab -plainStringTab genId as = preStringTab def genId (ArgsPlain as) +plainStringTab genId as = preStringTab def genId (ArgsPlain $ return as) -- | Creates a table of doubles (It's f-table in Csound). -- Arguments are: @@ -606,7 +743,7 @@ -- -- All tables are created at 0 and memory is never released. gen :: Int -> [Double] -> Tab -gen genId args = preTab def genId (ArgsPlain args) +gen genId args = preTab def genId (ArgsPlain $ return args) -- | Adds guard point to the table size (details of the interpolation schemes: you do need guard point if your intention is to read the -- table once but you don't need the guard point if you read table in many cycles, the guard point is the the first point of your table). @@ -664,7 +801,335 @@ sec2rel :: Tab -> Sig -> Sig sec2rel tab x = x / (sig $ ftlen tab / getSampleRate) +--------------------------------------------------- + +-- | Generates harmonic partials by analyzing an existing table. +-- +-- > tabHarmonics src minh maxh [ref_sr] [interp] +-- +-- * src -- source ftable. It should be primitive ie constructed not with "ftgen" family of opcodes. +-- +-- * minh -- lowest harmonic number +-- +-- * maxh -- maxh -- highest harmonic number +-- +-- * ref_sr (optional) -- maxh is scaled by (sr / ref_sr). The default value of ref_sr is sr. If ref_sr is zero or negative, it is now ignored. +-- +-- * interp (optional) -- if non-zero, allows changing the amplitude of the lowest and highest harmonic partial depending on the fractional part of minh and maxh. For example, if maxh is 11.3 then the 12th harmonic partial is added with 0.3 amplitude. This parameter is zero by default. +-- +-- GEN30 for Csound: +-- +tabHarmonics :: Tab -> Double -> Double -> Maybe Double -> Maybe Double -> Tab +tabHarmonics tab minh maxh mrefSr mInterp = hideGE $ do + idx <- renderTab tab + return $ preTab def idTabHarmonics (ArgsPlain $ return (catMaybes $ fmap Just [fromIntegral idx, minh, maxh] ++ [mrefSr, mInterp])) + +--------------------------------- +-- mixing tabs GEN31 GEN32 + +-- | It's just like sines3 but inplace of pure sinewave it uses supplied in the first argument shape. +-- +-- mixOnTab srcTable [(partialNumber, partialStrength, partialPahse)] +-- +-- phahse is in range [0, 1] +mixOnTab :: Tab -> [(PartialNumber, PartialStrength, PartialPhase)] -> Tab +mixOnTab tab xs = hideGE $ do + idx <- renderTab tab + return $ plains idMixOnTab $ fromIntegral idx : [a | (pn, strength, phs) <- xs, a <- [pn, strength, phs]] + +-- | It's like @mixOnTab@ but it's more generic since we can mix not only one shape. +-- But we can specify shape for each harmonic. +mixTabs :: [(Tab, PartialNumber, PartialStrength, PartialPhase)] -> Tab +mixTabs xs = hideGE $ do + args <- sequence [a | (tab, pn, strength, phs) <- xs, a <- (fmap fromIntegral $ renderTab tab) : fmap return [pn, strength, phs]] + return $ plains idMixTabs args + +-- | Normalizing table +-- +-- Csound GEN04: +normTab :: NormTabSpec -> Tab -> Tab +normTab spec tab = hideGE $ do + idx <- renderTab tab + return $ plains idNormTab $ fmap fromIntegral [idx, fromNormTabSpec spec] + where + fromNormTabSpec x = case x of + ScanLeftToRight -> 0 + ScanFromMiddle -> 1 + +data NormTabSpec = ScanLeftToRight | ScanFromMiddle + +-- | Creates a new table wich contains all values from the source table rescaled to the given interval. +-- +-- > scaleTab (minValue, maxValue) sourceTab +scaleTab :: (Double, Double) -> Tab -> Tab +scaleTab (minVal, maxVal) tab = hideGE $ do + tabId <- renderTab tab + return $ skipNorm $ gen idReadNumTab [fromIntegral tabId, minVal, maxVal] + +---------------------------------------------------- + +-- | tabseg -- Writes composite waveforms made up of pre-existing waveforms. +-- +-- tabseg [(tab, amplitude, duration)] +-- +-- Csound GEN18: +-- +-- Butnotice the difference with Csound we specify start and finish of writing but +-- here we only specify the relative length of segments. Segments are arranged so +-- that the start f next segment comes right after the end of the prev segment. +tabseg :: [(Tab, PartialStrength, Double)] -> Tab +tabseg xs = hideGE $ do + tabIds <- mapM renderTab tabs + return $ preTab def idLinTab $ mkArgs tabIds + where + (tabs, amps, durs) = unzip3 xs + segments n = fmap (second $ \x -> x - 1) $ tail $ scanl (\(a, b) x -> (b, b + x)) (0, 0) $ mkRelative n durs + mkArgs ids = ArgsPlain $ reader $ \size -> concat $ zipWith3 (\tabId amp (start, finish) -> [fromIntegral tabId, amp, start, finish]) ids amps (segments size) + +etabseg :: [(Tab, PartialStrength)] -> Tab +etabseg = tabseg . fmap (\(tab, amp) -> (tab, amp, 1)) + +-------------------------------------------------- +-- distributions + + +{- Csound Docs, distribution types + + 1 = Uniform (positive numbers only) + + 2 = Linear (positive numbers only) + + 3 = Triangular (positive and negative numbers) + + 4 = Exponential (positive numbers only) + + 5 = Biexponential (positive and negative numbers) + + 6 = Gaussian (positive and negative numbers) + + 7 = Cauchy (positive and negative numbers) + + 8 = Positive Cauchy (positive numbers only) + + 9 = Beta (positive numbers only) + + 10 = Weibull (positive numbers only) + + 11 = Poisson (positive numbers only) +-} + +gen21 :: Int -> [Double] -> Tab +gen21 typeId aux = gen idRandDists $ fromIntegral typeId : aux + +dist :: Int -> Tab +dist n = gen21 n [] + +-- | Uniform (positive numbers only) +uniDist :: Tab +uniDist = dist 1 + +-- | Linear (positive numbers only) +linDist :: Tab +linDist = dist 2 + +-- | Triangular (positive and negative numbers) +triDist :: Tab +triDist = dist 3 + +-- | Exponential (positive numbers only) +expDist :: Tab +expDist = dist 4 + +-- | Biexponential (positive and negative numbers) +biexpDist :: Tab +biexpDist = dist 5 + +-- | Gaussian (positive and negative numbers) +gaussDist :: Tab +gaussDist = dist 6 + +-- | Cauchy (positive and negative numbers) +cauchyDist :: Tab +cauchyDist = dist 7 + +-- | Positive Cauchy (positive numbers only) +pcauchyDist :: Tab +pcauchyDist = dist 8 + +-- | Beta (positive numbers only) +-- +-- > betaDist alpha beta +-- +-- * @alpha@ -- alpha value. If kalpha is smaller than one, smaller values favor values near 0. +-- +-- * @beta@ -- beta value. If kbeta is smaller than one, smaller values favor values near krange. +betaDist :: Double -> Double -> Tab +betaDist arg1 arg2 = gen21 9 [1, arg1, arg2] + +-- | Weibull (positive numbers only) +-- +-- * tau -- if greater than one, numbers near ksigma are favored. If smaller than one, small values are favored. If t equals 1, the distribution is exponential. Outputs only positive numbers. +weibullDist :: Double -> Tab +weibullDist arg1 = gen21 10 [1, arg1] + +-- | Poisson (positive numbers only) +poissonDist :: Tab +poissonDist = dist 11 + +-- with level + +dist' :: Int -> Double -> Tab +dist' n level = gen21 n [level] + +uniDist' :: Double -> Tab +uniDist' = dist' 1 + +linDist' :: Double -> Tab +linDist' = dist' 2 + +triDist' :: Double -> Tab +triDist' = dist' 3 + +expDist' :: Double -> Tab +expDist' = dist' 4 + +biexpDist' :: Double -> Tab +biexpDist' = dist' 5 + +gaussDist' :: Double -> Tab +gaussDist' = dist' 6 + +cauchyDist' :: Double -> Tab +cauchyDist' = dist' 7 + +pcauchyDist' :: Double -> Tab +pcauchyDist' = dist' 8 + +betaDist' :: Double -> Double -> Double -> Tab +betaDist' level arg1 arg2 = gen21 9 [level, arg1, arg2] + +weibullDist' :: Double -> Double -> Tab +weibullDist' level arg1 = gen21 10 [level, arg1] + +poissonDist' :: Double -> Tab +poissonDist' = dist' 11 + +-- GEN40 + +-- | Generates a random distribution using a distribution histogram (GEN40). +-- +-- Csound docs: +tabDist :: Tab -> Tab +tabDist src = hideGE $ do + tabId <- renderTab src + return $ gen idRandHist [fromIntegral tabId] + +-- | randDist — Generates a random list of numerical pairs (GEN41). +-- +-- > randDist [value1, prob1, value2, prob2, value3, prob3 ... valueN, probN] +-- +-- The first number of each pair is a value, and the second is the probability of that value to +-- be chosen by a random algorithm. Even if any number can be assigned to the probability element of each pair, +-- it is suggested to give it a percent value, in order to make it clearer for the user. +-- +-- This subroutine is designed to be used together with duserrnd and urd opcodes (see duserrnd for more information). +randDist :: [Double] -> Tab +randDist xs = skipNorm $ gen idRandPairs xs + + +-- | rangeDist — Generates a random distribution of discrete ranges of values (GEN42). +-- +-- The first number of each group is a the minimum value of the +-- range, the second is the maximum value and the third is the probability +-- of that an element belonging to that range of values can be chosen by +-- a random algorithm. Probabilities for a range should be a fraction of 1, +-- and the sum of the probabilities for all the ranges should total 1.0. +-- +-- This subroutine is designed to be used together with duserrnd and urd opcodes (see duserrnd for more information). +-- Since both duserrnd and urd do not use any interpolation, it is suggested to give a size reasonably big. +rangeDist :: [Double] -> Tab +rangeDist xs = skipNorm $ gen idRandRanges xs + +------------------------------------------------------ + +-- | Reads numbers from file (GEN23) +-- +-- csound doc: +readNumFile :: String -> Tab +readNumFile filename = skipNorm $ preTab def idReadNumFile $ FileAccess filename [] + +-- | Reads trajectory from file (GEN28) +-- +-- csound doc: +readTrajectoryFile :: String -> Tab +readTrajectoryFile filename = skipNorm $ preTab def idReadTrajectoryFile $ FileAccess filename [] + +-- | Reads PVOCEX files (GEN43) +-- +-- csound doc: +readPvocex :: String -> Int -> Tab +readPvocex filename channel = preTab def idPvocex $ FileAccess filename [fromIntegral channel] + +-- | readMultichannel — Creates an interleaved multichannel table from the specified source tables, in the format expected by the ftconv opcode (GEN52). +-- +-- > f # time size 52 nchannels fsrc1 offset1 srcchnls1 [fsrc2 offset2 srcchnls2 ... fsrcN offsetN srcchnlsN] +-- +-- csound doc: +readMultichannel :: Int -> [(Tab, Int, Int)] -> Tab +readMultichannel n args = hideGE $ do + idSrcs <- mapM renderTab fsrcs + return $ skipNorm $ gen idMultichannel $ fmap fromIntegral $ n : (concat $ zipWith3 (\a b c -> [a, b, c]) idSrcs offsets chnls) + where + (fsrcs, offsets, chnls) = unzip3 args + +------------------------------------------------------ + +-- | Csound's GEN33 — Generate composite waveforms by mixing simple sinusoids. +-- +-- > tabSines1 srcTab nh scl [fmode] +-- +-- Csound docs: +tabSines1 :: Tab -> Double -> Double -> Maybe Double -> Tab +tabSines1 = tabSinesBy idMixSines2 + +-- | Csound's GEN34 — Generate composite waveforms by mixing simple sinusoids. +-- +-- > tabSines2 srcTab nh scl [fmode] +-- +-- Csound docs: +tabSines2 :: Tab -> Double -> Double -> Maybe Double -> Tab +tabSines2 = tabSinesBy idMixSines2 + +tabSinesBy :: Int -> Tab -> Double -> Double -> Maybe Double -> Tab +tabSinesBy genId tab nh amp fmode = hideGE $ do + tabId <- renderTab tab + return $ preTab def genId $ ArgsPlain $ return $ [fromIntegral tabId, nh, amp] ++ (maybe [] return fmode) + ------------------- +-- wavelets + +-- | "wave" — Generates a compactly supported wavelet function. +-- +-- > waveletTab srcTab seq +-- +-- Csound docs: +waveletTab :: Tab -> Int -> Tab +waveletTab = waveletTabBy 0 + +-- | "wave" — Generates a compactly supported wavelet function. The result table is rescaled. +-- +-- > waveletTab srcTab seq +-- +-- Csound docs: +rescaleWaveletTab :: Tab -> Int -> Tab +rescaleWaveletTab = waveletTabBy 1 + +waveletTabBy :: Int -> Tab -> Int -> Tab +waveletTabBy rescaleFlag srcTab seq = hideGE $ do + tabId <- renderTab srcTab + return $ plainStringTab idWave $ fmap fromIntegral [tabId, seq, 0] + +------------------- -- specific tabs -- | Linear segments that form a singl cycle of triangle wave. @@ -677,12 +1142,81 @@ -- | Linear segments that form a single cycle of square wave. sqrTab :: Tab -sqrTab = lins [1, 0.5, 1, 0.01, -1, 0.5 -1, 0.01, 1] +sqrTab = lins [1, 0.5, 1, 0.01, -1, 0.5, -1, 0.01, 1] -- | Pulse-width wave formed with linear segments. Duty cycle rages from 0 to 1. 0.5 is a square wave. pwTab :: Double -> Tab pwTab duty = lins [1, duty, 1, 0.01, -1, 1 - duty, -1, 0.01, 1] +-- | Tab with tanh from the given interval. +-- +-- > tanhTab (start, end) +tanhTab :: (Double, Double) -> Tab +tanhTab (start, end) = plainStringTab idTanh [start, end, 0] + +-- | Tab with tanh from the given interval. The table is rescaled. +-- +-- > rescaleTanhTab (start, end) +rescaleTanhTab :: (Double, Double) -> Tab +rescaleTanhTab (start, end) = plainStringTab idTanh [start, end, 1] + +-- | Tab with exponential from the given interval. +-- +-- > expTab (start, end) +expTab :: (Double, Double) -> Tab +expTab (start, end) = plainStringTab idExp [start, end, 0] + +-- | Tab with exponential from the given interval. The table is rescaled. +-- +-- > rescaleExpTab (start, end) +rescaleExpTab :: (Double, Double) -> Tab +rescaleExpTab (start, end) = plainStringTab idExp [start, end, 1] + +-- | Tab with sone from the given interval. +-- +-- > soneTab (start, end) equalpoint +-- +-- * start, end -- first and last value to be stored. The points stored are uniformly spaced between these to the table size. +-- +-- * equalpoint -- the point on the curve when the input and output values are equal. +soneTab :: (Double, Double) -> Double -> Tab +soneTab (start, end) equalpoint = plainStringTab idSone [start, end, equalpoint, 0] + + +-- | Tab with sone from the given interval. +-- +-- > soneTab (start, end) equalpoint +-- +-- * start, end -- first and last value to be stored. The points stored are uniformly spaced between these to the table size. +-- +-- * equalpoint -- the point on the curve when the input and output values are equal. +rescaleSoneTab :: (Double, Double) -> Double -> Tab +rescaleSoneTab (start, end) equalpoint = plainStringTab idSone [start, end, equalpoint, 0] + +-- | "farey" — Fills a table with the Farey Sequence Fn of the integer n. +-- +-- see details in Csound doc: +-- +-- Notice that the arguments are reversed (in the haskell mindset) +-- +-- > fareyTab mode num +-- +-- num -- the integer n for generating Farey Sequence Fn +-- +-- mode -- integer to trigger a specific output to be written into the table: +-- +-- * 0 -- outputs floating point numbers representing the elements of Fn. +-- +-- * 1 -- outputs delta values of successive elements of Fn, useful for generating note durations for example. +-- +-- * 2 -- outputs only the denominators of the integer ratios, useful for indexing other tables or instruments for example. +-- +-- * 3 -- same as mode 2 but with normalised output. +-- +-- * 4 -- same as mode 0 but with 1 added to each number, useful for generating tables for tuning opcodes, for example cps2pch. +fareyTab :: Int -> Int -> Tab +fareyTab mode num = plainStringTab idFarey $ fmap fromIntegral [num, mode] + --------------------------------------------------- -- | @@ -822,3 +1356,95 @@ tablexkt :: Sig -> Tab -> Sig -> D -> Sig tablexkt b1 b2 b3 b4 = Sig $ f <$> unSig b1 <*> unTab b2 <*> unSig b3 <*> unD b4 where f a1 a2 a3 a4 = opcs "tablexkt" [(Ar,[Xr,Kr,Kr,Ir,Ir,Ir,Ir])] [a1,a2,a3,a4] + +---------------------------------------------------------------- +-- duserrnd and cuserrnd + +-- | cuserrnd — Continuous USER-defined-distribution RaNDom generator. +-- +-- Continuous USER-defined-distribution RaNDom generator. +-- +-- > aout cuserrnd kmin, kmax, ktableNum +-- > iout cuserrnd imin, imax, itableNum +-- > kout cuserrnd kmin, kmax, ktableNum +-- +-- csound doc: +-- +-- the tab should be done with tabDist, randDist or rangeDist +cuserrnd :: SigOrD a => a -> a -> Tab -> SE a +cuserrnd b1 b2 b3 = fmap (fromGE . return) $ SE $ (depT =<<) $ lift $ f <$> toGE b1 <*> toGE b2 <*> unTab b3 + where f a1 a2 a3 = opcs "cuserrnd" [(Ar,[Kr,Kr,Kr]) + ,(Ir,[Ir,Ir,Ir]) + ,(Kr,[Kr,Kr,Kr])] [a1,a2,a3] + +-- | duserrnd — Discrete USER-defined-distribution RaNDom generator. +-- +-- Discrete USER-defined-distribution RaNDom generator. +-- +-- > aout duserrnd ktableNum +-- > iout duserrnd itableNum +-- > kout duserrnd ktableNum +-- +-- csound doc: +-- +-- the tab should be done with tabDist, randDist or rangeDist +duserrnd :: SigOrD a => Tab -> SE a +duserrnd b1 = fmap (fromGE . return) $ SE $ (depT =<<) $ lift $ fmap f $ unTab b1 + where f a1 = opcs "duserrnd" [(Ar,[Kr]) + ,(Ir,[Ir]) + ,(Kr,[Kr])] [a1] + +---------------------------------------------------------------- +-- tab args + +bpRelativeArgs :: [Double] -> TabArgs +bpRelativeArgs xs = ArgsPlain $ reader $ \size -> fromRelative size xs + where + fromRelative n as = substOdds (makeRelative n $ getOdds as) as + + getOdds xs = fmap snd $ filter fst $ zip (cycle [True,False]) xs + + substOdds odds xs = zipWith3 go (cycle [True,False]) ((\a -> [a,a]) =<< odds) xs + where go flag odd x = if flag then odd else x + + makeRelative size as = fmap ((fromIntegral :: (Int -> Double)) . round . (fromIntegral size * )) as + +relativeArgs :: [Double] -> TabArgs +relativeArgs xs = ArgsPlain $ reader $ \size -> fromRelative size xs + 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" + +relativeArgsGen16 :: [Double] -> TabArgs +relativeArgsGen16 xs = ArgsPlain $ reader $ \size -> formRelativeGen16 size xs + where + formRelativeGen16 n as = substGen16 (mkRelative n $ getGen16 as) 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 + _ -> [] + + substGen16 durs xs = case (durs, xs) of + ([], as) -> as + (_, []) -> [] + (d:ds, valN:_:typeN:rest) -> valN : d : typeN : substGen16 ds rest + (_, _) -> xs + +mkRelative n as = fmap ((fromIntegral :: (Int -> Double)) . round . (s * )) as + where s = fromIntegral n / sum as + + + diff --git a/src/Csound/Types.hs b/src/Csound/Types.hs --- a/src/Csound/Types.hs +++ b/src/Csound/Types.hs @@ -22,7 +22,7 @@ module Csound.Types( -- * Primitive types Sig, D, Tab, Str, Spec, Wspec, - BoolSig, BoolD, Val(..), SigOrD, + BoolSig, BoolD, Val(..), SigOrD, Sig2, Sig3, Sig4, Sig5, Sig6, Sig8, -- ** Constructors @@ -42,7 +42,7 @@ quot', rem', div', mod', ceil', floor', round', int', frac', -- ** Logic functions - boolSig, when1, whens, whenD1, whenDs, whileDo, untilDo, whileDoD, untilDoD, whenElseD, compareWhenD, + boolSig, when1, whens, whenElse, whenD1, whenDs, whileDo, untilDo, whileDoD, untilDoD, whenElseD, compareWhenD, equalsTo, notEqualsTo, lessThan, greaterThan, lessThanEquals, greaterThanEquals, -- ** Aliases @@ -72,12 +72,45 @@ -- *** Logic functions ifArg, guardedArg, caseArg, + -- ** Monophonic arguments + MonoArg(..), MonoAdsr, adsrMonoSynt, monoAdsr, + -- ** Outputs - Sigs + Sigs, + + -- * Arrays + Arr, newLocalArr, newGlobalArr, newLocalCtrlArr, newGlobalCtrlArr, + writeArr, readArr, modifyArr, mixArr, + -- ** Type inference helpers + Arr1, DArr1, Arr2, DArr2, Arr3, DArr3, + arr1, darr1, arr2, darr2, arr3, darr3, + + -- ** Traverse and fold + foreachArr, foreachArrD, forRowArr, forColumnArr, forRowArrD, forColumnArrD, + foldArr, foldRowArr, foldColumnArr, foldRowsArrD, foldColumnsArrD, + + -- ** Array opcodes + fillLocalArr, fillGlobalArr, fillLocalCtrlArr, fillGlobalCtrlArr, + maparrayNew, lenarray, copyf2array, copya2ftab, minarray, maxarray, sumarray, + scalearray, slicearrayNew, + + maparrayCopy, slicearrayCopy, + + -- ** Spectral opcodes + SpecArr, + + fftNew, fftinvNew, rfftNew, rifftNew, pvs2tab, tab2pvs, cmplxprodNew, + rect2polNew, pol2rectNew, pol2rect2New, windowArrayNew, + r2cNew, c2rNew, magsArrayNew, phsArrayNew, + + fftCopy, fftinvCopy, rfftCopy, rifftCopy, cmplxprodCopy, + rect2polCopy, pol2rectCopy, pol2rect2Copy, windowArrayCopy, + r2cCopy, c2rCopy, magsArrayCopy, phsArrayCopy ) where import Data.Boolean import Csound.Typed.Types +import Csound.Typed.Control import Csound.Control.SE -- | Gets an init-rate value from the list by index. @@ -92,6 +125,9 @@ whenElseD :: BoolD -> SE () -> SE () -> SE () whenElseD cond ifDo elseDo = whenDs [(cond, ifDo)] elseDo +whenElse :: BoolSig -> SE () -> SE () -> SE () +whenElse cond ifDo elseDo = whens [(cond, ifDo)] elseDo + -- | Performs tree search f the first argument lies within the interval it performs the corresponding procedure. compareWhenD :: D -> [(D, SE ())] -> SE () compareWhenD val conds = case conds of @@ -102,3 +138,6 @@ where (less, more) = splitAt (length conds `div` 2) conds rootCond = fst $ last less + + +