-- |
-- Module      : Harmonic.Interface.Tidal.Groove
-- Description : Rhythm section interface for sub-bass and kick patterns
--
-- Provides 'subKick' (sub-bass and kick, held by note duration) 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 d k fund (1\/2, \"1 ~ ~ ~\", \"~\", \"~ ~ 1 ~\")
-- @
--
-- (dynamics, context, voice strategy, then (maxDur, sub-on, manual-off,
-- kick) pattern strings). Dynamics discipline: the launcher @d@ is the
-- only dynamic applied — 'subKick' deliberately ignores the form's
-- 'kDynamic' envelope, so the sub holds its level while the orchestra
-- swells and ducks around it.
--
-- Each sub note rings from its onset to the next kill boundary by its own note
-- length ('holdToNext' + @legato 1@) — see 'subKick' for why the hold is by
-- duration and not by a CC64 pedal.

module Harmonic.Interface.Tidal.Groove
  ( fund
  , subKick
  , holdToNext
  , noteoff
    -- * Clave and cascara grids
  , son32, son23, rumba32, rumba23, bossa32, bossa23, bellpat32, bellpat23
  ) where

import qualified Harmonic.Rules.Types.Pitch as Pitch
import qualified Harmonic.Rules.Import.Jazz as J
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, mapMaybe)
import Data.Foldable (toList)
import Sound.Tidal.Context

-- | Extract harmonic roots regardless of inversion — the harmonic
-- FUNDAMENTAL uniformly, where 'Harmonic.Interface.Tidal.Arranger.root'
-- is uniformly the sounding bass. Triads go through inversion detection
-- (a first-inversion bar reports its harmonic root, not its bass). Bars
-- of more than three tones ask the jazz namer for the rotation: a slash
-- structure (Bb7 over Ab) reports its true root (Bb), matching the
-- chart-convention grid name; a root-position extended chord — and any
-- set the namer cannot read — keeps its stored anchor. The walking bass
-- is unaffected either way: it anchors on the stored root internally
-- and reads a voice function only for beat-1 pitch choice.
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
      | [PitchClass] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Cadence -> [PitchClass]
H.cadenceIntervals (CadenceState -> Cadence
H.stateCadence CadenceState
cs)) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
3 =
          let anchor :: Int
anchor = PitchClass -> Int
Pitch.unPitchClass (NoteName -> PitchClass
Pitch.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
cs))
              ivs :: [Int]
ivs    = (PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
Pitch.unPitchClass (Cadence -> [PitchClass]
H.cadenceIntervals (CadenceState -> Cadence
H.stateCadence CadenceState
cs))
          in case [Int] -> Maybe (Text, Int)
J.jazzFunctionalityR [Int]
ivs of
               Just (Text
_, Int
d) | Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 -> [(Int
anchor Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12]
               Maybe (Text, Int)
_                    -> [Int
anchor]
      | Bool
otherwise =
          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
nBeats 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
nBeats
    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 :: Event b -> Time -> Maybe (Event b)
build Event b
ev Time
nx =
            let s0 :: Time
s0 = ArcF Time -> Time
forall a. ArcF a -> a
start (Event b -> ArcF Time
forall a. Event a -> ArcF Time
wholeOrPart Event 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 -> Event b
ev { whole = Just w, part = pt }) (ArcF Time -> Event b) -> Maybe (ArcF Time) -> Maybe (Event 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}. Event b -> Time -> Maybe (Event 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)

-- | Hold each onset of @pat@ until the next onset in @bounds@, rewriting the
-- event whole to @[onset, nextBoundary)@ (continuation fragments across cycles
-- are preserved). A boundary is where the note must stop, so the note stops
-- exactly there. Pair with @# legato 1@ so the emitted MIDI note-off lands on the
-- boundary. Values are sampled once at the onset and held for the whole note
-- (no mid-note re-sampling). @look@ is the lookahead\/lookback in cycles; note
-- lengths must not exceed it.
holdToNext :: Time -> Pattern Bool -> Pattern a -> Pattern a
holdToNext :: forall a. Time -> Pattern Bool -> Pattern a -> Pattern a
holdToNext Time
look Pattern Bool
bounds Pattern a
pat =
  Pattern a -> Pattern a
forall a. Pattern a -> Pattern a
splitQueries (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ Pattern a
pat { query = f, steps = Nothing, pureValue = Nothing }
  where
    f :: State -> [EventF (ArcF Time) a]
f State
st =
      let a :: ArcF Time
a    = State -> ArcF Time
arc State
st
          c0 :: Time
c0   = Time -> Time
sam (ArcF Time -> Time
forall a. ArcF a -> a
start ArcF Time
a)
          -- Onsets from up to `look` cycles back may still be sounding now.
          ons :: [EventF (ArcF Time) a]
ons  = (EventF (ArcF Time) a -> Bool)
-> [EventF (ArcF Time) a] -> [EventF (ArcF Time) a]
forall a. (a -> Bool) -> [a] -> [a]
filter EventF (ArcF Time) a -> Bool
forall a. Event a -> Bool
eventHasOnset
                   ([EventF (ArcF Time) a] -> [EventF (ArcF Time) a])
-> [EventF (ArcF Time) a] -> [EventF (ArcF Time) a]
forall a b. (a -> b) -> a -> b
$ Pattern a -> State -> [EventF (ArcF Time) a]
forall a. Pattern a -> State -> [Event a]
query Pattern a
pat State
st { arc = Arc (c0 - look) (c0 + 1) }
          bnds :: [Time]
bnds = (Time -> Time) -> [Time] -> [Time]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Time -> Time
forall a. a -> a
id
                   ([Time] -> [Time]) -> [Time] -> [Time]
forall a b. (a -> b) -> a -> b
$ (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] -> [Time])
-> [EventF (ArcF Time) Bool] -> [Time]
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
bounds State
st { arc = Arc (c0 - look) (c0 + look + 1) }
          nextB :: Time -> Time
nextB Time
s0 = case (Time -> Bool) -> [Time] -> [Time]
forall a. (a -> Bool) -> [a] -> [a]
filter (Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
> Time
s0) [Time]
bnds of
                       (Time
x:[Time]
_) -> Time
x
                       []    -> Time
c0 Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
look Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
1
          build :: Event b -> Maybe (Event b)
build Event b
ev =
            let s0 :: Time
s0 = ArcF Time -> Time
forall a. ArcF a -> a
start (Event b -> ArcF Time
forall a. Event a -> ArcF Time
wholeOrPart Event b
ev)
                w :: ArcF Time
w  = Time -> Time -> ArcF Time
forall a. a -> a -> ArcF a
Arc Time
s0 (Time -> Time
nextB Time
s0)
            in (\ArcF Time
pt -> Event b
ev { whole = Just w, part = pt }) (ArcF Time -> Event b) -> Maybe (ArcF Time) -> Maybe (Event 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 (EventF (ArcF Time) a -> Maybe (EventF (ArcF Time) a))
-> [EventF (ArcF Time) a] -> [EventF (ArcF Time) a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe EventF (ArcF Time) a -> Maybe (EventF (ArcF Time) a)
forall {b}. Event b -> Maybe (Event b)
build [EventF (ArcF Time) a]
ons

-- | Groove interface: kick and sub bass locked to the harmony, with chord
-- selection and kinetics gating from 'IK'.
--
-- Sub on\/off patterns and the kick pattern are bar-relative:
-- @\"[1]\/2\"@ = one onset every 2 bars, @\"1*4\"@ = 4 kicks per bar.
--
-- Each sub note is held by its own duration: from its onset to the next kill
-- boundary — the manual offs (@subOffPat@) and, for @maxDur < 1@, each onset
-- shifted by @maxDur*4@ — emitted with @legato 1@ so the note-off lands on the
-- boundary. The hold is by note length, not by a CC64 pedal: the MPC sub
-- program does not treat CC64 as a damper (a MIDI note-off arriving under a
-- held pedal is stranded), so no CC64 is emitted here at all.
--
-- Chord selection uses 'innerJoin' — we WANT new note-ons when the chord
-- changes. Sub is gated at @(0.1, 1)@ and kick at @(0.2, 1)@ via 'ki'. The
-- launcher dynamic is the only dynamic applied — 'subKick' deliberately
-- ignores the form's 'kDynamic' envelope, so the sub holds its level while the
-- orchestra swells and ducks around it.
subKick :: Pattern Double
         -> IK
         -> (P.Progression -> [[Int]])
         -> (Time, String, String, 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
      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)
      uniqueProgs :: [Progression]
uniqueProgs = [Progression] -> [Progression]
forall a. Eq a => [a] -> [a]
nub ((ProgressionContext -> Progression)
-> [ProgressionContext] -> [Progression]
forall a b. (a -> b) -> [a] -> [b]
map ProgressionContext -> Progression
PC.triadLayer (Kinetics -> [ProgressionContext]
kProgs Kinetics
kin))
      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]
      cacheForced :: ()
cacheForced = ((Progression, ([Int], Int)) -> () -> ())
-> () -> [(Progression, ([Int], Int))] -> ()
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Progression
_, ([Int]
ns, Int
cnt)) ()
acc -> [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
ns Int -> () -> ()
forall a b. a -> b -> b
`seq` Int
cnt Int -> () -> ()
forall a b. a -> b -> b
`seq` ()
acc) () [(Progression, ([Int], Int))]
cache
      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 ()
cacheForced () -> Pattern ValueMap -> Pattern ValueMap
forall a b. a -> b -> b
`seq` 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

-- |Cached subKick core: takes pre-computed (normPitches, nChords) and
-- pre-parsed patterns, and carries the note-duration \/ kill-boundary logic.
-- LEDs are not emitted here — the SC-side coordinator derives them from
-- outgoing MIDI on ch 10.
subKickCoreP :: ([Int], Int)
              -> Pattern Bool
              -> Pattern Bool
              -> Pattern Bool
              -> Pattern Int
              -> Pattern Double
              -> IK
              -> Time
              -> 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
    ledCC :: a -> a -> Pattern ValueMap
ledCC a
num a
cval = Pattern String -> Pattern ValueMap
midicmd Pattern String
"control"
                  # ctlNum (fromIntegral num)
                  # control (fromIntegral cval)

    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
    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
    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

    -- Kill boundaries: manual offs (subOffPat) plus auto offs (each onset +
    -- maxDur*4). maxDur >= 1 means manual-off only.
    killBounds :: Pattern Bool
killBounds
      | Time
maxDur Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
1 = Pattern Bool
subOffPat
      | Bool
otherwise   = [Pattern Bool] -> Pattern Bool
forall a. [Pattern a] -> Pattern a
stack [Pattern Bool
subOffPat, (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]

    -- Note-ons with pitch sampled once per onset, then each whole extended to
    -- the next kill boundary and emitted as a real note (legato 1 -> SuperDirt
    -- sends the note-off on the boundary).
    subOnsets :: Pattern ValueMap
subOnsets = 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)))
        # amp dyn
      ) Pattern Int
chordIdx)
    subPattern :: Pattern ValueMap
subPattern = Time -> Pattern Bool -> Pattern ValueMap -> Pattern ValueMap
forall a. Time -> Pattern Bool -> Pattern a -> Pattern a
holdToNext Time
8 Pattern Bool
killBounds Pattern ValueMap
subOnsets Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern Double -> Pattern ValueMap
legato Pattern Double
1

    -- Kick: 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
    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
$ Int -> Int -> Pattern ValueMap
forall {a} {a}.
(Integral a, Integral a) =>
a -> a -> Pattern ValueMap
ledCC (Int
32 :: Int) (Int
1 :: Int))
    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
$ Int -> Int -> Pattern ValueMap
forall {a} {a}.
(Integral a, Integral a) =>
a -> a -> Pattern ValueMap
ledCC (Int
32 :: Int) (Int
0 :: Int))

    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
subPattern Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern ValueMap
thru
    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
      ]

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

-- | Explicit 16-step (2-bar) boolean grids, one stroke per position, for
-- clave and cascara feels. Use with @struct@ or @mask@ on any instrument or
-- drum part.
--
-- @32@ is the 3-2 orientation; @23@ is the 2-3 rotation (@2 \<~@ over the
-- @\/4@ two-bar span swaps the halves). Onset positions are 1-indexed.
son32, son23, rumba32, rumba23, bossa32, bossa23,
  bellpat32, bellpat23 :: Pattern Bool
son32 :: Pattern Bool
son32     = Pattern Bool
"[1 0 0 1 0 0 1 0 0 0 1 0 1 0 0 0]/4"   -- son clave 3-2:   1 4 7 11 13
son23 :: Pattern Bool
son23     = Pattern Time
2 Pattern Time -> Pattern Bool -> Pattern Bool
forall a. Pattern Time -> Pattern a -> Pattern a
<~ Pattern Bool
son32
rumba32 :: Pattern Bool
rumba32   = Pattern Bool
"[1 0 0 1 0 0 0 1 0 0 1 0 1 0 0 0]/4"   -- rumba clave 3-2: 1 4 8 11 13
rumba23 :: Pattern Bool
rumba23   = Pattern Time
2 Pattern Time -> Pattern Bool -> Pattern Bool
forall a. Pattern Time -> Pattern a -> Pattern a
<~ Pattern Bool
rumba32
bossa32 :: Pattern Bool
bossa32   = Pattern Bool
"[1 0 0 1 0 0 0 1 0 0 1 0 0 1 0 0]/4"   -- bossa clave 3-2: 1 4 8 11 14
bossa23 :: Pattern Bool
bossa23   = Pattern Time
2 Pattern Time -> Pattern Bool -> Pattern Bool
forall a. Pattern Time -> Pattern a -> Pattern a
<~ Pattern Bool
bossa32
bellpat32 :: Pattern Bool
bellpat32 = Pattern Bool
"[1 0 1 0 1 1 0 1 1 0 1 1 0 1 0 1]/4"   -- bell / cascara:  1 3 5 6 8 9 11 12 14 16
bellpat23 :: Pattern Bool
bellpat23 = Pattern Time
2 Pattern Time -> Pattern Bool -> Pattern Bool
forall a. Pattern Time -> Pattern a -> Pattern a
<~ Pattern Bool
bellpat32