module Muh.Examples.Songs.Undertow ( example ) where import Control.Monad (guard) import Data.Foldable (toList, traverse_) import Data.List qualified as List import Data.Map.Strict qualified as Map import Data.Maybe (listToMaybe) import Data.Text (Text) import Data.Vector qualified as Vector import GHC.Stack (HasCallStack, withFrozenCallStack) import Lens.Micro ((%~), (&), (.~), (?~), _Just) import Muh.Examples.Example qualified as Example import Muh.Examples.Instruments.Bass qualified as Bass import Muh.Examples.Instruments.Keys qualified as Keys import Muh.Examples.Instruments.Lead qualified as Lead import Muh.Examples.Instruments.Pad qualified as Pad import Muh.Examples.Songs.Cookbook qualified as Cookbook import Muh.Synth.Delay qualified as Delay import Muh.Synth.Envelope (Envelope, adsr_) import Muh.Synth.Envelope qualified as Envelope import Muh.Synth.Filter (Filter, bandPass_, drive_, highPass_, lowPass_, resonance_) import Muh.Synth.Filter qualified as Filter import Muh.Synth.Instrument (Instrument, filterStage_, layered_, voice_) import Muh.Synth.Instrument qualified as Instrument import Muh.Synth.Labels () import Muh.Synth.Layered (noise_, oscillators_, unison_) import Muh.Synth.Mixer (Mixer, ducked_, groupBus_, highPassed_) import Muh.Synth.Mixer qualified as Mixer import Muh.Synth.Modulation qualified as Modulation import Muh.Synth.Note (Note) import Muh.Synth.Note qualified as Note import Muh.Synth.Notes.MIDI import Muh.Synth.Oscillator (saw_) import Muh.Synth.Oscillator qualified as Oscillator import Muh.Synth.Parameter qualified as Parameter import Muh.Synth.Part qualified as Part import Muh.Synth.Polyphony (voices_) import Muh.Synth.Polyphony qualified as Polyphony import Muh.Synth.Reverb qualified as Reverb import Muh.Synth.Seed qualified as Seed import Muh.Synth.VoiceParameter qualified as VoiceParameter import Muh.Tracker.Builder (Builder, instrument_, mixer_, section_, seed_, song_) import Muh.Tracker.Cell (Cell, atVolume_, effects_, gated_, panned_, play_) import Muh.Tracker.Cell qualified as Cell import Muh.Tracker.Effect qualified as Effect import Muh.Tracker.Groove (straight_) import Muh.Tracker.Pattern (Pattern) import Muh.Tracker.Pattern qualified as Pattern import Muh.Tracker.Position qualified as Position import Muh.Tracker.Song qualified as Song import Muh.Vis.Cast (Cast) import Muh.Vis.Cast qualified as Cast import Muh.Vis.Colour (rgb_) example :: Example.Example example = Example.Example { slug = "undertow" , title = "Undertow" , description = "Progressive trance built from one three-note motif: kick-ducked bass and music buses, noise drums, a gliding 808, and a supersaw carrying the long melody." , galleryPage = Just Example.GalleryPage { file = "undertow.html" , cover = Just "covers/undertow.jpg" , videoCover = Just "covers/undertow.jpg" , stems = undertowStems , sheet = Example.SheetWindow{start = 113, end = 170, label = "Drop"} } , cast = Just undertowCast , piece = Example.built undertow } undertow :: Builder () undertow = do instrument_ #kick synthKick instrument_ #clap noiseClap instrument_ #hats noiseHat instrument_ #openHat noiseOpenHat instrument_ #sub $ subStandIn & withGainDb 13.9 instrument_ #repriseSub $ repriseSub & withGainDb 19.1 instrument_ #eightOhEight $ Bass.eightOhEight & driven 4.5 & sustained & withGainDb 18 instrument_ #keys $ Keys.chipPluck & withGainDb 16 instrument_ #pad $ Pad.warmPad & withGainDb 9 instrument_ #strings $ stringsStandIn & withGainDb 10 instrument_ #stab chordStab instrument_ #supersaw $ Lead.supersaw & withGainDb 6 instrument_ #riser noiseRiser Example.describe undertowVoices mixer_ undertowMixer seed_ (Seed.Seed 0x554e4454) traverse_ section_ undertowSections song_ undertowSong undertowSong :: Song.Song undertowSong = Song.Song { name = "Undertow" , initialTempo = 136 , ticksPerRow , rowsPerBeat = 4 , beatsPerBar = 4 , groove = straight_ , conductor = #kick , parts = Map.map part (Part.laneCounts undertowLanes) , patterns = Map.fromList (zipWith barPattern [0 ..] moments) } where orders = Vector.fromList (map (Pattern.Id . fromIntegral) [0 .. length moments - 1]) part count = Song.Part count orders Song.PlayOnce (Song.channel_ 1 0) barPattern :: Int -> (Section, Int) -> (Pattern.Id, Pattern) barPattern index (section, bar) = ( identity , Cookbook.makePattern identity do step <- [0 .. rowsPerBar - 1] pure (musicRow Moment{section, bar, step}) ) where identity = Pattern.Id (fromIntegral index) undertowMixer :: Mixer undertowMixer = Mixer.zero_ & #drive .~ 1.7 & #returns .~ Map.fromList [(#delay, delay), (#reverb, reverb)] & #fallbackRoute .~ route & #groups .~ groups & #membership .~ membership where delay = Mixer.return_ (Mixer.Delay echo) 0.08 echo = Delay.Delay { time = Delay.Beats 0.75 , feedback = 0.3 } reverb = Mixer.return_ (Mixer.Reverb room) 0.12 room = Reverb.Reverb { decay = 2.6 , damping = 0.4 , preDelay = 0.025 , highPass = 220 } route = Mixer.Route { dry = 0.75 , sends = Map.fromList [(#delay, 1), (#reverb, 1)] } groups = Map.fromList [ (drumGroup, groupBus_ 1) , (lowGroup, groupBus_ 1 & ducked_ (kickDucking 0.5 0.14)) , (musicGroup, musicBus) , (repriseGroup, groupBus_ 1 & ducked_ stabDucking) ] musicBus = groupBus_ 1 & highPassed_ 150 & ducked_ (kickDucking 0.35 0.2) membership = Map.fromList do (handles, group) <- [ ([#kick, #clap, #hats, #openHat], drumGroup) , ([#sub, #eightOhEight], lowGroup) , ([#repriseSub], repriseGroup) , ([#keys, #pad, #strings, #supersaw, #stab], musicGroup) ] handle <- handles pure (handle, group) kickDucking depth release = Mixer.Ducking { key = #kick , depth , threshold = 0.12 , attackSeconds = 0.002 , releaseSeconds = release } stabDucking = Mixer.Ducking { key = #stab , depth = 0.75 , threshold = 0.05 , attackSeconds = 0.002 , releaseSeconds = 0.15 } drumGroup, lowGroup, musicGroup, repriseGroup :: Mixer.GroupId drumGroup = Mixer.GroupId 0 lowGroup = Mixer.GroupId 1 musicGroup = Mixer.GroupId 2 repriseGroup = Mixer.GroupId 3 undertowSections :: [Position.Section] undertowSections = do ((start, section), end) <- zip placed (map fst (drop 1 placed) <> [total]) pure (Position.Section section.name (at start) (closing end)) where total = sum (map (.bars) arrangement) at order = Position.Position order 0 0 closing end = if end < total then Just (at end) else Nothing undertowStems :: [Instrument.Handle] undertowStems = do (handle, _, _) <- undertowVoices pure handle undertowVoices :: [(Instrument.Handle, Text, Text)] undertowVoices = [ (#kick, "Undertow kick", "Ladder · a sine tuned to F with a two-octave pitch drop and ladder saturation; accented beats and phrase-end variations.") , (#clap, "Undertow noise clap", "Layered noise · band-passed with a quick filter snap; also the roll into the drop.") , (#hats, "Undertow noise hat", "Layered noise · high-passed sixteenths with no metallic partials.") , (#openHat, "Undertow noise open hat", "Layered noise · longer off-beats in the theme and the drop.") , (#sub, "Undertow sub", "Ladder · a driven sine swelling in on the off-beats.") , (#repriseSub, "Undertow reprise sub", "Ladder · one note per chord in the reprise, its filter blooming open and closing as it decays, ducked under the stabs.") , (#eightOhEight, "808 bass", "Ladder · a sine with a pitch sweep and saturation, gliding into every chord change of the drop.") , (#keys, "Velocity-layered chip pluck", "Layered · the three-note motif, its variations, and the long melody's quiet statements.") , (#pad, "Wide warm pad", "Prophet · warm saw chords whose filter opens across the intro.") , (#strings, "Undertow strings", "Prophet · a brighter pad an octave up that carries the ending alone.") , (#stab, "Undertow chord stab", "Layered · three detuned saws through a plucked state-variable low-pass, on the off-beats.") , (#supersaw, "Supersaw", "Layered · seven-voice unison saw behind a state-variable high-pass; the drop's lead and chords.") , (#riser, "Undertow noise riser", "Layered noise · band-passed and swept up into sections, and down at the outro.") ] undertowCast :: Cast undertowCast = Cast.Cast { groups = [ Cast.Group{name = "beat", slotWidth = 88, colour = rgb_ 0xff 0xb4 0x54, admits = Cast.Pinned [#kick, #clap, #hats, #openHat]} , Cast.Group{name = "low", slotWidth = 112, colour = rgb_ 0x9b 0x8f 0xb8, admits = Cast.Roles 1 ["low"]} , Cast.Group{name = "motif", slotWidth = 120, colour = rgb_ 0xf4 0xea 0xd2, admits = Cast.Pinned [#keys]} , Cast.Group{name = "lead", slotWidth = 112, colour = rgb_ 0x5a 0xd1 0xff, admits = Cast.Pinned [#supersaw]} , Cast.Group{name = "harmony", slotWidth = 98, colour = rgb_ 0x8e 0xe0 0x7a, admits = Cast.Roles 3 ["chords"]} ] , presences = do member <- [#kick, #clap, #hats, #openHat, #sub, #eightOhEight, #repriseSub, #keys, #supersaw, #pad, #strings, #stab] Cookbook.presences 1 member do (start, section) <- placed bar <- [0 .. section.bars - 1] role <- toList (castRoleAt member section bar) pure (start + bar, role) , looks = Map.fromList [ (#kick, rgb_ 0xff 0xb4 0x54) , (#clap, rgb_ 0xff 0xcf 0x8a) , (#hats, rgb_ 0xd0 0xc4 0x9a) , (#openHat, rgb_ 0xb8 0xbf 0xcc) , (#sub, rgb_ 0x9b 0x8f 0xb8) , (#eightOhEight, rgb_ 0xc4 0x9b 0xff) , (#repriseSub, rgb_ 0x7d 0x9c 0xc4) , (#keys, rgb_ 0xf4 0xea 0xd2) , (#supersaw, rgb_ 0x5a 0xd1 0xff) , (#pad, rgb_ 0x8e 0xe0 0x7a) , (#strings, rgb_ 0xa6 0xf2 0xff) , (#stab, rgb_ 0xff 0x8f 0xc7) ] , roles = Map.fromList [ ("roll", rgb_ 0xff 0x8a 0x65) , ("theme", rgb_ 0xff 0xcf 0x8a) , ("retrograde", rgb_ 0xff 0x8f 0xc7) , ("liquidation", rgb_ 0xc4 0x9b 0xff) , ("chords", rgb_ 0x8e 0xe0 0x7a) ] , timing = Cast.Timing{fadeSeconds = 0.5, leadSeconds = 0.5, holdSeconds = 1, bridgeSeconds = 1} } castRoleAt :: Instrument.Handle -> Section -> Int -> Maybe Text castRoleAt member section bar = snd <$> listToMaybe (List.sortOn fst candidates) where candidates = do Layer part density during <- section.layers guard (covers during bar) (handle, role) <- toList (castRole part density) guard (handle == member) pure (List.elemIndex role rolePriority, role) rolePriority :: [Text] rolePriority = ["lead", "theme", "retrograde", "liquidation", "motif", "roll", "chords", "low", "beat"] castRole :: Part -> Density -> Maybe (Instrument.Handle, Text) castRole part density = case part of Kick -> Just (#kick, "beat") Clap -> Just (#clap, if density == Full then "beat" else "roll") Hats -> Just (#hats, "beat") OpenHat -> Just (#openHat, "beat") Sub -> Just (if density == Full then #sub else #repriseSub, "low") EightOhEight -> Just (#eightOhEight, "low") Motif -> Just (#keys, "motif") Retrograde -> Just (#keys, "retrograde") Liquidation -> Just (#keys, "liquidation") Theme -> Just (if density == Full then (#supersaw, "lead") else (#keys, "theme")) Supersaw -> Just (#supersaw, if density == Full then "chords" else "lead") Pad -> Just (#pad, "chords") Strings -> Just (#strings, "chords") FinalChord -> Just (#strings, "chords") Stab -> if density == Full then Just (#stab, "chords") else Nothing PadFilterRise -> Nothing SupersawHighPassFall -> Nothing Riser -> Nothing Downlifter -> Nothing HarmonyReentry -> Nothing data Section = Section { name :: Text , bars :: Int , progression :: [Chord] , layers :: [Layer] } data Layer = Layer Part Density Span data Part = Kick | Clap | Hats | OpenHat | Sub | EightOhEight | Motif | Retrograde | Liquidation | Theme | Pad | PadFilterRise | Strings | Stab | Supersaw | SupersawHighPassFall | Riser | Downlifter | FinalChord | HarmonyReentry data Density = Thin | Full deriving stock (Eq) data Span = Whole | From Int | Until Int | Between Int Int arrangement :: [Section] arrangement = [ Section { name = "intro" , bars = 16 , progression = phrase , layers = [ Layer Kick Thin (From 4) , Layer Hats Thin Whole , Layer Pad Thin Whole , Layer PadFilterRise Full Whole , Layer Motif Thin (Between 8 9) , Layer Riser Thin (From 12) ] } , Section { name = "groove" , bars = 16 , progression = phrase , layers = [ Layer Kick Full Whole , Layer Clap Full Whole , Layer Hats Full Whole , Layer Sub Full Whole , Layer Motif Full Whole , Layer Pad Full Whole ] } , Section { name = "theme" , bars = 16 , progression = phrase , layers = [ Layer Kick Full Whole , Layer Clap Full Whole , Layer Hats Full Whole , Layer OpenHat Full Whole , Layer Sub Full Whole , Layer Motif Thin Whole , Layer Theme Thin Whole , Layer Pad Full Whole , Layer Strings Thin Whole , Layer Stab Thin Whole , Layer Riser Thin (From 12) ] } , Section { name = "breakdown" , bars = 16 , progression = retrogradePhrase , layers = [ Layer Retrograde Full Whole , Layer Strings Full Whole , Layer Supersaw Thin (From 8) , Layer SupersawHighPassFall Full (From 8) , Layer Riser Full (From 8) , Layer Clap Thin (From 12) ] } , Section { name = "drop" , bars = 32 , progression = phrase <> turnPhrase , layers = [ Layer Kick Full Whole , Layer Clap Full Whole , Layer Hats Full Whole , Layer OpenHat Full Whole , Layer EightOhEight Full Whole , Layer Theme Full Whole , Layer Pad Full Whole , Layer Strings Full Whole , Layer Stab Full Whole , Layer Supersaw Full Whole , Layer HarmonyReentry Full (Between 27 29) ] } , Section { name = "reprise" , bars = 6 , progression = loop , layers = [ Layer Hats Thin Whole , Layer Sub Thin Whole , Layer Stab Full Whole , Layer Liquidation Full Whole ] } , Section { name = "outro" , bars = 16 , progression = closingPhrase , layers = [ Layer Downlifter Full (Until 2) , Layer Kick Full Whole , Layer Clap Full (Until 14) , Layer Hats Thin Whole , Layer Sub Full (Until 12) , Layer Motif Thin Whole , Layer Theme Thin Whole , Layer Pad Full (Until 8) , Layer Supersaw Full (Until 4) , Layer FinalChord Thin (From 14) ] } , Section { name = "release" , bars = 4 , progression = [flatSixMajorSeventh] , layers = [Layer FinalChord Full Whole] } ] data Chord = Chord { root :: Note , voicing :: [Note] } deriving stock (Eq) loop :: [Chord] loop = concatMap (replicate 2) [tonic, flatSixMajorSeventh, flatThree, flatSevenOverThird] phrase :: [Chord] phrase = loop <> take 6 loop <> [dominantSuspended, dominant] turnPhrase :: [Chord] turnPhrase = loop <> [tonic, tonic, flatSixMajorSeventh, flatSeven, flatThree, flatThree, subdominant, subdominant] closingPhrase :: [Chord] closingPhrase = loop <> take 6 loop <> [flatSixMajorSeventh, flatSixMajorSeventh] retrogradePhrase :: [Chord] retrogradePhrase = reversedLoop <> take 6 reversedLoop <> [subdominant, dominant] where reversedLoop = concatMap (replicate 2) [flatSeven, flatThree, flatSixMajorSeventh, tonic] tonic, flatSixMajorSeventh, flatThree, flatSevenOverThird, flatSeven, dominantSuspended, dominant, subdominant :: Chord tonic = Chord F1 [F3, Ab3, C4, G4] flatSixMajorSeventh = Chord Db2 [F3, Ab3, C4, Eb4] flatThree = Chord Ab1 [Eb3, Ab3, C4, Eb4] flatSevenOverThird = Chord G1 [Eb3, G3, Bb3, Eb4] flatSeven = Chord Eb2 [Eb3, G3, Bb3, Eb4] dominantSuspended = Chord C2 [F3, G3, C4, G4] dominant = Chord C2 [E3, G3, C4, G4] subdominant = Chord Bb1 [F3, Bb3, Db4, F4] motif :: [(Int, Note, Int)] motif = [(0, Ab4, 3), (3, G4, 3), (6, C5, 4)] motifVariation :: Int -> [(Int, Note, Int)] motifVariation phraseBar | phraseBar == 15 = [] | otherwise = case phraseBar `mod` 4 of 0 -> motif 1 -> displaced 2 -> inverted _ -> answered displaced :: [(Int, Note, Int)] displaced = [(0, Ab4, 3), (3, G4, 5), (8, C5, 6)] inverted :: [(Int, Note, Int)] inverted = [(0, Ab4, 3), (3, Bb4, 3), (6, Eb4, 4)] answered :: [(Int, Note, Int)] answered = call <> response where call = take 2 motif response = do (position, pitch, _) <- call pure (10 + position * 2 `div` 3, Note.transpose 12 pitch, 2) liquidation :: Int -> [(Int, Note, Int)] liquidation = \case 0 -> motif 1 -> displaced 2 -> motif 3 -> take 2 motif <> [(6, C5, 10)] 4 -> take 2 motif 5 -> delayedBy 8 (retrogradeOf (take 2 motif)) <> [(14, C5, 4)] 6 -> [(0, Ab4, 28)] _ -> [] delayedBy :: Int -> [(Int, Note, Int)] -> [(Int, Note, Int)] delayedBy steps = map (\(position, pitch, rows) -> (position + steps, pitch, rows)) retrograde :: [(Int, Note, Int)] retrograde = retrogradeOf motif retrogradeOf :: [(Int, Note, Int)] -> [(Int, Note, Int)] retrogradeOf notes = zipWith (\(position, _, rows) (_, pitch, _) -> (position, pitch, rows)) notes (reverse notes) theme :: Chord -> [(Int, Int, Note, Int)] theme cadence = gesture 0 (Ab4, G4, C5) <> gesture 4 (C5, Bb4, Eb5) <> gesture 8 (Db5, C5, F5) <> [(12, 8, Eb5, 12), (13, 4, Db5, 6), (13, 10, C5, 14)] <> ending where gesture bar (first, second, held) = [ (bar, 8, first, 12) , (bar + 1, 4, second, 6) , (bar + 1, 10, held, 38) ] ending | cadence == subdominant = [(14, 8, Db5, 24)] | otherwise = [(14, 8, Bb4, 8), (15, 0, G4, 16)] diatonic :: Int -> Note -> Note diatonic steps pitch = scale !! (length (takeWhile (< pitch) scale) + steps) where scale = do candidate <- map Note.Note [0 .. 127] guard (Note.number candidate `mod` 12 `elem` [0, 1, 3, 5, 7, 8, 10]) pure candidate suspendedVoice :: Chord -> Maybe Int suspendedVoice chord | chord == flatSixMajorSeventh = Just 0 | chord == flatSevenOverThird = Just 1 | chord == subdominant = Just 2 | otherwise = Nothing data HoldDevice = StringResolution | VibratoSwell | HighPassLift deriving stock (Eq) reentryRows :: Int reentryRows = 8 reentryOpening :: Int -> Float reentryOpening row = curve (fromIntegral row) / curve (fromIntegral reentryRows) where curve x = 1 - 1 / (1 + x / 8) reentryFilters :: [([Part.Lane], Float, Float)] reentryFilters = [ (padLanes, 178, baseCutoff Pad.warmPad) , (stringLanes, 208, baseCutoff stringsStandIn) , (supersawChordLanes, 3000, baseCutoff Lead.supersaw) ] baseCutoff :: Instrument -> Float baseCutoff instrument = maybe 0 (\stage -> stage.patch.cutoffHz) instrument.voice.filter lift :: [HoldDevice] lift = [VibratoSwell, HighPassLift] dropHoldDevices :: Int -> [HoldDevice] dropHoldDevices = \case 2 -> [StringResolution] 6 -> lift 10 -> [StringResolution] 18 -> lift 22 -> [StringResolution] 26 -> [HighPassLift] 30 -> lift _ -> [] data Moment = Moment { section :: Section , bar :: Int , step :: Int } musicRow :: Moment -> Pattern.Row musicRow moment = Pattern.Row $ Map.fromListWith Cell.merge do Layer part density during <- moment.section.layers guard (covers during moment.bar) partCells moment density part covers :: Span -> Int -> Bool covers during bar = case during of Whole -> True From first -> bar >= first Until final -> bar < final Between first final -> bar >= first && bar < final partCells :: Moment -> Density -> Part -> [(Part.Lane, Cell)] partCells moment density = \case Kick -> do (position, velocity) <- kickPattern guard (step == position) pure ( #kick , play_ #kick F1 (if density == Full then velocity else velocity - 18) & hit 3 0 ) Clap -> case density of Full -> do guard (step `elem` [4, 12]) pure (#clap, play_ #clap C4 0x68 & hit 3 0.04) Thin -> do guard (step `mod` rollInterval == 0) pure ( #clap , play_ #clap C4 (min 0x76 (0x34 + 4 * (rowsPerBar * (4 - barsLeft) + step) `div` 3)) & hit 3 0.04 ) Hats -> case density of Full -> pure ( #hats , play_ #hats C4 (if even step then 0x54 else 0x3c + (bar * 5 + step * 3) `mod` 11) & hit 1 (-0.24) ) Thin -> do guard offbeat pure (#hats, play_ #hats C4 0x4c & hit 1 (-0.24)) OpenHat -> do guard offbeat pure (#openHat, play_ #openHat C4 0x5c & hit 2 0.3) Sub -> case density of Full -> do guard offbeat pure (#sub, play_ #sub (Note.transpose 12 chord.root) 0x64 & hit 2 0) Thin -> repriseSubCells EightOhEight -> eightOhEightCells Motif -> do (position, pitch, rows) <- motifVariation phraseBar guard motifBar guard (step == position) pure ( #motif , play_ #keys pitch (motifVelocity position) & hit rows (-0.12) ) Liquidation -> do (position, pitch, rows) <- liquidationFigure guard (step == position) pure ( #motif , play_ #keys pitch (motifVelocity (position - liquidationStart) - 3 * bar) & hit rows (-0.12) ) Retrograde -> do (position, pitch, rows) <- retrograde guard (even bar) guard (step == position) pure ( #motif , play_ #keys pitch 0x54 & hit (rows + 2) (-0.12) ) Theme -> case density of Full -> themeCells #supersawLead #supersaw 12 phraseBar <> liftCells Thin -> themeCells #theme #keys 0 phraseBar Pad -> chordCells padLanes #pad chord.voicing (if density == Full then 0x58 else 0x46) 30 [-0.5, -0.17, 0.17, 0.5] PadFilterRise -> do lane <- padLanes pure ( lane , Cookbook.control $ openingWrite <> [sweepSlide VoiceParameter.cutoffId 238 1368 (moment.section.bars * rowsPerBar) sectionRow] ) Strings -> stringCells Stab -> case density of Full -> do guard offbeat voiced stabLanes #stab (drop 1 chord.voicing) (if step `elem` [6, 14] then 0x5c else 0x50) 1 [-0.3, 0.05, 0.3] Thin -> do guard (phraseBar `elem` [7, 15]) guard (step `elem` [10, 14]) voiced stabLanes #stab (drop 1 chord.voicing) 0x54 1 [-0.3, 0.05, 0.3] Supersaw -> case density of Full -> chordCells supersawChordLanes #supersaw (drop 1 (map (Note.transpose 12) chord.voicing)) 0x4e 31 [-0.34, 0, 0.34] Thin -> themeCells #supersawLead #supersaw 12 (bar - 8) SupersawHighPassFall -> pure ( #supersawLead , Cookbook.control $ fallingWrite <> [sweepSlide VoiceParameter.cutoffId 2600 200 (8 * rowsPerBar) ((bar - 8) * rowsPerBar + step)] ) Riser -> sweepNote risingRow (riserBars * rowsPerBar) (if density == Full then 0x64 else 0x4c) (300, 7000) (0.15, 1) Downlifter -> sweepNote sectionRow (2 * rowsPerBar) 0x5a (7000, 250) (1, 0) HarmonyReentry -> do (lanes, closed, open) <- reentryFilters lane <- lanes effect <- reentryFilter closed open pure (lane, Cookbook.control [effect]) FinalChord -> case density of Thin -> do guard (even bar) guard (step == 0) voiced stringLanes #strings (map (Note.transpose 12) chord.voicing) 0x4a (6 * rowsPerBar) [-0.62, -0.22, 0.22, 0.62] Full -> do lane <- stringLanes pure ( lane , Cell.empty & #volumeColumn ?~ Cell.SlideVolume (Just fadeOut) ) where Moment{bar, step} = moment chord = chordAt moment.section bar phraseBar = bar `mod` 16 sectionRow = bar * rowsPerBar + step offbeat = step `elem` [2, 6, 10, 14] inDrop = moment.section.name == "drop" holding device start = inDrop && device `elem` dropHoldDevices start stringPitches = map (Note.transpose 12) chord.voicing stringVelocity = if density == Full then 0x50 else 0x42 stringPans = [-0.62, -0.22, 0.22, 0.62] stringCells = case suspendedVoice chord of Just voice | holding StringResolution bar -> do (index, (lane, pitch, pan)) <- zip [0 ..] (zip3 stringLanes stringPitches stringPans) guard (step == 0) pure ( lane , play_ #strings (if index == voice then diatonic 1 pitch else pitch) stringVelocity & hit (if index == voice then 16 else 31) pan ) | holding StringResolution (bar - 1) -> do guard (step == 0) pure ( stringLanes !! voice , play_ #strings (stringPitches !! voice) stringVelocity & hit 15 (stringPans !! voice) ) _ -> chordCells stringLanes #strings stringPitches stringVelocity 31 stringPans liftCells = liftSwell <> liftReset liftSwell = do guard (not (null (vibratoSwell <> highPassLift))) pure (#supersawLead, Cookbook.control (vibratoSwell <> highPassLift)) liftReset = do guard (holding HighPassLift (bar - 2)) guard (step == 0) pure (#supersawLead, Cookbook.control [Effect.ParameterWrite VoiceParameter.cutoffId (baseCutoff Lead.supersaw)]) vibratoSwell = do guard (holding VibratoSwell bar || holding VibratoSwell (bar - 1)) pure (Effect.Vibrato (Just (30 * fromIntegral (liftRow + 1) / 32))) highPassLift = do guard (holding HighPassLift (bar - 1)) pure (sweepSlide VoiceParameter.cutoffId (baseCutoff Lead.supersaw) 1800 rowsPerBar step) liftRow = if holding VibratoSwell (bar - 1) then rowsPerBar + step else step reentryFilter closed open | bar == 27 && step >= 12 = [sweepSlide VoiceParameter.cutoffId open closed 4 (step - 12)] | bar == 28 && step < reentryRows = [Effect.ParameterSlide VoiceParameter.cutoffId (Just reentrySlide)] | bar == 28 && step == reentryRows = [Effect.ParameterWrite VoiceParameter.cutoffId open] | otherwise = [] where reentrySlide = (reentryCutoff (step + 1) - reentryCutoff step) / fromIntegral ticksPerRow reentryCutoff row = closed * (open / closed) ** reentryOpening row rootChangesHere = inDrop && bar > 0 && chord.root /= (chordAt moment.section (bar - 1)).root rootChangesNext = inDrop && chord.root /= (chordAt moment.section (bar + 1)).root chordRows rows = if odd bar || rootChangesNext then rows - rowsPerBar else rows motifBar = density == Full || even bar repriseSubCells = do guard (even bar) guard (step == 0) pure ( #sub , play_ #repriseSub (Note.transpose 12 chord.root) 0x54 & panned_ 0 & gated_ (handOver 32) ) rowTicks rows = fromIntegral (rows * ticksPerRow) handOver rows = rowTicks rows - 1 fadeOut = -1 / fromIntegral (moment.section.bars * rowsPerBar * ticksPerRow) riserBars = if density == Full then 8 else 4 risingRow = (bar - (moment.section.bars - riserBars)) * rowsPerBar + step liquidationFigure = liquidation bar liquidationStart = minimum do (position, _, _) <- liquidationFigure pure position motifVelocity position = 0x4e + 2 * (phraseBar `mod` 8) + (if position == 0 then 8 else -4) kickPattern | phraseBar == 15 = take 3 accented | phraseBar == 7 = accented <> [(14, 0x46)] | otherwise = accented accented = do (position, accent) <- zip [0, 4, 8, 12] [0x76, 0x68, 0x70, 0x6a] pure (position, accent + (bar * 7 + position * 3) `mod` 5 - 2) barsLeft = moment.section.bars - bar rollInterval = case barsLeft of 4 -> 4 3 -> 2 _ -> 1 openingWrite = do guard (sectionRow == 0) pure (Effect.ParameterWrite VoiceParameter.cutoffId 238) fallingWrite = do guard (bar == 8) guard (step == 0) pure (Effect.ParameterWrite VoiceParameter.cutoffId 2600) chordCells lanes instrument pitches velocity rows pans = do guard (even bar || rootChangesHere) guard (step == 0) voiced lanes instrument pitches velocity (chordRows rows) pans voiced lanes instrument pitches velocity rows pans = do (lane, pitch, pan) <- zip3 lanes pitches pans pure (lane, play_ instrument pitch velocity & hit rows pan) themeCells lane instrument transpose themeBar = do (position, onset, pitch, rows) <- theme (chordAt moment.section (bar - phraseBar + 14)) guard (position == themeBar) guard (onset == step) pure ( lane , play_ instrument (Note.transpose transpose pitch) 0x60 & hit rows 0.08 ) eightOhEightCells = do (lane, offset, pitch, velocity, ticks, plays) <- [ (#bass, 0, chord.root, 0x6e, handOver 24, bar == 0) , (#bass, 16, chord.root, 0x6c, handOver 8, rootChangesHere) , (#bass, 24, Note.transpose popInterval chord.root, 0x60, rowTicks 7, True) , (Part.lane #bass 1, 30, next.root, 0x6c, handOver 26, bar + 1 < moment.section.bars) ] guard plays guard (spanRow == offset) pure ( lane , play_ #eightOhEight pitch velocity & panned_ 0 & gated_ ticks ) where spanRow = (bar `mod` 2) * rowsPerBar + step next = chordAt moment.section (bar + 1) popInterval = if bar >= 16 then 19 else 12 sweepNote :: (HasCallStack) => Int -> Int -> Int -> (Float, Float) -> (Float, Float) -> [(Part.Lane, Cell)] sweepNote row rows velocity (fromHz, toHz) (fromVolume, toVolume) = withFrozenCallStack $ if | row == 0 -> [ ( #riser , play_ #riser C4 velocity & effects_ [ Effect.ParameterWrite VoiceParameter.cutoffId fromHz , slide ] & atVolume_ fromVolume & hit rows 0 ) ] | row > 0 && row < rows -> [ ( #riser , Cell.empty & #volumeColumn ?~ Cell.SlideVolume (Just volumeStep) & #effects .~ Vector.singleton slide ) ] | otherwise -> [] where slide = sweepSlide VoiceParameter.cutoffId fromHz toHz rows row volumeStep = (toVolume - fromVolume) / fromIntegral (rows * ticksPerRow) chordAt :: Section -> Int -> Chord chordAt section bar = cycle section.progression !! max 0 bar sweepSlide :: Parameter.Id -> Float -> Float -> Int -> Int -> Effect.Effect sweepSlide parameterId from to rows row = Effect.ParameterSlide parameterId (Just ((level (row + 1) - level row) / fromIntegral ticksPerRow)) where level index = from * (to / from) ** (fromIntegral index / fromIntegral rows) hit :: Int -> Float -> Cell -> Cell hit rows position cell = cell & gated_ (fromIntegral (rows * ticksPerRow)) & panned_ position placed :: [(Int, Section)] placed = zip (scanl (+) 0 (map (.bars) arrangement)) arrangement moments :: [(Section, Int)] moments = do section <- arrangement bar <- [0 .. section.bars - 1] pure (section, bar) ticksPerRow, rowsPerBar :: Int ticksPerRow = 6 rowsPerBar = 16 padLanes, stringLanes, supersawChordLanes, stabLanes :: [Part.Lane] padLanes = Part.lanes #pad 4 stringLanes = Part.lanes #strings 4 supersawChordLanes = Part.lanes #supersawChords 3 stabLanes = Part.lanes #stab 3 undertowLanes :: [Part.Lane] undertowLanes = [#kick, #clap, #hats, #openHat, #sub, #bass, Part.lane #bass 1, #motif, #theme, #supersawLead, #riser] <> padLanes <> stringLanes <> supersawChordLanes <> stabLanes withGainDb :: Float -> Instrument -> Instrument withGainDb decibels = #gain %~ (* 10 ** (decibels / 20)) sustained :: Instrument -> Instrument sustained instrument = instrument & #voice . #ampEnvelope . #sustainLevel .~ 0.45 & #voice . #ampEnvelope . #releaseSeconds .~ 0.22 driven :: Float -> Instrument -> Instrument driven amount = #voice . #filter . _Just . #patch %~ drive_ amount subStandIn :: Instrument subStandIn = Bass.eightOhEight & #voice . #modulators .~ Vector.empty & #voice . #routes .~ Vector.empty & #voice . #ampEnvelope .~ swell & driven 4 where swell = adsr_ 0.025 0.1 1 0.18 & Envelope.restart_ repriseSub :: Instrument repriseSub = subStandIn & #voice . #ampEnvelope .~ decay & #voice . #filter . _Just . #patch . #cutoffHz .~ 200 & #voice %~ envelopeSweep #opening VoiceParameter.cutoffId (VoiceParameter.cutoffOctaves 3) openingEnvelope where decay = adsr_ 0.025 2.5 0.4 0.18 & Envelope.restart_ openingEnvelope = adsr_ 0.02 2.5 0 0.2 & Envelope.restart_ stringsStandIn :: Instrument stringsStandIn = Pad.warmPad & #gain %~ (* 0.7) & #voice . #ampEnvelope . #attackSeconds .~ 0.12 & #voice . #filter . _Just . #patch . #cutoffHz .~ 2022 synthKick :: Instrument synthKick = Bass.eightOhEight & #gain %~ (* 6.3) & #voice . #filter . _Just . #patch %~ drive_ 3 & #voice . #filter . _Just . #patch . #cutoffHz .~ 6000 & #voice %~ envelopeSweep #pitchDrop VoiceParameter.pitchId (VoiceParameter.pitchSemitones 24) pitchDropEnvelope & #voice . #ampEnvelope .~ body & #voice . #polyphony . #allocation .~ Polyphony.Monophonic Polyphony.LastNote Polyphony.RetriggerEnvelopes where pitchDropEnvelope = adsr_ 0 0.035 0 0.01 & Envelope.restart_ body = adsr_ 0.0005 0.3 0 0.05 & Envelope.restart_ noiseHat :: Instrument noiseHat = noiseDrum 0.4 (highPass_ 8500 & resonance_ 0.2) $ adsr_ 0.0005 0.035 0 0.02 & Envelope.restart_ noiseOpenHat :: Instrument noiseOpenHat = noiseDrum 0.16 (highPass_ 7000 & resonance_ 0.2) $ adsr_ 0.001 0.16 0 0.06 & Envelope.restart_ noiseClap :: Instrument noiseClap = noiseDrum 0.38 (bandPass_ 1300 & resonance_ 0.2) (adsr_ 0.001 0.14 0 0.06 & Envelope.restart_) & #voice %~ envelopeSweep #snap VoiceParameter.cutoffId (VoiceParameter.cutoffOctaves 1) snapEnvelope where snapEnvelope = adsr_ 0 0.03 0 0.01 & Envelope.restart_ noiseRiser :: Instrument noiseRiser = noiseDrum 0.25 (bandPass_ 300 & resonance_ 0.2) $ adsr_ 0.02 0 1 0.4 & Envelope.restart_ noiseDrum :: Float -> Filter -> Envelope -> Instrument noiseDrum level shape envelope = Instrument.Instrument { voice = voice_ (voices_ 4) envelope & #filter ?~ filterStage_ shape & #phasePolicy .~ Oscillator.FreeRunning , engine = layered_ [noise_ 0] , gain = level } envelopeSweep :: Modulation.SourceId -> Parameter.Id -> Float -> Envelope -> Instrument.Voice -> Instrument.Voice envelopeSweep source target amount envelope voice = voice & #modulators .~ Vector.singleton Modulation.Modulator{sourceId = source, signal = Modulation.Envelope envelope} & #routes .~ Vector.singleton Modulation.Route{sourceId = source, targetId = target, amount, polarity = Parameter.Unipolar} chordStab :: Instrument chordStab = Instrument.Instrument { voice = voice_ (voices_ 12) stabEnvelope & #filter ?~ filterStage_ shape & envelopeSweep #pluck VoiceParameter.cutoffId (VoiceParameter.cutoffOctaves 1.5) pluckEnvelope & #phasePolicy .~ Oscillator.FreeRunning , engine = layered_ (unison_ 3 12 0.4 saw) , gain = 0.09 } where stabEnvelope = adsr_ 0.002 0.2 0 0.12 & Envelope.restart_ shape = lowPass_ 1400 & resonance_ 0.25 pluckEnvelope = adsr_ 0 0.12 0 0.05 & Envelope.restart_ saw = oscillators_ [saw_]