{-# Language TypeFamilies, FlexibleInstances #-}
module Csound.Air.Envelope (
leg, xeg,
adsr140, trigTab,
onIdur, lindur, expdur, linendur,
onDur, lindurBy, expdurBy, linendurBy,
fadeIn, fadeOut, fades, expFadeIn, expFadeOut, expFades, slope, expSlope,
HumanizeValue(..), HumanizeTime(..), HumanizeValueTime(..),
hval, htime, hvalTime,
lpshold, loopseg, loopxseg, lpsholdBy, loopsegBy, loopxsegBy,
holdSeq, linSeq, expSeq,
linloop, exploop, sah, stepSeq,
constSeq, triSeq, sqrSeq, sawSeq, isawSeq, xsawSeq, ixsawSeq, isqrSeq, xtriSeq,
pwSeq, ipwSeq, rampSeq, irampSeq, xrampSeq, ixrampSeq,
adsrSeq, xadsrSeq, adsrSeq_, xadsrSeq_,
Seq, toSeq, onBeat, onBeats,
seqConst, seqLin, seqExp,
seqPw, iseqPw, seqSqr, iseqSqr,
seqSaw, iseqSaw, xseqSaw, ixseqSaw, seqRamp, iseqRamp, seqTri, seqTriRamp,
seqAdsr, xseqAdsr, seqAdsr_, xseqAdsr_,
seqPat, seqAsc, seqDesc, seqHalf
) where
import Control.Monad
import Control.Applicative
import Data.List(intersperse)
import Temporal.Media
import Csound.Typed
import Csound.Typed.Opcode hiding (lpshold, loopseg, loopxseg)
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.Control.Evt(evtToTrig)
leg :: D -> D -> D -> D -> Sig
leg = madsr
xeg :: D -> D -> D -> D -> Sig
xeg a d s r = mxadsr a d (s + 0.00001) r
onIdur :: [D] -> [D]
onIdur = onDur idur
onDur :: D -> [D] -> [D]
onDur dur xs = case xs of
a:b:as -> a : b * dur : onDur dur as
_ -> xs
lindur :: [D] -> Sig
lindur = linseg . onIdur
expdur :: [D] -> Sig
expdur = expseg . onIdur
lindurBy :: D -> [D] -> Sig
lindurBy dt = linseg . onDur dt
expdurBy :: D -> [D] -> Sig
expdurBy dt = expseg . onDur dt
linendur :: Sig -> D -> D -> Sig
linendur = linendurBy idur
linendurBy :: D -> Sig -> D -> D -> Sig
linendurBy dt asig ris dec = linen asig (ris * dt) dt (dec * dt)
fadeIn :: D -> Sig
fadeIn att = linseg [0, att, 1]
fadeOut :: D -> Sig
fadeOut dec = linsegr [1] dec 0
slope :: D -> D -> Sig
slope dt1 dt2 = linseg [0, dt1, 0, dt2, 1 ]
expSlope :: D -> D -> Sig
expSlope dt1 dt2 = linseg [0.001, dt1, 0.001, dt2, 1 ]
expFadeIn :: D -> Sig
expFadeIn att = expseg [0.0001, att, 1]
expFadeOut :: D -> Sig
expFadeOut dec = expsegr [1] dec 0.0001
fades :: D -> D -> Sig
fades att dec = fadeIn att * fadeOut dec
expFades :: D -> D -> Sig
expFades att dec = expFadeIn att * expFadeOut dec
stepSeq :: [Sig] -> Sig -> Sig
stepSeq as = lpshold (intersperseEnd 1 [1] as)
sah :: [Sig] -> Sig
sah as = stepSeq as (1 / period)
where
period = sumDts as
sumDts xs = case xs of
a : dt : rest -> dt + sumDts rest
_ -> 0
linloop :: [Sig] -> Sig
linloop = genLoop loopseg . (++ [0])
exploop :: [Sig] -> Sig
exploop = genLoop loopxseg . (++ [0])
genLoop :: ([Sig] -> Sig -> Sig) -> [Sig] -> Sig
genLoop f as = f (tfmList as) (1 / len)
where
tfmList xs = case xs of
[] -> []
[a] -> [a]
a:b:rest -> a : (b/len) : tfmList rest
len = go as
where
go xs = case xs of
[] -> 0
[a] -> 0
a:b:rest -> b + go rest
constSeq :: [Sig] -> Sig -> Sig
constSeq = genSeq stepSeq id
triSeq :: [Sig] -> Sig -> Sig
triSeq as cps = genSeq loopseg triList as cps
sqrSeq :: [Sig] -> Sig -> Sig
sqrSeq = genSeq stepSeq (intersperseEnd 0 [0])
sawSeq :: [Sig] -> Sig -> Sig
sawSeq = genSeq loopseg sawList
isqrSeq :: [Sig] -> Sig -> Sig
isqrSeq = genSeq stepSeq ((0 : ) . intersperseEnd 0 [])
isawSeq :: [Sig] -> Sig -> Sig
isawSeq = genSeq loopseg isawList
xsawSeq :: [Sig] -> Sig -> Sig
xsawSeq = genSeq loopxseg sawList
ixsawSeq :: [Sig] -> Sig -> Sig
ixsawSeq = genSeq loopxseg isawList
xtriSeq :: [Sig] -> Sig -> Sig
xtriSeq as cps = genSeq loopxseg triList as (cps)
pwSeq :: Sig -> [Sig] -> Sig -> Sig
pwSeq duty = genSeq lpshold (pwList duty)
ipwSeq :: Sig -> [Sig] -> Sig -> Sig
ipwSeq duty = genSeq lpshold (ipwList duty)
rampSeq :: Sig -> [Sig] -> Sig -> Sig
rampSeq duty xs = genSeq loopseg (rampList (head xs) duty) xs
xrampSeq :: Sig -> [Sig] -> Sig -> Sig
xrampSeq duty xs = genSeq loopxseg (rampList (head xs) duty) xs
irampSeq :: Sig -> [Sig] -> Sig -> Sig
irampSeq duty xs = genSeq loopseg (irampList (head xs) duty) xs
ixrampSeq :: Sig -> [Sig] -> Sig -> Sig
ixrampSeq duty xs = genSeq loopxseg (irampList (head xs) duty) xs
sawList xs = case xs of
[] -> []
[a] -> a : 1 : 0 : []
a:rest -> a : 1 : 0 : 0 : sawList rest
isawList xs = case xs of
[] -> []
[a] -> 0 : 1 : a : []
a:rest -> 0 : 1 : a : 0 : isawList rest
triList xs = case xs of
[] -> [0, 0]
a:rest -> 0 : 1 : a : 1 : triList rest
pwList k xs = case xs of
[] -> []
a:as -> a : k : 0 : (1 - k) : pwList k as
ipwList k xs = case xs of
[] -> []
a:as -> 0 : k : a : (1 - k) : ipwList k as
rampList a1 duty xs = case xs of
[] -> []
[a] -> 0.5 * a : d1 : a : d1 : 0.5 * a : d2 : 0 : d2 : 0.5 * a1 : []
a:as -> 0.5 * a : d1 : a : d1 : 0.5 * a : d2 : 0 : d2 : rampList a1 duty as
where
d1 = duty / 2
d2 = (1 - duty) / 2
irampList a1 duty xs = case xs of
[] -> []
[a] -> 0.5 * a : d1 : 0 : d1 : 0.5 * a : d2 : a : d2 : 0.5 * a1 : []
a:as -> 0.5 * a : d1 : 0 : d1 : 0.5 * a : d2 : a : d2 : rampList a1 duty as
where
d1 = duty / 2
d2 = (1 - duty) / 2
genSeq :: ([Sig] -> Sig -> Sig) -> ([Sig] -> [Sig]) -> [Sig] -> Sig -> Sig
genSeq mkSeq go as cps = mkSeq (go as) (cps / len)
where len = sig $ int $ length as
intersperseEnd :: a -> [a] -> [a] -> [a]
intersperseEnd val end xs = case xs of
[] -> end
[a] -> a : end
a:as -> a : val : intersperseEnd val end as
smooth :: Sig -> Sig
smooth = flip portk 0.001
fixEnd :: [Sig] -> [Sig]
fixEnd = ( ++ [0])
lpshold :: [Sig] -> Sig -> Sig
lpshold as cps = smooth $ C.lpshold cps 0 0 as
loopseg :: [Sig] -> Sig -> Sig
loopseg as cps = smooth $ C.loopseg cps 0 0 (fixEnd as)
loopxseg :: [Sig] -> Sig -> Sig
loopxseg as cps = smooth $ C.loopxseg cps 0 0 (fixEnd as)
lpsholdBy :: D -> [Sig] -> Sig -> Sig
lpsholdBy phase as cps = smooth $ C.lpshold cps 0 phase as
loopsegBy :: D -> [Sig] -> Sig -> Sig
loopsegBy phase as cps = smooth $ C.loopseg cps 0 phase (fixEnd as)
loopxsegBy :: D -> [Sig] -> Sig -> Sig
loopxsegBy phase as cps = smooth $ C.loopxseg cps 0 phase (fixEnd as)
adsrSeq :: Sig -> Sig -> Sig -> Sig -> [Sig] -> Sig -> Sig
adsrSeq a d s r = linSeq (adsrList a d s r)
xadsrSeq :: Sig -> Sig -> Sig -> Sig -> [Sig] -> Sig -> Sig
xadsrSeq a d s r = expSeq (adsrList a d s r)
adsrSeq_ :: Sig -> Sig -> Sig -> Sig -> Sig -> [Sig] -> Sig -> Sig
adsrSeq_ a d s r rest = linSeq (adsrList_ a d s r rest)
xadsrSeq_ :: Sig -> Sig -> Sig -> Sig -> Sig -> [Sig] -> Sig -> Sig
xadsrSeq_ a d s r rest = expSeq (adsrList_ a d s r rest)
adsrList :: Sig -> Sig -> Sig -> Sig -> [Sig]
adsrList a d s r = [0, a, 1, d, s, 1 - (a + d + r), s, r, 0]
adsrList_ :: Sig -> Sig -> Sig -> Sig -> Sig -> [Sig]
adsrList_ a d s r rest = [0, a, 1, d, s, 1 - (a + d + r + rest), s, r, 0, rest, 0]
holdSeq :: [Sig] -> [Sig] -> Sig -> Sig
holdSeq = genSegSeq lpshold
linSeq :: [Sig] -> [Sig] -> Sig -> Sig
linSeq = genSegSeq loopseg
expSeq :: [Sig] -> [Sig] -> Sig -> Sig
expSeq = genSegSeq loopxseg
genSegSeq :: ([Sig] -> Sig -> Sig) -> [Sig] -> [Sig] -> Sig -> Sig
genSegSeq mkSeg shape weights cps = mkSeg (groupSegs $ fmap (scaleVals shape) weights) (cps / len)
where
len = sig $ int $ length weights
scaleVals xs k = case xs of
[] -> []
[a] -> [a * k]
a:da:rest -> (a * k) : da : scaleVals rest k
groupSegs :: [[Sig]] -> [Sig]
groupSegs as = concat $ intersperse [0] as
newtype Seq = Seq { unSeq :: [Seq1] }
data Seq1 = Rest {
seq1Dur :: Sig }
| Seq1 {
seq1Dur :: Sig
, seq1Val :: Sig
}
type instance DurOf Seq = Sig
instance Duration Seq where
dur (Seq as) = sum $ fmap seq1Dur as
instance Rest Seq where
rest t = Seq [Rest t]
instance Delay Seq where
del t a = mel [rest t, a]
instance Melody Seq where
mel as = Seq $ as >>= unSeq
instance Stretch Seq where
str t (Seq as) = Seq $ fmap (updateDur t) as
where updateDur k a = a { seq1Dur = k * seq1Dur a }
toSeq :: Sig -> Seq
toSeq a = Seq [Seq1 1 a]
onBeat :: Seq -> Seq
onBeat a = str (1 / dur a) a
onBeats :: Sig -> Seq -> Seq
onBeats k = str k . onBeat
instance Num Seq where
fromInteger n = toSeq $ fromInteger n
(+) = undefined
(*) = undefined
negate = undefined
abs = undefined
signum = undefined
instance Fractional Seq where
fromRational = toSeq . fromRational
(/) = undefined
seqGen0 :: ([Sig] -> Sig -> Sig) -> (Sig -> Sig -> [Sig]) -> [Seq] -> Sig -> Sig
seqGen0 loopFun segFun as = loopFun (renderSeq0 segFun $ mel as)
seqGen1 :: ([Sig] -> Sig -> Sig) -> (Sig -> Sig -> [Sig]) -> [Seq] -> Sig -> Sig
seqGen1 loopFun segFun as = loopFun (renderSeq1 segFun $ mel as)
simpleSeq0 loopFun = seqGen0 loopFun $ \dt val -> [val, dt]
simpleSeq1 loopFun = seqGen0 loopFun $ \dt val -> [val, dt]
seq0 = seqGen0 lpshold
seq1 = seqGen1 loopseg
seqx = seqGen1 loopxseg
seqConst :: [Seq] -> Sig -> Sig
seqConst = simpleSeq0 lpshold
seqLin :: [Seq] -> Sig -> Sig
seqLin = simpleSeq1 loopseg
seqExp :: [Seq] -> Sig -> Sig
seqExp = simpleSeq1 loopxseg
seqPw :: Sig -> [Seq] -> Sig -> Sig
seqPw k = seq0 $ \dt val -> [val, dt * k, 0, dt * (1 - k)]
iseqPw :: Sig -> [Seq] -> Sig -> Sig
iseqPw k = seq0 $ \dt val -> [0, dt * k, val, dt * (1 - k)]
seqSqr :: [Seq] -> Sig -> Sig
seqSqr = seqPw 0.5
iseqSqr :: [Seq] -> Sig -> Sig
iseqSqr = iseqPw 0.5
saw1 dt val = [val, dt, 0, 0]
isaw1 dt val = [0, dt, val, 0]
seqSaw :: [Seq] -> Sig -> Sig
seqSaw = seq1 saw1
iseqSaw :: [Seq] -> Sig -> Sig
iseqSaw = seq1 isaw1
xseqSaw :: [Seq] -> Sig -> Sig
xseqSaw = seqx saw1
ixseqSaw :: [Seq] -> Sig -> Sig
ixseqSaw = seqx isaw1
seqRamp :: Sig -> [Seq] -> Sig -> Sig
seqRamp k = seq1 $ \dt val -> [val, k * dt, 0, (1 - k) * dt, 0, 0]
iseqRamp :: Sig -> [Seq] -> Sig -> Sig
iseqRamp k = seq1 $ \dt val -> [0, k * dt, val, (1 - k) * dt, 0, 0]
seqTri :: [Seq] -> Sig -> Sig
seqTri = seqTriRamp 0.5
seqTriRamp :: Sig -> [Seq] -> Sig -> Sig
seqTriRamp k = seq1 $ \dt val -> [0, dt * k, val, dt * (1 - k)]
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 ]
seqAdsr :: Sig -> Sig -> Sig -> Sig -> [Seq] -> Sig -> Sig
seqAdsr a d s r = seq1 (adsr1 a d s r)
xseqAdsr :: Sig -> Sig -> Sig -> Sig -> [Seq] -> Sig -> Sig
xseqAdsr a d s r = seqx (adsr1 a d s r)
seqAdsr_ :: Sig -> Sig -> Sig -> Sig -> Sig -> [Seq] -> Sig -> Sig
seqAdsr_ a d s r rest = seq1 (adsr1_ a d s r rest)
xseqAdsr_ :: Sig -> Sig -> Sig -> Sig -> Sig -> [Seq] -> Sig -> Sig
xseqAdsr_ a d s r rest = seqx (adsr1_ a d s r rest)
renderSeq0 :: (Sig -> Sig -> [Sig]) -> Seq -> [Sig]
renderSeq0 f (Seq as) = as >>= phi
where
phi x = case x of
Seq1 dt val -> f dt val
Rest dt -> [0, dt]
renderSeq1 :: (Sig -> Sig -> [Sig]) -> Seq -> [Sig]
renderSeq1 f (Seq as) = as >>= phi
where
phi x = case x of
Seq1 dt val -> f dt val
Rest dt -> [0, dt, 0, 0]
genSeqPat :: (Int -> [Double]) -> [Int] -> Seq
genSeqPat g ns = mel (ns >>= f)
where f n
| n <= 0 = []
| n == 1 = [1]
| otherwise = fmap (toSeq . sig . double) $ g n
seqPat :: [Int] -> Seq
seqPat ns = mel (ns >>= f)
where f n
| n <= 0 = []
| n == 1 = [1]
| otherwise = [1, rest $ sig $ int $ n - 1]
rowDesc n = [1, 1 - recipN .. recipN ]
where recipN = 1/ fromIntegral n
seqDesc :: [Int] -> Seq
seqDesc = genSeqPat rowDesc
seqAsc :: [Int] -> Seq
seqAsc = genSeqPat (\n -> let xs = rowDesc n in head xs : reverse (tail xs))
seqHalf :: [Int] -> Seq
seqHalf = genSeqPat $ (\n -> 1 : take (n - 1) (repeat 0.5))
hval :: HumanizeValue a => Sig -> a -> HumanizeValueOut a
hval = humanVal
htime :: HumanizeTime a => Sig -> a -> HumanizeTimeOut a
htime = humanTime
hvalTime :: HumanizeValueTime a => Sig -> Sig -> a -> HumanizeValueTimeOut a
hvalTime = humanValTime
class HumanizeValue a where
type HumanizeValueOut a :: *
humanVal :: Sig -> a -> HumanizeValueOut a
rndVal :: Sig -> Sig -> Sig -> SE Sig
rndVal cps dr val = fmap (+ val) $ randh dr cps
rndValD :: Sig -> D -> SE D
rndValD dr val = fmap (+ val) $ random (- (ir dr)) (ir dr)
instance HumanizeValue ([Seq] -> Sig -> Sig) where
type HumanizeValueOut ([Seq] -> Sig -> Sig) = [Seq] -> Sig -> SE Sig
humanVal dr f = \sq cps -> fmap (\x -> f x cps) (mapM (humanSeq cps) sq)
where
humanSeq cps (Seq as) = fmap Seq $ forM as $ \x -> case x of
Rest _ -> return x
Seq1 dt val -> fmap (Seq1 dt) $ rndVal cps dr val
instance HumanizeValue ([Sig] -> Sig -> Sig) where
type HumanizeValueOut ([Sig] -> Sig -> Sig) = [Sig] -> Sig -> SE Sig
humanVal dr f = \sq cps -> fmap (\x -> f x cps) (mapM (humanSig cps) sq)
where humanSig cps val = rndVal cps dr val
instance HumanizeValue ([D] -> Sig) where
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
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
class HumanizeTime a where
type HumanizeTimeOut a :: *
humanTime :: Sig -> a -> HumanizeTimeOut a
instance HumanizeTime ([Seq] -> Sig -> Sig) where
type HumanizeTimeOut ([Seq] -> Sig -> Sig) = [Seq] -> Sig -> SE Sig
humanTime dr f = \sq cps -> fmap (\x -> f x cps) (mapM (humanSeq cps) sq)
where
humanSeq cps (Seq as) = fmap Seq $ forM as $ \x -> case x of
Rest dt -> fmap Rest $ rndVal cps dr dt
Seq1 dt val -> fmap (flip Seq1 val) $ rndVal cps dr dt
instance HumanizeTime ([D] -> Sig) where
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
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
class HumanizeValueTime a where
type HumanizeValueTimeOut a :: *
humanValTime :: Sig -> Sig -> a -> HumanizeValueTimeOut a
instance HumanizeValueTime ([Seq] -> Sig -> Sig) where
type HumanizeValueTimeOut ([Seq] -> Sig -> Sig) = [Seq] -> Sig -> SE Sig
humanValTime drVal drTime f = \sq cps -> fmap (\x -> f x cps) (mapM (humanSeq cps) sq)
where
humanSeq cps (Seq as) = fmap Seq $ forM as $ \x -> case x of
Rest dt -> fmap Rest $ rndVal cps drTime dt
Seq1 dt val -> liftA2 Seq1 (rndVal cps drTime dt) (rndVal cps drVal val)
instance HumanizeValueTime ([D] -> Sig) where
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
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
trigTab :: Tab -> Sig -> Sig -> Sig
trigTab ifn kdur ktrig =
tablei (lineto ktrig (kdur * delay1 ktrig)) ifn `withD` 1
trigTabEvt :: Tab -> Sig -> Evt a -> Sig
trigTabEvt ifn kdur ktrig = trigTab ifn kdur (evtToTrig ktrig)