module Csound.Sam (
Sample, Sam, Bpm, runSam,
mapBpm, bindSam, bindBpm, liftSam, mapBpm2, bindBpm2, withBpm,
sig1, sig2, infSig1, infSig2, fromSig1, fromSig2, ToSam(..), limSam,
wav, wavr, seg, segr, rndWav, rndWavr, rndSeg, rndSegr, ramWav,
wav1, wavr1, seg1, segr1, rndWav1, rndWavr1, rndSeg1, rndSegr1, ramWav1,
ramLoop, ramRead, segLoop, segRead, relLoop, relRead,
ramLoop1, ramRead1, segLoop1, segRead1, relLoop1, relRead1,
linEnv, expEnv, hatEnv, decEnv, riseEnv, edecEnv, eriseEnv,
wide, flow, pick, pickBy,
atPan, atPch, atCps, atPanRnd, atVolRnd, atVolGauss,
rep1, rep, pat1, pat, pat',
Chord,
arpUp, arpDown, arpOneOf, arpFreqOf,
arpUp1, arpDown1, arpOneOf1, arpFreqOf1,
wall, forAirports, genForAirports, arpy,
metroS, toSec,
module Csound.Sam.Ui,
module Csound.Sam.Trig
) where
import Control.Monad.Trans.Class
import Control.Applicative
import Control.Monad.Trans.Reader
import Csound.Base
import Csound.Sam.Core
import Csound.Sam.Ui
import Csound.Sam.Trig
type instance DurOf Sam = D
instance Melody Sam where
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
instance Stretch Sam where
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 }
instance Loop Sam where
loop = genLoop $ \_ d asig -> repeatSnd d asig
instance Rest Sam where
rest dt = Sam $ reader $ \bpm -> S 0 (Dur $ toSec bpm dt)
infSig1 :: Sig -> Sam
infSig1 x = pure (x, x)
infSig2 :: Sig2 -> Sam
infSig2 = pure
sig1 :: D -> Sig -> Sam
sig1 dt a = Sam $ reader $ \_ -> S (a, a) (Dur dt)
sig2 :: D -> Sig2 -> Sam
sig2 dt a = Sam $ reader $ \_ -> S a (Dur dt)
fromSig1 :: D -> Sig -> Sam
fromSig1 dt = lim dt . infSig1
fromSig2 :: D -> Sig2 -> Sam
fromSig2 dt = lim dt . infSig2
wav :: String -> Sam
wav fileName = Sam $ return $ S (readSnd fileName) (Dur $ lengthSnd fileName)
wavr :: String -> Sam
wavr fileName = Sam $ return $ S (takeSnd len $ loopWav (1) fileName) (Dur len)
where len = lengthSnd fileName
seg :: D -> D -> String -> Sam
seg start end fileName = Sam $ return $ S (readSegWav start end 1 fileName) (Dur len)
where len = end start
segr :: D -> D -> String -> Sam
segr start end fileName = Sam $ return $ S (readSegWav start end (1) fileName) (Dur len)
where len = end start
rndWav :: D -> String -> Sam
rndWav dt fileName = rndSeg dt 0 (lengthSnd fileName) fileName
rndWavr :: D -> String -> Sam
rndWavr dt fileName = rndSegr dt 0 (lengthSnd fileName) fileName
rndSeg :: D -> D -> D -> String -> Sam
rndSeg = genRndSeg 1
rndSegr :: D -> D -> D -> String -> Sam
rndSegr = genRndSeg (1)
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 len)
where dl = end len
ramWav :: LoopMode -> Sig -> String -> Sam
ramWav loopMode speed fileName = Sam $ return $ S (ramSnd loopMode speed fileName) (Dur $ lengthSnd fileName)
ramWav1 :: LoopMode -> Sig -> String -> Sam
ramWav1 loopMode speed fileName = Sam $ return $ S (let x = ramSnd1 loopMode speed fileName in (x, x)) (Dur $ lengthSnd fileName)
wav1 :: String -> Sam
wav1 fileName = Sam $ return $ S (let x = readSnd1 fileName in (x, x)) (Dur $ lengthSnd fileName)
wavr1 :: String -> Sam
wavr1 fileName = Sam $ return $ S (let x = takeSnd len $ loopWav1 (1) fileName in (x, x)) (Dur len)
where len = lengthSnd fileName
seg1 :: D -> D -> String -> Sam
seg1 start end fileName = Sam $ return $ S (let x = readSegWav1 start end 1 fileName in (x, x)) (Dur len)
where len = end start
segr1 :: D -> D -> String -> Sam
segr1 start end fileName = Sam $ return $ S (let x = readSegWav1 start end (1) fileName in (x, x)) (Dur len)
where len = end start
rndWav1 :: D -> String -> Sam
rndWav1 dt fileName = rndSeg1 dt 0 (lengthSnd fileName) fileName
rndWavr1 :: D -> String -> Sam
rndWavr1 dt fileName = rndSegr1 dt 0 (lengthSnd fileName) fileName
rndSeg1 :: D -> D -> D -> String -> Sam
rndSeg1 = genRndSeg1 1
rndSegr1 :: D -> D -> D -> String -> Sam
rndSegr1 = genRndSeg1 (1)
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 len)
where dl = end len
toSec :: Bpm -> D -> D
toSec bpm a = a * 60 / bpm
toSecSig :: Bpm -> Sig -> Sig
toSecSig bpm a = a * 60 / sig bpm
addDur :: D -> Dur -> Dur
addDur d x = case x of
Dur a -> Dur $ d + a
InfDur -> InfDur
atPch :: Sig -> Sam -> Sam
atPch k = mapSig (scalePitch k)
atPan :: Sig -> Sam -> Sam
atPan k = fmap (\(a, b) -> pan2 (mean [a, b]) k)
atCps :: Sig -> Sam -> Sam
atCps k = mapSig (scaleSpec k)
tfmBy :: (S Sig2 -> Sig2) -> Sam -> Sam
tfmBy f = Sam . fmap (\x -> x { samSig = f x }) . unSam
tfmS :: (Bpm -> S Sig2 -> S Sig2) -> Sam -> Sam
tfmS f ra = Sam $ do
bpm <- ask
a <- unSam ra
return $ f bpm a
setInfDur :: Sam -> Sam
setInfDur = Sam . fmap (\a -> a { samDur = InfDur }) . unSam
wide :: D -> Sam -> Sam
wide = str . recip
flow :: [Sam] -> Sam
flow [] = 0
flow as = foldr1 flow2 as
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
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 (getDur . samDur) xs
let sigs = fmap samSig xs
return $ S (sched (\n -> return $ atTuple sigs $ sig n) $ fmap (\(dt, a) -> str dt $ temp a) $ pickFun (zip ds (fmap int [0..])) $ metroS bpm dt) InfDur
where getDur x = case x of
InfDur -> 1
Dur d -> d
pick :: Sig -> [Sam] -> Sam
pick = genPick oneOf
pickBy :: Sig -> [(D, Sam)] -> Sam
pickBy dt as = genPick (\ds -> freqOf $ zip (fmap fst as) ds) dt (fmap snd as)
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 = toSec bpm start
absEnd = toSec bpm end
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 (d start end), 1, end , 0]
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 (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 d
hatEnv :: Sam -> Sam
hatEnv = genEnv1 $ \d -> oscBy (polys 0 1 [0, 1, 1]) (1 / sig d)
riseEnv :: Sam -> Sam
riseEnv = genEnv1 $ \d -> linseg [0, d, 1]
decEnv :: Sam -> Sam
decEnv = genEnv1 $ \d -> linseg [1, d, 0]
eriseEnv :: Sam -> Sam
eriseEnv = genEnv1 $ \d -> expseg [0.0001, d, 1]
edecEnv :: Sam -> Sam
edecEnv = genEnv1 $ \d -> expseg [1, d, 0.0001]
type LoopFun = D -> D -> Sig2 -> Sig2
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)
}
rep1 :: D -> Sam -> Sam
rep1 = rep . return
pat1 :: D -> Sam -> Sam
pat1 = pat . return
rep :: [D] -> Sam -> Sam
rep dts = genLoop $ \bpm d asig -> sched (const $ return asig) $ fmap (const $ notes bpm d) $ metroS bpm (sig $ sum dts)
where notes bpm _ = har $ zipWith (\t dt-> singleEvent (toSec bpm t) (toSec bpm dt) unit) (patDurs dts) dts
pat :: [D] -> Sam -> Sam
pat dts = genLoop $ \bpm d asig -> sched (const $ return asig) $ fmap (const $ notes bpm d) $ metroS bpm (sig $ sum dts)
where notes bpm d = har $ fmap (\t -> fromEvent $ Event (toSec bpm t) d unit) $ patDurs dts
pat' :: [D] -> [D] -> Sam -> Sam
pat' vols dts = genLoop $ \bpm d asig -> sched (instr asig) $ fmap (const $ notes bpm d) $ metroS bpm (sig $ 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
lcmList :: [a] -> [b] -> [(a, b)]
lcmList as bs = take n $ zip (cycle as) (cycle bs)
where n = lcm (length as) (length bs)
wall :: D -> Sam -> Sam
wall dt a = mean [b, del hdt b]
where
hdt = 0.5 * dt
f = pat1 hdt . hatEnv . lim dt
b = f a
type Chord = [D]
type Arp1Fun = Evt Unit -> Evt D
arpInstr :: Sig2 -> D -> SE Sig2
arpInstr asig k = return $ mapSig (scalePitch (sig k)) asig
patDurs :: [D] -> [D]
patDurs dts = reverse $ snd $ foldl (\(counter, res) a -> (a + counter, counter:res)) (0, []) dts
genArp1 :: Arp1Fun -> Sig -> Sam -> Sam
genArp1 arpFun dt = genLoop $ \bpm d asig ->
sched (arpInstr asig) $ withDur d $ arpFun $ metroS bpm dt
arpUp1 :: Chord -> Sig -> Sam -> Sam
arpUp1 = genArp1 . cycleE
arpDown1 :: Chord -> Sig -> Sam -> Sam
arpDown1 ch = arpUp1 (reverse ch)
arpOneOf1 :: Chord -> Sig -> Sam -> Sam
arpOneOf1 = genArp1 . oneOf
arpFreqOf1 :: [D] -> Chord -> Sig -> Sam -> Sam
arpFreqOf1 freqs ch = genArp1 (freqOf (zip freqs ch))
genArp :: Arp1Fun -> [D] -> Sam -> Sam
genArp arpFun dts = genLoop $ \bpm d asig -> sched (arpInstr asig) $ fmap (notes bpm d) $ arpFun $ metroS bpm (sig $ sum dts)
where notes bpm d pchScale = har $ fmap (\t -> singleEvent (toSec bpm t) d pchScale) $ patDurs dts
arpUp :: Chord -> [D] -> Sam -> Sam
arpUp = genArp . cycleE
arpDown :: Chord -> [D] -> Sam -> Sam
arpDown ch = arpUp (reverse ch)
arpOneOf :: Chord -> [D] -> Sam -> Sam
arpOneOf = genArp . oneOf
arpFreqOf :: [D] -> Chord -> [D] -> Sam -> Sam
arpFreqOf freqs ch = genArp (freqOf $ zip freqs ch)
metroS :: Bpm -> Sig -> Evt Unit
metroS bpm dt = metroE (recip $ toSecSig bpm dt)
forAirports :: [(D, D, D)] -> Sam -> Sam
forAirports xs sample = mean $ flip fmap xs $
\(delTime, loopTime, note) -> del delTime $ pat [loopTime] (atPch (sig note) sample)
genForAirports :: [(D, D, Sam)] -> Sam
genForAirports xs = mean $ fmap (\(delTime, loopTime, sample) -> del delTime $ pat [loopTime] sample) xs
arp1 :: (SigSpace a, Sigs a) => (D -> SE a) -> D -> D -> 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 (sig dt)
arpy :: (D -> SE Sig2) -> D -> D -> 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
atPanRnd :: Sam -> Sam
atPanRnd = bindSam rndPan2
atVolGauss :: D -> Sam -> Sam
atVolGauss k = bindSam (gaussVol k)
atVolRnd :: (D, D) -> Sam -> Sam
atVolRnd k = bindSam (rndVol k)
class ToSam a where
toSam :: a -> Sam
limSam :: ToSam a => D -> a -> Sam
limSam dt = lim dt . toSam
instance ToSam Sig where
toSam x = Sam $ return $ S (x, x) InfDur
instance ToSam Sig2 where
toSam x = Sam $ return $ S x InfDur
instance ToSam (SE Sig) where
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
ramLoop :: Fidelity -> TempoSig -> PitchSig -> String -> Sam
ramLoop winSize tempo pitch file = toSam $ loopRam winSize tempo pitch file
ramRead :: Fidelity -> TempoSig -> PitchSig -> String -> Sam
ramRead winSize tempo pitch file = sig2 (lengthSnd file / ir tempo) $ readRam winSize tempo pitch file
segLoop :: Fidelity -> (Sig, Sig) -> TempoSig -> PitchSig -> String -> Sam
segLoop winSize ds tempo pitch file = toSam $ loopSeg winSize ds tempo pitch file
segRead :: Fidelity -> (Sig, Sig) -> TempoSig -> PitchSig -> String -> Sam
segRead winSize ds@(kmin, kmax) tempo pitch file = sig2 (ir $ (kmax kmin) / tempo) $ readSeg winSize ds tempo pitch file
relLoop :: Fidelity -> (Sig, Sig) -> TempoSig -> PitchSig -> String -> Sam
relLoop winSize ds tempo pitch file = toSam $ loopRel winSize ds tempo pitch file
relRead :: Fidelity -> (Sig, Sig) -> TempoSig -> PitchSig -> String -> Sam
relRead winSize ds@(kmin, kmax) tempo pitch file = sig2 (ir $ (kmax kmin) / tempo) $ readRel winSize ds tempo pitch file
ramLoop1 :: Fidelity -> TempoSig -> PitchSig -> String -> Sam
ramLoop1 winSize tempo pitch file = toSam $ loopRam1 winSize tempo pitch file
ramRead1 :: Fidelity -> TempoSig -> PitchSig -> String -> Sam
ramRead1 winSize tempo pitch file = sig1 (lengthSnd file / ir tempo) $ readRam1 winSize tempo pitch file
segLoop1 :: Fidelity -> (Sig, Sig) -> TempoSig -> PitchSig -> String -> Sam
segLoop1 winSize ds tempo pitch file = toSam $ loopSeg1 winSize ds tempo pitch file
segRead1 :: Fidelity -> (Sig, Sig) -> TempoSig -> PitchSig -> String -> Sam
segRead1 winSize ds@(kmin, kmax) tempo pitch file = sig1 (ir $ (kmax kmin) / tempo) $ readSeg1 winSize ds tempo pitch file
relLoop1 :: Fidelity -> (Sig, Sig) -> TempoSig -> PitchSig -> String -> Sam
relLoop1 winSize ds tempo pitch file = toSam $ loopRel1 winSize ds tempo pitch file
relRead1 :: Fidelity -> (Sig, Sig) -> TempoSig -> PitchSig -> String -> Sam
relRead1 winSize ds@(kmin, kmax) tempo pitch file = sig1 (ir $ (kmax kmin) / tempo) $ readRel1 winSize ds tempo pitch file