Sam Danielson

As part of my effort to seek enlightenment through Haskell I’ve made some music. It’s actually sort of neat creating a waveform that when played through a DA resembles something other than white noise. This isn’t controlling a sequencer – it’s just composing functions to make make a sound representation. It’s a lot like naive ray tracing where all objects are considered for each pixel in that for each sample I sum the waveforms for all notes, many of which are zero since a note only plays for a short duration and is otherwise silent.

Notes are made by transforming a sound frequency Signal (Double -> Double) with pitch and amplitude Shifters (Signal -> Signal). For the note envelope I create a signal that represents amplitude and modulate the sound signal with the amp combinator, which is a Modulator (Signal -> Signal -> Signal).

One thing missing from this implementation is the ability to write (signal = signal1 + signal2). I now would write (signal t = signal1 t + signal2 t,) since a signal is a function over time. mauke in #haskell (irc.freenode.net) was helpful but I still don’t understand why some things work the way they do so I chose not to write a (+) instance for signals until I understand it better. The following will play a few measures of Mozart’s something something as I remember it. I forgot what it’s called but it’s in C and it’s popular.

Here’s an ogg vorbis of the output: mozart.ogg

And the illiterate Haskell.

-- Compile and listen as follows
-- ghc -o mozart mozart.hs && ./mozart | mplayer -v -rawaudio rate=16000:channels=1:samplesize=1 -demuxer rawaudio -

import System.IO
import Data.Char

type Signal = Double -> Double
type Shifter = Signal -> Signal
type Modulator = Signal -> Signal -> Signal

main :: IO ()
main = putStr . toBytes . take 200000 . sample 16000 $ sound

sound :: Signal
sound = ampc 0.35 . shifterSum song . pitchc (440 * hstep ** 3 * 2 * pi) $ wave

song :: [Shifter]
song = zipWith (\e p -> amp e . pitchc p) (lhEnvs ++ rhEnvs) (lhPitches ++ rhPitches)

wave :: Signal
wave = flange (\x -> sin (x * 2)) sin

lhPitches :: [Double]
lhPitches = map (* (1/2)) $ [du,so,me,so,du,so,me,so,re,so,fa,so,du,so,me,so] ++
                            [du,la,fa,la,du,so,me,so,re,so,fa,so,du,so,me,so]
lhBegins :: [Double]
lhBegins = take 32 $ toTempo [1..]

-- Applies 0.1 second duration to left hand begin times
-- resulting in a list of complete amplitude envelopes
-- for each note.
lhEnvs :: [Signal]
lhEnvs = map (pianoEnv 0.1) lhBegins

rhPitches :: [Double]
rhPitches = [du,me,so,ti/2,du,re,du,  la,so,du*2,so,fa,me]
rhBegins :: [Double]
rhBegins = toTempo [1,5,7,9,12,12.5,13, 17,21,23,25,28,29]
rhEnvs :: [Signal]
rhEnvs = map (pianoEnv 0.5) rhBegins

-- attack decay sustain release to resemble a piano
-- apply duration and begin for complete envelope signal
pianoEnv :: Double -> Double -> Signal
pianoEnv = env 0.005 0.05 0.4 0.7

-- eigth note tempo
tempo = 160
toTempo :: [Double] -> [Double]
toTempo ts = map (\t -> 60 * t / tempo) ts

-- Sums list of signal shifters and mutes the original signal
shifterSum :: [Shifter] -> Shifter
shifterSum xs = foldr (shifterAdd) (const . const 0) xs

shifterAdd :: Shifter -> Shifter -> Shifter
shifterAdd a b input t = a input t + b input t

-- 1        b
--         / \c_____d
--        /          \
-- 0 ___a/            \e___   Makes an amplitude envelope for a note
--
-- Will div by zero in some cases.
env :: Double -> Double -> Double -> Double -> Double -> Double -> Signal
env attack decay sustain release duration begin t
    | t < a || t >= e = 0
    | t < b           = (t - a) / attack
    | t < c           = 1 - (1 - sustain) * (t - b) / decay
    | t < d           = sustain
    | t < e           = sustain - sustain * (t - d) / release
    where a = begin
          b = a + attack
          c = b + decay
          d = c + duration
          e = d + release

sample :: Double -> Signal -> [Double]
sample rate signal = [signal (t / rate) | t <- [0..]]

-- yuck
toBytes :: [Double] -> [Char]
toBytes = fmap $ chr . clamp 0 255 . (\n -> truncate $ (n + 1) * 127)

clamp min max x
    | x < min = min
    | x > max = max
    | otherwise = x

pitchc :: Double -> Signal -> Signal
pitchc mult input t = input (t * mult)

ampc :: Double -> Signal -> Signal
ampc mult input t = mult * (input t)

amp :: Modulator
amp control input t = (control t) * (input t)

-- only works for control where d/dt = 0
pitch :: Modulator
pitch control input t = input (t * control t)

flange :: Modulator
flange ff w t = w (t + ff t)

hstep = 2 ** (1/12)
du = hstep ** 0
re = hstep ** 2
me = hstep ** 4
fa = hstep ** 5
so = hstep ** 7
la = hstep ** 9
ti = hstep ** 11