csound-expression 5.3.3 → 5.3.4

raw patch · 35 files changed

+2086/−1968 lines, 35 filesdep ~csound-expression-dynamicdep ~csound-expression-opcodesdep ~csound-expression-typedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

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

API changes (from Hackage documentation)

Files

• csound-expression.cabal +13/−5
• src/Csound/Air/Envelope.hs +49/−35
• src/Csound/Air/Filter.hs +15/−17
• src/Csound/Air/Fm.hs +148/−143
• src/Csound/Air/Fx.hs +34/−35
• src/Csound/Air/Fx/FxBox.hs +44/−17
• src/Csound/Air/Granular.hs +411/−464
• src/Csound/Air/Granular/Morpheus.hs +204/−205
• src/Csound/Air/Hvs.hs +49/−51
• src/Csound/Air/Live.hs +40/−27
• src/Csound/Air/Looper.hs +99/−105
• src/Csound/Air/Misc.hs +47/−47
• src/Csound/Air/ModArg.hs +22/−21
• src/Csound/Air/Padsynth.hs +21/−20
• src/Csound/Air/Patch.hs +167/−166
• src/Csound/Air/Sampler.hs +104/−104
• src/Csound/Air/Seg.hs +109/−107
• src/Csound/Air/Spec.hs +35/−35
• src/Csound/Air/Wav.hs +7/−9
• src/Csound/Air/Wave.hs +16/−4
• src/Csound/Air/Wave/Sync.hs +12/−10
• src/Csound/Control/Evt.hs +13/−14
• src/Csound/Control/Gui.hs +28/−15
• src/Csound/Control/Gui/Widget.hs +7/−6
• src/Csound/Control/Instr.hs +7/−9
• src/Csound/Control/Midi.hs +89/−86
• src/Csound/Control/Overload/Outs.hs +16/−16
• src/Csound/Control/SE.hs +2/−2
• src/Csound/Control/Sf.hs +20/−21
• src/Csound/IO.hs +95/−13
• src/Csound/Options.hs +14/−5
• src/Csound/SigSpace.hs +5/−9
• src/Csound/Tab.hs +126/−129
• src/Csound/Tuning.hs +9/−6
• src/Csound/Types.hs +9/−10

@@ -1,6 +1,6 @@ Name:          csound-expression-Version:       5.3.3-Cabal-Version: >= 1.10+Version:       5.3.4+Cabal-Version: >= 1.22 License:       BSD3 License-file:  LICENSE Author:	       Anton Kholomiov@@ -78,9 +78,17 @@ Library   Ghc-Options:    -Wall   Build-Depends:-        base >= 4.6, base < 5, process, data-default, Boolean >= 0.1.0, colour >= 2.0, transformers >= 0.3, containers,-        csound-expression-typed >= 0.2.3.1, csound-expression-dynamic >= 0.3.5, temporal-media >= 0.6.3,-        csound-expression-opcodes >= 0.0.4.0+        base >= 4.6, base < 5,+        process,+        data-default,+        Boolean >= 0.1.0,+        colour >= 2.0,+        transformers >= 0.3,+        containers,+        csound-expression-typed >= 0.2.4,+        csound-expression-dynamic >= 0.3.6,+        temporal-media >= 0.6.3,+        csound-expression-opcodes >= 0.0.5.0   default-language: Haskell2010   Hs-Source-Dirs:      src/   Exposed-Modules:

@@ -4,7 +4,7 @@     leg, xeg,      -- ADSR with retrigger for mono-synths-    adsr140, trigTab,+    adsr140, trigTab, trigTabEvt,     -- * Relative duration     onIdur, lindur, expdur, linendur,     onDur, lindurBy, expdurBy, linendurBy,@@ -42,16 +42,13 @@ import Control.Applicative import Data.List(intersperse) -import Temporal.Media+import Temporal.Media hiding (rest)+import qualified Temporal.Media as T(Rest(..))  import Csound.Typed-import Csound.Typed.Opcode hiding (lpshold, loopseg, loopxseg)+import Csound.Typed.Opcode hiding (lpshold, loopseg, loopxseg, release) import qualified Csound.Typed.Opcode as C(lpshold, loopseg, loopxseg)-import Csound.Air.Wave-import Csound.Tab(lins, exps, gp)-import Csound.Air.Wave(oscBy)-import Csound.Air.Filter(slide)-import Csound.Typed.Plugins(adsr140, delay1k)+import Csound.Typed.Plugins(adsr140) import Csound.Control.Evt(evtToTrig)  -- | Linear adsr envelope generator with release@@ -84,8 +81,8 @@ -- -- > [a, t1 * dt, b, t2 * dt, c] onDur :: D -> [D] -> [D]-onDur dur xs = case xs of-    a:b:as -> a : b * dur : onDur dur as+onDur dt xs = case xs of+    a:b:as -> a : b * dt : onDur dt as     _ -> xs  -- | The opcode 'Csound.Opcode.linseg' with time intervals@@ -183,7 +180,7 @@         period = sumDts as          sumDts xs = case xs of-            a : dt : rest -> dt + sumDts rest+            _ : dt : rest -> dt + sumDts rest             _ -> 0  -- | It's just like @linseg@ but it loops over the envelope.@@ -206,8 +203,8 @@             where                 go xs = case xs of                     []  -> 0-                    [a] -> 0-                    a:b:rest -> b + go rest+                    [_] -> 0+                    _:b:rest -> b + go rest  -- | Sample and hold sequence. It outputs the looping sequence of constan elements. constSeq :: [Sig] -> Sig -> Sig@@ -276,28 +273,34 @@ ixrampSeq duty xs = genSeq loopxseg (irampList (head xs) duty) xs  +sawList :: [Sig] -> [Sig] sawList xs = case xs of     []  -> []     [a] -> a : 1 : 0 : []     a:rest -> a : 1 : 0 : 0 : sawList rest +isawList :: [Sig] -> [Sig] isawList xs = case xs of     []  -> []     [a] -> 0 : 1 : a : []     a:rest -> 0 : 1 : a : 0 : isawList rest +triList :: [Sig] -> [Sig] triList xs = case xs of     [] -> [0, 0]     a:rest -> 0 : 1 : a : 1 : triList rest +pwList :: Sig -> [Sig] -> [Sig] pwList k xs = case xs of     []   -> []     a:as -> a : k : 0 : (1 - k) : pwList k as +ipwList :: Sig -> [Sig] -> [Sig] ipwList k xs = case xs of     []   -> []     a:as -> 0 : k : a : (1 - k) : ipwList k as +rampList :: Sig -> Sig -> [Sig] -> [Sig] rampList a1 duty xs = case xs of     [] -> []     [a] -> 0.5 * a : d1 : a : d1 : 0.5 * a : d2 : 0 : d2 : 0.5 * a1 : []@@ -306,6 +309,7 @@         d1 = duty / 2         d2 = (1 - duty) / 2 +irampList :: Sig -> Sig -> [Sig] -> [Sig] irampList a1 duty xs = case xs of     [] -> []     [a] -> 0.5 * a : d1 : 0 : d1 : 0.5 * a : d2 : a : d2 : 0.5 * a1 : []@@ -523,7 +527,7 @@         seq1Dur :: Sig }     | Seq1 {           seq1Dur :: Sig-        , seq1Val :: Sig+        , _seq1Val :: Sig     }  type instance DurOf Seq = Sig@@ -531,11 +535,11 @@ instance Duration Seq where     dur (Seq as) = sum $ fmap seq1Dur as -instance Rest Seq where+instance T.Rest Seq where     rest t = Seq [Rest t]  instance Delay Seq where-    del t a = mel [rest t, a]+    del t a = mel [T.rest t, a]  instance Melody Seq where     mel as = Seq $ as >>= unSeq@@ -576,10 +580,13 @@ seqGen1 :: ([Sig] -> Sig -> Sig) -> (Sig -> Sig -> [Sig]) -> [Seq] -> Sig -> Sig seqGen1 loopFun segFun as = loopFun (renderSeq1 segFun $ mel as) +simpleSeq0, simpleSeq1 :: ([Sig] -> Sig -> Sig) -> [Seq] -> Sig -> Sig+ simpleSeq0 loopFun = seqGen0 loopFun $ \dt val -> [val, dt] simpleSeq1 loopFun = seqGen0 loopFun $ \dt val -> [val, dt] -seq0 = seqGen0 lpshold+seq1, seqx :: (Sig -> Sig -> [Sig]) -> [Seq] -> Sig -> Sig+ seq1 = seqGen1 loopseg seqx = seqGen1 loopxseg @@ -601,11 +608,11 @@ -- | The sequence of pulse width waves. -- The first argument is a duty cycle (ranges from 0 to 1). seqPw :: Sig -> [Seq] -> Sig -> Sig-seqPw k = seq0 $ \dt val -> [val, dt * k, 0, dt * (1 - k)]+seqPw k = seqGen0 lpshold $ \dt val -> [val, dt * k, 0, dt * (1 - k)]  -- | The sequence of inversed pulse width waves. iseqPw :: Sig -> [Seq] -> Sig -> Sig-iseqPw k = seq0 $ \dt val -> [0, dt * k, val, dt * (1 - k)]+iseqPw k = seqGen0 lpshold $ \dt val -> [0, dt * k, val, dt * (1 - k)]  -- | The sequence of square waves. seqSqr :: [Seq] -> Sig -> Sig@@ -617,7 +624,10 @@  -- saw +saw1 :: Num a => a -> a -> [a] saw1  dt val = [val, dt, 0, 0]++isaw1 :: Num a => a -> a -> [a] isaw1 dt val = [0, dt, val, 0]  -- | The sequence of sawtooth waves.@@ -656,9 +666,12 @@  -- adsr +adsr1 :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> [Sig] adsr1 a d s r dt val = [0, a * dt, val, d * dt, s * val, (1 - a - r), s * val, r * dt ]-adsr1_ a d s r rest dt val = [0, a * dt, val, d * dt, s * val, (1 - a - r - rest), s * val, r * dt, 0, rest ] +adsr1_ :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> [Sig]+adsr1_ a d s r restSig dt val = [0, a * dt, val, d * dt, s * val, (1 - a - r - restSig), s * val, r * dt, 0, restSig ]+ -- | The sequence of ADSR-envelopes. -- -- > seqAdsr att dec sus rel@@ -682,11 +695,11 @@ -- > att + dec + sus_time + rel + rest == 1  seqAdsr_ :: Sig -> Sig -> Sig -> Sig -> Sig -> [Seq] -> Sig -> Sig-seqAdsr_ a d s r rest = seq1 (adsr1_ a d s r rest)+seqAdsr_ a d s r restSig = seq1 (adsr1_ a d s r restSig)  -- | The sequence of exponential ADSR-envelopes with rest at the end. xseqAdsr_ :: Sig -> Sig -> Sig -> Sig -> Sig -> [Seq] -> Sig -> Sig-xseqAdsr_ a d s r rest = seqx (adsr1_ a d s r rest)+xseqAdsr_ a d s r restSig = seqx (adsr1_ a d s r restSig)  ------------------------------------------------- @@ -725,8 +738,9 @@     where f n             | n <= 0 = []             | n == 1 = [1]-            | otherwise = [1, rest $ sig $ int $ n - 1]+            | otherwise = [1, T.rest $ sig $ int $ n - 1] +rowDesc :: Int -> [Double] rowDesc n = [1, 1 - recipN .. recipN ]     where recipN = 1/ fromIntegral n @@ -805,15 +819,15 @@     type HumanizeValueOut ([D] -> Sig) = [D] -> SE Sig     humanVal dr f = \xs -> fmap f $ mapM human1 $ zip [0 ..] xs         where human1 (n, a)-                    | mod n 2 == 1 = rndValD dr a-                    | otherwise    = return a+                    | mod n 2 == (1 :: Int) = rndValD dr a+                    | otherwise             = return a  instance HumanizeValue ([D] -> D -> Sig) where     type HumanizeValueOut ([D] -> D -> Sig) = [D] -> D -> SE Sig     humanVal dr f = \xs release -> fmap (flip f release) $ mapM human1 $ zip [0 ..] xs         where human1 (n, a)-                    | mod n 2 == 1 = rndValD dr a-                    | otherwise    = return a+                    | mod n 2 == (1 :: Int) = rndValD dr a+                    | otherwise             = return a  -- time @@ -844,15 +858,15 @@     type HumanizeTimeOut ([D] -> Sig) = [D] -> SE Sig     humanTime dr f = \xs -> fmap f $ mapM human1 $ zip [0 ..] xs         where human1 (n, a)-                    | mod n 2 == 0 = rndValD dr a-                    | otherwise    = return a+                    | mod n 2 == (0 :: Int) = rndValD dr a+                    | otherwise             = return a  instance HumanizeTime ([D] -> D -> Sig) where     type HumanizeTimeOut ([D] -> D -> Sig) = [D] -> D -> SE Sig     humanTime dr f = \xs release -> liftA2 f (mapM human1 $ zip [0 ..] xs) (rndValD dr release)         where human1 (n, a)-                    | mod n 2 == 0 = rndValD dr a-                    | otherwise    = return a+                    | mod n 2 == (0 :: Int) = rndValD dr a+                    | otherwise             = return a  -- value & time @@ -883,15 +897,15 @@     type HumanizeValueTimeOut ([D] -> Sig) = [D] -> SE Sig     humanValTime drVal drTime f = \xs -> fmap f $ mapM human1 $ zip [0 ..] xs         where human1 (n, a)-                    | mod n 2 == 1 = rndValD drVal  a-                    | otherwise    = rndValD drTime a+                    | mod n 2 == (1 :: Int) = rndValD drVal  a+                    | otherwise             = rndValD drTime a  instance HumanizeValueTime ([D] -> D -> Sig) where     type HumanizeValueTimeOut ([D] -> D -> Sig) = [D] -> D -> SE Sig     humanValTime drVal drTime f = \xs release -> liftA2 f (mapM human1 $ zip [0 ..] xs) (rndValD drTime release)         where human1 (n, a)-                    | mod n 2 == 1 = rndValD drVal  a-                    | otherwise    = rndValD drTime a+                    | mod n 2 == (1 :: Int) = rndValD drVal  a+                    | otherwise             = rndValD drTime a   -----------------------------------------------------

@@ -54,9 +54,16 @@     -- ** low pass     lpCheb1, lpCheb1', lpCheb2, lpCheb2', clp, clp', +    -- ** band pass+    bpCheb1, bpCheb1', bpCheb2, bpCheb2', cbp, cbp',+     -- ** high pass     hpCheb1, hpCheb1', hpCheb2, hpCheb2', chp, chp', +    -- resonant filters+    cheb1, cheb2, vcf,+    cheb1', cheb2', vcf',+     -- * Named resonant low pass filters     plastic, wobble, trumpy, harsh, @@ -74,22 +81,11 @@     multiStatevar, multiSvfilter ) where -import Control.Applicative- import Csound.Typed-import Csound.Typed.Plugins hiding (-        zdf1, zlp1, zhp1, zap1,-        zdf2, zlp, zbp, zhp, zdf2_notch, zbr,-        zladder,-        diode, linDiode, noNormDiode,-        linKorg_lp, linKorg_hp, korg_lp, korg_hp)  import Csound.SigSpace(bat) import Csound.Typed.Opcode -import Control.Monad.Trans.Class-import Csound.Dynamic- -- | Low-pass filter. -- -- > lp cutoff resonance sig@@ -179,7 +175,7 @@  -- | Makes fake resonant filter from flat filter. The resulting filter just ignores the resonance. toReson :: FlatFilter -> ResonFilter-toReson filter = \cfq res -> filter cfq+toReson f = \cfq _res -> f cfq  -- | Applies a filter n-times. The n is given in the first rgument. filt :: Int -> ResonFilter -> ResonFilter@@ -268,6 +264,8 @@ singO2 :: Sig -> Sig singO2 = bat (formant bp2 anO2) +anO, anA, anE, anIY, anO2 :: [(Sig, Sig)]+ anO  = [(280, 20), (650, 25), (2200, 30), (3450, 40), (4500, 50)] anA  = [(650, 50), (1100, 50), (2860, 50), (3300, 50), (4500, 50)] anE  = [(500, 50), (1750, 50), (2450, 50), (3350, 50), (5000, 50)]@@ -281,19 +279,19 @@ -- -- > alpf1 centerFrequency resonance asig alp1 :: Sig -> Sig -> Sig -> Sig-alp1 freq reson asig = mvclpf1 asig freq reson+alp1 freq resonance asig = mvclpf1 asig freq resonance  -- | Analog-like low-pass filter -- -- > alpf2 centerFrequency resonance asig alp2 :: Sig -> Sig -> Sig -> Sig-alp2 freq reson asig = mvclpf2 asig freq reson+alp2 freq resonance asig = mvclpf2 asig freq resonance  -- | Analog-like low-pass filter ----- > alpf3 centerFrequency resonance asig+-- > alpf3 centerFrequency resonanceance asig alp3 :: Sig -> Sig -> Sig -> Sig-alp3 freq reson asig = mvclpf3 asig freq reson+alp3 freq resonance asig = mvclpf3 asig freq resonance  -- | Analog-like low-pass filter --@@ -309,7 +307,7 @@ -- -- * asig4 -- 24dB/oct low-pass response output. alp4 :: Sig -> Sig -> Sig -> (Sig, Sig, Sig, Sig)-alp4 freq reson asig = mvclpf4 asig freq reson+alp4 freq resonance asig = mvclpf4 asig freq resonance  -- | Analog-like high-pass filter --

@@ -1,27 +1,27 @@--- | Tools to build Fm synthesis graphs +-- | Tools to build Fm synthesis graphs -- -- Example -- -- > f a = fmOut1 $ do--- > 	x1 <- fmOsc 1--- > 	x2 <- fmOsc 2--- > 	x1 `fmod` [(a, x2)]--- > 	return x1+-- >  x1 <- fmOsc 1+-- >  x2 <- fmOsc 2+-- >  x1 `fmod` [(a, x2)]+-- >  return x1 module Csound.Air.Fm(-	-- * Fm graph-	Fm, FmNode,-	fmOsc', fmOsc, fmSig,-	fmod, -	fmOut, fmOut1, fmOut2,+  -- * Fm graph+  Fm, FmNode,+  fmOsc', fmOsc, fmSig,+  fmod,+  fmOut, fmOut1, fmOut2, -	-- * Simplified Fm graph-	FmSpec(..), FmGraph(..), fmRun,-	-- ** Specific graphs-	-- | Algorithms for DX7 fm synth-	dx_1,  dx_2,  dx_3,  dx_4 {-,  dx_5,  dx_6,  dx_7,  dx_8,-	dx_9,  dx_10, dx_11, dx_12, dx_13, dx_14, dx_15, dx_16,-	dx_17, dx_18, dx_19, dx_20, dx_21, dx_22, dx_23, dx_24,-	dx_25, dx_26, dx_27, dx_28, dx_29, dx_30, dx_31, dx_32 -}+  -- * Simplified Fm graph+  FmSpec(..), FmGraph(..), fmRun,+  -- ** Specific graphs+  -- | Algorithms for DX7 fm synth+  dx_1,  dx_2,  dx_3,  dx_4 {-,  dx_5,  dx_6,  dx_7,  dx_8,+  dx_9,  dx_10, dx_11, dx_12, dx_13, dx_14, dx_15, dx_16,+  dx_17, dx_18, dx_19, dx_20, dx_21, dx_22, dx_23, dx_24,+  dx_25, dx_26, dx_27, dx_28, dx_29, dx_30, dx_31, dx_32 -} ) where  import qualified Data.IntMap as IM@@ -31,60 +31,61 @@  import Csound.Typed import Csound.Air.Wave-import Csound.SigSpace  -- Fm graph rendering  type Fm a = State St a -newtype FmNode = FmNode { unFmNode :: Int }+newtype FmNode = FmNode Int  type FmIdx = (Int, Sig)  data Fmod = Fmod (Sig -> SE Sig) Sig [FmIdx] | Fsig Sig -data St = St -	{ newIdx     :: Int-	, units      :: [Fmod]-	, links      :: IM.IntMap [FmIdx]-	}+data St = St+  { st'newIdx     :: Int+  , st'units      :: [Fmod]+  , st'links      :: IM.IntMap [FmIdx]+  } -defSt = St -	{ newIdx = 0-	, units = []	-	, links = IM.empty }+defSt :: St+defSt = St+  { st'newIdx = 0+  , st'units = []+  , st'links = IM.empty }  renderGraph :: [Fmod] -> [FmIdx] -> Sig -> SE [Sig] renderGraph units outs cps = do-	refs <- initUnits (length units)-	mapM_ (loopUnit refs) (zip [0 .. ] units)-	mapM (renderIdx refs) outs-	where-		initUnits n = mapM (const $ newRef (0 :: Sig)) [1 .. n]+  refs <- initUnits (length units)+  mapM_ (loopUnit refs) (zip [0 .. ] units)+  mapM (renderIdx refs) outs+  where+    initUnits n = mapM (const $ newRef (0 :: Sig)) [1 .. n] -		loopUnit refs (n, x) = writeRef (refs !! n) =<< case x of-			Fsig asig -> return asig-			Fmod wave mod subs -> do-				s <- fmap sum $ mapM (renderModIdx refs) subs-				wave (cps * mod + s)-			where +    loopUnit refs (n, x) = writeRef (refs !! n) =<< case x of+      Fsig asig -> return asig+      Fmod wave modFreq subs -> do+        s <- fmap sum $ mapM (renderModIdx refs) subs+        wave (cps * modFreq + s)+      where -		renderIdx :: [Ref Sig] -> (Int, Sig) -> SE Sig-		renderIdx refs (idx, amp) = mul amp $ readRef (refs !! idx)+    renderIdx :: [Ref Sig] -> (Int, Sig) -> SE Sig+    renderIdx refs (idx, amp) = mul amp $ readRef (refs !! idx) -		renderModIdx :: [Ref Sig] -> (Int, Sig) -> SE Sig-		renderModIdx refs (idx, amp) = mul (amp * mod) $ readRef (refs !! idx)	-			where mod = case (units !! idx) of-					Fmod _ m _ -> m * cps-					_          -> 1+    renderModIdx :: [Ref Sig] -> (Int, Sig) -> SE Sig+    renderModIdx refs (idx, amp) = mul (amp * modFreq) $ readRef (refs !! idx)+      where+        modFreq = case (units !! idx) of+                    Fmod _ m _ -> m * cps+                    _          -> 1   mkGraph :: St -> [Fmod]-mkGraph s = zipWith extractMod (reverse $ units s) [0 .. ]-	where-		extractMod x n = case x of-			Fmod alg w _ -> Fmod alg w (maybe [] id $ IM.lookup n (links s))-			_            -> x+mkGraph s = zipWith extractMod (reverse $ st'units s) [0 .. ]+  where+    extractMod x n = case x of+      Fmod alg w _ -> Fmod alg w (maybe [] id $ IM.lookup n (st'links s))+      _            -> x  toFmIdx :: (Sig, FmNode) -> FmIdx toFmIdx (amp, FmNode n) = (n, amp)@@ -109,23 +110,23 @@ fmSig a = newFmod (Fsig a)  newFmod :: Fmod -> Fm FmNode-newFmod a = state $ \s -> -	let n  = newIdx s-	    s1 = s { newIdx = n + 1, units = a : units s }-	in  (FmNode n, s1)+newFmod a = state $ \s ->+  let n  = st'newIdx s+      s1 = s { st'newIdx = n + 1, st'units = a : st'units s }+  in  (FmNode n, s1)  -- modulator  fmod :: FmNode -> [(Sig, FmNode)] -> Fm ()-fmod (FmNode idx) mods = state $ \s -> -	((), s { links = IM.insertWithKey (\_ a b -> a ++ b) idx (fmap toFmIdx mods) (links s) })+fmod (FmNode idx) mods = state $ \s ->+  ((), s { st'links = IM.insertWithKey (\_ a b -> a ++ b) idx (fmap toFmIdx mods) (st'links s) })  -- outputs  -- | Renders Fm synth to function. fmOut :: Fm [(Sig, FmNode)] -> Sig -> SE [Sig] fmOut fm = renderGraph (mkGraph s) (fmap toFmIdx outs)-	where (outs, s) = runState fm defSt+  where (outs, s) = runState fm defSt  -- | Renders mono output. fmOut1 :: Fm FmNode -> Sig -> SE Sig@@ -137,114 +138,118 @@  ----------------------------------------------------------------------- -data FmSpec = FmSpec -	{ fmWave :: [Sig -> SE Sig]-	, fmCps :: [Sig]-	, fmInd :: [Sig]-	, fmOuts :: [Sig] }+data FmSpec = FmSpec+  { fmWave :: [Sig -> SE Sig]+  , fmCps :: [Sig]+  , fmInd :: [Sig]+  , fmOuts :: [Sig] } -data FmGraph = FmGraph -	{ fmGraph 	:: [(Int, [Int])]-	, fmGraphOuts :: [Int] }+data FmGraph = FmGraph+  { fmGraph   :: [(Int, [Int])]+  , fmGraphOuts :: [Int] }  fmRun :: FmGraph -> FmSpec -> Sig -> SE Sig fmRun graph spec' cps = fmap sum $ ($ cps) $ fmOut $ do-	ops <- zipWithM fmOsc' (fmWave spec) (fmCps spec)-	mapM_ (mkMod ops (fmInd spec)) (fmGraph graph)-	return $ zipWith (toOut ops) (fmOuts spec) (fmGraphOuts graph)-	where -		spec = addDefaults spec'-		toOut xs amp n = (amp, xs !! n)-		mkMod ops ixs (n, ms) = (ops !! n) `fmod` (fmap (\m -> (ixs !! m, ops !! m)) ms)+  ops <- zipWithM fmOsc' (fmWave spec) (fmCps spec)+  mapM_ (mkMod ops (fmInd spec)) (fmGraph graph)+  return $ zipWith (toOut ops) (fmOuts spec) (fmGraphOuts graph)+  where+    spec = addDefaults spec'+    toOut xs amp n = (amp, xs !! n)+    mkMod ops ixs (n, ms) = (ops !! n) `fmod` (fmap (\m -> (ixs !! m, ops !! m)) ms)  addDefaults :: FmSpec -> FmSpec-addDefaults spec = spec -	{ fmWave = fmWave spec ++ repeat rndOsc	-	, fmCps  = fmCps  spec ++ repeat 1-	, fmInd  = fmInd  spec ++ repeat 1-	, fmOuts = fmOuts spec ++ repeat 1 }+addDefaults spec = spec+  { fmWave = fmWave spec ++ repeat rndOsc+  , fmCps  = fmCps  spec ++ repeat 1+  , fmInd  = fmInd  spec ++ repeat 1+  , fmOuts = fmOuts spec ++ repeat 1 }  {-|->	 	+--+->		6  |->		+--+->		5->		|->	2	4->	|	|->	1	3->	+---++>   +--++>   6  |+>   +--++>   5+>   |+> 2 4+> | |+> 1 3+> +---+ -}-dx_1 = FmGraph -	{ fmGraphOuts = [1, 3]-	, fmGraph = -		[ (1, [2])-		, (3, [4])-		, (4, [5])-		, (5, [6])-		, (6, [6]) ]}+dx_1 :: FmGraph+dx_1 = FmGraph+  { fmGraphOuts = [1, 3]+  , fmGraph =+    [ (1, [2])+    , (3, [4])+    , (4, [5])+    , (5, [6])+    , (6, [6]) ]}  {-|->         6 +>         6 >         | >         5 >   +--+  |->	2  |  4->	+--+  |->	1     3+> 2  |  4+> +--+  |+> 1     3 >   +-----+ -}-dx_2 = FmGraph -	{ fmGraphOuts = [1, 3]-	, fmGraph = -		[ (1, [2])-		, (2, [2])-		, (3, [4])-		, (5, [6]) ]}+dx_2 :: FmGraph+dx_2 = FmGraph+  { fmGraphOuts = [1, 3]+  , fmGraph =+    [ (1, [2])+    , (2, [2])+    , (3, [4])+    , (5, [6]) ]}  {-|->	    +--+->	3   6  |->	|   +--+->	2   5->	|	|->	1 	4->	+---++>     +--++> 3   6  |+> |   +--++> 2   5+> | |+> 1   4+> +---+ -}-dx_3 = FmGraph -	{ fmGraphOuts = [1, 4]-	, fmGraph = -		[ (1, [2])-		, (2, [3])-		, (4, [5])-		, (5, [6])-		, (6, [6]) ]}+dx_3 :: FmGraph+dx_3 = FmGraph+  { fmGraphOuts = [1, 4]+  , fmGraph =+    [ (1, [2])+    , (2, [3])+    , (4, [5])+    , (5, [6])+    , (6, [6]) ]}  {-|->			+--+->		3	6  |->		|	|  |	->		2	5  |->		|	|  |->		1	4  |->		|	+--+->       +---+ +>     +--++>   3 6  |+>   | |  |+>   2 5  |+>   | |  |+>   1 4  |+>   | +--++>       +---+ -}+dx_4 :: FmGraph dx_4 = FmGraph-	{ fmGraphOuts = [1, 4]-	, fmGraph = -		[ (1, [2])-		, (2, [3])-		, (4, [5])-		, (5, [6])-		, (6, [4]) ]}+  { fmGraphOuts = [1, 4]+  , fmGraph =+    [ (1, [2])+    , (2, [3])+    , (4, [5])+    , (5, [6])+    , (6, [4]) ]}  {--dx12 = DxGraph -	{ dxGraphOuts = [3, 1]-	, dxGraph = -		[ (3, [4, 5, 6])-		, (1, [2])-		, (2, [2]) ]}+dx12 = DxGraph+  { dxGraphOuts = [3, 1]+  , dxGraph =+    [ (3, [4, 5, 6])+    , (1, [2])+    , (2, [2]) ]}  -}

@@ -51,8 +51,7 @@     fxWhite, fxPink, equalizer, eq4, eq7,     fxGain, -    fxAnalogDelay, fxDistortion, fxFollower, fxReverse, fxLoFi, fxChorus2, fxAutoPan, fxTrem, fxPitchShifter, fxFreqShifter, {- ,-    fxRingModulator, , -}+    fxAnalogDelay, fxDistortion, fxFollower, fxReverse, fxLoFi, fxChorus2, fxAutoPan, fxTrem, fxPitchShifter, fxFreqShifter,     fxCompress,      -- * Eq@@ -62,24 +61,24 @@     trackerSplice, pitchShifterDelay ) where +import Prelude hiding (min, max, mod)+ import Data.Boolean import Data.Default  import Csound.Typed-import Csound.Tab(sines4, startEnds, setSize, elins, newTab, tabSizeSecondsPower2, tablewa, sec2rel)-import Csound.Typed.Opcode-import Csound.SigSpace+import Csound.Typed.Opcode hiding (gain) import Csound.Tab -import Csound.Air.Wave(Lfo, unipolar, oscBy, utri, white, pink)+import Csound.Air.Wave(Lfo, unipolar, oscBy, white, pink) import Csound.Air.Filter import Csound.Typed.Plugins hiding(pitchShifterDelay,     fxAnalogDelay, fxDistortion, fxEnvelopeFollower, fxFlanger, fxFreqShifter, fxLoFi,-    fxPanTrem, fxPhaser, fxPitchShifter, fxReverse, fxRingModulator, fxChorus2, tapeEcho)+    fxPanTrem, fxPhaser, fxPitchShifter, fxReverse, fxChorus2, tapeEcho)  import qualified Csound.Typed.Plugins as P(pitchShifterDelay,     fxAnalogDelay, fxDistortion, fxEnvelopeFollower, fxFlanger, fxFreqShifter, fxLoFi,-    fxPanTrem, fxPhaser, fxPitchShifter, fxReverse, fxRingModulator, fxChorus2, fxPingPong, tapeRead, tapeWrite, tapeEcho)+    fxPanTrem, fxPhaser, fxPitchShifter, fxReverse, fxChorus2, fxPingPong, tapeEcho)  -- | Mono version of the cool reverberation opcode reverbsc. --@@ -274,12 +273,12 @@     buf <- newTab tabLen     ptrRef <- newRef (0 :: Sig)     aresRef <- newRef (0 :: Sig)-    ptr <- readRef ptrRef-    when1 (ptr >=* sig tabLen) $ do+    ptr1 <- readRef ptrRef+    when1 (ptr1 >=* sig tabLen) $ do         writeRef ptrRef 0-    ptr <- readRef ptrRef+    ptr2 <- readRef ptrRef -    let kphs = (ptr / sig tabLen) - (delTim/(sig $ tabLen / getSampleRate))+    let kphs = (ptr2 / sig tabLen) - (delTim/(sig $ tabLen / getSampleRate))     awet <-go buf (wrap kphs 0 1)     writeRef aresRef $ asig + kfeed * awet     ares <- readRef aresRef@@ -420,8 +419,8 @@         kDry = kr $ table kmix iDry `withD` 1  fxWet :: (Num a, SigSpace a) => Sig -> a -> a -> a-fxWet mix ain aout = mul dry ain + mul wet aout-    where (dry, wet) = dryWetMix mix+fxWet mixSig ain aout = mul dry ain + mul wet aout+    where (dry, wet) = dryWetMix mixSig  -- Distortion @@ -447,7 +446,7 @@ -- -- > stChorus2 mix rate depth width sigIn stChorus2 :: Balance -> RateSig -> DepthSig -> WidthSig -> Sig2 -> Sig2-stChorus2 kmix krate' kdepth kwidth (al, ar) = fxWet kmix (al, ar) (aoutL, aoutR)+stChorus2 kmix krate' kdepth kwidth (aleft, aright) = fxWet kmix (aleft, aright) (aoutL, aoutR)     where         krate = expScale 20 (0.001, 7) krate'         ilfoshape = setSize 131072 $ sines4 [(1, 0.5, 0, 0.5)]@@ -456,10 +455,10 @@         amodL = osciliktp   krate ilfoshape 0         amodR = osciliktp   krate ilfoshape (kwidth*0.5)         vdel mod x = vdelay x (mod * kChoDepth * 1000) (1.2 * 1000)-        aChoL = vdel amodL al-        aChoR = vdel amodR ar-        aoutL = 0.6 * (aChoL + al)-        aoutR = 0.6 * (aChoR + ar)+        aChoL = vdel amodL aleft+        aChoR = vdel amodR aright+        aoutL = 0.6 * (aChoL + aleft)+        aoutR = 0.6 * (aChoR + aright)  -- Analog delay @@ -489,7 +488,7 @@ -- -- > equalizer gainsAndFrequencies gain sigIn equalizer :: [(Sig, Sig)] -> Sig -> Sig -> Sig-equalizer fs gain ain0 = case fs of+equalizer fs gainSig ain0 = case fs of     []   -> ain     x:[] -> g 0 x ain     x:y:[] -> mean [g 1 x ain, g 2 y ain]@@ -499,7 +498,7 @@         iEQcurve = skipNorm $ setSize 4096 $ startEnds [1/64,4096,7.9,64]         iGainCurve = skipNorm $ setSize 4096 $ startEnds [0.5,4096,3,4]         g ty (gain, freq) asig = pareq  asig freq (table gain iEQcurve `withD` 1) iQ `withD` ty-        kgain = table gain iGainCurve `withD` 1+        kgain = table gainSig iGainCurve `withD` 1         ain = kgain * ain0  -- | Equalizer with frequencies: 100, 200, 400, 800, 1600, 3200, 6400@@ -523,8 +522,8 @@ -- > fxWhite lfoFreq depth sigIn fxWhite :: Sig -> Sig -> Sig -> SE Sig fxWhite freq depth ain = do-    noise <- white-    return $ ain + 0.5 * depth * blp cps noise+    noiseSig <- white+    return $ ain + 0.5 * depth * blp cps noiseSig     where cps = expScale 4 (20, 20000) freq  -- | Adds filtered pink noize to the signal@@ -532,8 +531,8 @@ -- > fxWhite lfoFreq depth sigIn fxPink :: Sig -> Sig -> Sig -> SE Sig fxPink freq depth ain = do-    noise <- pink-    return $ ain + 0.5 * depth * blp cps noise+    noiseSig <- pink+    return $ ain + 0.5 * depth * blp cps noiseSig     where cps = expScale 4 (20, 20000) freq  -- Echo@@ -590,21 +589,21 @@      whens [         (kmode >=* 1 &&* kmode `lessThan` 2, do-                kindx <- readRef kindxRef-                writeRef kindxRef $ ifB (kindx >* segLength) 0 (kindx + 1)-                kindx <- readRef kindxRef-                when1 (kindx + apos >* sig (ftlen buf)) $ do+                kindx1 <- readRef kindxRef+                writeRef kindxRef $ ifB (kindx1 >* segLength) 0 (kindx1 + 1)+                kindx2 <- readRef kindxRef+                when1 (kindx2 + apos >* sig (ftlen buf)) $ do                     writeRef kindxRef $ (-segLength) -                kindx <- readRef kindxRef+                kindx3 <- readRef kindxRef -                writeRef aoutRef $ table (apos + kindx) buf `withDs` [0, 1]+                writeRef aoutRef $ table (apos + kindx3) buf `withDs` [0, 1]                 writeRef ksampRef 0         ), (kmode >=* 2 &&* kmode `lessThan` 3, do-                kindx <- readRef kindxRef-                writeRef kindxRef $ ifB ((kindx+apos) <=* 0) (sig (ftlen buf) - apos) (kindx-1)-                kindx <- readRef kindxRef-                writeRef aoutRef $ table (apos+kindx) buf `withDs` [0, 1]+                kindx1 <- readRef kindxRef+                writeRef kindxRef $ ifB ((kindx1+apos) <=* 0) (sig (ftlen buf) - apos) (kindx1-1)+                kindx2 <- readRef kindxRef+                writeRef aoutRef $ table (apos+kindx2) buf `withDs` [0, 1]                 writeRef ksampRef 0         )] (do                 writeRef ksampRef 1

@@ -1,4 +1,4 @@-{-# Language FlexibleContexts #-}+{-# Language FlexibleContexts, LambdaCase #-}  -- | A friendly family of effects. These functions are kindly provided by Iain McCurdy (designed in Csound). module Csound.Air.Fx.FxBox(@@ -196,20 +196,18 @@ import Data.Default  import Csound.Typed-import Csound.Typed.Opcode(ampdb, scale, expcurve, compress)-import Csound.Typed.Gui--import Csound.SigSpace+import Csound.Typed.Opcode(scale, expcurve)+import Csound.Typed.Gui hiding (width) -import qualified Csound.Typed.Plugins as P(pitchShifterDelay,-    fxAnalogDelay, fxDistortion, fxEnvelopeFollower, fxFlanger, fxFreqShifter, fxLoFi,-    fxPanTrem, fxMonoTrem, fxPhaser, fxPitchShifter, fxReverse, fxRingModulator, fxChorus2)+import qualified Csound.Typed.Plugins as P(+    fxAnalogDelay, fxDistortion, fxEnvelopeFollower, fxFlanger, fxLoFi,+    fxPanTrem, fxMonoTrem, fxPhaser, fxReverse, fxRingModulator, fxChorus2)  import Csound.Air.Patch(Fx, Fx1, Fx2) import Csound.Air.Fx(Balance, DelayTime, Feedback, ToneSig, SensitivitySig,     BaseCps, Resonance, DepthSig, RateSig, TremWaveSig, FoldoverSig, BitsReductionSig,     DriveSig, TimeSig, WidthSig,-    rever2, pingPong, pingPong', PingPongSpec(..),+    rever2, pingPong', PingPongSpec(..),     EchoGain, RandomSpreadSig,     tapeEcho) @@ -217,7 +215,6 @@ import Csound.Air.Wav(toMono) import Csound.Air.Misc(fromMono, ambiEnv, saturator) -import qualified Data.Colour as C import qualified Data.Colour.SRGB as C  @@ -715,6 +712,8 @@   -- colors+tortColor, fowlerColor, adeleColor, pongColor, flanColor, revsyColor, phasyColor,+  crusherColor, choryColor, panyColor, tremyColor, ringoColor, reverbColor :: String  tortColor = red fowlerColor = maroon@@ -730,21 +729,24 @@ ringoColor = maroon reverbColor = olive +paintTo :: String -> Source a -> Source a paintTo = fxColor . C.sRGB24read +red, maroon, blue, aqua, navy, lime,  green, yellow, purple, olive, orange, fuchsia :: String+ red = "#FF4136" maroon = "#85144b" blue = "#0074D9" aqua = "#7FDBFF"-teal = "#39CCCC" navy = "#001f3f"-orange = "#FF851B" lime = "#01FF70" green = "#2ECC40" yellow = "#FFDC00" purple = "#B10DC9"-fuchsia = "#F012BE" olive = "#3D9970"+-- teal = "#39CCCC"+orange = "#FF851B"+fuchsia = "#F012BE"  -- Analog Delay @@ -752,6 +754,7 @@ uiAdeleBy initTone initFeedback initBalance initDelayTime = mapSource bindSig $ paintTo adeleColor $ fxBox "Delay" fx True  [("balance", initBalance), ("del time", initDelayTime), ("fbk", initFeedback), ("tone", initTone)]     where         fx [balance, delayTime, feedback, tone] = return . adele balance delayTime feedback tone+        fx _                                    = undefined  uiAdeleBy_ :: Sigs a => Double -> Double -> Double -> Source (Fx a) uiAdeleBy_ = uiAdeleBy 0.5@@ -792,14 +795,17 @@ uiMagnus size initDelayTime initFeedback initEchoGain initTone initSpread  = mapSource bindSig $ paintTo adeleColor $ fxBox "Tape echo" fx True [("del time", initDelayTime), ("fbk", initFeedback), ("echo gain", initEchoGain), ("tone", initTone), ("tape qty", initSpread)]     where         fx [delayTime, feedback, echoGain, tone, spread] = return . magnus (int size) delayTime feedback echoGain tone spread+        fx _                                             = undefined  -- Ping-pong delay  uiPongyBy :: Sigs a => Double -> Double -> Double -> Double -> Double -> Source (Fx a)-uiPongyBy initTone initWidth initFeedback initBalance initDelayTime = mapSource bindSig $ paintTo adeleColor $ fxBox "Ping-pong" fx True  [("balance", initBalance), ("del time", initDelayTime), ("fbk", initFeedback), ("tone", initTone), ("width", initWidth)]+uiPongyBy initTone initWidth initFeedback initBalance initDelayTime = mapSource bindSig $ paintTo pongColor $ fxBox "Ping-pong" fx True  [("balance", initBalance), ("del time", initDelayTime), ("fbk", initFeedback), ("tone", initTone), ("width", initWidth)]     where         fx [balance, delayTime, feedback, tone, width] = return . pongy balance delayTime feedback tone width+        fx _                                           = undefined +defWidth :: Double defWidth = 0.7  uiPongyBy_ :: Sigs a => Double -> Double -> Double -> Source (Fx a)@@ -841,6 +847,7 @@ uiTortBy initTone initDrive = mapSource bindSig $ paintTo tortColor $ fxBox "Distort" fx True [("drive", initDrive), ("tone", initTone)]     where         fx [drive, tone] = return . tort drive tone+        fx _             = undefined  uiTortBy_ :: Sigs a => Double -> Source (Fx a) uiTortBy_ = uiTortBy 0.5@@ -881,11 +888,13 @@ uiFowler' = mapSource bindSig $ paintTo fowlerColor $ fxBox "Follower" fx True [("size", size1)]     where         fx [size] = return . fowler' size+        fx _      = undefined  uiFowlerBy :: Sigs a => Double -> Source (Fx a) uiFowlerBy size = mapSource bindSig $ paintTo fowlerColor $ fxBox "Follower" fx True [("sense", size), ("freq", size), ("reson", size)]     where         fx [sense, freq, resonance] = return . fowler sense freq resonance+        fx _                        = undefined  uiFowler1, uiFowler2, uiFowler3, uiFowler4, uiFowler5 :: Sigs a => Source (Fx a) @@ -901,11 +910,13 @@ uiFlan' = mapSource bindSig $ paintTo flanColor $ fxBox "Flanger" fx True [("size", size1)]     where         fx [size] = return . flan' size+        fx _      = undefined  uiFlanBy :: Sigs a => Double -> Source (Fx a) uiFlanBy size = mapSource bindSig $ paintTo flanColor $ fxBox "Flanger" fx True $ setAll size ["rate", "depth", "del time", "fbk"]     where         fx [rate, depth, delayTime, fbk] = return . flan rate depth delayTime fbk+        fx _                             = undefined  uiFlan1, uiFlan2, uiFlan3, uiFlan4, uiFlan5 :: Sigs a => Source (Fx a) @@ -923,11 +934,13 @@ uiPhasy' = mapSource bindSig $ paintTo phasyColor $ fxBox "Phaser" fx  True $ [("size", size1)]     where         fx [x] = return . phasy' x+        fx _   = undefined  uiPhasyBy :: Sigs a => Double -> Source (Fx a) uiPhasyBy size = mapSource bindSig $ paintTo phasyColor $ fxBox "Phaser" fx True $ setAll size ["rate", "depth", "cps", "fbk"]     where         fx [rate, depth, cps, fbk] = return . phasy rate depth cps fbk+        fx _                       = undefined  uiPhasy1, uiPhasy2, uiPhasy3, uiPhasy4, uiPhasy5 :: Sigs a => Source (Fx a) @@ -943,11 +956,13 @@ uiChory' = paintTo choryColor $ fxBox "Chorus" fx True [("size", size1)]     where         fx [size] = return . chory' size+        fx _      = undefined  uiChoryBy :: Sig2s a => Double -> Source (Fx a) uiChoryBy size = paintTo choryColor $ fxBox "Chorus" fx True $ setAll size ["rate", "depth", "width"]     where         fx [rate, depth, width] = return . mapSig2 (chory rate depth width)+        fx _                    = undefined  uiChory1, uiChory2, uiChory3, uiChory4, uiChory5 :: Sig2s a => Source (Fx a) @@ -965,6 +980,7 @@ genUiPany' mkPany = paintTo panyColor $ fxBox "Pan" fx True [("size", size1)]     where         fx [size] = return . mkPany size+        fx _      = undefined  uiOscPany', uiTriPany', uiSqrPany' :: Source Fx2 @@ -976,6 +992,7 @@ genUiPanyBy wave size = paintTo panyColor $ fxBox "Pan" fx True $ setAll size ["depth", "rate"]     where         fx [depth, rate] = return . pany wave depth rate+        fx _             = undefined  uiOscPanyBy, uiTriPanyBy, uiSqrPanyBy :: Double -> Source Fx2 @@ -1011,6 +1028,7 @@ genUiTremy' mkTremy = mapSource bindSig $ paintTo tremyColor $ fxBox "Tremolo" fx True [("size", size1)]     where         fx [size] = return . mkTremy size+        fx _      = undefined  uiOscTremy', uiTriTremy', uiSqrTremy' :: Sigs a => Source (Fx a) @@ -1022,6 +1040,7 @@ genUiTremyBy wave size = mapSource bindSig $ paintTo tremyColor $ fxBox "Tremolo" fx True $ setAll size ["depth", "rate"]     where         fx [depth, rate] = return . tremy wave depth rate+        fx _             = undefined  uiOscTremyBy, uiTriTremyBy, uiSqrTremyBy :: Sigs a => Double -> Source (Fx a) @@ -1057,11 +1076,13 @@ uiRingo' = mapSource bindSig $ paintTo ringoColor $ fxBox "Ringo" fx True [("size", size1)]     where         fx [size] = return . ringo' size+        fx _      = undefined  uiRingoBy :: Sigs a => Double -> Source (Fx a) uiRingoBy size = mapSource bindSig $ paintTo ringoColor $ fxBox "Ring Mod" fx True $ setAll size ["mix", "rate", "env mod"]     where         fx [balance, rate, envMod] = return . ringo balance rate envMod+        fx _                       = undefined  uiRingo1, uiRingo2, uiRingo3, uiRingo4, uiRingo5 :: Sigs a => Source (Fx a) @@ -1074,9 +1095,10 @@ -- Crusher  uiCrusher :: Sigs a => Double -> Double -> Source (Fx a)-uiCrusher initReduction initFoldover = mapSource bindSig $ paintTo revsyColor $ fxBox "LoFi" fx True [("redux", initReduction), ("foldover", initFoldover)]+uiCrusher initReduction initFoldover = mapSource bindSig $ paintTo crusherColor $ fxBox "LoFi" fx True [("redux", initReduction), ("foldover", initFoldover)]     where         fx [redux, foldover] = return . crusher redux foldover+        fx _                 = undefined  -- Reverse @@ -1084,6 +1106,7 @@ uiRevsy initTime = mapSource bindSig $ paintTo revsyColor $ fxBox "Reverse" fx True [("time", initTime)]     where         fx [time] = return . revsy time+        fx _      = undefined  ------------------------------------------------------------ -- Reverbs@@ -1091,7 +1114,9 @@ uiRevBy :: Sig2s a => Double -> Double -> Source (Fx a) uiRevBy initFeedback initMix = paintTo reverbColor $ fxBox "Reverb" fx True [("mix", initMix), ("fbk", initFeedback)]     where-        fx [balance, feedback] = \asig -> return $ mapSig2 (\x -> mul (1 - balance) x + mul balance (rever2 feedback x)) asig+        fx = \case+          [balance, feedback] -> \asig -> return $ mapSig2 (\x -> mul (1 - balance) x + mul balance (rever2 feedback x)) asig+          _                   -> undefined  uiRoom :: Sig2s a => Double -> Source (Fx a) uiRoom = uiRevBy 0.6@@ -1146,7 +1171,9 @@ uiMonoRevBy :: Double -> Double -> Source Fx1 uiMonoRevBy initFeedback initMix = paintTo reverbColor $ fxBox "Reverb" fx True [("mix", initMix), ("fbk", initFeedback)]     where-        fx [balance, feedback] = \asig -> return $ mixAt balance (rever1 feedback) asig+        fx = \case+          [balance, feedback] -> \asig -> return $ mixAt balance (rever1 feedback) asig+          _                   -> undefined  uiMonoRoom :: Double -> Source Fx1 uiMonoRoom = uiMonoRevBy 0.6

@@ -2,17 +2,17 @@ -- Unfortunately they are very hard to use due to large number of arguments. -- This module attempts to set most of the arguments with sensible defaults. -- So that a novice could start to use it. The defaults are implemented with--- the help of the class @Default@. It's a standard way to implement defaults +-- the help of the class @Default@. It's a standard way to implement defaults -- in the Haskell. The class @Defaults@ defines a single constnat called @def@. -- With @def@ we can get the default value for the given type. -- -- Several csound opcodes are reimplemented so that first argument contains--- secondary parameters. The type for parameters always has the instance for the +-- secondary parameters. The type for parameters always has the instance for the -- class @Default@. The original csound opcodes are defined in the end of the module -- with prefix @csd@. ----- Also many granular synth opcodes expect the sound file as input. --- There are predefined versions of the opcodes that take in the file names +-- Also many granular synth opcodes expect the sound file as input.+-- There are predefined versions of the opcodes that take in the file names -- instead of tables with sampled sound. They have suffix @Snd@ for stereo and @Snd1@ for mono files. -- -- For example, that's how we can use the @granule@ opcode:@@ -43,86 +43,81 @@ -- they implemented as window tables see the table constructors with prefix @win@. -- -- Usual order of arguments is: @GrainRate@, @GrainSize@, @TempoSig@, @PitchSig@, file @table@ or @name@, @poniter@ to the table.--- +-- module Csound.Air.Granular(-	GrainRate, GrainSize, Pointer, ConstPitchSig,+  GrainRate, GrainSize, Pointer, ConstPitchSig, -	-- * Grainy (simple partikkel)-	RndGrainySpec(..),-	grainy, grainy1, rndGrainy, rndGrainy1,-	ptrGrainy, rndPtrGrainy, -	ptrGrainySnd, ptrGrainySnd1,+  -- * Grainy (simple partikkel)+  RndGrainySpec(..),+  grainy, grainy1, rndGrainy, rndGrainy1,+  ptrGrainy, rndPtrGrainy,+  ptrGrainySnd, ptrGrainySnd1, -	-- * Sndwarp-	SndwarpSpec(..), -	sndwarp, sndwarpst, sndwarpSnd, sndwarpSnd1,-	ptrSndwarp, ptrSndwarpst, ptrSndwarpSnd, ptrSndwarpSnd1,+  -- * Sndwarp+  SndwarpSpec(..),+  sndwarp, sndwarpst, sndwarpSnd, sndwarpSnd1,+  ptrSndwarp, ptrSndwarpst, ptrSndwarpSnd, ptrSndwarpSnd1, -	-- * Syncgrain	-	SyncgrainSpec(..), RndSyncgrainSpec(..),-	syncgrain, syncgrainSnd, syncgrainSnd1,-	rndSyncgrain, rndSyncgrainSnd, rndSyncgrainSnd1,+  -- * Syncgrain+  SyncgrainSpec(..), RndSyncgrainSpec(..),+  syncgrain, syncgrainSnd, syncgrainSnd1,+  rndSyncgrain, rndSyncgrainSnd, rndSyncgrainSnd1, -	-- * Granule	-	GranuleSpec(..), GranuleMode(..),-	granule, granuleSnd, granuleSnd1,+  -- * Granule+  GranuleSpec(..), GranuleMode(..),+  granule, granuleSnd, granuleSnd1, -	-- * Partikkel-	PartikkelSpec(..),-	partikkel, +  -- * Partikkel+  PartikkelSpec(..),+  partikkel, -	-- * Fof2+  -- * Fof2 -	Fof2Spec(..),-	fof2, fof2Snd, fof2Snd1,+  Fof2Spec(..),+  fof2, fof2Snd, fof2Snd1, -	-- * Granular delays+  -- * Granular delays -	-- | This block is for granular delay effects. To make granular delay from the granular functions-	-- it has to support reading from table with pointer (phasor).-	-- All functions have the same four parameters: -	---	-- * @maxDelayTime@ -- maximum delay length in seсoncds.  -	---	-- * @delayTime@ -- delay time (it can vary. it's a signal).  -	---	-- * @feedback@ -- amount of feedback. How much of processed signal is mixed to-	--    the delayed signal-	---	-- * @balance@ -- mix between dry and wet signal. 0 is dry only signal. 1 is wet only signl.-	---	-- The rest arguments are taken from the original granular functions.-	grainyDelay, rndGrainyDelay, sndwarpDelay, -	syncgrainDelay, rndSyncgrainDelay, partikkelDelay, fofDelay,	+  -- | This block is for granular delay effects. To make granular delay from the granular functions+  -- it has to support reading from table with pointer (phasor).+  -- All functions have the same four parameters:+  --+  -- * @maxDelayTime@ -- maximum delay length in seсoncds.+  --+  -- * @delayTime@ -- delay time (it can vary. it's a signal).+  --+  -- * @feedback@ -- amount of feedback. How much of processed signal is mixed to+  --    the delayed signal+  --+  -- * @balance@ -- mix between dry and wet signal. 0 is dry only signal. 1 is wet only signl.+  --+  -- The rest arguments are taken from the original granular functions.+  grainyDelay, rndGrainyDelay, sndwarpDelay,+  syncgrainDelay, rndSyncgrainDelay, partikkelDelay, fofDelay, -	-- * Granular effets-	-	-- | The functions are based on the granular delays. -	-- each function is a granular delay with zero feedback and instant delay time.-	grainyFx, rndGrainyFx, sndwarpFx, -	syncgrainFx, rndSyncgrainFx, partikkelFx, fofFx,+  -- * Granular effets -	-- * Csound functions-	csdSndwarp, csdSndwarpst, csdSyncgrain, csdGranule, csdPartikkel+  -- | The functions are based on the granular delays.+  -- each function is a granular delay with zero feedback and instant delay time.+  grainyFx, rndGrainyFx, sndwarpFx,+  syncgrainFx, rndSyncgrainFx, partikkelFx, fofFx,++  -- * Csound functions+  csdSndwarp, csdSndwarpst, csdSyncgrain, csdGranule, csdPartikkel ) where  -- http://www.youtube.com/watch?v=tVW809gMND0  import Data.Default-import Data.Boolean-import Data.List(isSuffixOf)-import Control.Applicative hiding ((<*))-import Control.Monad.Trans.Class import Csound.Dynamic hiding (int, when1, whens) import Csound.Typed -import Csound.Typed.Opcode hiding(partikkel, granule, grain, syncgrain, sndwarp, sndwarpst, fof2)-import qualified Csound.Typed.Opcode as C(partikkel, granule, grain, syncgrain, sndwarp, sndwarpst, fof2)+import Csound.Typed.Opcode hiding(partikkel, granule, grain, syncgrain, sndwarp, sndwarpst, fof2, tab, pitch, tempo)+import qualified Csound.Typed.Opcode as C(granule, sndwarp, sndwarpst, fof2)  import Csound.Air.Wav(PitchSig, TempoSig, lengthSnd) import Csound.Air.Fx(tabDelay, MaxDelayTime, DelayTime, Feedback, Balance) import Csound.Tab-import Csound.SigSpace  -- example --@@ -130,17 +125,12 @@ -- let w a b c = mul 0.1 $ q a + q b + q c -- dac $ at magicCave2 $ (w 0 7 12) + delaySnd 2 (w (-12) (12 + 5) (12 + 7)) + delaySnd 1.3 (w 0 5 24) --w1 = "/home/anton/house2.wav"-w2 = "/home/anton/fox.wav"-w3 = "/home/anton/music/csd/ClassGuit.wav"- ----------------------------------------------------------------- -- partikkel -type GrainRate 	= Sig-type GrainSize 	= Sig-type Pointer 	= Sig+type GrainRate  = Sig+type GrainSize  = Sig+type Pointer  = Sig  type ConstPitchSig = D ----------------------------------------------------------------------@@ -151,78 +141,78 @@ -- -- csound doc: <http://www.csounds.com/manual/html/partikkel.html> data PartikkelSpec = PartikkelSpec-	{ partikkelDistribution		:: Sig-	, partikkelDisttab			:: Tab-	, partikkelSync				:: Sig-	, partikkelEnv2amt			:: Sig-	, partikkelEnv2tab			:: Tab-	, partikkelEnv_attack		:: Tab-	, partikkelEnv_decay		:: Tab-	, partikkelSustain_amount	:: Sig-	, partikkelA_d_ratio		:: Sig	-	, partikkelAmp 				:: Sig	-	, partikkelGainmasks 		:: Tab	-	, partikkelSweepshape 		:: Sig-	, partikkelWavfreqstarttab 	:: Tab-	, partikkelWavfreqendtab 	:: Tab	-	, partikkelWavfm 			:: Sig-	, partikkelFmamptab 		:: Tab-	, partikkelFmenv 			:: Tab-	, partikkelCosine 			:: Tab	-	, partikkelNumpartials 		:: Sig-	, partikkelChroma 			:: Sig-	, partikkelChannelmasks 	:: Tab	-	, partikkelRandommask 		:: Sig	-	, partikkelWaveamptab 		:: Tab	-	, partikkelWavekeys 		:: [Sig]-	, partikkelMax_grains		:: D-	}+  { partikkelDistribution   :: Sig+  , partikkelDisttab      :: Tab+  , partikkelSync       :: Sig+  , partikkelEnv2amt      :: Sig+  , partikkelEnv2tab      :: Tab+  , partikkelEnv_attack   :: Tab+  , partikkelEnv_decay    :: Tab+  , partikkelSustain_amount :: Sig+  , partikkelA_d_ratio    :: Sig+  , partikkelAmp        :: Sig+  , partikkelGainmasks    :: Tab+  , partikkelSweepshape     :: Sig+  , partikkelWavfreqstarttab  :: Tab+  , partikkelWavfreqendtab  :: Tab+  , partikkelWavfm      :: Sig+  , partikkelFmamptab     :: Tab+  , partikkelFmenv      :: Tab+  , partikkelCosine       :: Tab+  , partikkelNumpartials    :: Sig+  , partikkelChroma       :: Sig+  , partikkelChannelmasks   :: Tab+  , partikkelRandommask     :: Sig+  , partikkelWaveamptab     :: Tab+  , partikkelWavekeys     :: [Sig]+  , partikkelMax_grains   :: D+  }  instance Default PartikkelSpec where-	def = PartikkelSpec -		{ partikkelDistribution		= 1-		, partikkelDisttab			= setSize 32768 $ lins [0, 1, 1]-		, partikkelSync				= 0-		, partikkelEnv2amt			= 1-		, partikkelEnv2tab			= setSize 4096 $ winSync-		, partikkelEnv_attack		= noTab-		, partikkelEnv_decay		= noTab-		, partikkelSustain_amount	= 0-		, partikkelA_d_ratio		= 0		-		, partikkelAmp 				= 1-		, partikkelGainmasks 		= noTab		-		, partikkelSweepshape 		= 0-		, partikkelWavfreqstarttab 	= noTab-		, partikkelWavfreqendtab 	= noTab-		, partikkelWavfm 			= 0-		, partikkelFmamptab 		= noTab-		, partikkelFmenv 			= noTab-		, partikkelCosine 			= setSize 8193 $ sines3 [(1, 1, 90)]		-		, partikkelNumpartials 		= 1-		, partikkelChroma 			= 1-		, partikkelChannelmasks 	= noTab-		, partikkelRandommask 		= 0-		, partikkelWaveamptab 		= noTab		-		, partikkelWavekeys 		= [1] -		, partikkelMax_grains		= 1000-		}+  def = PartikkelSpec+    { partikkelDistribution   = 1+    , partikkelDisttab      = setSize 32768 $ lins [0, 1, 1]+    , partikkelSync       = 0+    , partikkelEnv2amt      = 1+    , partikkelEnv2tab      = setSize 4096 $ winSync+    , partikkelEnv_attack   = noTab+    , partikkelEnv_decay    = noTab+    , partikkelSustain_amount = 0+    , partikkelA_d_ratio    = 0+    , partikkelAmp        = 1+    , partikkelGainmasks    = noTab+    , partikkelSweepshape     = 0+    , partikkelWavfreqstarttab  = noTab+    , partikkelWavfreqendtab  = noTab+    , partikkelWavfm      = 0+    , partikkelFmamptab     = noTab+    , partikkelFmenv      = noTab+    , partikkelCosine       = setSize 8193 $ sines3 [(1, 1, 90)]+    , partikkelNumpartials    = 1+    , partikkelChroma       = 1+    , partikkelChannelmasks   = noTab+    , partikkelRandommask     = 0+    , partikkelWaveamptab     = noTab+    , partikkelWavekeys     = [1]+    , partikkelMax_grains   = 1000+    } --- | Randomized parameters for function @grainy@. We can randomize pitch scaleing factor (0 to 1), --- read position (in ratio: 0 to 1), and duration of the grains (in seconds, in magnitude of 0.005 to 0.5). -data RndGrainySpec = RndGrainySpec -	{ rndGrainyPitch	:: Sig-	, rndGrainyPos		:: Sig-	, rndGrainyDur		:: Sig-	}+-- | Randomized parameters for function @grainy@. We can randomize pitch scaleing factor (0 to 1),+-- read position (in ratio: 0 to 1), and duration of the grains (in seconds, in magnitude of 0.005 to 0.5).+data RndGrainySpec = RndGrainySpec+  { rndGrainyPitch  :: Sig+  , rndGrainyPos    :: Sig+  , rndGrainyDur    :: Sig+  }  instance Default RndGrainySpec where-	def = RndGrainySpec-		{ rndGrainyPitch	= 0.25-		, rndGrainyPos		= 0.1-		, rndGrainyDur		= 0.2-		}+  def = RndGrainySpec+    { rndGrainyPitch  = 0.25+    , rndGrainyPos    = 0.1+    , rndGrainyDur    = 0.2+    } --- | +-- | -- Granular synthesizer with "per grain" control --       over many of its parameters.  Has a sync input to --       sychronize its internal grain scheduler clock to an external@@ -253,30 +243,30 @@ -- * @ifiltabs@ -- list of tables (up to 4 values can be used) partikkel :: PartikkelSpec -> GrainRate -> GrainSize -> PitchSig -> [Tab] -> [Pointer] -> Sig partikkel spec kgrainrate kgrainsize kpitch ifiltab apnter = mul 0.2 res-	where-		res = csdPartikkel -				kgrainrate (partikkelDistribution spec) (partikkelDisttab spec) (partikkelSync spec)-				(partikkelEnv2amt spec) (partikkelEnv2tab spec) (partikkelEnv_attack spec) (partikkelEnv_decay spec)-				(partikkelSustain_amount spec) (partikkelA_d_ratio spec) (kgrainsize * 1000) (partikkelAmp spec)-				(partikkelGainmasks spec) kwavfreq (partikkelSweepshape spec) (partikkelWavfreqstarttab spec)-				(partikkelWavfreqendtab spec) (partikkelWavfm spec) (partikkelFmamptab spec) (partikkelFmenv spec)-				(partikkelCosine spec) kgrainrate (partikkelNumpartials spec) (partikkelChroma spec)-				(partikkelChannelmasks spec) (partikkelRandommask spec) -				filtab1 filtab2 filtab3 filtab4-				(partikkelWaveamptab spec)-				apnter1 apnter2 apnter3 apnter4-				keys1 keys2 keys3 keys4-				(partikkelMax_grains spec)+  where+    res = csdPartikkel+        kgrainrate (partikkelDistribution spec) (partikkelDisttab spec) (partikkelSync spec)+        (partikkelEnv2amt spec) (partikkelEnv2tab spec) (partikkelEnv_attack spec) (partikkelEnv_decay spec)+        (partikkelSustain_amount spec) (partikkelA_d_ratio spec) (kgrainsize * 1000) (partikkelAmp spec)+        (partikkelGainmasks spec) kwavfreq (partikkelSweepshape spec) (partikkelWavfreqstarttab spec)+        (partikkelWavfreqendtab spec) (partikkelWavfm spec) (partikkelFmamptab spec) (partikkelFmenv spec)+        (partikkelCosine spec) kgrainrate (partikkelNumpartials spec) (partikkelChroma spec)+        (partikkelChannelmasks spec) (partikkelRandommask spec)+        filtab1 filtab2 filtab3 filtab4+        (partikkelWaveamptab spec)+        apnter1 apnter2 apnter3 apnter4+        keys1 keys2 keys3 keys4+        (partikkelMax_grains spec) -		iorig		= 		1 / (ftlen(head ifiltab)/getSampleRate) -		kwavfreq	= 		sig iorig * kpitch+    iorig   =     1 / (ftlen(head ifiltab)/getSampleRate)+    kwavfreq  =     sig iorig * kpitch -		filtab1 : filtab2 : filtab3 : filtab4 : _ = cycle ifiltab -		apnter1 : apnter2 : apnter3 : apnter4 : _ = cycle apnter-		keys1   : keys2   : keys3   : keys4   : _ = cycle (partikkelWavekeys spec)+    filtab1 : filtab2 : filtab3 : filtab4 : _ = cycle ifiltab+    apnter1 : apnter2 : apnter3 : apnter4 : _ = cycle apnter+    keys1   : keys2   : keys3   : keys4   : _ = cycle (partikkelWavekeys spec)  -- | Simplified version of partikkel. The partikkel for mono sounds.--- +-- -- > grainy1 speed grainrate grainsize kfreqFactor file -- -- * @speed@ - speed of the playback@@ -290,7 +280,7 @@ grainy1 = grainyChn 1  -- | Simplified version of partikkel. The partikkel for stereo sounds.--- +-- -- > grainy1 speed grainrate grainsize kfreqFactor file -- -- * @speed@ - speed of the playback@@ -301,12 +291,12 @@ -- -- * @file@ - filename of an audio file to read the grains. grainy :: GrainRate -> GrainSize -> TempoSig -> PitchSig -> String -> Sig2-grainy kgrainrate kgrainsize kspeed kfreqFactor file = (f 1, f 2)	-	where f n = grainyChn n kgrainrate kgrainsize kspeed kfreqFactor file+grainy kgrainrate kgrainsize kspeed kfreqFactor file = (f 1, f 2)+  where f n = grainyChn n kgrainrate kgrainsize kspeed kfreqFactor file  grainyChn :: Int -> GrainRate -> GrainSize -> TempoSig -> PitchSig -> String -> Sig-grainyChn n kgrainrate kgrainsize kspeed kpitch file = -	ptrGrainy kgrainrate kgrainsize kpitch (grainyTab n file) (grainyPtr kspeed file)+grainyChn n kgrainrate kgrainsize kspeed kpitch file =+  ptrGrainy kgrainrate kgrainsize kpitch (grainyTab n file) (grainyPtr kspeed file)  -- | Randomized version of @grainy1@. rndGrainy1 :: RndGrainySpec -> GrainRate -> GrainSize -> TempoSig -> PitchSig -> String -> SE Sig@@ -315,18 +305,18 @@ -- | Randomized version of @grainy@. rndGrainy :: RndGrainySpec -> GrainRate -> GrainSize -> TempoSig -> PitchSig -> String -> SE Sig2 rndGrainy spec kgrainrate kgrainsize kspeed kfreqFactor file = do-	asig1 <- f 1140-	asig2 <- f 2-	return (asig1, asig2)-	where f n = rndGrainyChn n spec kgrainrate kgrainsize kspeed kfreqFactor file+  asig1 <- f 1140+  asig2 <- f 2+  return (asig1, asig2)+  where f n = rndGrainyChn n spec kgrainrate kgrainsize kspeed kfreqFactor file  rndGrainyChn :: Int -> RndGrainySpec -> GrainRate -> GrainSize -> TempoSig -> PitchSig -> String -> SE Sig-rndGrainyChn n spec kgrainrate kgrainsize kspeed kpitch file = -	rndPtrGrainy spec kgrainrate kgrainsize kpitch (grainyTab n file) (grainyPtr kspeed file)+rndGrainyChn n spec kgrainrate kgrainsize kspeed kpitch file =+  rndPtrGrainy spec kgrainrate kgrainsize kpitch (grainyTab n file) (grainyPtr kspeed file)   -- | Simplified version of partikkel with pointer access to the table. The partikkel for mono sounds.--- +-- -- > ptrGrainy grainrate grainsize kfreqFactor tab apnter -- -- * @speed@ - speed of the playback@@ -339,11 +329,11 @@ -- -- * @apnter@ - pointer to the table. pointer is relative to total size (0 to 1). ptrGrainy :: GrainRate -> GrainSize -> PitchSig -> Tab -> Pointer -> Sig-ptrGrainy kgrainrate kgrainsize kcent ifiltab apnter = -	partikkel def kgrainrate kgrainsize kcent [ifiltab] [apnter]+ptrGrainy kgrainrate kgrainsize kcent ifiltab apnter =+  partikkel def kgrainrate kgrainsize kcent [ifiltab] [apnter]  -- | Simplified version of partikkel with pointer access to the table. The partikkel for mono sounds.--- +-- -- > ptrGrainy grainrate grainsize kfreqFactor tab apnter -- -- * @speed@ - speed of the playback@@ -357,10 +347,10 @@ -- * @apnter@ - pointer to the table in seconds ptrGrainySnd :: GrainRate -> GrainSize -> PitchSig -> String -> Pointer -> Sig2 ptrGrainySnd kgrainrate kgrainsize kcent file apnter = (f (wavs file 0 WavLeft), f (wavs file 0 WavRight))-	where f tab = partikkel def kgrainrate kgrainsize kcent [tab] [apnter / sig (lengthSnd file)]+  where f tab = partikkel def kgrainrate kgrainsize kcent [tab] [apnter / sig (lengthSnd file)]  -- | Simplified version of partikkel with pointer access to the table. The partikkel for mono sounds.--- +-- -- > ptrGrainy grainrate grainsize kfreqFactor tab apnter -- -- * @speed@ - speed of the playback@@ -374,24 +364,24 @@ -- * @apnter@ - pointer to the table in seconds ptrGrainySnd1 :: GrainRate -> GrainSize -> PitchSig -> String -> Pointer -> Sig ptrGrainySnd1 kgrainrate kgrainsize kcent file apnter = f (wavs file 0 WavLeft)-	where f tab = partikkel def kgrainrate kgrainsize kcent [tab] [apnter / sig (lengthSnd file)]+  where f tab = partikkel def kgrainrate kgrainsize kcent [tab] [apnter / sig (lengthSnd file)]  -- | Randomized version of @ptrGrainy@. rndPtrGrainy :: RndGrainySpec -> GrainRate -> GrainSize -> PitchSig -> Tab -> Pointer -> SE Sig rndPtrGrainy rndSpec kgrainrate kgrainsize kpitch ifiltab apnter = do-	kpitchRandVal <- rand (rndGrainyPitch rndSpec)-	arndpos <- linrand (rndGrainyPos rndSpec)-	krndsize <- rand (rndGrainyDur rndSpec)-	return $ ptrGrainy kgrainrate (kgrainsize + krndsize) (kpitch + kpitchRandVal) ifiltab (apnter + arndpos)+  kpitchRandVal <- rand (rndGrainyPitch rndSpec)+  arndpos <- linrand (rndGrainyPos rndSpec)+  krndsize <- rand (rndGrainyDur rndSpec)+  return $ ptrGrainy kgrainrate (kgrainsize + krndsize) (kpitch + kpitchRandVal) ifiltab (apnter + arndpos)  grainyTab :: Int -> String -> Tab grainyTab n file = wavs file 0 (if n == 1 then WavLeft else WavRight)  grainyPtr :: Sig -> String -> Sig grainyPtr kspeed file = apnter-	where-		ifildur = filelen $ text file		-		apnter = phasor (kspeed / sig ifildur)+  where+    ifildur = filelen $ text file+    apnter = phasor (kspeed / sig ifildur)  ----------------------------------------------------------------- -- granule@@ -401,9 +391,9 @@  fromGranuleMode :: GranuleMode -> D fromGranuleMode x = case x of-	GranuleForward -> 1-	GranuleBackward -> -1-	GranuleRandom -> 0+  GranuleForward -> 1+  GranuleBackward -> -1+  GranuleRandom -> 0  -- | Secondary parameters for @granule@. We can use the @def@ to get the defaults. --@@ -415,7 +405,7 @@ -- -- * Mode  - playback mode (see @GranuleMode@, play forward is the default) ----- * Skip_os - gskip pointer random offset in sec, 0 will be no offset (0.5 is default). +-- * Skip_os - gskip pointer random offset in sec, 0 will be no offset (0.5 is default). -- -- * Gap_os - gap random offset in ratios (0 to 1) of the gap size, 0 gives no offset (0.5 is default). --@@ -427,56 +417,57 @@ -- -- * Dec  - decay of the grain envelope in ratios (0 to 1) of grain size (0.3 is default). ---data GranuleSpec = GranuleSpec -	{ granuleGap   :: Sig-	, granuleVoice :: D-	, granuleRatio :: D-	, granuleMode  :: GranuleMode-	, granuleSkip_os :: D-	, granuleGap_os :: D-	, granuleSize_os :: D-	, granuleSeed :: D-	, granuleAtt   :: D-	, granuleDec   :: D	-	}+data GranuleSpec = GranuleSpec+  { granuleGap   :: Sig+  , granuleVoice :: D+  , granuleRatio :: D+  , granuleMode  :: GranuleMode+  , granuleSkip_os :: D+  , granuleGap_os :: D+  , granuleSize_os :: D+  , granuleSeed :: D+  , granuleAtt   :: D+  , granuleDec   :: D+  }  instance Default GranuleMode where-	def = GranuleForward+  def = GranuleForward  instance Default GranuleSpec where-	def = GranuleSpec -		{ granuleGap = 0-		, granuleVoice = 64-		, granuleRatio = 1-		, granuleMode  = def-		, granuleSkip_os = 0.5-		, granuleGap_os = 0.5-		, granuleSize_os = 0.5-		, granuleSeed = 0.5-		, granuleAtt   = 0.3-		, granuleDec   = 0.3	-		}+  def = GranuleSpec+    { granuleGap = 0+    , granuleVoice = 64+    , granuleRatio = 1+    , granuleMode  = def+    , granuleSkip_os = 0.5+    , granuleGap_os = 0.5+    , granuleSize_os = 0.5+    , granuleSeed = 0.5+    , granuleAtt   = 0.3+    , granuleDec   = 0.3+    } +toPercent :: D -> D toPercent = (100 * )  -- | A more complex granular synthesis texture generator.--- --- granule is a Csound unit generator which employs a wavetable as input --- to produce granularly synthesized audio output. Wavetable data may be --- generated by any of the GEN subroutines such as GEN01 which reads an --- audio data file into a wavetable. This enable a sampled sound to be used --- as the source for the grains. Up to 128 voices are implemented internally. --- The maximum number of voices can be increased by redefining the variable MAXVOICE --- in the grain4.h file. granule has a build-in random number generator to handle --- all the random offset parameters. Thresholding is also implemented to scan the source --- function table at initialization stage. This facilitates features such as skipping +--+-- granule is a Csound unit generator which employs a wavetable as input+-- to produce granularly synthesized audio output. Wavetable data may be+-- generated by any of the GEN subroutines such as GEN01 which reads an+-- audio data file into a wavetable. This enable a sampled sound to be used+-- as the source for the grains. Up to 128 voices are implemented internally.+-- The maximum number of voices can be increased by redefining the variable MAXVOICE+-- in the grain4.h file. granule has a build-in random number generator to handle+-- all the random offset parameters. Thresholding is also implemented to scan the source+-- function table at initialization stage. This facilitates features such as skipping -- silence passage between sentences. -- -- > granule spec chord grainSize ftab -- -- * @spec@ -- secondary parameters. We can use @def@ to get the defaults. ----- * @chord :: [D]@ -- the list of pitch factors to scale the original sound. +-- * @chord :: [D]@ -- the list of pitch factors to scale the original sound. --    It can be up to 4 items long. This parameters allows us to create a chords out of grains. -- -- * @grainSize@ -- grain size in sec.@@ -484,95 +475,45 @@ -- * @ftab@ - table with sampled sound. granule :: GranuleSpec -> [ConstPitchSig] -> GrainSize -> Tab -> Sig granule spec chord kgsize ifn = granuleWithLength len spec chord kgsize ifn-	where len = nsamp ifn / getSampleRate+  where len = nsamp ifn / getSampleRate  -- | @granule@ that is defined on stereo audio files. We provide the filename instead of table.--- The rest is the same. +-- The rest is the same. granuleSnd :: GranuleSpec -> [ConstPitchSig] -> GrainSize -> String -> Sig2-granuleSnd spec chord kgsize file = -	( granuleWithLength len spec chord kgsize (wavs file 0 WavLeft)-	, granuleWithLength len spec chord kgsize (wavs file 0 WavRight))-	where len = filelen $ text file+granuleSnd spec chord kgsize file =+  ( granuleWithLength len spec chord kgsize (wavs file 0 WavLeft)+  , granuleWithLength len spec chord kgsize (wavs file 0 WavRight))+  where len = filelen $ text file  -- | @granule@ that is defined on mono audio files. We provide the filename instead of table. -- The rest is the same. granuleSnd1 :: GranuleSpec -> [ConstPitchSig] -> GrainSize -> String -> Sig granuleSnd1 spec chord kgsize file = granuleWithLength len spec chord kgsize (wavs file 0 WavLeft)-	where len = filelen $ text file+  where len = filelen $ text file  granuleWithLength :: D -> GranuleSpec -> [ConstPitchSig] -> GrainSize -> Tab -> Sig-granuleWithLength len spec chord kgsize ifn = mul 0.2 res -	where-		kgap 		= granuleGap spec-		kamp 		= 1-		ivoice      = granuleVoice spec-		iratio      = granuleRatio spec-		imode       = fromGranuleMode $ granuleMode spec-		ithd        = 0-		ipshift     = int $ min (length $ chord) 4-		igskip      = 0-		igskip_os   = toPercent $ granuleSkip_os spec-		ilength     = len-		igap_os     = toPercent $ granuleGap_os spec-		igsize_os   = toPercent $ granuleSize_os spec-		iatt        = toPercent $ granuleAtt spec-		idec        = toPercent $ granuleDec spec-		iseed       = granuleSeed spec-		ipitch1 : ipitch2 : ipitch3 : ipitch4 : _ = chord ++ [1, 1, 1, 1]-		-		-- create the granular synthesis textures; one for each channel-		res  = csdGranule kamp ivoice iratio imode ithd ifn ipshift igskip-				igskip_os ilength kgap igap_os kgsize igsize_os iatt idec `withDs` [iseed, ipitch1, ipitch2, ipitch3, ipitch4]--main = print "hi"---------------------------------------------------------------------- grain--{--	grain doesn't work with deferred tables--csdGrain = C.grain--data GrainSpec = GrainSpec -	{ grainPitch :: Sig-	, grainAmpoff :: Sig-	, grainPitchoff :: Sig-	, grainDur :: Sig-	, grainMaxDur :: D-	, grainWin :: Tab-	, grainRandom :: Bool-	}--instance Default GrainSpec where-	def = GrainSpec-		{ grainPitch 		= 1-		, grainAmpoff		= 0-		, grainPitchoff 	= 0-		, grainDur 			= 1-		, grainMaxDur		= 1-		, grainWin			= setSize 1025 $ winHanning [1]-		, grainRandom		= True-		}--grain :: GrainSpec -> Sig -> Tab -> Sig-grain spec kdens ftab = setRnd $ csdGrain 1 (grainPitch spec * sig (getSampleRate / ftlen ftab)) kdens -	(grainAmpoff spec) (grainPitchoff spec) (grainDur spec) ftab (grainWin spec) (grainMaxDur spec) -	where setRnd = if (grainRandom spec) then id else ( `withD` 1)--grainSnd :: GrainSpec -> Sig -> String -> Sig2-grainSnd spec kdens file = (grainSndChn 1 spec kdens file, grainSndChn 2 spec kdens file)--grainSnd1 :: GrainSpec -> Sig -> String -> Sig-grainSnd1 = grainSndChn 1+granuleWithLength len spec chord kgsize ifn = mul 0.2 res+  where+    kgap    = granuleGap spec+    kamp    = 1+    ivoice      = granuleVoice spec+    iratio      = granuleRatio spec+    imode       = fromGranuleMode $ granuleMode spec+    ithd        = 0+    ipshift     = int $ min (length $ chord) 4+    igskip      = 0+    igskip_os   = toPercent $ granuleSkip_os spec+    ilength     = len+    igap_os     = toPercent $ granuleGap_os spec+    igsize_os   = toPercent $ granuleSize_os spec+    iatt        = toPercent $ granuleAtt spec+    idec        = toPercent $ granuleDec spec+    iseed       = granuleSeed spec+    ipitch1 : ipitch2 : ipitch3 : ipitch4 : _ = chord ++ [1, 1, 1, 1] -grainSndChn :: Int -> GrainSpec -> Sig -> String -> Sig-grainSndChn n spec kdens file = setRnd $ csdGrain 1 (grainPitch spec / sig (filelen $ text file)) kdens -	(grainAmpoff spec) (grainPitchoff spec) (grainDur spec) ftab (grainWin spec) (grainMaxDur spec) -	where -		setRnd = if (grainRandom spec) then id else ( `withD` 1)-		ftab = wavs file 0 (if (n == 1) then WavLeft else WavRight)--}+    -- create the granular synthesis textures; one for each channel+    res  = csdGranule kamp ivoice iratio imode ithd ifn ipshift igskip+        igskip_os ilength kgap igap_os kgsize igsize_os iatt idec `withDs` [iseed, ipitch1, ipitch2, ipitch3, ipitch4]  --------------------------------------------------------- -- syncgrain@@ -582,43 +523,43 @@ -- * @Win@ -- grain window function (half-sine is used by default) -- -- * @Overlap@ -- grain overlap (use values in range 0 to 100, the 25 is default)-data SyncgrainSpec = SyncgrainSpec -	{ syncgrainWin 	 :: Tab-	, syncgrainOverlap :: D	-	}+data SyncgrainSpec = SyncgrainSpec+  { syncgrainWin   :: Tab+  , syncgrainOverlap :: D+  }  -- | Randomized parameters for arguments (in range 0 to 1).-data RndSyncgrainSpec = RndSyncgrainSpec -	{ rndSyncTimescale :: Sig-	, rndSyncgrainPitch :: Sig-	, rndSyncgrainGrainDur :: Sig-	}+data RndSyncgrainSpec = RndSyncgrainSpec+  { rndSyncTimescale :: Sig+  , rndSyncgrainPitch :: Sig+  , rndSyncgrainGrainDur :: Sig+  }  instance  Default SyncgrainSpec where-	def = SyncgrainSpec -		{ syncgrainWin 	   = setSize 16384 $ sines3 [(0.5, 1, 0)]-		, syncgrainOverlap   = 25		-		}+  def = SyncgrainSpec+    { syncgrainWin     = setSize 16384 $ sines3 [(0.5, 1, 0)]+    , syncgrainOverlap   = 25+    }  instance Default RndSyncgrainSpec where-	def = RndSyncgrainSpec -		{ rndSyncTimescale     = 0.5-		, rndSyncgrainPitch    = 0.51 -		, rndSyncgrainGrainDur = 0.2-		}+  def = RndSyncgrainSpec+    { rndSyncTimescale     = 0.5+    , rndSyncgrainPitch    = 0.51+    , rndSyncgrainGrainDur = 0.2+    }  -- | Synchronous granular synthesis. ----- syncgrain implements synchronous granular synthesis. --- The source sound for the grains is obtained by reading --- a function table containing the samples of the source waveform. --- For sampled-sound sources, GEN01 is used. syncgrain will accept +-- syncgrain implements synchronous granular synthesis.+-- The source sound for the grains is obtained by reading+-- a function table containing the samples of the source waveform.+-- For sampled-sound sources, GEN01 is used. syncgrain will accept -- deferred allocation tables. -- -- > syncgrain spec graidDuration timeScale PitchSig ftab -- -- * @spec@ - secondary params (use @def@ to get the defaults)--- +-- -- * @graidDuration@ - duration of grains in seconds. -- -- * @timeScale@ - tempo scaling factor.@@ -626,61 +567,59 @@ -- * @PitchSig@ - pitch scaling factor. -- -- * @ftab@ - table with sampled sound.-syncgrain :: SyncgrainSpec -> GrainSize -> TempoSig -> PitchSig -> Tab -> Sig +syncgrain :: SyncgrainSpec -> GrainSize -> TempoSig -> PitchSig -> Tab -> Sig syncgrain spec kgrdur ktimescale kpitch ftab = mul 0.2 res-	where-		kgroverlap = sig $ (syncgrainOverlap spec) / 2+  where+    kgroverlap = sig $ (syncgrainOverlap spec) / 2 -		ko1 = int' (kgroverlap + 0.15)-		kfr = ko1 / kgrdur -		kps = 1 / ko1+    ko1 = int' (kgroverlap + 0.15)+    kfr = ko1 / kgrdur+    kps = 1 / ko1 -		awp = phasor (sig $ getSampleRate / ftlen ftab)-		res = csdSyncgrain 1 kfr kpitch kgrdur (kps * ktimescale) ftab (syncgrainWin spec) (syncgrainOverlap spec)+    res = csdSyncgrain 1 kfr kpitch kgrdur (kps * ktimescale) ftab (syncgrainWin spec) (syncgrainOverlap spec)  -- | The syncgrain with randomized parameters. rndSyncgrain :: RndSyncgrainSpec -> SyncgrainSpec -> GrainSize -> TempoSig -> PitchSig -> Tab -> SE Sig-rndSyncgrain rndSpec spec kgrdur ktimescale kpitch ftab = do	-		rndSyncGrainDur <- rnd (rndSyncgrainGrainDur rndSpec)-		rndSyncGrainPitch <- birnd (rndSyncgrainPitch rndSpec)-		rndSyncGrainTimescale <- birnd (rndSyncTimescale rndSpec)-		let kgroverlap = sig $ (syncgrainOverlap spec) / 2-		    ko1 = int' (kgroverlap + 0.15)-		    kgr = kgrdur + rndSyncGrainDur-		    kfr = ko1 / kgr -		    kps = 1 / ko1+rndSyncgrain rndSpec spec kgrdur ktimescale kpitch ftab = do+    rndSyncGrainDur <- rnd (rndSyncgrainGrainDur rndSpec)+    rndSyncGrainPitch <- birnd (rndSyncgrainPitch rndSpec)+    rndSyncGrainTimescale <- birnd (rndSyncTimescale rndSpec)+    let kgroverlap = sig $ (syncgrainOverlap spec) / 2+        ko1 = int' (kgroverlap + 0.15)+        kgr = kgrdur + rndSyncGrainDur+        kfr = ko1 / kgr+        kps = 1 / ko1 -		    awp = phasor (sig $ getSampleRate / ftlen ftab)-		    res = csdSyncgrain 1 kfr (kpitch + rndSyncGrainPitch) kgr (kps * ktimescale + rndSyncGrainTimescale) ftab (syncgrainWin spec) (syncgrainOverlap spec)-		return res+        res = csdSyncgrain 1 kfr (kpitch + rndSyncGrainPitch) kgr (kps * ktimescale + rndSyncGrainTimescale) ftab (syncgrainWin spec) (syncgrainOverlap spec)+    return res  -- | syncgrain that is defined on stereo audio files. We provide the filename instead of table. -- The rest is the same. syncgrainSnd :: SyncgrainSpec -> GrainSize -> TempoSig -> PitchSig -> String -> Sig2-syncgrainSnd spec kgrdur ktimescale kpitch  file = -	(f $ wavs file 0 WavLeft, f $ wavs file 0 WavRight)-	where f = syncgrain spec kgrdur ktimescale kpitch +syncgrainSnd spec kgrdur ktimescale kpitch  file =+  (f $ wavs file 0 WavLeft, f $ wavs file 0 WavRight)+  where f = syncgrain spec kgrdur ktimescale kpitch  -- | syncgrain that is defined on mono audio files. We provide the filename instead of table. -- The rest is the same. syncgrainSnd1 :: SyncgrainSpec -> GrainSize -> TempoSig -> PitchSig -> String -> Sig-syncgrainSnd1 spec kgrdur ktimescale kpitch  file = f $ wavs file 0 WavLeft	-	where f = syncgrain spec kgrdur ktimescale kpitch +syncgrainSnd1 spec kgrdur ktimescale kpitch  file = f $ wavs file 0 WavLeft+  where f = syncgrain spec kgrdur ktimescale kpitch  -- | rndSyncgrain that is defined on stereo audio files. We provide the filename instead of table. -- The rest is the same. rndSyncgrainSnd :: RndSyncgrainSpec -> SyncgrainSpec -> GrainSize -> TempoSig -> PitchSig -> String -> SE Sig2 rndSyncgrainSnd rndSpec spec kgrdur ktimescale kpitch  file = do-	aleft  <- f $ wavs file 0 WavLeft-	aright <- f $ wavs file 0 WavRight-	return (aleft, aright)-	where f = rndSyncgrain rndSpec spec kgrdur ktimescale kpitch +  aleft  <- f $ wavs file 0 WavLeft+  aright <- f $ wavs file 0 WavRight+  return (aleft, aright)+  where f = rndSyncgrain rndSpec spec kgrdur ktimescale kpitch  -- | rndSyncgrain that is defined on mono audio files. We provide the filename instead of table. -- The rest is the same. rndSyncgrainSnd1 :: RndSyncgrainSpec -> SyncgrainSpec -> GrainSize -> TempoSig -> PitchSig -> String -> SE Sig-rndSyncgrainSnd1 rndSpec spec kgrdur ktimescale kpitch  file = f $ wavs file 0 WavLeft	-	where f = rndSyncgrain rndSpec spec kgrdur ktimescale kpitch +rndSyncgrainSnd1 rndSpec spec kgrdur ktimescale kpitch  file = f $ wavs file 0 WavLeft+  where f = rndSyncgrain rndSpec spec kgrdur ktimescale kpitch  ------------------------------------------------------- -- sndwarp@@ -689,49 +628,49 @@ -- -- * @WinSize@ - window size in seconds (not in samples as in Csound!). The default is 0.1 ----- * @Randw@ -  the bandwidth of a random number generator. +-- * @Randw@ -  the bandwidth of a random number generator. --    The random numbers will be added to iwsize. It's measured in ratio to WinSize. --    So the 1 means the one WinSize length. The default is 0.3 ----- * @Overlap@  - determines the density of overlapping windows. The default value is 50. +-- * @Overlap@  - determines the density of overlapping windows. The default value is 50. --  It's in range (0 to 100)-data SndwarpSpec = SndwarpSpec -	{ sndwarpWinSize :: D-	, sndwarpRandw   :: D-	, sndwarpOvelrap :: D-	, sndwarpWin     :: Tab-	}+data SndwarpSpec = SndwarpSpec+  { sndwarpWinSize :: D+  , sndwarpRandw   :: D+  , sndwarpOvelrap :: D+  , sndwarpWin     :: Tab+  }  instance Default SndwarpSpec where-	def = SndwarpSpec-		{ sndwarpWinSize  = 0.1-		, sndwarpRandw    = 0.3-		, sndwarpOvelrap  = 50-		, sndwarpWin      = setSize 16384 $ sines3 [(0.5, 1, 0)]-		}+  def = SndwarpSpec+    { sndwarpWinSize  = 0.1+    , sndwarpRandw    = 0.3+    , sndwarpOvelrap  = 50+    , sndwarpWin      = setSize 16384 $ sines3 [(0.5, 1, 0)]+    }  -- | Simple sndwarp with scaling mode (corresponds to Csound's @initmode == 0@). ----- > sndwarp spec resample speed ftab +-- > sndwarp spec resample speed ftab -- -- * @spec@ - secondary params (use @def@ to get the defaults) ----- * @resample@ -  the factor by which to change the pitch of the sound. For example, a value of 2 will produce a +-- * @resample@ -  the factor by which to change the pitch of the sound. For example, a value of 2 will produce a --     sound one octave higher than the original. The timing of the sound, however, will not be altered. ----- * @speed@  - the factor by which to change the tempo of the sound. +-- * @speed@  - the factor by which to change the tempo of the sound. -- -- * @ftab@ -- table with the samples sndwarp :: SndwarpSpec -> TempoSig -> PitchSig -> Tab -> Sig-sndwarp spec kspeed xresample ftab = mul 0.2 $ csdSndwarp 1 kspeed xresample ftab 0 -	(getSampleRate * sndwarpWinSize spec) (getSampleRate * sndwarpRandw spec) -	(sndwarpOvelrap spec) (sndwarpWin spec) 0+sndwarp spec kspeed xresample ftab = mul 0.2 $ csdSndwarp 1 kspeed xresample ftab 0+  (getSampleRate * sndwarpWinSize spec) (getSampleRate * sndwarpRandw spec)+  (sndwarpOvelrap spec) (sndwarpWin spec) 0  -- | Stereo version of the @sndwarp@. sndwarpst :: SndwarpSpec -> TempoSig -> PitchSig -> Tab -> Sig2-sndwarpst spec xspeed xresample ftab = mul 0.2 $ csdSndwarpst 1 xspeed xresample ftab 0 -	(getSampleRate * sndwarpWinSize spec) (getSampleRate * sndwarpRandw spec) -	(sndwarpOvelrap spec) (sndwarpWin spec) 0+sndwarpst spec xspeed xresample ftab = mul 0.2 $ csdSndwarpst 1 xspeed xresample ftab 0+  (getSampleRate * sndwarpWinSize spec) (getSampleRate * sndwarpRandw spec)+  (sndwarpOvelrap spec) (sndwarpWin spec) 0  -- | Sndwarp that is defined on stereo audio files. We provide the filename instead of table. -- The rest is the same.@@ -744,28 +683,28 @@ sndwarpSnd1 spec kspeed xresample file = sndwarp spec kspeed xresample (wavs file 0 WavLeft)  --- | The simple sndwarp with pointer (Csound @initmode = 1@). +-- | The simple sndwarp with pointer (Csound @initmode = 1@). -- -- > sndwarp spec resample ftab ptr -- -- * @spec@ - secondary params (use @def@ to get the defaults) ----- * @resample@ -  the factor by which to change the pitch of the sound. For example, a value of 2 will produce a +-- * @resample@ -  the factor by which to change the pitch of the sound. For example, a value of 2 will produce a --     sound one octave higher than the original. The timing of the sound, however, will not be altered. -- -- * @ftab@ -- table with the samples ----- * @ptr@  - pointer to read the table (in seconds). +-- * @ptr@  - pointer to read the table (in seconds). ptrSndwarp :: SndwarpSpec -> PitchSig -> Tab -> Pointer -> Sig-ptrSndwarp spec xresample ftab xptr = mul 0.2 $ csdSndwarp 1 xptr xresample ftab 0 -	(getSampleRate * sndwarpWinSize spec) (getSampleRate * sndwarpRandw spec) -	(sndwarpOvelrap spec) (sndwarpWin spec) 1+ptrSndwarp spec xresample ftab xptr = mul 0.2 $ csdSndwarp 1 xptr xresample ftab 0+  (getSampleRate * sndwarpWinSize spec) (getSampleRate * sndwarpRandw spec)+  (sndwarpOvelrap spec) (sndwarpWin spec) 1  -- | Stereo version of @ptrSndwarp@. ptrSndwarpst :: SndwarpSpec -> PitchSig -> Tab -> Pointer -> Sig2-ptrSndwarpst spec xresample ftab xptr = csdSndwarpst 1 xptr xresample ftab 0 -	(getSampleRate * sndwarpWinSize spec) (getSampleRate * sndwarpRandw spec) -	(sndwarpOvelrap spec) (sndwarpWin spec) 1+ptrSndwarpst spec xresample ftab xptr = csdSndwarpst 1 xptr xresample ftab 0+  (getSampleRate * sndwarpWinSize spec) (getSampleRate * sndwarpRandw spec)+  (sndwarpOvelrap spec) (sndwarpWin spec) 1  -- | ptrSndwarp that is defined on stereo audio files. We provide the filename instead of table. -- The rest is the same.@@ -782,69 +721,68 @@   -- | Defaults for @fof2@ opcode.-data Fof2Spec = Fof2Spec -	{ fof2TimeMod  :: Sig-	, fof2PitchMod :: Sig-	, fof2Oct   :: Sig -	, fof2Band  :: Sig-	, fof2Rise  :: Sig-	, fof2Decay :: Sig-	, fof2Gliss :: Sig-	, fof2Win   :: Tab-	}+data Fof2Spec = Fof2Spec+  { fof2TimeMod  :: Sig+  , fof2PitchMod :: Sig+  , fof2Oct   :: Sig+  , fof2Band  :: Sig+  , fof2Rise  :: Sig+  , fof2Decay :: Sig+  , fof2Gliss :: Sig+  , fof2Win   :: Tab+  }  instance Default Fof2Spec where-	def = Fof2Spec-		{ fof2TimeMod  	= 0.2-		, fof2PitchMod 	= 0 -		, fof2Oct   		= 0-		, fof2Band  		= 0-		, fof2Rise  		= 0.5-		, fof2Decay 		= 0.5-		, fof2Gliss 		= 0-		, fof2Win   		= setSize 8192 $ sines4 [(0.5, 1, 270, 1)]-		}+  def = Fof2Spec+    { fof2TimeMod   = 0.2+    , fof2PitchMod  = 0+    , fof2Oct       = 0+    , fof2Band      = 0+    , fof2Rise      = 0.5+    , fof2Decay     = 0.5+    , fof2Gliss     = 0+    , fof2Win       = setSize 8192 $ sines4 [(0.5, 1, 270, 1)]+    }  -- | Reimplementation of fof2 opcode for stereo  audio files. fof2Snd :: Fof2Spec -> GrainRate -> GrainSize -> TempoSig -> String -> Sig2 fof2Snd spec kgrainrate kgrainsize kspeed file = (f 1, f 2)-	where f n = fof2Chn n spec kgrainrate kgrainsize kspeed file+  where f n = fof2Chn n spec kgrainrate kgrainsize kspeed file  -- | Reimplementation of fof2 opcode for mono audio files. fof2Snd1 :: Fof2Spec -> GrainRate -> GrainSize -> TempoSig -> String -> Sig fof2Snd1 spec kgrainrate kgrainsize kspeed file = f 1-	where f n = fof2Chn n spec kgrainrate kgrainsize kspeed file+  where f n = fof2Chn n spec kgrainrate kgrainsize kspeed file  fof2Chn :: Int -> Fof2Spec -> GrainRate -> GrainSize -> TempoSig -> String -> Sig-fof2Chn n spec kgrainrate kgrainsize kspeed file = -	fof2 spec kgrainrate kgrainsize (grainyTab n file) (grainyPtr kspeed file)+fof2Chn n spec kgrainrate kgrainsize kspeed file =+  fof2 spec kgrainrate kgrainsize (grainyTab n file) (grainyPtr kspeed file)  -- | Reimplementation of fof2 opcode. fof2 :: Fof2Spec -> GrainRate -> GrainSize -> Tab -> Pointer -> Sig-fof2 spec grainRate grainSize buf kphs = go (ftlen buf) buf kphs-	where-		kfund = grainRate-		kris  = fof2Rise spec-		kdec  = fof2Decay spec-		kband = fof2Band spec-		koct  = fof2Oct spec-		kgliss = fof2Gliss spec+fof2 spec grainRate grainSize buf kphs = go (ftlen buf)+  where+    kfund = grainRate+    kris  = fof2Rise spec+    kdec  = fof2Decay spec+    kband = fof2Band spec+    koct  = fof2Oct spec+    kgliss = fof2Gliss spec -		go :: D -> Tab -> Sig -> Sig-		go tabLen buf kphs = do			    -			csdFof2 (ampdbfs (-8)) kfund kform koct kband (kris * kdur) -				kdur (kdec * kdur) 100	giLive giSigRise 86400 kphs kgliss-			where-				kdur = grainSize / kfund				-				kform = (sig $ getSampleRate / tabLen)	-				giSigRise = fof2Win spec-				giLive = buf+    go tabLen = do+      csdFof2 (ampdbfs (-8)) kfund kform koct kband (kris * kdur)+        kdur (kdec * kdur) 100  giLive giSigRise 86400 kphs kgliss+      where+        kdur = grainSize / kfund+        kform = (sig $ getSampleRate / tabLen)+        giSigRise = fof2Win spec+        giLive = buf  ------------------------------------------------------------------------ -- granular effects  -- partikkelDelay :: PartikkelSpec -> D -> Sig -> GrainRate -> GrainSize -> Sig -> Sig -> SE Sig--- partikkelDelay spec maxLength delTim +-- partikkelDelay spec maxLength delTim  -- | Granular delay effect for fof2. Good values for grain rate and size are --@@ -852,68 +790,75 @@ -- > grainSize = 2.5 fofDelay :: MaxDelayTime -> DelayTime -> Feedback -> Balance -> Fof2Spec -> GrainRate -> GrainSize -> Sig -> SE Sig fofDelay maxLength delTim kfeed kbalance spec grainRate grainSize asig = do-	rndTmod <- rnd31 kTmod 1-	rndFmod <- rnd31 kFmod 1-	tabDelay (go rndFmod tabLen) maxLength (delTim + rndTmod) kfeed kbalance asig-	where -		kTmod = fof2TimeMod spec-		kFmod = fof2PitchMod spec-		kfund = grainRate-		kris  = fof2Rise spec-		kdec  = fof2Decay spec-		kband = fof2Band spec-		koct  = fof2Oct spec-		kgliss = fof2Gliss spec+  rndTmod <- rnd31 kTmod 1+  rndFmod <- rnd31 kFmod 1+  tabDelay (go rndFmod) maxLength (delTim + rndTmod) kfeed kbalance asig+  where+    kTmod = fof2TimeMod spec+    kFmod = fof2PitchMod spec+    kfund = grainRate+    kris  = fof2Rise spec+    kdec  = fof2Decay spec+    kband = fof2Band spec+    koct  = fof2Oct spec+    kgliss = fof2Gliss spec -		tabLen = tabSizeSecondsPower2 maxLength+    tabLen = tabSizeSecondsPower2 maxLength -		go :: Sig -> D -> Tab -> Sig -> SE Sig-		go kFmod tabLen buf kphs = do			    -			return $ csdFof2 (ampdbfs (-8)) kfund kform koct kband (kris * kdur) -						kdur (kdec * kdur) 100	giLive giSigRise 86400 kphs kgliss-			where-				kdur = grainSize / kfund				-				kform   = (1+kFmod)*(sig $ getSampleRate / tabLen)			+    go :: Sig -> Tab -> Sig -> SE Sig+    go kFmodSig buf kphs = do+      return $ csdFof2 (ampdbfs (-8)) kfund kform koct kband (kris * kdur)+            kdur (kdec * kdur) 100  giLive giSigRise 86400 kphs kgliss+      where+        kdur = grainSize / kfund+        kform   = (1+kFmodSig)*(sig $ getSampleRate / tabLen) -				giSigRise = fof2Win spec-				giLive = buf+        giSigRise = fof2Win spec+        giLive = buf  -- | Granular delay effect for @grainy@. grainyDelay :: MaxDelayTime -> DelayTime -> Feedback -> Balance -> GrainRate -> GrainSize -> PitchSig -> Sig -> SE Sig grainyDelay maxDel delTime kfeed kbalance grainRate grainSize pitch asig = tabDelay go maxDel delTime kfeed kbalance asig-	where go tab ptr = return $ ptrGrainy grainRate grainSize pitch tab ptr+  where go tab ptr = return $ ptrGrainy grainRate grainSize pitch tab ptr  -- | Granular delay effect for @rndGrainy@. rndGrainyDelay :: MaxDelayTime -> DelayTime -> Feedback -> Balance -> RndGrainySpec -> GrainRate -> GrainSize -> PitchSig -> Sig -> SE Sig rndGrainyDelay  maxDel delTime kfeed kbalance spec grainRate grainSize pitch asig = tabDelay go maxDel delTime kfeed kbalance asig-	where go = rndPtrGrainy spec grainRate grainSize pitch+  where go = rndPtrGrainy spec grainRate grainSize pitch  -- | Granular delay effect for @sndwarp@. sndwarpDelay :: MaxDelayTime -> DelayTime -> Feedback -> Balance -> SndwarpSpec -> PitchSig -> Sig -> SE Sig sndwarpDelay maxDel delTime kfeed kbalance spec pitch asig = tabDelay go maxDel delTime kfeed kbalance asig-	where go tab ptr = return $ ptrSndwarp spec pitch tab (sec2rel tab ptr)+  where go tab ptr = return $ ptrSndwarp spec pitch tab (sec2rel tab ptr)  -- | Granular delay effect for @syncgrain@. syncgrainDelay :: MaxDelayTime -> DelayTime -> Feedback -> Balance -> SyncgrainSpec -> GrainSize -> TempoSig -> PitchSig -> Sig -> SE Sig syncgrainDelay maxDel delTime kfeed kbalance spec grainSize tempo pitch asig = tabDelay go maxDel delTime kfeed kbalance asig-	where go tab _ = return $ syncgrain spec grainSize tempo pitch tab+  where go tab _ = return $ syncgrain spec grainSize tempo pitch tab  -- | Granular delay effect for @rndSyncgrain@. rndSyncgrainDelay :: MaxDelayTime -> DelayTime -> Feedback -> Balance -> RndSyncgrainSpec -> SyncgrainSpec -> GrainSize -> TempoSig -> PitchSig -> Sig -> SE Sig rndSyncgrainDelay maxDel delTime kfeed kbalance rndSpec spec grainSize tempo pitch asig = tabDelay go maxDel delTime kfeed kbalance asig-	where go tab _ = rndSyncgrain rndSpec spec grainSize tempo pitch tab+  where go tab _ = rndSyncgrain rndSpec spec grainSize tempo pitch tab  -- | Granular delay effect for @partikkel@. partikkelDelay :: MaxDelayTime -> DelayTime -> Feedback -> Balance -> PartikkelSpec -> GrainRate -> GrainSize -> PitchSig -> Sig -> SE Sig partikkelDelay maxDel delTime kfeed kbalance spec grainRate grainSize pitch asig = tabDelay go maxDel delTime kfeed kbalance asig-	where go tab ptr = return $ partikkel spec grainRate grainSize pitch [tab] [ptr]+  where go tab ptr = return $ partikkel spec grainRate grainSize pitch [tab] [ptr]  ------------------------------------------------------------------------- -- effects +fxFeed :: Feedback fxFeed = 0++fxBalance :: Balance fxBalance = 1++fxMaxLength :: MaxDelayTime fxMaxLength = 1++fxDelTime :: DelayTime fxDelTime = 0.05  type GrainDelay a = MaxDelayTime -> DelayTime -> Feedback -> Balance -> a@@ -953,7 +898,7 @@ ------------------------------------------------------------------------ -- csound opcodes --- | +-- | -- Granular synthesizer with "per grain" control --       over many of its parameters.  Has a sync input to --       sychronize its internal grain scheduler clock to an external@@ -980,16 +925,17 @@ -- >                   [, iopcode_id] -- -- csound doc: <http://www.csounds.com/manual/html/partikkel.html>-csdPartikkel :: Tuple a => Sig	-> Sig -> Tab -> Sig -> Sig -> Tab -> Tab -> Tab -> Sig	-> Sig -> Sig -> Sig -> Tab -> Sig 	-> Sig 	-> Tab-> Tab -> Sig	-> Tab -> Tab -> Tab -> Sig -> Sig -> Sig -> Tab -> Sig -> Tab -> Tab -> Tab -> Tab -> Tab -> Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> D -> a+csdPartikkel :: Tuple a => Sig  -> Sig -> Tab -> Sig -> Sig -> Tab -> Tab -> Tab -> Sig -> Sig -> Sig -> Sig -> Tab -> Sig  -> Sig  -> Tab-> Tab -> Sig -> Tab -> Tab -> Tab -> Sig -> Sig -> Sig -> Tab -> Sig -> Tab -> Tab -> Tab -> Tab -> Tab -> Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> D -> a csdPartikkel b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15 b16 b17 b18 b19 b20 b21 b22 b23 b24 b25 b26 b27 b28 b29 b30 b31 b32 b33 b34 b35 b36 b37 b38 b39 b40 = pureTuple $ f <$> unSig b1 <*> unSig b2 <*> unTab b3 <*> unSig b4 <*> unSig b5 <*> unTab b6 <*> unTab b7 <*> unTab b8 <*> unSig b9 <*> unSig b10 <*> unSig b11 <*> unSig b12 <*> unTab b13 <*> unSig b14 <*> unSig b15 <*> unTab b16 <*> unTab b17 <*> unSig b18 <*> unTab b19 <*> unTab b20 <*> unTab b21 <*> unSig b22 <*> unSig b23 <*> unSig b24 <*> unTab b25 <*> unSig b26 <*> unTab b27 <*> unTab b28 <*> unTab b29 <*> unTab b30 <*> unTab b31 <*> unSig b32 <*> unSig b33 <*> unSig b34 <*> unSig b35 <*> unSig b36 <*> unSig b37 <*> unSig b38 <*> unSig b39 <*> unD b40-    where f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31 a32 a33 a34 a35 a36 a37 a38 a39 a40 = -    			mopcs "partikkel" ([Ar,Ar,Ar,Ar,Ar,Ar,Ar,Ar],[Ar,Kr,Ir,Ar,Kr,Ir,Ir,Ir,Kr,Kr,Kr,Kr,Ir,Kr,Kr,Ir,Ir,Ar,Ir,Kr,Ir,Kr,Kr,Kr,Ir,Kr,Kr,Kr,Kr,Kr,Ir,Ar,Ar,Ar,Ar,Kr,Kr,Kr,Kr,Ir,Ir]) [a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15,a16,a17,a18,a19,a20,a21,a22,a23,a24,a25,a26,a27,a28,a29,a30,a31,a32,a33,a34,a35,a36,a37,a38,a39,a40]+    where+      f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31 a32 a33 a34 a35 a36 a37 a38 a39 a40 =+          mopcs "partikkel" ([Ar,Ar,Ar,Ar,Ar,Ar,Ar,Ar],[Ar,Kr,Ir,Ar,Kr,Ir,Ir,Ir,Kr,Kr,Kr,Kr,Ir,Kr,Kr,Ir,Ir,Ar,Ir,Kr,Ir,Kr,Kr,Kr,Ir,Kr,Kr,Kr,Kr,Kr,Ir,Ar,Ar,Ar,Ar,Kr,Kr,Kr,Kr,Ir,Ir]) [a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15,a16,a17,a18,a19,a20,a21,a22,a23,a24,a25,a26,a27,a28,a29,a30,a31,a32,a33,a34,a35,a36,a37,a38,a39,a40] --- | +-- | -- Synchronous granular synthesis. -- -- syncgrain implements synchronous granular synthesis. The source sound for the--- grains is obtained by reading a function table containing the samples of the source waveform. +-- grains is obtained by reading a function table containing the samples of the source waveform. -- For sampled-sound sources, GEN01 is used. -- syncgrain will accept deferred allocation tables. --@@ -999,9 +945,9 @@ -- csound doc: <http://www.csounds.com/manual/html/syncgrain.html> csdSyncgrain :: Sig -> Sig -> Sig -> Sig -> Sig -> Tab -> Tab -> D -> Sig csdSyncgrain b1 b2 b3 b4 b5 b6 b7 b8 = Sig $ f <$> unSig b1 <*> unSig b2 <*> unSig b3 <*> unSig b4 <*> unSig b5 <*> unTab b6 <*> unTab b7 <*> unD b8-	where f a1 a2 a3 a4 a5 a6 a7 a8 = opcs "syncgrain" [(Ar, [Kr,Kr,Kr,Kr,Kr,Ir,Ir,Ir])] [a1, a2, a3, a4, a5, a6, a7, a8]+  where f a1 a2 a3 a4 a5 a6 a7 a8 = opcs "syncgrain" [(Ar, [Kr,Kr,Kr,Kr,Kr,Ir,Ir,Ir])] [a1, a2, a3, a4, a5, a6, a7, a8] --- | +-- | -- A more complex granular synthesis texture generator. -- -- The granule unit generator is more complex than grain, but does add new possibilities.@@ -1014,7 +960,7 @@ csdGranule :: Sig -> D -> D -> D -> D -> Tab -> D -> D -> D -> D -> Sig -> D -> Sig -> D -> D -> D -> Sig csdGranule = C.granule --- | +-- | -- Reads a mono sound sample from a table and applies time-stretching and/or pitch modification. -- -- sndwarp reads sound samples from a table and applies time-stretching and/or pitch modification. Time and frequency modification are independent from one another. For example, a sound can be stretched in time while raising the pitch!@@ -1027,7 +973,7 @@ csdSndwarp = C.sndwarp  --- | +-- | -- Reads a stereo sound sample from a table and applies time-stretching and/or pitch modification. -- -- sndwarpst reads stereo sound samples from a table and applies time-stretching and/or pitch modification. Time and frequency modification are independent from one another. For example, a sound can be stretched in time while raising the pitch!@@ -1039,7 +985,7 @@ csdSndwarpst :: Sig -> Sig -> Sig -> Tab -> D -> D -> D -> D -> Tab -> D -> Sig2 csdSndwarpst = C.sndwarpst --- | +-- | -- Produces sinusoid bursts including k-rate incremental indexing with each successive burst. -- -- Audio output is a succession of sinusoid bursts initiated at frequency xfund with a spectral peak at xform. For xfund above 25 Hz these bursts produce a speech-like formant with spectral characteristics determined by the k-input parameters. For lower fundamentals this generator provides a special form of granular synthesis.@@ -1048,4 +994,5 @@ -- >           ifna, ifnb, itotdur, kphs, kgliss [, iskip] -- -- csound doc: <http://www.csounds.com/manual/html/fof2.html>+csdFof2 :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> D -> Tab -> Tab -> D -> Sig -> Sig -> Sig csdFof2 = C.fof2

@@ -2,41 +2,38 @@ -- 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(..),+  WaveAmp, WaveKey, MorphWave,+  MorphSpec(..), GrainDensity(..), GrainEnv(..), -	morpheus,+  morpheus, -	-- *  Sound files-	morphSnd1, morphSnd,+  -- *  Sound files+  morphSnd1, morphSnd, -	-- * Amplitude modes-	pairToSquare,+  -- * Amplitude modes+  pairToSquare, -	-- * Oscillators-	morpheusOsc, morpheusOsc2+  -- * 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.  --- +-- | 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)@@ -44,20 +41,20 @@ -- * @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 }+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+  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. --@@ -70,34 +67,34 @@ -- * 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 }+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 }+  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 +-- | 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	-	}+data MorphSpec = MorphSpec+  { morphGrainDensity :: GrainDensity+  , morphGrainEnv     :: GrainEnv+  }  instance Default MorphSpec where-	def = MorphSpec -		{ morphGrainDensity = def-		, morphGrainEnv     = def-		}+  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@@ -110,7 +107,7 @@ -- -- * 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. +-- * 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)@@ -122,99 +119,100 @@  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+  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+      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]+      async = 0+      kamp = 1 -    	-- 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]	+      ichannelmasks = skipNorm $ doubles [0, 0,  0.5] -    	-- grain density-    	grainDensity = morphGrainDensity spec-    	kGrainRate = grainRate grainDensity-    	kduration = grainSize grainDensity                    +      kdistribution = 1+      idisttab = setSize 16 $ startEnds [1, 16, -10, 0] -    	kwavfreq = cps+      -- 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] -    	krandommask = grainSkip grainDensity+      -- grain density+      grainDensity = morphGrainDensity spec+      kGrainRate = grainRate grainDensity+      kduration = grainSize grainDensity -    	-- waves+      kwavfreq = cps -    	kwavekey1 = getWaveKey wave1-    	kwavekey2 = getWaveKey wave2-    	kwavekey3 = getWaveKey wave3-    	kwavekey4 = getWaveKey wave4+      krandommask = grainSkip grainDensity -    	asamplepos1 = getSamplePos wave1-    	asamplepos2 = getSamplePos wave2-    	asamplepos3 = getSamplePos wave3-    	asamplepos4 = getSamplePos wave4+      -- waves -    	kwaveform1 = getWaveForm wave1-    	kwaveform2 = getWaveForm wave2-    	kwaveform3 = getWaveForm wave3-    	kwaveform4 = getWaveForm wave4+      kwavekey1 = getWaveKey wave1+      kwavekey2 = getWaveKey wave2+      kwavekey3 = getWaveKey wave3+      kwavekey4 = getWaveKey wave4 -    	amp1 = getAmp wave1-    	amp2 = getAmp wave2-    	amp3 = getAmp wave3-    	amp4 = getAmp wave4+      asamplepos1 = getSamplePos wave1+      asamplepos2 = getSamplePos wave2+      asamplepos3 = getSamplePos wave3+      asamplepos4 = getSamplePos wave4 -    	imax_grains = 100   	+      kwaveform1 = getWaveForm wave1+      kwaveform2 = getWaveForm wave2+      kwaveform3 = getWaveForm wave3+      kwaveform4 = getWaveForm wave4 -    	getWaveKey (tab1, amp1, key1, ptr1) = key1 / sig (getTabLen tab1)+      amp1 = getAmp wave1+      amp2 = getAmp wave2+      amp3 = getAmp wave3+      amp4 = getAmp wave4 -    	getSamplePos (_, _, _, ptr) = ptr-    	getWaveForm (form, _, _, _) = form-    	getAmp (_, amp, _, _) = kr amp+      imax_grains = 100 -    	-- no trainlets-    	icosine = cosine-    	kTrainCps = kGrainRate-    	knumpartials = 7-    	kchroma = 3+      getWaveKey (tab1, _, key1, _) = key1 / sig (getTabLen tab1) -    	-- 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+      getSamplePos (_, _, _, ptr) = ptr+      getWaveForm (form, _, _, _) = form+      getAmp (_, amp, _, _) = kr amp -    	-- other params-    	igainmasks = skipNorm $ doubles [0, 0,   1]-    	ksweepshape = 0.5-    	iwavfreqstarttab = skipNorm $ doubles [0, 0, 1]-    	iwavfreqendtab = skipNorm $ doubles [0, 0, 1]+      -- no trainlets+      icosine = cosine+      kTrainCps = kGrainRate+      knumpartials = 7+      kchroma = 3 -    	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+      -- 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 :: Tab -> D getTabLen t = ftlen t / getSampleRate  -- | Creates four control signals out two signals. The control signals are encoded by the position@@ -227,8 +225,8 @@ -- 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)))+  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@.@@ -237,22 +235,23 @@  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)))+  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. +-- 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)]+  where+    ratio = cps / sig baseFreq+    aptr = cycleTab t+    waves = [(t, 1, 1, aptr)] +cycleTab :: Tab -> Sig cycleTab t = phasor $ sig $ recip $ getTabLen t  -- | Morpheus oscillator. We control the four tables with pair of control signals (see the function @pairToSquare@).@@ -260,10 +259,10 @@ -- > 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+  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@@ -271,21 +270,21 @@ 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)+  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])+      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]+      env = linseg [0, 1, 1, 3, 1] -- 10, 0] -			amp1 = linseg [1, 8, 1, 4, 0]-			amp2 = linseg [0, 6, 0, 6, 1]+      amp1 = linseg [1, 8, 1, 4, 0]+      amp2 = linseg [0, 6, 0, 6, 1]  -} @@ -298,82 +297,82 @@  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)+  [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)+    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+    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]+    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 :: Sig -> (Sig, Sig, Sig, Sig) partWaveChain3 = partWaveChain [1/3, 0.25, 1/3, 0.25] -partWaveChain4 :: Sig -> (Sig, Sig, Sig, Sig) +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-			_        -> []+  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)+    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+      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)+          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]+      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 +      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 --}			+      lengs xs = tail $ scanl (\res (a, _) -> res + a) 0 xs+-}

@@ -1,19 +1,17 @@ -- | Hyper vectorial synthesis-module Csound.Air.Hvs(    -	HvsSnapshot, HvsMatrix1, HvsMatrix2, HvsMatrix3,-	hvs1, hvs2, hvs3,+module Csound.Air.Hvs(+  HvsSnapshot, HvsMatrix1, HvsMatrix2, HvsMatrix3,+  hvs1, hvs2, hvs3, -	-- | Csound functions-	csdHvs1, csdHvs2, csdHvs3+  -- | Csound functions+  csdHvs1, csdHvs2, csdHvs3 ) where -import Control.Applicative hiding ((<*)) import Control.Monad.Trans.Class import Csound.Dynamic hiding (int) import Csound.Typed  import Csound.Typed.Opcode hiding (hvs1, hvs2, hvs3)-import qualified Csound.Typed.Opcode as C(hvs1, hvs2, hvs3)  import Csound.Tab @@ -31,7 +29,7 @@  -- Hyper Vectorial Synthesis. --- | +-- | -- Allows one-dimensional Hyper Vectorial Synthesis (HVS) controlled by externally-updated k-variables. -- -- hvs1 allows one-dimensional Hyper Vectorial Synthesis (HVS) controlled by externally-updated k-variables.@@ -43,7 +41,7 @@ csdHvs1 b1 b2 b3 b4 b5 b6 = SE $ (depT_ =<<) $ lift $ f <$> unSig b1 <*> unD b2 <*> unD b3 <*> unTab b4 <*> unTab b5 <*> unTab b6     where f a1 a2 a3 a4 a5 a6 = opcs "hvs1" [(Xr,[Kr,Ir,Ir,Ir,Ir,Ir,Ir])] [a1,a2,a3,a4,a5,a6] --- | +-- | -- Allows two-dimensional Hyper Vectorial Synthesis (HVS) controlled by externally-updated k-variables. -- -- hvs2 allows two-dimensional Hyper Vectorial Synthesis (HVS) controlled by externally-updated k-variables.@@ -62,7 +60,7 @@                                                                                       ,a7                                                                                       ,a8] --- | +-- | -- Allows three-dimensional Hyper Vectorial Synthesis (HVS) controlled by externally-updated k-variables. -- -- hvs3 allows three-dimensional Hyper Vectorial Synthesis (HVS) controlled by externally-updated k-variables.@@ -75,12 +73,12 @@     where f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 = opcs "hvs3" [(Xr                                                           ,[Kr,Kr,Kr,Ir,Ir,Ir,Ir,Ir,Ir,Ir,Ir])] [a1,a2,a3,a4,a5,a6,a7,a8,a9,a10] --- | One dimensional Hyper vectorial synthesis. +-- | One dimensional Hyper vectorial synthesis. -- We can provide a list of vectors (of lists but the same length for all items is assumed) -- and a signal that ranges from 0 to 1. It interpolates between vectors in the list. -- As a result we get a n interpolated vector. It's a list but the actual length -- equals to the length of input vectors.--- +-- -- An example. We can set the center frequency and resonance of the filter with the single parameter: -- -- > let f = hvs1 [[100, 0.1], [300, 0.1], [600, 0.5], [800, 0.9]]@@ -93,18 +91,18 @@ -- It's determined by the length of the items in the input list. hvs1 :: HvsMatrix1 -> Sig -> SE [Sig] hvs1 as x = do-	outTab <- newTab (int numParams)-	csdHvs1 x (int numParams) (int numPointsX) outTab positionsTab snapTab-	return $ fmap (kr . flip tab outTab . sig . int) [0 .. numParams - 1]-	where -		numParams  = length $ head as-		numPointsX = length as+  outTab <- newTab (int numParams)+  csdHvs1 x (int numParams) (int numPointsX) outTab positionsTab snapTab+  return $ fmap (kr . flip tab outTab . sig . int) [0 .. numParams - 1]+  where+    numParams  = length $ head as+    numPointsX = length as -		positionsTab = doubles $ fmap fromIntegral [0 .. numPointsX - 1]-		snapTab = doubles $ concat as+    positionsTab = doubles $ fmap fromIntegral [0 .. numPointsX - 1]+    snapTab = doubles $ concat as --- | Two dimensional Hyper vectorial synthesis. --- Now we provide a list of lists of vectors. The length of all vectors should be the same +-- | Two dimensional Hyper vectorial synthesis.+-- Now we provide a list of lists of vectors. The length of all vectors should be the same -- but there is no limit for the number! So that's how we can control a lot of parameters -- with pair of signals. The input 2D atrix is the grid of samples. -- It finds the closest four points in the grid and interpolates between them (it's a weighted sum).@@ -113,40 +111,40 @@ -- -- The usage is the same as in the case of @hvs1@. An example: ----- > g = hvs2 [[[100, 0.1, 0.3], [800, 0.1, 0.5], [1400, 0.1, 0.8]], --- > 		  [[100, 0.5, 0.3], [800, 0.5, 0.5], [1400, 0.5, 0.8]], --- > 		  [[100, 0.8, 0.3], [800, 0.8, 0.5], [1400, 0.8, 0.8]]]--- > +-- > g = hvs2 [[[100, 0.1, 0.3], [800, 0.1, 0.5], [1400, 0.1, 0.8]],+-- >      [[100, 0.5, 0.3], [800, 0.5, 0.5], [1400, 0.5, 0.8]],+-- >      [[100, 0.8, 0.3], [800, 0.8, 0.5], [1400, 0.8, 0.8]]]+-- > -- > main = dac $ do--- > 	(g1, kx) <- uknob 0.5--- > 	(g2, ky) <- uknob 0.5--- > 	[cfq, q, w] <- g (kx, ky)--- > 	panel $ hor [g1, g2]--- > 	at (mlp cfq q) $ fmap (cfd w (saw 110)) (white)+-- >  (g1, kx) <- uknob 0.5+-- >  (g2, ky) <- uknob 0.5+-- >  [cfq, q, w] <- g (kx, ky)+-- >  panel $ hor [g1, g2]+-- >  at (mlp cfq q) $ fmap (cfd w (saw 110)) (white) hvs2 :: HvsMatrix2 -> Sig2 -> SE [Sig] hvs2 as (x, y) = do-	outTab <- newTab (int numParams)-	csdHvs2 x y (int numParams) (int numPointsX) (int numPointsY) outTab positionsTab snapTab-	return $ fmap (kr . flip tab outTab . sig . int) [0 .. numParams - 1]-	where -		numParams  = length $ head $ head as-		numPointsX = length $ head as-		numPointsY = length as+  outTab <- newTab (int numParams)+  csdHvs2 x y (int numParams) (int numPointsX) (int numPointsY) outTab positionsTab snapTab+  return $ fmap (kr . flip tab outTab . sig . int) [0 .. numParams - 1]+  where+    numParams  = length $ head $ head as+    numPointsX = length $ head as+    numPointsY = length as -		positionsTab = doubles $ fmap fromIntegral [0 .. (numPointsX * numPointsY - 1)]-		snapTab = doubles $ concat $ concat as+    positionsTab = doubles $ fmap fromIntegral [0 .. (numPointsX * numPointsY - 1)]+    snapTab = doubles $ concat $ concat as --- | The three dimensional +-- | The three dimensional hvs3 :: HvsMatrix3 -> Sig3 -> SE [Sig] hvs3 as (x, y, z) = do-	outTab <- newTab (int numParams)-	csdHvs3 x y z (int numParams) (int numPointsX) (int numPointsY) (int numPointsZ) outTab positionsTab snapTab-	return $ fmap (kr . flip tab outTab . sig . int) [0 .. numParams - 1]-	where -		numParams  = length $ head $ head $ head as-		numPointsX = length $ head $ head as-		numPointsY = length $ head as-		numPointsZ = length as+  outTab <- newTab (int numParams)+  csdHvs3 x y z (int numParams) (int numPointsX) (int numPointsY) (int numPointsZ) outTab positionsTab snapTab+  return $ fmap (kr . flip tab outTab . sig . int) [0 .. numParams - 1]+  where+    numParams  = length $ head $ head $ head as+    numPointsX = length $ head $ head as+    numPointsY = length $ head as+    numPointsZ = length as -		positionsTab = doubles $ fmap fromIntegral [0 .. (numPointsX * numPointsY * numPointsZ) - 1]-		snapTab = doubles $ concat $ concat $ concat as+    positionsTab = doubles $ fmap fromIntegral [0 .. (numPointsX * numPointsY * numPointsZ) - 1]+    snapTab = doubles $ concat $ concat $ concat as

@@ -36,20 +36,16 @@ import Control.Monad  import Data.Bool-import Data.Colour import Data.Boolean import Data.Default import qualified Data.Colour.Names as C import qualified Data.Colour.SRGB as C -import Csound.Typed-import Csound.Typed.Gui-import Csound.Control.Midi-import Csound.Control.Evt-import Csound.Control.Instr-import Csound.Control.Gui-import Csound.Typed.Opcode hiding (space)-import Csound.SigSpace+import Csound.Typed hiding (arg, mix)+import Csound.Typed.Gui hiding (widget, width)+import Csound.Control.Instr hiding (mix)+import Csound.Control.Gui hiding (widget, width)+import Csound.Typed.Opcode hiding (space, integ, gain, tone, delay, mute) import Csound.Air.Wave import Csound.Air.Fx import Csound.Air.Patch@@ -131,7 +127,7 @@     offRef <- newGlobalRef (0 :: Sig)     writeRef offRef off     let (names, initVals) = unzip args-    (gs, as)  <- fmap unzip $ mapM (\(name, initVal) -> slider name (linSpan 0 1) initVal) $ zip names initVals+    (gs, as)  <- fmap unzip $ mapM (\(nm, initVal) -> slider nm (linSpan 0 1) initVal) $ zip names initVals     let f x = do           ref <- newRef (0 :: a)           goff <- readRef offRef@@ -153,12 +149,16 @@ -- | Creates an FX-box from the given visual representation. -- It inserts a big On/Off button atop of the GUI. uiBox :: (Sigs a) => String -> Source (Fx a) -> Bool -> Source (Fx a)-uiBox name fx onOff = mapGuiSource (setBorder UpBoxBorder) $ vlift2' uiOnOffSize uiBoxSize go off fx+uiBox name fx' onOff =+  mapGuiSource (setBorder UpBoxBorder) $ vlift2' uiOnOffSize uiBoxSize go offs fx'     where-        off =  mapGuiSource (setFontSize 25) $ toggleSig name onOff+        offs = mapGuiSource (setFontSize 25) $ toggleSig name onOff         go off fx arg = fmap (mul off) $ fx arg +uiOnOffSize :: Double uiOnOffSize = 1.7++uiBoxSize :: Double uiBoxSize   = 8  uiGroupGui :: Gui -> Gui -> Gui@@ -248,13 +248,14 @@  -- | Applies FX to the Patch. atFx :: Source (Fx a) -> Patch a -> Source (Patch a)-atFx uiFx patch = lift1 (\fx -> addPostFx 1 fx patch) uiFx+atFx f patch = lift1 (\fx -> addPostFx 1 fx patch) f  -- | The distortion widget. The arguments are -- -- > uiDistort isOn levelOfDistortion drive tone uiDistort :: Sigs a => Bool -> Double -> Double -> Double -> Source (Fx a)-uiDistort isOn level drive tone = mapSource bindSig $ sourceColor2 C.red $ fxBox "Distortion" (\[level, drive, tone] -> return . fxDistort level drive tone) isOn+uiDistort isOn level drive tone = mapSource bindSig $ sourceColor2 C.red $+  fxBox "Distortion" (\[level', drive', tone'] -> return . fxDistort level' drive' tone') isOn     [("level", level), ("drive", drive), ("tone", tone)]  @@ -262,7 +263,8 @@ -- -- > uiChorus isOn mix rate depth width uiChorus :: Bool -> Double -> Double -> Double -> Double -> Source Fx2-uiChorus isOn mix rate depth width = sourceColor2 C.coral $ fxBox "Chorus" (\[mix, rate, depth, width] -> return . stChorus2 mix rate depth width) isOn+uiChorus isOn mix rate depth width = sourceColor2 C.coral $+  fxBox "Chorus" (\[mix', rate', depth', width'] -> return . stChorus2 mix' rate' depth' width') isOn     [("mix",mix), ("rate",rate), ("depth",depth), ("width",width)]  uiDry :: (Sigs a) => Source (Fx a)@@ -272,7 +274,8 @@ -- -- > uiFlanger isOn  rate depth delay feedback uiFlanger :: Sigs a => Bool -> Double -> Double -> Double -> Double -> Source (Fx a)-uiFlanger isOn rate depth delay fback = mapSource bindSig $ sourceColor2 C.indigo $ fxBox "Flanger" (\[fback, rate, depth, delay] -> return . fxFlanger fback rate depth delay) isOn+uiFlanger isOn rate depth delay fback = mapSource bindSig $ sourceColor2 C.indigo $+  fxBox "Flanger" (\[fback', rate', depth', delay'] -> return . fxFlanger fback' rate' depth' delay') isOn     [("rate",rate), ("depth",depth), ("delay",delay), ("fback", fback)]  @@ -280,14 +283,16 @@ -- -- > uiPhaser isOn mix feedback rate depth frequency uiPhaser :: Sigs a => Bool -> Double -> Double -> Double -> Double -> Source (Fx a)-uiPhaser isOn rate depth freq fback = mapSource bindSig $ sourceColor2 C.orange $ fxBox "Phaser" (\[rate, depth, frequency, feedback] -> return . fxPhaser rate depth frequency feedback) isOn+uiPhaser isOn rate depth freq fback = mapSource bindSig $ sourceColor2 C.orange $+  fxBox "Phaser" (\[rate', depth', frequency', feedback'] -> return . fxPhaser rate' depth' frequency' feedback') isOn     [("rate",rate), ("depth",depth), ("freq", freq), ("fback", fback)]  -- | The delay widget. The arguments are -- -- > uiDelay isOn mix feedback delayTime tone uiDelay :: Sigs a => Bool -> Double -> Double -> Double -> Double -> Source (Fx a)-uiDelay isOn mix fback time tone = mapSource bindSig $ sourceColor2 C.dodgerblue $ fxBox "Delay" (\[mix, fback, time, tone] -> return . analogDelay mix fback time tone) isOn+uiDelay isOn mix fback time tone = mapSource bindSig $ sourceColor2 C.dodgerblue $+  fxBox "Delay" (\[mix', fback', time', tone'] -> return . analogDelay mix' fback' time' tone') isOn     [("mix",mix), ("fback",fback), ("time",time), ("tone",tone)]  @@ -295,7 +300,8 @@ -- -- > uiEcho isOn maxDelayTime delayTime feedback uiEcho :: Sigs a => Bool -> D -> Double -> Double -> Source (Fx a)-uiEcho isOn maxDelTime time fback = mapSource bindSig $ sourceColor2 C.deepskyblue $ fxBox "Echo" (\[time, fback] -> return . fxEcho maxDelTime time fback) isOn+uiEcho isOn maxDelTime time fback = mapSource bindSig $ sourceColor2 C.deepskyblue $+  fxBox "Echo" (\[time', fback'] -> return . fxEcho maxDelTime time' fback') isOn     [("time", time), ("fback", fback)]  @@ -303,7 +309,8 @@ -- -- > uiFilter isOn lowPassfrequency highPassFrequency gain uiFilter :: Sigs a => Bool -> Double -> Double -> Double -> Source (Fx a)-uiFilter isOn lpf hpf gain = mapSource bindSig $ fxBox "Filter" (\[lpf, hpf, gain] -> return . fxFilter lpf hpf gain) isOn+uiFilter isOn lpf hpf gain = mapSource bindSig $+  fxBox "Filter" (\[lpf', hpf', gain'] -> return . fxFilter lpf' hpf' gain') isOn     [("lpf",lpf), ("hpf",hpf), ("gain",gain)]  @@ -311,27 +318,31 @@ -- -- > uiReverb mix depth uiReverb :: Bool -> Double -> Double -> Source Fx2-uiReverb isOn mix depth = sourceColor2 C.forestgreen $ fxBox "Reverb" (\[mix, depth] asig -> return $ cfd mix asig (rever2 depth asig)) isOn-    [("mix", mix), ("depth", depth)]+uiReverb isOn mix depth = sourceColor2 C.forestgreen $+  fxBox "Reverb" (\[mix', depth'] asig -> return $ cfd mix' asig (rever2 depth' asig)) isOn+      [("mix", mix), ("depth", depth)]  -- | The gain widget, it's set to on by default. The arguments are -- -- > uiGain amountOfGain uiGain :: Sigs a => Double -> Source (Fx a)-uiGain gain = mapSource bindSig $ sourceColor2 C.black $ fxBox "Gain" (\[vol] -> return . fxGain vol) True [("gain", gain)]+uiGain gain = mapSource bindSig $ sourceColor2 C.black $+  fxBox "Gain" (\[vol] -> return . fxGain vol) True [("gain", gain)]  -- | The filtered white noize widget. The arguments are -- -- > uiWhite isOn centerFreqOfFilter amountOfNoize uiWhite :: Sigs a => Bool -> Double -> Double -> Source (Fx a)-uiWhite isOn freq depth = mapSource bindSig $ sourceColor2 C.dimgray $ fxBox "White" (\[freq, depth] -> fxWhite freq depth) isOn+uiWhite isOn freq depth = mapSource bindSig $ sourceColor2 C.dimgray $+  fxBox "White" (\[freq', depth'] -> fxWhite freq' depth') isOn     [("freq", freq), ("depth", depth)]  -- | The filtered pink noize widget. The arguments are -- -- > uiPink isOn centerFreqOfFilter amountOfNoize uiPink :: Sigs a => Bool -> Double -> Double -> Source (Fx a)-uiPink isOn freq depth = mapSource bindSig $ sourceColor2 C.deeppink $ fxBox "Pink" (\[freq, depth] -> fxPink freq depth) isOn+uiPink isOn freq depth = mapSource bindSig $ sourceColor2 C.deeppink $+  fxBox "Pink" (\[freq', depth'] -> fxPink freq' depth') isOn     [("freq", freq), ("depth", depth)]  -- | The constructor for signal processing functions with no arguments (controlls).@@ -420,6 +431,7 @@ ---------------------------------------------------- -- instrument choosers +genMidiChooser :: Sigs a => (t1 -> t2 -> Source (Msg -> SE a)) -> t1 -> t2 -> Source a genMidiChooser chooser xs initVal = joinSource $ lift1 midi $ chooser xs initVal  -- | Chooses a midi instrument among several alternatives. It uses the @hradio@ for GUI groupping.@@ -479,6 +491,7 @@     [("thresh", initThresh), ("loknee", initLoknee), ("hiknee", initHiknee), ("ratio", initRatio), ("att", initAtt), ("rel", initRel),  ("gain", initGain)]     where         fx [thresh, loknee, hiknee, ratio, att, rel, gain] = return . fxCompress thresh (loknee, hiknee) ratio (att, rel) gain+        fx _ = undefined          paintTo = fxColor . C.sRGB24read         orange = "#FF851B"@@ -567,8 +580,8 @@     where         n = length xs         nextPow-            | frac == 0 = n-            | otherwise = 2 ^ (integ + 1)+            | frac == (0 :: Double) = n+            | otherwise = 2 ^ (integ + 1 :: Int)             where                 (integ, frac) = properFraction $ logBase 2 (fromIntegral n) 

@@ -1,15 +1,15 @@ {-# Language FlexibleContexts, ScopedTypeVariables #-} -- | A multitap looper. module Csound.Air.Looper (-	LoopSpec(..), LoopControl(..),-	sigLoop, midiLoop, sfLoop --, patchLoop+  LoopSpec(..), LoopControl(..),+  sigLoop, midiLoop, sfLoop --, patchLoop ) where  import Control.Monad import Data.List  import Data.Default-import Data.Boolean+import Data.Boolean hiding (cond) import Csound.Typed import Csound.Typed.Gui hiding (button) import Csound.Control.Evt@@ -17,14 +17,9 @@ import Csound.Control.Gui import Csound.Control.Sf -import Csound.Typed.Opcode hiding (space, button)-import Csound.SigSpace-import Csound.Air.Live-import Csound.Air.Wave import Csound.Air.Fx import Csound.Air.Filter import Csound.Air.Patch-import Csound.Air.Misc   -- | The type for fine tuning of the looper. Let's review the values:@@ -49,35 +44,35 @@ -- * @loopReeatFades@ -- a repeat fade weight is a value that represents --    an amount of repetition. A looping tap is implemented as a delay tap with --   big feedback. The repeat fades equals to the feedback amount. It have to be not bigger--- 	 than 1. If the value equals to 1 than the loop is repeated forever. If it's lower+--   than 1. If the value equals to 1 than the loop is repeated forever. If it's lower --   than 1 the loop is gradually going to fade. -- -- * @loopControl@ -- specifies an external controllers for the looper. --   See the docs for the type @LoopSpec@. data LoopSpec = LoopSpec-	{ loopMixVal  :: [Sig]-	, loopPrefx  :: [Fx2]-	, loopPostfx :: [Fx2]-	, loopPrefxVal :: [Sig]-	, loopPostfxVal :: [Sig]-	, loopInitInstr :: Int-	, loopFades :: [[Int]]-	, loopRepeatFades :: [Sig]-	, loopControl :: LoopControl-	}+  { loopMixVal  :: [Sig]+  , loopPrefx  :: [Fx2]+  , loopPostfx :: [Fx2]+  , loopPrefxVal :: [Sig]+  , loopPostfxVal :: [Sig]+  , loopInitInstr :: Int+  , loopFades :: [[Int]]+  , loopRepeatFades :: [Sig]+  , loopControl :: LoopControl+  }  instance Default LoopSpec where-	def = LoopSpec {-		  loopPrefx  		= []-		, loopPostfx 		= []-		, loopPrefxVal 		= []-		, loopPostfxVal 	= []-		, loopMixVal      	= []-		, loopInitInstr 	= 0-		, loopFades 		= []-		, loopRepeatFades   = []-		, loopControl       = def-		}+  def = LoopSpec {+      loopPrefx     = []+    , loopPostfx    = []+    , loopPrefxVal    = []+    , loopPostfxVal   = []+    , loopMixVal        = []+    , loopInitInstr   = 0+    , loopFades     = []+    , loopRepeatFades   = []+    , loopControl       = def+    }  -- | External controllers. We can control the looper with -- UI-widgets but sometimes it's convenient to control the@@ -103,18 +98,18 @@ -- -- > def { loopTap = Just someEvt } data LoopControl = LoopControl-	{ loopTap  :: Maybe (Evt D)-	, loopFade :: Maybe ([Evt D])-	, loopDel  :: Maybe Tick-	, loopThrough :: Maybe (Evt D)-	}+  { loopTap  :: Maybe (Evt D)+  , loopFade :: Maybe ([Evt D])+  , loopDel  :: Maybe Tick+  , loopThrough :: Maybe (Evt D)+  }  instance Default LoopControl where-	def = LoopControl {-		  loopTap  = Nothing-		, loopFade = Nothing-		, loopDel  = Nothing-		, loopThrough = Nothing }+  def = LoopControl {+      loopTap  = Nothing+    , loopFade = Nothing+    , loopDel  = Nothing+    , loopThrough = Nothing }  type TapControl     = [String] -> Int -> Source Sig type FadeControl    = [String -> Source (Evt D)]@@ -160,94 +155,93 @@  getControls :: LoopControl -> (TapControl, FadeControl, DelControl, ThroughControl) getControls a =-	( maybe hradioSig (hradioSig' . evtToSig (-1)) (loopTap a)-	, fmap (\f x -> f x True) $ maybe (repeat toggle) (\xs -> fmap toggle' xs ++ repeat toggle) (loopFade a)-	, ( $ "del") $ maybe button button' (loopDel a)-	, (\f -> f "through" False) $ maybe toggleSig (toggleSig' . evtToSig (-1))  (loopThrough a))+  ( maybe hradioSig (hradioSig' . evtToSig (-1)) (loopTap a)+  , fmap (\f x -> f x True) $ maybe (repeat toggle) (\xs -> fmap toggle' xs ++ repeat toggle) (loopFade a)+  , ( $ "del") $ maybe button button' (loopDel a)+  , (\f -> f "through" False) $ maybe toggleSig (toggleSig' . evtToSig (-1))  (loopThrough a))  genLoop :: forall a. (BoolSig -> a -> SE Sig2) -> LoopSpec -> D -> [D] -> [a] -> Source Sig2 genLoop playInstr spec dtBpm times' instrs = do-	(preFxKnobGui, preFxKnobWrite, preFxKnobRead) <- setKnob "pre" (linSpan 0 1) 0.5-	(postFxKnobGui, postFxKnobWrite, postFxKnobRead) <- setKnob "post" (linSpan 0 1) 0.5-	(mixKnobGui, mixKnobWrite, mixKnobRead) <- setKnob "mix" (linSpan 0 1) 0.5+  (preFxKnobGui, preFxKnobWrite, preFxKnobRead) <- setKnob "pre" (linSpan 0 1) 0.5+  (postFxKnobGui, postFxKnobWrite, postFxKnobRead) <- setKnob "post" (linSpan 0 1) 0.5+  (mixKnobGui, mixKnobWrite, mixKnobRead) <- setKnob "mix" (linSpan 0 1) 0.5 -	let knobGuis = ver [mixKnobGui, preFxKnobGui, postFxKnobGui]+  let knobGuis = ver [mixKnobGui, preFxKnobGui, postFxKnobGui] -	mapGuiSource (\gs -> hor [knobGuis, sca 12 gs]) $ joinSource $ vlift3 (\(thr, delEvt) x sils -> do-		-- knobs-		mixCoeffs <- tabSigs mixKnobWrite mixKnobRead x initMixVals-		preCoeffs <- tabSigs preFxKnobWrite preFxKnobRead x initPreVals-		postCoeffs <- tabSigs postFxKnobWrite postFxKnobRead x initPostVals+  mapGuiSource (\gs -> hor [knobGuis, sca 12 gs]) $ joinSource $ vlift3 (\(thr, delEvt) x sils -> do+    -- knobs+    mixCoeffs <- tabSigs mixKnobWrite mixKnobRead x initMixVals+    preCoeffs <- tabSigs preFxKnobWrite preFxKnobRead x initPreVals+    postCoeffs <- tabSigs postFxKnobWrite postFxKnobRead x initPostVals -		refs <- mapM (const $ newRef (1 :: Sig)) ids-		delRefs <- mapM (const $ newRef (0 :: Sig)) ids-		zipWithM_ (setSilencer refs) silencer sils-		at smallRoom2 $ sum $ zipWith3 (f delEvt thr x) (zip3 times ids repeatFades) (zip5 mixCoeffs preFx preCoeffs postFx postCoeffs) $ zip3 delRefs refs instrs) throughDel sw sil-	where-		(tapControl, fadeControl, delControl, throughControl) = getControls (loopControl spec)+    refs <- mapM (const $ newRef (1 :: Sig)) ids+    delRefs <- mapM (const $ newRef (0 :: Sig)) ids+    zipWithM_ (setSilencer refs) silencer sils+    at smallRoom2 $ sum $ zipWith3 (f delEvt thr x) (zip3 times ids repeatFades) (zip5 mixCoeffs preFxProc preCoeffs postFxProc postCoeffs) $ zip3 delRefs refs instrs) throughDel sw sil+  where+    (tapControl, fadeControl, delControl, throughControl) = getControls (loopControl spec) -		dt = 60 / dtBpm+    dt = 60 / dtBpm -		times = take len $ times' ++ repeat 1+    times = take len $ times' ++ repeat 1 -		postFx = take len $ loopPostfx spec ++ repeat return-		preFx = take len $ loopPrefx spec ++ repeat return-		repeatFades = loopRepeatFades spec ++ repeat 1+    postFxProc = take len $ loopPostfx spec ++ repeat return+    preFxProc = take len $ loopPrefx spec ++ repeat return+    repeatFades = loopRepeatFades spec ++ repeat 1 -		len = length ids-		initMixVals = take len $ loopMixVal spec ++ repeat 0.5-		initPreVals = take len $ loopPrefxVal spec ++ repeat 0.5-		initPostVals = take len $ loopPostfxVal spec ++ repeat 0.5+    len = length ids+    initMixVals = take len $ loopMixVal spec ++ repeat 0.5+    initPreVals = take len $ loopPrefxVal spec ++ repeat 0.5+    initPostVals = take len $ loopPostfxVal spec ++ repeat 0.5 -		silencer-			| null (loopFades spec) = fmap return ids-			| otherwise               = loopFades spec+    silencer+      | null (loopFades spec) = fmap return ids+      | otherwise               = loopFades spec -		initInstr = loopInitInstr spec+    initInstr = loopInitInstr spec -		ids = [0 .. length instrs - 1]-		through = throughControl-		delete = delControl+    ids = [0 .. length instrs - 1]+    through = throughControl -		throughDel = hlift2' 6 1 (\a b -> (a, b)) through delete-		sw = tapControl (fmap show ids) initInstr-		sil = hlifts id $ zipWith (\f n -> f (show n)) fadeControl [0 .. length silencer - 1]+    throughDel = hlift2' 6 1 (\a b -> (a, b)) through delControl+    sw = tapControl (fmap show ids) initInstr+    sil = hlifts id $ zipWith (\g n -> g (show n)) fadeControl [0 .. length silencer - 1] -		maxDel = 3+    maxDel = 3 -		f :: Tick -> Sig -> Sig -> (D, Int, Sig) -> (Sig, Fx2, Sig, Fx2, Sig) -> (Ref Sig, Ref Sig, a) -> SE Sig2-		f delEvt thr x (t, n, repeatFadeWeight) (mixCoeff, preFx, preCoeff, postFx, postCoeff) (delRef, silRef, instr) = do-			silVal <- readRef silRef-			runEvt delEvt $ \_ -> do-				a <- readRef delRef-				when1 isCurrent $ writeRef delRef (ifB (a + 1 `lessThan` maxDel) (a + 1) 0)-			delVal <- readRef delRef-			echoSig <- playSf 0+    f :: Tick -> Sig -> Sig -> (D, Int, Sig) -> (Sig, Fx2, Sig, Fx2, Sig) -> (Ref Sig, Ref Sig, a) -> SE Sig2+    f delEvt thr x (t, n, repeatFadeWeight) (mixCoeff, preFx, preCoeff, postFx, postCoeff) (delRef, silRef, instr) = do+      silVal <- readRef silRef+      runEvt delEvt $ \_ -> do+        a <- readRef delRef+        when1 isCurrent $ writeRef delRef (ifB (a + 1 `lessThan` maxDel) (a + 1) 0)+      delVal <- readRef delRef+      echoSig <- playSf 0 -			let d0 = delVal ==* 0-			    d1 = delVal ==* 1-			    d2 = delVal ==* 2+      let d0 = delVal ==* 0+          d1 = delVal ==* 1+          d2 = delVal ==* 2 -			let playEcho dId = mul (smooth 0.05 $ ifB dId 1 0) $ mul (smooth 0.1 silVal) $ at (echo (dt * t) (ifB dId repeatFadeWeight 0)) $ ifB dId echoSig 0+      let playEcho dId = mul (smooth 0.05 $ ifB dId 1 0) $ mul (smooth 0.1 silVal) $ at (echo (dt * t) (ifB dId repeatFadeWeight 0)) $ ifB dId echoSig 0 -			mul mixCoeff $ mixAt postCoeff postFx $ sum [ return $ sum $ fmap playEcho [d0, d1, d2]-				, playSf 1]-			where-				playSf thrVal = mixAt preCoeff preFx $ playInstr (isCurrent &&* thr ==* thrVal) instr-				isCurrent = x ==* (sig $ int n)+      mul mixCoeff $ mixAt postCoeff postFx $ sum [ return $ sum $ fmap playEcho [d0, d1, d2]+        , playSf 1]+      where+        playSf thrVal = mixAt preCoeff preFx $ playInstr (isCurrent &&* thr ==* thrVal) instr+        isCurrent = x ==* (sig $ int n) -		setSilencer refs silIds evt = runEvt evt $ \v ->-			mapM_ (\ref -> writeRef ref $ sig v) $ fmap (refs !! ) silIds+    setSilencer refs silIds evt = runEvt evt $ \v ->+      mapM_ (\ref -> writeRef ref $ sig v) $ fmap (refs !! ) silIds  tabSigs :: Output Sig -> Input Sig -> Sig -> [Sig] -> SE [Sig] tabSigs writeWidget readWidget switch initVals = do-	refs <- mapM newGlobalRef initVals+  refs <- mapM newGlobalRef initVals -	vs <- mapM readRef refs-	runEvt (changedE [switch]) $ \_ -> do-		mapM_  (\(v, x) -> when1 (x ==* switch) $ writeWidget v) $ zip vs $ fmap (sig . int) [0 .. length initVals - 1]+  vs <- mapM readRef refs+  runEvt (changedE [switch]) $ \_ -> do+    mapM_  (\(v, x) -> when1 (x ==* switch) $ writeWidget v) $ zip vs $ fmap (sig . int) [0 .. length initVals - 1] -	forM_ (zip [0..] refs) $ \(n, ref) -> do-		when1 ((sig $ int n) ==* switch) $ writeRef ref readWidget+  forM_ (zip [0..] refs) $ \(n, ref) -> do+    when1 ((sig $ int n) ==* switch) $ writeRef ref readWidget -	return vs+  return vs

@@ -44,12 +44,9 @@     ambiEnv ) where -import Control.Monad import Data.Boolean import Data.Default -import Csound.Dynamic hiding (int, when1)- import Csound.Typed import Csound.Typed.Opcode hiding (metro) import Csound.Control.Gui@@ -60,7 +57,6 @@ import Csound.Air.Patch import Csound.Air.Envelope import Csound.Air.Filter-import Csound.SigSpace import Csound.IO(writeSndBy) import Csound.Options(setRates) import Csound.Typed.Plugins(delay1k)@@ -101,7 +97,7 @@  -- | Adds a random vibrato to the sound unit. Sound units is a function that takes in a frequency. randomPitch :: Sig -> Sig -> (Sig -> a) -> (Sig -> SE a)-randomPitch rndAmp rndCps f cps = fmap go $ randh (cps * rndAmp) rndCps+randomPitch randAmp randCps f cps = fmap go $ randh (cps * randAmp) randCps     where go krand = f (cps + krand)  -- | Chorus takes a number of copies, chorus width and wave shape.@@ -128,7 +124,7 @@ -- The signal comes last (this order is not standard in the Csound but it's more -- convinient to use with Haskell). resonsBy :: (cps -> bw -> Sig -> Sig) -> [(cps, bw)] -> Sig -> Sig-resonsBy filt ps asig = mean $ fmap (( $ asig) . uncurry filt) ps+resonsBy flt ps asig = mean $ fmap (( $ asig) . uncurry flt) ps  -- | Mixes dry and wet signals. --@@ -281,17 +277,19 @@     k <- birnd amount     return $ x  + k * total +rndDur, rndCps, rndTune :: D -> D -> SE D+ rndDur amt x = rndVal x amt x rndCps amt x = rndVal x (amt / 10) x rndTune amt x = rndVal 0.7 amt x  rndSpec ::TrSpec -> SE TrSpec rndSpec spec = do-    dur  <- rndDur'+    dur'  <- rndDur'     tune <- rndTune'     cps  <- rndCps'     return $ spec-        { trDur  = dur+        { trDur  = dur'         , trTune = tune         , trCps  = cps }     where@@ -300,7 +298,10 @@         rndCps'  = (maybe return rndCps $ (trRnd spec)) $ trCps spec  +addDur' :: D -> Sig -> SE Sig addDur' dt x = xtratim dt >> return x++addDur :: Sig -> SE Sig addDur = addDur' 0.1  getAccent :: Int -> [D]@@ -350,17 +351,18 @@     sched (\amp -> mul (sig amp) $ drum (TrSpec (amp + 1) 0 (1200 * (amp + 0.5)) (Just 0.05))) $     withDur 0.5 $ f $ metro (x / 60) +rimShot' :: TrSpec -> SE Sig rimShot' spec = pureRimShot' =<< rndSpec spec  -- cps = 1700 pureRimShot' :: TrSpec -> SE Sig pureRimShot' spec = rndAmp =<< addDur =<< (mul 0.8 $ aring + anoise)     where-        dur     = trDur  spec+        dur'     = trDur  spec         tune    = trTune spec         cps     = trCps  spec -        fullDur = 0.027 * dur+        fullDur = 0.027 * dur'          -- ring         aenv1 = expsega [1,fullDur,0.001]@@ -377,12 +379,12 @@ claves' :: TrSpec -> SE Sig claves' spec = rndAmp =<< addDur =<< asig     where-        dur     = trDur  spec+        dur'     = trDur  spec         tune    = trTune spec         cps     = trCps  spec          ifrq = cps * octave tune-        dt   = 0.045 * dur+        dt   = 0.045 * dur'         aenv = expsega  [1, dt, 0.001]         afmod = expsega [3,0.00005,1]         asig = mul (- 0.4 * (aenv-0.001)) $ rndOsc (sig ifrq * afmod)@@ -393,12 +395,12 @@ genConga :: D -> TrSpec -> SE Sig genConga dt spec = rndAmp =<< addDur =<< asig     where-        dur     = trDur  spec+        dur'     = trDur  spec         tune    = trTune spec         cps     = trCps  spec          ifrq = cps * octave tune-        fullDur = dt * dur+        fullDur = dt * dur'         aenv = transeg [0.7,1/ifrq,1,1,fullDur,-6,0.001]         afmod = expsega [3,0.25/ifrq,1]         asig = mul (-0.25 * aenv) $ rndOsc (sig ifrq * afmod)@@ -406,42 +408,46 @@ maraca' ::  TrSpec -> SE Sig maraca' spec = rndAmp =<< addDur =<< anoise     where-        dur     = trDur  spec+        dur'    = trDur  spec         tune    = trTune spec-        cps     = trCps  spec -        fullDur = 0.07* dur         otune   = sig $ octave tune         iHPF    = limit (6000 * otune) 20 (sig getSampleRate / 2)         iLPF    = limit (12000 * otune) 20 (sig getSampleRate / 3)-        aenv    = expsega [0.4,0.014* dur,1,0.01 * dur, 0.05, 0.05 * dur, 0.001]+        aenv    = expsega [0.4,0.014* dur',1,0.01 * dur', 0.05, 0.05 * dur', 0.001]         anoise  = mul aenv $ fmap (blp iLPF . bhp iHPF) $ noise 0.75 0  ------------------------------------------- -- drones (copied from csound-catalog) +testDrone, testDrone2, testDrone3, testDrone4 :: D -> SE Sig2+ testDrone  cps = atNote (deepPad razorPad) (0.8, cps)+  where+    razorPad = razorPad' def+    razorPad' (RazorPad speed) = withLargeHall' 0.35 $ polySynt $ at fromMono . mul 0.6 . onCps (uncurry $ impRazorPad speed)+ testDrone2 cps = atNote (deepPad nightPad) (0.8, cps)+  where+    nightPad   = withLargeHall $ polySynt $ mul 0.48 . at fromMono . onCps (mul (fadeOut 1) . impNightPad 0.5)+ testDrone3 cps = atNote (deepPad caveOvertonePad) (0.8, cps)+  where+    caveOvertonePad =  FxChain (fx1 0.2 (magicCave2 . mul 0.8)) $ polySynt overtoneInstr+ testDrone4 cps = atNote (deepPad pwEnsemble) (0.8, cps)+  where+    pwEnsemble = withSmallHall $ polySynt $ at fromMono . mul 0.55 . onCps impPwEnsemble -pwEnsemble = withSmallHall $ polySynt $ at fromMono . mul 0.55 . onCps impPwEnsemble-nightPad   = withLargeHall $ polySynt $ mul 0.48 . at fromMono . onCps (mul (fadeOut 1) . impNightPad 0.5) -data RazorPad = RazorPad { razorPadSpeed :: Sig }+data RazorPad = RazorPad Sig  instance Default RazorPad where     def = RazorPad 0.5 -razorPad = razorPad' def-razorPad' (RazorPad speed) = withLargeHall' 0.35 $ polySynt $ at fromMono . mul 0.6 . onCps (uncurry $ impRazorPad speed)--overtonePad = withLargeHall' 0.35 $ polySynt overtoneInstr- overtoneInstr :: CsdNote D -> SE Sig2 overtoneInstr = mul 0.65 . at fromMono . mixAt 0.25 (mlp 1500 0.1) . onCps (\cps -> mul (fades 0.25 1.2) (tibetan 11 0.012 cps) + mul (fades 0.25 1) (tibetan 13 0.015 (cps * 0.5))) -caveOvertonePad =  FxChain (fx1 0.2 (magicCave2 . mul 0.8)) $ polySynt overtoneInstr  -- implem @@ -466,18 +472,20 @@     where wave = ifB (cps `lessThan` 230) (waveBy 5) (ifB (cps `lessThan` 350) (waveBy 3) (waveBy 1))           waveBy x = sines $ [0.3, 0, 0, 0] ++ replicate x 0.1 -impRazorPad speed amp cps = f cps + 0.75 * f (cps * 0.5)-    where f cps = mul (leg 0.5 0 1 1) $ genRazor (filt 1 mlp) speed amp cps+impRazorPad :: Sig -> Sig -> Sig -> SE Sig+impRazorPad speed' amp' cps' = g cps' + 0.75 * g (cps' * 0.5)+    where+      g cps = mul (leg 0.5 0 1 1) $ genRazor (filt 1 mlp) speed' amp' cps -genRazor filter speed amp cps = mul amp $ do-    a1 <- ampSpline 0.01-    a2 <- ampSpline 0.02+      genRazor f speed amp cps = mul amp $ do+          a1 <- ampSpline 0.01+          a2 <- ampSpline 0.02 -    return $ filter (1000 + 2 * cps + 500 * amp) 0.1 $ mean [-          fosc 1 3 (a1 * uosc (speed)) cps-        , fosc 3 1 (a2 * uosc (speed + 0.2)) cps-        , fosc 1 7 (a1 * uosc (speed - 0.15)) cps ]-    where ampSpline c = rspline ( amp) (3.5 + amp) ((speed / 4) * (c - 0.1)) ((speed / 4) * (c  + 0.1))+          return $ f (1000 + 2 * cps + 500 * amp) 0.1 $ mean [+                fosc 1 3 (a1 * uosc (speed)) cps+              , fosc 3 1 (a2 * uosc (speed + 0.2)) cps+              , fosc 1 7 (a1 * uosc (speed - 0.15)) cps ]+          where ampSpline c = rspline ( amp) (3.5 + amp) ((speed / 4) * (c - 0.1)) ((speed / 4) * (c  + 0.1))   -- |@@ -502,14 +510,6 @@ magicCave2 :: Sig2 -> Sig2 magicCave2 = rever2 0.99 --- | Stereo reverb for small hall.-smallHall2 :: Sig2 -> Sig2-smallHall2 = rever2 0.8---- | Stereo reverb for large hall.-largeHall2 :: Sig2 -> Sig2-largeHall2 = rever2 0.9- -- | Mono reverb (based on reverbsc) -- -- > rever2 feedback (asigLeft, asigRight)@@ -583,7 +583,7 @@ -- | Detects attacks in the signal. Outputs trigger-signal -- where 1 is when attack happens and 0 otherwise. attackTrigSig :: Sig -> Sig -> SE Sig-attackTrigSig thresh x = do+attackTrigSig thresh a = do   kTime <- newCtrlRef (iWait + 1)   kTrig <- newCtrlRef 0 @@ -599,7 +599,7 @@    readRef kTrig   where-    da = diffSig 0.01 $ rms x+    da = diffSig 0.01 $ rms a     iWait :: Sig     iWait = 100 

@@ -7,37 +7,39 @@     delModArg1, delModArg2, delModArg3, delModArg4,      -- * Oscillators-    oscArg1, oscArg2, oscArg3, oscArg4,    +    oscArg1, oscArg2, oscArg3, oscArg4,     triArg1, triArg2, triArg3, triArg4,     sqrArg1, sqrArg2, sqrArg3, sqrArg4,     sawArg1, sawArg2, sawArg3, sawArg4,      -- ** Random phase-    rndOscArg1, rndOscArg2, rndOscArg3, rndOscArg4,    +    rndOscArg1, rndOscArg2, rndOscArg3, rndOscArg4,     rndTriArg1, rndTriArg2, rndTriArg3, rndTriArg4,     rndSqrArg1, rndSqrArg2, rndSqrArg3, rndSqrArg4,     rndSawArg1, rndSawArg2, rndSawArg3, rndSawArg4,      -- ** Delayed-    delOscArg1, delOscArg2, delOscArg3, delOscArg4,    +    delOscArg1, delOscArg2, delOscArg3, delOscArg4,     delTriArg1, delTriArg2, delTriArg3, delTriArg4,     delSqrArg1, delSqrArg2, delSqrArg3, delSqrArg4,     delSawArg1, delSawArg2, delSawArg3, delSawArg4,      -- ** Delayed with Random phase-    delRndOscArg1, delRndOscArg2, delRndOscArg3, delRndOscArg4,    +    delRndOscArg1, delRndOscArg2, delRndOscArg3, delRndOscArg4,     delRndTriArg1, delRndTriArg2, delRndTriArg3, delRndTriArg4,     delRndSqrArg1, delRndSqrArg2, delRndSqrArg3, delRndSqrArg4,     delRndSawArg1, delRndSawArg2, delRndSawArg3, delRndSawArg4,      -- * Noise     noiseArg1, noiseArg2, noiseArg3, noiseArg4,+    pinkArg1, pinkArg2, pinkArg3, pinkArg4,     jitArg1, jitArg2, jitArg3, jitArg4,     gaussArg1, gaussArg2, gaussArg3, gaussArg4,     gaussiArg1, gaussiArg2, gaussiArg3, gaussiArg4,      -- ** Delayed     delNoiseArg1, delNoiseArg2, delNoiseArg3, delNoiseArg4,+    delPinkArg1, delPinkArg2, delPinkArg3, delPinkArg4,     delJitArg1, delJitArg2, delJitArg3, delJitArg4,     delGaussArg1, delGaussArg2, delGaussArg3, delGaussArg4,     delGaussiArg1, delGaussiArg2, delGaussiArg3, delGaussiArg4,@@ -56,7 +58,6 @@ import Csound.Typed.Opcode(gauss, gaussi, jitter, linseg, linsegr, expsegr) import Csound.Air.Wave import Csound.Air.Envelope-import Csound.SigSpace  -- trumpet: -- dac $ mul 1.3 $ mixAt 0.15 largeHall2 $ midi $ onMsg (\cps -> (mul (linsegr [0,0.01, 1, 3, 0.2] 0.2 0) . at (jitterArg1 (0.15 + 0.05 * uosc 0.2) 3 20  alp1 (mul (fades 0.2 0.2) $ 2700 + 0.6 * cps) 0.2) . gaussArg1 0.03 (\x -> return (saw x) + mul (0.12 * expseg [1, 2, 0.1]) (bat (alp1 cps 0.4) white))) cps)@@ -421,30 +422,30 @@  -- jitter noise -jitArg1 :: (ModArg1 (SE Sig) b) => Sig -> Sig -> Sig -> b -> ModArgOut1 (SE Sig) b +jitArg1 :: (ModArg1 (SE Sig) b) => Sig -> Sig -> Sig -> b -> ModArgOut1 (SE Sig) b jitArg1 depth cpsMin cpsMax f = modArg1 depth (jitter 1 cpsMin cpsMax) f -jitArg2 :: (ModArg2 (SE Sig) b) => Sig -> Sig -> Sig -> b -> ModArgOut2 (SE Sig) b +jitArg2 :: (ModArg2 (SE Sig) b) => Sig -> Sig -> Sig -> b -> ModArgOut2 (SE Sig) b jitArg2 depth cpsMin cpsMax f = modArg2 depth (jitter 1 cpsMin cpsMax) f -jitArg3 :: (ModArg3 (SE Sig) b) => Sig -> Sig -> Sig -> b -> ModArgOut3 (SE Sig) b +jitArg3 :: (ModArg3 (SE Sig) b) => Sig -> Sig -> Sig -> b -> ModArgOut3 (SE Sig) b jitArg3 depth cpsMin cpsMax f = modArg3 depth (jitter 1 cpsMin cpsMax) f -jitArg4 :: (ModArg4 (SE Sig) b) => Sig -> Sig -> Sig -> b -> ModArgOut4 (SE Sig) b +jitArg4 :: (ModArg4 (SE Sig) b) => Sig -> Sig -> Sig -> b -> ModArgOut4 (SE Sig) b jitArg4 depth cpsMin cpsMax f = modArg4 depth (jitter 1 cpsMin cpsMax) f  -- jitter noise -delJitArg1 :: (ModArg1 (SE Sig) b) => D -> D -> Sig -> Sig -> Sig -> b -> ModArgOut1 (SE Sig) b +delJitArg1 :: (ModArg1 (SE Sig) b) => D -> D -> Sig -> Sig -> Sig -> b -> ModArgOut1 (SE Sig) b delJitArg1 delTime riseTime depth cpsMin cpsMax f = delModArg1 delTime riseTime depth (jitter 1 cpsMin cpsMax) f -delJitArg2 :: (ModArg2 (SE Sig) b) => D -> D -> Sig -> Sig -> Sig -> b -> ModArgOut2 (SE Sig) b +delJitArg2 :: (ModArg2 (SE Sig) b) => D -> D -> Sig -> Sig -> Sig -> b -> ModArgOut2 (SE Sig) b delJitArg2 delTime riseTime depth cpsMin cpsMax f = delModArg2 delTime riseTime depth (jitter 1 cpsMin cpsMax) f -delJitArg3 :: (ModArg3 (SE Sig) b) => D -> D -> Sig -> Sig -> Sig -> b -> ModArgOut3 (SE Sig) b +delJitArg3 :: (ModArg3 (SE Sig) b) => D -> D -> Sig -> Sig -> Sig -> b -> ModArgOut3 (SE Sig) b delJitArg3 delTime riseTime depth cpsMin cpsMax f = delModArg3 delTime riseTime depth (jitter 1 cpsMin cpsMax) f -delJitArg4 :: (ModArg4 (SE Sig) b) => D -> D -> Sig -> Sig -> Sig -> b -> ModArgOut4 (SE Sig) b +delJitArg4 :: (ModArg4 (SE Sig) b) => D -> D -> Sig -> Sig -> Sig -> b -> ModArgOut4 (SE Sig) b delJitArg4 delTime riseTime depth cpsMin cpsMax f = delModArg4 delTime riseTime depth (jitter 1 cpsMin cpsMax) f  -- gauss noise@@ -759,7 +760,7 @@  instance ModArg2 (SE Sig) (a -> Sig -> b -> c -> Sig2) where     type ModArgOut2 (SE Sig) (a -> Sig -> b -> c -> Sig2) = a -> Sig -> b -> c -> SE Sig2-    modArg2 depth ma f = \x1 x2 x3 x4 -> fmap (\a -> f x1 (x2 * (1 + depth * a)) x3 x4) ma    +    modArg2 depth ma f = \x1 x2 x3 x4 -> fmap (\a -> f x1 (x2 * (1 + depth * a)) x3 x4) ma  -------------------------------------------- -- dirty in, dirty mono out@@ -789,7 +790,7 @@  instance ModArg2 (SE Sig) (a -> Sig -> b -> c -> SE Sig2) where     type ModArgOut2 (SE Sig) (a -> Sig -> b -> c -> SE Sig2) = a -> Sig -> b -> c -> SE Sig2-    modArg2 depth ma f = \x1 x2 x3 x4 -> ma >>= (\a -> f x1 (x2 * (1 + depth * a)) x3 x4)    +    modArg2 depth ma f = \x1 x2 x3 x4 -> ma >>= (\a -> f x1 (x2 * (1 + depth * a)) x3 x4)  -------------------------------------------- --------------------------------------------@@ -830,7 +831,7 @@  instance ModArg3 Sig (a -> b -> Sig -> c -> SE Sig) where     type ModArgOut3 Sig (a -> b -> Sig -> c -> SE Sig) = a -> b -> Sig -> c -> SE Sig-    modArg3 depth a f = \x1 x2 x3 x4 -> f x1 x2 (x3 * (1 + depth * a)) x4    +    modArg3 depth a f = \x1 x2 x3 x4 -> f x1 x2 (x3 * (1 + depth * a)) x4  -------------------------------------------- -- pure in, dirty stereo out@@ -841,7 +842,7 @@  instance ModArg3 Sig (a -> b -> Sig -> c -> SE Sig2) where     type ModArgOut3 Sig (a -> b -> Sig -> c -> SE Sig2) = a -> b -> Sig -> c -> SE Sig2-    modArg3 depth a f = \x1 x2 x3 x4 -> f x1 x2 (x3 * (1 + depth * a)) x4    +    modArg3 depth a f = \x1 x2 x3 x4 -> f x1 x2 (x3 * (1 + depth * a)) x4  -------------------------------------------- -- dirty in, pure mono out@@ -863,7 +864,7 @@  instance ModArg3 (SE Sig) (a -> b -> Sig -> c -> Sig2) where     type ModArgOut3 (SE Sig) (a -> b -> Sig -> c -> Sig2) = a -> b -> Sig -> c -> SE Sig2-    modArg3 depth ma f = \x1 x2 x3 x4 -> fmap (\a -> f x1 x2 (x3 * (1 + depth * a)) x4) ma    +    modArg3 depth ma f = \x1 x2 x3 x4 -> fmap (\a -> f x1 x2 (x3 * (1 + depth * a)) x4) ma  -------------------------------------------- -- dirty in, dirty mono out@@ -893,7 +894,7 @@  class ModArg4 a b where     type ModArgOut4 a b :: *-    modArg4 :: Sig -> a -> b -> ModArgOut4 a b  +    modArg4 :: Sig -> a -> b -> ModArgOut4 a b  -------------------------------------------- -- pure in, pure mono out@@ -907,7 +908,7 @@  instance ModArg4 Sig (a -> b -> c -> Sig -> Sig2) where     type ModArgOut4 Sig (a -> b -> c -> Sig -> Sig2) = a -> b -> c -> Sig -> Sig2-    modArg4 depth a f = \x1 x2 x3 x4 -> f x1 x2 x3 (x4 * (1 + depth * a))    +    modArg4 depth a f = \x1 x2 x3 x4 -> f x1 x2 x3 (x4 * (1 + depth * a))  -------------------------------------------- -- pure in, dirty mono out@@ -935,7 +936,7 @@  instance ModArg4 (SE Sig) (a -> b -> c -> Sig -> Sig2) where     type ModArgOut4 (SE Sig) (a -> b -> c -> Sig -> Sig2) = a -> b -> c -> Sig -> SE Sig2-    modArg4 depth ma f = \x1 x2 x3 x4 -> fmap (\a -> f x1 x2 x3 (x4 * (1 + depth * a))) ma    +    modArg4 depth ma f = \x1 x2 x3 x4 -> fmap (\a -> f x1 x2 x3 (x4 * (1 + depth * a))) ma  -------------------------------------------- -- dirty in, dirty mono out

@@ -8,14 +8,14 @@ -- -- An example: ----- > harms = [ --- >     1, 0.7600046992, 0.6199994683, 0.9399998784, 0.4400023818, 0.0600003302, --- >     0.8499968648, 0.0899999291, 0.8199964762, 0.3199984133, +-- > harms = [+-- >     1, 0.7600046992, 0.6199994683, 0.9399998784, 0.4400023818, 0.0600003302,+-- >     0.8499968648, 0.0899999291, 0.8199964762, 0.3199984133, -- >     0.9400014281, 0.3000001907, 0.120003365, 0.1799997687, 0.5200006366]--- > +-- > -- > spec = defPadsynthSpec 42.2 harms--- > --- > main = dac $ mul 0.4 $ mixAt 0.35 largeHall2 $ mixAt 0.45 (echo 0.25 0.75) $ +-- >+-- > main = dac $ mul 0.4 $ mixAt 0.35 largeHall2 $ mixAt 0.45 (echo 0.25 0.75) $ -- >             midi $ onMsg $ mul (fades 0.5 0.7) . padsynthOsc2 spec  module Csound.Air.Padsynth (@@ -30,11 +30,11 @@     padsynthOscMultiVolCps, padsynthOscMultiVolCps2,      -- * Granular oscillators-    morphsynthOscMultiCps, quadMorphsynthOscMultiCps   +    morphsynthOscMultiCps, quadMorphsynthOscMultiCps ) where  import Data.List-import Control.Arrow+import Control.Arrow (first, second)  import Csound.Typed import Csound.Tab@@ -44,11 +44,11 @@  import Csound.Air.Granular.Morpheus --- | Padsynth oscillator. +-- | Padsynth oscillator. -- -- padsynthOsc spec frequency ----- It makes it easy to create padsynth sound waves (see Tab.padsynth). +-- It makes it easy to create padsynth sound waves (see Tab.padsynth). -- It creates a padsynth table and reads it with poscil at the right speed. padsynthOsc :: PadsynthSpec -> Sig -> SE Sig padsynthOsc spec freq = padsynthOscByTab (double $ padsynthFundamental spec) (padsynth spec) freq@@ -57,7 +57,7 @@ padsynthOscByTab baseFreq tab freq = ares     where         len = ftlen tab-        wave = rndPhs (\phs freq -> poscil 1 freq tab `withD` phs)+        wave = rndPhs (\phs frq -> poscil 1 frq tab `withD` phs)         ares = wave (freq * (sig $ (getSampleRate / len) / baseFreq))  toStereoOsc :: (a -> SE Sig) -> (a -> SE Sig2)@@ -81,16 +81,13 @@     baseFreq <- readRef refBaseFreq      return (baseFreq, tab)-    where      +    where         toCase refTab refBaseFreq spec = do             writeRef refTab (padsynth spec)             writeRef refBaseFreq (double $ padsynthFundamental spec)          lastTab      = padsynth $ snd $ last specs         lastBaseFreq = double $ padsynthFundamental $ snd $ last specs-   -toThreshholdCond :: D -> (Double, PadsynthSpec) -> (BoolD, PadsynthSpec)-toThreshholdCond val (thresh, spec) = (val `lessThanEquals` double thresh, spec)  -- | It uses several padsynth tables. Each table is responsible for specific interval of frequencies. -- The list of pairs specifies the threshhold value and padsynth specification.@@ -131,7 +128,7 @@ -- -- > padsynthOscMultiVolCps thresholdSpecPairs (amplitude, frequency) = ... padsynthOscMultiVolCps :: [((Double, Double), PadsynthSpec)] -> (D, D) -> SE Sig-padsynthOscMultiVolCps specs (amp, freq) = undefined+padsynthOscMultiVolCps _ = undefined  -- | TODO (undefined function) --@@ -162,8 +159,11 @@ bwOddOscBy2 :: [Double] -> Double -> Sig -> SE Sig2 bwOddOscBy2 harmonics bandwidth = toStereoOsc (bwOddOscBy harmonics bandwidth) +limit :: Int limit = 15 +triCoeff, sqrCoeff, sawCoeff :: [Double]+ triCoeff = intersperse 0 $ zipWith (*) (iterate (* (-1)) (1)) $ fmap (\x -> 1 / (x * x)) $ [1, 3 ..] sqrCoeff = intersperse 0 $ zipWith (*) (iterate (* (-1)) (1)) $ fmap (\x -> 1 / (x))     $ [1, 3 ..] sawCoeff = zipWith (*) (iterate (* (-1)) (1)) $ fmap (\x -> 1 / (x)) $ [1, 2 ..]@@ -238,9 +238,10 @@ -- 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 +    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)+        getFreqTab spec = layeredPadsynthSpec freq (fmap (first double) spec)+        toTab mainFreq (frq, t) = (sig $ frq / mainFreq, t)+

@@ -1,29 +1,29 @@-{-# Language ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances #-}+{-# Language ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances, LambdaCase #-} -- | Patches. module Csound.Air.Patch(-  -	CsdNote, Instr, MonoInstr, Fx, Fx1, Fx2, FxSpec(..), DryWetRatio,-	Patch1, Patch2, Patch(..), PolySyntSpec(..), MonoSyntSpec(..),++  CsdNote, Instr, MonoInstr, Fx, Fx1, Fx2, FxSpec(..), DryWetRatio,+  Patch1, Patch2, Patch(..), PolySyntSpec(..), MonoSyntSpec(..),     SyntSkin, GenInstr, GenMonoInstr, GenFxSpec,     polySynt, monoSynt, adsrMono, adsrMonoFilter, fxSpec, polySyntFilter, monoSyntFilter, fxSpecFilter, -    mapPatchInstr, mapMonoPolyInstr, transPatch, dryPatch, getPatchFx,	+    mapPatchInstr, mapMonoPolyInstr, transPatch, dryPatch, getPatchFx,     setFxMix, setFxMixes,     setMidiChn, -	-- * Midi-	atMidi, +  -- * Midi+  atMidi, -	-- * Events-	atSched, atSchedUntil, atSchedHarp,+  -- * Events+  atSched, atSchedUntil, atSchedHarp, -	-- * Sco-	atSco,+  -- * Sco+  atSco, -	-- * Single note-	atNote,+  -- * Single note+  atNote, -	-- * Fx+  -- * Fx     addInstrFx, addPreFx, addPostFx,      -- ** Specific fx@@ -31,56 +31,55 @@     mapFx, mapFx', bindFx, bindFx',     mapPreFx, mapPreFx', bindPreFx, bindPreFx', -	-- * Pads-	harmonPatch, deepPad,+  -- * Pads+  harmonPatch, deepPad, -	-- * Misc-	patchWhen, +  -- * Misc+  patchWhen,      mixInstr, -	-- * Rever-	withSmallRoom, withSmallRoom', -	withSmallHall, withSmallHall',-	withLargeHall, withLargeHall',-	withMagicCave, withMagicCave',+  -- * Rever+  withSmallRoom, withSmallRoom',+  withSmallHall, withSmallHall',+  withLargeHall, withLargeHall',+  withMagicCave, withMagicCave', -	-- * Sound font patches-	sfPatch, sfPatchHall,+  -- * Sound font patches+  sfPatch, sfPatchHall,      -- * Monosynt params     onMonoSyntSpec, setMonoSlide, setMonoSharp,-	+     -- * Csound API     patchByNameMidi, -	-- * Custom temperament-	-- ** Midi-	atMidiTemp,-	-- ** Csound API-    patchByNameMidiTemp	    +  -- * Custom temperament+  -- ** Midi+  atMidiTemp,+  -- ** Csound API+    patchByNameMidiTemp ) where -import Data.Boolean-import Data.Default    +import Data.Boolean hiding (cond)+import Data.Default import Control.Monad import Control.Applicative import Control.Arrow(second)  import Control.Monad.Trans.Reader-import Csound.Typed-import Csound.SigSpace+import Csound.Typed hiding (arg) import Csound.Control.Midi import Csound.Control.Instr import Csound.Control.Evt(impulse) import Csound.Control.Sf import Csound.Air.Fx import Csound.Air.Filter(ResonFilter, mlp)-import Csound.Typed.Opcode(cpsmidinn, ampdb)+import Csound.Typed.Opcode(cpsmidinn) import Csound.Tuning import Csound.Types -import Csound.SigSpace+import Temporal.Media hiding (rest) import Csound.IO  -- | Common parameters for patches. We use this type to parametrize the patch with some tpyes of arguments@@ -88,7 +87,7 @@ -- change the character of the patch. So by making patches depend on filter type we can let the user to change -- the filter type and  leave the algorithm the same. It's like changing between trademarks. Moog sound vs Korg sound. ----- The instruments in the patches depend on the @SyntSkin@ through the @Reader@ data type. +-- The instruments in the patches depend on the @SyntSkin@ through the @Reader@ data type. -- -- If user doesn't supply any syntSkin value the default is used (`mlp` -- moog low pass filter). Right now -- the data type is just a synonym for filter but it can become a data type with more parameters in the future releases.@@ -125,9 +124,9 @@  -- | Fx specification. It;s a pair of dryWet ratio and a transformation function. data FxSpec a = FxSpec-	{ fxMix :: DryWetRatio-	, fxFun :: Fx a	-	}+  { fxMix :: DryWetRatio+  , fxFun :: Fx a+  }  -- | Mono-output patch. type Patch1 = Patch Sig@@ -136,17 +135,17 @@ type Patch2 = Patch Sig2  -- | Specification for monophonic synthesizer.--- +-- -- * Chn -- midi channel to listen on -- -- * SlideTime -- time of transition between notes data MonoSyntSpec = MonoSyntSpec-    { monoSyntChn       :: MidiChn      +    { monoSyntChn       :: MidiChn     , monoSyntSlideTime :: Maybe D }  instance Default MonoSyntSpec where-    def = MonoSyntSpec -        { monoSyntChn = ChnAll        +    def = MonoSyntSpec+        { monoSyntChn = ChnAll         , monoSyntSlideTime = Just 0.008 }  data PolySyntSpec = PolySyntSpec@@ -163,13 +162,13 @@ -- -- * set of common parameters (@SyntSkin@) ----- * patch with chain of effects, +-- * 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 +data Patch a     = MonoSynt MonoSyntSpec (GenMonoInstr a) -- (GenInstr Sig a)     | PolySynt PolySyntSpec (GenInstr D   a)     | SetSkin SyntSkin (Patch a)@@ -177,14 +176,14 @@     | SplitPatch (Patch a) D (Patch a)     | LayerPatch [(Sig, Patch a)] -+smoothMonoSpec :: MonoSyntSpec -> MonoArg -> MonoArg smoothMonoSpec spec = maybe id smoothMonoArg (monoSyntSlideTime spec)  -- | Constructor for polyphonic synthesizer. It expects a function from notes to signals. polySynt :: (Instr D a) -> Patch a polySynt = PolySynt def . return --- | Constructor for polyphonic synthesizer with flexible choice of the low-pass filter. +-- | Constructor for polyphonic synthesizer with flexible choice of the low-pass filter. -- If we use the filter from the first argument user lately can change it to some another filter. It defaults to mlp. polySyntFilter :: (ResonFilter -> Instr D a) -> Patch a polySyntFilter instr = PolySynt def $ reader instr@@ -197,9 +196,9 @@ -- | Constructor for monophonic synth with envelope generator and flexible choice of filter. It's just like @adsrMono@ -- but the user lately can change filter provided in the first argument to some another filter. adsrMonoFilter :: (ResonFilter -> MonoAdsr -> Instr Sig a) -> Patch a-adsrMonoFilter f = monoSyntFilter (\filter -> adsrMonoSynt (f filter))+adsrMonoFilter f = monoSyntFilter (\fltr -> adsrMonoSynt (f fltr)) --- | Constructor for monophonic synthesizer. The instrument is defned on the raw monophonic aruments (see @MonoArg@). +-- | Constructor for monophonic synthesizer. The instrument is defned on the raw monophonic aruments (see @MonoArg@). monoSynt :: (MonoInstr a) -> Patch a monoSynt = MonoSynt def . return @@ -207,13 +206,13 @@ monoSyntFilter :: (ResonFilter -> MonoInstr a) -> Patch a monoSyntFilter instr = MonoSynt def $ reader instr --- | Constructor for FX-specification. +-- | Constructor for FX-specification. -- -- > fxSpec dryWetRatio fxFun fxSpec :: Sig -> Fx a -> GenFxSpec a fxSpec ratio fx = return $ FxSpec ratio fx --- | Constructor for FX-specification with flexible filter choice. +-- | Constructor for FX-specification with flexible filter choice. -- -- > fxSpec dryWetRatio fxFun fxSpecFilter :: Sig -> (ResonFilter -> Fx a) -> GenFxSpec a@@ -245,9 +244,9 @@  -- | Removes all effects from the patch. dryPatch :: Patch a -> Patch a-dryPatch x = case x of-    MonoSynt spec instr -> x-    PolySynt spec instr -> x+dryPatch patch = case patch of+    MonoSynt _ _ -> patch+    PolySynt _ _ -> patch     SetSkin skin p -> SetSkin skin (dryPatch p)     FxChain _ p         -> dryPatch p     SplitPatch a dt b   -> SplitPatch (dryPatch a) dt (dryPatch b)@@ -259,9 +258,9 @@  -- | 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 -> fmap (\t -> t { fxMix = k }) x) ks fxs) x-    _ -> p+setFxMixes ks = \case+    FxChain fxs x -> FxChain (zipFirst (\k q -> fmap (\t -> t { fxMix = k }) q) ks fxs) x+    other -> other     where         zipFirst f xs ys = case (xs, ys) of             (_,    [])   -> []@@ -271,7 +270,7 @@ --------------------------------------------------------------  instance SigSpace a => SigSpace (Patch a) where-	mapSig f x = +  mapSig f x =             case x of                 MonoSynt spec instr -> MonoSynt spec $ fmap (fmap (mapSig f) . ) $ instr                 PolySynt spec instr -> PolySynt spec $ fmap (fmap (mapSig f) . ) $ instr@@ -281,7 +280,7 @@                 LayerPatch xs  -> FxChain [return $ FxSpec 1 (return . mapSig f)] $ LayerPatch xs  mapSnd :: (a -> b) -> [(c, a)] -> [(c, b)]-mapSnd f = fmap (second f) +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@@ -292,16 +291,16 @@  -- | Plays a patch with a single infinite note. atNote :: (SigSpace a, Sigs a) => Patch a -> CsdNote D -> SE a-atNote p note = go Nothing p note-    where              -        go maybeSkin p note@(amp, cps) = case p of-            MonoSynt spec instr -> (runSkin instr maybeSkin) (MonoArg (sig amp) (sig cps) 1 (impulse 0))-            PolySynt spec instr -> (runSkin instr maybeSkin) note+atNote = go Nothing+    where+        go maybeSkin q note@(amp, cps) = case q of+            MonoSynt _spec instr -> (runSkin instr maybeSkin) (MonoArg (sig amp) (sig cps) 1 (impulse 0))+            PolySynt _spec instr -> (runSkin instr maybeSkin) note             SetSkin  skin p -> newSkin skin p             FxChain fxs p -> getPatchFx maybeSkin fxs =<< rec p             LayerPatch xs -> onLayered xs rec             SplitPatch a t b -> getSplit (cps `lessThan` t) (rec a) (rec b)-            where                +            where                 rec x = go maybeSkin x note                 newSkin skin x = go (Just skin) x note @@ -311,7 +310,7 @@ getSplit :: (Num a, Tuple a) => BoolD -> SE a -> SE a -> SE a getSplit cond a b = do     ref <- newRef 0-    whenElseD cond +    whenElseD cond         (mixRef ref =<< a)         (mixRef ref =<< b)     readRef ref@@ -320,17 +319,17 @@ -- midi  midiChn :: Sigs a => MidiChn -> (Msg -> SE a) -> SE a-midiChn chn = case chn of+midiChn = \case     ChnAll -> midi     Chn n  -> midin n     Pgm pgm chn -> pgmidi pgm chn --- | Plays a patch with midi. +-- | Plays a patch with midi. atMidi :: (SigSpace a, Sigs a) => Patch a -> SE a-atMidi x = go Nothing x-    where -        go maybeSkin x = case x of-            MonoSynt spec instr -> monoSynt spec (runSkin instr maybeSkin)+atMidi = go Nothing+    where+        go maybeSkin = \case+            MonoSynt spec instr -> monoSyntProc spec (runSkin instr maybeSkin)             PolySynt spec instr -> midiChn (polySyntChn spec) ((runSkin instr maybeSkin) . ampCps)             SetSkin skin p -> newSkin skin p             FxChain fxs p -> getPatchFx maybeSkin fxs =<< rec p@@ -340,17 +339,17 @@                 newSkin skin p = go (Just skin) p                 rec = go maybeSkin -                monoSynt spec instr = instr =<< getArg+                monoSyntProc spec instr = instr =<< getArg                     where-                        getArg = fmap (smoothMonoSpec spec) $ genMonoMsg chn                         +                        getArg = fmap (smoothMonoSpec spec) $ genMonoMsg chn                         chn  = monoSyntChn spec  -- | Plays a patch with midi with given temperament (see @Csound.Tuning@). atMidiTemp :: (SigSpace a, Sigs a) => Temp -> Patch a -> SE a-atMidiTemp tm x = go Nothing x-    where -        go maybeSkin x = case x of-            MonoSynt spec instr -> monoSynt spec (runSkin instr maybeSkin)+atMidiTemp tm = go Nothing+    where+        go maybeSkin = \case+            MonoSynt spec instr -> monoSyntProc spec (runSkin instr maybeSkin)             PolySynt spec instr -> midiChn (polySyntChn spec) ((runSkin instr maybeSkin) . ampCps' tm)             SetSkin skin p -> newSkin skin p             FxChain fxs p -> getPatchFx maybeSkin fxs =<< rec p@@ -360,38 +359,38 @@                 newSkin skin p = go (Just skin) p                 rec = go maybeSkin -                monoSynt spec instr = instr =<< getArg+                monoSyntProc spec instr = instr =<< getArg                     where-                        getArg = fmap (smoothMonoSpec spec) $ genMonoMsgTemp tm chn                         +                        getArg = fmap (smoothMonoSpec spec) $ genMonoMsgTemp tm chn                         chn  = monoSyntChn spec   genMidiSplitPatch :: (SigSpace a, Sigs a) => Maybe SyntSkin -> (Msg -> (D, D)) -> Patch a -> D -> Patch a -> SE a-genMidiSplitPatch maybeSkin midiArg = genSplitPatch maybeSkin playMonoInstr playInstr +genMidiSplitPatch maybeSkin midiArg = genSplitPatch maybeSkin playMonoInstr playInstr     where         playMonoInstr chn cond instr = instr =<< genFilteredMonoMsg chn cond         playInstr chn instr = midiChn chn (instr . midiArg)  genSplitPatch :: (SigSpace a, Sigs a) => Maybe SyntSkin -> (MidiChn -> (D -> BoolD) -> MonoInstr a -> SE a)  -> (MidiChn -> (CsdNote D -> SE a) -> SE a) -> Patch a -> D -> Patch a -> SE a-genSplitPatch maybeSkin playMonoInstr playInstr a dt b = liftA2 (+) (leftSplit maybeSkin dt a) (rightSplit maybeSkin dt b)+genSplitPatch maybeSkin' playMonoInstr playInstr a' dt' b' = liftA2 (+) (leftSplit maybeSkin' dt' a') (rightSplit maybeSkin' dt' b')     where         leftSplit  maybeSkin dt a = onCondPlay maybeSkin ( `lessThan` dt)          ( `lessThan` (sig dt))           a         rightSplit maybeSkin dt a = onCondPlay maybeSkin ( `greaterThanEquals` dt) ( `greaterThanEquals` (sig dt))  a -        onCondPlay maybeSkin cond condSig x = case x of-            MonoSynt spec instr -> playMonoInstr  (monoSyntChn spec) cond  (runSkin instr maybeSkin)+        onCondPlay maybeSkin cond condSig = \case+            MonoSynt spec instr -> playMonoInstr  (monoSyntChn spec) cond  (restrictMonoInstr condSig $ runSkin instr maybeSkin)             PolySynt spec instr -> playInstr (polySyntChn spec) (restrictPolyInstr cond (runSkin instr maybeSkin))             SetSkin  skin p -> onCondPlay (Just skin) cond condSig p             FxChain fxs p -> getPatchFx maybeSkin fxs =<< onCondPlay maybeSkin cond condSig p             LayerPatch xs -> onLayered xs (onCondPlay maybeSkin cond condSig)-            SplitPatch a dt b -> liftA2 (+) -                        (onCondPlay maybeSkin (\x -> cond x &&* (x `lessThan` dt))           (\x -> condSig x &&* (x `lessThan` (sig dt))) a) +            SplitPatch a dt b -> liftA2 (+)+                        (onCondPlay maybeSkin (\x -> cond x &&* (x `lessThan` dt))           (\x -> condSig x &&* (x `lessThan` (sig dt))) a)                         (onCondPlay maybeSkin (\x -> cond x &&* (x `greaterThanEquals` dt))  (\x -> condSig x &&* (x `greaterThanEquals` (sig dt) ))  b)  restrictPolyInstr :: (Sigs a) => (D -> BoolD) -> (CsdNote D -> SE a) -> CsdNote D -> SE a-restrictPolyInstr cond instr note@(amp, cps) = do+restrictPolyInstr cond instr note@(_amp, cps) = do     ref <- newRef 0-    whenElseD (cond cps) +    whenElseD (cond cps)         (writeRef ref =<< instr note)         (writeRef ref 0)     readRef ref@@ -399,15 +398,15 @@ restrictMonoInstr :: (Sigs a) => (Sig -> BoolSig) -> MonoInstr a -> MonoInstr a restrictMonoInstr cond instr arg = instr $ arg { monoGate = monoGate arg * gate2 }     where-        cps = monoCps arg +        cps = monoCps arg         gate2 = ifB (cond cps) 1 0  -------------------------------------------------------------- -- sched --- | Plays a patch with event stream. +-- | Plays a patch with event stream. atSched :: (SigSpace a, Sigs a) => Patch a -> Evt (Sco (CsdNote D)) -> SE a-atSched x evt = go Nothing x evt+atSched = go Nothing     where         go maybeSkin x evt = case x of             MonoSynt spec instr -> (runSkin instr maybeSkin) =<< (fmap (smoothMonoSpec spec) $ monoSched evt)@@ -416,28 +415,28 @@             FxChain fxs p  -> getPatchFx maybeSkin fxs =<< rec p             LayerPatch xs -> onLayered xs rec             SplitPatch a t b -> genSplitPatch maybeSkin (const $ const playMonoInstr) (const playInstr) a t b-            where -                rec x = go maybeSkin x evt-                newSkin skin x = go (Just skin) x evt+            where+                rec a = go maybeSkin a evt+                newSkin skin a = go (Just skin) a evt                 playInstr instr = return $ sched instr evt                 playMonoInstr instr = instr =<< monoSched evt --- | Plays a patch with event stream with stop-note event stream. +-- | 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 = go Nothing x evt stop-    where -        go maybeSkin x evt stop = case x of     +atSchedUntil = go Nothing+    where+        go maybeSkin x evt stop = case x of             MonoSynt _ instr -> playMonoInstr (runSkin instr maybeSkin)             PolySynt _ instr -> playInstr (runSkin instr maybeSkin)             SetSkin skin p -> newSkin skin p             FxChain fxs p  -> getPatchFx maybeSkin fxs =<< rec p             LayerPatch xs -> onLayered xs rec             SplitPatch a cps b -> genSplitPatch maybeSkin (const $ const playMonoInstr) (const playInstr) a cps b-            where -                rec x = go maybeSkin x evt stop-                newSkin skin x = go (Just skin) x evt stop+            where+                rec a = go maybeSkin a evt stop+                newSkin skin a = go (Just skin) a evt stop                 playInstr instr = return $ schedUntil instr evt stop-                playMonoInstr instr = instr =<< monoSchedUntil evt stop                +                playMonoInstr instr = instr =<< monoSchedUntil evt stop  -- | Plays notes indefinetely (it's more useful for monophonic synthesizers). atSchedHarp :: (SigSpace a, Sigs a) => Patch a -> Evt (CsdNote D) -> SE a@@ -445,50 +444,50 @@  -------------------------------------------------------------- -- sco- --- | Plays a patch with scores. ++-- | Plays a patch with scores. atSco :: forall a . (SigSpace a, Sigs a) => Patch a -> Sco (CsdNote D) -> Sco (Mix a)-atSco x sc = go Nothing x sc-    where         -        go maybeSkin x sc = case x of-            MonoSynt _ instr -> monoSco (runSkin instr maybeSkin) sc-            PolySynt _ instr -> sco (runSkin instr maybeSkin) sc -            SetSkin skin p -> newSkin skin p-            FxChain fxs p  -> eff (getPatchFx maybeSkin fxs) $ rec p+atSco = go Nothing+    where+        go skin x sc = case x of+            MonoSynt _ instr -> monoSco (runSkin instr skin) sc+            PolySynt _ instr -> sco (runSkin instr skin) sc+            SetSkin sk p -> newSkin sk p+            FxChain fxs p  -> eff (getPatchFx skin fxs) $ rec p             LayerPatch xs -> har $ fmap (\(vol, p) -> rec (mul vol p)) xs-            SplitPatch a cps b -> scoSplitPatch maybeSkin a cps b sc+            SplitPatch a cps b -> scoSplitPatch skin a cps b             where-                rec x = go maybeSkin x sc-                newSkin skin x = go (Just skin) x sc+                rec a = go skin a sc+                newSkin sk a = go (Just sk) a sc -                scoSplitPatch :: Maybe SyntSkin -> Patch a -> D -> Patch a -> Sco (CsdNote D) -> Sco (Mix a)-                scoSplitPatch maybeSkin a dt b sc = har [leftSplit maybeSkin dt a, rightSplit maybeSkin dt b]+                scoSplitPatch :: Maybe SyntSkin -> Patch a -> D -> Patch a -> Sco (Mix a)+                scoSplitPatch maybeSkin a dt b = har [leftSplit maybeSkin dt a, rightSplit maybeSkin dt b]                     where-                        leftSplit  maybeSkin dt a = onCondPlay maybeSkin ( `lessThan` dt) a-                        rightSplit maybeSkin dt a = onCondPlay maybeSkin ( `greaterThanEquals` dt) a+                        leftSplit  mSkin t = onCondPlay mSkin ( `lessThan` t)+                        rightSplit mSkin t = onCondPlay mSkin ( `greaterThanEquals` t) -                        onCondPlay maybeSkin cond x = case x of-                            MonoSynt spec instr -> error "Split doesn't work for monophonic synths with Scores. Please use only polyphonic synths in this case."-                            PolySynt spec instr -> sco (restrictPolyInstr cond (runSkin instr maybeSkin)) sc-                            SetSkin skin p -> onCondPlay (Just skin) cond p-                            FxChain fxs p -> eff (getPatchFx maybeSkin fxs) $ go maybeSkin p sc-                            LayerPatch xs -> har $ fmap (\(vol, p) -> go maybeSkin (mul vol p) sc) xs-                            SplitPatch a dt b -> har -                                        [ onCondPlay maybeSkin (\x -> cond x &&* (x `lessThan` dt)) a-                                        , onCondPlay maybeSkin (\x -> cond x &&* (x `greaterThanEquals` dt)) b ]+                        onCondPlay mSkin cond = \case+                            MonoSynt _spec _instr -> error "Split doesn't work for monophonic synths with Scores. Please use only polyphonic synths in this case."+                            PolySynt _spec instr -> sco (restrictPolyInstr cond (runSkin instr mSkin)) sc+                            SetSkin sk p -> onCondPlay (Just sk) cond p+                            FxChain fxs p -> eff (getPatchFx mSkin fxs) $ go mSkin p sc+                            LayerPatch xs -> har $ fmap (\(vol, p) -> go mSkin (mul vol p) sc) xs+                            SplitPatch m t n -> har+                                        [ onCondPlay mSkin (\q -> cond q &&* (q `lessThan` t)) m+                                        , onCondPlay mSkin (\q -> cond q &&* (q `greaterThanEquals` t)) n ]  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)    +--    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-    SetSkin skin p -> SetSkin skin  $ onMonoSyntSpec f p -    FxChain fxs p -> FxChain fxs $ onMonoSyntSpec f p +    SetSkin skin p -> SetSkin skin  $ onMonoSyntSpec f p+    FxChain fxs p -> FxChain fxs $ onMonoSyntSpec f p     LayerPatch xs -> LayerPatch $ mapSnd (onMonoSyntSpec f) xs     SplitPatch a cps b -> SplitPatch (onMonoSyntSpec f a) cps (onMonoSyntSpec f b) @@ -497,8 +496,8 @@ setMidiChn chn x = case x of     MonoSynt spec instr -> MonoSynt (spec { monoSyntChn = chn }) instr     PolySynt spec instr -> PolySynt (spec { polySyntChn = chn }) instr-    SetSkin skin p -> SetSkin skin $ go p -    FxChain fxs p -> FxChain fxs $ go p +    SetSkin skin p -> SetSkin skin $ go p+    FxChain fxs p -> FxChain fxs $ go p     LayerPatch xs -> LayerPatch $ mapSnd go xs     SplitPatch a cps b -> SplitPatch (go a) cps (go b)     where go = setMidiChn chn@@ -531,21 +530,22 @@ addPreFx dw f p = case p of     FxChain fxs (PolySynt spec instr) -> FxChain (addFx fxs) (PolySynt spec instr)     FxChain fxs (MonoSynt spec instr) -> FxChain (addFx fxs) (MonoSynt spec instr)-    SetSkin skin p -> SetSkin skin $ addPreFx dw f p-    PolySynt spec instr -> FxChain fxSpec $ PolySynt spec instr-    MonoSynt spec instr -> FxChain fxSpec $ MonoSynt spec instr+    SetSkin skin q -> SetSkin skin $ addPreFx dw f q+    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 = [return $ FxSpec dw f]+    _ -> undefined+    where+        addFx xs = xs ++ fxSpec'+        fxSpec' = [return $ FxSpec dw f]  -- | Appends an effect after patch's effect. addPostFx :: DryWetRatio -> Fx a -> Patch a -> Patch a addPostFx dw f p = case p of-    FxChain fxs rest -> FxChain (return fxSpec : fxs) rest-    _                -> FxChain [return fxSpec] p-    where fxSpec = FxSpec dw f+    FxChain fxs rest -> FxChain (return fxSpec' : fxs) rest+    _                -> FxChain [return fxSpec'] p+    where fxSpec' = FxSpec dw f  -------------------------------------------------------------- @@ -557,10 +557,10 @@     SetSkin skin p -> SetSkin skin $ rec p     FxChain  fxs p      -> FxChain (fmap (fmap $ mapFun (playWhen cond)) fxs) (rec p)     LayerPatch xs       -> LayerPatch $ mapSnd rec xs-    SplitPatch a cps b  -> SplitPatch (rec a) cps (rec b)        -    where +    SplitPatch a cps b  -> SplitPatch (rec a) cps (rec b)+    where         rec = patchWhen cond-        mapFun f x = x { fxFun = f $ fxFun x }+        mapFun f a = a { fxFun = f $ fxFun a }  -- | Mix two patches together. mixInstr :: (SigSpace b, Num b) => Sig -> Patch b -> Patch b -> Patch b@@ -574,7 +574,7 @@ harmonPatch amps freqs = tfmInstr monoTfm polyTfm     where         monoTfm instr = \arg -> fmap sum $ zipWithM (\a f -> fmap (mul a) $ transMonoInstr f instr arg) amps freqs-        polyTfm instr = \arg -> fmap sum $ zipWithM (\a f -> fmap (mul a) $ transPolyInstr f instr arg) amps freqs +        polyTfm instr = \arg -> fmap sum $ zipWithM (\a f -> fmap (mul a) $ transPolyInstr f instr arg) amps freqs  -- | Adds an octave below note for a given patch to make the sound deeper. deepPad :: (SigSpace b, Sigs b) => Patch b -> Patch b@@ -588,10 +588,9 @@     SetSkin  skin p -> SetSkin skin $ rec p     FxChain fxs p -> FxChain fxs $ rec p     SplitPatch a cps b -> SplitPatch (rec a) cps (rec b)-    LayerPatch xs -> LayerPatch $ mapSnd rec xs+    LayerPatch xs -> LayerPatch $ fmap (second rec) xs     where         rec = tfmInstr monoTfm polyTfm-        mapSnd f = fmap (second f)   ------------------------------------------------ -- revers@@ -655,11 +654,11 @@ 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 = go Nothing x    -    where -        go maybeSkin x = case x of -            MonoSynt spec instr -> monoSynt spec (runSkin instr maybeSkin)-            PolySynt spec instr -> polySynt spec (runSkin instr maybeSkin)+genPatchByNameMidi monoKey2cps polyKey2cps name x = go Nothing x+    where+        go maybeSkin = \case+            MonoSynt spec instr -> monoSyntProc spec (runSkin instr maybeSkin)+            PolySynt spec instr -> polySyntProc spec (runSkin instr maybeSkin)             SetSkin skin p      -> newSkin skin p             FxChain fxs p       -> getPatchFx maybeSkin fxs =<< rec p             LayerPatch xs       -> onLayered xs rec@@ -668,19 +667,19 @@                 rec = go maybeSkin                 newSkin skin = go (Just skin) -                monoSynt spec instr = instr =<< (fmap (smoothMonoSpec spec . convert) $ trigNamedMono name)+                monoSyntProc spec instr = instr =<< (fmap (smoothMonoSpec spec . convert) $ trigNamedMono name)                     where-                        convert arg = arg { monoAmp = vel2ampSig (monoAmp arg), monoCps = monoKey2cps (monoCps arg) }                        +                        convert a = a { monoAmp = vel2ampSig (monoAmp a), monoCps = monoKey2cps (monoCps a) } -                polySynt spec instr = trigByNameMidi name go+                polySyntProc _spec instr = trigByNameMidi name proc                     where-                        go :: (D, D, Unit) -> SE a-                        go (pitch, vol, _) = instr (vel2amp vol, polyKey2cps pitch)+                        proc :: (D, D, Unit) -> SE a+                        proc (pitch, vol, _) = instr (vel2amp vol, polyKey2cps pitch)                  splitPatch a cps b = genSplitPatch maybeSkin playMonoInstr playInstr a cps b -                playMonoInstr chn cond instr = monoSynt (def { monoSyntChn = chn }) instr-                playInstr chn instr = polySynt (def { polySyntChn = chn }) instr+                playMonoInstr chn _cond instr = monoSyntProc (def { monoSyntChn = chn }) instr+                playInstr chn instr = polySyntProc (def { polySyntChn = chn }) instr  vel2amp :: D -> D vel2amp vol = ((vol / 64) ** 2) / 2@@ -709,9 +708,9 @@ -- | Wrapper for function @trigByNameMidi@. genPatchByNameMidi :: forall a . (SigSpace a, Sigs a) => (D -> D) -> String -> Patch D a -> SE a genPatchByNameMidi key2cps name p = getPatchFx p =<< trigByNameMidi name go-	where-		go :: (D, D, Unit) -> SE a-		go (pitch, vol, _) = patchInstr p (vel2amp vol, key2cps pitch)+  where+    go :: (D, D, Unit) -> SE a+    go (pitch, vol, _) = patchInstr p (vel2amp vol, key2cps pitch)   -- | Triggers patch with Csound API.@@ -755,8 +754,8 @@ -- | Wrapper for function @trigByNameMidi@ for mono synth. genMonoPatchByNameMidi' :: forall a . (SigSpace a, Sigs a) => (Sig -> Sig) -> D -> D -> String -> Patch Sig a -> SE a genMonoPatchByNameMidi' key2cps portTime relTime name p = getPatchFx p =<< patchInstr p =<< fmap convert (trigNamedMono portTime relTime name)-	where-		convert (vol, pch) = (vel2ampSig vol, key2cps pch)+  where+    convert (vol, pch) = (vel2ampSig vol, key2cps pch)  vel2amp :: D -> D vel2amp vol = ((vol / 64) ** 2) / 2@@ -822,6 +821,8 @@  instance RenderCsd Patch1 where     renderCsdBy opt p = renderCsdBy opt (atMidi p)+    csdArity _ = CsdArity 0 1  instance RenderCsd Patch2 where     renderCsdBy opt p = renderCsdBy opt (atMidi p)+    csdArity _ = CsdArity 0 2

@@ -1,43 +1,42 @@ module Csound.Air.Sampler ( -	-- * Event sampler+  -- * Event sampler -	-- | Note: The release phase of the instrument is skipped-	-- with event sampler functions.-	evtTrig, evtTap, evtGroup, evtCycle,+  -- | Note: The release phase of the instrument is skipped+  -- with event sampler functions.+  evtTrig, evtTap, evtGroup, evtCycle, -	syncEvtTrig, syncEvtTap, syncEvtGroup, syncEvtCycle,+  syncEvtTrig, syncEvtTap, syncEvtGroup, syncEvtCycle, -	-- * Keyboard sampler-	charTrig, charTap, charPush, charToggle, charGroup, charCycle,+  -- * Keyboard sampler+  charTrig, charTap, charPush, charToggle, charGroup, charCycle, -	syncCharTrig, syncCharTap, syncCharPush,syncCharToggle, syncCharGroup, syncCharCycle,+  syncCharTrig, syncCharTap, syncCharPush,syncCharToggle, syncCharGroup, syncCharCycle,+  syncEvtToggle, -    -- * Midi sampler-    midiTrig, midiTap, midiPush, midiToggle, midiGroup,+  -- * Midi sampler+  midiTrig, midiTap, midiPush, midiToggle, midiGroup, -    -- * Generic functions-    midiTrigBy, midiTapBy, midiPushBy, midiToggleBy, midiGroupBy,+  -- * Generic functions+  midiTrigBy, midiTapBy, midiPushBy, midiToggleBy, midiGroupBy, -    -- ** Midi instruments-    MidiTrigFun, midiAmpInstr, midiLpInstr, midiAudioLpInstr, midiConstInstr,+  -- ** Midi instruments+  MidiTrigFun, midiAmpInstr, midiLpInstr, midiAudioLpInstr, midiConstInstr, -    -- * Misc+  -- * Misc -    -- | Keyboard char columns-    keyColumn1, keyColumn2, keyColumn3, keyColumn4, keyColumn5,-    keyColumn6, keyColumn7, keyColumn8, keyColumn9, keyColumn0,-    keyColumns+  -- | Keyboard char columns+  keyColumn1, keyColumn2, keyColumn3, keyColumn4, keyColumn5,+  keyColumn6, keyColumn7, keyColumn8, keyColumn9, keyColumn0,+  keyColumns  ) where -import Data.Monoid import Data.Boolean import Temporal.Class  import Csound.Typed import Csound.Control-import Csound.SigSpace  import Csound.Air.Filter(mlp) import Csound.Air.Wav(takeSnd)@@ -49,14 +48,14 @@ -- | Triggers the signal with the first stream and turns it off with the second stream. evtTrig :: (Sigs a) => Maybe a -> Tick -> Tick -> a -> a evtTrig minitVal x st a = case minitVal of-	Nothing -> ons-	Just v0 -> ons + offs v0 + first v0-	where-		ons     = evtTrigNoInit x st a-		offs  v = evtTrigNoInit st x v-		first v = evtTrigger loadbang x v+  Nothing -> ons+  Just v0 -> ons + offs v0 + first v0+  where+    ons     = evtTrigNoInit x st a+    offs  v = evtTrigNoInit st x v+    first v = evtTrigger loadbang x v -		evtTrigNoInit x st a = runSeg $ loop $ lim st $ del x $ loop (lim x $ toSeg a)+    evtTrigNoInit xEvt stEvt aSig = runSeg $ loop $ lim stEvt $ del xEvt $ loop (lim xEvt $ toSeg aSig)  syncEvtTrig :: (Sigs a) => Sig -> Maybe a -> Tick -> Tick -> a -> a syncEvtTrig bpm minitVal x st a = evtTrig minitVal (syncBpm bpm x) (syncBpm bpm st) a@@ -64,7 +63,7 @@ -- | Toggles the signal with event stream. evtToggle :: (Sigs a) => Maybe a -> Tick -> a -> a evtToggle initVal evt = evtTrig initVal (fmap (const unit) ons) (fmap (const unit) offs)-	where (offs, ons) = splitToggle $ toTog evt+  where (offs, ons) = splitToggle $ toTog evt  syncEvtToggle :: (Sigs a) => Sig -> Maybe a -> Tick -> a -> a syncEvtToggle bpm initVal evt = evtToggle initVal (syncBpm bpm evt)@@ -84,10 +83,10 @@ -- costum monosynthes with this function. The last event stream stops all signals. evtGroup :: (Sigs a) => Maybe a -> [(Tick, a)] -> Tick -> a evtGroup initVal as stop = sum $ fmap (\(a, b, c) -> evtTrig initVal a (mappend b stop) c)-	$ zipWith (\n (a, sam) -> (a, mconcat $ fmap snd $ filter ((/= n) . fst) allEvts, sam)) [(0 :: Int)..] as-	where-		allEvts :: [(Int, Tick)]-		allEvts = zip [0 ..] (fmap fst as)+  $ zipWith (\n (a, sam) -> (a, mconcat $ fmap snd $ filter ((/= n) . fst) allEvts, sam)) [(0 :: Int)..] as+  where+    allEvts :: [(Int, Tick)]+    allEvts = zip [0 ..] (fmap fst as)  syncEvtGroup :: (Sigs a) => Sig -> Maybe a -> [(Tick, a)] -> Tick -> a syncEvtGroup bpm initVal as stop = evtGroup initVal (fmap (\(e, a) -> (syncBpm bpm e, a)) as) (syncBpm bpm stop)@@ -95,13 +94,13 @@ -- | Triggers one signal after another with an event stream. evtCycle :: (Sigs a) => Maybe a -> Tick -> Tick -> [a] -> a evtCycle minitVal start stop sigs = case minitVal of-	Nothing -> ons-	Just _  -> ons + offs-	where-		ons  = evtCycleNoInit start stop sigs-		offs = evtGroup minitVal [(start, 0)] stop+  Nothing -> ons+  Just _  -> ons + offs+  where+    ons  = evtCycleNoInit start stop sigs+    offs = evtGroup minitVal [(start, 0)] stop -		evtCycleNoInit start stop sigs = runSeg $ loop $ lim stop $ del start $ loop $ mel $ fmap (lim start . toSeg) sigs+    evtCycleNoInit startMsg stopMsg asigs = runSeg $ loop $ lim stopMsg $ del startMsg $ loop $ mel $ fmap (lim startMsg . toSeg) asigs  -- | Triggers one signal after another with an event stream. syncEvtCycle :: (Sigs a) => Sig -> Maybe a -> Tick -> Tick -> [a] -> a@@ -114,28 +113,28 @@ -- Stops signal from playing when one of the chars from the second string is pressed. charTrig :: (Sigs a) => Maybe a -> String -> String -> a -> a charTrig minitVal starts stops asig = case minitVal of-	Nothing      -> ons-	Just initVal -> ons + offs initVal + first initVal-	where-		ons   = charTrigNoInit starts stops  asig-		offs  initVal = charTrigNoInit stops  starts initVal-		first initVal = evtTrigger loadbang (strOn starts) initVal+  Nothing      -> ons+  Just initVal -> ons + offs initVal + first initVal+  where+    ons   = charTrigNoInit starts stops  asig+    offs  initVal = charTrigNoInit stops  starts initVal+    first initVal = evtTrigger loadbang (strOn starts) initVal -		charTrigNoInit starts stops asig = runSeg $ loop $ lim (strOn stops) $ toSeg $ retrig (const $ return asig) (strOn starts)+    charTrigNoInit startMsg stopMsg bsig = runSeg $ loop $ lim (strOn stopMsg) $ toSeg $ retrig (const $ return bsig) (strOn startMsg)  -- | Triggers a signal when one of the chars from the first string is pressed. -- Stops signal from playing when one of the chars from the second string is pressed. -- Synchronizes the signal with bpm (first argument). syncCharTrig :: (Sigs a) => Sig -> Maybe a -> String -> String -> a -> a syncCharTrig bpm minitVal starts stops asig = case minitVal of-	Nothing      -> ons-	Just initVal -> ons + offs initVal + first initVal-	where-		ons           = charTrigNoInit starts stops  asig-		offs  initVal = charTrigNoInit stops  starts initVal-		first initVal = syncEvtTrigger bpm loadbang (strOn starts) initVal+  Nothing      -> ons+  Just initVal -> ons + offs initVal + first initVal+  where+    ons           = charTrigNoInit starts stops  asig+    offs  initVal = charTrigNoInit stops  starts initVal+    first initVal = syncEvtTrigger bpm loadbang (strOn starts) initVal -		charTrigNoInit starts stops asig = runSeg $ loop $ lim (syncBpm bpm $ strOn stops) $ toSeg $ retrig (const $ return asig) (syncBpm bpm $ strOn starts)+    charTrigNoInit startMsg stopMsg bsig = runSeg $ loop $ lim (syncBpm bpm $ strOn stopMsg) $ toSeg $ retrig (const $ return bsig) (syncBpm bpm $ strOn startMsg)  -- syncCharTrig :: (Sigs a) => Sig -> String -> String -> a -> a -- syncCharTrig bpm starts stops asig = runSeg $ loop $ lim (syncBpm bpm $ strOn stops) $ toSeg $ retrig (const $ return asig) (syncBpm bpm $ strOn starts)@@ -150,12 +149,12 @@  genCharPush :: Sigs a => (Tick -> Tick -> a -> a) -> Maybe a -> Char -> a -> a genCharPush trig minitVal ch asig = case minitVal of-	Nothing -> ons-	Just v0 -> ons + offs v0 + first v0-	where-		ons     = trig (charOn ch)  (charOff ch) asig-		offs  v = trig (charOff ch) (charOn  ch) v-		first v = trig loadbang (charOn ch) v+  Nothing -> ons+  Just v0 -> ons + offs v0 + first v0+  where+    ons     = trig (charOn ch)  (charOff ch) asig+    offs  v = trig (charOff ch) (charOn  ch) v+    first v = trig loadbang (charOn ch) v  -- | Toggles the signal when key is pressed. charToggle :: (Sigs a) => Maybe a -> Char -> a -> a@@ -168,18 +167,18 @@  -- | Toggles the signal when key is pressed. genCharToggle :: (Sigs a) => (Tick -> Tick) -> Maybe a -> Char -> a -> a-genCharToggle needSync minitVal key asig = retrig (togInstr minitVal asig)-	$ accumE (1 :: D) (\_ s -> (s, mod' (s + 1) 2))-	$ needSync $ charOn key-	where-		togInstr mv0 asig isPlay = do-			ref <- newRef 0-			case mv0 of-				Nothing -> return ()-				Just v0 -> writeRef ref v0-			when1 (sig isPlay ==* 1) $ do-				writeRef ref asig-			readRef ref+genCharToggle needSync minitVal key asig = retrig (togInstr minitVal)+  $ accumE (1 :: D) (\_ s -> (s, mod' (s + 1) 2))+  $ needSync $ charOn key+  where+    togInstr mv0 isPlay = do+      ref <- newRef 0+      case mv0 of+        Nothing -> return ()+        Just v0 -> writeRef ref v0+      when1 (sig isPlay ==* 1) $ do+        writeRef ref asig+      readRef ref  -- Consider note limiting? or performance degrades -- every note is held to infinity and it continues to produce zeroes.@@ -205,22 +204,23 @@  genCharGroup :: (Sigs a) => (Tick -> Tick -> a -> a) -> Maybe a -> [(Char, a)] -> String -> a genCharGroup trig minitVal as stop = case minitVal of-	Nothing      -> charGroupNoInit as stop-	Just initVal -> ons + offs initVal + first initVal-	where-		ons           = charGroupNoInit as stop-		offs  initVal = charGroupNoInit (fmap (\ch -> (ch, initVal)) stop) onKeys-		first initVal = trig loadbang (mconcat $ fmap charOn onKeys) initVal+  Nothing      -> charGroupNoInit trig as stop+  Just initVal -> ons + offs initVal + first initVal+  where+    ons           = charGroupNoInit trig as stop+    offs  initVal = charGroupNoInit trig (fmap (\ch -> (ch, initVal)) stop) onKeys+    first initVal = trig loadbang (mconcat $ fmap charOn onKeys) initVal -		onKeys = fmap fst as+    onKeys = fmap fst as -		charGroupNoInit as stop = sum $ fmap f as-			where-				allKeys = fmap fst as ++ stop-				f (key, asig) = trig ons offs asig-					where-						ons  = charOn key-						offs = strOn allKeys+charGroupNoInit :: Sigs a => (Tick -> Tick -> a -> a) -> [(Char, a)] -> String -> a+charGroupNoInit trig as stop = sum $ fmap f as+  where+    allKeys = fmap fst as ++ stop+    f (key, asig) = trig ons offs asig+      where+        ons  = charOn key+        offs = strOn allKeys  -- | Plays signals one after another when key is pressed. -- Stops the group from playing when the char from the last@@ -263,7 +263,7 @@  -- | Ignores the amplitude and justplays back the original signal. midiConstInstr :: (SigSpace a, Sigs a) => a -> D -> SE a-midiConstInstr asig amp = return asig+midiConstInstr asig _amp = return asig  -- | Plays a signal when the key is pressed. Retriggers the signal when the key is pressed again. -- The key is an integer midi code. The C1 is 60 and the A1 is 69.@@ -311,37 +311,37 @@ -- It produces some output. The default is scaling the signal with the amplitude. midiPushBy :: (SigSpace a, Sigs a) => MidiTrigFun a -> MidiChn -> Int -> a -> SE a midiPushBy midiInstr midiChn key asig = do-	ons  <- midiKeyOn midiChn (int key)-	offs <- midiKeyOff midiChn (int key)-	return $ midiEvtTriggerBy midiInstr ons offs asig+  ons  <- midiKeyOn midiChn (int key)+  offs <- midiKeyOff midiChn (int key)+  return $ midiEvtTriggerBy midiInstr ons offs asig  -- | The generic midiToggle. We can specify the midi function. -- The midi function takes in a signal and a volume of the pressed key (it ranges from 0 to 1). -- It produces some output. The default is scaling the signal with the amplitude. midiToggleBy :: (SigSpace a, Sigs a) => MidiTrigFun a -> MidiChn -> Int -> a -> SE a-midiToggleBy midiInstr midiChn key asig = fmap (\evt -> retrig (togMidiInstr asig) evt)-	(fmap (accumE (1 :: D) (\a s -> ((a, s), mod' (s + 1) 2))) $ midiKeyOn midiChn $ int key)-	where-		togMidiInstr asig (amp, isPlay) = do-			ref <- newRef 0-			when1 (sig isPlay ==* 1) $ do-				writeRef ref =<< midiInstr asig amp-			readRef ref+midiToggleBy midiInstr midiChn key asig = fmap (\evt -> retrig togMidiInstr evt)+  (fmap (accumE (1 :: D) (\a s -> ((a, s), mod' (s + 1) 2))) $ midiKeyOn midiChn $ int key)+  where+    togMidiInstr (amp, isPlay) = do+      ref <- newRef 0+      when1 (sig isPlay ==* 1) $ do+        writeRef ref =<< midiInstr asig amp+      readRef ref  -- | The generic midiGroup. We can specify the midi function. -- The midi function takes in a signal and a volume of the pressed key (it ranges from 0 to 1). -- It produces some output. The default is scaling the signal with the amplitude. midiGroupBy :: (SigSpace a, Sigs a) => MidiTrigFun a -> MidiChn -> [(Int, a)] -> SE a midiGroupBy midiInstr midiChn as = fmap sum $ mapM f as-	where-		allKeys = fmap fst as-		f (key, asig) = do-			ons  <- midiKeyOn midiChn (int key)-			offs <- fmap (fmap (const unit) . mconcat) $ mapM (midiKeyOn midiChn . int) allKeys-			return $ midiEvtTriggerBy midiInstr ons offs asig+  where+    allKeys = fmap fst as+    f (key, asig) = do+      ons  <- midiKeyOn midiChn (int key)+      offs <- fmap (fmap (const unit) . mconcat) $ mapM (midiKeyOn midiChn . int) allKeys+      return $ midiEvtTriggerBy midiInstr ons offs asig  midiEvtTriggerBy :: (SigSpace a, Sigs a) => (a -> D -> SE a) -> Evt D -> Tick -> a -> a-midiEvtTriggerBy midiInstr ons offs asig = schedUntil (midiAmpInstr asig) ons offs+midiEvtTriggerBy midiInstr ons offs asig = schedUntil (midiInstr asig) ons offs  ----------------------------------------------------------- -- misc

@@ -1,17 +1,16 @@ {-# Language TypeFamilies #-}+{-# Language LambdaCase #-} module Csound.Air.Seg (-	Seg, toSeg, runSeg,-	constLim, constDel, constRest, limSnd+  Seg, toSeg, runSeg,+  constLim, constDel, constRest, limSnd ) where  import Data.Maybe-import Data.Monoid import Data.Boolean  import Temporal.Class  import Csound.Typed-import Csound.SigSpace import Csound.Control  import Csound.Air.Wav hiding (Loop)@@ -27,46 +26,46 @@ -- or play a sequence of segments. The main feature of the segments is the -- ability to schedule the signals with event streams (like button clicks or midi-events). data Seg a-	= Unlim a-	| Lim Tick (Seg a)-	| ConstLim Sig (Seg a)-	| Seq [Seg a]-	| Par [Seg a]-	| Loop (Seg a)+  = Unlim a+  | Lim Tick (Seg a)+  | ConstLim Sig (Seg a)+  | Seq [Seg a]+  | Par [Seg a]+  | Loop (Seg a)  instance Functor Seg where-	fmap f x = case x of-		Unlim a -> Unlim $ f a-		Lim dt a -> Lim dt $ fmap f a-		ConstLim dt a -> ConstLim dt $ fmap f a-		Seq as  -> Seq $ fmap (fmap f) as-		Par as  -> Par $ fmap (fmap f) as-		Loop a  -> Loop $ fmap f a+  fmap f x = case x of+    Unlim a -> Unlim $ f a+    Lim dt a -> Lim dt $ fmap f a+    ConstLim dt a -> ConstLim dt $ fmap f a+    Seq as  -> Seq $ fmap (fmap f) as+    Par as  -> Par $ fmap (fmap f) as+    Loop a  -> Loop $ fmap f a  instance SigSpace a => SigSpace (Seg a) where-	mapSig f x = fmap (mapSig f) x+  mapSig f x = fmap (mapSig f) x  type instance DurOf (Seg a) = Tick  instance Sigs a => Melody (Seg a) where-	mel = sflow+  mel = sflow  instance Sigs a => Harmony (Seg a) where-	har = spar+  har = spar  instance Sigs a => Compose (Seg a) where  instance Sigs a => Delay (Seg a) where-	del = sdel+  del = sdel  instance Sigs a => Loop (Seg a) where-	loop = sloop+  loop = sloop  instance (Sigs a, Num a) => Rest (Seg a) where-	rest = srest+  rest = srest  instance Sigs a => Limit (Seg a) where-	lim = slim+  lim = slim  seq1 :: Tick -> a -> Seg a seq1 dt a = Lim dt (Unlim a)@@ -79,39 +78,39 @@ -- | Limits the length of the segment with event stream. slim :: Tick -> Seg a -> Seg a slim da x = case x of-	Par as   -> Par (fmap (slim da) as)-	_        -> Lim da x+  Par as   -> Par (fmap (slim da) as)+  _        -> Lim da x  -- | Limits the length of the segment with constant length in seconds. constLim :: Sig -> Seg a -> Seg a constLim da x = case x of-	Par as   -> Par (fmap (constLim da) as)-	_        -> ConstLim da x+  Par as   -> Par (fmap (constLim da) as)+  _        -> ConstLim da x  -- | Plays the sequence of segments one ofter another. sflow :: [Seg a] -> Seg a sflow as = Seq $ flatten =<< as-	where-		flatten x = case x of-			Seq as -> as-			_      -> [x]+  where+    flatten x = case x of+      Seq xs -> xs+      _      -> [x]  -- | Plays a list of segments at the same time. -- the total length equals to the biggest length of all segments. spar :: [Seg a] -> Seg a spar as = Par $ flatten =<< as-	where-		flatten x = case x of-			Par as -> as-			_      -> [x]+  where+    flatten x = case x of+      Par xs -> xs+      _      -> [x]  -- | Loops over a segment. The segment should be limited for loop to take effect. sloop :: Seg a -> Seg a sloop x = case x of-	Unlim a -> Unlim a-	Loop a  -> Loop a-	Par as  -> Par (fmap sloop as)-	_       -> Loop x+  Unlim a -> Unlim a+  Loop a  -> Loop a+  Par as  -> Par (fmap sloop as)+  _       -> Loop x   -- | Limits a signal with an event stream and retriggers it after stop.@@ -123,72 +122,75 @@ -- | Converts segments to signals. runSeg :: (Sigs a) => Seg a -> a runSeg x = case x of-	Unlim a -> a+  Unlim a -> a -	Lim dt (Unlim a) -> elim dt a-	Lim dt (Seq as)  -> uncurry (evtLoopOnce (Just dt)) (getEvtAndSig $ rmTailAfterUnlim as)-	Lim dt (Loop (Seq as)) -> uncurry (evtLoop (Just dt)) (getEvtAndSig $ rmTailAfterUnlim as)-	Lim dt (Loop a) -> elim dt (runSeg (Loop a))-	Lim dt a -> elim dt (runSeg a)+  Lim dt (Unlim a) -> elim dt a+  Lim dt (Seq as)  -> uncurry (evtLoopOnce (Just dt)) (getEvtAndSig $ rmTailAfterUnlim as)+  Lim dt (Loop (Seq as)) -> uncurry (evtLoop (Just dt)) (getEvtAndSig $ rmTailAfterUnlim as)+  Lim dt (Loop a) -> elim dt (runSeg (Loop a))+  Lim dt a -> elim dt (runSeg a)  -	ConstLim dt (Unlim a) -> takeSnd dt a-	ConstLim dt (Seq as)  -> uncurry (evtLoopOnce (Just $ impulseE $ ir dt)) (getEvtAndSig $ rmTailAfterUnlim as)-	ConstLim dt (Loop (Seq as)) -> uncurry (evtLoop (Just $ impulseE $ ir dt)) (getEvtAndSig $ rmTailAfterUnlim as)-	ConstLim dt (Loop a) -> takeSnd dt (runSeg (Loop a))-	ConstLim dt a -> takeSnd dt (runSeg a)+  ConstLim dt (Unlim a) -> takeSnd dt a+  ConstLim dt (Seq as)  -> uncurry (evtLoopOnce (Just $ impulseE $ ir dt)) (getEvtAndSig $ rmTailAfterUnlim as)+  ConstLim dt (Loop (Seq as)) -> uncurry (evtLoop (Just $ impulseE $ ir dt)) (getEvtAndSig $ rmTailAfterUnlim as)+  ConstLim dt (Loop a) -> takeSnd dt (runSeg (Loop a))+  ConstLim dt a -> takeSnd dt (runSeg a) -	Seq as -> uncurry (evtLoopOnce Nothing) (getEvtAndSig $ rmTailAfterUnlim as)+  Seq as -> uncurry (evtLoopOnce Nothing) (getEvtAndSig $ rmTailAfterUnlim as) -	Loop (ConstLim dt a) -> repeatSnd dt $ runSeg a-	Loop (Lim dt a)      -> evtLoop Nothing [return $ runSeg a] [dt]-	Loop (Seq as)            -> uncurry (evtLoop Nothing) (getEvtAndSig as)+  Loop (ConstLim dt a) -> repeatSnd dt $ runSeg a+  Loop (Lim dt a)      -> evtLoop Nothing [return $ runSeg a] [dt]+  Loop (Seq as)            -> uncurry (evtLoop Nothing) (getEvtAndSig as) -	Par as -> maybeElim (getDur x) $ sum $ fmap (\a -> maybeElim (getDur a) $ runSeg a) as+  Par as -> maybeElim (getDur x) $ sum $ fmap (\a -> maybeElim (getDur a) $ runSeg a) as+  Loop (Unlim _) -> undefined+  Loop (Par _) -> undefined+  Loop  (Loop _) -> undefined  getDur :: Seg a -> Maybe (Either Sig Tick) getDur x = case x of-	Unlim _ -> Nothing-	Loop  _ -> Nothing-	Lim dt _ -> Just $ Right dt-	ConstLim dt _ -> Just $ Left dt-	Seq as -> fromListT sum aftT' as-	Par as -> fromListT (foldl1 maxB) simT' as-	where-		fromListT g f as-			| all isJust ds = Just $ phi g f $ fmap fromJust ds-			| otherwise     = Nothing-			where ds = fmap getDur as+  Unlim _ -> Nothing+  Loop  _ -> Nothing+  Lim dt _ -> Just $ Right dt+  ConstLim dt _ -> Just $ Left dt+  Seq as -> fromListT sum aftT' as+  Par as -> fromListT (foldl1 maxB) simT' as+  where+    fromListT g f as+      | all isJust ds = Just $ phi g f $ fmap fromJust ds+      | otherwise     = Nothing+      where ds = fmap getDur as -		phi g f xs-			| all isJust as = Left  $ g $ fmap fromJust as-			| otherwise     = Right $ f $ fmap toEvt xs-			where as = fmap getConstT xs+    phi g f xs+      | all isJust as = Left  $ g $ fmap fromJust as+      | otherwise     = Right $ f $ fmap toEvt xs+      where as = fmap getConstT xs -		getConstT x = case x of-			Left d -> Just d-			_      -> Nothing+    getConstT = \case+      Left d -> Just d+      _      -> Nothing -		toEvt = either (impulseE . ir) id+    toEvt = either (impulseE . ir) id  getEvtAndSig :: (Num a, Sigs a) => [Seg a] -> ([SE a], [Tick]) getEvtAndSig as = unzip $ fmap (\x -> (return (runSeg x), getTick $ getDur x)) as-	where getTick = maybe mempty (either (impulseE . ir) id)+  where getTick = maybe mempty (either (impulseE . ir) id)   rmTailAfterUnlim :: [Seg a] -> [Seg a] rmTailAfterUnlim = takeByIncludeLast isUnlim-	where-		isUnlim x = case x of-			Unlim _ -> True-			Loop  _ -> True-			Par  as -> any isUnlim as-			_       -> False+  where+    isUnlim x = case x of+      Unlim _ -> True+      Loop  _ -> True+      Par  as -> any isUnlim as+      _       -> False  takeByIncludeLast :: (a -> Bool) -> [a] -> [a] takeByIncludeLast f xs = case xs of-	[] -> []-	a:as -> if f a then [a] else a : takeByIncludeLast f as+  [] -> []+  a:as -> if f a then [a] else a : takeByIncludeLast f as  ------------------------------------------------- -- aux@@ -216,10 +218,10 @@  maybeElim :: (Num a, Sigs a) => Maybe (Either Sig Tick) -> a -> a maybeElim mdt a = case mdt of-	Nothing -> a-	Just x  -> case x of-		Left d  -> takeSnd d a-		Right t -> elim t a+  Nothing -> a+  Just x  -> case x of+    Left d  -> takeSnd d a+    Right t -> elim t a  -- | Takes the first event from the event stream and ignores the rest of the stream. take1 :: Evt a -> Evt a@@ -230,28 +232,28 @@  aftT' :: [Tick] -> Tick aftT' evts = take1 $ sigToEvt $ evtLoop Nothing asigs evts-	where-		asigs :: [SE Sig]-		asigs = fmap (return . sig) $ (replicate (length evts - 1) 0) ++ [1]+  where+    asigs :: [SE Sig]+    asigs = fmap (return . sig) $ (replicate (length evts - 1) 0) ++ [1]  simT' :: [Tick] -> Tick simT' as = Evt $ \bam -> do-	isAwaitingRef <- newRef (1 :: D)-	countDownRef  <- newRef (int (length as) :: D)+  isAwaitingRef <- newRef (1 :: D)+  countDownRef  <- newRef (int (length as) :: D) -	mapM_ (mkEvt countDownRef) as+  mapM_ (mkEvt countDownRef) as -	countDown <- readRef countDownRef-	isAwaiting <- readRef isAwaitingRef-	when1 (sig isAwaiting ==* 1 &&* sig countDown ==* 0) $ do-		bam unit-		writeRef isAwaitingRef 0-	where-		mkEvt ref e = do-			notFiredRef <- newRef (1 :: D)-			notFired <- readRef notFiredRef-			runEvt e $ \_ -> do-				when1 (sig notFired ==* 1) $ do-					writeRef notFiredRef 0-					modifyRef ref (\x -> x - 1)+  countDown <- readRef countDownRef+  isAwaiting <- readRef isAwaitingRef+  when1 (sig isAwaiting ==* 1 &&* sig countDown ==* 0) $ do+    bam unit+    writeRef isAwaitingRef 0+  where+    mkEvt ref e = do+      notFiredRef <- newRef (1 :: D)+      notFired <- readRef notFiredRef+      runEvt e $ \_ -> do+        when1 (sig notFired ==* 1) $ do+          writeRef notFiredRef 0+          modifyRef ref (\x -> x - 1) 

@@ -1,5 +1,5 @@  -- | Spectral functions- module Csound.Air.Spec( 	+ module Csound.Air.Spec(     toSpec, fromSpec, mapSpec, scaleSpec, addSpec, scalePitch,     CrossSpec(..),     crossSpecFilter, crossSpecVocoder, crossSpecFilter1, crossSpecVocoder1@@ -26,8 +26,8 @@ mapSpec :: (Spec -> Spec) -> Sig -> Sig mapSpec f = fromSpec . f . toSpec --- | Scales all frequencies. Usefull for transposition. --- For example, we can transpose a signal by the given amount of semitones: +-- | Scales all frequencies. Usefull for transposition.+-- For example, we can transpose a signal by the given amount of semitones: -- -- > scaleSpec (semitone 1) asig scaleSpec :: Sig -> Sig -> Sig@@ -58,7 +58,7 @@ -- -- * scale --amplitude scaling factor. default is 1 ----- * pitch -- the pitch scaling factor. default is 1 +-- * pitch -- the pitch scaling factor. default is 1 -- -- * @maxTracks@ -- max number of tracks in resynthesis (tradsyn) and analysis (partials). --@@ -73,34 +73,34 @@ -- * @MinPoints@ -- minimum number of time points for a detected peak to make a track (1 is the minimum). -- -- * @MaxGap@ -- maximum gap between time-points for track continuation (> 0). Tracks that have no continuation after kmaxgap will be discarded.-data CrossSpec = CrossSpec -	{ crossFft 		:: D-	, crossHopSize 	:: D-	, crossScale    :: Sig-	, crossPitch    :: Sig-	, crossMaxTracks :: D-	, crossWinType  :: D-	, crossSearch   :: Sig-	, crossDepth    :: Sig-	, crossThresh   :: Sig-	, crossMinPoints :: Sig-	, crossMaxGap    :: Sig-	}+data CrossSpec = CrossSpec+  { crossFft    :: D+  , crossHopSize  :: D+  , crossScale    :: Sig+  , crossPitch    :: Sig+  , crossMaxTracks :: D+  , crossWinType  :: D+  , crossSearch   :: Sig+  , crossDepth    :: Sig+  , crossThresh   :: Sig+  , crossMinPoints :: Sig+  , crossMaxGap    :: Sig+  }  instance Default CrossSpec where-	def = CrossSpec -		{ crossFft 		= 12-		, crossHopSize 	= 9-		, crossScale    = 1-		, crossPitch    = 1-		, crossMaxTracks = 500-		, crossWinType  = 1-		, crossSearch   = 1.05-		, crossDepth    = 1-		, crossThresh   = 0.01-		, crossMinPoints = 1-		, crossMaxGap    = 3-		}+  def = CrossSpec+    { crossFft    = 12+    , crossHopSize  = 9+    , crossScale    = 1+    , crossPitch    = 1+    , crossMaxTracks = 500+    , crossWinType  = 1+    , crossSearch   = 1.05+    , crossDepth    = 1+    , crossThresh   = 0.01+    , crossMinPoints = 1+    , crossMaxGap    = 3+    }   -- | Filters the partials of the second signal with partials of the first signal.@@ -120,8 +120,8 @@ crossSpecVocoder1 = crossSpecBy 1  crossSpecBy :: D -> CrossSpec -> Sig -> Sig -> Sig-crossSpecBy imode spec ain1 ain2 = -	tradsyn (trcross (getPartials ain2) (getPartials ain1) (crossSearch spec) (crossDepth spec) `withD` imode) (crossScale spec) (crossPitch spec) (sig $ crossMaxTracks spec) sine-	where-		getPartials asig = partials fs1 fsi2 (crossThresh spec) (crossMinPoints spec) (crossMaxGap spec) (crossMaxTracks spec)-			where (fs1, fsi2) = pvsifd asig (2 ** (crossFft spec)) (2 ** (crossHopSize spec)) (crossWinType spec) +crossSpecBy imode spec ain1 ain2 =+  tradsyn (trcross (getPartials ain2) (getPartials ain1) (crossSearch spec) (crossDepth spec) `withD` imode) (crossScale spec) (crossPitch spec) (sig $ crossMaxTracks spec) sine+  where+    getPartials asig = partials fs1 fsi2 (crossThresh spec) (crossMinPoints spec) (crossMaxGap spec) (crossMaxTracks spec)+      where (fs1, fsi2) = pvsifd asig (2 ** (crossFft spec)) (2 ** (crossHopSize spec)) (crossWinType spec)

@@ -46,20 +46,17 @@ import Data.List(isSuffixOf) import Data.Default import Data.Boolean-import Control.Applicative hiding((<*))  import Temporal.Media -import Control.Monad.Trans.Class import Csound.Dynamic hiding (int, Sco)  import Csound.Typed-import Csound.Typed.Opcode+import Csound.Typed.Opcode hiding (tempo, pitch, metro, tab) import Csound.Tab(mp3s, mp3Left, wavs, wavLeft, WavChn(..), Mp3Chn(..))-import Csound.Control.Instr(withDur, sched)+import Csound.Control.Instr(withDur) -import Csound.SigSpace(mapSig)-import Csound.Control.Evt(metroE, loadbang)+import Csound.Control.Evt(metro, loadbang)  import Csound.Air.Spec @@ -77,7 +74,7 @@ -- | Delays a signal by the first argument and takes only second argument amount -- of signal (everything is measured in seconds). segmentSnd ::Sigs a => Sig -> Sig -> a -> a-segmentSnd dt dur asig = sched (const $ return asig) $ fmap (del dt) $ withDur dur $ loadbang+segmentSnd dt durS asig = sched (const $ return asig) $ fmap (del dt) $ withDur durS $ loadbang  -- | Repeats the signal with the given period. repeatSnd :: Sigs a => Sig -> a -> a@@ -119,7 +116,7 @@  -- | Produces repeating segments with the given time in seconds. segments :: Sig -> Evt (Sco Unit)-segments dt = withDur dt $ metroE (recip dt)+segments dt = withDur dt $ metro (recip dt)  -- Stereo @@ -307,7 +304,7 @@ -- -- * playback speed lphase :: D -> Sig -> Sig -> Sig -> Sig-lphase irefdur kloopstart kloopend kspeed  = atimpt+lphase irefdur kloopstart kloopend kspeed  = atimpt * sig irefdur     where         kfqrel = kspeed / (kloopend - kloopstart)         andxrel = phasor kfqrel@@ -522,4 +519,5 @@ scaleWav winSizePowerOfTwo tempo pitch filename = (go $ mkTab False 0 filename, go $ mkTab False 1 filename)     where go = simpleTempoScale winSizePowerOfTwo tempo pitch +simpleTempoScale :: D -> Sig -> Sig -> Tab -> Sig simpleTempoScale winSizePowerOfTwo tempo pitch t = temposcal tempo 1 pitch t 1 `withD` (2 ** (winSizePowerOfTwo + 11))

@@ -3,7 +3,7 @@ module Csound.Air.Wave (     Wave, -	 -- * Bipolar+   -- * Bipolar     osc, oscBy, saw, isaw, pulse, sqr, pw, tri, ramp, blosc,      -- ** With phase control@@ -54,8 +54,7 @@  import Csound.Typed import Csound.Typed.Opcode hiding (lfo)-import Csound.Tab(setSize, elins, sine, cosine, sines4, triTab, pwTab, sawTab, sqrTab)-import Csound.SigSpace+import Csound.Tab(sine, cosine, triTab, pwTab, sawTab, sqrTab)  type Wave = Sig -> SE Sig @@ -139,7 +138,7 @@ -- -- > fosc carrierFreq modulatorFreq modIndex cps fosc :: Sig -> Sig -> Sig -> Sig -> Sig-fosc car mod ndx cps = foscili 1 cps car mod ndx sine+fosc car modFreq ndx cps = foscili 1 cps car modFreq ndx sine  -- | Pulse width modulation (width range is 0 to 1) --@@ -179,6 +178,10 @@ unipolar' :: (D -> Sig -> Sig) -> (D -> Sig -> Sig) unipolar' f phs cps = unipolar $ f phs cps +uosc', utri', usqr', usaw', upulse', uisaw' :: D -> Sig -> Sig+uoscBy', ublosc' :: Tab -> D -> Sig -> Sig+uramp', upw' :: Sig -> D -> Sig -> Sig+ uosc' = unipolar' osc' uoscBy' a = unipolar' (oscBy' a) usaw' = unipolar' saw'@@ -197,6 +200,10 @@ rndPhs :: (D -> Sig -> Sig) -> (Sig -> SE Sig) rndPhs f cps = fmap (\x -> f x cps) $ rnd 1 +rndOsc, rndTri, rndSqr, rndSaw, rndIsaw, rndPulse :: Sig -> SE Sig+rndOscBy, rndBlosc :: Tab -> Sig -> SE Sig+rndRamp, rndPw :: Sig -> Sig -> SE Sig+ rndOsc = rndPhs osc' rndOscBy a = rndPhs (oscBy' a) rndSaw = rndPhs saw'@@ -211,6 +218,10 @@ -------------------------------------------------------------------------- -- unipolar random phase +urndOsc, urndTri, urndSqr, urndSaw, urndIsaw, urndPulse :: Sig -> SE Sig+urndOscBy, urndBlosc :: Tab -> Sig -> SE Sig+urndRamp, urndPw :: Sig -> Sig -> SE Sig+ urndOsc = rndPhs uosc' urndOscBy a = rndPhs (uoscBy' a) urndSaw = rndPhs usaw'@@ -281,6 +292,7 @@  -------------------------------------------------------------------------- +linRange :: Integral a => a -> Sig -> [Sig] linRange n amount = fmap (\x -> amount * sig (2 * double x - 1)) [0, (1 / fromIntegral n) .. 1]  -- | Unision by Hertz. It creates n oscillators that are playing

@@ -1,6 +1,6 @@ -- | Oscillators with hard and soft sync module Csound.Air.Wave.Sync(-	-- * Hard sync+  -- * Hard sync     SyncSmooth(..),      sawSync, isawSync, pulseSync, sqrSync, triSync, bloscSync,@@ -27,7 +27,7 @@     rawTriSyncBy, rawSqrSyncBy, rawSawSyncBy, rawPwSyncBy,      -- *** With absolute slave frequency-	rawTriSyncAbs, 	rawSqrSyncAbs, rawSawSyncAbs, rawPwSyncAbs,+  rawTriSyncAbs,  rawSqrSyncAbs, rawSawSyncAbs, rawPwSyncAbs,     rawTriSyncAbsBy, rawSqrSyncAbsBy, rawSawSyncAbsBy, rawPwSyncAbsBy,     -- * Soft sync@@ -42,9 +42,8 @@ import Data.Default  import Csound.Typed-import Csound.Typed.Opcode hiding (lfo)+import Csound.Typed.Opcode hiding (lfo, tab) import Csound.Tab-import Csound.SigSpace  import Csound.Air.Wave @@ -161,22 +160,25 @@ -- | 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)+    RawSync         -> (\_ _ -> 1)+    SawSync         -> (\amaster _ -> (1 - amaster))+    TriSync         -> (const $ readSync uniTriTab)+    TrapSync        -> (const $ readSync uniTrapTab)+    UserSync genTab -> (const $ readSync genTab)     where         readSync ft async = table3 async ft `withD` 1 +uniSawTab, uniTriTab, uniTrapTab :: Tab+ uniSawTab  = setSize 4097 $ elins [1, 0] uniTriTab  = setSize 4097 $ elins [0, 1, 0] uniTrapTab = setSize 4097 $ elins [1, 1, 0] +syncOsc :: (Sig -> Sig -> Sig) -> Tab -> Sig -> Sig -> Sig syncOsc smoothFun ftab slaveCps cps = dcblock $ aout     where         (amaster, asyncMaster) = syncphasor cps 0-        (aslave,  asyncSlave)  = syncphasor slaveCps asyncMaster+        (aslave,  _asyncSlave)  = syncphasor slaveCps asyncMaster         aosc = table3 aslave ftab `withD` 1         aout = aosc * smoothFun amaster asyncMaster 

@@ -23,7 +23,6 @@     every, masked ) where -import Data.Monoid import Data.Default import Data.Boolean import Data.Tuple@@ -73,16 +72,16 @@ -- > gaussTrig freq deviation gaussTrig :: Sig -> Sig -> Tick gaussTrig afreq adev = Evt $ \bam -> do-    on <- gausstrig 1 (afreq * sig getBlockSize) adev-    when1 (on >* 0.5) $ bam unit+    thresh <- gausstrig 1 (afreq * sig getBlockSize) adev+    when1 (thresh >* 0.5) $ bam unit  -- | Creates a stream of random events. The argument is a number of events per second. -- -- > dust eventsPerSecond dust :: Sig -> Tick dust freq = Evt $ \bam -> do-    on <- O.dust 1 (freq * sig getBlockSize)-    when1 (on >* 0.5) $ bam unit+    thresh <- O.dust 1 (freq * sig getBlockSize)+    when1 (thresh >* 0.5) $ bam unit  -- | Creates a signal that contains a random ones that happen with given frequency. dustSig :: Sig -> SE Sig@@ -108,8 +107,8 @@  -- | Makes an event stream from list of events. eventList :: [(Sig, Sig, a)] -> Evt (Sco a)-eventList es = fmap (const $ har $ fmap singleEvent es) loadbang-    where singleEvent (start, duration, content) = del start $ str duration $ temp content+eventList es = fmap (const $ har $ fmap single es) loadbang+    where single (start, duration, content) = del start $ str duration $ temp content  -- | Behaves like 'Csound.Opcode.Basic.changed', but returns an event stream. changedE :: [Sig] ->  Evt Unit@@ -137,8 +136,8 @@ -- | Constructs an event stream that contains pairs from the -- given pair of signals. Events happens when any signal changes. snaps2 :: Sig2 -> Evt (D, D)-snaps2 (x, y) = snapshot const (x, y) trigger-    where trigger = sigToEvt $ changed [x, y]+snaps2 (x, y) = snapshot const (x, y) triggerSig+    where triggerSig = sigToEvt $ changed [x, y]  ---------------------------------------------------------------------- -- higher level evt-funs@@ -155,9 +154,9 @@ listAt :: (Tuple a, Arg a) => [a] -> Evt D -> Evt a listAt vals evt     | null vals = mempty-    | otherwise = fmap (atArg vals) $ filterE within evt+    | otherwise = fmap (atArg vals) $ filterE withinBounds evt     where-        within x = (x >=* 0) &&* (x `lessThan` len)+        withinBounds x = (x >=* 0) &&* (x `lessThan` len)         len = int $ length vals  -- |@@ -247,8 +246,8 @@         vals = fmap snd rnds  takeByWeight :: (Tuple a, Arg a) => [Sig] -> [a] -> D -> a-takeByWeight accumWeights vals at =-    guardedArg (zipWith (\w val -> (at `lessThan` ir w, val)) accumWeights vals) (last vals)+takeByWeight accumWeights vals atD =+    guardedArg (zipWith (\w val -> (atD `lessThan` ir w, val)) accumWeights vals) (last vals)  accumWeightList :: Num a => [a] -> [a] accumWeightList = go 0@@ -261,7 +260,7 @@ -- with stateful function that produce not just values but the list of values -- with frequencies of occurrence. We apply this function to the current state -- and the value and then at random pick one of the values.-freqAccum :: (Tuple s, Tuple (b, s), Arg (b, s))+freqAccum :: (Arg b, Arg s)     => s -> (a -> s -> Rnds (b, s)) -> Evt a -> Evt b freqAccum s0 f = accumSE s0 $ \a s ->     let rnds = f a s

@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-orphans #-} {-# Language     TypeSynonymInstances,     FlexibleInstances,@@ -55,7 +56,7 @@     -- * Gui     Gui,     Widget, Input, Output, Inner,-    Sink(..), Source(..), Display(..), SinkSource(..),+    Sink, Source, Display, SinkSource,     widget, sink, source, display, sinkSource, sinkSlice, sourceSlice,     mapSource, mapGuiSource,     mhor, mver, msca,@@ -90,12 +91,11 @@  import Csound.Typed -import Csound.Typed.Gui+import Csound.Typed.Gui hiding (props)  import Csound.Control.Gui.Layout-import Csound.Control.Gui.Props+import Csound.Control.Gui.Props hiding (props) import Csound.Control.Gui.Widget-import Csound.SigSpace  instance SigSpace a => SigSpace (Source a) where     mapSig f = mapSource (mapSig f)@@ -191,8 +191,12 @@     (gb, b) <- mb     return $ (gf ga gb, f a b) +lift2' :: Double -> Double+  -> (Gui -> Gui -> Gui)+  -> (a -> b -> c)+  -> Source a -> Source b -> Source c lift2' a b gf = lift2 (tfm2 a b gf)-    where tfm2 sa sb gf = \a b -> gf (sca sa a) (sca sb b)+    where tfm2 sa sb gf' = \a' b' -> gf' (sca sa a') (sca sb b')  -- | Combines two sound sources. Visuals are aligned horizontally -- and the sound sources a grouped with the given function.@@ -219,8 +223,12 @@     (gc, c) <- mc     return $ (gf ga gb gc, f a b c) +lift3' :: Double -> Double -> Double+  -> (Gui -> Gui -> Gui -> Gui)+  -> (a -> b -> c -> d)+  -> Source a -> Source b -> Source c -> Source d lift3' sa sb sc gf = lift3 (tfm3 sa sb sc gf)-    where tfm3 sa sb sc gf = \a b c -> gf (sca sa a) (sca sb b) (sca sc c)+    where tfm3 sa' sb' sc' gf' = \a b c -> gf' (sca sa' a) (sca sb' b) (sca sc' c)  -- | The same as @hlift2@ but for three sound sources. hlift3 :: (a -> b -> c -> d) -> Source a -> Source b -> Source c -> Source d@@ -232,11 +240,11 @@  -- | The same as @hlift2'@ but for three sound sources. hlift3' :: Double -> Double -> Double -> (a -> b -> c -> d) -> Source a -> Source b -> Source c -> Source d-hlift3' a b c = lift3' a b c (\a b c -> hor [a, b, c])+hlift3' a b c = lift3' a b c (\a' b' c' -> hor [a', b', c'])  -- | The same as @vlift2'@ but for three sound sources. vlift3' :: Double -> Double -> Double -> (a -> b -> c -> d) -> Source a -> Source b -> Source c -> Source d-vlift3' a b c = lift3' a b c (\a b c -> ver [a, b, c])+vlift3' a b c = lift3' a b c (\a' b' c' -> ver [a', b', c'])  lift4 :: (Gui -> Gui -> Gui -> Gui -> Gui) -> (a -> b -> c -> d -> e) -> Source a -> Source b -> Source c -> Source d -> Source e lift4 gf f ma mb mc md = source $ do@@ -246,8 +254,12 @@     (gd, d) <- md     return $ (gf ga gb gc gd, f a b c d) +lift4' :: Double -> Double -> Double -> Double+  -> (Gui -> Gui -> Gui -> Gui -> Gui)+  -> (a -> b -> c -> d -> e)+  -> Source a -> Source b -> Source c -> Source d -> Source e lift4' sa sb sc sd gf = lift4 (tfm3 sa sb sc sd gf)-    where tfm3 sa sb sc sd gf = \a b c d -> gf (sca sa a) (sca sb b) (sca sc c) (sca sd d)+    where tfm3 sa' sb' sc' sd' gf' = \a b c d -> gf' (sca sa' a) (sca sb' b) (sca sc' c) (sca sd' d)  -- | The same as @hlift2@ but for four sound sources. hlift4 :: (a -> b -> c -> d -> e) -> Source a -> Source b -> Source c -> Source d -> Source e@@ -259,12 +271,11 @@  -- | The same as @hlift2'@ but for four sound sources. hlift4' :: Double -> Double -> Double -> Double -> (a -> b -> c -> d -> e) -> Source a -> Source b -> Source c -> Source d -> Source e-hlift4' a b c d = lift4' a b c d (\a b c d -> hor [a, b, c, d])+hlift4' a b c d = lift4' a b c d (\a' b' c' d' -> hor [a', b', c', d'])  -- | The same as @vlift2'@ but for four sound sources. vlift4' :: Double -> Double -> Double -> Double -> (a -> b -> c -> d -> e) -> Source a -> Source b -> Source c -> Source d -> Source e-vlift4' a b c d = lift4' a b c d (\a b c d -> ver [a, b, c, d])-+vlift4' a b c d = lift4' a b c d (\a' b' c' d' -> ver [a', b', c', d'])  lift5 :: (Gui -> Gui -> Gui -> Gui -> Gui -> Gui) -> (a1 -> a2 -> a3 -> a4 -> a5 -> b) -> Source a1 -> Source a2 -> Source a3 -> Source a4 -> Source a5 -> Source b lift5 gf f ma1 ma2 ma3 ma4 ma5 = source $ do@@ -275,8 +286,10 @@     (ga5, a5) <- ma5     return $ (gf ga1 ga2 ga3 ga4 ga5, f a1 a2 a3 a4 a5) +lift5' :: Double -> Double -> Double -> Double -> Double ->+  (Gui -> Gui -> Gui -> Gui -> Gui -> Gui) -> (a1 -> a2 -> a3 -> a4 -> a5 -> b) -> Source a1 -> Source a2 -> Source a3 -> Source a4 -> Source a5 -> Source b lift5' sa sb sc sd se gf = lift5 (tfm3 sa sb sc sd se gf)-    where tfm3 sa sb sc sd se gf = \a b c d e -> gf (sca sa a) (sca sb b) (sca sc c) (sca sd d) (sca se e)+    where tfm3 sa' sb' sc' sd' se' gf' = \a b c d e -> gf' (sca sa' a) (sca sb' b) (sca sc' c) (sca sd' d) (sca se' e)  -- | The same as @hlift2@ but for five sound sources. hlift5 :: (a1 -> a2 -> a3 -> a4 -> a5 -> b) -> Source a1 -> Source a2 -> Source a3 -> Source a4 -> Source a5 -> Source b@@ -288,11 +301,11 @@  -- | The same as @hlift2'@ but for five sound sources. hlift5' :: Double -> Double -> Double -> Double -> Double -> (a1 -> a2 -> a3 -> a4 -> a5 -> b) -> Source a1 -> Source a2 -> Source a3 -> Source a4 -> Source a5 -> Source b-hlift5' a b c d e = lift5' a b c d e (\a b c d e -> hor [a, b, c, d, e])+hlift5' a b c d e = lift5' a b c d e (\a' b' c' d' e' -> hor [a', b', c', d', e'])  -- | The same as @vlift2'@ but for five sound sources. vlift5' :: Double -> Double -> Double -> Double -> Double -> (a1 -> a2 -> a3 -> a4 -> a5 -> b) -> Source a1 -> Source a2 -> Source a3 -> Source a4 -> Source a5 -> Source b-vlift5' a b c d e = lift5' a b c d e (\a b c d e -> ver [a, b, c, d, e])+vlift5' a b c d e = lift5' a b c d e (\a' b' c' d' e' -> ver [a', b', c', d', e'])  -- | Monadic bind with horizontal concatenation of visuals. hbind :: Source a -> (a -> Source b) -> Source b

@@ -51,16 +51,16 @@     hradio', vradio', hradioSig', vradioSig' ) where +import Prelude hiding (span, reads)+ import Control.Monad -import Data.Monoid import Data.List(transpose) import Data.Boolean -import Csound.Typed.Gui+import Csound.Typed.Gui hiding (widget, height, width) import Csound.Typed.Types import Csound.Control.SE-import Csound.SigSpace(uon) import Csound.Control.Evt(listAt, Tick, snaps2, dropE, devt, loadbang, evtToSig) import Csound.Typed.Opcode(changed) @@ -185,12 +185,13 @@ vnumbers = genNumbers ver  genNumbers :: ([Gui] -> Gui) -> [Double] -> Source Sig-genNumbers gx as@(d:ds) = source $ do+genNumbers gx as@(d:_) = source $ do     ref <- newGlobalCtrlRef (sig $ double d)     (gs, evts) <- fmap unzip $ mapM (button . show) as     zipWithM_ (\x e -> runEvt e $ \_ -> writeRef ref (sig $ double x)) as evts     res <- readRef ref     return (gx gs, res)+genNumbers _ [] = error "Not implemented for empty list"   -------------------------------------------------------------------@@ -252,8 +253,8 @@         reGroupCol = reGroup ver         reGroupRow = reGroup hor -        reGroup f as = (f xs, ys)-            where (xs, ys) = unzip as+        reGroup f bs = (f xs, ys)+            where (xs, ys) = unzip bs   -- | Horizontal radio group.

@@ -108,28 +108,26 @@     newOutInstr, noteOn, noteOff ) where -import Control.Applicative import Control.Monad.Trans.Class import Csound.Dynamic hiding (str, Sco(..), when1, alwaysOn)  import Csound.Typed-import Csound.Typed.Opcode hiding (initc7, turnoff2)+import Csound.Typed.Opcode hiding (initc7, metro) import Csound.Control.Overload-import Temporal.Media(Event(..), mapEvents)+import Temporal.Media(Event(..), mapEvents, temp, str, dur) -import Csound.Control.Evt(metroE, repeatE, splitToggle, loadbang)-import Temporal.Media hiding (delay, line, chord, stretch)+import Csound.Control.Evt(metro, repeatE, splitToggle, loadbang)  -- | Mixes the scores and plays them in the loop. mixLoop :: (Sigs a) => Sco (Mix a) -> a-mixLoop a = sched instr $ withDur dt $ repeatE unit $ metroE $ 1 / dt+mixLoop a = sched instr $ withDur dt $ repeatE unit $ metro $ 1 / dt     where         dt = dur a         instr _ = return $ mix a  -- | Mixes the procedures and plays them in the loop. mixLoop_ :: Sco (Mix Unit) -> SE ()-mixLoop_ a = sched_ instr $ withDur dt $ repeatE unit $ metroE $ 1 / dt+mixLoop_ a = sched_ instr $ withDur dt $ repeatE unit $ metro $ 1 / dt     where         dt = dur a         instr _ = mix_ a@@ -147,10 +145,10 @@  -- | Invokes an instrument with toggle event stream (1 stands for on and 0 stands for off). schedToggle :: (Sigs b) => SE b -> Evt D -> b-schedToggle res evt = schedUntil instr on off+schedToggle res evt = schedUntil instr ons offs     where         instr = const res-        (on, off) = splitToggle evt+        (ons, offs) = splitToggle evt  -- | Invokes an instrument with first event stream and -- holds the note until the second event stream is active.

@@ -1,11 +1,11 @@ {-# Language FlexibleContexts #-} -- | Midi. module Csound.Control.Midi(-    MidiChn(..), MidiFun, toMidiFun, toMidiFun_, +    MidiChn(..), MidiFun, toMidiFun, toMidiFun_,     Msg, Channel, midi, midin, pgmidi, ampCps,     midi_, midin_, pgmidi_,     -- * Mono-midi synth-    monoMsg, holdMsg, trigNamedMono, genMonoMsg, smoothMonoArg, +    monoMsg, holdMsg, trigNamedMono, genMonoMsg, smoothMonoArg,     genFilteredMonoMsg, genFilteredMonoMsgTemp,      -- ** Custom temperament@@ -17,15 +17,18 @@     ampmidinn,      -- ** Custom temperament-    ampCps', cpsmidi', cpsmidi'D, cpsmidi'Sig, +    ampCps', cpsmidi', cpsmidi'D, cpsmidi'Sig,      -- * Overload-    tryMidi, tryMidi', MidiInstr(..), MidiInstrTemp(..)+    tryMidi, tryMidi', MidiInstr(..), MidiInstrTemp(..),++    -- * Other+    namedAmpCpsSig ) where  import Data.Boolean -import Csound.Typed+import Csound.Typed hiding (arg) import Csound.Typed.Opcode hiding (initc7) import Csound.Control.Overload import Csound.Control.Instr(alwaysOn)@@ -36,26 +39,26 @@  -- | Specifies the midi channel or programm. data MidiChn = ChnAll | Chn Int | Pgm (Maybe Int) Int-	deriving (Show, Eq)+  deriving (Show, Eq)  type MidiFun a = (Msg -> SE a) -> SE a  toMidiFun :: Sigs a => MidiChn -> MidiFun a toMidiFun x = case x of-	ChnAll  -> midi-	Chn n   -> midin n-	Pgm a b -> pgmidi a b+  ChnAll  -> midi+  Chn n   -> midin n+  Pgm a b -> pgmidi a b  toMidiFun_ :: MidiChn -> MidiFun () toMidiFun_ x = case x of-	ChnAll  -> midi_-	Chn n   -> midin_ n-	Pgm a b -> pgmidi_ a b+  ChnAll  -> midi_+  Chn n   -> midin_ n+  Pgm a b -> pgmidi_ a b  ampCps :: Msg -> (D, D) ampCps msg = (ampmidi msg 1, cpsmidi msg) --- | Converts midi velocity number to amplitude. +-- | Converts midi velocity number to amplitude. -- The first argument is dynamic range in decibels. -- -- > ampmidinn (volMinDb, volMaxDb) volumeKey = amplitude@@ -97,7 +100,7 @@ -- The signal fades out when nothing is pressed. -- It can be used in mono-synths. Arguments are custom temperament, midi channel, portamento time -- and release time. A portamento time is time it takes for transition--- from one note to another. +-- from one note to another. -- -- > monoMsgTemp temperament channel portamentoTime releaseTime monoMsgTemp :: Temp -> MidiChn -> D -> D -> SE (Sig, Sig)@@ -105,13 +108,13 @@  -- | Produces an argument for monophonic midi-synth. -- The signal fades out when nothing is pressed.--- It can be used in mono-synths. +-- It can be used in mono-synths. -- -- > genMonoMsg channel genMonoMsg :: MidiChn -> SE MonoArg genMonoMsg chn = genAmpCpsSig cpsmidi (toMidiFun chn) --- | Just like mono @genMonoMsg@ but also we can alter the temperament. The temperament spec goes first. +-- | Just like mono @genMonoMsg@ but also we can alter the temperament. The temperament spec goes first. -- -- > genMonoMsgTemp temperament channel genMonoMsgTemp :: Temp -> MidiChn -> SE MonoArg@@ -122,20 +125,20 @@  smoothMonoMsg :: (Msg -> D) -> MidiChn -> D -> D -> SE (Sig, Sig) smoothMonoMsg key2cps chn portTime relTime = do-	(MonoArg amp cps status _) <- genAmpCpsSig key2cps (toMidiFun chn)-	return (port amp portTime * port status relTime,  port cps portTime)+  (MonoArg amp cps status _) <- genAmpCpsSig key2cps (toMidiFun chn)+  return (port amp portTime * port status relTime,  port cps portTime)   genFilteredMonoMsg :: MidiChn -> (D -> BoolD) -> SE MonoArg-genFilteredMonoMsg chn cond = filteredGenAmpCpsSig cpsmidi (toMidiFun chn) cond+genFilteredMonoMsg chn condition = filteredGenAmpCpsSig cpsmidi (toMidiFun chn) condition --- | Just like mono @genMonoMsg@ but also we can alter the temperament. The temperament spec goes first. +-- | Just like mono @genMonoMsg@ but also we can alter the temperament. The temperament spec goes first. -- -- > genMonoMsgTemp temperament channel genFilteredMonoMsgTemp :: Temp -> MidiChn -> (D -> BoolD) -> SE MonoArg-genFilteredMonoMsgTemp tm chn cond = filteredGenAmpCpsSig (cpsmidi' tm) (toMidiFun chn) cond+genFilteredMonoMsgTemp tm chn condition = filteredGenAmpCpsSig (cpsmidi' tm) (toMidiFun chn) condition --- | Produces midi amplitude and frequency as a signal and holds the +-- | Produces midi amplitude and frequency as a signal and holds the -- last value till the next one is present. -- It can be used in mono-synths. Arguments are portamento time -- and release time. A portamento time is time it takes for transition@@ -145,7 +148,7 @@ holdMsg :: MidiChn -> D -> SE (Sig, Sig) holdMsg = genHoldMsg cpsmidi --- | Produces midi amplitude and frequency as a signal and holds the +-- | Produces midi amplitude and frequency as a signal and holds the -- last value till the next one is present. -- It can be used in mono-synths. Arguments are portamento time -- and release time. A portamento time is time it takes for transition@@ -157,8 +160,8 @@  genHoldMsg :: (Msg -> D) -> MidiChn -> D -> SE (Sig, Sig) genHoldMsg key2cps channel portTime = do-	(amp, cps) <- genHoldAmpCpsSig key2cps (toMidiFun_ channel)-	return (port amp portTime,  port cps portTime)+  (amp, cps) <- genHoldAmpCpsSig key2cps (toMidiFun_ channel)+  return (port amp portTime,  port cps portTime)   @@ -167,8 +170,8 @@     ref <- newGlobalRef ((0, 0) :: (Sig, Sig))     status <- midiFun (instr ref)     (amp, cps) <- readRef ref-    return $ makeMonoArg (amp, cps) status	-	where+    return $ makeMonoArg (amp, cps) status+  where         makeMonoArg (amp, cps) status = MonoArg kamp kcps resStatus retrig             where                 kamp = downsamp amp@@ -180,14 +183,14 @@         instr :: Ref (Sig, Sig) -> Msg -> SE Sig         instr hNote msg = do             writeRef hNote (sig $ ampmidi msg 1, sig $ key2cps msg)-            return 1		+            return 1  filteredGenAmpCpsSig :: (Msg -> D) -> ((Msg -> SE Sig) -> SE Sig) -> (D -> BoolD) -> SE MonoArg-filteredGenAmpCpsSig key2cps midiFun cond  = do+filteredGenAmpCpsSig key2cps midiFun condition  = do     ref <- newGlobalRef ((0, 0) :: (Sig, Sig))     status <- midiFun (instr ref)     (amp, cps) <- readRef ref-    return $ makeMonoArg (amp, cps) status  +    return $ makeMonoArg (amp, cps) status     where         makeMonoArg (amp, cps) status = MonoArg kamp kcps resStatus retrig             where@@ -200,26 +203,26 @@         instr :: Ref (Sig, Sig) -> Msg -> SE Sig         instr hNote msg = do             resRef <- newRef 0-            whenElseD (cond $ key2cps msg)+            whenElseD (condition $ key2cps msg)                 (do                     writeRef hNote (sig $ ampmidi msg 1, sig $ key2cps msg)                     writeRef resRef 1)                 (do                     writeRef resRef 0)-            readRef resRef            +            readRef resRef  genHoldAmpCpsSig :: (Msg -> D) -> ((Msg -> SE ()) -> SE ()) -> SE (Sig, Sig) genHoldAmpCpsSig key2cps midiFun = do-	ref <- newGlobalRef ((0, 0) :: (Sig, Sig))-	midiFun (instr ref)	-	(amp, cps) <- readRef ref-	return (downsamp amp, downsamp cps)-	where -		instr :: Ref (Sig, Sig) -> Msg -> SE ()-		instr hNote msg = do-			writeRef hNote (sig $ ampmidi msg 1, sig $ key2cps msg)			+  ref <- newGlobalRef ((0, 0) :: (Sig, Sig))+  midiFun (instr ref)+  (amp, cps) <- readRef ref+  return (downsamp amp, downsamp cps)+  where+    instr :: Ref (Sig, Sig) -> Msg -> SE ()+    instr hNote msg = do+      writeRef hNote (sig $ ampmidi msg 1, sig $ key2cps msg) --- | Creates a named instrument that can be triggered with Csound API. +-- | Creates a named instrument that can be triggered with Csound API. -- This way we can create a csd file that can be used inside another program/language. -- -- It simulates the input for monophonic midi-like instrument. Notes are encoded with messages:@@ -233,22 +236,22 @@  namedAmpCpsSig:: String -> SE (Sig, Sig, Sig) namedAmpCpsSig name = do-	ref <- newGlobalRef ((0, 0) :: (Sig, Sig))	-	statusRef <- newGlobalRef (0 :: Sig)-	status <- trigByNameMidi name (instr statusRef ref)-	writeRef statusRef status -	let resStatus = ifB (downsamp status ==* 0) 0 1-	(amp, cps) <- readRef ref-	return (downsamp amp, downsamp cps, resStatus)-	where -		instr :: Ref Sig -> Ref (Sig, Sig) -> (D, D, Unit) -> SE Sig-		instr statusRef hNote (pitchKey, volKey, _) = do-			curId <- readRef statusRef-			myIdRef <- newRef (ir curId)-			myId <- readRef myIdRef			-			when1 (curId ==* (sig $ myId + 1)) $ do-				writeRef hNote (sig volKey, sig pitchKey)-			return 1+  ref <- newGlobalRef ((0, 0) :: (Sig, Sig))+  statusRef <- newGlobalRef (0 :: Sig)+  status <- trigByNameMidi name (instr statusRef ref)+  writeRef statusRef status+  let resStatus = ifB (downsamp status ==* 0) 0 1+  (amp, cps) <- readRef ref+  return (downsamp amp, downsamp cps, resStatus)+  where+    instr :: Ref Sig -> Ref (Sig, Sig) -> (D, D, Unit) -> SE Sig+    instr statusRef hNote (pitchKey, volKey, _) = do+      curId <- readRef statusRef+      myIdRef <- newRef (ir curId)+      myId <- readRef myIdRef+      when1 (curId ==* (sig $ myId + 1)) $ do+        writeRef hNote (sig volKey, sig pitchKey)+      return 1  -------------------------------------------------------------- @@ -262,56 +265,56 @@ midiKeyOff = midiKeyOffBy . toMidiFun  midiKeyOnBy :: MidiFun Sig -> D -> SE (Evt D)-midiKeyOnBy midiFun key = do	-	chRef  <- newGlobalRef (0 :: Sig)-	evtRef <- newGlobalRef (0 :: Sig)-	writeRef chRef =<< midiFun instr+midiKeyOnBy midiFun key = do+  chRef  <- newGlobalRef (0 :: Sig)+  evtRef <- newGlobalRef (0 :: Sig)+  writeRef chRef =<< midiFun instr -	alwaysOn $ do-		a <- readRef chRef-		writeRef evtRef $ diff a+  alwaysOn $ do+    a <- readRef chRef+    writeRef evtRef $ diff a -	evtSig <- readRef evtRef-	return $ filterE ( >* 0) $ snaps evtSig-	where-		instr msg = do-			print' [notnum msg] -			return $ ifB (boolSig $ notnum msg ==* key) (sig $ ampmidi msg 1) 0+  evtSig <- readRef evtRef+  return $ filterE ( >* 0) $ snaps evtSig+  where+    instr msg = do+      print' [notnum msg]+      return $ ifB (boolSig $ notnum msg ==* key) (sig $ ampmidi msg 1) 0   midiKeyOffBy :: MidiFun Sig -> D -> SE Tick-midiKeyOffBy midiFun key = do	-	chRef  <- newGlobalRef (0 :: Sig)-	evtRef <- newGlobalRef (0 :: Sig)-	writeRef chRef =<< midiFun instr+midiKeyOffBy midiFun key = do+  chRef  <- newGlobalRef (0 :: Sig)+  evtRef <- newGlobalRef (0 :: Sig)+  writeRef chRef =<< midiFun instr -	alwaysOn $ do-		a <- readRef chRef-		writeRef evtRef $ diff a+  alwaysOn $ do+    a <- readRef chRef+    writeRef evtRef $ diff a -	evtSig <- readRef evtRef-	return $ fmap (const unit) $ filterE ( `lessThan` 0) $ snaps evtSig-	where-		instr msg = do-			print' [notnum msg] -			return $ ifB (boolSig $ notnum msg ==* key) (sig $ ampmidi msg 1) 0+  evtSig <- readRef evtRef+  return $ fmap (const unit) $ filterE ( `lessThan` 0) $ snaps evtSig+  where+    instr msg = do+      print' [notnum msg]+      return $ ifB (boolSig $ notnum msg ==* key) (sig $ ampmidi msg 1) 0  --------------------------------------------------------------  -- | Initialization of the midi control-messages. initc7 :: D -> D -> D -> SE ()-initc7 = initMidiCtrl +initc7 = initMidiCtrl  -- | Initializes midi control and get the value in the specified range. midiCtrl7 :: D -> D -> D -> D -> D -> SE Sig midiCtrl7 chno ctrlno ival imin imax = do     initc7 chno ctrlno ival     return $ ctrl7 chno ctrlno imin imax-    + -- | Initializes midi control and get the value in the range (-1) to 1. midiCtrl :: D -> D -> D -> SE Sig midiCtrl chno ctrlno ival = midiCtrl7 chno ctrlno ival (-1) 1-    + -- | Unipolar midiCtrl. Initializes midi control and get the value in the range 0 to 1. umidiCtrl :: D -> D -> D -> SE Sig umidiCtrl chno ctrlno ival = midiCtrl7 chno ctrlno ival 0 1

@@ -1,9 +1,9 @@-{-# Language -        TypeFamilies, -        FlexibleInstances, +{-# Language+        TypeFamilies,+        FlexibleInstances,         FlexibleContexts #-} module Csound.Control.Overload.Outs(-    Outs(..), onArg       +    Outs(..), onArg ) where  import Csound.Typed@@ -16,26 +16,26 @@     toOuts :: a -> SE (SigOuts a)  instance Outs Sig where-	type SigOuts Sig = Sig-	toOuts = return +  type SigOuts Sig = Sig+  toOuts = return  instance Outs (Sig, Sig) where-	type SigOuts (Sig, Sig) = (Sig, Sig)-	toOuts = return+  type SigOuts (Sig, Sig) = (Sig, Sig)+  toOuts = return  instance Outs (Sig, Sig, Sig, Sig) where-	type SigOuts (Sig, Sig, Sig, Sig) = (Sig, Sig, Sig, Sig)-	toOuts = return+  type SigOuts (Sig, Sig, Sig, Sig) = (Sig, Sig, Sig, Sig)+  toOuts = return  instance Outs (SE Sig) where-	type SigOuts (SE Sig) = Sig-	toOuts = id +  type SigOuts (SE Sig) = Sig+  toOuts = id  instance Outs (SE (Sig, Sig)) where-	type SigOuts (SE (Sig, Sig)) = (Sig, Sig)-	toOuts = id+  type SigOuts (SE (Sig, Sig)) = (Sig, Sig)+  toOuts = id  instance Outs (SE (Sig, Sig, Sig, Sig)) where-	type SigOuts (SE (Sig, Sig, Sig, Sig)) = (Sig, Sig, Sig, Sig)-	toOuts = id+  type SigOuts (SE (Sig, Sig, Sig, Sig)) = (Sig, Sig, Sig, Sig)+  toOuts = id 

@@ -1,9 +1,9 @@ module Csound.Control.SE(     SE, Ref, writeRef, readRef, modifyRef, mixRef, newRef, sensorsSE, newGlobalRef, globalSensorsSE,     newCtrlRef, newGlobalCtrlRef, newClearableGlobalRef, newTab, newGlobalTab,-    whileRef, whileRef+    whileRef ) where  import Csound.Typed.Control-import Csound.Typed.Types.Tuple+import Csound.Typed.Types.Tuple() 

@@ -1,12 +1,12 @@--- | Sound fonts. Playing Sf2 samples. +-- | Sound fonts. Playing Sf2 samples. -- -- There are three groups of functions.--- Functions that are defined for midi messages, midi notes (it's a pair of integers from 0-127) +-- Functions that are defined for midi messages, midi notes (it's a pair of integers from 0-127) -- and  the frequencies (in Hz). -- Each group contains four functions. They are destinguished by suffixes.--- The function with no suffix play a sf2 file with linear interpolation +-- The function with no suffix play a sf2 file with linear interpolation -- and take stereo output.--- The function with suffix @3@ read samples with cubic interpolation. +-- The function with suffix @3@ read samples with cubic interpolation. -- The functions with suffix @m@ produce mono outputs. -- The loopers play samples in loops. module Csound.Control.Sf(@@ -23,7 +23,6 @@  import Csound.Typed import Csound.Typed.Opcode-import Csound.SigSpace  import Csound.Tuning import Csound.Control.Midi@@ -70,10 +69,10 @@ sfMsg3m :: Sf -> D -> Msg -> SE Sig sfMsg3m = genSfMsg sfplay3m --- | Midi looper of the sf2 samples. +-- | Midi looper of the sf2 samples. -- The first arguments are: start, end, crossfade of the loop. sfMsgLooper :: Sig -> Sig -> Sig -> Sf -> D -> Msg -> SE (Sig, Sig)-sfMsgLooper start end crossfade = genSfMsg $ +sfMsgLooper start end crossfade = genSfMsg $     \vel key amp cps sf -> sflooper vel key amp cps sf start end crossfade  -----------------------------------@@ -105,10 +104,10 @@ sfMsgTemp3m :: Temp -> Sf -> D -> Msg -> SE Sig sfMsgTemp3m = genSfMsgTemp sfplay3m --- | Midi looper of the sf2 samples. +-- | Midi looper of the sf2 samples. -- The first arguments are: start, end, crossfade of the loop. sfMsgLooperTemp :: Sig -> Sig -> Sig -> Temp -> Sf -> D -> Msg -> SE (Sig, Sig)-sfMsgLooperTemp start end crossfade = genSfMsgTemp $ +sfMsgLooperTemp start end crossfade = genSfMsgTemp $     \vel key amp cps sf -> sflooper vel key amp cps sf start end crossfade  -----------------------------------------@@ -124,7 +123,7 @@ sfKey3 = genSfKey sfplay3  -- | Reads sf2 samples at given midi velocity and key (both are from 0 to 127).--- The second argument is sustain. Interpolation is linear. +-- The second argument is sustain. Interpolation is linear. -- The output is mono. sfKeym :: Sf -> D -> D -> D -> Sig sfKeym = genSfKey sfplaym@@ -135,40 +134,40 @@ sfKey3m :: Sf -> D -> D -> D -> Sig sfKey3m = genSfKey sfplay3m --- | Looper of the sf2 samples. +-- | Looper of the sf2 samples. -- The first arguments are: start, end, crossfade of the loop. sfKeyLooper :: Sig -> Sig -> Sig -> Sf -> D -> D -> D -> (Sig, Sig)-sfKeyLooper start end crossfade = genSfKey $ +sfKeyLooper start end crossfade = genSfKey $     \vel key amp cps sf -> sflooper vel key amp cps sf start end crossfade  ----------------------------------------- --- | Reads sf2 samples with amplitude in (0, 1) and frequency in Hz. +-- | Reads sf2 samples with amplitude in (0, 1) and frequency in Hz. -- The interpolation is linear. sfCps :: Sf -> D -> D -> D -> (Sig, Sig) sfCps = genSfCps sfplay --- | Reads sf2 samples with amplitude in (0, 1) and frequency in Hz. +-- | Reads sf2 samples with amplitude in (0, 1) and frequency in Hz. -- The interpolation is cubic. sfCps3 :: Sf -> D -> D -> D -> (Sig, Sig) sfCps3 = genSfCps sfplay3 --- | Reads sf2 samples with amplitude in (0, 1) and frequency in Hz. +-- | Reads sf2 samples with amplitude in (0, 1) and frequency in Hz. -- The interpolation is linear. -- The output is mono. sfCpsm :: Sf -> D -> D -> D -> Sig sfCpsm = genSfCps sfplaym --- | Reads sf2 samples with amplitude in (0, 1) and frequency in Hz. +-- | Reads sf2 samples with amplitude in (0, 1) and frequency in Hz. -- The interpolation is cubic. -- The output is mono. sfCps3m :: Sf -> D -> D -> D -> Sig sfCps3m = genSfCps sfplay3m --- | Looper of the sf2 samples. +-- | Looper of the sf2 samples. -- The first arguments are: start, end, crossfade of the loop. sfCpsLooper :: Sig -> Sig -> Sig -> Sf -> D -> D -> D -> (Sig, Sig)-sfCpsLooper start end crossfade = genSfCps $ +sfCpsLooper start end crossfade = genSfCps $     \vel key amp cps sf -> sflooper vel key amp cps sf start end crossfade  ----------------------------------------------@@ -187,12 +186,12 @@     where env = sfEnv sustain (vel / 127)  genSfCps :: (Tuple a, SigSpace a) => SfFun a -> Sf -> D -> D -> D -> a-genSfCps play sf sustain amp cps = mul env $ play (127 * amp) (f2m cps) 1 (sig cps) sf `withD` 1 -    where env = sfEnv sustain amp +genSfCps play sf sustain amp cps = mul env $ play (127 * amp) (f2m cps) 1 (sig cps) sf `withD` 1+    where env = sfEnv sustain amp  sfEnv :: D -> D -> Sig sfEnv sustain amp = sig frac * env-    where +    where         frac = amp / 8000         env  = linsegr [0, 0.007, 1] sustain 0 

@@ -23,6 +23,7 @@ module Csound.IO (     -- * Rendering     RenderCsd(..),+    CsdArity(..),     renderCsd,     writeCsd, writeCsdBy,     writeSnd, writeSndBy,@@ -67,65 +68,109 @@     readMacrosString, readMacrosDouble, readMacrosInt ) where +--import Control.Concurrent+import Control.Monad+ import System.Process import qualified Control.Exception as E -import Control.Monad-import Data.Monoid import Data.Default import Csound.Typed import Csound.Control.Gui -import Csound.Options(setSilent, setDac, setAdc, setCabbage)+import Csound.Options(setSilent, setDac, setAdc, setDacBy, setAdcBy, setCabbage) +import qualified Data.List as L+ render :: Sigs a => Options -> SE a -> IO String render = renderOutBy  render_ :: Options -> SE () -> IO String render_ = renderOutBy_ +data CsdArity = CsdArity+  { csdArity'inputs  :: Int+  , csdArity'outputs :: Int+  } deriving (Show, Eq)+ class RenderCsd a where     renderCsdBy :: Options -> a -> IO String+    csdArity :: a -> CsdArity +hasInputs :: RenderCsd a => a -> Bool+hasInputs = ( > 0) . csdArity'inputs . csdArity++hasOutputs :: RenderCsd a => a -> Bool+hasOutputs = ( > 0) . csdArity'outputs . csdArity+ instance {-# OVERLAPPING #-} RenderCsd (SE ()) where     renderCsdBy = render_+    csdArity _ = CsdArity 0 0  #if __GLASGOW_HASKELL__ >= 710 instance {-# OVERLAPPABLE #-} Sigs a => RenderCsd a where     renderCsdBy opt a = render opt (return a)+    csdArity a = CsdArity 0 (tupleArity a)  instance {-# OVERLAPPABLE #-} Sigs a => RenderCsd (SE a) where     renderCsdBy opt a = render opt a+    csdArity a = CsdArity 0 (outArity a)  instance {-# OVERLAPPABLE #-} Sigs a => RenderCsd (Source a) where     renderCsdBy opt a = renderCsdBy opt (fromSource a)+    csdArity a = CsdArity 0 (tupleArity $ proxySource a)+      where  instance {-# OVERLAPPABLE #-} Sigs a => RenderCsd (Source (SE a)) where     renderCsdBy opt a = renderCsdBy opt (fromSourceSE a)+    csdArity a = CsdArity 0 (tupleArity $ proxySE $ proxySource a)+ #endif +proxySource :: Source a -> a+proxySource = const undefined++proxySE :: SE a -> a+proxySE = const undefined++proxyFun :: (a -> b) -> (a, b)+proxyFun = const undefined++proxyIn :: (a -> b) -> a+proxyIn = fst . proxyFun++proxyOut :: (a -> b) -> b+proxyOut = snd . proxyFun+ instance {-# OVERLAPPABLE #-} (Sigs a, Sigs b) => RenderCsd (a -> b) where     renderCsdBy opt f = renderEffBy opt (return . f)+    csdArity a = CsdArity (tupleArity $ proxyIn a) (tupleArity $ proxyOut a)  instance {-# OVERLAPPABLE #-} (Sigs a, Sigs b) => RenderCsd (a -> SE b) where     renderCsdBy opt f = renderEffBy opt f+    csdArity a = CsdArity (tupleArity $ proxyIn a) (tupleArity $ proxySE $ proxyOut a)  instance {-# OVERLAPPABLE #-} (Sigs a, Sigs b) => RenderCsd (a -> Source b) where     renderCsdBy opt f = renderEffBy opt (fromSource . f)+    csdArity a = CsdArity (tupleArity $ proxyIn a) (tupleArity $ proxySource $ proxyOut a)  instance (Sigs a, Sigs b) => RenderCsd (a -> Source (SE b)) where     renderCsdBy opt f = renderEffBy opt (fromSourceSE . f)+    csdArity a = CsdArity (tupleArity $ proxyIn a) (tupleArity $ proxySE $ proxySource $ proxyOut a)  instance {-# OVERLAPPING #-} (Sigs a) => RenderCsd (a -> Source (SE Sig2)) where     renderCsdBy opt f = renderEffBy opt (fromSourceSE . f)+    csdArity a = CsdArity (tupleArity $ proxyIn a) (tupleArity $ proxySE $ proxySource $ proxyOut a)  instance {-# OVERLAPPING #-} RenderCsd (Source ()) where     renderCsdBy opt src = renderCsdBy opt $ do         (ui, _) <- src         panel ui+    csdArity _ = CsdArity 0 0  instance {-# OVERLAPPING #-} RenderCsd (Source (SE ())) where     renderCsdBy opt src = renderCsdBy opt (joinSource src)+    csdArity _ = CsdArity 0 0  -- | Renders Csound file. renderCsd :: RenderCsd a => a -> IO String@@ -147,9 +192,14 @@ writeSndBy :: RenderCsd a => Options -> String -> a -> IO () writeSndBy opt file a = do     writeCsdBy opt fileCsd a-    runWithUserInterrupt $ "csound -o " ++ file ++ " " ++ fileCsd+    runWithUserInterrupt (postSetup opt) $ unwords ["csound -o", file, fileCsd, logTrace opt]     where fileCsd = "tmp.csd" +logTrace :: Options -> String+logTrace opt+  | csdNeedTrace opt = ""+  | otherwise        = "--logfile=null"+ -- | Renders Csound file, saves it to the given file, renders with csound command and plays it with the given program. -- -- > playCsd program file csd@@ -164,7 +214,7 @@ playCsdBy :: (RenderCsd a) => Options -> (String -> IO ()) -> String -> a -> IO () playCsdBy opt player file a = do     writeCsdBy opt fileCsd a-    runWithUserInterrupt $ "csound -o " ++ fileWav ++ " " ++ fileCsd+    runWithUserInterrupt (postSetup opt) $ unwords ["csound -o", fileWav, fileCsd, logTrace opt]     player fileWav     return ()     where fileCsd = file ++ ".csd"@@ -173,7 +223,7 @@ simplePlayCsdBy :: (RenderCsd a) => Options -> String -> String -> a -> IO () simplePlayCsdBy opt player = playCsdBy opt phi     where phi file = do-            runWithUserInterrupt $ player ++ " " ++ file+            runWithUserInterrupt (pure ()) $ unwords [player, file]  -- | Renders csound code to file @tmp.csd@ with flags set to @-odac@, @-iadc@ and @-Ma@ -- (sound output goes to soundcard in real time).@@ -184,9 +234,20 @@ dacBy :: (RenderCsd a) => Options -> a -> IO () dacBy opt' a = do     writeCsdBy opt "tmp.csd" a-    runWithUserInterrupt $ "csound " ++ "tmp.csd"-    where opt = opt' <> setDac <> setAdc+    runWithUserInterrupt (postSetup opt') $ unwords ["csound tmp.csd", logTrace opt']+    where+      opt = opt' <> withDac <> withAdc +      withDac+        | hasJackConnections opt' = setDacBy "null"+        | hasOutputs a            = setDac+        | otherwise               = mempty++      withAdc+        | hasJackConnections opt' = setAdcBy "null"+        | hasInputs a             = setAdc+        | otherwise               = mempty+ -- | Output to dac with virtual midi keyboard. vdac :: (RenderCsd a) => a -> IO () vdac = dacBy (setVirtual def)@@ -207,8 +268,28 @@ csdBy :: (RenderCsd a) => Options -> a -> IO () csdBy options a = do     writeCsdBy (setSilent <> options) "tmp.csd" a-    runWithUserInterrupt $ "csound tmp.csd"+    runWithUserInterrupt (postSetup options) $ unwords ["csound tmp.csd", logTrace options] +postSetup :: Options -> IO ()+postSetup opt = jackConnect opt++jackConnect :: Options -> IO ()+jackConnect opt+  | Just conns <- csdJackConnect opt = case conns of+                                         [] -> pure ()+                                         _  -> void $ runCommand $ jackCmd conns+  | otherwise                        = pure ()+  where+    addSleep = ("sleep 0.1; " <> )++    jackCmd = addSleep . L.intercalate ";" . fmap jackConn+    jackConn (port1, port2) = unwords ["jack_connect", port1, port2]++hasJackConnections :: Options -> Bool+hasJackConnections opt+  | Just conns <- csdJackConnect opt = not $ null conns+  | otherwise                        = False+ ---------------------------------------------------------- -- players @@ -231,14 +312,15 @@ ---------------------------------------------------------- -- handle user interrupts -runWithUserInterrupt :: String -> IO ()-runWithUserInterrupt cmd = do+runWithUserInterrupt :: IO () -> String -> IO ()+runWithUserInterrupt setup cmd = do     pid <- runCommand cmd+    setup     E.catch (waitForProcess pid >> return ()) (onUserInterrupt pid)     where         onUserInterrupt :: ProcessHandle -> E.AsyncException -> IO ()         onUserInterrupt pid x = case x of-            E.UserInterrupt -> terminateProcess pid >> E.throw x+            E.UserInterrupt -> terminateProcess pid             e               -> E.throw e  ----------------------------------------------------------@@ -253,7 +335,7 @@ runCabbageBy :: (RenderCsd a) => Options -> a -> IO () runCabbageBy opt' a = do     writeCsdBy opt "tmp.csd" a-    runWithUserInterrupt $ "Cabbage " ++ "tmp.csd"+    runWithUserInterrupt (pure ()) $ "Cabbage tmp.csd"     where opt = opt' <> setCabbage  ------------------------------

@@ -4,12 +4,13 @@     -- * Shortcuts     setDur,     setRates, setBufs, setGain,-    setJack, setAlsa, setCoreAudio, setMme,+    setJack, setJackConnect, setAlsa, setCoreAudio, setMme,     setOutput, setInput,     setDac, setAdc, setDacBy, setAdcBy, setThru,     setSilent, setMidiDevice, setMa,-    setMessageLevel, noTrace,+    setMessageLevel, noMessages, setTrace,     setCabbage,+    setJacko,      -- * Flags     -- | Csound's command line flags. See original documentation for@@ -37,7 +38,6 @@     Config(..) ) where -import Data.Monoid import Data.Default import Csound.Typed @@ -145,12 +145,21 @@ setMessageLevel n = def { csdFlags = def { displays = def { messageLevel = Just n }}}  -- | Sets the tracing or debug info of csound console to minimum.-noTrace :: Options-noTrace = setMessageLevel 0+noMessages :: Options+noMessages = setMessageLevel 0 +setTrace :: Options+setTrace = def { csdTrace = Just True }+ ---------------------------------------------  -- | Provides options for Cabbage VST-engine. setCabbage :: Options setCabbage = setRates 48000 64 <> setNoRtMidi <> setMidiDevice "0"     where setNoRtMidi = def { csdFlags = def { rtmidi = Just NoRtmidi, audioFileOutput = def { nosound = True } }}++-- | Defines what ports we should connect after application is launched+--+-- It invokes @jack_connect@ for every pair of port-names in the list.+setJackConnect :: [(String, String)] -> Options+setJackConnect connections = def { csdJackConnect = Just connections }

@@ -1,22 +1,18 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# Language -        TypeFamilies, -        MultiParamTypeClasses, -        FlexibleInstances, +{-# Language+        TypeFamilies,+        MultiParamTypeClasses,+        FlexibleInstances,         FlexibleContexts #-} module Csound.SigSpace(     SigSpace(..), BindSig(..), mul, mul', on, uon, At(..), MixAt(..), bat, bmixAt,     cfd, cfd4, cfds, cfdSpec, cfdSpec4, cfdsSpec, wsum,      -- * Stereo sig space-    SigSpace2(..), BindSig2(..), mul2, mul2'    +    SigSpace2(..), BindSig2(..), mul2, mul2' ) where -import Control.Monad-import Control.Applicative- import Csound.Typed-import Csound.Types import Csound.Typed.Opcode(pvscross, pvscale, pvsmix, balance)  -- | Spectral crossfade.

@@ -1,9 +1,10 @@+{-# Language LambdaCase #-} -- | Creating Function Tables (Buffers) module Csound.Tab (     -- | If you are not familliar with Csound's conventions     -- you are pobably not aware of the fact that for efficiency reasons Csound requires that table size is equal-    -- to power of 2 or power of two plus one which stands for guard point (you do need guard point if your intention is to read the -    -- table once but you don't need the guard point if you read the table in many cycles, then the guard point is the the first point of your table).  +    -- to power of 2 or power of two plus one which stands for guard point (you do need guard point if your intention is to read the+    -- table once but you don't need the guard point if you read the table in many cycles, then the guard point is the the first point of your table).     Tab, noTab,      -- * Table querries@@ -11,11 +12,11 @@     nsamp, ftlen, ftsr, ftchnls, ftcps,      -- * Table granularity-    TabFi, fineFi, coarseFi,        +    TabFi, fineFi, coarseFi,      -- * Fill table with numbers     doubles,-   +     -- * Create new tables to write/update data      newTab, newGlobalTab, tabSizeSeconds, tabSizePower2, tabSizeSecondsPower2,@@ -40,7 +41,7 @@     tanhTab, rescaleTanhTab, expTab, rescaleExpTab, soneTab, rescaleSoneTab,     fareyTab, -    -- * Interpolants    +    -- * Interpolants     -- | All funtions have the same shape of arguments:     --     -- > fun [a, n1, b, n2, c, ...]@@ -49,14 +50,14 @@     --     -- * a, b, c .. - are ordinate values     ---    -- * n1, n2 .. - are lengths of the segments relative to the total number of the points in the table   -    --    +    -- * n1, n2 .. - are lengths of the segments relative to the total number of the points in the table+    --     -- Csounders, Heads up! all segment lengths are relative to the total sum of the segments.-    -- You don't need to make the sum equal to the number of points in the table. Segment's lengths will be resized +    -- You don't need to make the sum equal to the number of points in the table. Segment's lengths will be resized     -- automatically. For example if we want to define a curve that rises to 1 over 25\% of the table and then falls down to zero     -- we can define it like this:     ---    -- > lins [0, 0.25, 1, 0.75, 0] +    -- > lins [0, 0.25, 1, 0.75, 0]     --     -- or     --@@ -66,15 +67,15 @@     --     -- > lins [0, 1, 1, 3, 0]     ---    -- all these expressions are equivalent. +    -- all these expressions are equivalent.     consts, lins, cubes, exps, splines, startEnds, tabseg, bpLins, bpExps,     -- ** Equally spaced interpolants     econsts, elins, ecubes, eexps, esplines, estartEnds, etabseg, -    -- * Polynomials    +    -- * Polynomials     polys, chebs1, chebs2, bessels, -    -- * Random values +    -- * Random values      -- ** Distributions     uniDist, linDist, triDist, expDist, biexpDist, gaussDist,@@ -83,12 +84,12 @@     -- *** Distributions with levels     uniDist', linDist', triDist', expDist', biexpDist', gaussDist',     cauchyDist', pcauchyDist', betaDist', weibullDist', poissonDist',-    +     -- ** Rand values and ranges     randDist, rangeDist,  -    -- * Windows  +    -- * Windows     winHamming, winHanning,  winBartlett, winBlackman,     winHarris, winGauss, winKaiser, winRectangle, winSync, @@ -103,19 +104,19 @@      -- * Low level Csound definition.     gen,-    +     -- * Modify tables     skipNorm, forceNorm, setSize, setDegree, guardPoint, gp,-    -    -- ** Handy shortcuts        ++    -- ** Handy shortcuts     -- | handy shortcuts for the function 'setDegree'.     lllofi, llofi, lofi, midfi, hifi, hhifi, hhhifi,-    +     -- * Identifiers for GEN-routines-    +     -- | Low level Csound integer identifiers for tables. These names can be used in the function 'Csound.Base.fineFi'-    idWavs, idMp3s, idDoubles, idSines, idSines3, idSines2, -    idPartials, idSines4, idBuzzes, idConsts, idLins, idCubes, +    idWavs, idMp3s, idDoubles, idSines, idSines3, idSines2,+    idPartials, idSines4, idBuzzes, idConsts, idLins, idCubes,     idExps, idSplines, idStartEnds,  idPolys, idChebs1, idChebs2, idBessels, idWins,     idPadsynth, idTanh, idExp, idSone, idFarey, idWave, @@ -181,18 +182,16 @@     -- * GENquadbezier — (not implemented yet) Generate a table with values from a quadratic Bézier function.     -- * GENfarey — fareyTab -- Fills a table with the Farey Sequence Fn of the integer n.     -- * GENwave — waveletTab -- Generates a compactly supported wavelet function.-    -- * GENpadsynth — pdsynth, bwSines Generate a sample table using the padsynth algorithm.     +    -- * GENpadsynth — pdsynth, bwSines Generate a sample table using the padsynth algorithm. ) where -import Control.Applicative hiding ((<*)) import Control.Arrow(second) import Control.Monad.Trans.Class import Control.Monad.Trans.Reader-import Csound.Dynamic hiding (int, when1, whens)+import Csound.Dynamic hiding (int, when1, whens, genId, pn)  import Data.Default import Csound.Typed-import Csound.Typed.Opcode(ftgentmp, ftgenonce) import Data.Maybe  -- | The default table. It's rendered to @(-1)@ in the Csound.@@ -207,14 +206,14 @@ newTab :: D -> SE Tab newTab size = ftgentmp 0 0 size 7 0 [size, 0] --- | Creates a new global table. +-- | Creates a new global table. -- It's generated only once. It's persisted between instrument calls. -- -- > newGlobalTab identifier size newGlobalTab :: D -> SE Tab-newGlobalTab size = do  +newGlobalTab size = do     identifier <- getNextGlobalGenId-    ref <- newGlobalRef (0 :: D)        +    ref <- newGlobalRef (0 :: D)     tabId <- ftgenonce 0 (int identifier) size 7 0 [size, 0]     writeRef ref (fromGE $ toGE tabId)     fmap (fromGE . toGE) $ readRef ref@@ -254,7 +253,7 @@ -- -- with channel argument we can read left, right or both channels. wavs :: String -> Double -> WavChn -> Tab-wavs filename skiptime channel = preTab (SizePlain 0) idWavs +wavs filename skiptime channel = preTab (SizePlain 0) idWavs     (FileAccess filename [skiptime, format, fromIntegral $ fromWavChn channel])     where format = 0 @@ -285,11 +284,11 @@ -- > mp3s fileName skipTime format -- -- skipTime specifies from what second it should read the file.--- +-- -- format is: 1 - for mono files, 2 - for stereo files, 3 - for left channel of stereo file, -- 4 for right channel of stereo file mp3s :: String -> Double -> Mp3Chn -> Tab-mp3s filename skiptime channel = preTab (SizePlain 0) idMp3s +mp3s filename skiptime channel = preTab (SizePlain 0) idMp3s     (FileAccess filename [skiptime, format])     where format = fromIntegral $ fromMp3Chn channel @@ -322,16 +321,16 @@     | isPowerOfTwo n        = n     | isPowerOfTwo (n - 1)  = n     | otherwise             = -n-    + isPowerOfTwo :: Int -> Bool-isPowerOfTwo a +isPowerOfTwo a     | null zeroes   = False     | otherwise     = all ( == 0) zeroes     where zeroes = fmap (flip mod 2) $ takeWhile (> 1) $ iterate (\x -> div x 2) a  -- loadFile :: Int -> String -> Double -> Tab --- | Table contains all provided values +-- | Table contains all provided values -- (table is extended to contain all values and to be of the power of 2 or the power of two plus one). -- (by default it skips normalization). doubles :: [Double] -> Tab@@ -342,8 +341,8 @@ -- -- > exps [a, n1, b, n2, c, ...] ----- where --- +-- where+-- -- * @a, b, c, ...@ are ordinate values -- -- * @n1, n2, ...@  are lengths of the segments relative to the total number of the points in the table@@ -352,7 +351,7 @@  -- | Equally spaced segments of exponential curves. ----- > eexps [a, b, c, ...] +-- > eexps [a, b, c, ...] -- -- is the same as --@@ -360,7 +359,7 @@ eexps :: [Double] -> Tab eexps = exps . insertOnes --- | Segments of cubic polynomials. +-- | Segments of cubic polynomials. -- -- > cubes [a, n1, b, n2, c, ...] --@@ -374,7 +373,7 @@  -- | Equally spaced segments of cubic polynomials. ----- > ecubes [a, b, c, ...] +-- > ecubes [a, b, c, ...] -- -- is the same as --@@ -382,7 +381,7 @@ ecubes :: [Double] -> Tab ecubes = cubes . insertOnes --- | Segments of straight lines. +-- | Segments of straight lines. -- -- > lins [a, n1, b, n2, c, ...] --@@ -396,7 +395,7 @@  -- | Equally spaced segments of straight lines. ----- > elins [a, b, c, ...] +-- > elins [a, b, c, ...] -- -- is the same as --@@ -418,7 +417,7 @@  -- | Equally spaced spline curve. ----- > esplines [a, b, c, ...] +-- > esplines [a, b, c, ...] -- -- is the same as --@@ -440,14 +439,14 @@  -- | Equally spaced constant segments. ----- > econsts [a, b, c, ...] +-- > econsts [a, b, c, ...] -- -- is the same as -- -- > consts [a, 1, b, 1, c, ...] econsts :: [Double] -> Tab econsts = consts . insertOnes-   + -- | Creates a table from a starting value to an ending value. -- -- > startEnds [val1, dur1, type1, val2, dur2, type2, val3, ... typeX, valN]@@ -459,7 +458,7 @@ -- * type1, type2 ... -- if 0, a straight line is produced. If non-zero, then it creates the following curve, for dur steps: -- -- > beg + (end - beg) * (1 - exp( i*type)) / (1 - exp(type * dur))--- +-- -- * beg, end - end points of the segment -- -- * dur - duration of the segment@@ -475,7 +474,7 @@ -- > estartEnds [val1, 1, type1, val2, 1, type2, ...] estartEnds :: [Double] -> Tab estartEnds = startEnds . insertOnes16-    where +    where         insertOnes16 xs = case xs of             a:b:as  -> a : 1 : b : insertOnes16 as             _       -> xs@@ -486,7 +485,7 @@ -- > bpLins [x1, y1, x2, y2, ..., xN, yN] -- -- csound docs: <http://www.csounds.com/manual/html/GEN27.html>--- +-- -- All x1, x2, .. should belong to the interval [0, 1]. The actual values are rescaled to fit the table size. bpLins :: [Double] -> Tab bpLins xs = preTab def idLinsBreakPoints $ bpRelativeArgs xs@@ -571,9 +570,9 @@  -- | Creates tanh sigmoid. The argument is the radius of teh sigmoid. tanhSigmoid :: Double -> Tab-tanhSigmoid x = esplines (fmap tanh [-x, (-x +0.5) .. x]) +tanhSigmoid x = esplines (fmap tanh [-x, (-x +0.5) .. x]) --- | Generates values similar to the opcode 'Csound.Opcode.Basic.buzz'. +-- | Generates values similar to the opcode 'Csound.Opcode.Basic.buzz'. -- -- > buzzes numberOfHarmonics [lowestHarmonic, coefficientOfAttenuation] --@@ -582,7 +581,7 @@ buzzes :: Double -> [Double] -> Tab buzzes nh opts = plains idBuzzes (nh : take 2 opts) --- | Modified Bessel function of the second kind, order 0 (for amplitude modulated FM). +-- | Modified Bessel function of the second kind, order 0 (for amplitude modulated FM). -- -- > bessels xint --@@ -657,23 +656,23 @@ winSync :: Tab winSync         = wins Sync [1] --- | This creates a function that contains a Gaussian window with a maximum value of 1. --- The extra argument specifies how broad the window is, as the standard deviation of the curve; --- in this example the s.d. is 2. The default value is 1. +-- | This creates a function that contains a Gaussian window with a maximum value of 1.+-- The extra argument specifies how broad the window is, as the standard deviation of the curve;+-- in this example the s.d. is 2. The default value is 1. -- -- > winGauss 2 winGauss :: Double -> Tab winGauss a = wins Gaussian [1, a] --- | This creates a function that contains a Kaiser window with a maximum value of 1. --- The extra argument specifies how "open" the window is, for example a value of 0 results --- in a rectangular window and a value of 10 in a Hamming like window. +-- | This creates a function that contains a Kaiser window with a maximum value of 1.+-- The extra argument specifies how "open" the window is, for example a value of 0 results+-- in a rectangular window and a value of 10 in a Hamming like window. -- -- > winKaiser openness winKaiser :: Double -> Tab winKaiser openness = wins Kaiser [1, openness] -data WinType +data WinType     = Hamming | Hanning | Bartlett | Blackman     | Harris | Gaussian | Kaiser | Rectangle | Sync @@ -695,9 +694,9 @@ -- | Padsynth parameters. -- -- see for details: <http://csound.github.io/docs/manual/GENpadsynth.html>-data PadsynthSpec = PadsynthSpec +data PadsynthSpec = PadsynthSpec     { padsynthFundamental     :: Double-    , padsynthBandwidth       :: Double    +    , padsynthBandwidth       :: Double     , padsynthPartialScale    :: Double     , padsynthHarmonicStretch :: Double     , padsynthShape           :: PadsynthShape@@ -723,10 +722,10 @@  -- | Creates tables for the padsynth algorithm (described at <http://www.paulnasca.com/algorithms-created-by-me>). -- The table size should be very big the default is 18 power of 2.--- +-- -- csound docs: <http://csound.github.io/docs/manual/GENpadsynth.html> padsynth :: PadsynthSpec -> Tab-padsynth (PadsynthSpec fundamentalFreq partialBW partialScale harmonicStretch shape shapeParameter harmonics) = +padsynth (PadsynthSpec fundamentalFreq partialBW partialScale harmonicStretch shape shapeParameter harmonics) =     plainStringTab idPadsynth ([fundamentalFreq, partialBW, partialScale, harmonicStretch, padsynthShapeId shape, shapeParameter] ++ harmonics)                                      -- 261.625565     25.0         1.0             1.0             2.0                 1.0             1.0 0.5 0.0 0.2@@ -745,12 +744,12 @@ gen :: Int -> [Double] -> Tab gen genId args = preTab def genId (ArgsPlain $ return args) --- | Adds guard point to the table size (details of the interpolation schemes: you do need guard point if your intention is to read the --- table once but you don't need the guard point if you read table in many cycles, the guard point is the the first point of your table).  +-- | Adds guard point to the table size (details of the interpolation schemes: you do need guard point if your intention is to read the+-- table once but you don't need the guard point if you read table in many cycles, the guard point is the the first point of your table). guardPoint :: Tab -> Tab guardPoint = updateTabSize $ \x -> case x of     SizePlain n -> SizePlain $ plainGuardPoint n-    a -> a{ hasGuardPoint = True }    +    a -> a{ hasGuardPoint = True }     where plainGuardPoint n             | even n    = n + 1             | otherwise = n@@ -763,17 +762,17 @@ setSize :: Int -> Tab -> Tab setSize n = updateTabSize $ const (SizePlain n) --- | Sets the relative size value. You can set the base value in the options +-- | Sets the relative size value. You can set the base value in the options -- (see 'Csound.Base.tabResolution' at 'Csound.Base.CsdOptions', with tabResolution you can easily change table sizes for all your tables). -- Here zero means the base value. 1 is the base value multiplied by 2, 2 is the base value multiplied by 4--- and so on. Negative values mean division by the specified degree. +-- and so on. Negative values mean division by the specified degree. setDegree :: Int -> Tab -> Tab setDegree degree = updateTabSize $ \x -> case x of     SizePlain n -> SizePlain n     a -> a{ sizeDegree = degree }  -- | Sets degrees from -3 to 3.-lllofi, llofi, lofi, midfi, hifi, hhifi, hhhifi :: Tab -> Tab +lllofi, llofi, lofi, midfi, hifi, hhifi, hhhifi :: Tab -> Tab  lllofi  = setDegree (-3) llofi   = setDegree (-2)@@ -781,12 +780,12 @@ midfi   = setDegree 0 hifi    = setDegree 1 hhifi   = setDegree 2-hhhifi  = setDegree 3 +hhhifi  = setDegree 3  -- | Writes tables in sequential locations. ----- This opcode writes to a table in sequential locations to and from an a-rate --- variable. Some thought is required before using it. It has at least two major, +-- This opcode writes to a table in sequential locations to and from an a-rate+-- variable. Some thought is required before using it. It has at least two major, -- and quite different, applications which are discussed below. -- -- > kstart tablewa kfn, asig, koff@@ -813,7 +812,7 @@ -- -- * maxh -- maxh -- highest harmonic number ----- * ref_sr (optional) -- maxh is scaled by (sr / ref_sr). The default value of ref_sr is sr. If ref_sr is zero or negative, it is now ignored. +-- * ref_sr (optional) -- maxh is scaled by (sr / ref_sr). The default value of ref_sr is sr. If ref_sr is zero or negative, it is now ignored. -- -- * interp (optional) -- if non-zero, allows changing the amplitude of the lowest and highest harmonic partial depending on the fractional part of minh and maxh. For example, if maxh is 11.3 then the 12th harmonic partial is added with 0.3 amplitude. This parameter is zero by default. --@@ -828,7 +827,7 @@ -- mixing tabs GEN31 GEN32  -- | It's just like sines3 but inplace of pure sinewave it uses supplied in the first argument shape.--- +-- -- mixOnTab srcTable [(partialNumber, partialStrength, partialPahse)] -- -- phahse is in range [0, 1]@@ -868,7 +867,7 @@  ---------------------------------------------------- --- | tabseg  -- Writes composite waveforms made up of pre-existing waveforms. +-- | tabseg  -- Writes composite waveforms made up of pre-existing waveforms. -- -- tabseg [(tab, amplitude, duration)] --@@ -878,12 +877,12 @@ -- here we only specify the relative length of segments. Segments are arranged so -- that the start f next segment comes right after the end of the prev segment. tabseg :: [(Tab, PartialStrength, Double)] -> Tab-tabseg xs = hideGE $ do +tabseg xs = hideGE $ do     tabIds <- mapM renderTab tabs     return $ preTab def idLinTab $ mkArgs tabIds     where-        (tabs, amps, durs) = unzip3 xs        -        segments n = fmap (second $ \x -> x - 1) $ tail $ scanl (\(a, b) x -> (b, b + x)) (0, 0) $ mkRelative n durs+        (tabs, amps, durs) = unzip3 xs+        segments n = fmap (second $ \x -> x - 1) $ tail $ scanl (\(_, b) x -> (b, b + x)) (0, 0) $ mkRelative n durs         mkArgs ids = ArgsPlain $ reader $ \size -> concat $ zipWith3 (\tabId amp (start, finish) -> [fromIntegral tabId, amp, start, finish]) ids amps (segments size)  etabseg :: [(Tab, PartialStrength)] -> Tab@@ -959,9 +958,9 @@ -- | Beta (positive numbers only) -- -- > betaDist alpha beta--- --- * @alpha@ -- alpha value. If kalpha is smaller than one, smaller values favor values near 0.  --+-- * @alpha@ -- alpha value. If kalpha is smaller than one, smaller values favor values near 0.+-- -- * @beta@ -- beta value. If kbeta is smaller than one, smaller values favor values near krange. betaDist :: Double -> Double -> Tab betaDist arg1 arg2 = gen21 9 [1, arg1, arg2]@@ -1028,8 +1027,8 @@ -- -- > randDist  [value1, prob1, value2, prob2, value3, prob3 ... valueN, probN] ----- The first number of each pair is a value, and the second is the probability of that value to --- be chosen by a random algorithm. Even if any number can be assigned to the probability element of each pair, +-- The first number of each pair is a value, and the second is the probability of that value to+-- be chosen by a random algorithm. Even if any number can be assigned to the probability element of each pair, -- it is suggested to give it a percent value, in order to make it clearer for the user. -- -- This subroutine is designed to be used together with duserrnd and urd opcodes (see duserrnd for more information).@@ -1039,13 +1038,13 @@  -- | rangeDist — Generates a random distribution of discrete ranges of values (GEN42). ----- The first number of each group is a the minimum value of the --- range, the second is the maximum value and the third is the probability --- of that an element belonging to that range of values can be chosen by --- a random algorithm. Probabilities for a range should be a fraction of 1, +-- The first number of each group is a the minimum value of the+-- range, the second is the maximum value and the third is the probability+-- of that an element belonging to that range of values can be chosen by+-- a random algorithm. Probabilities for a range should be a fraction of 1, -- and the sum of the probabilities for all the ranges should total 1.0. ----- This subroutine is designed to be used together with duserrnd and urd opcodes (see duserrnd for more information). +-- This subroutine is designed to be used together with duserrnd and urd opcodes (see duserrnd for more information). -- Since both duserrnd and urd do not use any interpolation, it is suggested to give a size reasonably big. rangeDist :: [Double] -> Tab rangeDist xs = skipNorm $ gen idRandRanges xs@@ -1071,7 +1070,7 @@ readPvocex filename channel = preTab def idPvocex $ FileAccess filename [fromIntegral channel]  -- | readMultichannel — Creates an interleaved multichannel table from the specified source tables, in the format expected by the ftconv opcode (GEN52).--- +-- -- > f # time size 52 nchannels fsrc1 offset1 srcchnls1 [fsrc2 offset2 srcchnls2 ... fsrcN offsetN srcchnlsN] -- -- csound doc: <http://www.csounds.com/manual/html/GEN52.html>@@ -1084,7 +1083,7 @@  ------------------------------------------------------ --- | Csound's GEN33 — Generate composite waveforms by mixing simple sinusoids.  +-- | Csound's GEN33 — Generate composite waveforms by mixing simple sinusoids. -- -- > tabSines1 srcTab nh scl [fmode] --@@ -1092,7 +1091,7 @@ tabSines1 :: Tab -> Double -> Double -> Maybe Double -> Tab tabSines1 = tabSinesBy idMixSines2 --- | Csound's GEN34 — Generate composite waveforms by mixing simple sinusoids. +-- | Csound's GEN34 — Generate composite waveforms by mixing simple sinusoids. -- -- > tabSines2 srcTab nh scl [fmode] --@@ -1125,9 +1124,9 @@ rescaleWaveletTab = waveletTabBy 1  waveletTabBy :: Int -> Tab -> Int -> Tab-waveletTabBy rescaleFlag srcTab seq = hideGE $ do+waveletTabBy rescaleFlag srcTab sq = hideGE $ do     tabId <- renderTab srcTab-    return $ plainStringTab idWave $ fmap fromIntegral [tabId, seq, 0]+    return $ plainStringTab idWave $ fmap fromIntegral [tabId, sq, rescaleFlag]  ------------------- -- specific tabs@@ -1202,7 +1201,7 @@ -- > fareyTab mode num -- -- num -- the integer n for generating Farey Sequence Fn--- +-- -- mode -- integer to trigger a specific output to be written into the table: -- -- * 0 -- outputs floating point numbers representing the elements of Fn.@@ -1219,15 +1218,15 @@  --------------------------------------------------- --- | --- tablew — Change the contents of existing function tables. +-- |+-- 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. +-- 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]@@ -1239,7 +1238,7 @@     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.@@ -1264,7 +1263,7 @@   --- | +-- | -- 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.@@ -1282,7 +1281,7 @@                                  ,(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.@@ -1300,7 +1299,7 @@                                   ,(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.@@ -1318,11 +1317,11 @@                                   ,(Ir,[Ir,Ir,Ir,Ir,Ir])                                   ,(Kr,[Kr,Ir,Ir,Ir,Ir])] [a1,a2] --- | --- tableikt — Provides k-rate control over table numbers. +-- |+-- 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. +-- 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]@@ -1332,11 +1331,11 @@ 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. +-- |+-- 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. +-- 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]@@ -1347,8 +1346,8 @@     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. +-- |+-- tablexkt — Reads function tables with linear, cubic, or sinc interpolation. -- -- > ares tablexkt xndx, kfn, kwarp, iwsize [, ixmode] [, ixoff] [, iwrap] --@@ -1375,7 +1374,7 @@ cuserrnd b1 b2 b3 = fmap (fromGE . return) $ SE $ (depT =<<) $ lift $ f <$> toGE b1 <*> toGE b2 <*> unTab b3     where f a1 a2 a3 = opcs "cuserrnd" [(Ar,[Kr,Kr,Kr])                                   ,(Ir,[Ir,Ir,Ir])-                                  ,(Kr,[Kr,Kr,Kr])] [a1,a2,a3] +                                  ,(Kr,[Kr,Kr,Kr])] [a1,a2,a3]  -- | duserrnd — Discrete USER-defined-distribution RaNDom generator. --@@ -1392,57 +1391,55 @@ duserrnd b1 = fmap (fromGE . return) $ SE $ (depT =<<) $ lift $ fmap f $ unTab b1     where f a1 = opcs "duserrnd" [(Ar,[Kr])                                   ,(Ir,[Ir])-                                  ,(Kr,[Kr])] [a1] +                                  ,(Kr,[Kr])] [a1]  ---------------------------------------------------------------- -- tab args  bpRelativeArgs :: [Double] -> TabArgs-bpRelativeArgs xs = ArgsPlain $ reader $ \size -> fromRelative size xs+bpRelativeArgs ys = ArgsPlain $ reader $ \size -> fromRelative size ys     where         fromRelative n as = substOdds (makeRelative n $ getOdds as) as          getOdds xs = fmap snd $ filter fst $ zip (cycle [True,False]) xs          substOdds odds xs = zipWith3 go (cycle [True,False]) ((\a -> [a,a]) =<< odds) xs-            where go flag odd x = if flag then odd else x+            where go flag odd' x = if flag then odd' else x          makeRelative size as = fmap ((fromIntegral :: (Int -> Double)) . round . (fromIntegral size * )) as  relativeArgs :: [Double] -> TabArgs relativeArgs xs = ArgsPlain $ reader $ \size -> fromRelative size xs     where-        fromRelative n as = substEvens (mkRelative n $ getEvens as) as          +        fromRelative n as = substEvens (mkRelative n $ getEvens as) as -        getEvens xs = case xs of+        getEvens = \case             [] -> []             _:[] -> []             _:b:as -> b : getEvens as-            -        substEvens evens xs = case (evens, xs) of++        substEvens evens ys = case (evens, ys) of             ([], as) -> as             (_, []) -> []             (e:es, a:_:as) -> a : e : substEvens es as             _ -> error "table argument list should contain even number of elements"-            + relativeArgsGen16 :: [Double] -> TabArgs relativeArgsGen16 xs = ArgsPlain $ reader $ \size -> formRelativeGen16 size xs-    where            -        formRelativeGen16 n as = substGen16 (mkRelative n $ getGen16 as) as-         -          -- special case. subst relatives for Gen16+    where         formRelativeGen16 n as = substGen16 (mkRelative n $ getGen16 as) as -        getGen16 xs = case xs of+        getGen16 = \case             _:durN:_:rest    -> durN : getGen16 rest             _                -> [] -        substGen16 durs xs = case (durs, xs) of +        substGen16 durs ys = case (durs, ys) of             ([], as) -> as             (_, [])  -> []             (d:ds, valN:_:typeN:rest)   -> valN : d : typeN : substGen16 ds rest-            (_, _)   -> xs+            (_, _)   -> ys +mkRelative :: (Functor t, Foldable t, RealFrac b, Integral a) => a -> t b -> t Double mkRelative n as = fmap ((fromIntegral :: (Int -> Double)) . round . (s * )) as     where s = fromIntegral n / sum as