hsc3-graphs-0.11: src/acid-otophilia.hs
-- 08091500Acid309 by_otophilia
import Data.List
import Data.Maybe
import Sound.OpenSoundControl {- hosc -}
import Sound.SC3.ID {- hsc3 -}
import System.Random {- random -}
-- * Instruments
mk_ec :: [UGen] -> [EnvCurve]
mk_ec = map EnvNum
mk_env :: [UGen] -> [UGen] -> [UGen] -> [UGen]
mk_env l t c = env l t (mk_ec c) 0 0
kick :: Synthdef
kick =
let bus = control KR "outBus" 0
env0 = let d = mk_env [0.5,1,0.5,0] [0.005,0.06,0.26] [-4,-2,-4]
in envGen AR 1 1 0 1 RemoveSynth d
env1 = let d = mk_env [110,59,29] [0.005,0.29] [-4,-5]
in midiCPS (envGen AR 1 1 0 1 DoNothing d)
s = let p = lfPulse AR env1 0 0.5 - 0.5
q = p + mce2 (whiteNoise 'a' AR) (whiteNoise 'b' AR)
r = lpf q (env1 * 1.5) * env0
in clip2 (r + sinOsc AR env1 0.5 * env0 * 1.2) 1
in synthdef "kick" (out bus s)
snare :: Synthdef
snare =
let bus = control KR "outBus" 0
amp = control KR "amp" 0.8
env0 = let d = mk_env [0.5,1,0.5,0] [0.005,0.03,0.10] [-4,-2,-4]
in envGen AR 1 1 0 1 DoNothing d
env1 = let d = mk_env [110,60,49] [0.005,0.1] [-4,-5]
in midiCPS (envGen AR 1 1 0 1 DoNothing d)
env2 = let d = mk_env [1,0.4,0] [0.05,0.13] [-2,-2]
in envGen AR 1 1 0 1 RemoveSynth d
oscs = let p = lfPulse AR env1 0 0.5 - 0.5
q = lfPulse AR (env1 * 1.6) 0 0.5 * 0.5 - 0.25
r = lpf (p + q) (env1 * 1.2) * env0
in r + sinOsc AR env1 0.8 * env0
noise = let p = mce2 (whiteNoise 'a' AR) (whiteNoise 'b' AR) * 0.2
q = hpf p 200 * 2
r = bpf q 6900 0.6 * 3 + p
in r * env2
s = clip2 (oscs + noise) 1 * amp
in synthdef "snare" (out bus s)
clap :: Synthdef
clap =
let bus = control KR "outBus" 0
amp = control KR "amp" 0.5
env1 = let d = mk_env [0,1,0,1,0,1,0,1,0]
[0.001,0.013,0,0.01,0,0.01,0,0.03]
[0,-3,0,-3,0,-3,0,-4]
in envGen AR 1 1 0 1 DoNothing d
env2 = let d = mk_env [0,1,0] [0.02,0.3] [0,-4]
in envGen AR 1 1 0 1 RemoveSynth d
noise1 = let p = mce2 (whiteNoise 'a' AR) (whiteNoise 'a' AR) * env1
q = hpf p 600
in bpf q 2000 3
noise2 = let p = mce2 (whiteNoise 'a' AR) (whiteNoise 'a' AR) * env2
q = hpf p 1000
in bpf q 1200 0.7 * 0.7
s = let p = noise1 + noise2
in softClip (p * 2) * amp
in synthdef "clap" (out bus s)
hat :: Synthdef
hat =
let bus = control KR "outBus" 0
amp = control KR "amp" 0.3
env1 = let d = mk_env [0,1.0,0] [0.001,0.2] [0,-12]
in envGen AR 1 1 0 1 DoNothing d
env2 = let d = mk_env [0,1.0,0.05,0] [0.002,0.05,0.03] [0,-4,-4]
in envGen AR 1 1 0 1 RemoveSynth d
(r0:r1:r2:_) = randomRs (-4.0,4.0) (mkStdGen 5)
oscs1 = let n1 = 5
f i = let f0 = midiCPS (linLin i 0 (n1-1) 42 75 + r0)
f1 = midiCPS (linLin i 0 (n1-1) 78 80 + r1)
in sinOsc AR f0 (sinOsc AR f1 0 * 12) * (1/n1)
p = sum (map f [0..n1-1])
in bHiPass p 1000 2 * env1
noise = let n2 = 8
p = whiteNoise 'a' AR
f i = let t = 1 / midiCPS (linLin i 0 (n2-1) 40 50 + r2)
in combN p 0.05 t 0.1
q = sum (map f [0..n2-1]) * (1/n2) + p
r = bpf q 6000 0.9 * 0.5 + q
in bHiPass (bLowShelf r 3000 0.5 (-6)) 1000 1.5 * env2
s = softClip (noise + oscs1) * amp
in synthdef "hat" (out bus s)
acid :: Synthdef
acid =
let bus = control KR "outBus" 0
gate' = control KR "gate" 1
pitch' = control KR "pitch" 50
amp = control KR "amp" 0.3
pitch'' = lag pitch' 0.12 * (1 - trig gate' 0.001) * gate'
env1 = let d = env [0,1,0,0] [0.001,2,0.04] (mk_ec [0,-4,-4]) 2 0
in envGen AR gate' amp 0 1 DoNothing d
env2 = let d = envADSR 0.001 0.8 0 0.8 70 (EnvNum (-4)) 0
in envGen AR gate' 1 0 1 DoNothing d
s = let p = lfPulse AR (midiCPS pitch'') 0.0 0.51 * 2 - 1
q = rlpf p (midiCPS (pitch'' + env2)) 0.3
in q * env1
in synthdef "acid" (out bus (mce2 s s))
fx :: Synthdef
fx =
let bus = control KR "outBus" 0
gate' = control KR "gate" 0
i = in' 2 AR bus
e = let d = env [0.02,0.3,0.02] [0.4,0.01] (mk_ec [3,-4]) 1 0
in envGen KR (1 - trig gate' 0.01) 1 0 1 DoNothing d
r = let MCE [i0,i1] = i
in freeVerb2 (bpf i0 3500 1.5) (bpf i1 3500 1.5) 1 0.95 0.15 * e
s = limiter (hpf ((i + r) * 1.2) 40) 1 0.02
in synthdef "fx" (replaceOut bus s)
-- * Sequences
type D = [Int]
dr_seq :: Num a => [[[a]]]
dr_seq =
let s = [[[1,0,0,0, 0,0,0,0, 1,0,0,1, 0,0,1,0]
,[0,0,0,0, 0,0,0,2, 0,2,1,0, 4,3,3,3]
,[0,0,0,0, 4,0,0,0, 0,0,0,0, 4,0,0,0]
,[1,2,4,0, 1,0,4,0, 1,2,4,2, 1,0,4,2]
,[1,0,0,0, 1,0,0,0, 1,0,0,0, 1,0,0,0]]
,[[0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0]
,[0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0]
,[0,0,0,0, 4,0,0,0, 0,0,0,0, 4,0,0,0]
,[1,2,4,0, 1,0,4,0, 1,2,4,2, 1,0,4,2]
,[1,0,0,0, 1,0,0,0, 1,0,0,0, 1,0,0,0]]
,[[1,0,0,0, 1,0,0,0, 1,0,0,0, 1,0,0,0]
,[0,0,0,0, 0,0,0,2, 0,0,0,0, 0,0,0,0]
,[0,0,0,0, 4,0,0,0, 0,0,0,0, 4,0,0,0]
,[1,2,4,0, 1,0,4,0, 1,2,4,2, 1,0,4,2]
,[1,0,0,0, 1,0,0,0, 1,0,0,0, 1,0,0,0]]
,[[1,0,0,0, 1,0,0,0, 1,0,0,0, 1,0,0,0]
,[0,0,0,0, 4,0,0,2, 0,0,0,0, 4,0,0,0]
,[0,0,0,0, 0,0,0,0, 0,0,0,0, 4,0,0,0]
,[1,2,4,0, 1,0,4,0, 1,2,4,2, 1,0,4,2]
,[1,0,0,0, 1,0,0,0, 1,0,0,0, 1,0,0,0]]]
in map transpose s
dr_msg :: Int -> (Int,Int) -> Maybe OSC
dr_msg fx_id (i,x) =
let m nm pr = Just (s_new nm (-1) AddToHead 1 pr)
x' = fromIntegral x
sq n = n * n
in case i of
0 -> if x > 0 then m "kick" [] else Nothing
1 -> if x > 0 then m "snare" [("amp",sq (x'/4) * 0.7)] else Nothing
2 -> if x > 0 then m "clap" [("amp",sq (x'/4) * 0.5)] else Nothing
3 -> if x > 0 then m "hat" [("amp",sq (x'/4) * 0.32)] else Nothing
4 -> Just (n_set fx_id [("gate",x')])
_ -> error "dr_seq_msg"
dr_seq_msg :: Int -> Double -> D -> OSC
dr_seq_msg fx_id t =
Bundle (UTCr t) .
mapMaybe (dr_msg fx_id) .
zip [0..]
b_seq :: Num a => [[a]]
b_seq =
let s = [[1,1,1,1, 1,1,1,1, 0,1,0,1, 1,1,1,0]
,[1,1,0,2, 1,1,0,0, 2,0,2,0, 1,2,0,4]
,map (+ 38) [-24,-12,0,-12, 0,-12,10,12, 0,7,-7,0, -11,1,13,15]]
in transpose s
type B = (Int,Double,Double)
b_form :: [Int] -> B
b_form xs =
let i = fromIntegral
in case xs of
[b1,b2,b3] -> (b1,i b2,i b3)
_ -> error "b_form"
b_seq_msg :: Int -> Double -> Double -> B -> [OSC]
b_seq_msg acid_id dt t (b0,b1,b2) =
let on = let p = n_set acid_id [("pitch",b2)]
m = if b0 == 1
then [p,n_set acid_id [("gate",1)]]
else [p]
in Bundle (UTCr t) m
off = let end_t = t + (dt * b1 * 0.25 * 0.99)
in Bundle (UTCr end_t) [n_set acid_id [("gate",0)]]
in if b1 > 0 then [on,off] else [on]
-- * Runtime
ao_init :: Transport t => t -> IO (Int,Int)
ao_init fd = do
let i = [kick,snare,clap,hat,acid,fx]
_ <- async fd (Bundle immediately (map d_recv i))
let acid_id = 10
fx_id = 11
send fd (s_new "acid" acid_id AddToHead 1 [("gate",0)])
send fd (s_new "fx" fx_id AddToTail 1 [])
return (acid_id,fx_id)
dt_seq :: Double -> [Double]
dt_seq bpm =
let shf = 0.16
n = 60 / bpm
dt i = if i `mod` 2 == 0 then 0.25 * (1 + shf) else 0.25 * (1 - shf)
in map ((* n) . dt) ([0..]::[Int])
ao_run_seq :: Transport t => t -> (Int,Int) -> [D] -> [B] -> IO ()
ao_run_seq fd (acid_id,fx_id) d_sq b_sq = do
init_t <- utcr
let dt_seq' = dt_seq 130
t_seq = scanl1 (+) (init_t : dt_seq')
act (t,dt,d,b) =
do send fd (dr_seq_msg fx_id t d)
mapM_ (send fd) (b_seq_msg acid_id dt t b)
pauseThreadUntil t
mapM_ act (zip4 t_seq dt_seq' d_sq b_sq)
main :: IO ()
main =
let act fd = do
let d_sq = cycle (concat dr_seq)
b_sq = map b_form (cycle b_seq)
ids <- ao_init fd
ao_run_seq fd ids d_sq b_sq
in withSC3 act