module Exercise06 where import Data.List (maximumBy, transpose) import Data.Array.Unboxed (listArray, array, IArray, UArray, (!)) import Data.Fixed ( mod' ) import Data.Maybe ( fromJust, isJust ) import Data.Function ( on ) -- for debugging import Text.Printf (printf) import Effects (addGain, clip, distortion, addEffects) import Types (DSPEffect, sampleRate, Sample, ADSR, Oscillator, Note, Semitone, Hz, SampledSignal, Signal, Seconds ) import Control.Applicative (Applicative(liftA2)) {-MCCOMMENT Not really sure what to include in tags so I included it all. Since I used unsafeIO (as discussed in Zulip) to read in some samples, that code needs to uncommented (it can't be submitted on Artemis). Search for MCCOMMENT unsafeIO for the start and end of those comments, there are a total of two blocks, the first one being directly below this comment. You should be able to just delete all lines containing "MCCOMMENT unsafeIO" and it should just work! (regex replace .*MCCOMMENT unsafeIO.*\n with the empty string) The other regular MCCOMMENT below has all the other relevant information. -} {- WETT -} import GHC.IO (unsafePerformIO) sinPeriod :: Signal sinPeriod t | 0 <= t && t <= 1 = sin $ 2 * pi * t triPeriod :: Signal triPeriod t | 0 <= t && t <= 1 = 1 - (4 * abs (t - 0.5)) sawPeriod :: Signal sawPeriod t | 0 <= t && t <= 1 = 2 * t - 1 sqwPeriod :: Signal sqwPeriod 0.5 = 1 sqwPeriod t | 0 <= t && t <= 1 = signum $ t - 0.5 silence :: Signal silence = const 0 -- NOTE: the formula is taken from https://pages.mtu.edu/~suits/NoteFreqCalcs.html f :: Semitone -> Hz f n = 440.0 * (2 ** (fromInteger n / 12.0)) -- i wrote a pointfree version but im scared theres a mistake -- f :: Semitone -> Hz -- f = (*440.0) . (2**) . (/12.0) . fromInteger tone :: Signal -> Semitone -> Signal tone periodSignal semitone t = let freq = f semitone in periodSignal $ freq * mod' t (1 / freq) osc :: Signal -> ADSR -> Oscillator osc periodSignal adsrValues semitone duration = adsr adsrValues duration (tone periodSignal semitone) adsrError :: ADSR -> Seconds -> Maybe String adsrError (attack, decay, sustain, release) duration | attack <= 0 = Just "attack must be > 0" | decay <= 0 = Just "decay must be > 0" | release <= 0 = Just "release must be > 0" | attack + decay + release > duration = Nothing --Just "duration too small for given A/D/R" | sustain < 0 || 1 < sustain = Just "sustain must be in range [0, 1], inclusive" | otherwise = Nothing adsrEnvelopeShort :: ADSR -> Seconds -> Signal adsrEnvelopeShort (attack, decay, sustain, release) duration t = adsrEnvelope (attack, decay, sustain, release) newDuration (t * newDuration / duration) where newDuration = attack + decay + release adsrEnvelope :: ADSR -> Seconds -> Signal adsrEnvelope values duration _ | isJust err = error $ fromJust err where err = adsrError values duration adsrEnvelope (attack, decay, sustain, release) duration t -- the special short envelope avoids popping on short notes | duration < attack + decay + release = adsrEnvelopeShort (attack, decay, sustain, release) duration t | t <= attack = t / attack | t <= attack + decay = 1 + (t - attack) * (sustain - 1) / decay | t <= duration - release = sustain | t <= duration = sustain * (duration - t) / release | t >= 0 = 0 adsr :: ADSR -> Seconds -> Signal -> Signal adsr adsrValues duration baseSignal = liftA2 (*) baseSignal (adsrEnvelope adsrValues duration) mix :: [SampledSignal] -> SampledSignal mix sss | not $ null sss = map ((/signalCount) . sum) $ transpose sss where signalCount = fromIntegral $ length sss -- INTSTRUMENTS/OSCILLATORS piano :: Oscillator piano = osc sinPeriod (0.01, 0.1, 0.7, 0.2) lead :: Oscillator lead = osc sqwPeriod (0.01, 0.2, 0.3, 0.1) bass :: Oscillator bass = osc sinPeriod (0.001, 0.2, 0.9, 0.1) silenceOsc :: Oscillator silenceOsc _ _ = const 0 interpolate :: Num a => a -> a -> a -> a interpolate from to v = from + v * (to - from) -- create an "oscillator" by using the given sampled note as a base, -- other semitones are just a stretch/compression of the given sample (not perfect but good enough) oscFromSample :: Semitone -> SampledSignal -> Oscillator oscFromSample baseSemitone ss = sampleOsc where sampleCount = length ss baseFreq = f baseSemitone -- keeping all the samples in an array is necessary to get any kind of performance (it actually performs pretty well) sampleArray = Data.Array.Unboxed.listArray (0, sampleCount - 1) ss :: Data.Array.Unboxed.UArray Int Double sampleOsc semitone duration t | sampleIndex1 < 0 || sampleIndex2 >= sampleCount = 0 | sampleIndex1 == sampleIndex2 = sampleArray ! sampleIndex1 -- interpolate between two adjacent samples goes a long way to reduce buzz/whistle | otherwise = interpolate (sampleArray ! sampleIndex1) (sampleArray ! sampleIndex2) (samplePos - fromIntegral sampleIndex1) where noteFreq = f semitone samplePos = noteFreq * t * sampleRate / baseFreq sampleIndex1 = floor samplePos sampleIndex2 = ceiling samplePos fadeOut :: Seconds -> Seconds -> Signal fadeOut fadeDuration noteDuration t | t <= noteDuration - fadeDuration = 1.0 | t >= noteDuration = 0.0 | otherwise = (noteDuration - t) / fadeDuration readSample :: String -> IO SampledSignal readSample fName = do fContent <- readFile fName return $ map read $ lines fContent -- so that I don't have to remember this crazy long type signature every time type Synth = (Oscillator -> [Note] -> SampledSignal) -> [[Note]] -> SampledSignal --notesToSignal :: Synth -- MCCOMMENT unsafeIO --notesToSignal = undefined -- MCCOMMENT unsafeIO {-# NOINLINE readSampleUnsafe #-} -- i plan to remove the unsafe io, but im kinda lazy so idk readSampleUnsafe :: String -> SampledSignal readSampleUnsafe fName = unsafePerformIO $ readSample fName -- these samples were generated with Audacity and exported with Tools > Sample Data Export -- a sampled piano -- free from http://theremin.music.uiowa.edu/MISpiano.html, courtesy of University of Iowa piano2 :: Oscillator piano2 st duration t = fadeOut 0.1 duration t * piano2osc st duration t where piano2osc = oscFromSample (-9) (normalize $ readSampleUnsafe "samples/piano_c4.sample") -- an ocarina seemed fitting -- free from https://freewavesamples.com/alesis-fusion-ocarina-c5, courtesy of Jason Champion ocarina :: Oscillator ocarina st duration t = fadeOut 0.1 duration t * ocarinaOsc st duration t where ocarinaOsc = oscFromSample 3 (normalize $ readSampleUnsafe "samples/ocarina_c5_long.sample") -- a bell -- free from https://freewavesamples.com/korg-tr-rack-tinkle-bells-c6, courtesy of Jason Champion tinkleBell :: Oscillator tinkleBell st duration t = fadeOut 0.1 duration t * tinkleBellOsc st duration t where tinkleBellOsc = oscFromSample 15 (readSampleUnsafe "samples/bell_c6.sample") -- a guitar -- free from https://freewavesamples.com/alesis-fusion-nylon-string-guitar-c4, courtesy of Jason Champion guitarNylon :: Oscillator guitarNylon st duration t = fadeOut 0.1 duration t * guitarNylonOsc st duration t where guitarNylonOsc = oscFromSample (-9) (readSampleUnsafe "samples/guitar_nylon_c4.sample") -- a trumpet -- free from https://freewavesamples.com/e-mu-proteus-fx-echotpt-c5, courtesy of Jason Champion trumpet :: Oscillator trumpet st duration t = fadeOut 0.1 duration t * trumpetOsc st duration t where trumpetOsc = oscFromSample 3(readSampleUnsafe "samples/trumpet_c5.sample") -- FILTERS -- comb, allPass and reverb adapted from https://medium.com/the-seekers-project/coding-a-basic-reverb-algorithm-part-2-an-introduction-to-audio-programming-4db79dd4e325 -- Uses a Schroeder Reverberator. I don't claim to fully understand everything going on :p -- comb: y[n] = x[n] + d*y[n−K] comb :: Double -> Int -> DSPEffect comb decayFactor delaySamples samples = start ++ comb' start rem where (start, rem) = splitAt delaySamples samples comb' _ [] = [] comb' prevBlock remainingSamples = combedBlock ++ comb' combedBlock (drop delaySamples remainingSamples) where combedBlock = zipWith (\p c -> c + p * decayFactor) prevBlock remainingSamples -- allPass: y[n] = (−d*x[n]) + x[n−K] + (d*y[n−K]) -- doesn't seem to work properly allPass :: Double -> Int -> DSPEffect allPass decayFactor delaySamples samples = {- drop delaySamples $ -} {- start ++ -} ap' start start rem where (start, rem) = splitAt delaySamples samples ap' _ _ [] = [] ap' prevOut prevIn remainingSamples = passedBlock ++ (uncurry $ ap' passedBlock) (splitAt delaySamples remainingSamples) where passedBlock = zipWith3 (\px py x -> (- decayFactor * x) + px + (decayFactor * py)) prevIn prevOut remainingSamples identityFilter :: DSPEffect identityFilter = id normalize :: DSPEffect normalize samples = map (* scale) samples where scale = abs $ 1 / maximumBy (compare `on` abs) samples parallelEffects :: [(DSPEffect, Double)] -> DSPEffect parallelEffects effectsVolumes = mix . zipWith (\(eff, vol) ss -> map (* vol) $ eff ss) effectsVolumes . repeat msToSamples :: Seconds -> Int msToSamples = round . (/ 1000) . (* sampleRate) -- this reverb is supposed to have two all pass filters out the back, but mine don't seem to work quite right -- and produce a "roll" at the start of each note, as each all pass filter "starts up" -- honestly the reverb is ok without it so I just dropped the all pass filters standardReverb :: Seconds -> Double -> Double -> DSPEffect standardReverb rd df w = normalize . {- allPass1 . allPass1 . -} wetMixParallelComb where reverbDelay = msToSamples rd -- in samples decayFactor = df wet = w allPassDf = 0.131 allPassDelay = msToSamples 90 comb1 = comb decayFactor reverbDelay comb2 = comb (decayFactor - 0.1313) (reverbDelay - msToSamples 11.73) comb3 = comb (decayFactor - 0.2743) (reverbDelay + msToSamples 19.31) comb4 = comb (decayFactor - 0.31) (reverbDelay - msToSamples 7.97) parallelComb = parallelEffects $ zip [comb1, comb2, comb3, comb4] [1, 1, 1, 1] wetMixParallelComb = parallelEffects [(identityFilter, 1 - wet), (parallelComb, wet)] -- allPass1 = allPass allPassDf allPassDelay -- mix the signals with some volume mixTracks :: [SampledSignal] -> [Double] -> SampledSignal mixTracks trks vols = mix $ zipWith (\trk vol -> map (* vol) trk) trks vols -- here we mix it all together and apply the effects notesToSignal :: Synth -- (Oscillator -> [Note] -> SampledSignal) -> [[Note]] -> SampledSignal notesToSignal = {- basicSynth -} songOfStormsSynth {- (semitoneSynth 15 tinkleBell) -} synth :: (Double, Double) -> Double -> [(Oscillator, [DSPEffect], Double)] -> [DSPEffect] -> Synth synth (timeBefore, timeAfter) speedupFactor tInfo finalEffects playNotes tracks = normalize finalAudio where (instruments, trackEffects, trackVolumes) = unzip3 tInfo speedCorrectedTracks = map (map (\(st, start, duration) -> (st, speedupFactor * start, speedupFactor * duration))) tracks playedTracks = zipWith playNotes instruments speedCorrectedTracks paddedTracks = map ((replicate (msToSamples timeBefore) 0 ++) . (++ replicate (msToSamples timeAfter) 0)) playedTracks tracksWithEffects = zipWith addEffects trackEffects paddedTracks mixedTracks = mixTracks tracksWithEffects trackVolumes finalAudio = addEffects finalEffects mixedTracks -- track 0: low accomp -- track 1: high accomp -- track 2: melody -- track 3: bells {- MCCOMMENT Intended usage: stack run mid/song_of_storms_final.mid output.wav On my machine it takes about 30 seconds, nothing outrageous. The prebuilt midi is at output.wav Important things: -> oscFromSample (above): uses a sampled instrument (provided in a file) to generate an oscillator, below it are various instruments created this way, including piano, trumpet and an OCARINA -> standardReverb (above): uses comb filters (and is supposed to use an allpass filter, see above) to create a reverb DSPEffect -> the rest is pretty standard, I just created a helper function to create "synths", ie. to programmatically generate notesToSignal for various inputs -> I also gave the MIDI a slightly nicer ending -> not sure if the note at about ~0:44 is suppoed to be there but i kind of like it -} songOfStormsSynth :: Synth songOfStormsSynth = synth (500, 10000) 0.62 [(piano2, [pianoReverb], 0.35), (trumpet, [trumpetReverb], 0.3), (ocarina, [ocarinaReverb], 0.9)] [] where pianoReverb = standardReverb 50 0.7 0.4 ocarinaReverb = standardReverb 200 0.8 0.7 trumpetReverb = standardReverb 400 0.8 0.3 -- generates a pure semitone, useful for testing semitoneSynth :: Semitone -> Oscillator -> [DSPEffect] -> Synth semitoneSynth semitone instrument effects playNotes _ = addEffects effects $ playNotes instrument [(semitone, 0, 5)] {- TTEW -} csvADSR :: Seconds -> ADSR -> Seconds -> String csvADSR interval adsrValues duration = csvSignal interval (adsrEnvelope adsrValues duration) duration csvSignal :: Seconds -> Signal -> Seconds -> String csvSignal interval signal duration = unlines $ map (\t -> printf "%0.5f" t ++ ", " ++ printf "%0.5f" (signal t)) [0, interval .. duration]