csound-sampler 0.0.9.0 → 0.0.10.0
raw patch · 6 files changed
+365/−372 lines, 6 filesdep ~csound-expressionPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: csound-expression
API changes (from Hackage documentation)
Files
- csound-sampler.cabal +4/−3
- src/Csound/Sam.hs +165/−167
- src/Csound/Sam/Chord.hs +21/−21
- src/Csound/Sam/Core.hs +39/−35
- src/Csound/Sam/Trig.hs +32/−36
- src/Csound/Sam/Ui.hs +104/−110
csound-sampler.cabal view
@@ -1,5 +1,5 @@ name: csound-sampler-version: 0.0.9.0+version: 0.0.10.0 license: BSD3 license-file: LICENSE author: Anton Kholomiov@@ -8,7 +8,7 @@ stability: Experimental category: Music build-type: Simple-cabal-version: >=1.8+cabal-version: >=1.22 synopsis: A musical sampler based on Csound description: A simple sampler based on the library csound-expression. We can define loops and patterns of samples. An intricate pattern of sound is just few strokes away.@@ -25,7 +25,8 @@ library Ghc-Options: -Wall Hs-Source-Dirs: src/- build-depends: base >= 4, base < 5, transformers >= 0.3, csound-expression >= 5.3.2+ build-depends: base >= 4, base < 5, transformers >= 0.3, csound-expression >= 5.3.4+ Default-language: Haskell2010 exposed-modules: Csound.Sam Csound.Sam.Core
src/Csound/Sam.hs view
@@ -1,34 +1,35 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} -- | The sampler {-# Language TypeFamilies, DeriveFunctor, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-} module Csound.Sam (- Sample, Sam, Bpm, runSam,- -- * Lifters- mapBpm, bindSam, bindBpm, liftSam, mapBpm2, bindBpm2, withBpm,- -- * Constructors- sig1, sig2, infSig1, infSig2, fromSig1, fromSig2, ToSam(..), limSam,- -- ** Stereo- wav, wavr, seg, segr, rndWav, rndWavr, rndSeg, rndSegr, ramWav,- -- ** Mono- wav1, wavr1, seg1, segr1, rndWav1, rndWavr1, rndSeg1, rndSegr1, ramWav1,- -- * Reading from RAM- -- ** Stereo- ramLoop, ramRead, segLoop, segRead, relLoop, relRead,- -- ** Mono- ramLoop1, ramRead1, segLoop1, segRead1, relLoop1, relRead1,+ Sample, Sam, Bpm, runSam,+ -- * Lifters+ mapBpm, bindSam, bindBpm, liftSam, mapBpm2, bindBpm2, withBpm,+ -- * Constructors+ sig1, sig2, infSig1, infSig2, fromSig1, fromSig2, ToSam(..), limSam,+ -- ** Stereo+ wav, wavr, seg, segr, rndWav, rndWavr, rndSeg, rndSegr, ramWav,+ -- ** Mono+ wav1, wavr1, seg1, segr1, rndWav1, rndWavr1, rndSeg1, rndSegr1, ramWav1,+ -- * Reading from RAM+ -- ** Stereo+ ramLoop, ramRead, segLoop, segRead, relLoop, relRead,+ -- ** Mono+ ramLoop1, ramRead1, segLoop1, segRead1, relLoop1, relRead1, -- ** Tempo/pitch scaling based on temposcal wavScale, wavScale1, drumScale, drumScale1, harmScale, harmScale1,- -- * Envelopes- linEnv, expEnv, hatEnv, decEnv, riseEnv, edecEnv, eriseEnv,- -- * Arrange- wide, flow, pick, pickBy,- atPan, atPch, atCps, atPanRnd, atVolRnd, atVolGauss,- -- * Loops- rep1, rep, pat1, pat, pat', rndPat, rndPat',- -- * Arpeggio+ -- * Envelopes+ linEnv, expEnv, hatEnv, decEnv, riseEnv, edecEnv, eriseEnv,+ -- * Arrange+ wide, flow, pick, pickBy,+ atPan, atPch, atCps, atPanRnd, atVolRnd, atVolGauss,+ -- * Loops+ rep1, rep, pat1, pat, pat', rndPat, rndPat',+ -- * Arpeggio Chord,- arpUp, arpDown, arpOneOf, arpFreqOf,- arpUp1, arpDown1, arpOneOf1, arpFreqOf1,+ arpUp, arpDown, arpOneOf, arpFreqOf,+ arpUp1, arpDown1, arpOneOf1, arpFreqOf1, -- * Misc patterns wall, forAirports, genForAirports, arpy, @@ -43,10 +44,9 @@ ) where import Control.Monad.Trans.Class-import Control.Applicative import Control.Monad.Trans.Reader -import Csound.Base+import Csound.Base hiding (pitch, tempo, dur) import Csound.Sam.Core import Csound.Sam.Ui import Csound.Sam.Trig@@ -54,77 +54,76 @@ type instance DurOf Sam = Sig instance Melody Sam where- mel = flow+ mel = flow instance Harmony Sam where- (=:=) = (+)+ (=:=) = (+) instance Compose Sam where instance Delay Sam where- del dt = tfmS phi- where phi bpm x = x { samSig = asig, samDur = dur }- where- absDt = toSec bpm dt- asig = delaySnd absDt $ samSig x- dur = addDur absDt $ samDur x+ del dt = tfmS $ \bpm x ->+ let absDt = toSec bpm dt+ asig = delaySnd absDt $ samSig x+ dur = addDur absDt $ samDur x+ in x { samSig = asig, samDur = dur } instance Stretch Sam where- str k (Sam a) = Sam $ withReaderT ( * k) a+ str k (Sam a) = Sam $ withReaderT ( * k) a instance Limit Sam where- lim d = tfmS $ \bpm x ->- let absD = toSec bpm d- in x { samSig = takeSnd absD $ samSig x- , samDur = Dur absD }+ lim d = tfmS $ \bpm x ->+ let absD = toSec bpm d+ in x { samSig = takeSnd absD $ samSig x+ , samDur = Dur absD } instance Loop Sam where- loop = genLoop $ \_ d asig -> repeatSnd d asig+ loop = genLoop $ \_ d asig -> repeatSnd d asig instance Rest Sam where- rest dt = Sam $ reader $ \bpm -> S 0 (Dur $ toSec bpm dt)+ rest dt = Sam $ reader $ \bpm -> S 0 (Dur $ toSec bpm dt) instance At Sig2 Sig2 Sam where- type AtOut Sig2 Sig2 Sam = Sam- at f x = fmap f x+ type AtOut Sig2 Sig2 Sam = Sam+ at f x = fmap f x instance At Sig2 (SE Sig2) Sam where- type AtOut Sig2 (SE Sig2) Sam = Sam- at f x = bindSam f x+ type AtOut Sig2 (SE Sig2) Sam = Sam+ at f x = bindSam f x instance At Sig (SE Sig) Sam where- type AtOut Sig (SE Sig) Sam = Sam- at f x = liftSam $ fmap (at f) x+ type AtOut Sig (SE Sig) Sam = Sam+ at f x = liftSam $ fmap (at f) x instance At Sig Sig2 Sam where- type AtOut Sig Sig2 Sam = Sam- at f x = at phi x- where- phi (a, b) = 0.5 * (f a + f b)+ type AtOut Sig Sig2 Sam = Sam+ at f x = at phi x+ where+ phi (a, b) = 0.5 * (f a + f b) instance At Sig (SE Sig2) Sam where- type AtOut Sig (SE Sig2) Sam = Sam- at f x = at phi x- where- phi (a, b) = do- a' <- f a- b' <- f b- return $ 0.5 * (a' + b')+ type AtOut Sig (SE Sig2) Sam = Sam+ at f x = at phi x+ where+ phi (a, b) = do+ a' <- f a+ b' <- f b+ return $ 0.5 * (a' + b') instance MixAt Sig2 Sig2 Sam where- mixAt k f sam = at (\x -> cfd k x (f x)) sam+ mixAt k f sam = at (\x -> cfd k x (f x)) sam instance MixAt Sig2 (SE Sig2) Sam where- mixAt k f sam = at (\x -> fmap (cfd k x) (f x)) sam+ mixAt k f sam = at (\x -> fmap (cfd k x) (f x)) sam instance MixAt Sig (SE Sig) Sam where- mixAt k f sam = at (\x -> fmap (cfd k x) (f x)) sam+ mixAt k f sam = at (\x -> fmap (cfd k x) (f x)) sam instance MixAt Sig Sig2 Sam where- mixAt k f sam = at (\x -> cfd k (x, x) (f x)) sam+ mixAt k f sam = at (\x -> cfd k (x, x) (f x)) sam instance MixAt Sig (SE Sig2) Sam where- mixAt k f sam = at (\x -> fmap (cfd k (x, x)) (f x)) sam+ mixAt k f sam = at (\x -> fmap (cfd k (x, x)) (f x)) sam -- | Constructs sample from mono signal infSig1 :: Sig -> Sam@@ -157,19 +156,19 @@ -- | Constructs sample from wav that is played in reverse. wavr :: String -> Sam wavr fileName = Sam $ return $ S (takeSnd (sig len) $ loopWav (-1) fileName) (Dur $ sig len)- where len = lengthSnd fileName+ where len = lengthSnd fileName -- | Constructs sample from the segment of a wav file. The start and end times are measured in seconds. -- -- > seg begin end fileName seg :: D -> D -> String -> Sam seg start end fileName = Sam $ return $ S (readSegWav start end 1 fileName) (Dur $ sig len)- where len = end - start+ where len = end - start --- | Constructs reversed sample from segment of an audio file. segr :: D -> D -> String -> Sam segr start end fileName = Sam $ return $ S (readSegWav start end (-1) fileName) (Dur $ sig len)- where len = end - start+ where len = end - start -- | Picks segments from the wav file at random. The first argument is the length of the segment. rndWav :: D -> String -> Sam@@ -189,11 +188,11 @@ genRndSeg :: Sig -> D -> D -> D -> String -> Sam genRndSeg speed len start end fileName = Sam $ lift $ do- x <- random 0 1- let a = start + dl * x- let b = a + len- return $ S (readSegWav a b speed fileName) (Dur $ sig len)- where dl = end - len+ x <- random 0 1+ let a = start + dl * x+ let b = a + len+ return $ S (readSegWav a b speed fileName) (Dur $ sig len)+ where dl = end - len -- | Reads a sample from the file in RAM. --@@ -214,19 +213,19 @@ -- | Constructs sample from mono wav that is played in reverse. wavr1 :: String -> Sam wavr1 fileName = Sam $ return $ S (let x = takeSnd (sig len) $ loopWav1 (-1) fileName in (x, x)) (Dur $ sig len)- where len = lengthSnd fileName+ where len = lengthSnd fileName -- | Constructs sample from the segment of a mono wav file. The start and end times are measured in seconds. -- -- > seg begin end fileName seg1 :: D -> D -> String -> Sam seg1 start end fileName = Sam $ return $ S (let x = readSegWav1 start end 1 fileName in (x, x)) (Dur $ sig len)- where len = end - start+ where len = end - start --- | Constructs reversed sample from segment of a mono audio file. segr1 :: D -> D -> String -> Sam segr1 start end fileName = Sam $ return $ S (let x = readSegWav1 start end (-1) fileName in (x, x)) (Dur $ sig len)- where len = end - start+ where len = end - start -- | Picks segments from the mono wav file at random. The first argument is the length of the segment. rndWav1 :: D -> String -> Sam@@ -246,11 +245,11 @@ genRndSeg1 :: Sig -> D -> D -> D -> String -> Sam genRndSeg1 speed len start end fileName = Sam $ lift $ do- x <- random 0 1- let a = start + dl * x- let b = a + len- return $ S (let y = readSegWav1 a b speed fileName in (y, y)) (Dur $ sig len)- where dl = end - len+ x <- random 0 1+ let a = start + dl * x+ let b = a + len+ return $ S (let y = readSegWav1 a b speed fileName in (y, y)) (Dur $ sig len)+ where dl = end - len toSec :: Bpm -> Sig -> Sig@@ -261,8 +260,8 @@ addDur :: Sig -> Dur -> Dur addDur d x = case x of- Dur a -> Dur $ d + a- InfDur -> InfDur+ Dur a -> Dur $ d + a+ InfDur -> InfDur -- | Scales sample by pitch in tones. atPch :: Sig -> Sam -> Sam@@ -281,9 +280,9 @@ tfmS :: (Bpm -> S Sig2 -> S Sig2) -> Sam -> Sam tfmS f ra = Sam $ do- bpm <- ask- a <- unSam ra- return $ f bpm a+ bpm <- ask+ a <- unSam ra+ return $ f bpm a setInfDur :: Sam -> Sam setInfDur = Sam . fmap (\a -> a { samDur = InfDur }) . unSam@@ -301,28 +300,28 @@ flow2 :: Sam -> Sam -> Sam flow2 (Sam ra) (Sam rb) = Sam $ do- a <- ra- b <- rb- let sa = samSig a- let sb = samSig b- return $ case (samDur a, samDur b) of- (Dur da, Dur db) -> S (sa + delaySnd da sb) (Dur $ da + db)- (InfDur, _) -> a- (Dur da, InfDur) -> S (sa + delaySnd da sb) InfDur+ a <- ra+ b <- rb+ let sa = samSig a+ let sb = samSig b+ return $ case (samDur a, samDur b) of+ (Dur da, Dur db) -> S (sa + delaySnd da sb) (Dur $ da + db)+ (InfDur, _) -> a+ (Dur da, InfDur) -> S (sa + delaySnd da sb) InfDur type PickFun = [(D, D)] -> Evt Unit -> Evt (D, D) genPick :: PickFun -> Sig -> [Sam] -> Sam-genPick pickFun dt as = Sam $ do- bpm <- ask- xs <- sequence $ fmap unSam as- let ds = fmap (ir . getDur . samDur) xs- let sigs = fmap samSig xs- return $ S (sched (\n -> return $ atTuple sigs $ sig n) $ fmap (\(dt, a) -> str (sig dt) $ temp a) $ pickFun (zip ds (fmap int [0..])) $ metroS bpm dt) InfDur- where- getDur x = case x of- InfDur -> -1- Dur d -> d+genPick pickFun dtSig as = Sam $ do+ bpm <- ask+ xs <- sequence $ fmap unSam as+ let ds = fmap (ir . getDur . samDur) xs+ let sigs = fmap samSig xs+ return $ S (sched (\n -> return $ atTuple sigs $ sig n) $ fmap (\(dt, a) -> str (sig dt) $ temp a) $ pickFun (zip ds (fmap int [0..])) $ metroS bpm dtSig) InfDur+ where+ getDur x = case x of+ InfDur -> -1+ Dur d -> d -- | Picks samples at random. The first argument is the period ofmetronome in BPMs. -- The tick of metronome produces new random sample from the list.@@ -337,38 +336,36 @@ type EnvFun = (Dur -> D -> D -> Sig) genEnv :: EnvFun -> D -> D -> Sam -> Sam-genEnv env start end = tfmS f- where f bpm a = a { samSig = mul (env (samDur a) absStart absEnd) $ samSig a }- where- absStart = toSecD bpm start- absEnd = toSecD bpm end+genEnv env start end = tfmS $ \bpm a ->+ let absStart = toSecD bpm start+ absEnd = toSecD bpm end+ in a { samSig = mul (env (samDur a) absStart absEnd) $ samSig a } -- | A linear rise-decay envelope. Times a given in BPMs. -- -- > linEnv rise dec sample linEnv :: D -> D -> Sam -> Sam-linEnv = genEnv f- where f dur start end = case dur of- InfDur -> linseg [0, start, 1]- Dur d -> linseg [0, start, 1, maxB 0 (ir d - start - end), 1, end , 0]+linEnv = genEnv $ \dur start end -> case dur of+ InfDur -> linseg [0, start, 1]+ Dur d -> linseg [0, start, 1, maxB 0 (ir d - start - end), 1, end , 0] -- | An exponential rise-decay envelope. Times a given in BPMs. -- -- > expEnv rise dec sample expEnv :: D -> D -> Sam -> Sam expEnv = genEnv f- where- f dur start end = case dur of- InfDur -> expseg [zero, start, 1]- Dur d -> expseg [zero, start, 1, maxB 0 (ir d - start - end), 1, end , zero]- zero = 0.00001+ where+ f dur start end = case dur of+ InfDur -> expseg [zero, start, 1]+ Dur d -> expseg [zero, start, 1, maxB 0 (ir d - start - end), 1, end , zero]+ zero = 0.00001 genEnv1 :: (D -> Sig) -> Sam -> Sam genEnv1 envFun = tfmBy f- where- f a = flip mul (samSig a) $ case samDur a of- InfDur -> 1- Dur d -> envFun (ir d)+ where+ f a = flip mul (samSig a) $ case samDur a of+ InfDur -> 1+ Dur d -> envFun (ir d) -- | Parabolic envelope that starts and ends at zero and reaches maximum at the center.@@ -395,11 +392,11 @@ genLoop :: LoopFun -> Sam -> Sam genLoop g = setInfDur . tfmS f- where- f bpm a = a { samSig = case samDur a of- InfDur -> samSig a- Dur d -> g bpm d (samSig a)- }+ where+ f bpm a = a { samSig = case samDur a of+ InfDur -> samSig a+ Dur d -> g bpm d (samSig a)+ } -- | Plays the sample at the given period (in BPMs). The samples don't overlap.@@ -412,40 +409,41 @@ -- | Plays the sample at the given pattern of periods (in BPMs). The samples don't overlap. rep :: [Sig] -> Sam -> Sam-rep dts = genLoop $ \bpm d asig -> sched (const $ return asig) $ fmap (const $ notes bpm) $ metroS bpm (sum dts)- where notes bpm = har $ zipWith (\t dt-> singleEvent (toSec bpm t) (toSec bpm dt) unit) (patDurs dts) dts+rep dts = genLoop $ \bpm _d asig -> sched (const $ return asig) $ fmap (const $ notes bpm) $ metroS bpm (sum dts)+ where notes bpm = har $ zipWith (\t dt-> singleEvent (toSec bpm t) (toSec bpm dt) unit) (patDurs dts) dts -- | Plays the sample at the given pattern of periods (in BPMs). The overlapped samples are mixed together. pat :: [Sig] -> Sam -> Sam pat dts = genLoop $ \bpm d asig -> sched (const $ return asig) $ fmap (const $ notes bpm d) $ metroS bpm (sum dts)- where notes bpm d = har $ fmap (\t -> fromEvent $ Event (toSec bpm t) d unit) $ patDurs dts+ where notes bpm d = har $ fmap (\t -> fromEvent $ Event (toSec bpm t) d unit) $ patDurs dts -- | Plays the sample at the given pattern of periods (in BPMs) and sometimes skips the samples from playback. The overlapped samples are mixed together. -- The first argument is the probability of inclusion. rndPat :: Sig -> [Sig] -> Sam -> Sam rndPat prob dts = genLoop $ \bpm d asig -> sched (const $ rndSkipInstr prob asig) $ fmap (const $ notes bpm d) $ metroS bpm (sum dts)- where- notes bpm d = har $ fmap (\t -> fromEvent $ Event (toSec bpm t) d unit) $ patDurs dts+ where+ notes bpm d = har $ fmap (\t -> fromEvent $ Event (toSec bpm t) d unit) $ patDurs dts -- | Plays the sample at the given pattern of volumes and periods (in BPMs). The overlapped samples are mixed together. -- -- > pat' volumes periods pat' :: [D] -> [Sig] -> Sam -> Sam pat' vols dts = genLoop $ \bpm d asig -> sched (instr asig) $ fmap (const $ notes bpm d) $ metroS bpm (sum dts')- where- notes bpm d = har $ zipWith (\v t -> singleEvent (toSec bpm t) d v) vols' $ patDurs dts'- instr asig v = return $ mul (sig v) asig- (vols', dts') = unzip $ lcmList vols dts+ where+ notes bpm d = har $ zipWith (\v t -> singleEvent (toSec bpm t) d v) vols' $ patDurs dts'+ instr asig v = return $ mul (sig v) asig+ (vols', dts') = unzip $ lcmList vols dts +rndSkipInstr :: (Tuple a, Num a) => Sig -> a -> SE a rndSkipInstr probSig asig = do- let prob = ir probSig- ref <- newRef 0- p <- random 0 (1 :: D)- whenD1 (p `lessThan` prob) $- writeRef ref asig- whenD1 (p `greaterThanEquals` prob) $- writeRef ref 0- readRef ref+ let prob = ir probSig+ ref <- newRef 0+ p <- random 0 (1 :: D)+ whenD1 (p `lessThan` prob) $+ writeRef ref asig+ whenD1 (p `greaterThanEquals` prob) $+ writeRef ref 0+ readRef ref -- | Plays the sample at the given pattern of volumes and periods (in BPMs) and sometimes skips the samples from playback. The overlapped samples are mixed together. -- The first argument is the probability of inclusion.@@ -453,15 +451,15 @@ -- > rndPat' probability volumes periods rndPat' :: Sig -> [D] -> [Sig] -> Sam -> Sam rndPat' prob vols dts = genLoop $ \bpm d asig -> sched (instr asig) $ fmap (const $ notes bpm d) $ metroS bpm (sum dts')- where- notes bpm d = har $ zipWith (\v t -> singleEvent (toSec bpm t) d v) vols' $ patDurs dts'- instr asig v = mul (sig v) $ rndSkipInstr prob asig- (vols', dts') = unzip $ lcmList vols dts+ where+ notes bpm d = har $ zipWith (\v t -> singleEvent (toSec bpm t) d v) vols' $ patDurs dts'+ instr asig v = mul (sig v) $ rndSkipInstr prob asig+ (vols', dts') = unzip $ lcmList vols dts lcmList :: [a] -> [b] -> [(a, b)] lcmList as bs = take n $ zip (cycle as) (cycle bs)- where n = lcm (length as) (length bs)+ where n = lcm (length as) (length bs) -- | Constructs the wall of sound from the initial segment of the sample. -- The segment length is given in BPMs.@@ -469,10 +467,10 @@ -- > wall segLength wall :: Sig -> Sam -> Sam wall dt a = mean [b, del hdt b]- where- hdt = 0.5 * dt- f = pat1 hdt . hatEnv . lim dt- b = f a+ where+ hdt = 0.5 * dt+ f = pat1 hdt . hatEnv . lim dt+ b = f a -- | The tones of the chord. type Chord = [D]@@ -487,7 +485,7 @@ genArp1 :: Arp1Fun -> Sig -> Sam -> Sam genArp1 arpFun dt = genLoop $ \bpm d asig ->- sched (arpInstr asig) $ withDur d $ arpFun $ metroS bpm dt+ sched (arpInstr asig) $ withDur d $ arpFun $ metroS bpm dt -- | Plays ascending arpeggio of samples. arpUp1 :: Chord -> Sig -> Sam -> Sam@@ -508,7 +506,7 @@ genArp :: Arp1Fun -> [Sig] -> Sam -> Sam genArp arpFun dts = genLoop $ \bpm d asig -> sched (arpInstr asig) $ fmap (notes bpm d) $ arpFun $ metroS bpm (sum dts)- where notes bpm d pchScale = har $ fmap (\t -> singleEvent (toSec bpm t) d pchScale) $ patDurs dts+ where notes bpm d pchScale = har $ fmap (\t -> singleEvent (toSec bpm t) d pchScale) $ patDurs dts -- | Plays ascending arpeggio of samples. arpUp :: Chord -> [Sig] -> Sam -> Sam@@ -528,7 +526,7 @@ arpFreqOf freqs ch = genArp (freqOf $ zip freqs ch) metroS :: Bpm -> Sig -> Evt Unit-metroS bpm dt = metroE (recip $ toSec bpm dt)+metroS bpm dt = metro (recip $ toSec bpm dt) -- | The pattern is influenced by the Brian Eno's work "Music fo Airports". -- The argument is list of tripples:@@ -553,7 +551,7 @@ arp1 :: (SigSpace a, Sigs a) => (D -> SE a) -> Sig -> Sig -> Int -> [D] -> a arp1 instr bpm dt n ch = sched (\(amp, cps) -> fmap (mul (sig amp)) $ instr cps) $- withDur (toSec bpm dt) $ cycleE (lcmList (1 : replicate (n - 1) 0.7) ch) $ metroS bpm dt+ withDur (toSec bpm dt) $ cycleE (lcmList (1 : replicate (n - 1) 0.7) ch) $ metroS bpm dt -- | The arpeggiator for the sequence of chords. --@@ -568,9 +566,9 @@ -- the list of frequencies. arpy :: (D -> SE Sig2) -> Sig -> Sig -> Int -> [[D]] -> Sam arpy instr chordPeriod speed accentNum chords = Sam $ do- bpm <- ask- res <- unSam $ loop $ flow $ map (linEnv 0.05 0.05 . fromSig2 chordPeriod . arp1 instr bpm speed accentNum) chords- return $ S (samSig res) InfDur+ bpm <- ask+ res <- unSam $ loop $ flow $ map (linEnv 0.05 0.05 . fromSig2 chordPeriod . arp1 instr bpm speed accentNum) chords+ return $ S (samSig res) InfDur -- | Applies random panning to every sample playback. atPanRnd :: Sam -> Sam@@ -585,26 +583,26 @@ atVolRnd k = bindSam (rndVol k) class ToSam a where- toSam :: a -> Sam+ toSam :: a -> Sam limSam :: ToSam a => Sig -> a -> Sam limSam dt = lim dt . toSam instance ToSam Sig where- toSam x = Sam $ return $ S (x, x) InfDur+ toSam x = Sam $ return $ S (x, x) InfDur instance ToSam Sig2 where- toSam x = Sam $ return $ S x InfDur+ toSam x = Sam $ return $ S x InfDur instance ToSam (SE Sig) where- toSam x = Sam $ do- y <- lift x- return $ S (y, y) InfDur+ toSam x = Sam $ do+ y <- lift x+ return $ S (y, y) InfDur instance ToSam (SE Sig2) where- toSam x = Sam $ do- y <- lift x- return $ S y InfDur+ toSam x = Sam $ do+ y <- lift x+ return $ S y InfDur --------------------------------------------------------------- --- reading from RAM
src/Csound/Sam/Chord.hs view
@@ -1,9 +1,9 @@ -- | Shortcuts for common chords. module Csound.Sam.Chord (- chTrans, chRot, - chMin, chMaj, chLead, - chMaj7, chMin7, ch7, chLead7, - atMaj, atMin, atMaj7, atMin7 + chTrans, chRot,+ chMin, chMaj, chLead,+ chMaj7, chMin7, ch7, chLead7,+ atMaj, atMin, atMaj7, atMin7 ) where import Csound.Base(int, D)@@ -43,16 +43,16 @@ -- | Rotates the chord. chRot :: Int -> Chord -> Chord chRot m- | m == 0 = id- | m < 0 = rotPos m- | otherwise = rotNeg (abs m)- where - rotPos 1 xs = tail xs ++ [head xs + 12]- rotPos n xs = rotPos (n - 1) (rotPos 1 xs)+ | m == 0 = id+ | m < 0 = rotPos m+ | otherwise = rotNeg (abs m)+ where+ rotPos 1 xs = tail xs ++ [head xs + 12]+ rotPos n xs = rotPos (n - 1) (rotPos 1 xs) - rotNeg 1 xs = (last xs - 12) : init xs- rotNeg n xs = rotNeg (n - 1) (rotNeg 1 xs)- + rotNeg 1 xs = (last xs - 12) : init xs+ rotNeg n xs = rotNeg (n - 1) (rotNeg 1 xs)+ toneMsg :: a toneMsg = error $ "Tone number should belong to interval (0, 6)" @@ -70,22 +70,22 @@ -- | Chord in major scale at the given note (if there are seven notes) atMaj :: Int -> Chord atMaj n = chTrans (int $ 12 * oct + inMaj tone) $ toneMap tone chMaj chMin chMin chMaj chMaj chMin chLead- where (oct, tone) = octTone n+ where (oct, tone) = octTone n -- | Chord in minor scale at the given note (if there are seven notes) atMin :: Int -> Chord atMin n = chTrans (int $ 12 * oct + inMin tone) $ toneMap tone chMin chLead chMaj chMin chMin chMaj chMaj- where (oct, tone) = octTone n+ where (oct, tone) = octTone n -- | Seventh chord in major scale at the given note (if there are seven notes) atMaj7 :: Int -> Chord atMaj7 n = chTrans (int $ 12 * oct + inMaj tone) $ toneMap tone chMaj7 chMin7 chMin7 chMaj7 ch7 chMin7 chLead7- where (oct, tone) = octTone n+ where (oct, tone) = octTone n -- | Seventh chord in minor scale at the given note (if there are seven notes) atMin7 :: Int -> Chord atMin7 n = chTrans (int $ 12 * oct + inMin tone) $ toneMap tone chMin7 chLead7 chMaj7 chMin7 chMin7 chMaj7 ch7- where (oct, tone) = octTone n+ where (oct, tone) = octTone n inMaj :: Int -> Int inMaj x = toneMap x 0 2 4 5 7 9 11@@ -94,8 +94,8 @@ inMin x = toneMap x 0 2 3 5 7 9 10 octTone :: Int -> (Int, Int)-octTone n - | n < 0 = (oct - 1, tone + 7)- | otherwise = (oct, tone)- where (oct, tone) = quotRem n 7+octTone n+ | n < 0 = (oct - 1, tone + 7)+ | otherwise = (oct, tone)+ where (oct, tone) = quotRem n 7
src/Csound/Sam/Core.hs view
@@ -1,8 +1,8 @@ -- | The core types/ They are not imported by default. {-# Language DeriveFunctor, TypeSynonymInstances, FlexibleInstances #-} module Csound.Sam.Core (- Sam, runSam, Sample(..), S(..), Dur(..), Bpm,- liftSam, mapBpm, mapBpm2, bindSam, bindBpm, bindBpm2, withBpm+ Sam, runSam, Sample(..), S(..), Dur(..), Bpm,+ liftSam, mapBpm, mapBpm2, bindSam, bindBpm, bindBpm2, withBpm ) where import Control.Applicative@@ -16,17 +16,21 @@ instance RenderCsd Sam where renderCsdBy opt sample = renderCsdBy opt (runSam (getBpm * 4) sample)+ csdArity _ = CsdArity 0 2 instance RenderCsd (Source Sam) where- renderCsdBy opt sample = renderCsdBy opt (lift1 (runSam (getBpm * 4)) sample)+ renderCsdBy opt sample = renderCsdBy opt (lift1 (runSam (getBpm * 4)) sample)+ csdArity _ = CsdArity 0 2 instance RenderCsd (SE Sam) where renderCsdBy opt sample = renderCsdBy opt (runSam (getBpm * 4) =<< sample)+ csdArity _ = CsdArity 0 2 instance RenderCsd (SE (Source Sam)) where renderCsdBy opt sample = renderCsdBy opt $ do- sample' <- sample- lift1 (runSam (getBpm * 4)) sample'+ sample' <- sample+ lift1 (runSam (getBpm * 4)) sample'+ csdArity _ = CsdArity 0 2 runSam :: Bpm -> Sam -> SE Sig2 runSam bpm x = fmap samSig $ runReaderT (unSam x) bpm@@ -38,64 +42,64 @@ -- | The generic type for samples. newtype Sample a = Sam { unSam :: ReaderT Bpm SE (S a)- } deriving (Functor)+ } deriving (Functor) instance Applicative Sample where- pure = Sam . pure . pure- (Sam rf) <*> (Sam ra) = Sam $ liftA2 (<*>) rf ra+ pure = Sam . pure . pure+ (Sam rf) <*> (Sam ra) = Sam $ liftA2 (<*>) rf ra data S a = S- { samSig :: a- , samDur :: Dur- } deriving (Functor)+ { samSig :: a+ , samDur :: Dur+ } deriving (Functor) instance Applicative S where- pure a = S a InfDur- (S f df) <*> (S a da) = S (f a) $ case (df, da) of- (Dur durF, Dur durA) -> Dur $ maxB durF durA- _ -> InfDur+ pure a = S a InfDur+ (S f df) <*> (S a da) = S (f a) $ case (df, da) of+ (Dur durF, Dur durA) -> Dur $ maxB durF durA+ _ -> InfDur instance Num a => Num (Sample a) where- (+) = liftA2 (+)- (*) = liftA2 (*)- (-) = liftA2 (-)- negate = fmap negate- abs = fmap abs- signum = fmap signum- fromInteger = pure . fromInteger+ (+) = liftA2 (+)+ (*) = liftA2 (*)+ (-) = liftA2 (-)+ negate = fmap negate+ abs = fmap abs+ signum = fmap signum+ fromInteger = pure . fromInteger instance Fractional a => Fractional (Sample a) where- recip = fmap recip- fromRational = pure . fromRational+ recip = fmap recip+ fromRational = pure . fromRational instance SigSpace a => SigSpace (Sample a) where- mapSig f = fmap (mapSig f)+ mapSig f = fmap (mapSig f) instance SigSpace2 a => SigSpace2 (Sample a) where- mapSig2 f = fmap (mapSig2 f)+ mapSig2 f = fmap (mapSig2 f) instance BindSig2 a => BindSig2 (Sample a) where- bindSig2 f = return . bindSam (bindSig2 f)+ bindSig2 f = return . bindSam (bindSig2 f) -- Lifters -- | Hides the effects inside sample. liftSam :: Sample (SE a) -> Sample a liftSam (Sam ra) = Sam $ do- a <- ra- lift $ fmap (\x -> a{ samSig = x}) $ samSig a+ a <- ra+ lift $ fmap (\x -> a{ samSig = x}) $ samSig a -- | Transforms the sample with BPM. mapBpm :: (Bpm -> a -> b) -> Sample a -> Sample b mapBpm f a = Sam $ do- bpm <- ask- unSam $ fmap (f bpm) a+ bpm <- ask+ unSam $ fmap (f bpm) a -- | Transforms the sample with BPM. mapBpm2 :: (Bpm -> a -> b -> c) -> Sample a -> Sample b -> Sample c mapBpm2 f a b = Sam $ do- bpm <- ask- unSam $ liftA2 (f bpm) a b+ bpm <- ask+ unSam $ liftA2 (f bpm) a b -- | Lifts bind on stereo signals to samples. bindSam :: (a -> SE b) -> Sample a -> Sample b@@ -112,5 +116,5 @@ withBpm :: (Bpm -> Sample a) -> Sample a withBpm x = Sam $ do- bpm <- ask- unSam $ x bpm+ bpm <- ask+ unSam $ x bpm
src/Csound/Sam/Trig.hs view
@@ -1,21 +1,17 @@ module Csound.Sam.Trig (- -- * Char sampler- samCharTrig, samCharTap, samCharPush, samCharToggle, samCharGroup, samCharCycle,+ -- * Char sampler+ samCharTrig, samCharTap, samCharPush, samCharToggle, samCharGroup, samCharCycle, - -- ** Synchronized with number of beats- samSyncCharTrig, samSyncCharPush, samSyncCharToggle, samSyncCharTap, samSyncCharGroup, samSyncCharCycle,+ -- ** Synchronized with number of beats+ samSyncCharTrig, samSyncCharPush, samSyncCharToggle, samSyncCharTap, samSyncCharGroup, samSyncCharCycle, - -- * Midi sampler- samMidiTrig, samMidiTap, samMidiPush, samMidiToggle, samMidiGroup,+ -- * Midi sampler+ samMidiTrig, samMidiTap, samMidiPush, samMidiToggle, samMidiGroup, - -- ** Generic functions- samMidiTrigBy, samMidiTapBy, samMidiPushBy, samMidiToggleBy, samMidiGroupBy,+ -- ** Generic functions+ samMidiTrigBy, samMidiTapBy, samMidiPushBy, samMidiToggleBy, samMidiGroupBy, ) where -import Data.Foldable(Foldable(foldMap))-import Data.Traversable hiding (mapM)-import Control.Arrow(first, second)- import Csound.Base import qualified Csound.Sam.Core as S import Csound.Sam.Core(Sam, bindSam, mapBpm, mapBpm2)@@ -26,20 +22,20 @@ -- and stops the sample with any char from the second string. samCharTrig :: Maybe Sam -> String -> String -> Sam -> Sam samCharTrig initVal starts stops x = case initVal of- Nothing -> fmap (charTrig Nothing starts stops) x- Just v0 -> liftA2 (\v sigs -> charTrig (Just v) starts stops sigs) v0 x+ Nothing -> fmap (charTrig Nothing starts stops) x+ Just v0 -> liftA2 (\v sigs -> charTrig (Just v) starts stops sigs) v0 x -- | Plays a sample while the key is pressed. samCharPush :: Maybe Sam -> Char -> Sam -> Sam samCharPush initVal ch x = case initVal of- Nothing -> fmap (charPush Nothing ch) x- Just v0 -> liftA2 (\v sigs -> charPush (Just v) ch sigs) v0 x+ Nothing -> fmap (charPush Nothing ch) x+ Just v0 -> liftA2 (\v sigs -> charPush (Just v) ch sigs) v0 x -- | Toggles the sample when the key is pressed. samCharToggle :: Maybe Sam -> Char -> Sam -> Sam samCharToggle initVal ch x = case initVal of- Nothing -> fmap (charToggle Nothing ch) x- Just v0 -> liftA2 (\v sigs -> charToggle (Just v) ch sigs) v0 x+ Nothing -> fmap (charToggle Nothing ch) x+ Just v0 -> liftA2 (\v sigs -> charToggle (Just v) ch sigs) v0 x -- | Char trigger with fixed note limiting by length in second. -- It's useful optimization. It's good to use for drum notes and short sounds.@@ -50,16 +46,16 @@ -- The last string is for stopping the samples. samCharGroup :: Maybe Sam -> [(Char, Sam)] -> String -> Sam samCharGroup initVal as stop = case initVal of- Nothing -> fmap (\xs -> charGroup Nothing (zip starts xs) stop) (sequenceA sams)- Just v0 -> liftA2 (\v xs -> charGroup (Just v) (zip starts xs) stop) v0 (sequenceA sams)- where (starts, sams) = unzip as+ Nothing -> fmap (\xs -> charGroup Nothing (zip starts xs) stop) (sequenceA sams)+ Just v0 -> liftA2 (\v xs -> charGroup (Just v) (zip starts xs) stop) v0 (sequenceA sams)+ where (starts, sams) = unzip as -- | Plays samples in sequence when key is pressed. The last string is -- for stopping the sequence. samCharCycle :: Maybe Sam -> Char -> String -> [Sam] -> Sam samCharCycle initVal start stop as = case initVal of- Nothing -> fmap (charCycle Nothing start stop) (sequenceA as)- Just v0 -> liftA2 (\v xs -> charCycle (Just v) start stop xs) v0 (sequenceA as)+ Nothing -> fmap (charCycle Nothing start stop) (sequenceA as)+ Just v0 -> liftA2 (\v xs -> charCycle (Just v) start stop xs) v0 (sequenceA as) ------------------------------------------------------@@ -73,22 +69,22 @@ -- The first argument is the number of beats for syncronization. samSyncCharTrig :: Sig -> Maybe Sam -> String -> String -> Sam -> Sam samSyncCharTrig beats initVal starts stops x = case initVal of- Nothing -> mapBpm (\bpm a -> syncCharTrig (syncBeats bpm beats) Nothing starts stops a) x- Just v0 -> mapBpm2 (\bpm v sigs -> syncCharTrig (syncBeats bpm beats) (Just v) starts stops sigs) v0 x+ Nothing -> mapBpm (\bpm a -> syncCharTrig (syncBeats bpm beats) Nothing starts stops a) x+ Just v0 -> mapBpm2 (\bpm v sigs -> syncCharTrig (syncBeats bpm beats) (Just v) starts stops sigs) v0 x -- | Plays a sample while the key is pressed. -- The first argument is the number of beats for syncronization. samSyncCharPush :: Sig -> Maybe Sam -> Char -> Sam -> Sam samSyncCharPush beats initVal ch x = case initVal of- Nothing -> mapBpm (\bpm a -> syncCharPush (syncBeats bpm beats) Nothing ch a) x- Just v0 -> mapBpm2 (\bpm v sigs -> syncCharPush (syncBeats bpm beats) (Just v) ch sigs) v0 x+ Nothing -> mapBpm (\bpm a -> syncCharPush (syncBeats bpm beats) Nothing ch a) x+ Just v0 -> mapBpm2 (\bpm v sigs -> syncCharPush (syncBeats bpm beats) (Just v) ch sigs) v0 x -- | Toggles the sample when the key is pressed. -- The first argument is the number of beats for syncronization. samSyncCharToggle :: Sig -> Maybe Sam -> Char -> Sam -> Sam samSyncCharToggle beats initVal ch x = case initVal of- Nothing -> mapBpm (\bpm a -> syncCharToggle (syncBeats bpm beats) Nothing ch a) x- Just v0 -> mapBpm2 (\bpm v sigs -> syncCharToggle (syncBeats bpm beats) (Just v) ch sigs) v0 x+ Nothing -> mapBpm (\bpm a -> syncCharToggle (syncBeats bpm beats) Nothing ch a) x+ Just v0 -> mapBpm2 (\bpm v sigs -> syncCharToggle (syncBeats bpm beats) (Just v) ch sigs) v0 x -- | Char trigger with fixed note limiting by length in second. -- It's useful optimization. It's good to use for drum notes and short sounds.@@ -100,17 +96,17 @@ -- The last string is for stopping the samples. samSyncCharGroup :: Sig -> Maybe Sam -> [(Char, Sam)] -> String -> Sam samSyncCharGroup beats initVal as stop = case initVal of- Nothing -> mapBpm (\bpm xs -> syncCharGroup (syncBeats bpm beats) Nothing (zip starts xs) stop) (sequenceA sams)- Just v0 -> mapBpm2 (\bpm v xs -> syncCharGroup (syncBeats bpm beats) (Just v) (zip starts xs) stop) v0 (sequenceA sams)- where (starts, sams) = unzip as+ Nothing -> mapBpm (\bpm xs -> syncCharGroup (syncBeats bpm beats) Nothing (zip starts xs) stop) (sequenceA sams)+ Just v0 -> mapBpm2 (\bpm v xs -> syncCharGroup (syncBeats bpm beats) (Just v) (zip starts xs) stop) v0 (sequenceA sams)+ where (starts, sams) = unzip as -- | Plays samples in sequence when key is pressed. The last string is -- for stopping the sequence. -- The first argument is the number of beats for syncronization. samSyncCharCycle :: Sig -> Maybe Sam -> Char -> String -> [Sam] -> Sam samSyncCharCycle beats initVal start stop as = case initVal of- Nothing -> mapBpm (\bpm -> syncCharCycle (syncBeats bpm beats) Nothing start stop) (sequenceA as)- Just v0 -> mapBpm2 (\bpm v xs -> syncCharCycle (syncBeats bpm beats) (Just v) start stop xs) v0 (sequenceA as)+ Nothing -> mapBpm (\bpm -> syncCharCycle (syncBeats bpm beats) Nothing start stop) (sequenceA as)+ Just v0 -> mapBpm2 (\bpm v xs -> syncCharCycle (syncBeats bpm beats) (Just v) start stop xs) v0 (sequenceA as) ------------------------------------------------------ @@ -137,7 +133,7 @@ -- The key is an integer midi code. The C1 is 60 and the A1 is 69. samMidiGroup :: MidiChn -> [(Int, Sam)] -> Sam samMidiGroup midiChn as = S.liftSam $ fmap (\xs -> midiGroup midiChn $ zip keys xs) $ sequenceA sams- where (keys, sams) = unzip as+ where (keys, sams) = unzip as -- | Generic samMidiTrig. We can specify the midi triggering function. -- The midi function takes in a signal and a volume of the pressed key (it ranges from 0 to 1).@@ -168,4 +164,4 @@ -- It produces some output. The default is scaling the signal with the amplitude. samMidiGroupBy :: MidiTrigFun Sig2 -> MidiChn -> [(Int, Sam)] -> Sam samMidiGroupBy midiFun midiChn as = S.liftSam $ fmap (\xs -> midiGroupBy midiFun midiChn $ zip keys xs) $ sequenceA sams- where (keys, sams) = unzip as+ where (keys, sams) = unzip as
src/Csound/Sam/Ui.hs view
@@ -1,12 +1,12 @@ {-# Language FlexibleContexts #-} -- | Graphical widgets for playing samples module Csound.Sam.Ui(- freeSim, hfreeSim, freeSimWith, hfreeSimWith,- freeTog, hfreeTog,- sim, hsim, simWith, hsimWith,- tog, htog,- live, liveEf,- mixSam, uiSam, addGain+ freeSim, hfreeSim, freeSimWith, hfreeSimWith,+ freeTog, hfreeTog,+ sim, hsim, simWith, hsimWith,+ tog, htog,+ live, liveEf,+ mixSam, uiSam, addGain ) where import Data.List(transpose)@@ -18,7 +18,7 @@ groupToggles :: ([Sig2] -> Sig2) -> [Sam] -> [Evt D] -> Sam groupToggles group sams ts = Sam $ reader $ \r ->- S (group $ zipWith (\sam t -> schedToggle (runSam r sam) t) sams ts) InfDur+ S (group $ zipWith (\sam t -> schedToggle (runSam r sam) t) sams ts) InfDur -- | A widget for playing several samples at the same time (aka `sim`ultaneously). -- The prefix `free` means no syncronization. the samples start to play when the button is pressed.@@ -46,11 +46,11 @@ genFreeSimInits :: ([Gui] -> Gui) -> [(String, Sam, Bool)] -> Source Sam genFreeSimInits gcat as = source $ do- (guis, ts) <- fmap unzip $ zipWithM (\a b -> toggle a b) names initVals- let res = groupToggles mean sams ts- return (gcat guis, res)- where- (names, sams, initVals) = unzip3 as+ (guis, ts) <- fmap unzip $ zipWithM (\a b -> toggle a b) names initVals+ let res = groupToggles mean sams ts+ return (gcat guis, res)+ where+ (names, sams, initVals) = unzip3 as -- | The widget to toggle between several samples (aka `tog`gle). -- The prefix `free` means no syncronization. the samples start to play when the button is pressed.@@ -63,22 +63,22 @@ genFreeTog :: ([Gui] -> Gui) -> [(String, Sam)] -> Source Sam genFreeTog gcat as = source $ do- (guis, writes, reads) <- fmap unzip3 $ mapM (flip setToggleSig False) names- curRef <- newGlobalRef (0 :: Sig)- current <- readRef curRef- zipWithM_ (\w i -> w $ ifB (current ==* i) 1 0) writes ids- zipWithM_ (\r i -> runEvt (snaps r) $ \x -> do- when1 (sig x ==* 0 &&* current ==* i) $ do- writeRef curRef 0- when1 (sig x ==* 1) $ do- writeRef curRef i- ) reads ids+ (guis, writeProcs, readProcs) <- fmap unzip3 $ mapM (flip setToggleSig False) names+ curRef <- newGlobalRef (0 :: Sig)+ current <- readRef curRef+ zipWithM_ (\w i -> w $ ifB (current ==* i) 1 0) writeProcs ids+ zipWithM_ (\r i -> runEvt (snaps r) $ \x -> do+ when1 (sig x ==* 0 &&* current ==* i) $ do+ writeRef curRef 0+ when1 (sig x ==* 1) $ do+ writeRef curRef i+ ) readProcs ids - let res = groupToggles sum sams $ fmap (snaps . (\i -> ifB (current ==* i) 1 0)) ids- return (gcat guis, res)- where- (names, sams) = unzip as- ids = fmap (sig . int) [1 .. length as]+ let res = groupToggles sum sams $ fmap (snaps . (\i -> ifB (current ==* i) 1 0)) ids+ return (gcat guis, res)+ where+ (names, sams) = unzip as+ ids = fmap (sig . int) [1 .. length as] genSim :: ([Gui] -> Gui) -> Int -> [(String, Sam)] -> Source Sam@@ -86,18 +86,18 @@ genSimInits :: ([Gui] -> Gui) -> Int -> [(String, Sam, Bool)] -> Source Sam genSimInits gcat numBeats as = source $ do- (guis, writes, reads) <- fmap unzip3 $ zipWithM (\a b -> setToggleSig a b) names initVals- curRefs <- mapM (const $ newGlobalRef (0 :: Sig)) ids- currents <- mapM readRef curRefs- zipWithM_ (\w val -> w val) writes currents- let mkReaders bpm = zipWithM_ (\r ref -> runEvt (syncBpm (bpm / sig (int numBeats)) $ snaps r) $ \x -> do- writeRef ref (sig x)- ) reads curRefs- let res = bindBpm (\bpm x -> mkReaders bpm >> return x) $ groupToggles mean sams $ fmap snaps currents- return (gcat guis, res)- where- (names, sams, initVals) = unzip3 as- ids = fmap (sig . int) [1 .. length as]+ (guis, writeProcs, readProcs) <- fmap unzip3 $ zipWithM (\a b -> setToggleSig a b) names initVals+ curRefs <- mapM (const $ newGlobalRef (0 :: Sig)) ids+ currents <- mapM readRef curRefs+ zipWithM_ (\w val -> w val) writeProcs currents+ let mkReaders bpm = zipWithM_ (\r ref -> runEvt (syncBpm (bpm / sig (int numBeats)) $ snaps r) $ \x -> do+ writeRef ref (sig x)+ ) readProcs curRefs+ let res = bindBpm (\bpm x -> mkReaders bpm >> return x) $ groupToggles mean sams $ fmap snaps currents+ return (gcat guis, res)+ where+ (names, sams, initVals) = unzip3 as+ ids = fmap (sig . int) [1 .. length as] -- | A widget for playing several samples at the same time (aka `sim`ultaneously). -- The first argument is about syncronization.@@ -132,22 +132,22 @@ genTogWithRef :: ([Gui] -> Gui) -> Int -> [(String, Sam)] -> Source (Sam, Ref Sig) genTogWithRef gcat numBeats as = source $ do- (guis, writes, reads) <- fmap unzip3 $ mapM (flip setToggleSig False) names- curRef <- newGlobalRef (0 :: Sig)- current <- readRef curRef- zipWithM_ (\w i -> w $ ifB (current ==* i) 1 0) writes ids- let mkReaders bpm = zipWithM_ (\r i -> runEvt (syncBpm (bpm / (sig $ int numBeats)) $ snaps r) $ \x -> do- when1 (sig x ==* 0 &&* current ==* i) $ do- writeRef curRef 0- when1 (sig x ==* 1) $ do- writeRef curRef i- ) reads ids+ (guis, writeProcs, readProcs) <- fmap unzip3 $ mapM (flip setToggleSig False) names+ curRef <- newGlobalRef (0 :: Sig)+ current <- readRef curRef+ zipWithM_ (\w i -> w $ ifB (current ==* i) 1 0) writeProcs ids+ let mkReaders bpm = zipWithM_ (\r i -> runEvt (syncBpm (bpm / (sig $ int numBeats)) $ snaps r) $ \x -> do+ when1 (sig x ==* 0 &&* current ==* i) $ do+ writeRef curRef 0+ when1 (sig x ==* 1) $ do+ writeRef curRef i+ ) readProcs ids - let res = bindBpm (\bpm x -> mkReaders bpm >> return x) $ groupToggles sum sams $ fmap (snaps . (\i -> ifB (current ==* i) 1 0)) ids- return (gcat guis, (res, curRef))- where- (names, sams) = unzip as- ids = fmap (sig . int) [1 .. length as]+ let res = bindBpm (\bpm x -> mkReaders bpm >> return x) $ groupToggles sum sams $ fmap (snaps . (\i -> ifB (current ==* i) 1 0)) ids+ return (gcat guis, (res, curRef))+ where+ (names, sams) = unzip as+ ids = fmap (sig . int) [1 .. length as] -- | A widget to toggle playing of several samples. The switch -- of the playing is synchronized with each n'th beat where@@ -174,44 +174,44 @@ -- in row-wise fashion. live :: Int -> [String] -> [Sam] -> Source Sam live numBeats names sams = source $ do- (gVols, vols) <- fmap unzip $ mapM defSlider $ replicate n "vol"- (gs, xs) <- fmap unzip $ zipWithM (\a b -> mkLiveRow numBeats a b) (zip names gVols) rows- let (sigs, refs) = unzip xs- (gMaster, masterVol) <- defSlider "master"- (g, proc) <- mkLiveSceneRow numBeats gMaster ids refs- return $ (hor $ g : gs, bindBpm (\bpm asig -> proc bpm >> return asig) $ mul masterVol $ mean $ zipWith mul vols sigs)- where- rows = transpose $ splitRows n sams- ids = fmap (sig . int) [1 .. length (head rows)]- n = length names+ (gVols, vols) <- fmap unzip $ mapM defSlider $ replicate n "vol"+ (gs, xs) <- fmap unzip $ zipWithM (\a b -> mkLiveRow numBeats a b) (zip names gVols) rows+ let (sigs, refs) = unzip xs+ (gMaster, masterVol) <- defSlider "master"+ (g, proc) <- mkLiveSceneRow numBeats gMaster ids refs+ return $ (hor $ g : gs, bindBpm (\bpm asig -> proc bpm >> return asig) $ mul masterVol $ mean $ zipWith mul vols sigs)+ where+ rows = transpose $ splitRows n sams+ ids = fmap (sig . int) [1 .. length (head rows)]+ n = length names mkLiveRow :: Int -> (String, Gui) -> [Sam] -> Source (Sam, Ref Sig)-mkLiveRow numBeats (name, gVol) xs = genTogWithRef (\xs -> ver $ xs ++ [gVol]) numBeats (zip (name : repeat "") xs)+mkLiveRow numBeats (name, gVol) as = genTogWithRef (\xs -> ver $ xs ++ [gVol]) numBeats (zip (name : repeat "") as) mkLiveSceneRow :: Int -> Gui -> [Sig] -> [Ref Sig] -> SE (Gui, Sig -> SE ()) mkLiveSceneRow numBeats gMaster ids refs = do- (guis, writes, reads) <- fmap unzip3 $ mapM (flip setToggleSig False) names- curRef <- newGlobalRef (0 :: Sig)- current <- readRef curRef- zipWithM_ (\w i -> w $ ifB (current ==* i) 1 0) writes ids- let mkReaders bpm = zipWithM_ (\r i -> runEvt (syncBpm (bpm / sig (int numBeats)) $ snaps r) $ \x -> do- when1 (sig x ==* 0 &&* current ==* i) $ do- writeRef curRef 0- mapM_ (flip writeRef 0) refs- when1 (sig x ==* 1) $ do- writeRef curRef i- mapM_ (flip writeRef i) refs- ) reads ids+ (guis, writeProcs, readProcs) <- fmap unzip3 $ mapM (flip setToggleSig False) names+ curRef <- newGlobalRef (0 :: Sig)+ current <- readRef curRef+ zipWithM_ (\w i -> w $ ifB (current ==* i) 1 0) writeProcs ids+ let mkReaders bpm = zipWithM_ (\r i -> runEvt (syncBpm (bpm / sig (int numBeats)) $ snaps r) $ \x -> do+ when1 (sig x ==* 0 &&* current ==* i) $ do+ writeRef curRef 0+ mapM_ (flip writeRef 0) refs+ when1 (sig x ==* 1) $ do+ writeRef curRef i+ mapM_ (flip writeRef i) refs+ ) readProcs ids - return (ver $ guis ++ [gMaster], mkReaders)- where- names = take len $ fmap show [1 ..]- len = length ids+ return (ver $ guis ++ [gMaster], mkReaders)+ where+ names = take len $ fmap show [(1::Int) ..]+ len = length ids splitRows :: Int -> [a] -> [[a]] splitRows n as- | length as < n = []- | otherwise = take n as : splitRows n (drop n as)+ | length as < n = []+ | otherwise = take n as : splitRows n (drop n as) defSlider :: String -> Source Sig defSlider tag = slider tag (linSpan 0 1) 0.5@@ -221,26 +221,26 @@ -- between dry and wet signals. liveEf :: Int -> [String] -> [Sam] -> (Double, Fx2) -> [(Double, Fx2)] -> Source Sam liveEf numBeats names sams masterEff effs = source $ do- (gVols, vols) <- fmap unzip $ mapM defSlider $ replicate n "vol"- (gEffs, effCtrls) <- fmap unzip $- mapM (\(tag, initVal) -> slider tag (linSpan 0 1) initVal) $ zip (replicate n "eff") (fmap fst effs)- let gCtrls = zipWith ctrlGui gEffs gVols- (gs, xs) <- fmap unzip $ zipWithM (\a b -> mkLiveRow numBeats a b) (zip names gCtrls) rows- let (sigs, refs) = unzip xs- (gMaster, masterVol) <- defSlider "master"- (gMasterEff, masterEffCtrl) <- slider "eff" (linSpan 0 1) (fst masterEff)- (g, proc) <- mkLiveSceneRow numBeats (ctrlGui gMasterEff gMaster) ids refs- return $ (hor $ g : gs, bindBpm (\bpm asig -> proc bpm >> return asig) $- mul masterVol $ appEff (snd masterEff) masterEffCtrl $- mean $ zipWith mul vols $ zipWith (uncurry appEff) (zip (fmap snd effs) effCtrls) sigs)- where- rows = transpose $ splitRows n sams- ids = fmap (sig . int) [1 .. length (head rows)]- n = length names+ (gVols, vols) <- fmap unzip $ mapM defSlider $ replicate n "vol"+ (gEffs, effCtrls) <- fmap unzip $+ mapM (\(tag, initVal) -> slider tag (linSpan 0 1) initVal) $ zip (replicate n "eff") (fmap fst effs)+ let gCtrls = zipWith ctrlGui gEffs gVols+ (gs, xs) <- fmap unzip $ zipWithM (\a b -> mkLiveRow numBeats a b) (zip names gCtrls) rows+ let (sigs, refs) = unzip xs+ (gMaster, masterVol) <- defSlider "master"+ (gMasterEff, masterEffCtrl) <- slider "eff" (linSpan 0 1) (fst masterEff)+ (g, proc) <- mkLiveSceneRow numBeats (ctrlGui gMasterEff gMaster) ids refs+ return $ (hor $ g : gs, bindBpm (\bpm asig -> proc bpm >> return asig) $+ mul masterVol $ appEff (snd masterEff) masterEffCtrl $+ mean $ zipWith mul vols $ zipWith (uncurry appEff) (zip (fmap snd effs) effCtrls) sigs)+ where+ rows = transpose $ splitRows n sams+ ids = fmap (sig . int) [1 .. length (head rows)]+ n = length names - appEff f depth a = bindSam (\x -> fmap (\y -> y + (mul (1 - depth) x)) $ mul depth $ f x) a+ appEff f depth a = bindSam (\x -> fmap (\y -> y + (mul (1 - depth) x)) $ mul depth $ f x) a - ctrlGui eff vol = sca 2.5 $ ver [eff, vol]+ ctrlGui ef vol = sca 2.5 $ ver [ef, vol] -- | It's useful to convert samples to signals an insert -- them in the widget @mixer@.@@ -252,16 +252,10 @@ -- > uisam name isOn bpm samWidget uiSam :: String -> Bool -> Sig -> Source Sam -> Source Fx2 uiSam name onOff bpm sam = uiSig name onOff (joinSource $ mapSource (runSam bpm) sam)- where- joinSource :: Source (SE Sig2) -> Source Sig2- joinSource a = source $ do- (g, mres) <- a- res <- mres- return (g, res) -- | Adds gain slider on top of the widget. addGain :: SigSpace a => Source a -> Source a addGain x = source $ do- (g, asig) <- x- (gainGui, gain) <- slider "gain" (linSpan 0 1) 0.5- return (ver [sca 0.15 gainGui, g], mul gain asig)+ (g, asig) <- x+ (gainGui, gainSig) <- slider "gain" (linSpan 0 1) 0.5+ return (ver [sca 0.15 gainGui, g], mul gainSig asig)