exe/Main.hs

   1 {-# LANGUAGE DataKinds #-}
   2
   3 import Data.List (unfoldr)
   4 import LambdaSound
   5 import System.Random
   6
   7 import qualified Deque.Strict as DQ
   8
   9 karplusStrong
  10   :: (StdGen -> Maybe (Pulse, StdGen)) -- ^ how to initialize each entry of the initial buffer
  11   -> (StdGen -> Pulse -> Pulse -> (Pulse, StdGen)) -- ^ slide step
  12   -> Int -- ^ sample rate
  13   -> (Hz -> Sound 'I Pulse) -- ^ instrument
  14 karplusStrong genPulse f sampleRate freq =
  15   let -- we generate s[0], ..., s[T-1]
  16       waveTable = take waveTableLen $ unfoldr genPulse gen
  17       -- construct our deque with those elements
  18       deque0 = DQ.fromConsAndSnocLists waveTable []
  19       -- sliding function
  20       slide (dq, g) = case DQ.uncons dq of
  21         Just (a, as)
  22           | Just a' <- DQ.head as ->
  23               let (new_a, g') = f g a a' in
  24                 (a, (DQ.snoc new_a as, g'))
  25         _ -> error "welp"
  26   in unfoldrSoundPulse slide (deque0, gen)
  27
  28   where waveTableLen = floor (fromIntegral sampleRate / freq) :: Int
  29         gen = mkStdGen 142
  30
  31 main :: IO ()
  32 main = do
  33   let sampleRate = 44100
  34
  35       attenuate a b = 0.995*(a+b)/2
  36       centeredPulse g = case randomR (-0.5, 0.5) g of
  37           (a, g') -> Just (Pulse a, g')
  38
  39       guitar = karplusStrong centeredPulse (\_gen a a' -> (attenuate a a', _gen)) sampleRate
  40       snare = karplusStrong (\g -> Just (0.5, g))
  41         (\gen a a' -> case random gen of
  42             (b, gen') ->
  43               let v = attenuate a a'
  44               in (if b then v else negate v, gen')
  45         ) sampleRate
  46
  47       -- guitar sounds
  48       sound1 = setDuration 2 $ asNote guitar a3
  49       sound2 = simpleReverb 0.01 sound1
  50       sound3 = setDuration 2 $ parallel [ asNote guitar x | x <- [c3, e3, g3] ]
  51       sound4 = simpleReverb 0.01 sound3
  52
  53       -- drum sound
  54       sound5 = setDuration 0.3 $ asNote snare a3
  55
  56       -- demo piece
  57       sound6 =
  58         let gtrLoop =
  59               [ ([c3, g3], [c4, d4+1])
  60               , ([a2+1, g3], [c4, d4+1])
  61               , ([g2+1, f3], [g4, f4])
  62               , ([f2, d3+1], [f4, d4+1])
  63               ]
  64             gtr = repeatSound 2 $ sequentially
  65               [ repeatSound 4 $ parallel
  66                 -- we play the notes from 'l' in parallel, followed by the
  67                 -- notes from 'r' in sequence
  68                 [ setDuration 0.9 (parallel [ asNote guitar x | x <- l ])
  69                 , setDuration 0.3 silence >>> sequentially (map (setDuration 0.3 . asNote guitar) r)
  70                 ]
  71               | (l, r) <- gtrLoop
  72               ]
  73             dr1 = repeatSound 48 (setDuration 0.6 sound5)
  74             dr2 = repeatSound 96 (reduce 0.8 sound5)
  75             dr3 = repeatSound 32 (amplify 1.2 $ setDuration 0.75 silence >>> setDuration 0.15 sound5)
  76         in setDuration 2 silence >>> parallel [gtr, dr1, dr2, dr3]
  77
  78       -- all the sounds from this post
  79       sounds = [sound1, sound2, sound3, sound4, sound5, sound6]
  80
  81   mapM_ (play sampleRate 1) sounds
  82   sequence_ [ saveWav ("karplus_strong_" ++ show n ++ ".wav") (fromIntegral sampleRate) s | (n, s) <- zip [(1 :: Int)..] sounds ]