csound-expression 5.0.1 → 5.1.0

raw patch · 19 files changed

+1896/−190 lines, 19 filesdep ~csound-expression-dynamicdep ~csound-expression-typedPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: csound-expression-dynamic, csound-expression-typed

API changes (from Hackage documentation)

Files

• csound-expression.cabal +7/−4
• src/Csound/Air.hs +5/−0
• src/Csound/Air/Envelope.hs +4/−0
• src/Csound/Air/Filter.hs +210/−2
• src/Csound/Air/Fx.hs +92/−0
• src/Csound/Air/Granular/Morpheus.hs +379/−0
• src/Csound/Air/Live.hs +7/−3
• src/Csound/Air/Looper.hs +3/−1
• src/Csound/Air/Misc.hs +8/−15
• src/Csound/Air/Padsynth.hs +27/−17
• src/Csound/Air/Patch.hs +403/−135
• src/Csound/Air/Wave.hs +93/−4
• src/Csound/Air/Wave/Sync.hs +272/−0
• src/Csound/Cabbage.hs +48/−0
• src/Csound/IO.hs +94/−2
• src/Csound/Options.hs +25/−1
• src/Csound/SigSpace.hs +5/−1
• src/Csound/Tab.hs +198/−4
• src/Csound/Types.hs +16/−1

@@ -1,5 +1,5 @@ Name:          csound-expression-Version:       5.0.1+Version:       5.1.0 Cabal-Version: >= 1.6 License:       BSD3 License-file:  LICENSE@@ -33,7 +33,7 @@      * Thanks a lot to all who patiently answered my questions and provided skillful solutions, encouragement and ideas:     .-    Iain McCurdy, Victor Lazarini, Rory Walsh, Steven Yi, John Ffitch, Joachim Heintz, Peter Burgess, Dr. Richard Boulanger, Michael Gogins, Oeyvind Brandtsegg,+    Iain McCurdy, Victor Lazzarini, Rory Walsh, Steven Yi, John Ffitch, Joachim Heintz, Peter Burgess, Dr. Richard Boulanger, Michael Gogins, Oeyvind Brandtsegg,     Richard Dobson, Partev Barr Sarkissian, Dave Phillips, Guillermo Senna, Art Hunkins,      Ben McAllister, Michael Rhoades, Gleb Rogozinsky, Eugene Cherny, Brian Merchant, Wolf Peuker, Hlöðver Sigurðsson, Aaron Krister Johnson, Andy Fillebrown and friends :)    @@ -79,7 +79,7 @@   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.0.9.3, csound-expression-dynamic >= 0.1.6, temporal-media >= 0.6.1,+        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   Hs-Source-Dirs:      src/   Exposed-Modules:@@ -87,7 +87,9 @@          Csound.Air                 Csound.Air.Wave-        Csound.Air.Granular        +        Csound.Air.Wave.Sync+        Csound.Air.Granular+        Csound.Air.Granular.Morpheus         Csound.Air.Envelope         Csound.Air.Filter         Csound.Air.ModArg@@ -111,6 +113,7 @@         Csound.IO         Csound.Options         Csound.Tuning+        Csound.Cabbage          Csound.Control         Csound.Control.Evt

@@ -2,6 +2,8 @@ module Csound.Air (           -- | The basic sound waves: pure sine, sawtooth, square, triangle, LFOs.     module Csound.Air.Wave,+    -- | Hard and soft sync+    module Csound.Air.Wave.Sync,      -- | Envelope generators.     module Csound.Air.Envelope,  @@ -17,6 +19,7 @@      -- | Granular synthesis     module Csound.Air.Granular,+    module Csound.Air.Granular.Morpheus,      -- | Spectral Processing     module Csound.Air.Spec, @@ -53,11 +56,13 @@ ) where  import Csound.Air.Wave+import Csound.Air.Wave.Sync import Csound.Air.Envelope import Csound.Air.Filter import Csound.Air.ModArg import Csound.Air.Wav import Csound.Air.Granular+import Csound.Air.Granular.Morpheus import Csound.Air.Spec import Csound.Air.Fx import Csound.Air.Live

@@ -2,6 +2,9 @@ -- | Envelopes module Csound.Air.Envelope (     leg, xeg,++    -- ADSR with retrigger for mono-synths+    adsr140,     -- * Relative duration     onIdur, lindur, expdur, linendur,     onDur, lindurBy, expdurBy, linendurBy,  @@ -49,6 +52,7 @@ import Csound.Tab(lins, exps, gp) import Csound.Air.Wave(oscBy) import Csound.Air.Filter(slide)+import Csound.Typed.Plugins(adsr140)  -- | Linear adsr envelope generator with release --

@@ -19,7 +19,7 @@     -- * Specific filters      -- ** Moog filters-    mlp, mlp2, mlp3, lp18,+    mlp, mlp2, mlp3, lp18, ladder,      -- ** Formant filters     formant, singA, singO, singE, singU, singO2,@@ -33,10 +33,51 @@     alp1, alp2, alp3, alp4, ahp,      -- ** Low level analog filters    -    mvchpf, mvclpf1, mvclpf2, mvclpf3, mvclpf4+    mvchpf, mvclpf1, mvclpf2, mvclpf3, mvclpf4,++    -- * Zero delay filters++    -- ** One pole filters+    zdf1, zlp1, zhp1, zap1,++    -- ** Two pole filters+    zdf2, zlp, zbp, zhp, zdf2_notch, zbr,++    -- ** Ladder filter+    zladder, ++    -- ** Four poles filters+    zdf4, zlp4, zbp4, zhp4, ++    -- ** Eq-filters+    peakEq, highShelf, lowShelf,++    -- * Classic analog-like filters++    -- ** low pass+    lpCheb1, lpCheb1', lpCheb2, lpCheb2', clp, clp',++    -- ** high pass+    hpCheb1, hpCheb1', hpCheb2, hpCheb2', chp, chp',++    -- * Named resonant low pass filters+    plastic, wobble, trumpy, harsh, ++    -- * TB303 filter+    tbf, diode, linDiode, noNormDiode,++    -- Korg 35 filters+    linKorg_lp, linKorg_hp, korg_lp, korg_hp,++    -- * Statevariable filters+    slp, shp, sbp, sbr,++    -- * Multimode filters+    multiStatevar, multiSvfilter ) where  import Csound.Typed+import Csound.Typed.Plugins import Csound.SigSpace(bat) import Csound.Typed.Opcode @@ -298,3 +339,170 @@ genMvclpf :: String -> Sig -> Sig -> Sig -> Sig genMvclpf name b1 b2 b3 = Sig $ f <$> unSig b1 <*> unSig b2 <*> unSig b3     where f a1 a2 a3 = opcs name [(Ar,[Ar,Xr,Xr,Ir])] [a1,a2,a3]+++-----------------------------------------------+-- named filters++-- classic filters++-- low pass++-- | Chebyshev  type I low pass filter (with 2 poles).+lpCheb1 :: Sig -> Sig -> Sig+lpCheb1 = lpCheb1' 2++-- | Chebyshev  type I low pass filter (with given number of poles, first argument).+lpCheb1' :: D -> Sig -> Sig -> Sig+lpCheb1' npoles kcf asig = clfilt asig kcf 0 npoles `withD` 1++-- | Chebyshev  type II low pass filter (with 2 poles).+lpCheb2 :: Sig -> Sig -> Sig +lpCheb2 = lpCheb2' 2++-- | Chebyshev  type II low pass filter (with given number of poles, first argument).+lpCheb2' :: D -> Sig -> Sig -> Sig+lpCheb2' npoles kcf asig = clfilt asig kcf 0 npoles `withD` 2++-- | Butterworth lowpass filter based on clfilt opcode (with 2 poles).+clp :: Sig -> Sig -> Sig+clp = clp' 2++-- | Butterworth lowpass filter based on clfilt opcode (with given number of poles, first argument).+clp' :: D -> Sig -> Sig -> Sig+clp' npoles kcf asig = clfilt asig kcf 0 npoles `withD` 0++-- high pass++-- | Chebyshev  type I high pass filter (with 2 poles).+hpCheb1 :: Sig -> Sig -> Sig+hpCheb1 = hpCheb1' 2++-- | Chebyshev  type I high pass filter (with given number of poles, first argument).+hpCheb1' :: D -> Sig -> Sig -> Sig+hpCheb1' npoles kcf asig = clfilt asig kcf 1 npoles `withD` 1++-- | Chebyshev  type II high pass filter (with 2 poles).+hpCheb2 :: Sig -> Sig -> Sig +hpCheb2 = hpCheb2' 2++-- | Chebyshev  type II high pass filter (with given number of poles, first argument).+hpCheb2' :: D -> Sig -> Sig -> Sig+hpCheb2' npoles kcf asig = clfilt asig kcf 1 npoles `withD` 2++-- | Butterworth high pass filter based on clfilt opcode (with 2 poles).+chp :: Sig -> Sig -> Sig+chp = clp' 2++-- | Butterworth high pass filter based on clfilt opcode (with given number of poles, first argument).+chp' :: D -> Sig -> Sig -> Sig+chp' npoles kcf asig = clfilt asig kcf 1 npoles `withD` 0++------------------------------------------+-- band-pass++mkBp :: FlatFilter -> FlatFilter -> Sig -> Sig -> Sig -> Sig+mkBp lowPass highPass cfq bw asig = highPass (cfq - rad) $ lowPass (cfq + rad) asig+    where rad = bw / 2++bpCheb1 :: Sig -> Sig -> Sig -> Sig+bpCheb1 = bpCheb1' 2++bpCheb1' :: D -> Sig -> Sig -> Sig -> Sig+bpCheb1' npoles = mkBp (lpCheb1' npoles) (hpCheb1' npoles) ++bpCheb2 :: Sig -> Sig -> Sig -> Sig+bpCheb2 = bpCheb2' 2++bpCheb2' :: D -> Sig -> Sig -> Sig -> Sig+bpCheb2' npoles = mkBp (lpCheb2' npoles) (hpCheb2' npoles) ++cbp :: Sig -> Sig -> Sig -> Sig+cbp = cbp' 2++cbp' :: D -> Sig -> Sig -> Sig -> Sig+cbp' npoles = mkBp (clp' npoles) (chp' npoles) +++---------------------------------------------+-- resonant filters++mkReson :: FlatFilter -> FlatFilter -> ResonFilter+mkReson lowPass highPass kcf res asig = 0.5 * (lowPass (kcf * 2) asig + bandPass bw kcf asig)+    where+        bw = kcf / (0.001 + abs res)+        bandPass = mkBp lowPass highPass   ++cheb1 :: Sig -> Sig -> Sig -> Sig+cheb1 = cheb1' 2++cheb1' :: D -> Sig -> Sig -> Sig -> Sig+cheb1' npoles = mkReson (lpCheb1' npoles) (hpCheb1' npoles) ++cheb2 :: Sig -> Sig -> Sig -> Sig+cheb2 = cheb2' 2++cheb2' :: D -> Sig -> Sig -> Sig -> Sig+cheb2' npoles = mkReson (lpCheb2' npoles) (hpCheb2' npoles) ++vcf :: Sig -> Sig -> Sig -> Sig+vcf = cbp' 2++vcf' :: D -> Sig -> Sig -> Sig -> Sig+vcf' npoles = mkReson (clp' npoles) (chp' npoles) ++-- moog ladder++ladder :: Sig -> Sig -> Sig -> Sig+ladder kcf res asig = moogladder asig kcf res++-----------------------------------------+-- named filters++plastic :: Sig -> Sig -> Sig -> Sig+plastic kcf res asig = rezzy asig kcf (1 + 99 * res)++wobble :: Sig -> Sig -> Sig -> Sig+wobble kcf res asig = lowres asig kcf res++trumpy :: Sig -> Sig -> Sig -> Sig+trumpy kcf res asig = vlowres asig kcf (res* 0.15) 6 (4 + res * 20)++harsh :: Sig -> Sig -> Sig -> Sig+harsh kcf res asig = bat (\x -> bqrez x kcf (1 + 90 * res)) asig++-----------------------------++-- | Fixed version of tbfcv filter+-- the first argument is distortion (range [0, 1])+tbf :: Sig -> Sig -> Sig -> Sig -> Sig+tbf dist kcf res asig = tbvcf asig (1010 + kcf) res (0.5 + 3.5 * dist) 0.5++-----------------------------+-- state variable filter++slp :: Sig -> Sig -> Sig -> Sig+slp kcf res asig = lows+    where (_, lows, _, _) = statevar asig kcf res++shp :: Sig -> Sig -> Sig -> Sig+shp kcf res asig = highs+    where (highs, _, _, _) = statevar asig kcf res++sbp :: Sig -> Sig -> Sig -> Sig+sbp kcf res asig = mids+    where (_, _, mids, _) = statevar asig kcf res++sbr :: Sig -> Sig -> Sig -> Sig+sbr kcf res asig = sides+    where (_, _, _, sides) = statevar asig kcf res+++multiStatevar :: (Sig, Sig, Sig) -> Sig -> Sig -> Sig -> Sig+multiStatevar (weightLows, wieghtHighs, weightMids) kcf res asig = weightLows * lows + wieghtHighs * highs + weightMids * mids+    where (highs, lows, mids, _) = statevar asig kcf res++multiSvfilter :: (Sig, Sig, Sig) -> Sig -> Sig -> Sig -> Sig+multiSvfilter (weightLows, wieghtHighs, weightMids) kcf res asig = weightLows * lows + wieghtHighs * highs + weightMids * mids+    where (highs, lows, mids) = svfilter asig kcf res+

@@ -1,3 +1,4 @@+{-# Language FlexibleContexts #-} -- | Effects module Csound.Air.Fx(         -- * Reverbs@@ -5,6 +6,16 @@     smallRoom, smallHall, largeHall, magicCave,     smallRoom2, smallHall2, largeHall2, magicCave2, +    room, chamber, hall, cave,++    -- ** Impulse Responce convolution reverbs+    --+    -- | Be careful with volumes. Some IRs can require scaling with really small coefficients like 0.01.+    -- +    monoIR, stereoIR, stereoIR2, pmonoIR, pstereoIR, pstereoIR2, +    monoIR', stereoIR', stereoIR2',+    ZConvSpec(..), zconv, zconv',+     -- * Delays     MaxDelayTime, DelayTime, Feedback, Balance,     echo, fdelay, fvdelay, fvdelays, funDelays, tabDelay,@@ -16,6 +27,7 @@     -- * Chorus     DepthSig, RateSig, WidthSig, ToneSig,     chorus,+    -- solinaChorus, testSolinaChorus,      -- * Flanger     flange,@@ -30,6 +42,9 @@     fxWhite, fxWhite2, fxPink, fxPink2, equalizer, equalizer2, eq4, eq7,     fxGain,  +    -- Eq+    audaciousEq,+     -- * Misc     trackerSplice @@ -42,9 +57,11 @@ import Csound.Tab(sines4, startEnds, setSize, elins, newTab, tabSizeSecondsPower2, tablewa, sec2rel) import Csound.Typed.Opcode import Csound.SigSpace+import Csound.Tab  import Csound.Air.Wave(Lfo, unipolar, oscBy, utri, white, pink) import Csound.Air.Filter+import Csound.Typed.Plugins  -- | Mono version of the cool reverberation opcode reverbsc. --@@ -105,6 +122,81 @@ -- | The magic cave reverb (stereo). magicCave2 :: Sig2 -> Sig2 magicCave2 = rever2 0.99++---------------------------------------------------------------------------------++-- | An alias for +--+-- > let room dryWet asig = mixAt dryWet smallRoom2 asig+room :: MixAt Sig2 Sig2 a => Sig -> a -> AtOut Sig2 Sig2 a+room mx ain = mixAt mx smallRoom2 ain++-- | An alias for +--+-- > let room dryWet asig = mixAt dryWet smallHall2 asig+chamber :: MixAt Sig2 Sig2 a => Sig -> a -> AtOut Sig2 Sig2 a+chamber mx ain = mixAt mx smallHall2 ain++-- | An alias for +--+-- > let room dryWet asig = mixAt dryWet largeHall2 asig+hall :: MixAt Sig2 Sig2 a => Sig -> a -> AtOut Sig2 Sig2 a+hall mx ain = mixAt mx largeHall2 ain++-- | An alias for +--+-- > let room dryWet asig = mixAt dryWet magicCave2 asig+cave :: MixAt Sig2 Sig2 a => Sig -> a -> AtOut Sig2 Sig2 a+cave mx ain = mixAt mx magicCave2 ain++---------------------------------------------------------------------------------+-- IR reverbs++-- | Fast zero delay convolution with impulse response that is contained in mono-audio file.+--+-- > monoIR irFile ain+monoIR :: FilePath -> Sig -> Sig+monoIR = monoIR' def++-- | Fast zero delay convolution with impulse response that is contained in mono-audio file.+-- We can specify aux parameters for convolution algorithm (see @zconv'@).+--+-- > monoIR' spec irFile ain+monoIR' :: ZConvSpec -> FilePath -> Sig -> Sig+monoIR' spec fileName ain = zconv' spec (wavLeft fileName) ain++-- | Fast zero delay convolution with impulse response that is contained in stereo-audio file.+--+-- > stereoIR irFile ain+stereoIR :: FilePath -> Sig2 -> Sig2+stereoIR = stereoIR' def++-- | Fast zero delay convolution with impulse response that is contained in stereo-audio file.+-- We can specify aux parameters for convolution algorithm (see @zconv'@).+--+-- > stereoIR' spec irFile ain+stereoIR' :: ZConvSpec -> FilePath -> Sig2 -> Sig2+stereoIR' spec fileName (ainL, ainR) = (zconv' spec (wavLeft fileName) ainL, zconv' spec (wavRight fileName) ainR)++-- | If IR is encoded in a couple of mono files.+stereoIR2 :: (FilePath, FilePath) -> Sig2 -> Sig2+stereoIR2 = stereoIR2' def++-- | If IR is encoded in a couple of mono files.+stereoIR2' :: ZConvSpec -> (FilePath, FilePath) -> Sig2 -> Sig2+stereoIR2' spec (file1, file2) (ainL, ainR) = (monoIR' spec file1 ainL, monoIR' spec file2 ainR)++-- | Precise mono IR with pconvolve (requires a lot of CPU).+pmonoIR :: FilePath -> Sig -> Sig+pmonoIR fileName ain = pconvolve ain (text fileName)++-- | Precise stereo IR with pconvolve (requires a lot of CPU).+pstereoIR :: FilePath -> Sig2 -> Sig2+pstereoIR fileName (ainL, ainR) = pconvolve ((ainL + ainR) * 0.5) (text fileName)++pstereoIR2 :: (FilePath, FilePath) -> Sig2 -> Sig2+pstereoIR2 (file1, file2) (ainL, ainR) = (pmonoIR file1 ainL, pmonoIR file2 ainR)+      --------------------------------------------------------------------------------- -- Delays

@@ -0,0 +1,379 @@+    -- | Wonderful echoes from morpheus.+-- Granular synthesis for morphing between waveforms.+-- It's a simplification of partikkel opcode for the case of morphing.+module Csound.Air.Granular.Morpheus(+	WaveAmp, WaveKey, MorphWave, +	MorphSpec(..), GrainDensity(..), GrainEnv(..),++	morpheus,++	-- *  Sound files+	morphSnd1, morphSnd,++	-- * Amplitude modes+	pairToSquare,++	-- * Oscillators+	morpheusOsc, morpheusOsc2+) where++import Control.Arrow+import Data.Default++import Csound.Typed+import Csound.Typed.Opcode+import Csound.Tab+import Csound.SigSpace++import Csound.Air.Granular(Pointer, csdPartikkel)+import Csound.Air.Wav+import Csound.Air.Wave+import Csound.Types(compareWhenD)++type WaveAmp = Sig+type WaveKey = Sig++type MorphWave = (Tab, WaveAmp, WaveKey, Pointer)++-- | Density of the grain stream.  +-- +-- * @rate@ is how many grains per second is generated+--+-- * @size@ is the size of each grain in milliseconds (it's good to set it relative to grain rate)+--+-- * @skip@ skip is a skip ratio (0 to 1). It's the probability of grain skip. Zero means no skip and 1 means every grain is left out.+--+-- see docs for Csound partikkel opcode for more detailed information <http://www.csounds.com/manual/html/partikkel.html>+data GrainDensity = GrainDensity +	{ grainRate :: Sig+	, grainSize :: Sig+	, grainSkip :: Sig }++instance Default GrainDensity where+	def = GrainDensity+			{ grainRate = kGrainRate+			, grainSize = kduration+			, grainSkip = 0 }+		where +			kGrainDur	= 2.5							-- length of each grain relative to grain rate +			kduration	= (kGrainDur*1000)/kGrainRate	-- grain dur in milliseconds, relative to grain rate+			kGrainRate  = 12++-- | Parameters for grain envelope.+--+-- * attShape -- table that contains shape of the attack.+--+-- * decShape -- table that contains shape of the decay+--+-- * sustRatio -- how big is sustain phase relative to attack and decay+--+-- * attack to decay ration -- relative amount of attack decay ration. 0.5 means attack equals decay.+--+-- see docs for Csound partikkel opcode for more detailed information <http://www.csounds.com/manual/html/partikkel.html>+data GrainEnv = GrainEnv +	{ grainAttShape :: Tab+	, grainDecShape :: Tab+	, grainSustRatio :: Sig+	, grainAttDecRatio :: Sig }++instance Default GrainEnv where+	def = GrainEnv +			{ grainAttShape = sigmoidRise+			, grainDecShape = sigmoidFall+			, grainSustRatio = 0.25+			, grainAttDecRatio = 0.5 }++-- sigmoidRise = guardPoint $ sines4 [(0.5, 1, 270, 1)]+-- sigmoidFall = guardPoint $ sines4 [(0.5, 1, 90, 1)]++-- | Specification of morphing synth. It has the default instance +-- and the values in its records has default instances too+data MorphSpec = MorphSpec +	{ morphGrainDensity :: GrainDensity+	, morphGrainEnv     :: GrainEnv	+	}++instance Default MorphSpec where+	def = MorphSpec +		{ morphGrainDensity = def+		, morphGrainEnv     = def+		}++-- | Synth that is based on partikkel. It allows easy morphing between unlimited number of waves.+-- While partikkel allows only 4 waves to be used. We can use as many as we like. Internally+-- the list is split on groups 4 elements or less in each and one partikkel is applied to each group.+-- Many parameters of partikel were simplified to get the good defaults for sound morphing behavior.+--+-- > morpheus spec waves frequencyScale+--+-- * spec -- contains many misc parameters+--+-- * waves list can contain up to four wave tables to read grains from.+--+-- * frequencyScale -- scaling factor for frequency. 1 means playing at the original frequency, 2 rises the pitch by octave. +--     We can use negative values to play the grains in reverse.+morpheus :: MorphSpec -> [MorphWave] -> Sig -> SE Sig2+morpheus spec pwaves cps = sum $ fmap (\waves -> morpheus4 spec waves cps) (splitBy4 pwaves)++splitBy4 :: [a] -> [[a]]+splitBy4 xs = case xs of+    a:b:c:d:rest -> [a,b,c,d] : splitBy4 rest+    rest         -> [rest]++morpheus4 :: MorphSpec -> [MorphWave] -> Sig -> SE Sig2+morpheus4 spec pwaves cps = do+	iwaveamptab <- makeMorphTable amp1 amp2 amp3 amp4+	return $ csdPartikkel agrainrate kdistribution idisttab async kenv2amt ienv2tab+					ienv_attack ienv_decay ksustain_amount ka_d_ratio kduration kamp igainmasks+               	  	kwavfreq ksweepshape iwavfreqstarttab iwavfreqendtab awavfm+               	  	ifmamptab ifmenv icosine kTrainCps knumpartials+               	  	kchroma ichannelmasks krandommask kwaveform1 kwaveform2 kwaveform3 kwaveform4+               	  	iwaveamptab asamplepos1 asamplepos2 asamplepos3 asamplepos4+               	  	kwavekey1 kwavekey2 kwavekey3 kwavekey4 imax_grains+    where+    	wave1 : wave2 : wave3 : wave4 : _ = cycle pwaves++    	async = 0+    	kamp = 1	+   	+    	ichannelmasks = skipNorm $ doubles [0, 0,  0.5]+    			    	+    	kdistribution = 1+    	idisttab = setSize 16 $ startEnds [1, 16, -10, 0]++    	-- grain shape settings+    	grainEnv = morphGrainEnv spec+    	ienv_attack = grainAttShape grainEnv+    	ienv_decay  = grainDecShape grainEnv+    	ksustain_amount = grainSustRatio grainEnv+    	ka_d_ratio = grainAttDecRatio grainEnv+    	kenv2amt = 0    +    	ienv2tab = eexps [1, 0.0001]	++    	-- grain density+    	grainDensity = morphGrainDensity spec+    	kGrainRate = grainRate grainDensity+    	kduration = grainSize grainDensity                    ++    	kwavfreq = cps++    	krandommask = grainSkip grainDensity++    	-- waves++    	kwavekey1 = getWaveKey wave1+    	kwavekey2 = getWaveKey wave2+    	kwavekey3 = getWaveKey wave3+    	kwavekey4 = getWaveKey wave4++    	asamplepos1 = getSamplePos wave1+    	asamplepos2 = getSamplePos wave2+    	asamplepos3 = getSamplePos wave3+    	asamplepos4 = getSamplePos wave4++    	kwaveform1 = getWaveForm wave1+    	kwaveform2 = getWaveForm wave2+    	kwaveform3 = getWaveForm wave3+    	kwaveform4 = getWaveForm wave4++    	amp1 = getAmp wave1+    	amp2 = getAmp wave2+    	amp3 = getAmp wave3+    	amp4 = getAmp wave4++    	imax_grains = 100   	++    	getWaveKey (tab1, amp1, key1, ptr1) = key1 / sig (getTabLen tab1)++    	getSamplePos (_, _, _, ptr) = ptr+    	getWaveForm (form, _, _, _) = form+    	getAmp (_, amp, _, _) = kr amp++    	-- no trainlets+    	icosine = cosine+    	kTrainCps = kGrainRate+    	knumpartials = 7+    	kchroma = 3++    	-- no FM+    	kGrFmFreq = kGrainRate / 4+    	kGrFmIndex = 0    	+    	aGrFmSig = kGrFmIndex * osc kGrFmFreq+    	agrainrate = kGrainRate + aGrFmSig * kGrainRate+    	ifmenv = elins [0, 1, 0]+    	ifmamptab = skipNorm $ doubles [0, 0, 1]    	+    	awavfm = 0++    	-- other params+    	igainmasks = skipNorm $ doubles [0, 0,   1]+    	ksweepshape = 0.5+    	iwavfreqstarttab = skipNorm $ doubles [0, 0, 1]+    	iwavfreqendtab = skipNorm $ doubles [0, 0, 1]++    	makeMorphTable a1 a2 a3 a4 = do+    		t <- newTab 64+    		mapM_  (\(i, amp) -> tablew amp  (2 + sig (int i)) t ) (zip [0 .. ] [a1, a2, a3, a4])+    		return t++getTabLen t = ftlen t / getSampleRate++-- | Creates four control signals out two signals. The control signals are encoded by the position+-- of the point on XY-plane. The four resulting signals are derived from the proximity of the point+-- to four squares of the ((0, 1), (0, 1)) square. It can be useful to control the morpheus with XY-pad controller.+pairToSquare :: (Sig, Sig) -> (Sig, Sig, Sig, Sig)+pairToSquare (x, y) = ((1 - x) * (1 - y), x * (1 - y) , x * y, (1 - x) * y)++-- | Morpheus synth for mono-audio files. The first cell in each tripple is occupied by file name.+-- The rest arguments are the same as for @morpheus@.+morphSnd1 :: MorphSpec -> [(String, WaveAmp, WaveKey)] -> Sig -> SE Sig2+morphSnd1 spec waves cps = morpheus spec (fmap fromSnd waves) cps+	where+		fromSnd (file, amp, key) = (wavLeft file, amp, key, phasor (1 / sig (lengthSnd file)))++-- | Morpheus synth for stereo-audio files. The first cell in each tripple is occupied by file name.+-- The rest arguments are the same as for @morpheus@.+morphSnd :: MorphSpec -> [(String, WaveAmp, WaveKey)] -> Sig -> SE Sig2+morphSnd spec waves cps = morphSndByTab wavLeft spec waves cps + morphSndByTab wavRight spec waves cps++morphSndByTab :: (String -> Tab) -> MorphSpec -> [(String, WaveAmp, WaveKey)] -> Sig -> SE Sig2+morphSndByTab getTab spec waves cps = morpheus spec (fmap fromSnd waves) cps+	where+		fromSnd (file, amp, key) = (getTab file, amp, key, phasor (1 / sig (lengthSnd file)))++-- | Morpheus oscillator.+--+-- > morpheusOsc spec (baseFrequency, table) cps+--+-- @baseFrequency@ is the frequency of the sample contained in the table. With oscillator+-- we can read the table on different frequencies. +morpheusOsc :: MorphSpec -> (D, Tab) -> Sig -> SE Sig2+morpheusOsc spec (baseFreq, t) cps = morpheus spec waves ratio+	where+		ratio = cps / sig baseFreq+		aptr = cycleTab t+		waves = [(t, 1, 1, aptr)]++cycleTab t = phasor $ sig $ recip $ getTabLen t++-- | Morpheus oscillator. We control the four tables with pair of control signals (see the function @pairToSquare@).+--+-- > morpheusOsc2 spec baseFrequency waves (x, y) cps = ...+morpheusOsc2 :: MorphSpec -> D -> [(Sig, Tab)] -> (Sig, Sig) -> Sig -> SE Sig2+morpheusOsc2 spec baseFreq ts (x, y) cps = morpheus spec waves ratio+	where+		(a1, a2, a3, a4) = pairToSquare (x, y)+		ratio = cps / sig baseFreq		+		waves = zipWith (\amp (key, t) -> (t, amp, key, cycleTab t)) (cycle [a1, a2, a3, a4]) ts+++{- examples++main' = dac $ mul 0.2 $ morphSnd1 def [("floss/ClassGuit.wav", linseg [1, 3, 1, 3, 0], linseg [1, 3, 1, 3, 0]), ("floss/ClassGuit.wav", linseg [0, 3, 0, 3, 1], (-1))] 1++main = dac $ lift1 (\p -> mixAt 0.25 largeHall2 $ mixAt 0.6 (pingPong 0.124 0.5 0.7) $+	at (filt 2 (\cfq res x -> moogladder x cfq res) (env * 12000) 0.1) $ mul (0.2 * env) $ +	morpheus (def { morphGrainDensity = def { grainRate = linseg [36, 18, 4], grainSize = linseg [ 1200, 6, 5700, 12, 750 ], grainSkip = 0.45 * uosc 0.17 }}) +		(tabs p) (negate $ semitone (5))) (ujoy (0.5, 0.5)) +		where+			tabs (x, y) = [file a1 1, file a2 0.5, file2 a3 1, file3 a4 1]+				where (a1, a2, a3, a4) = pairToSquare (x, y)++			file a x = (wavl "floss/ClassGuit.wav", a, x, linseg [2.5, 18, 3.5])+			file2 a x = (wavl "floss/hd.wav", a, x, linseg [0.2, 18, 0.6])+			file3 a x = (wavl "floss/hd.wav", a, x, linseg [0.02, 18, 0.5])++			env = linseg [0, 1, 1, 3, 1] -- 10, 0]++			amp1 = linseg [1, 8, 1, 4, 0]+			amp2 = linseg [0, 6, 0, 6, 1]++-}+++{-+-- todo+-- playing samples in chain++pyramidWeights++partWaveChain :: [Double] -> Sig -> (Sig, Sig, Sig, Sig)+partWaveChain xs pointer = case xs of+	[a, da] -> +		let (amp1, amp2) = go1 a da pointer+		in  (amp1, amp2, 0, 0)+	[a, da, b, db] -> 		+		let (amp1, amp2, amp3) = go2 a da b db pointer+		in  (amp1, amp2, amp3, 0)+	[a, da, b, db, c, dc] -> +		let (amp1, amp2, amp3, amp4) = go3 a da b db c dc pointer	+		in  (amp1, amp2, amp3, amp4)+	_ -> error "partWaveChain: wrong number of elements in the list. Should be [a, da], [a, da, b, db] or [a, da, b, db, c, dc]."		+	where+		go1 a da ptr = (readTab t1 ptr, readTab t2 ptr)+			where+				d = da / 2+				t1 = leftTab (a - d) (a + d)+				t2 = rightTab (a - d) (a + d)++		go2 a da b db = (readTab t1 ptr, readTab t2 ptr, readTab t3 ptr)+			where+				da2 = da / 2+				db2 = db / 2+				t1 = leftTab (a - da2) (a + da2)+				t2 = centerTab (a - da2) (a + da2) (b - db2) (b + db2)+				t3 = rightTab (b - db2) (b + db2)++		go3 = undefined++		readTab t ptr = table ptr t1 `withD` 1+		leftTab a b c  = lins [1, a, 1, b, 0, c, 0] +		rightTab a b c = lins [0, a, 0, b, 1, c, 1] +		centerTab a b c d e = lins [0, a, 0, b, 1, c, 1, d, 0, e, 0]++partWaveChain2 :: Sig -> (Sig, Sig, Sig, Sig)+partWaveChain2 = partWaveChain [0.5, 0.25]++partWaveChain3 :: Sig -> (Sig, Sig, Sig, Sig) +partWaveChain3 = partWaveChain [1/3, 0.25, 1/3, 0.25]++partWaveChain4 :: Sig -> (Sig, Sig, Sig, Sig) +partWaveChain4 = partWaveChain [0.25, 0.2, 0.25, 0.2, 0.25, 0.2]++cfdChainWeights :: [Double] -> Sig -> [Sig]+cfdChainWeights xs ptr = getWeights ptr (getPairs xs)+	where+		getPairs xs = case xs of+			a:b:rest -> (a, b) : getPairs rest+			_        -> []++		getPairs ptr xs = case xs of+			[] -> [1]+			[(a, rada)] -> go1 a rada ptr+			a : as -> goN a (init as) (zip lengs $ makeAdjacentPairs xs) (last as)+		where+			go1 a da ptr = [readTab t1 ptr, readTab t2 ptr]+				where+					d = da / 2+					t1 = leftTab (a - d) (a + d)+					t2 = rightTab (a - d) (a + d)++			goN (start, startRad) center (end, endRad) = +				startTab ++ centerTabs ++ [endTab]+				where+					startTab = leftTab (start - startRad) (2 * startRad) (1 - (start + startRad))+					endTab   = rightTab (1 - (end - endRad)) (2 * endRad) (end + endRad) +					centerTabs = fmap toCenterTab center++					toCenterTab (leng, (a, rada), (b, radb)) = centerTab (leng - rada) (2 * rada)++			readTab t ptr = table ptr t1 `withD` 1+			leftTab a b c  = lins [1, a, 1, b, 0, c, 0] +			rightTab a b c = lins [0, a, 0, b, 1, c, 1] +			centerTab a b c d e = lins [0, a, 0, b, 1, c, 1, d, 0, e, 0]++			makeAdjacentPairs xs = case xs of+				[] -> []+				x:xs -> tail $ scanl (\(a, b) c -> (b, c)) (x, x) xs ++			lengs xs = tail $ scanl (\res (a, _) -> res + a) 0 xs +-}			

@@ -11,12 +11,13 @@     -- * Instrument choosers     hinstrChooser, vinstrChooser,     hmidiChooser, vmidiChooser,-    hpatchChooser, vpatchChooser,+--    hpatchChooser, vpatchChooser,      -- ** Fx units     uiDistort, uiChorus, uiFlanger, uiPhaser, uiDelay, uiEcho,     uiFilter, uiReverb, uiGain, uiWhite, uiPink, uiFx, uiRoom,-    uiHall, uiCave, uiSig, uiMix, uiMidi, uiPatch,+    uiHall, uiCave, uiSig, uiMix, uiMidi, +    -- uiPatch,       -- * Static widgets     AdsrBound(..), AdsrInit(..),@@ -308,10 +309,12 @@ uiMidi xs initVal = sourceColor2 C.forestgreen $ uiBox "Midi" fx True     where fx = lift1 (\aout arg -> return $ aout + arg) $ vmidiChooser xs initVal +{- -- | Patch chooser implemented as FX-box. uiPatch :: [(String, Patch2)] -> Int -> Source FxFun  uiPatch xs initVal = sourceColor2 C.forestgreen $ uiBox "Patch" fx True     where fx = lift1 (\aout arg -> return $ aout + arg) $ vpatchChooser xs initVal+-}  -- | the widget for mixing in a signal to the signal. uiSig :: String -> Bool -> Source Sig2 -> Source FxFun@@ -409,6 +412,7 @@ routeInstr :: Sigs b => [a -> SE b] -> Sig -> (a -> SE b) routeInstr instrs instrId arg = fmap sum $ mapM ( $ arg) $ zipWith (\n instr -> playWhen (sig (int n) ==* instrId) instr) [0 ..] instrs +{- ---------------------------------------------------- -- effect choosers @@ -427,4 +431,4 @@         instrs = fmap patchInstr patches         fxs    = fmap getPatchFx patches         -+-}

@@ -2,7 +2,7 @@ -- | A multitap looper. module Csound.Air.Looper ( 	LoopSpec(..), LoopControl(..),-	sigLoop, midiLoop, sfLoop, patchLoop+	sigLoop, midiLoop, sfLoop --, patchLoop ) where  import Control.Monad@@ -132,9 +132,11 @@ midiLoop :: LoopSpec -> D -> [D] -> [Msg -> SE Sig2] -> Source Sig2 midiLoop = genLoop $ \cond midiInstr -> midi $ playWhen cond midiInstr  +{- -- | Some instruments not work well with the looper. Alwo be aware of limitation of software resources. patchLoop :: LoopSpec -> D -> [D] -> [Patch2] -> Source Sig2 patchLoop = genLoop $ \cond p -> atMidi (patchWhen cond p)+-}  -- | Simple multitap Looper. We can create as many taps as we like -- also we can create fade outs/ins insert effects and control mix. 

@@ -417,13 +417,8 @@ testDrone3 cps = atNote (deepPad caveOvertonePad) (0.8, cps) testDrone4 cps = atNote (deepPad pwEnsemble) (0.8, cps) -pwEnsemble = Patch-    { patchInstr = at fromMono . mul 0.55 . onCps impPwEnsemble-    , patchFx    = fx1 0.25 smallHall2 }--nightPad = Patch-    { patchInstr = mul 0.48 . at fromMono . onCps (mul (fadeOut 1) . impNightPad 0.5)-    , patchFx    = fx1 0.25 largeHall2 }+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)  data RazorPad = RazorPad { razorPadSpeed :: Sig } @@ -431,16 +426,14 @@     def = RazorPad 0.5  razorPad = razorPad' def--razorPad' (RazorPad speed) = Patch-    { patchInstr = at fromMono . mul 0.6 . onCps (uncurry $ impRazorPad speed)-    , patchFx    = fx1 0.35 largeHall2 }+razorPad' (RazorPad speed) = withLargeHall' 0.35 $ PolySynt def $ at fromMono . mul 0.6 . onCps (uncurry $ impRazorPad speed)     -overtonePad = Patch-    { patchInstr = 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)))-    , patchFx    = fx1 0.35 smallHall2 }+overtonePad = withLargeHall' 0.35 $ PolySynt def 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 = overtonePad { patchFx = fx1 0.2 (magicCave2 . mul 0.8) }+caveOvertonePad =  FxChain (fx1 0.2 (magicCave2 . mul 0.8)) $ PolySynt def overtoneInstr  -- implem 

@@ -27,7 +27,10 @@     -- * Layered padsynth     padsynthOscMultiCps, padsynthOscMultiCps2,     padsynthOscMultiVol, padsynthOscMultiVol2,-    padsynthOscMultiVolCps, padsynthOscMultiVolCps2    +    padsynthOscMultiVolCps, padsynthOscMultiVolCps2,++    -- * Granular oscillators+    morphsynthOscMultiCps, quadMorphsynthOscMultiCps    ) where  import Data.List@@ -37,7 +40,10 @@ import Csound.Tab import Csound.Air.Wave import Csound.Typed.Opcode(poscil)+import Csound.Types(compareWhenD) +import Csound.Air.Granular.Morpheus+ -- | Padsynth oscillator.  -- -- padsynthOsc spec frequency@@ -134,22 +140,6 @@ padsynthOscMultiVolCps2 specs x = toStereoOsc (padsynthOscMultiVolCps specs) x  ------------------------------------------------------- --whenElseD :: BoolD -> SE () -> SE () -> SE ()-whenElseD cond ifDo elseDo = whenDs [(cond, ifDo)] elseDo--compareWhenD :: D -> [(D, SE ())] -> SE ()-compareWhenD val conds = case conds of-    [] -> return ()-    [(cond, ifDo)] -> ifDo -    (cond1, do1):(cond2, do2): [] -> whenElseD (val `lessThan` cond1) do1 do2-    _ -> whenElseD (val `lessThan` rootCond) (compareWhenD val less) (compareWhenD val more)-    where-        (less, more) = splitAt (length conds `div` 2) conds-        rootCond = fst $ last less------------------------------------------------------ -- waves  -- | Creates padsynth oscillator with given harmonics.@@ -234,3 +224,23 @@ -- an idea ^ to crossfade between noises 4 knobs and to crossfade between harmonics other 4 knobs -- for a synth +----------------------------------------------------------------+-- morpheus oscil++-- | Combines morpheus oscillators with padsynth algorithm.+-- It uses single table for granular synthesis.+morphsynthOscMultiCps :: MorphSpec -> [(Double, PadsynthSpec)] -> D -> SE Sig2+morphsynthOscMultiCps morphSpec specs freq = do+    (baseFreq, tab) <- layeredPadsynthSpec freq (fmap (first double) specs)+    morpheusOsc morphSpec (baseFreq, tab) (sig freq)++-- | Combines morpheus oscillators with padsynth algorithm.+-- It uses up to four tables for granular synthesis.+quadMorphsynthOscMultiCps :: MorphSpec -> [[(Double, PadsynthSpec)]] -> (Sig, Sig) -> D -> SE Sig2+quadMorphsynthOscMultiCps morphSpec specs (x, y) freq = do+    freqTabs <- mapM getFreqTab specs    +    let mainFreq = fst $ head freqTabs +    morpheusOsc2 morphSpec mainFreq (fmap (toTab mainFreq) freqTabs) (x, y) (sig freq)+    where+        getFreqTab specs = layeredPadsynthSpec freq (fmap (first double) specs)+        toTab mainFreq (freq, t) = (sig $ freq / mainFreq, t)

@@ -1,13 +1,17 @@ {-# Language ScopedTypeVariables #-} -- | Patches. module Csound.Air.Patch(+   	CsdNote, Instr, Fx, Fx1, Fx2, FxSpec(..), DryWetRatio,-	Patch1, Patch2, Patch(..),	-	PatchSig1, PatchSig2,-	getPatchFx, dryPatch, atMix, atMixes,+	Patch1, Patch2, Patch(..), PolySyntSpec(..), MonoSyntSpec(..),+    polySynt, monoSynt, +    mapPatchInstr, mapMonoPolyInstr, transPatch, dryPatch, getPatchFx,	+    setFxMix, setFxMixes,+    setMidiChn,+ 	-- * Midi-	atMidi, atMono, atMono', atMonoSharp, atHoldMidi,+	atMidi,   	-- * Events 	atSched,@@ -20,14 +24,16 @@ 	atNote,  	-- * Fx-	addInstrFx, addPreFx, addPostFx,+    addInstrFx, addPreFx, addPostFx,  	-- * Pads 	harmonPatch, deepPad,  	-- * Misc-	patchWhen, mixInstr,+	patchWhen,  +    mixInstr,+ 	-- * Rever 	withSmallRoom, withSmallRoom',  	withSmallHall, withSmallHall',@@ -37,18 +43,24 @@ 	-- * Sound font patches 	sfPatch, sfPatchHall, -	-- * Csound API-	patchByNameMidi, monoPatchByNameMidi, monoSharpPatchByNameMidi, monoPatchByNameMidi',+    -- * Monosynt params+    onMonoSyntSpec, setMonoSharp, setMonoHold,+	+    -- * Csound API+    patchByNameMidi,  	-- * Custom temperament 	-- ** Midi-	atMidiTemp, atMonoTemp, atMonoSharpTemp, atMonoTemp', atHoldMidiTemp, +	atMidiTemp, 	-- ** Csound API-	patchByNameMidiTemp, monoPatchByNameMidiTemp, monoSharpPatchByNameMidiTemp, monoPatchByNameMidiTemp'+    patchByNameMidiTemp	     ) where +import Data.Boolean+import Data.Default     import Control.Monad import Control.Applicative+import Control.Arrow(second)  import Csound.Typed import Csound.SigSpace@@ -58,6 +70,7 @@ import Csound.Air.Fx import Csound.Typed.Opcode(cpsmidinn, ampdb) import Csound.Tuning+import Csound.Types  -- | A simple csound note (good for playing with midi-keyboard). -- It's a pair of amplitude (0 to 1) and freuqncy (Hz).@@ -76,179 +89,386 @@ -- | Stereo effect. type Fx2 = Fx Sig2 --- | Mono patches.-type Patch1 = Patch D Sig---- | Stereo patches.-type Patch2 = Patch D Sig2---- | Mono continuous patches.-type PatchSig1 = Patch Sig Sig---- | Stereo continuous patches.-type PatchSig2 = Patch Sig Sig2-+-- | Fx specification. It;s a pair of dryWet ratio and a transformation function. data FxSpec a = FxSpec 	{ fxMix :: DryWetRatio 	, fxFun :: Fx a	 	} --- | A patch. It's an instrument, an effect and default dry/wet ratio.-data Patch a b = Patch-	{ patchInstr :: Instr a b-	, patchFx	 :: [FxSpec b]-	}+-- | Mono-output patch.+type Patch1 = Patch Sig -dryPatch :: Patch a b -> Patch a b-dryPatch p = p { patchFx = [] }+-- | Stereo-output patch.+type Patch2 = Patch Sig2 --- | Sets the mix of the last effect.-atMix :: Sig -> Patch a b -> Patch a b-atMix k p = p { patchFx = mapHead (\x -> x { fxMix = k }) (patchFx p) }-	where -		mapHead f xs = case xs of-			[]   -> []-			a:as -> f a : as+-- | Specification for monophonic synthesizer.+-- +-- * 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 } --- | Sets the mix of the effects from last to first.-atMixes :: [Sig] -> Patch a b -> Patch a b-atMixes ks p = p { patchFx = zipFirst (\k x -> x { fxMix = k }) ks (patchFx p) }-	where-		zipFirst f xs ys = case (xs, ys) of-			(_,    [])   -> []-			([],   bs)   -> bs-			(a:as, b:bs) -> f a b : zipFirst f as bs+instance Default MonoSyntSpec where+    def = MonoSyntSpec +        { monoSyntChn = ChnAll+        , monoSyntHold = False+        , monoSyntSlideTime = 0.01+        , monoSyntRelease = 0.1 } +data PolySyntSpec = PolySyntSpec+    { polySyntChn :: MidiChn } -wet :: (SigSpace a, Sigs a) => FxSpec a -> Fx a-wet (FxSpec k fx) asig = fmap ((mul (1 - k) asig + ) . mul k) $ fx asig+instance Default PolySyntSpec where+    def = PolySyntSpec { polySyntChn = ChnAll } --- | Transforms all the effects for the given patch into a single function. -getPatchFx :: (SigSpace a, Sigs a) => Patch b a -> Fx a-getPatchFx p = foldr (<=<) return $ fmap wet $ patchFx p+-- | The patch can be:+--+-- *  a plain monophonic or polyphonic synthesizer+--+-- * patch with chain of effects, +--+-- * split on keyboard with certain frequency+--+-- * 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)+    | SplitPatch (Patch a) D (Patch a)+    | LayerPatch [(Sig, Patch a)] --------------------------------------------------------------- -instance SigSpace a => SigSpace (Patch b a) where-	mapSig f p = p { patchInstr = fmap (mapSig f) . patchInstr p }+polySynt :: (Instr D a) -> Patch a+polySynt = PolySynt def +monoSynt :: (Instr Sig a) -> Patch a+monoSynt = MonoSynt def++-- 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 mono poly x = case x of+    MonoSynt spec instr -> MonoSynt spec (mono instr)+    PolySynt spec instr -> PolySynt spec (poly instr)+    FxChain  fxs p      -> FxChain fxs (rec p)+    LayerPatch xs       -> LayerPatch (mapSnd rec xs)+    SplitPatch a dt b   -> SplitPatch (rec a) dt (rec b)+    where+        rec = mapMonoPolyInstr mono poly++-- Maps all polyphonic patches within the given patch.+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+    FxChain fxs p -> FxChain fxs $ rec p+    LayerPatch xs -> LayerPatch (mapSnd rec xs)+    SplitPatch a dt b -> SplitPatch (rec a) dt (rec b)+    where+        rec = mapPatchInstr f++-- | Removes all effects from the patch.+dryPatch :: Patch a -> Patch a+dryPatch x = case x of+    MonoSynt spec instr -> x+    PolySynt spec instr -> x+    FxChain _ p         -> dryPatch p+    SplitPatch a dt b   -> SplitPatch (dryPatch a) dt (dryPatch b)+    LayerPatch xs       -> LayerPatch $ mapSnd dryPatch xs++-- | Sets the dryWet ratio of the effects wwithin the patch.+setFxMix :: Sig -> Patch a -> Patch a+setFxMix a = setFxMixes [a]++-- | 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+    _ -> p+    where+        zipFirst f xs ys = case (xs, ys) of+            (_,    [])   -> []+            ([],   bs)   -> bs+            (a:as, b:bs) -> f a b : zipFirst f as bs+ ----------------------------------------------------------------- note --- | Plays a patch at the given note.-atNote :: (SigSpace b, Sigs b) => Patch a b -> CsdNote a -> SE b-atNote p note = getPatchFx p =<< patchInstr p note+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+                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 +mapSnd :: (a -> b) -> [(c, a)] -> [(c, b)]+mapSnd f = fmap (second f) ++wet :: (SigSpace a, Sigs a) => FxSpec a -> Fx a+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++-- | 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++getSplit :: (Num a, Tuple a) => BoolD -> SE a -> SE a -> SE a+getSplit cond a b = do+    ref <- newRef 0+    whenElseD cond +        (mixRef ref =<< a)+        (mixRef ref =<< b)+    readRef ref+ -------------------------------------------------------------- -- midi --- | Plays a patch with midi. Supplies a custom value for mixing effects (dry/wet).--- The 0 is a dry signal, the 1 is a wet signal.-atMidi :: (SigSpace a, Sigs a) => Patch D a -> SE a-atMidi a = getPatchFx a =<< midi (patchInstr a . ampCps)	---- | Plays a patch with midi. Supplies a custom value for mixing effects (dry/wet).--- The 0 is a dry signal, the 1 is a wet signal.-atMidiTemp :: (SigSpace a, Sigs a) => Temp -> Patch D a -> SE a-atMidiTemp tm a = getPatchFx a =<< midi (patchInstr a . ampCps' tm)+midiChn :: Sigs a => MidiChn -> (Msg -> SE a) -> SE a+midiChn chn = case chn of+    ChnAll -> midi+    Chn n  -> midin n+    Pgm pgm chn -> pgmidi pgm chn --- | Simplified monosynth patch-atMono :: (SigSpace a, Sigs a) => Patch Sig a -> SE a-atMono = atMono' ChnAll 0.01 0.1+-- | 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+            where+                getArg+                    | monoSyntHold spec = holdMsg chn port+                    | otherwise         = monoMsg chn port rel --- | Simplified monosynth patch with custom temperament.-atMonoTemp :: (SigSpace a, Sigs a) => Temp -> Patch Sig a -> SE a-atMonoTemp tm = atMonoTemp' tm ChnAll 0.01 0.1+                port = monoSyntSlideTime spec+                rel  = monoSyntRelease spec+                chn  = monoSyntChn spec --- | Simplified monosynth patch (sharp attack and transitions)-atMonoSharp :: (SigSpace a, Sigs a) => Patch Sig a -> SE a-atMonoSharp = atMono' ChnAll 0.005 0.05+-- | 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+            where+                getArg+                    | monoSyntHold spec = holdMsgTemp tm chn port+                    | otherwise         = monoMsgTemp tm chn port rel --- | Simplified monosynth patch (sharp attack and transitions) with custom temperament.-atMonoSharpTemp :: (SigSpace a, Sigs a) => Temp -> Patch Sig a -> SE a-atMonoSharpTemp tm = atMonoTemp' tm ChnAll 0.005 0.05+                port = monoSyntSlideTime spec+                rel  = monoSyntRelease spec+                chn  = monoSyntChn spec --- | Monosynth patch. Plays the patch with function @monoMsg@------ > atMonoMidi midiChn portamentotime releaseTime patch-atMono' :: (SigSpace a, Sigs a) => MidiChn -> D -> D -> Patch Sig a -> SE a-atMono' chn port rel a = getPatchFx a =<< patchInstr a =<< monoMsg chn port rel+genMidiSplitPatch :: (SigSpace a, Sigs a) => (Msg -> (D, D)) -> Patch a -> D -> Patch a -> SE a+genMidiSplitPatch midiArg = genSplitPatch $ \chn instr -> midiChn chn (instr . midiArg) --- | Monosynth patch with custom temperament. Plays the patch with function @monoMsgTemp@------ > atMonoMidi midiChn portamentotime releaseTime patch-atMonoTemp' :: (SigSpace a, Sigs a) => Temp -> MidiChn -> D -> D -> Patch Sig a -> SE a-atMonoTemp' tm chn port rel a = getPatchFx a =<< patchInstr a =<< monoMsgTemp tm chn port rel+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)+    where+        leftSplit  dt a = onCondPlay ( `lessThan` dt) a+        rightSplit dt a = onCondPlay ( `greaterThanEquals` dt) a --- | Monosynth patch. Plays the patch with function @holdMsg@------ > atMonoMidi midiChn portamentotime patch-atHoldMidi :: (SigSpace a, Sigs a) => MidiChn -> D -> Patch Sig a -> SE a-atHoldMidi chn port a = getPatchFx a =<< patchInstr a =<< holdMsg chn port+        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)+            SplitPatch a dt b -> liftA2 (+) +                        (onCondPlay (\x -> cond x &&* (x `lessThan` dt)) a) +                        (onCondPlay (\x -> cond x &&* (x `greaterThanEquals` dt)) b) --- | Monosynth patch with custom temperament. Plays the patch with function @holdMsgTemp@------ > atMonoMidi midiChn portamentotime patch-atHoldMidiTemp :: (SigSpace a, Sigs a) => Temp -> MidiChn -> D -> Patch Sig a -> SE a-atHoldMidiTemp tm chn port a = getPatchFx a =<< patchInstr a =<< holdMsgTemp tm chn port+restrictPolyInstr :: (Sigs a) => (D -> BoolD) -> (CsdNote D -> SE a) -> CsdNote D -> SE a+restrictPolyInstr cond instr note@(amp, cps) = do+    ref <- newRef 0+    whenElseD (cond cps) +        (writeRef ref =<< instr note)+        (writeRef ref 0)+    readRef ref  -------------------------------------------------------------- -- sched --- | Plays a patch with event stream. Supplies a custom value for mixing effects (dry/wet).--- The 0 is a dry signal, the 1 is a wet signal.-atSched :: (SigSpace a, Sigs a) => Patch D a -> Evt (Sco (CsdNote D)) -> SE a-atSched p evt = getPatchFx p $ sched (patchInstr p) evt+-- | 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 -atSchedUntil :: (SigSpace a, Sigs a) => Patch D a -> Evt (CsdNote D) -> Evt b -> SE a-atSchedUntil p evt stop = getPatchFx p $ schedUntil (patchInstr p) evt stop +-- | 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+ -------------------------------------------------------------- -- sco  --- | Plays a patch with scores. Supplies a custom value for mixing effects (dry/wet).--- The 0 is a dry signal, the 1 is a wet signal.-atSco :: (SigSpace a, Sigs a) => Patch D a -> Sco (CsdNote D) -> Sco (Mix a)-atSco p sc = eff (getPatchFx p) $ sco (patchInstr p) sc	+-- | 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  ---------------------------------------------------------------+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 +        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 ]++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++--    getPatchFx a =<< midi (patchInstr a . ampCps)    ++-- | Transform  the spec for monophonic patch.+onMonoSyntSpec :: (MonoSyntSpec -> MonoSyntSpec) -> Patch a -> Patch a+onMonoSyntSpec f x = case x of+    MonoSynt spec instr -> MonoSynt (f spec) instr+    PolySynt spec instr -> PolySynt spec instr+    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)++-- | Sets the midi channel for all instruments in the patch.+setMidiChn :: MidiChn -> Patch a -> Patch a+setMidiChn chn x = case x of+    MonoSynt spec instr -> MonoSynt (spec { monoSyntChn = chn }) instr+    PolySynt spec instr -> PolySynt (spec { polySyntChn = chn }) instr+    FxChain fxs p -> FxChain fxs $ go p +    LayerPatch xs -> LayerPatch $ mapSnd go xs+    SplitPatch a cps b -> SplitPatch (go a) cps (go b)+    where go = setMidiChn chn+++-- | Sets the monophonic to sharp transition and quick release.+setMonoSharp :: Patch a -> Patch a+setMonoSharp = onMonoSyntSpec (\x -> x { monoSyntSlideTime = 0.005, monoSyntRelease = 0.05 })++-- | Sets the monophonic patch to hold mode. All notes are held.+setMonoHold :: Patch a -> Patch a+setMonoHold = onMonoSyntSpec (\x -> x { monoSyntHold = True })++-- | 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))+ -- | Adds an effect to the patch's instrument.-addInstrFx :: Fx b -> Patch a b -> Patch a b-addInstrFx f p = p { patchInstr = f <=< patchInstr p }+addInstrFx :: Fx a -> Patch a -> Patch a+addInstrFx f p = mapPatchInstr (\instr -> f <=< instr) p  -- | Appends an effect before patch's effect.-addPreFx :: DryWetRatio -> Fx b -> Patch a b -> Patch a b-addPreFx dw f p = p { patchFx = patchFx p ++ [FxSpec dw f] }+addPreFx :: DryWetRatio -> Fx a -> Patch a -> Patch a+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)+    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]  -- | Appends an effect after patch's effect.-addPostFx :: DryWetRatio -> Fx b -> Patch a b -> Patch a b-addPostFx dw f p = p { patchFx = FxSpec dw f : patchFx p }------------------------------------------------------------------+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+    where fxSpec = FxSpec dw f --- | Plays the patch when confition is true otherwise it produces silence.-patchWhen :: Sigs b => BoolSig -> Patch a b -> Patch a b-patchWhen cond p = p -	{ patchInstr = playWhen cond (patchInstr p)-	, patchFx    = fmap (mapFun $ playWhen cond) (patchFx p) }-	where mapFun f x = x { fxFun = f $ fxFun x }+-------------------------------------------------------------- +-- | 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)+    LayerPatch xs       -> LayerPatch $ mapSnd rec xs+    SplitPatch a cps b  -> SplitPatch (rec a) cps (rec b)        +    where +        rec = patchWhen cond+        mapFun f x = x { fxFun = f $ fxFun x } -mixInstr :: (SigSpace b, Num b) => Sig -> Patch a b -> Patch a b -> Patch a b-mixInstr k f p = p { patchInstr = \x -> liftA2 (+) (patchInstr p x) (fmap (mul k) (patchInstr f x)) }+-- | Mix two patches together.+mixInstr :: (SigSpace b, Num b) => Sig -> Patch b -> Patch b -> Patch b+mixInstr k f p = LayerPatch [(k, f), (1, p)]  ------------------------------------------------ -- pads -harmonPatch :: (Fractional a, SigSpace b, Sigs b) => [Sig] -> [a] -> Patch a b -> Patch a b-harmonPatch amps freqs p = p { -		patchInstr = \(amp, cps) -> fmap sum $ zipWithM (\a f -> fmap (mul a) $ patchInstr p (amp, cps * f)) amps freqs	-	}+-- | Harmnoic series of patches.+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  -deepPad :: (Fractional a, SigSpace b, Sigs b) => Patch a b -> Patch a b+-- | 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 monoTfm polyTfm x = case x of+    MonoSynt spec instr -> MonoSynt spec $ monoTfm instr+    PolySynt spec instr -> PolySynt spec $ polyTfm instr+    FxChain fxs p -> FxChain fxs $ rec p+    SplitPatch a cps b -> SplitPatch (rec a) cps (rec b)+    LayerPatch xs -> LayerPatch $ mapSnd rec xs+    where+        rec = tfmInstr monoTfm polyTfm+        mapSnd f = fmap (second f) + ------------------------------------------------ -- revers @@ -282,19 +502,18 @@ ------------------------------------------------ -- sound font patch +-- | Sound font patch with a bit of reverb. sfPatchHall :: Sf -> Patch2-sfPatchHall sf = Patch -    { patchInstr = \(amp, cps) -> return $ sfCps sf 0.5 amp cps-    , patchFx    = [(FxSpec 0.25 (return . smallHall2))] }+sfPatchHall = withSmallHall . sfPatch +-- | Sound font patch. sfPatch :: Sf -> Patch2-sfPatch sf = Patch -    { patchInstr = \(amp, cps) -> return $ sfCps sf 0.5 amp cps-    , patchFx    = [] }+sfPatch sf = PolySynt def $ \(amp, cps) -> return $ sfCps sf 0.5 amp cps  ------------------------------------------------ -- Csound API + -- | Triggers patch with Csound API. -- It creates a named instruement with given name (first argument). --@@ -302,6 +521,53 @@ -- -- > i "givenName" 1 pitchKey volumeKey     -- note on -- > i "givenName" 0 pitchKey volumeKey     -- note off+patchByNameMidi :: (SigSpace a, Sigs a) => String -> Patch a -> SE a+patchByNameMidi = genPatchByNameMidi cpsmidinn cpsmidinn++-- | Triggers patch with Csound API.+-- It creates a named instruement with given name (second argument).+-- It behaves like the function @patchByNameMidi@ but we can specify custom temperament.+patchByNameMidiTemp :: (SigSpace a, Sigs a) => Temp -> String -> Patch a -> SE a+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)+            where+                convert (vol, pch) = (vel2ampSig vol, monoKey2cps pch)+                portTime = monoSyntSlideTime spec+                relTime  = monoSyntRelease    spec++        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 polySynt a cps b++vel2amp :: D -> D+vel2amp vol = ((vol / 64) ** 2) / 2++vel2ampSig :: Sig -> Sig+vel2ampSig vol = ((vol / 64) ** 2) / 2++{-++-- | Triggers patch with Csound API.+-- It creates a named instruement with given name (first argument).+--+-- It simulates the midi-like instrument. Notes are encoded with messages:+--+-- > i "givenName" 1 pitchKey volumeKey     -- note on+-- > i "givenName" 0 pitchKey volumeKey     -- note off patchByNameMidi :: (SigSpace a, Sigs a) => String -> Patch D a -> SE a patchByNameMidi = genPatchByNameMidi cpsmidinn @@ -368,3 +634,5 @@  vel2ampSig :: Sig -> Sig vel2ampSig vol = ((vol / 64) ** 2) / 2++-}

@@ -11,6 +11,10 @@     rndOsc, rndOscBy, rndSaw, rndIsaw, rndPulse, rndSqr, rndPw, rndTri, rndRamp, rndBlosc,         rndPhs, +    -- ** Raw analog waves (no band limiting)+    -- | Analogue-like waves with no band-limiting. Can be useful for LFOs.+    rawTri, rawSaw, rawSqr, rawPw, rawTri', rawSaw', rawSqr', rawPw', rndRawTri, rndRawSaw, rndRawSqr, rndRawPw,+     -- * Unipolar     unipolar, bipolar, uosc, uoscBy, usaw, uisaw, upulse, usqr, upw, utri, uramp, ublosc, @@ -20,6 +24,10 @@     -- ** With random phase     urndOsc, urndOscBy, urndSaw, urndIsaw, urndPulse, urndSqr, urndPw, urndTri, urndRamp, urndBlosc,         +    -- ** Raw analog waves (no band limiting)+    -- | Analogue-like waves with no band-limiting. Can be useful for LFOs.+    urawTri, urawSaw, urawSqr, urawPw, urawTri', urawSaw', urawSqr', urawPw', urndRawTri, urndRawSaw, urndRawSqr, urndRawPw,+     -- * Noise     rndh, urndh, rndi, urndi, white, pink, @@ -44,7 +52,7 @@  import Csound.Typed import Csound.Typed.Opcode hiding (lfo)-import Csound.Tab(sine, cosine, sines4)+import Csound.Tab(setSize, elins, sine, cosine, sines4, triTab, pwTab, sawTab, sqrTab) import Csound.SigSpace  -- | A pure tone (sine wave).@@ -181,7 +189,7 @@ -------------------------------------------------------------------------- -- random phase --- | Generic random phase oscil+-- | Generic random smoothTypephase oscil rndPhs :: (D -> Sig -> Sig) -> (Sig -> SE Sig) rndPhs f cps = fmap (\x -> f x cps) $ rnd 1 @@ -196,6 +204,9 @@ rndRamp a = rndPhs (ramp' a) rndBlosc a = rndPhs (blosc' a) +--------------------------------------------------------------------------+-- unipolar random phase+ urndOsc = rndPhs uosc' urndOscBy a = rndPhs (uoscBy' a) urndSaw = rndPhs usaw' @@ -207,8 +218,6 @@ urndRamp a = rndPhs (uramp' a) urndBlosc a = rndPhs (ublosc' a) ------------------------------------------------------------------------------ unipolar random phase  -------------------------------------------------------------------------- -- noise@@ -340,3 +349,83 @@ -- | Gbuz with phase gbuz' :: D -> (Sig, Sig) -> Sig -> Sig -> Sig gbuz' phs hs hratio x = gbuz hs hratio x `withD` phs++---------------------------------------------+-- raw waveforms++-- bipolar++rawTri :: Sig -> Sig+rawTri = oscBy triTab++rawSaw :: Sig -> Sig+rawSaw = oscBy sawTab++rawSqr :: Sig -> Sig+rawSqr = oscBy sqrTab++rawPw :: Double -> Sig -> Sig+rawPw duty = oscBy (pwTab duty)++rawTri' :: D -> Sig -> Sig+rawTri' = oscBy' triTab++rawSaw' :: D -> Sig -> Sig+rawSaw' = oscBy' sawTab++rawSqr' :: D -> Sig -> Sig+rawSqr' = oscBy' sqrTab++rawPw' :: Double -> D -> Sig -> Sig+rawPw' duty = oscBy' (pwTab duty)++rndRawTri :: Sig -> SE Sig+rndRawTri = rndOscBy triTab++rndRawSaw :: Sig -> SE Sig+rndRawSaw = rndOscBy sawTab++rndRawSqr :: Sig -> SE Sig+rndRawSqr = rndOscBy sqrTab++rndRawPw :: Double -> Sig -> SE Sig+rndRawPw duty = rndOscBy (pwTab duty)++-- unipolar++urawTri :: Sig -> Sig+urawTri = uoscBy triTab++urawSaw :: Sig -> Sig+urawSaw = uoscBy sawTab++urawSqr :: Sig -> Sig+urawSqr = uoscBy sqrTab++urawPw :: Double -> Sig -> Sig+urawPw duty = uoscBy (pwTab duty)++urawTri' :: D -> Sig -> Sig+urawTri' = uoscBy' triTab++urawSaw' :: D -> Sig -> Sig+urawSaw' = uoscBy' sawTab++urawSqr' :: D -> Sig -> Sig+urawSqr' = uoscBy' sqrTab++urawPw' :: Double -> D -> Sig -> Sig+urawPw' duty = uoscBy' (pwTab duty)++urndRawTri :: Sig -> SE Sig+urndRawTri = urndOscBy triTab++urndRawSaw :: Sig -> SE Sig+urndRawSaw = urndOscBy sawTab++urndRawSqr :: Sig -> SE Sig+urndRawSqr = urndOscBy sqrTab++urndRawPw :: Double -> Sig -> SE Sig+urndRawPw duty = urndOscBy (pwTab duty)+

@@ -0,0 +1,272 @@+-- | Oscillators with hard and soft sync+module Csound.Air.Wave.Sync(+	-- * Hard sync+    SyncSmooth(..),++    sawSync, isawSync, pulseSync, sqrSync, triSync, bloscSync,+    sawSync', isawSync', pulseSync', sqrSync', triSync', bloscSync',++    -- ** With random phase+    rndSawSync, rndIsawSync, rndPulseSync, rndSqrSync, rndTriSync, rndBloscSync,++    -- ** With absolute slave frequencies+    sawSyncAbs, isawSyncAbs, pulseSyncAbs, sqrSyncAbs, triSyncAbs, bloscSyncAbs,+    sawSyncAbs', isawSyncAbs', pulseSyncAbs', sqrSyncAbs', triSyncAbs', bloscSyncAbs',+++    -- ** With absolute custom smooth mode+    sawSyncBy, isawSyncBy, pulseSyncBy, sqrSyncBy, triSyncBy, bloscSyncBy,+    sawSyncBy', isawSyncBy', pulseSyncBy', sqrSyncBy', triSyncBy', bloscSyncBy',+    sawSyncAbsBy, isawSyncAbsBy, pulseSyncAbsBy, sqrSyncAbsBy, triSyncAbsBy, bloscSyncAbsBy,+    sawSyncAbsBy', isawSyncAbsBy', pulseSyncAbsBy', sqrSyncAbsBy', triSyncAbsBy', bloscSyncAbsBy',++    -- ** Raw (non-bandlimited) shapes++    -- *** With relative slave frequency+    rawTriSync, rawSqrSync, rawSawSync, rawPwSync,+    rawTriSyncBy, rawSqrSyncBy, rawSawSyncBy, rawPwSyncBy,++    -- *** With absolute slave frequency+	rawTriSyncAbs, 	rawSqrSyncAbs, rawSawSyncAbs, rawPwSyncAbs,+    rawTriSyncAbsBy, rawSqrSyncAbsBy, rawSawSyncAbsBy, rawPwSyncAbsBy,+    +   -- * Soft sync++   -- *** With relative slave frequency+    softSync, rawSoftSync, softSyncBy, rawSoftSyncBy,++    -- *** With absolute slave frequency+    softSyncAbs, rawSoftSyncAbs, softSyncAbsBy, rawSoftSyncAbsBy+) where++import Data.Default++import Csound.Typed+import Csound.Typed.Opcode hiding (lfo)+import Csound.Tab+import Csound.SigSpace++import Csound.Air.Wave++--------------------------------------------------------------------------+-- hard sync random phase++rndPhsSync :: (D -> Sig -> Sig -> Sig) -> (Sig -> Sig -> SE Sig)+rndPhsSync f ratio cps = fmap (\x -> f x ratio cps) $ rnd 1++-- | Hard sync with saw waveform and randomized phase.+rndSawSync :: Sig -> Sig -> SE Sig +rndSawSync = rndPhsSync sawSync'++-- | Hard sync with integral saw waveform and randomized phase.+rndIsawSync :: Sig -> Sig -> SE Sig+rndIsawSync = rndPhsSync isawSync'++-- | Hard sync with pulse waveform and randomized phase.+rndPulseSync :: Sig -> Sig -> SE Sig +rndPulseSync = rndPhsSync pulseSync'++-- | Hard sync with square waveform and randomized phase.+rndSqrSync :: Sig -> Sig -> SE Sig +rndSqrSync = rndPhsSync sqrSync'++-- | Hard sync with triangle waveform and randomized phase.+rndTriSync :: Sig -> Sig -> SE Sig+rndTriSync = rndPhsSync triSync'++-- | Hard sync with band-limited table waveform waveform and randomized phase.+rndBloscSync :: Tab -> Sig -> Sig -> SE Sig +rndBloscSync t = rndPhsSync (bloscSync' t)++-------------------------------------------------------------------------+-- Hard-sync for simple non-bandlimited waveforms++-- | Hard-sync with non-bandlimited triangle wave.+rawTriSyncBy :: SyncSmooth -> Sig -> Sig -> Sig+rawTriSyncBy = oscSyncBy triTab++-- | Hard-sync with non-bandlimited square wave.+rawSqrSyncBy :: SyncSmooth -> Sig -> Sig -> Sig+rawSqrSyncBy = oscSyncBy sqrTab++-- | Hard-sync with non-bandlimited sawtooth wave.+rawSawSyncBy :: SyncSmooth -> Sig -> Sig -> Sig+rawSawSyncBy = oscSyncBy sawTab++-- | Hard-sync with non-bandlimited pulse-width wave.+rawPwSyncBy  :: Double -> SyncSmooth -> Sig -> Sig -> Sig+rawPwSyncBy duty = oscSyncBy (pwTab duty)++-------------------------------------------------------------------------++-- | Hard-sync with non-bandlimited triangle wave.+rawTriSync :: Sig -> Sig -> Sig+rawTriSync = rawTriSyncBy def++-- | Hard-sync with non-bandlimited square wave.+rawSqrSync :: Sig -> Sig -> Sig+rawSqrSync = rawSqrSyncBy def++-- | Hard-sync with non-bandlimited sawtooth wave.+rawSawSync :: Sig -> Sig -> Sig+rawSawSync = rawSawSyncBy def++-- | Hard-sync with non-bandlimited pulse-width wave.+rawPwSync  :: Double -> Sig -> Sig -> Sig+rawPwSync duty = rawPwSyncBy duty def++-------------------------------------------------------------------------+-- Hard-sync for simple non-bandlimited waveforms with absolute slave frequency++-- | Hard-sync with non-bandlimited triangle wave.+rawTriSyncAbsBy :: SyncSmooth -> Sig -> Sig -> Sig+rawTriSyncAbsBy = oscSyncAbsBy triTab++-- | Hard-sync with non-bandlimited square wave.+rawSqrSyncAbsBy :: SyncSmooth -> Sig -> Sig -> Sig+rawSqrSyncAbsBy = oscSyncAbsBy sqrTab++-- | Hard-sync with non-bandlimited sawtooth wave.+rawSawSyncAbsBy :: SyncSmooth -> Sig -> Sig -> Sig+rawSawSyncAbsBy = oscSyncAbsBy sawTab++-- | Hard-sync with non-bandlimited pulse-width wave.+rawPwSyncAbsBy  :: Double -> SyncSmooth -> Sig -> Sig -> Sig+rawPwSyncAbsBy duty = oscSyncAbsBy (pwTab duty)++-------------------------------------------------------------------------++-- | Hard-sync with non-bandlimited triangle wave.+rawTriSyncAbs :: Sig -> Sig -> Sig+rawTriSyncAbs = rawTriSyncAbsBy def++-- | Hard-sync with non-bandlimited square wave.+rawSqrSyncAbs :: Sig -> Sig -> Sig+rawSqrSyncAbs = rawSqrSyncAbsBy def++-- | Hard-sync with non-bandlimited sawtooth wave.+rawSawSyncAbs :: Sig -> Sig -> Sig+rawSawSyncAbs = rawSawSyncAbsBy def++-- | Hard-sync with non-bandlimited pulse-width wave.+rawPwSyncAbs  :: Double -> Sig -> Sig -> Sig+rawPwSyncAbs duty = rawPwSyncAbsBy duty def+++-------------------------------------------------------------------------++oscSyncBy :: Tab -> SyncSmooth -> Sig -> Sig -> Sig+oscSyncBy tab smoothType cpsRatio cps = oscSyncAbsBy tab smoothType (cpsRatio * cps) cps++-- | Hard-sync with non-bandlimited waves.+oscSyncAbsBy :: Tab -> SyncSmooth -> Sig -> Sig -> Sig+oscSyncAbsBy tab smoothType slaveCps cps = (\smoothFun -> syncOsc smoothFun tab (ar slaveCps) (ar cps)) $ case smoothType of+    RawSync      -> (\_ _ -> 1)                   +    SawSync      -> (\amaster _ -> (1 - amaster)) +    TriSync      -> (const $ readSync uniTriTab)  +    TrapSync     -> (const $ readSync uniTrapTab) +    UserSync gen -> (const $ readSync gen)        +    where+        readSync ft async = table3 async ft `withD` 1        +        +uniSawTab  = setSize 4097 $ elins [1, 0]+uniTriTab  = setSize 4097 $ elins [0, 1, 0]+uniTrapTab = setSize 4097 $ elins [1, 1, 0]++syncOsc smoothFun ftab slaveCps cps = dcblock $ aout+    where+        (amaster, asyncMaster) = syncphasor cps 0+        (aslave,  asyncSlave)  = syncphasor slaveCps asyncMaster+        aosc = table3 aslave ftab `withD` 1+        aout = aosc * smoothFun amaster asyncMaster++----------------------------------------------------------+-- Soft-sync++-- | Soft sync with given waveform (with band-limited square wave for switch).+-- The soft sync amount is controlled with ratio between master and slave frequencies.+--+-- > softSync slaveWave ratio masterWave+softSync :: SigSpace a => (Sig -> a) -> Sig -> (Sig -> a)+softSync = softSyncBy def++-- | Soft sync with given waveform (with raw square wave for switch). It's faster than `softSync`+-- The soft sync amount is controlled with ratio between master and slave frequencies.+--+-- > rawSoftSync slaveWave ratio masterWave+rawSoftSync :: SigSpace a => (Sig -> a) -> Sig -> (Sig -> a)+rawSoftSync = rawSoftSyncBy def++-- | Soft sync with given waveform (with band-limited square wave for switch).+-- The soft sync amount is controlled with ratio between master and slave frequencies.+-- With first argument we can specify the smoothness algorithm.+--+-- > softSyncBy spec slaveWave ratio masterWave+--+softSyncBy :: SigSpace a => SyncSmooth -> (Sig -> a) -> Sig -> (Sig -> a)+softSyncBy = genSoftSync sqr blosc++-- | Soft sync with given waveform (with raw square wave for switch). It's faster than `softSyncBy`+-- The soft sync amount is controlled with ratio between master and slave frequencies.+-- With first argument we can specify the smoothness algorithm.+--+-- > rawSoftSyncBy spec slaveWave ratio masterWave+--+rawSoftSyncBy :: SigSpace a => SyncSmooth -> (Sig -> a) -> Sig -> (Sig -> a)+rawSoftSyncBy = genSoftSync rawSqr oscBy++----------------------------------------------------------+++-- | Soft sync with given waveform (with band-limited square wave for switch).+-- The soft sync amount is controlled with absolute frequency of the slave oscillator.+--+-- > softSyncAbs slaveWave ratio masterWave+softSyncAbs :: SigSpace a => (Sig -> a) -> Sig -> (Sig -> a)+softSyncAbs = softSyncAbsBy def++-- | Soft sync with given waveform (with raw square wave for switch). It's faster than `softSyncAbs`+-- The soft sync amount is controlled with absolute frequency of the slave oscillator.+--+-- > rawSoftSyncAbs slaveWave ratio masterWave+rawSoftSyncAbs :: SigSpace a => (Sig -> a) -> Sig -> (Sig -> a)+rawSoftSyncAbs = rawSoftSyncAbsBy def+++-- | Soft sync with given waveform (with band-limited square wave for switch).+-- The soft sync amount is controlled with absolute frequency of the slave oscillator.+-- With first argument we can specify the smoothness algorithm.+--+-- > softSyncAbsBy spec slaveWave ratio masterWave+--+softSyncAbsBy :: SigSpace a => SyncSmooth -> (Sig -> a) -> Sig -> (Sig -> a)+softSyncAbsBy = genSoftSyncAbs sqr blosc++-- | Soft sync with given waveform (with raw square wave for switch). It's faster than `softSyncAbsBy`+-- The soft sync amount is controlled with absolute frequency of the slave oscillator.+-- With first argument we can specify the smoothness algorithm.+--+-- > rawSoftSyncBy spec slaveWave ratio masterWave+--+rawSoftSyncAbsBy :: SigSpace a => SyncSmooth -> (Sig -> a) -> Sig -> (Sig -> a)+rawSoftSyncAbsBy = genSoftSyncAbs rawSqr oscBy++----------------------------------------------------------++genSoftSync :: SigSpace a => (Sig -> Sig) -> (Tab -> Sig -> Sig) -> SyncSmooth -> (Sig -> a) -> Sig -> (Sig -> a)+genSoftSync cpsSwitchWave smoothTabWave smoothType wave ratio cps = genSoftSyncAbs cpsSwitchWave smoothTabWave smoothType wave (ratio * cps) cps++genSoftSyncAbs :: SigSpace a => (Sig -> Sig) -> (Tab -> Sig -> Sig) -> SyncSmooth -> (Sig -> a) -> Sig -> (Sig -> a)+genSoftSyncAbs cpsSwitchWave smoothTabWave smoothType wave slaveCps cps = flip mul rawSync $ case smoothType of+    RawSync  -> 1+    SawSync  -> smoothTabWave uniSawTab cps+    TriSync  -> smoothTabWave uniTriTab cps+    TrapSync -> smoothTabWave uniTrapTab cps+    UserSync t -> smoothTabWave t cps+    where +        rawSync = wave (ar $ ar slaveCps * (ar $ cpsSwitchWave cps)) ++------------------------------------------------------+-- PW and Ramp hard sync++-- pwSync 

@@ -0,0 +1,48 @@+-- | The Cab is a monad for Cabbage markup language. +-- The markup description can be constructed in the same way as blaze-html markup.+--+-- We use monadic sequencing for sequencing of markup elements.+--+-- An example:+--+-- > import Csound.Base+-- > import qualified Csound.Cabbage as C+-- > +-- > ui = do+-- >     C.cabbage $ do+-- >         C.form $ do+-- >            C.size 100 100+-- >            C.pluginid "plugin"+-- >        C.button $ do+-- >            C.bounds 10 10 80 80+-- >            C.channel "button"+-- >            C.text1 "Click me"+-- >             C.colour0 (C.Rgb 150 30 0)+-- >             C.colour1 (C.Rgb 30 150 12) +-- >     res <- chnCtrlGet "button"  +-- >     return res+-- > +-- > main = dac $ do+-- >    btn <- ui+-- >    return $ btn * osc 220+--+-- We can read a complete tutorial on how to create Cabbage plugins at the guide:+-- <https://github.com/spell-music/csound-expression/blob/master/tutorial/chapters/CabbageTutorial.md>+module Csound.Cabbage(+    Cab, CabProp, Col(..), cabbage,++    -- * Widgets+    button, filebutton, infobutton, checkbox, combobox, csoundoutput, encoder, gentable, +    hrange, vrange, form, groupbox, image, keyboard, label, hslider, vslider,+    rslider, soundfiler, signaldisplay, textbox, texteditor, xypad,++    -- * Properties+    bounds, channel, text1, text2, value, colour, colour0, colour1, backgroundcolour, textcolour, trackercolour, outlinecolour, +    fontcolour, fontcolour0, fontcolour1, latched, identchannel, rotate, alpha, visible, caption, widgetarray, popuptext, +    active, svgfile, populate, mode, file, shape, corners, channeltype, align, sliderincr, max, min, textbox', trackerthickness,+    linethickness, range, range2, size, pluginid, guirefresh, plant, child, show, middlec, keywidth, scrollbars, fontstyle,+    scrubberpos, zoom, displaytype, updaterate, wrap+) where++import Prelude hiding (show, min, max)+import Csound.Typed.Gui.Cab

@@ -35,7 +35,10 @@     dac, dacBy, vdac, vdacBy,      -- * Render and run-    csd, csdBy+    csd, csdBy,++    -- * Render and run with cabbage+    runCabbage, runCabbageBy ) where  import System.Process@@ -46,7 +49,7 @@ import Csound.Typed import Csound.Control.Gui -import Csound.Options(setSilent, setDac)+import Csound.Options(setSilent, setDac, setCabbage)  render :: Sigs a => Options -> SE a -> IO String render = renderOutBy @@ -69,12 +72,21 @@ instance RenderCsd Sig4 where     renderCsdBy opt a = render opt (return a) +instance RenderCsd (Sig2, Sig2) where+    renderCsdBy opt a = render opt (return a)+ instance RenderCsd Sig6 where     renderCsdBy opt a = render opt (return a) +instance RenderCsd (Sig2, Sig2, Sig2) where+    renderCsdBy opt a = render opt (return a)+ instance RenderCsd Sig8 where     renderCsdBy opt a = render opt (return a) +instance RenderCsd (Sig2, Sig2, Sig2, Sig2) where+    renderCsdBy opt a = render opt (return a)+ instance RenderCsd (Sig8, Sig8) where       renderCsdBy opt a = render opt (return a) @@ -90,12 +102,21 @@ instance RenderCsd (SE Sig4) where     renderCsdBy opt a = render opt a +instance RenderCsd (SE (Sig2, Sig2)) where+    renderCsdBy opt a = render opt a+ instance RenderCsd (SE Sig6) where     renderCsdBy opt a = render opt a +instance RenderCsd (SE (Sig2, Sig2, Sig2)) where+    renderCsdBy opt a = render opt a+ instance RenderCsd (SE Sig8) where     renderCsdBy opt a = render opt a +instance RenderCsd (SE (Sig2, Sig2, Sig2, Sig2)) where+    renderCsdBy opt a = render opt a+ instance RenderCsd (SE (Sig8, Sig8)) where       renderCsdBy opt a = render opt a @@ -111,12 +132,21 @@ instance (Sigs a) => RenderCsd (a -> Sig4) where     renderCsdBy opt f = renderEffBy opt (return . f) +instance (Sigs a) => RenderCsd (a -> (Sig2, Sig2)) where+    renderCsdBy opt f = renderEffBy opt (return . f)+ instance (Sigs a) => RenderCsd (a -> Sig6) where     renderCsdBy opt f = renderEffBy opt (return . f) +instance (Sigs a) => RenderCsd (a -> (Sig2, Sig2, Sig2)) where+    renderCsdBy opt f = renderEffBy opt (return . f)+ instance (Sigs a) => RenderCsd (a -> Sig8) where     renderCsdBy opt f = renderEffBy opt (return . f) +instance (Sigs a) => RenderCsd (a -> (Sig2, Sig2, Sig2, Sig2)) where+    renderCsdBy opt f = renderEffBy opt (return . f)+ instance (Sigs a) => RenderCsd (a -> (Sig8, Sig8)) where     renderCsdBy opt f = renderEffBy opt (return . f) @@ -147,6 +177,29 @@                 panel gui                 return asig +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++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                ++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@@ -160,6 +213,7 @@                 (gui, asig) <- a                 panel gui                 asig+ instance RenderCsd (Source (SE Sig4)) where     renderCsdBy opt a = renderCsdBy opt res         where res = do@@ -167,6 +221,30 @@                 panel gui                 asig +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++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                ++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+ instance RenderCsd (Source ()) where     renderCsdBy opt src = renderCsdBy opt $ do         (ui, _) <- src        @@ -290,3 +368,17 @@             E.UserInterrupt -> terminateProcess pid >> E.throw x             e               -> E.throw e +----------------------------------------------------------++-- | Runs the csound files with cabbage engine. +-- It invokes the Cabbage command line utility and setts all default cabbage flags.+runCabbage :: (RenderCsd a) => a -> IO ()+runCabbage = runCabbageBy def++-- | Runs the csound files with cabbage engine with user defined options. +-- It invokes the Cabbage command line utility and setts all default cabbage flags.+runCabbageBy :: (RenderCsd a) => Options -> a -> IO ()+runCabbageBy opt' a = do+    writeCsdBy opt "tmp.csd" a+    runWithUserInterrupt $ "Cabbage " ++ "tmp.csd" +    where opt = opt' <> setCabbage

@@ -3,10 +3,13 @@      -- * Shortcuts     setDur,-    setRates, setBufs, setGain, setJack,+    setRates, setBufs, setGain, +    setJack, setAlsa, setCoreAudio, setMme,     setOutput, setInput,      setDac, setAdc, setDacBy, setAdcBy, setThru,     setSilent, setMidiDevice, setMa,+    setMessageLevel, noTrace,+    setCabbage,      -- * Flags     -- | Csound's command line flags. See original documentation for @@ -34,6 +37,7 @@     Config(..) ) where +import Data.Monoid import Data.Default import Csound.Typed @@ -58,7 +62,15 @@ setJack :: String -> Options setJack name = def { csdFlags = def { rtaudio = Just $ Jack name "input" "output" } } +setCoreAudio :: Options+setCoreAudio = def { csdFlags = def { rtaudio = Just $ CoreAudio } } +setAlsa :: Options+setAlsa = def { csdFlags = def { rtaudio = Just $ Alsa } }++setMme :: Options+setMme = def { csdFlags = def { rtaudio = Just $ Mme } }+ setDac :: Options setDac = setDacBy "" @@ -97,3 +109,15 @@ -- | Sets midi device to all. setMa :: Options setMa = setMidiDevice "a"++setMessageLevel :: Int -> Options+setMessageLevel n = def { csdFlags = def { displays = def { messageLevel = Just n }}}++noTrace :: Options+noTrace = setMessageLevel 0++---------------------------------------------++setCabbage :: Options+setCabbage = setRates 48000 64 <> setNoRtMidi <> setMidiDevice "0"+    where setNoRtMidi = def { csdFlags = def { rtmidi = Just NoRtmidi, audioFileOutput = def { nosound = True } }} 

@@ -5,7 +5,7 @@         FlexibleInstances,          FlexibleContexts #-} module Csound.SigSpace(-    SigSpace(..), BindSig(..), mul, on, uon, At(..), MixAt(..), bat, bmixAt,+    SigSpace(..), BindSig(..), mul, mul', on, uon, At(..), MixAt(..), bat, bmixAt,     cfd, cfd4, cfds, cfdSpec, cfdSpec4, cfdsSpec,      wsum         ) where@@ -28,6 +28,10 @@ -- | 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 

@@ -22,14 +22,15 @@      -- * Read from files     WavChn(..), Mp3Chn(..),-    wavs, mp3s,+    wavs, wavLeft, wavRight, mp3s, mp3Left, mp3Right, mp3m,      -- * (In)Harmonic series     PartialStrength, PartialNumber, PartialPhase, PartialDC,     sines, sines3, sines2, sines1, sines4, buzzes, bwSines, bwOddSines,      -- ** Special cases-    sine, cosine, sigmoid, tanhSigmoid,+    sine, cosine, sigmoid, sigmoidRise, sigmoidFall, tanhSigmoid,+    triTab, sawTab, sqrTab, pwTab,      -- * Interpolants         -- | All funtions have the same shape of arguments:@@ -91,10 +92,16 @@     idPadsynth, idTanh, idExp, idSone, idFarey, idWave,      -- * Tabular opcodes-    tablewa, sec2rel,+    sec2rel,      -- * Tables of tables-    TabList, tabList, fromTabList, fromTabListD+    TabList, tabList, fromTabList, fromTabListD,++    -- * Mic table functions+    tablewa, tablew, readTab, readTable, readTable3, readTablei,++    -- ** Table Reading with Dynamic Selection+    tableikt, tablekt, tablexkt ) where  import Control.Applicative hiding ((<*))@@ -182,6 +189,14 @@ instance Default Mp3Chn where     def = Mp3All +-- | Reads left channel of audio-file+wavLeft :: String -> Tab+wavLeft file = wavs file 0 WavLeft++-- | Reads right channel of audio-file+wavRight :: String -> Tab+wavRight file = wavs file 0 WavRight+ -- | Loads mp3 file to table: -- -- > mp3s fileName skipTime format@@ -195,6 +210,18 @@     (FileAccess filename [skiptime, format])     where format = fromIntegral $ fromMp3Chn channel +-- | Reads left channel of mp3-file+mp3Left :: String -> Tab+mp3Left file = mp3s file 0 Mp3Left++-- | Reads right channel of mp3-file+mp3Right :: String -> Tab+mp3Right file = mp3s file 0 Mp3Right++-- | Reads mono of mp3-file+mp3m :: String -> Tab+mp3m file = mp3s file 0 Mp3Mono+ interp :: Int -> [Double] -> Tab interp genId as = preTab def genId (ArgsRelative as) @@ -428,6 +455,14 @@ sigmoid :: Tab sigmoid = sines4 [(0.5, 0.5, 270, 0.5)] +-- | Table for sigmoid rise wave.+sigmoidRise :: Tab+sigmoidRise = guardPoint $ sines4 [(0.5, 1, 270, 1)]++-- | Table for sigmoid fall wave.+sigmoidFall :: Tab+sigmoidFall = guardPoint $ sines4 [(0.5, 1, 90, 1)]+ -- | Creates tanh sigmoid. The argument is the radius of teh sigmoid. tanhSigmoid :: Double -> Tab tanhSigmoid x = esplines (fmap tanh [-x, (-x +0.5) .. x]) @@ -628,3 +663,162 @@ -- | Transforms phasor that is defined in seconds to relative phasor that ranges in 0 to 1. sec2rel :: Tab -> Sig -> Sig sec2rel tab x = x / (sig $ ftlen tab / getSampleRate)++-------------------+-- specific tabs++-- | Linear segments that form a singl cycle of triangle wave.+triTab :: Tab+triTab = elins [0, 1, 0, -1, 0]++-- | Linear segments that form a single cycle of sawtooth wave.+sawTab :: Tab+sawTab = elins [1, -1]++-- | 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]++-- | 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]++---------------------------------------------------++-- | +-- tablew — Change the contents of existing function tables. +--+-- This opcode operates on existing function tables, changing their contents. +-- tablew is for writing at k- or at a-rates, with the table number being +-- specified at init time. Using tablew with i-rate signal and index values +-- is allowed, but the specified data will always be written to the function +-- table at k-rate, not during the initialization pass. The valid combinations +-- of variable types are shown by the first letter of the variable names. +--+-- > tablew asig, andx, ifn [, ixmode] [, ixoff] [, iwgmode]+-- > tablew isig, indx, ifn [, ixmode] [, ixoff] [, iwgmode]+-- > tablew ksig, kndx, ifn [, ixmode] [, ixoff] [, iwgmode]+--+-- csound doc: <http://www.csounds.com/manual/html/tablew.html>+tablew ::  Sig -> Sig -> Tab -> SE ()+tablew b1 b2 b3 = SE $ (depT_ =<<) $ lift $ f <$> unSig b1 <*> unSig b2 <*> unTab b3+    where f a1 a2 a3 = opcs "tablew" [(Xr,[Xr,Xr,Ir,Ir,Ir,Ir])] [a1,a2,a3]+++-- | +-- Notice that this function is the same as @tab@, but it wraps the output in the SE-monad.+-- So you can use the @tab@ if your table is read-only and you can use @readTab@ if+-- you want to update the table and the order of read/write operation is important.+--+-- Fast table opcodes.+--+-- Fast table opcodes. Faster than+--     table and+--     tablew because don't+--     allow wrap-around and limit and don't check index validity. Have+--     been implemented in order to provide fast access to+--     arrays. Support non-power of two tables (can be generated by any+--     GEN function by giving a negative length value).+--+-- > kr  tab  kndx, ifn[, ixmode]+-- > ar  tab  xndx, ifn[, ixmode]+--+-- csound doc: <http://www.csounds.com/manual/html/tab.html>+readTab ::  Sig -> Tab -> SE Sig+readTab b1 b2 = fmap ( Sig . return) $ SE $ (depT =<<) $ lift $ f <$> unSig b1 <*> unTab b2+    where f a1 a2 = opcs "tab" [(Kr,[Kr,Ir,Ir]),(Ar,[Xr,Ir,Ir])] [a1,a2]++++-- | +-- Notice that this function is the same as @table@, but it wraps the output in the SE-monad.+-- So you can use the @table@ if your table is read-only and you can use @readTable@ if+-- you want to update the table and the order of read/write operation is important.+--+-- Accesses table values by direct indexing.+--+-- > ares  table  andx, ifn [, ixmode] [, ixoff] [, iwrap]+-- > ires  table  indx, ifn [, ixmode] [, ixoff] [, iwrap]+-- > kres  table  kndx, ifn [, ixmode] [, ixoff] [, iwrap]+--+-- csound doc: <http://www.csounds.com/manual/html/table.html>+readTable :: SigOrD a => a -> Tab -> SE a+readTable b1 b2 = fmap (fromGE . return) $ SE $ (depT =<<) $ lift $ f <$> toGE b1 <*> unTab b2+    where f a1 a2 = opcs "table" [(Ar,[Ar,Ir,Ir,Ir,Ir])+                                 ,(Ir,[Ir,Ir,Ir,Ir,Ir])+                                 ,(Kr,[Kr,Ir,Ir,Ir,Ir])] [a1,a2]++-- | +-- Notice that this function is the same as @tablei@, but it wraps the output in the SE-monad.+-- So you can use the @tablei@ if your table is read-only and you can use @readTablei@ if+-- you want to update the table and the order of read/write operation is important.+--+-- Accesses table values by direct indexing with cubic interpolation.+--+-- > ares  table3  andx, ifn [, ixmode] [, ixoff] [, iwrap]+-- > ires  table3  indx, ifn [, ixmode] [, ixoff] [, iwrap]+-- > kres  table3  kndx, ifn [, ixmode] [, ixoff] [, iwrap]+--+-- csound doc: <http://www.csounds.com/manual/html/table3.html>+readTable3 :: SigOrD a => a -> Tab -> SE a+readTable3 b1 b2 = fmap (fromGE . return) $ SE $ (depT =<<) $ lift $ f <$> toGE b1 <*> unTab b2+    where f a1 a2 = opcs "table3" [(Ar,[Ar,Ir,Ir,Ir,Ir])+                                  ,(Ir,[Ir,Ir,Ir,Ir,Ir])+                                  ,(Kr,[Kr,Ir,Ir,Ir,Ir])] [a1,a2]++-- | +-- Notice that this function is the same as @table3@, but it wraps the output in the SE-monad.+-- So you can use the @table3@ if your table is read-only and you can use @readTable3@ if+-- you want to update the table and the order of read/write operation is important.+--+-- Accesses table values by direct indexing with linear interpolation.+--+-- > ares  tablei  andx, ifn [, ixmode] [, ixoff] [, iwrap]+-- > ires  tablei  indx, ifn [, ixmode] [, ixoff] [, iwrap]+-- > kres  tablei  kndx, ifn [, ixmode] [, ixoff] [, iwrap]+--+-- csound doc: <http://www.csounds.com/manual/html/tablei.html>+readTablei :: SigOrD a => a -> Tab -> SE a+readTablei b1 b2 = fmap (fromGE . return) $ SE $ (depT =<<) $ lift $ f <$> toGE b1 <*> unTab b2+    where f a1 a2 = opcs "tablei" [(Ar,[Ar,Ir,Ir,Ir,Ir])+                                  ,(Ir,[Ir,Ir,Ir,Ir,Ir])+                                  ,(Kr,[Kr,Ir,Ir,Ir,Ir])] [a1,a2]++-- | +-- tableikt — Provides k-rate control over table numbers. +--+-- k-rate control over table numbers. Function tables are read with linear interpolation. +-- The standard Csound opcode tablei, when producing a k- or a-rate result, can only use an init-time variable to select the table number. tableikt accepts k-rate control as well as i-time. In all other respects they are similar to the original opcodes. +--+-- > ares tableikt xndx, kfn [, ixmode] [, ixoff] [, iwrap]+-- > kres tableikt kndx, kfn [, ixmode] [, ixoff] [, iwrap]+--+-- csound doc: <http://www.csounds.com/manual/html/tableikt.html>+tableikt ::  Sig -> Tab -> Sig+tableikt b1 b2 = Sig $ f <$> unSig b1 <*> unTab b2+    where f a1 a2 = opcs "tableikt" [(Ar,[Xr,Kr,Ir,Ir,Ir]),(Kr,[Xr,Kr,Ir,Ir,Ir])] [a1,a2]++-- | +-- tablekt — Provides k-rate control over table numbers. +--+-- k-rate control over table numbers. Function tables are read with linear interpolation. +-- The standard Csound opcode table when producing a k- or a-rate result, can only use an init-time variable to select the table number. tablekt accepts k-rate control as well as i-time. In all other respects they are similar to the original opcodes. +--+-- > ares tablekt xndx, kfn [, ixmode] [, ixoff] [, iwrap]+-- > kres tablekt kndx, kfn [, ixmode] [, ixoff] [, iwrap]+--+-- csound doc: <http://www.csounds.com/manual/html/tablekt.html>+tablekt ::  Sig -> Tab -> Sig+tablekt b1 b2 = Sig $ f <$> unSig b1 <*> unTab b2+    where f a1 a2 = opcs "tablekt" [(Ar,[Xr,Kr,Ir,Ir,Ir]),(Kr,[Xr,Kr,Ir,Ir,Ir])] [a1,a2]+++-- | +-- tablexkt — Reads function tables with linear, cubic, or sinc interpolation. +--+-- > ares tablexkt xndx, kfn, kwarp, iwsize [, ixmode] [, ixoff] [, iwrap]+--+-- csound doc: <http://www.csounds.com/manual/html/tablexkt.html>+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]

@@ -42,7 +42,7 @@     quot', rem', div', mod', ceil', floor', round', int', frac',                 -- ** Logic functions-    boolSig, when1, whens, whenD1, whenDs, whileDo, untilDo, whileDoD, untilDoD,+    boolSig, when1, whens, whenD1, whenDs, whileDo, untilDo, whileDoD, untilDoD, whenElseD, compareWhenD,     equalsTo, notEqualsTo, lessThan, greaterThan, lessThanEquals, greaterThanEquals,      -- ** Aliases @@ -78,6 +78,7 @@  import Data.Boolean import Csound.Typed.Types+import Csound.Control.SE  -- | Gets an init-rate value from the list by index. atArg :: (Tuple a, Arg a) => [a] -> D -> a@@ -87,3 +88,17 @@ atTuple :: (Tuple a) => [a] -> Sig -> a atTuple as ind = guardedTuple (zip (fmap (\x -> sig (int x) ==* ind) [0 .. ]) as) (head as) ++whenElseD :: BoolD -> SE () -> SE () -> SE ()+whenElseD cond ifDo elseDo = whenDs [(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+    [] -> return ()+    [(cond, ifDo)] -> ifDo +    (cond1, do1):(cond2, do2): [] -> whenElseD (val `lessThan` cond1) do1 do2+    _ -> whenElseD (val `lessThan` rootCond) (compareWhenD val less) (compareWhenD val more)+    where+        (less, more) = splitAt (length conds `div` 2) conds+        rootCond = fst $ last less