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