module Muh.Examples.Songs.PatienceNeon
  ( example
  ) where

import Control.Monad (guard)
import Data.Foldable (traverse_)
import Data.Map.Strict qualified as Map
import Data.Ratio ((%))
import Data.Text (Text)
import Data.Vector qualified as Vector
import Lens.Micro ((%~), (&), (.~), (?~), _Just)

import Muh.Examples.Example qualified as Example
import Muh.Examples.Instruments.Drums qualified as Drums
import Muh.Examples.Instruments.Keys qualified as Keys
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 (adsr_)
import Muh.Synth.Filter (drive_, lowPassLadder_, resonance_)
import Muh.Synth.Instrument (Instrument, filterStage_, voice_)
import Muh.Synth.Instrument qualified as Instrument
import Muh.Synth.Labels ()
import Muh.Synth.Layered qualified as Layered
import Muh.Synth.Mixer (Mixer)
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 (bank_, sine_, triangle_)
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 (mono_, 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_, release_)
import Muh.Tracker.Effect qualified as Effect
import Muh.Tracker.Groove (rowSwing_)
import Muh.Tracker.Pattern (row_)
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 = "patience-neon"
    , title = "Patience, Neon"
    , description = "Five minutes of warm deep house, sine-tine chords, glass melodies, and shuffled jungle breaks for cyberdeck Solitaire."
    , galleryPage =
        Just
          Example.GalleryPage
            { file = "patience.html"
            , cover = Just "covers/patience-neon.jpg"
            , videoCover = Just "covers/patience-neon.jpg"
            , stems = patienceNeonStems
            , sheet = Example.SheetWindow{start = 30, end = 90, label = "House"}
            }
    , cast = Just patienceNeonCast
    , piece = Example.built patienceNeon
    }

patienceNeon :: Builder ()
patienceNeon = do
  instrument_ #bass $ roundBass & withGainDb 10
  instrument_ #pad velvetPad
  instrument_ #keys electricKeys
  instrument_ #glass $ Keys.glassKeys & withGain 0.46
  instrument_ #pluck $ Keys.chipPluck & withGain 0.607
  instrument_ #kick $ Drums.kick & withGain 1.0
  instrument_ #snare $
    Drums.snare
      & withGain 0.16
      & withGainDb (-15)
  instrument_ #hats $ Drums.hat & withGain 0.32
  Example.describe patienceNeonVoices
  mixer_ patienceNeonMixer
  seed_ (Seed.Seed 0x50415449)
  traverse_ section_ sections
  song_ patienceNeonSong
  where
    sections = do
      (name, start, end) <-
        [ ("intro", 0, Just 16)
        , ("house", 16, Just 48)
        , ("breaks", 48, Just 64)
        , ("floating", 64, Just 80)
        , ("return", 80, Just 112)
        , ("breaks-2", 112, Just 128)
        , ("finale", 128, Just 144)
        , ("outro", 144, Just 156)
        , ("release", 156, Nothing)
        ]
      pure (Position.Section name (at start) (fmap at end))
    at bar = Position.Position bar 0 0

patienceNeonSong :: Song.Song
patienceNeonSong =
  Song.Song
    { name = "Patience, Neon"
    , initialTempo = 128
    , ticksPerRow = 6
    , rowsPerBeat = 4
    , beatsPerBar = 4
    , groove = rowSwing_ 6 (1 % 12)
    , conductor = #kick
    , parts = Map.map part (Part.laneCounts patienceNeonLanes)
    , patterns = Map.fromList do
        bar <- [0 .. 159]
        pure (identity bar, Cookbook.makePattern (identity bar) (map (musicRow bar) [0 .. 15]))
    }
  where
    orders = Vector.fromList (map identity [0 .. 159])
    part count = Song.Part count orders Song.PlayOnce (Song.channel_ 1 0)
    identity :: Int -> Pattern.Id
    identity bar = Pattern.Id (fromIntegral bar)

patienceNeonMixer :: Mixer
patienceNeonMixer =
  Mixer.zero_
    & #drive .~ 1.08
    & #returns .~ Map.fromList [(#delay, delay), (#reverb, reverb)]
    & #fallbackRoute .~ route
  where
    delay = Mixer.return_ (Mixer.Delay echo) 0.077
    echo =
      Delay.Delay
        { time = Delay.Beats 0.75
        , feedback = 0.28
        }
    reverb = Mixer.return_ (Mixer.Reverb room) 0.14
    room =
      Reverb.Reverb
        { decay = 2.2
        , damping = 0.35
        , preDelay = 0.02
        , highPass = 160
        }
    route =
      Mixer.Route
        { dry = 0.7
        , sends = Map.fromList [(#delay, 1), (#reverb, 1)]
        }

patienceNeonLanes :: [Part.Lane]
patienceNeonLanes =
  [#kick, #snare, #hats, #snareGhost, #hatsOffbeat, #bass]
    <> Part.lanes #keys 4
    <> Part.lanes #pad 2
    <> [#glass, #pluck]

musicRow :: Int -> Int -> Pattern.Row
musicRow bar step
  | bar >= releaseBar = row_ releases
  | otherwise = row_ (drums <> bass <> chords <> cloud <> melody <> answer)
  where
    broken = brokenBar bar
    floating = floatingBar bar
    outro = outroBar bar
    pulse = pulseBar bar
    full = fullBar bar
    fill = bar `mod` 8 == 7 && step >= 12
    fade = if outro then fromIntegral (releaseBar - bar) / 12 else min 1 (fromIntegral (bar + 2) / 8)
    harmony = (bar `div` 2) `mod` 8
    voicing = harmonies !! harmony
    root = roots !! harmony
    hit :: Rational -> Float -> Cell -> Cell
    hit duration position cell =
      cell
        & gated_ duration
        & atVolume_ fade
        & panned_ position
    releases = do
      lane <- patienceNeonLanes
      guard (bar == releaseBar)
      guard (step == 0)
      pure (lane, release_)
    drums = kick <> snare <> hats <> snareGhost <> hatsOffbeat
    kick = do
      guard pulse
      guard (step `elem` (if broken then [0, 6, 10] else [0, 4, 8, 12]))
      guard (not (fill && step == 12 && bar `mod` 16 == 15))
      pure (#kick, play_ #kick C4 (if step == 0 then 0x74 else 0x69) & hit 6 0)
    snare = do
      guard (snareBar bar)
      guard (step `elem` (if broken && odd bar then [4, 11] else [4, 12]))
      pure (#snare, play_ #snare C4 0x57 & hit 6 0.06)
    hats = do
      guard (hatsBar bar)
      guard (step `elem` (if full then [0, 2 .. 14] else [2, 6, 10, 14]))
      pure
        ( #hats
        , play_ #hats C4 (if step `mod` 4 == 2 then 0x59 else 0x36 + (bar + step) `mod` 13)
            & hit 3 (-0.32)
        )
    snareGhost = do
      guard full
      guard ((broken && step `elem` [3, 7, 14]) || (fill && step `elem` [13, 15]))
      pure
        ( #snareGhost
        , play_ #snare C4 (if fill then 0x45 + step else 0x37)
            & effects_ (Effect.SampleOffset (Just 700) : ghostRoll)
            & hit 3 0.24
        )
    ghostRoll = do
      guard (fill && step == 15)
      pure (Effect.RetriggerEvery 2)
    hatsOffbeat = do
      guard full
      guard (step `elem` (if broken then [1, 5, 9, 11, 13, 15] else [3, 7, 11, 15]))
      pure
        ( #hatsOffbeat
        , play_ #hats C4 (0x2a + (bar * 7 + step) `mod` 19)
            & effects_ [Effect.DelayNote 1]
            & hit 2 0.4
        )
    bass = do
      (position, interval, strength, duration) <- bassFigure
      guard (bassBar bar)
      guard (step == position)
      pure (#bass, play_ #bass (Note.transpose interval root) strength & hit duration 0)
    bassFigure
      | broken =
          [ (0, 0, 0x68, 13)
          , (6, 12, 0x60, 7)
          , (10, 7, 0x64, 9)
          , (15, 12, 0x5c, 4)
          ]
      | otherwise =
          [ (0, 0, 0x6a, 13)
          , (6, 7, 0x62, 8)
          , (10, 12, 0x66, 8)
          , (14, 7, 0x5e, 6)
          ]
    chords = do
      (lane, pitch, pan) <- zip3 (Part.lanes #keys 4) voicing [-0.36, -0.12, 0.12, 0.36]
      guard (chordBar bar)
      guard (step `elem` chordSteps)
      pure
        ( lane
        , play_ #keys pitch (if step == 2 then 0x5b else 0x4d)
            & hit (if floating then 32 else 10) pan
        )
    chordSteps
      | floating = [0]
      | broken = [2, 10]
      | odd bar = [2, 9, 14]
      | otherwise = [2, 10]
    cloud = do
      (lane, pitch, pan) <- zip3 (Part.lanes #pad 2) [head voicing, last voicing] [-0.55, 0.55]
      guard (even bar)
      guard (step == 0)
      guard (padBar bar)
      pure (lane, play_ #pad pitch (if floating then 0x57 else 0x43) & hit 174 pan)
    melody = do
      (position, degree, strength) <- motifs !! (bar `mod` 4)
      guard (melodyBar bar)
      guard (step == position)
      pure (#glass, play_ #glass (Note.transpose 12 (voicing !! degree)) strength & hit 8 (-0.18))
    answer = do
      guard (bar >= 32)
      guard (bar < 144)
      guard (bar `mod` 4 == 3)
      guard (step `elem` [6, 14])
      pure
        ( #pluck
        , play_ #pluck (Note.transpose 12 (voicing !! (bar `mod` 4))) 0x42
            & effects_ [Effect.DelayNote 2]
            & hit 5 0.48
        )

releaseBar :: Int
releaseBar = 156

brokenBar, floatingBar, outroBar, pulseBar, fullBar :: Int -> Bool
brokenBar bar = bar >= 48 && bar < 64 || bar >= 112 && bar < 128
floatingBar bar = bar >= 64 && bar < 80
outroBar bar = bar >= 144
pulseBar bar = bar >= 8 && not (floatingBar bar) && bar < 152
fullBar bar = bar >= 16 && not (floatingBar bar) && not (outroBar bar)

snareBar, hatsBar, bassBar, chordBar, padBar, melodyBar :: Int -> Bool
snareBar bar = pulseBar bar && bar >= 16
hatsBar bar = bar >= 4 && (not (floatingBar bar) || bar >= 72)
bassBar bar = bar >= 16 && (not (floatingBar bar) || bar >= 76) && bar < 152
chordBar bar = bar >= 8
padBar bar = bar < 144 || bar >= 152
melodyBar bar = (bar >= 24 && bar < 48) || (bar >= 68 && bar < 112) || (bar >= 128 && bar < 148)

patienceNeonCast :: Cast
patienceNeonCast =
  Cast.Cast
    { groups =
        [ Cast.Group{name = "drums", slotWidth = 108, colour = rgb_ 0xff 0xb4 0x54, admits = Cast.Pinned [#kick, #snare, #hats]}
        , Cast.Group{name = "bass", slotWidth = 124, colour = rgb_ 0xc4 0x9b 0xff, admits = Cast.Pinned [#bass]}
        , Cast.Group{name = "chords", slotWidth = 124, colour = rgb_ 0xf4 0xea 0xd2, admits = Cast.Pinned [#keys, #pad]}
        , Cast.Group{name = "call", slotWidth = 124, colour = rgb_ 0x5a 0xd1 0xff, admits = Cast.Pinned [#glass]}
        , Cast.Group{name = "answer", slotWidth = 124, colour = rgb_ 0xe6 0xe0 0x5a, admits = Cast.Guests 1 [#pluck]}
        ]
    , presences = do
        (member, sounds, role) <-
          [ (#kick, pulseBar, rhythm "drums")
          , (#snare, snareBar, rhythm "drums")
          , (#hats, hatsBar, rhythm "drums")
          , (#bass, bassBar, rhythm "bass")
          , (#keys, chordBar, harmony)
          , (#pad, padBar, harmony)
          , (#glass, melodyBar, const "call")
          ]
        Cookbook.presences 1 member do
          bar <- [0 .. releaseBar - 1]
          guard (sounds bar)
          pure (bar, role bar)
    , looks =
        Map.fromList
          [ (#kick, rgb_ 0xff 0xb4 0x54)
          , (#snare, rgb_ 0xff 0x8f 0xc7)
          , (#hats, rgb_ 0xd0 0xc4 0x9a)
          , (#bass, rgb_ 0xc4 0x9b 0xff)
          , (#keys, rgb_ 0xf4 0xea 0xd2)
          , (#pad, rgb_ 0x7d 0x9c 0xc4)
          , (#glass, rgb_ 0x5a 0xd1 0xff)
          , (#pluck, rgb_ 0xe6 0xe0 0x5a)
          ]
    , roles =
        Map.fromList
          [ ("breaks", rgb_ 0xff 0x8a 0x65)
          , ("floating", rgb_ 0xa6 0xf2 0xff)
          ]
    , timing = Cast.Timing{fadeSeconds = 0.5, leadSeconds = 0.5, holdSeconds = 1, bridgeSeconds = 1}
    }
  where
    rhythm steady bar = if brokenBar bar then "breaks" else steady
    harmony bar = if floatingBar bar then "floating" else "chords"

harmonies :: [[Note]]
harmonies =
  [ [A3, C4, E4, G4]
  , [A3, C4, E4, B4]
  , [G3, B3, D4, Fs4]
  , [G3, B3, D4, A4]
  , [G3, B3, C4, E4]
  , [Fs3, A3, C4, E4]
  , [Fs3, A3, B3, D4]
  , [Gs3, B3, D4, F4]
  ]

roots :: [Note]
roots = [D2, D2, G2, G2, C2, C2, B1, E2]

motifs :: [[(Int, Int, Int)]]
motifs =
  [ [(0, 2, 0x53), (7, 3, 0x48), (10, 1, 0x4e)]
  , [(2, 0, 0x4c), (12, 2, 0x45)]
  , [(3, 1, 0x52), (6, 2, 0x49), (14, 3, 0x4d)]
  , [(0, 2, 0x4e), (9, 0, 0x46)]
  ]

patienceNeonStems :: [Instrument.Handle]
patienceNeonStems = do
  (handle, _, _) <- patienceNeonVoices
  pure handle

patienceNeonVoices :: [(Instrument.Handle, Text, Text)]
patienceNeonVoices =
  [ (#bass, "Patience rounded bass", "Ladder · triangle/sine sub-bass with a short filter envelope.")
  , (#pad, "Wide warm pad", "Prophet · detuned sustained chord edges for the ambient middle.")
  , (#keys, "Patience sine tine keys", "Layered · four-note electric-key voicings spread across the stereo field.")
  , (#glass, "Sampled glass keys", "Sample · short melodic calls and returns above the chord bed.")
  , (#pluck, "Velocity-layered chip pluck", "Layered · delayed two-note answers lifted to survive the full mix.")
  , (#kick, "Sine sweep kick", "Fixed-rate sample · four-on-the-floor anchor, reduced for bass room.")
  , (#snare, "Noise-body snare", "Fixed-rate sample · velocity-shaped backbeat and preserved ghost detail.")
  , (#hats, "Metallic noise hat", "Fixed-rate sample · shuffled sixteenths and delayed fills.")
  ]

withGainDb :: Float -> Instrument -> Instrument
withGainDb decibels = #gain %~ (* 10 ** (decibels / 20))

withGain :: Float -> Instrument -> Instrument
withGain gain = #gain .~ gain

roundBass :: Instrument
roundBass =
  Instrument.Instrument
    { voice
    , engine = Instrument.LadderMono patch
    , gain = 0.555
    }
  where
    voice =
      voice_ (mono_ Polyphony.LegatoEnvelopes) (adsr_ 0.002 0.11 0.58 0.09)
        & #filter ?~ filterStage_ (lowPassLadder_ 600 & resonance_ 0.14 & drive_ 1.1)
        & #modulators .~ Vector.singleton cutoffSweep
        & #routes .~ Vector.singleton cutoffSweepRoute
    cutoffSweep =
      Modulation.Modulator
        { sourceId = #cutoffSweep
        , signal = Modulation.Envelope (adsr_ 0.001 0.18 0.15 0.05)
        }
    cutoffSweepRoute =
      Modulation.Route
        { sourceId = #cutoffSweep
        , targetId = VoiceParameter.cutoffId
        , amount = VoiceParameter.cutoffOctaves 1.2
        , polarity = Parameter.Unipolar
        }
    patch =
      Instrument.Ladder
        { oscillators =
            bank_
              [ triangle_ & #level .~ 0.8
              , sine_ & #level .~ 0.2
              ]
        , noise = Oscillator.Noise{level = 0, color = 0}
        , glideSeconds = 0.08
        }

velvetPad :: Instrument
velvetPad =
  Pad.warmPad
    & #gain .~ 0.195
    & #voice %~ softenPad

softenPad :: Instrument.Voice -> Instrument.Voice
softenPad voice =
  voice
    & #filter . _Just . #patch . #cutoffHz .~ 892
    & #ampEnvelope . #attackSeconds .~ 0.6
    & #ampEnvelope . #releaseSeconds .~ 2.2

electricKeys :: Instrument
electricKeys = case Keys.chipPluck.engine of
  Instrument.Layers patch ->
    Instrument.Instrument
      { gain = 0.182
      , voice =
          Keys.chipPluck.voice
            & #ampEnvelope .~ envelope
            & #polyphony .~ voices_ 16
      , engine = Instrument.Layers (patch & #layers %~ Vector.singleton . tine . Vector.head)
      }
  _ -> Keys.chipPluck
  where
    envelope = adsr_ 0.004 0.8 0.12 0.24
    tine :: Layered.Layer -> Layered.Layer
    tine layer =
      layer
        & #source .~ Layered.AnalogSource (bank_ partials)
        & #gain .~ 1
        & #pan .~ 0
        & #selection .~ Layered.Stack
    partials =
      [ sine_ & #level .~ 0.8
      , sine_
          & #semitones .~ 12
          & #cents .~ 3
          & #level .~ 0.14
      , triangle_
          & #cents .~ -4
          & #level .~ 0.06
      ]