{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      : Harmonic.Interface.Tidal.Groove
-- Description : Rhythm section interface for sub-bass and kick patterns
--
-- Provides 'subKick' (sub-bass with CC64 sustain pedal) and 'fund'
-- (fundamental bass note extraction) for rhythm-section integration
-- with harmonically-generated progressions.
--
-- 'subKick' tracks the harmony: it reads the fundamental of whichever bar the
-- form is currently on, so the sub follows a modulation without being
-- rewritten. In a launcher it is an ordinary block:
--
-- @
-- subk f k d = p \"subk\" $ f
--   $ subKick k \"1 ~ ~ 1\" |* vel d
-- @
--
-- The note is held by a CC64 sustain pedal rather than by note length, so the
-- sub rings between onsets instead of retriggering — see 'subKick' for why
-- the sustain value and the pedal are paired.

module Harmonic.Interface.Tidal.Groove
  ( fund
  , subKick
  , noteoff
  ) where

import qualified Harmonic.Rules.Types.Pitch as Pitch
import qualified Harmonic.Rules.Types.Harmony as H
import qualified Harmonic.Rules.Types.Progression as P
import qualified Harmonic.Rules.Types.ProgressionContext as PC
import Harmonic.Interface.Tidal.Form (Kinetics(..), IK, ki)
import Data.List (nub, sortOn)
import Data.Maybe (catMaybes)
import Data.Foldable (toList)
import Sound.Tidal.Context

-- | Extract harmonic roots regardless of inversion.
-- Always returns the fundamental root note from CadenceState.
fund :: P.Progression -> [[Int]]
fund :: Progression -> [[Int]]
fund Progression
prog =
  let cadenceStates :: [CadenceState]
cadenceStates = Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
P.unProgression Progression
prog)
  in (CadenceState -> [Int]) -> [CadenceState] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map CadenceState -> [Int]
fundToInt [CadenceState]
cadenceStates
  where
    fundToInt :: H.CadenceState -> [Int]
    fundToInt :: CadenceState -> [Int]
fundToInt CadenceState
cs =
      let chord :: Chord
chord = CadenceState -> Chord
H.fromCadenceState CadenceState
cs
          rootNoteName :: NoteName
rootNoteName = Chord -> NoteName
H.chordNoteName Chord
chord
          rootPc :: PitchClass
rootPc = NoteName -> PitchClass
Pitch.pitchClass NoteName
rootNoteName
      in [PitchClass -> Int
Pitch.unPitchClass PitchClass
rootPc]

-- | Truncate each gate onset's note length to at most @1\/n@ of a bar (bar = 4
--   cycles), else extend it to the next onset. Only @True@ onsets sound; a
--   truncated tail is a rest; onsets are not moved. Pair with @# legato 1@ on
--   sustaining instruments to hear the length. Precondition: @n > 0@.
--
--   Bar patterns are written @\"\/4\"@ (1 cycle = 1 beat, 1 bar = 4 cycles), so
--   e.g. @noteoff 4@ caps each hit at a quarter note (1 cycle):
--
--   > noteoff 4 "[[1 0 0 0] [0 0 0 0] [1 0 0 0] [1 0 0 0]]\/4"  ==  "[1 0 1 1]\/4"
noteoff :: Time -> Pattern Bool -> Pattern Bool
noteoff :: Time -> Pattern Bool -> Pattern Bool
noteoff Time
n Pattern Bool
p = Pattern Bool -> Pattern Bool
forall a. Pattern a -> Pattern a
splitQueries (Pattern Bool -> Pattern Bool) -> Pattern Bool -> Pattern Bool
forall a b. (a -> b) -> a -> b
$ Pattern Bool
p { query = f, steps = Nothing, pureValue = Nothing }
  where
    barLen :: Time
barLen = Time
4
    cap :: Time
cap    = Time
barLen Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Time
n
    f :: State -> [EventF (ArcF Time) Bool]
f State
st =
      let a :: ArcF Time
a   = State -> ArcF Time
arc State
st
          b0 :: Time
b0  = Time
barLen Time -> Time -> Time
forall a. Num a => a -> a -> a
* Time -> Time
sam (ArcF Time -> Time
forall a. ArcF a -> a
start ArcF Time
a Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Time
barLen)          -- enclosing-bar start
          ons :: [EventF (ArcF Time) Bool]
ons = (EventF (ArcF Time) Bool -> Time)
-> [EventF (ArcF Time) Bool] -> [EventF (ArcF Time) Bool]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (ArcF Time -> Time
forall a. ArcF a -> a
start (ArcF Time -> Time)
-> (EventF (ArcF Time) Bool -> ArcF Time)
-> EventF (ArcF Time) Bool
-> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EventF (ArcF Time) Bool -> ArcF Time
forall a. Event a -> ArcF Time
wholeOrPart)
                  ([EventF (ArcF Time) Bool] -> [EventF (ArcF Time) Bool])
-> [EventF (ArcF Time) Bool] -> [EventF (ArcF Time) Bool]
forall a b. (a -> b) -> a -> b
$ (EventF (ArcF Time) Bool -> Bool)
-> [EventF (ArcF Time) Bool] -> [EventF (ArcF Time) Bool]
forall a. (a -> Bool) -> [a] -> [a]
filter (\EventF (ArcF Time) Bool
e -> EventF (ArcF Time) Bool -> Bool
forall a. Event a -> Bool
eventHasOnset EventF (ArcF Time) Bool
e Bool -> Bool -> Bool
&& EventF (ArcF Time) Bool -> Bool
forall a b. EventF a b -> b
value EventF (ArcF Time) Bool
e)
                  ([EventF (ArcF Time) Bool] -> [EventF (ArcF Time) Bool])
-> [EventF (ArcF Time) Bool] -> [EventF (ArcF Time) Bool]
forall a b. (a -> b) -> a -> b
$ Pattern Bool -> State -> [EventF (ArcF Time) Bool]
forall a. Pattern a -> State -> [Event a]
query Pattern Bool
p State
st { arc = Arc b0 (b0 + barLen) }
          nexts :: [Time]
nexts = Int -> [Time] -> [Time]
forall a. Int -> [a] -> [a]
drop Int
1 ((EventF (ArcF Time) Bool -> Time)
-> [EventF (ArcF Time) Bool] -> [Time]
forall a b. (a -> b) -> [a] -> [b]
map (ArcF Time -> Time
forall a. ArcF a -> a
start (ArcF Time -> Time)
-> (EventF (ArcF Time) Bool -> ArcF Time)
-> EventF (ArcF Time) Bool
-> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EventF (ArcF Time) Bool -> ArcF Time
forall a. Event a -> ArcF Time
wholeOrPart) [EventF (ArcF Time) Bool]
ons) [Time] -> [Time] -> [Time]
forall a. [a] -> [a] -> [a]
++ [Time
b0 Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
barLen]
          build :: EventF (ArcF Time) b -> Time -> Maybe (EventF (ArcF Time) b)
build EventF (ArcF Time) b
ev Time
nx =
            let s0 :: Time
s0 = ArcF Time -> Time
forall a. ArcF a -> a
start (EventF (ArcF Time) b -> ArcF Time
forall a. Event a -> ArcF Time
wholeOrPart EventF (ArcF Time) b
ev)
                w :: ArcF Time
w  = Time -> Time -> ArcF Time
forall a. a -> a -> ArcF a
Arc Time
s0 (Time -> Time -> Time
forall a. Ord a => a -> a -> a
min Time
nx (Time
s0 Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
cap))
            in (\ArcF Time
pt -> EventF (ArcF Time) b
ev { whole = Just w, part = pt }) (ArcF Time -> EventF (ArcF Time) b)
-> Maybe (ArcF Time) -> Maybe (EventF (ArcF Time) b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArcF Time -> ArcF Time -> Maybe (ArcF Time)
subArc ArcF Time
a ArcF Time
w
      in [Maybe (EventF (ArcF Time) Bool)] -> [EventF (ArcF Time) Bool]
forall a. [Maybe a] -> [a]
catMaybes ((EventF (ArcF Time) Bool
 -> Time -> Maybe (EventF (ArcF Time) Bool))
-> [EventF (ArcF Time) Bool]
-> [Time]
-> [Maybe (EventF (ArcF Time) Bool)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith EventF (ArcF Time) Bool -> Time -> Maybe (EventF (ArcF Time) Bool)
forall {b}.
EventF (ArcF Time) b -> Time -> Maybe (EventF (ArcF Time) b)
build [EventF (ArcF Time) Bool]
ons [Time]
nexts)

-- | Normalize pitch classes to C2-B2 range (MIDI 36-47) for MPC sub program.
-- Empty list returns 35 (B1, where no sample is assigned = silence).
-- Pitch classes [0-11] map to MIDI [36-47] (C2-B2).
normalizeToSubRange :: [Int] -> Int
normalizeToSubRange :: [Int] -> Int
normalizeToSubRange [] = Int
35  -- B1: no sample (silence)
normalizeToSubRange (Int
pc:[Int]
_) = Int
36 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
pc Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12)

-- | Groove interface using patterned chord selection with kinetics gating.
--
-- CC64 sustain mechanism with chord selection from 'IK'.
-- Sub on\/off patterns and kick pattern are bar-relative:
-- @\"[1]\/2\"@ = one onset every 2 bars, @\"1*4\"@ = 4 kicks per bar.
--
-- Chord selection uses 'innerJoin' — we WANT new note-ons when the
-- chord changes (unlike melodic instruments where sustain across
-- boundaries is desirable).
--
-- The progression is read from @kProg@ via @innerJoin@.
-- Sub is gated at @(0.1, 1)@ and kick at @(0.2, 1)@ via @ki@.
subKick :: Pattern Double               -- ^ Dynamics pattern (> 0 = sub active)
        -> IK                            -- ^ Performance context (kinetics + chord selection)
        -> (P.Progression -> [[Int]])    -- ^ Voice strategy (fund or bass)
        -> (Time,                        -- ^ Max sub duration before auto-off
            String,                      -- ^ Sub note on pattern string
            String,                      -- ^ Manual note off pattern string
            String)                      -- ^ Kick placement pattern string
        -> Pattern ValueMap
subKick :: Pattern Double
-> IK
-> (Progression -> [[Int]])
-> (Time, String, String, String)
-> Pattern ValueMap
subKick Pattern Double
dyn IK
k Progression -> [[Int]]
voiceFunc (Time
maxDur, String
subOnStr, String
subOffStr, String
kickStr) =
  let (Kinetics
kin, Pattern Int
chordPat) = IK
k
      -- Parse pattern strings ONCE at construction time (not per progression change)
      subOnPat :: Pattern Bool
subOnPat  = Pattern Time -> Pattern Bool -> Pattern Bool
forall a. Pattern Time -> Pattern a -> Pattern a
slow Pattern Time
4 (Pattern Bool -> Pattern Bool) -> Pattern Bool -> Pattern Bool
forall a b. (a -> b) -> a -> b
$ String -> Pattern Bool
forall a. (Enumerable a, Parseable a) => String -> Pattern a
parseBP_E String
subOnStr
      subOffPat :: Pattern Bool
subOffPat = Pattern Time -> Pattern Bool -> Pattern Bool
forall a. Pattern Time -> Pattern a -> Pattern a
slow Pattern Time
4 (Pattern Bool -> Pattern Bool) -> Pattern Bool -> Pattern Bool
forall a b. (a -> b) -> a -> b
$ String -> Pattern Bool
forall a. (Enumerable a, Parseable a) => String -> Pattern a
parseBP_E String
subOffStr
      kickPat :: Pattern Bool
kickPat   = Pattern Time -> Pattern Bool -> Pattern Bool
forall a. Pattern Time -> Pattern a -> Pattern a
slow Pattern Time
4 (Pattern Bool -> Pattern Bool) -> Pattern Bool -> Pattern Bool
forall a b. (a -> b) -> a -> b
$ String -> Pattern Bool
forall a. (Enumerable a, Parseable a) => String -> Pattern a
parseBP_E String
kickStr
      progPat :: Pattern Progression
progPat = (ProgressionContext -> Progression)
-> Pattern ProgressionContext -> Pattern Progression
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ProgressionContext -> Progression
PC.triadLayer (Kinetics -> Pattern ProgressionContext
kProg Kinetics
kin)
      -- Pre-compute voicings at construction time
      allEvents :: [Event Progression]
allEvents = Pattern Progression -> ArcF Time -> [Event Progression]
forall a. Pattern a -> ArcF Time -> [Event a]
queryArc Pattern Progression
progPat (Time -> Time -> ArcF Time
forall a. a -> a -> ArcF a
Arc Time
0 Time
1000)
      uniqueProgs :: [Progression]
uniqueProgs = [Progression] -> [Progression]
forall a. Eq a => [a] -> [a]
nub ((Event Progression -> Progression)
-> [Event Progression] -> [Progression]
forall a b. (a -> b) -> [a] -> [b]
map Event Progression -> Progression
forall a b. EventF a b -> b
value [Event Progression]
allEvents)
      cache :: [(Progression, ([Int], Int))]
cache = [(Progression
p, let raw :: [[Int]]
raw = Progression -> [[Int]]
voiceFunc Progression
p
                       norm :: [Int]
norm = ([Int] -> Int) -> [[Int]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> Int
normalizeToSubRange [[Int]]
raw
                       nc :: Int
nc = [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
norm
                   in ([Int]
norm, Int
nc))
              | Progression
p <- [Progression]
uniqueProgs]
      lookupCache :: Progression -> ([Int], Int)
lookupCache Progression
prog = case Progression -> [(Progression, ([Int], Int))] -> Maybe ([Int], Int)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Progression
prog [(Progression, ([Int], Int))]
cache of
        Just ([Int], Int)
hit -> ([Int], Int)
hit
        Maybe ([Int], Int)
Nothing  -> let raw :: [[Int]]
raw = Progression -> [[Int]]
voiceFunc Progression
prog
                    in (([Int] -> Int) -> [[Int]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> Int
normalizeToSubRange [[Int]]
raw, [[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
raw)
  in Pattern (Pattern ValueMap) -> Pattern ValueMap
forall b. Pattern (Pattern b) -> Pattern b
innerJoin (Pattern (Pattern ValueMap) -> Pattern ValueMap)
-> Pattern (Pattern ValueMap) -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ (Progression -> Pattern ValueMap)
-> Pattern Progression -> Pattern (Pattern ValueMap)
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Progression
prog ->
       ([Int], Int)
-> Pattern Bool
-> Pattern Bool
-> Pattern Bool
-> Pattern Int
-> Pattern Double
-> IK
-> Time
-> Pattern ValueMap
subKickCoreP (Progression -> ([Int], Int)
lookupCache Progression
prog) Pattern Bool
subOnPat Pattern Bool
subOffPat Pattern Bool
kickPat Pattern Int
chordPat Pattern Double
dyn IK
k Time
maxDur
     ) Pattern Progression
progPat

-- |Internal: subKick logic with ki gating on sub\/kick groups.
-- LEDs are no longer emitted from here; they are derived passively by the
-- SC-side coordinator from this channel's outgoing MIDI traffic.
subKickCore :: (P.Progression -> [[Int]])
            -> P.Progression
            -> Pattern Bool             -- ^ Pre-parsed sub on pattern
            -> Pattern Bool             -- ^ Pre-parsed sub off pattern
            -> Pattern Bool             -- ^ Pre-parsed kick pattern
            -> Pattern Int              -- ^ Chord selection pattern
            -> Pattern Double           -- ^ Dynamics
            -> IK
            -> Time                     -- ^ Max sub duration
            -> Pattern ValueMap
subKickCore :: (Progression -> [[Int]])
-> Progression
-> Pattern Bool
-> Pattern Bool
-> Pattern Bool
-> Pattern Int
-> Pattern Double
-> IK
-> Time
-> Pattern ValueMap
subKickCore Progression -> [[Int]]
voiceFunc Progression
prog Pattern Bool
subOnPat Pattern Bool
subOffPat Pattern Bool
kickPat Pattern Int
chordPat Pattern Double
dyn IK
k Time
maxDur
  | [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
normPitches = Pattern ValueMap
forall a. Pattern a
silence
  | Bool
otherwise =
  let
    -- CC helper
    midiCC :: Pattern Double -> Pattern Double -> Pattern ValueMap
midiCC Pattern Double
num Pattern Double
val = Pattern String -> Pattern ValueMap
midicmd Pattern String
"control" Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern Double -> Pattern ValueMap
ctlNum Pattern Double
num Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern Double -> Pattern ValueMap
control Pattern Double
val

    -- LED feedback helper (only used for the kick high-C indicator on CC 32;
    -- the 12 pitch-class LEDs CC 20-31 are driven by the SC-side coordinator)
    ledCC :: a -> a -> Pattern ValueMap
ledCC a
num a
val = Pattern String -> Pattern ValueMap
midicmd Pattern String
"control"
                  # ctlNum (fromIntegral num)
                  # control (fromIntegral val)

    -- Convert dynamics to boolean gate for mask
    dynGate :: Pattern Bool
dynGate = (Double -> Bool) -> Pattern Double -> Pattern Bool
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0) Pattern Double
dyn

    -- MIDI routing: channel 10 (0-indexed = midichan 9) on "thru" device
    thru :: Pattern ValueMap
thru = Pattern String -> Pattern ValueMap
s Pattern String
"thru" Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern Double -> Pattern ValueMap
midichan Pattern Double
9

    -- 0-indexed chord index from 1-indexed input, wrapping modulo nChords
    chordIdx :: Pattern Int
chordIdx = (Int -> Int) -> Pattern Int -> Pattern Int
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Int
i -> (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
nChords) Pattern Int
chordPat

    -- Sub pattern: note-ons gated by dynamics and structured by subOnPat
    subPattern :: Pattern ValueMap
subPattern = Pattern Bool -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Bool -> Pattern a -> Pattern a
mask Pattern Bool
dynGate (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ Pattern Bool -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Bool -> Pattern a -> Pattern a
struct Pattern Bool
subOnPat (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$
      Pattern (Pattern ValueMap) -> Pattern ValueMap
forall b. Pattern (Pattern b) -> Pattern b
innerJoin ((Int -> Pattern ValueMap)
-> Pattern Int -> Pattern (Pattern ValueMap)
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Int
ci ->
        Pattern Note -> Pattern ValueMap
midinote (Note -> Pattern Note
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Note -> Pattern Note) -> Note -> Pattern Note
forall a b. (a -> b) -> a -> b
$ Int -> Note
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Int]
normPitches [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! (Int
ci Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
nChords)))
        # sustain 0.01 # amp dyn
      ) Pattern Int
chordIdx)

    -- Kick pattern: fixed C3 (MIDI 48), one-shot
    kickPattern :: Pattern ValueMap
kickPattern = Pattern Bool -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Bool -> Pattern a -> Pattern a
struct Pattern Bool
kickPat (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ Pattern Note -> Pattern ValueMap
midinote Pattern Note
48 Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern Double -> Pattern ValueMap
sustain Pattern Double
0.01 Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern Double -> Pattern ValueMap
amp Pattern Double
1

    -- Sustain pedal: CC 64 = 127 continuous background
    -- 1\/128 offset avoids timestamp collision with note-on events
    sustainOn :: Pattern ValueMap
sustainOn = (Pattern Time
1Pattern Time -> Pattern Time -> Pattern Time
forall a. Fractional a => a -> a -> a
/Pattern Time
128) Pattern Time -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Time -> Pattern a -> Pattern a
~> Pattern Time -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Time -> Pattern a -> Pattern a
segment Pattern Time
16 (Pattern Double -> Pattern Double -> Pattern ValueMap
midiCC Pattern Double
64 Pattern Double
127)

    -- Auto note-off: CC 64 = 0 shifted by maxDur after each note-on
    autoOff :: Pattern ValueMap
autoOff
      | Time
maxDur Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
1 = Pattern ValueMap
forall a. Pattern a
silence
      | Bool
otherwise   = Pattern Bool -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Bool -> Pattern a -> Pattern a
struct ((Time -> Pattern Time
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Time
maxDur Time -> Time -> Time
forall a. Num a => a -> a -> a
* Time
4)) Pattern Time -> Pattern Bool -> Pattern Bool
forall a. Pattern Time -> Pattern a -> Pattern a
~> Pattern Bool
subOnPat) (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ Pattern Double -> Pattern Double -> Pattern ValueMap
midiCC Pattern Double
64 Pattern Double
0

    -- Manual note-off: CC 64 = 0 at user-specified boundaries
    manualOff :: Pattern ValueMap
manualOff = Pattern Bool -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Bool -> Pattern a -> Pattern a
struct Pattern Bool
subOffPat (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ Pattern Double -> Pattern Double -> Pattern ValueMap
midiCC Pattern Double
64 Pattern Double
0

    -- Kick LED: 1\/64 offset puts the CC on its own SuperDirt dispatch tick
    -- so it doesn't collide with the kick note under MIDI burst load.
    -- Pulse extended to 1\/8 cycle for reliable visual response.
    kickLedOn :: Pattern ValueMap
kickLedOn  = (Pattern Time
1Pattern Time -> Pattern Time -> Pattern Time
forall a. Fractional a => a -> a -> a
/Pattern Time
64) Pattern Time -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Time -> Pattern a -> Pattern a
~> (Pattern Bool -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Bool -> Pattern a -> Pattern a
struct Pattern Bool
kickPat (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Pattern ValueMap
forall {a} {a}.
(Integral a, Integral a) =>
a -> a -> Pattern ValueMap
ledCC Integer
32 Integer
1)
    kickLedOff :: Pattern ValueMap
kickLedOff = (Pattern Time
1Pattern Time -> Pattern Time -> Pattern Time
forall a. Fractional a => a -> a -> a
/Pattern Time
64) Pattern Time -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Time -> Pattern a -> Pattern a
~> (Pattern Bool -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Bool -> Pattern a -> Pattern a
struct ((Time -> Pattern Time
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Time
1Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/Time
8)) Pattern Time -> Pattern Bool -> Pattern Bool
forall a. Pattern Time -> Pattern a -> Pattern a
~> Pattern Bool
kickPat) (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Pattern ValueMap
forall {a} {a}.
(Integral a, Integral a) =>
a -> a -> Pattern ValueMap
ledCC Integer
32 Integer
0)

    -- Sub group: sub pattern + CC64 sustain
    subGroup :: Pattern ValueMap
subGroup = (Double, Double) -> IK -> Pattern ValueMap -> Pattern ValueMap
forall a. (Double, Double) -> IK -> Pattern a -> Pattern a
ki (Double
0.1, Double
1) IK
k (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ [Pattern ValueMap] -> Pattern ValueMap
forall a. [Pattern a] -> Pattern a
stack
      [ Pattern ValueMap
subPattern Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern ValueMap
thru
      , Pattern ValueMap
sustainOn Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern ValueMap
thru, Pattern ValueMap
autoOff Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern ValueMap
thru, Pattern ValueMap
manualOff Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern ValueMap
thru
      ]

    -- Kick group: kick pattern + kick LED (CC 32, high-C indicator)
    kickGroup :: Pattern ValueMap
kickGroup = (Double, Double) -> IK -> Pattern ValueMap -> Pattern ValueMap
forall a. (Double, Double) -> IK -> Pattern a -> Pattern a
ki (Double
0.2, Double
1) IK
k (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ [Pattern ValueMap] -> Pattern ValueMap
forall a. [Pattern a] -> Pattern a
stack
      [ Pattern ValueMap
kickPattern Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern ValueMap
thru
      , Pattern ValueMap
kickLedOn Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern ValueMap
thru, Pattern ValueMap
kickLedOff Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern ValueMap
thru
      ]

    -- Pedal up: CC64=0 when sub is inactive (kinetics below threshold)
    -- Resets physical instrument to default touch behaviour
    pedalUp :: Pattern ValueMap
pedalUp = Pattern Bool -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Bool -> Pattern a -> Pattern a
mask ((Double -> Bool) -> Pattern Double -> Pattern Bool
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0.1) (Kinetics -> Pattern Double
kSignal (IK -> Kinetics
forall a b. (a, b) -> a
fst IK
k))) (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ Pattern Time -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Time -> Pattern a -> Pattern a
segment Pattern Time
1 (Pattern Double -> Pattern Double -> Pattern ValueMap
midiCC Pattern Double
64 Pattern Double
0) Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern ValueMap
thru

  in [Pattern ValueMap] -> Pattern ValueMap
forall a. [Pattern a] -> Pattern a
stack [Pattern ValueMap
subGroup, Pattern ValueMap
kickGroup, Pattern ValueMap
pedalUp]
  where
    rawPitches :: [[Int]]
rawPitches  = Progression -> [[Int]]
voiceFunc Progression
prog
    normPitches :: [Int]
normPitches = ([Int] -> Int) -> [[Int]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> Int
normalizeToSubRange [[Int]]
rawPitches
    nChords :: Int
nChords     = [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
normPitches

-- |Cached subKick: takes pre-computed (normPitches, nChords) and pre-parsed patterns.
-- All CC64\/sustain\/timing logic identical to subKickCore. LEDs are not emitted
-- here — the SC-side coordinator derives them from outgoing MIDI on ch 10.
subKickCoreP :: ([Int], Int)
             -> Pattern Bool             -- ^ Pre-parsed sub on pattern
             -> Pattern Bool             -- ^ Pre-parsed sub off pattern
             -> Pattern Bool             -- ^ Pre-parsed kick pattern
             -> Pattern Int              -- ^ Chord selection pattern
             -> Pattern Double           -- ^ Dynamics
             -> IK
             -> Time                     -- ^ Max sub duration
             -> Pattern ValueMap
subKickCoreP :: ([Int], Int)
-> Pattern Bool
-> Pattern Bool
-> Pattern Bool
-> Pattern Int
-> Pattern Double
-> IK
-> Time
-> Pattern ValueMap
subKickCoreP ([Int]
normPitches, Int
nChords) Pattern Bool
subOnPat Pattern Bool
subOffPat Pattern Bool
kickPat Pattern Int
chordPat Pattern Double
dyn IK
k Time
maxDur
  | Int
nChords Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Pattern ValueMap
forall a. Pattern a
silence
  | Bool
otherwise =
  let
    -- CC helper
    midiCC :: Pattern Double -> Pattern Double -> Pattern ValueMap
midiCC Pattern Double
num Pattern Double
val = Pattern String -> Pattern ValueMap
midicmd Pattern String
"control" Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern Double -> Pattern ValueMap
ctlNum Pattern Double
num Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern Double -> Pattern ValueMap
control Pattern Double
val

    -- LED feedback helper (only used for the kick high-C indicator on CC 32;
    -- the 12 pitch-class LEDs CC 20-31 are driven by the SC-side coordinator)
    ledCC :: a -> a -> Pattern ValueMap
ledCC a
num a
val = Pattern String -> Pattern ValueMap
midicmd Pattern String
"control"
                  # ctlNum (fromIntegral num)
                  # control (fromIntegral val)

    -- Convert dynamics to boolean gate for mask
    dynGate :: Pattern Bool
dynGate = (Double -> Bool) -> Pattern Double -> Pattern Bool
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0) Pattern Double
dyn

    -- MIDI routing: channel 10 (0-indexed = midichan 9) on "thru" device
    thru :: Pattern ValueMap
thru = Pattern String -> Pattern ValueMap
s Pattern String
"thru" Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern Double -> Pattern ValueMap
midichan Pattern Double
9

    -- 0-indexed chord index from 1-indexed input, wrapping modulo nChords
    chordIdx :: Pattern Int
chordIdx = (Int -> Int) -> Pattern Int -> Pattern Int
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Int
i -> (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
nChords) Pattern Int
chordPat

    -- Sub pattern: note-ons gated by dynamics and structured by subOnPat
    subPattern :: Pattern ValueMap
subPattern = Pattern Bool -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Bool -> Pattern a -> Pattern a
mask Pattern Bool
dynGate (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ Pattern Bool -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Bool -> Pattern a -> Pattern a
struct Pattern Bool
subOnPat (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$
      Pattern (Pattern ValueMap) -> Pattern ValueMap
forall b. Pattern (Pattern b) -> Pattern b
innerJoin ((Int -> Pattern ValueMap)
-> Pattern Int -> Pattern (Pattern ValueMap)
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Int
ci ->
        Pattern Note -> Pattern ValueMap
midinote (Note -> Pattern Note
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Note -> Pattern Note) -> Note -> Pattern Note
forall a b. (a -> b) -> a -> b
$ Int -> Note
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Int]
normPitches [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! (Int
ci Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
nChords)))
        # sustain 0.01 # amp dyn
      ) Pattern Int
chordIdx)

    -- Kick pattern: fixed C3 (MIDI 48), one-shot
    kickPattern :: Pattern ValueMap
kickPattern = Pattern Bool -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Bool -> Pattern a -> Pattern a
struct Pattern Bool
kickPat (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ Pattern Note -> Pattern ValueMap
midinote Pattern Note
48 Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern Double -> Pattern ValueMap
sustain Pattern Double
0.01 Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern Double -> Pattern ValueMap
amp Pattern Double
1

    -- Sustain pedal: CC 64 = 127 continuous background
    -- 1\/128 offset avoids timestamp collision with note-on events
    sustainOn :: Pattern ValueMap
sustainOn = (Pattern Time
1Pattern Time -> Pattern Time -> Pattern Time
forall a. Fractional a => a -> a -> a
/Pattern Time
128) Pattern Time -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Time -> Pattern a -> Pattern a
~> Pattern Time -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Time -> Pattern a -> Pattern a
segment Pattern Time
16 (Pattern Double -> Pattern Double -> Pattern ValueMap
midiCC Pattern Double
64 Pattern Double
127)

    -- Auto note-off: CC 64 = 0 shifted by maxDur after each note-on
    autoOff :: Pattern ValueMap
autoOff
      | Time
maxDur Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
1 = Pattern ValueMap
forall a. Pattern a
silence
      | Bool
otherwise   = Pattern Bool -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Bool -> Pattern a -> Pattern a
struct ((Time -> Pattern Time
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Time
maxDur Time -> Time -> Time
forall a. Num a => a -> a -> a
* Time
4)) Pattern Time -> Pattern Bool -> Pattern Bool
forall a. Pattern Time -> Pattern a -> Pattern a
~> Pattern Bool
subOnPat) (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ Pattern Double -> Pattern Double -> Pattern ValueMap
midiCC Pattern Double
64 Pattern Double
0

    -- Manual note-off: CC 64 = 0 at user-specified boundaries
    manualOff :: Pattern ValueMap
manualOff = Pattern Bool -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Bool -> Pattern a -> Pattern a
struct Pattern Bool
subOffPat (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ Pattern Double -> Pattern Double -> Pattern ValueMap
midiCC Pattern Double
64 Pattern Double
0

    -- Kick LED: 1\/64 offset puts the CC on its own SuperDirt dispatch tick
    -- so it doesn't collide with the kick note under MIDI burst load.
    -- Pulse extended to 1\/8 cycle for reliable visual response.
    kickLedOn :: Pattern ValueMap
kickLedOn  = (Pattern Time
1Pattern Time -> Pattern Time -> Pattern Time
forall a. Fractional a => a -> a -> a
/Pattern Time
64) Pattern Time -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Time -> Pattern a -> Pattern a
~> (Pattern Bool -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Bool -> Pattern a -> Pattern a
struct Pattern Bool
kickPat (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Pattern ValueMap
forall {a} {a}.
(Integral a, Integral a) =>
a -> a -> Pattern ValueMap
ledCC Integer
32 Integer
1)
    kickLedOff :: Pattern ValueMap
kickLedOff = (Pattern Time
1Pattern Time -> Pattern Time -> Pattern Time
forall a. Fractional a => a -> a -> a
/Pattern Time
64) Pattern Time -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Time -> Pattern a -> Pattern a
~> (Pattern Bool -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Bool -> Pattern a -> Pattern a
struct ((Time -> Pattern Time
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Time
1Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/Time
8)) Pattern Time -> Pattern Bool -> Pattern Bool
forall a. Pattern Time -> Pattern a -> Pattern a
~> Pattern Bool
kickPat) (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Pattern ValueMap
forall {a} {a}.
(Integral a, Integral a) =>
a -> a -> Pattern ValueMap
ledCC Integer
32 Integer
0)

    -- Sub group: sub pattern + CC64 sustain
    subGroup :: Pattern ValueMap
subGroup = (Double, Double) -> IK -> Pattern ValueMap -> Pattern ValueMap
forall a. (Double, Double) -> IK -> Pattern a -> Pattern a
ki (Double
0.1, Double
1) IK
k (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ [Pattern ValueMap] -> Pattern ValueMap
forall a. [Pattern a] -> Pattern a
stack
      [ Pattern ValueMap
subPattern Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern ValueMap
thru
      , Pattern ValueMap
sustainOn Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern ValueMap
thru, Pattern ValueMap
autoOff Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern ValueMap
thru, Pattern ValueMap
manualOff Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern ValueMap
thru
      ]

    -- Kick group: kick pattern + kick LED (CC 32, high-C indicator)
    kickGroup :: Pattern ValueMap
kickGroup = (Double, Double) -> IK -> Pattern ValueMap -> Pattern ValueMap
forall a. (Double, Double) -> IK -> Pattern a -> Pattern a
ki (Double
0.2, Double
1) IK
k (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ [Pattern ValueMap] -> Pattern ValueMap
forall a. [Pattern a] -> Pattern a
stack
      [ Pattern ValueMap
kickPattern Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern ValueMap
thru
      , Pattern ValueMap
kickLedOn Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern ValueMap
thru, Pattern ValueMap
kickLedOff Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern ValueMap
thru
      ]

    -- Pedal up: CC64=0 when sub is inactive (kinetics below threshold)
    -- Resets physical instrument to default touch behaviour
    pedalUp :: Pattern ValueMap
pedalUp = Pattern Bool -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Bool -> Pattern a -> Pattern a
mask ((Double -> Bool) -> Pattern Double -> Pattern Bool
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0.1) (Kinetics -> Pattern Double
kSignal (IK -> Kinetics
forall a b. (a, b) -> a
fst IK
k))) (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ Pattern Time -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Time -> Pattern a -> Pattern a
segment Pattern Time
1 (Pattern Double -> Pattern Double -> Pattern ValueMap
midiCC Pattern Double
64 Pattern Double
0) Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern ValueMap
thru

  in [Pattern ValueMap] -> Pattern ValueMap
forall a. [Pattern a] -> Pattern a
stack [Pattern ValueMap
subGroup, Pattern ValueMap
kickGroup, Pattern ValueMap
pedalUp]