-- |
-- Module      : Harmonic.Interface.Tidal.Bridge
-- Description : TidalCycles interface for harmonic progressions
--
-- Bridge between the harmonic generation engine and TidalCycles live coding.
-- Chord selection via mininotation patterns (@Pattern Int@).
--
-- Two arrangement strategies:
--
-- * 'arrange' — onset-join with kinetics range gating: each note maps
--   through the chord active at its onset time, masked by kinetics signal.
--
-- * 'arrange'' — squeeze with kinetics range gating: each chord slot
--   gets the full input pattern compressed to fit.
--
-- Both take a progression modifier @(P.Progression -> P.Progression)@
-- and read the base progression from @kProg k@ via @innerJoin@.

module Harmonic.Interface.Tidal.Bridge
  ( -- * Voice Functions
    VoiceFunction
  , voiceRange
  , layerForVoicing

    -- * Chord Selection Helpers
  , warp
  , rep

    -- * Arrangement
  , arrange       -- onset-join with kinetics
  , arrange'      -- squeeze with kinetics

    -- * Natural harmonics (the composite overtone series)
  , Tuning
  , ecbc
  , composite
  , harmonics
  , overtoneMap
  , overtoneTable
  , compositeSeries
  , stringPitches
  , partialOffset

    -- * Parallelism Harmoniser
  , parallel      -- stack fixed-interval parallel voices over arrange output

    -- * Harmonic state for an external note-mapper
  , harmonicState

    -- * Chord Lookup
  , lookupChordAt
  , lookupChord
  , lookupProgression

    -- * Progression Overlap (Re-exports from Arranger)
  , overlapF
  , overlapB
  , overlap

    -- * Eager-forcing helper (shared with LineHarmony)
  , forceAll
  ) where

-- Phase B imports
import qualified Harmonic.Rules.Types.Progression as P
import qualified Harmonic.Rules.Types.ProgressionContext as PC
import Harmonic.Rules.Types.ProgressionContext (Layer(..))
import qualified Harmonic.Rules.Types.Harmony as H
import qualified Harmonic.Rules.Types.Pitch as Pitch
import qualified Harmonic.Interface.Tidal.Arranger as A
import Harmonic.Interface.Tidal.Form (Kinetics(..), IK)
import Harmonic.Interface.Tidal.Utils (mono')

import Data.Foldable (toList)
import Data.List (sort, nub, nubBy, intercalate)
import Data.Maybe (isJust)
import Sound.Tidal.Context hiding (voice)

-------------------------------------------------------------------------------
-- Voice Function Types
-------------------------------------------------------------------------------

-- |Voice function type: extracts integer pitch sequences from progression
type VoiceFunction = P.Progression -> [[Int]]

-- |Filter pattern events by DEGREE-INDEX range — the raw @Pattern Int@
-- values before the degree→pitch mapping, NOT MIDI notes. Instrument
-- range clipping in MIDI space happens later, via
-- 'Harmonic.Interface.Tidal.Orchestra.clip'.
voiceRange :: (Int, Int) -> Pattern Int -> Pattern Int
voiceRange :: (Int, Int) -> Pattern Int -> Pattern Int
voiceRange (Int
lo, Int
hi) = (Int -> Bool) -> Pattern Int -> Pattern Int
forall a. (a -> Bool) -> Pattern a -> Pattern a
filterValues (\Int
v -> Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
lo Bool -> Bool -> Bool
&& Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
hi)

-- |Force every element of a nested 'Note' list to WHNF. Used to hoist the
-- per-bar voicing computation (which can be expensive for large mode
-- chroma) from the audio query thread to REPL evaluation time. Returns
-- @()@ so callers can compose via 'seq'.
forceAll :: [[Note]] -> ()
forceAll :: [[Note]] -> ()
forceAll = ([Note] -> () -> ()) -> () -> [[Note]] -> ()
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\[Note]
xs ()
acc -> (Note -> () -> ()) -> () -> [Note] -> ()
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Note -> () -> ()
forall a b. a -> b -> b
seq ()
acc [Note]
xs) ()

-------------------------------------------------------------------------------
-- Chord Selection Helpers
-------------------------------------------------------------------------------

-- |Parse a mininotation chord selection pattern (bar-relative).
-- The @/N@ divisor specifies the number of bars the pattern spans.
--
-- @
-- let r = warp \"[1 2 3 4]\/4\"   -- 4 chords over 4 bars (1 per bar)
-- let r = warp \"[1 2]\/8\"       -- 2 chords over 8 bars (4 bars each)
-- @
warp :: String -> Pattern Int
warp :: [Char] -> Pattern Int
warp [Char]
str = Pattern Time -> Pattern Int -> Pattern Int
forall a. Pattern Time -> Pattern a -> Pattern a
slow Pattern Time
4 (Pattern Int -> Pattern Int) -> Pattern Int -> Pattern Int
forall a b. (a -> b) -> a -> b
$ [Char] -> Pattern Int
forall a. (Enumerable a, Parseable a) => [Char] -> Pattern a
parseBP_E [Char]
str

-- |Generate a sequential chord selection pattern from a progression.
-- Auto-derives length from the progression. Timing is bar-relative.
--
-- @
-- let r = rep s4 1     -- 4 chords over 4 bars (1 bar each)
-- let r = rep s4 0.5   -- 4 chords over 2 bars (half bar each)
-- @
rep :: PC.ProgressionContext -> Pattern Time -> Pattern Int
rep :: ProgressionContext -> Pattern Time -> Pattern Int
rep ProgressionContext
pc Pattern Time
repVal =
  let barsN :: Int
barsN = ProgressionContext -> Int
PC.pcLength ProgressionContext
pc
  in Pattern Time -> Pattern Int -> Pattern Int
forall a. Pattern Time -> Pattern a -> Pattern a
slow (Int -> Pattern Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
barsN Pattern Time -> Pattern Time -> Pattern Time
forall a. Num a => a -> a -> a
* Pattern Time
repVal Pattern Time -> Pattern Time -> Pattern Time
forall a. Num a => a -> a -> a
* Pattern Time
4) (Pattern Int -> Pattern Int) -> Pattern Int -> Pattern Int
forall a b. (a -> b) -> a -> b
$ [Pattern Int] -> Pattern Int
forall a. [Pattern a] -> Pattern a
fastcat ([Pattern Int] -> Pattern Int) -> [Pattern Int] -> Pattern Int
forall a b. (a -> b) -> a -> b
$ (Int -> Pattern Int) -> [Int] -> [Pattern Int]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Pattern Int
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Int
1..Int
barsN]

-------------------------------------------------------------------------------
-- Arrangement: arrange (onset-join)
-------------------------------------------------------------------------------

-- |Map notes through chords using onset-time lookup, with kinetics range gating.
--
-- The base progression and chord selection are read from @IK@.
-- The modifier function transforms the progression (e.g. @overlapF 0@, @id@).
-- Events are masked by the kinetics signal: only active when kSignal is
-- within the @(lo, hi)@ range. Form-driven dynamics (@kDynamic@) are applied
-- automatically.
--
-- Parameter order: context first (kinetics range, IK, MIDI range), then
-- interactive (voice function, modifier, patterns).
-- |Project the requested layer from a context together with its voicing
-- route. Chroma routing: the S\/M layers of a genP-provenance context are
-- THE curated 5\/7-PC chroma, and the S\/M layers of a chordscale-derived
-- gen \/ genJ context are the analysis pentatonic \/ mode chroma — both are
-- always voiced by 'A.strataModeFlow', lattice semantics: pattern index
-- @i@ addresses the i-th slot of a fixed pitch lattice grounded on bar 0
-- and inflected per bar — a held index pedals its pitch across key areas
-- rather than transposing with each bar's root. The T
-- layer always honours the user's 'VoiceFunction', as do the S\/M layers
-- of genE contexts (independent partner triads — ordinary harmony, so
-- never chroma-routed) and of contexts whose layers are still literal
-- duplicates (hand-built material without
-- 'Harmonic.Evaluation.Analysis.KeyArea.chordscale').
--
-- Routing by provenance \/ derived-chroma detection replaces the old
-- first-bar cardinality sniff (@isOctaSM@), which mis-routed
-- mixed-cardinality material in both directions (triad-first-bar chroma
-- escaped to the DP; 4-note-first-bar harmony was captured by the chroma
-- engine). Derived detection requires BOTH a distinct mode layer AND
-- every mode bar at chroma cardinality (≥5) — so a subst-downgraded genE
-- context (distinct but triadic layers) and a bar-substituted derived
-- context (mixed cardinality after the edit) both fall back to the user's
-- 'VoiceFunction' rather than half-claiming lattice semantics.
-- A genE context is excluded whole, combination selectors included. Its
-- @S@\/@M@ are partner triads, and its @SM@\/@TSM@ unions are polytonal
-- SONORITIES — three stacked triads, five tones — not scale forms, so the
-- cyclic DP is the right tool for them and 'A.hasBigChroma' correctly
-- declines to reroute a uniform 5-PC progression. Deliberate, not a gap.
layerForVoicing :: Layer -> PC.ProgressionContext -> (Bool, P.Progression)
layerForVoicing :: Layer -> ProgressionContext -> (Bool, Progression)
layerForVoicing Layer
lyr ProgressionContext
ctx =
  let chromaBar :: CadenceState -> Bool
chromaBar 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
5
      derived :: Bool
derived = ProgressionContext -> Family
PC.pcFamily ProgressionContext
ctx Family -> Family -> Bool
forall a. Eq a => a -> a -> Bool
/= Family
PC.FPoly
                Bool -> Bool -> Bool
&& ProgressionContext -> Progression
PC.modeLayer ProgressionContext
ctx Progression -> Progression -> Bool
forall a. Eq a => a -> a -> Bool
/= ProgressionContext -> Progression
PC.triadLayer ProgressionContext
ctx
                Bool -> Bool -> Bool
&& (CadenceState -> Bool) -> [CadenceState] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CadenceState -> Bool
chromaBar (Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
P.unProgression (ProgressionContext -> Progression
PC.modeLayer ProgressionContext
ctx)))
      chroma :: Bool
chroma  = Layer
lyr Layer -> Layer -> Bool
forall a. Eq a => a -> a -> Bool
/= Layer
T Bool -> Bool -> Bool
&& (Maybe (Seq (Tristrata, StrataLabel)) -> Bool
forall a. Maybe a -> Bool
isJust (ProgressionContext -> Maybe (Seq (Tristrata, StrataLabel))
PC.pcProvenance ProgressionContext
ctx) Bool -> Bool -> Bool
|| Bool
derived)
  in (Bool
chroma, Layer -> ProgressionContext -> Progression
PC.layer Layer
lyr ProgressionContext
ctx)

-- | Render scale-degree patterns into a playable 'ControlPattern', reading
-- pitches from the progression under the given voicing strategy.
--
-- The workhorse of the Tidal interface: every orchestral instrument in
-- "Harmonic.Interface.Tidal.Orchestra" is a thin wrapper around it.
--
-- @d1 $ arrange (0,1) k (-9,9) T flow id [\"0 1 2 3\"]@
arrange :: (Double, Double)                     -- ^ Kinetics gate: events pass only while 'kSignal' sits inside @(lo, hi)@ — the same predicate as 'Harmonic.Interface.Tidal.Form.ki', applied here so every instrument line carries its own activation band
        -> IK                                    -- ^ Performance context (kinetics + chord selection)
        -> (Int, Int)                            -- ^ Degree-index trim for the input patterns (scale degrees, not MIDI; instrument-range clipping happens later via clip)
        -> Layer                                 -- ^ Progression layer to voice — single (T | S | M) or synthesized combination (TS | TM | SM | TSM | PT)
        -> VoiceFunction                         -- ^ Voice function (flow, root, etc.)
        -> (P.Progression -> P.Progression)      -- ^ Progression modifier (overlapF 0, id, etc.)
        -> [Pattern Int]                         -- ^ Input patterns to harmonize
        -> Pattern ValueMap
arrange :: (Double, Double)
-> IK
-> (Int, Int)
-> Layer
-> VoiceFunction
-> (Progression -> Progression)
-> [Pattern Int]
-> Pattern ValueMap
arrange (Double
lo, Double
hi) (Kinetics
kin, Pattern Int
chordPat) (Int, Int)
register Layer
lyr VoiceFunction
voiceFunc Progression -> Progression
modifier [Pattern Int]
pats =
  let -- Pre-compute note range filter ONCE (shared across all innerJoin invocations)
      ranged :: Pattern Int
ranged = (Int -> Bool) -> Pattern Int -> Pattern Int
forall a. (a -> Bool) -> Pattern a -> Pattern a
filterValues (Kinetics -> Int -> Bool
kDegrees Kinetics
kin) ((Int, Int) -> Pattern Int -> Pattern Int
voiceRange (Int, Int)
register ([Pattern Int] -> Pattern Int
forall a. [Pattern a] -> Pattern a
stack [Pattern Int]
pats))  -- the line's range, then the launcher's ('isolate')
      -- The pattern carries the raw context; projection (layer synthesis
      -- for TS\/TM\/SM\/TSM\/PT), the modifier and the voicing all run at
      -- cache build. The audio thread only equality-matches the context —
      -- combination selectors never synthesize per query.
      progPat :: Pattern ProgressionContext
progPat = Kinetics -> Pattern ProgressionContext
kProg Kinetics
kin
      effectiveVF :: (Bool, Progression) -> [[Int]]
effectiveVF (Bool
chroma, Progression
p) =
        if Bool
chroma then VoiceFunction
A.strataModeFlow Progression
p else VoiceFunction
voiceFunc Progression
p
      voicingsOf :: ProgressionContext -> ([[Note]], Int)
voicingsOf ProgressionContext
ctx =
        let vs :: [[Int]]
vs = (Bool, Progression) -> [[Int]]
effectiveVF ((Progression -> Progression)
-> (Bool, Progression) -> (Bool, Progression)
forall a b. (a -> b) -> (Bool, a) -> (Bool, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Progression -> Progression
modifier (Layer -> ProgressionContext -> (Bool, Progression)
layerForVoicing Layer
lyr ProgressionContext
ctx))
            sc :: [[Note]]
sc = ([Int] -> [Note]) -> [[Int]] -> [[Note]]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Note) -> [Int] -> [Note]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Note
forall a b. (Integral a, Num b) => a -> b
fromIntegral) [[Int]]
vs :: [[Note]]
        in [[Note]] -> ()
forceAll [[Note]]
sc () -> ([[Note]], Int) -> ([[Note]], Int)
forall a b. a -> b -> b
`seq` ([[Note]]
sc, [[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
vs)
      -- Pre-compute voicings at construction time. The 'forceAll' walks
      -- every inner list spine, forcing the lazy voicing computation per
      -- bar — hoisting the work from the audio thread (where it would
      -- cause 'skip:' events on first query) to REPL evaluation time.
      -- Exact cache domain: the form's own distinct contexts (kProgs is
      -- already nub'd at form build). No time-window sampling (the old
      -- @queryArc … (Arc 0 1000)@ allocated 1000 events per instrument
      -- and silently missed progressions past the horizon, forcing a
      -- full voice-leading solve on the audio thread mid-set).
      cache :: [(ProgressionContext, ([[Note]], Int))]
cache = [ (ProgressionContext
ctx, ProgressionContext -> ([[Note]], Int)
voicingsOf ProgressionContext
ctx) | ProgressionContext
ctx <- Kinetics -> [ProgressionContext]
kProgs Kinetics
kin ]
      cacheForced :: ()
cacheForced = ((ProgressionContext, ([[Note]], Int)) -> () -> ())
-> () -> [(ProgressionContext, ([[Note]], Int))] -> ()
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(ProgressionContext
_, ([[Note]]
scs, Int
_)) ()
acc -> [[Note]] -> ()
forceAll [[Note]]
scs () -> () -> ()
forall a b. a -> b -> b
`seq` ()
acc) () [(ProgressionContext, ([[Note]], Int))]
cache
      lookupCache :: ProgressionContext -> ([[Note]], Int)
lookupCache ProgressionContext
ctx = case ProgressionContext
-> [(ProgressionContext, ([[Note]], Int))] -> Maybe ([[Note]], Int)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ProgressionContext
ctx [(ProgressionContext, ([[Note]], Int))]
cache of
        Just ([[Note]], Int)
hit -> ([[Note]], Int)
hit
        Maybe ([[Note]], Int)
Nothing  -> ProgressionContext -> ([[Note]], Int)
voicingsOf ProgressionContext
ctx
  in ()
cacheForced () -> Pattern ValueMap -> Pattern ValueMap
forall a b. a -> b -> b
`seq` (Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall a. Num a => Pattern a -> Pattern a -> Pattern a
|* [Char] -> Pattern Double -> Pattern ValueMap
pF [Char]
"amp" (Kinetics -> Pattern Double
kDynamic Kinetics
kin)) (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
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
x -> Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
lo Bool -> Bool -> Bool
&& Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
hi) (Kinetics -> Pattern Double
kSignal Kinetics
kin)) (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 (Pattern (Pattern ValueMap) -> Pattern ValueMap)
-> Pattern (Pattern ValueMap) -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ (ProgressionContext -> Pattern ValueMap)
-> Pattern ProgressionContext -> 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 (\ProgressionContext
ctx ->
         ([[Note]], Int) -> Pattern Int -> Pattern Int -> Pattern ValueMap
arrangeLookup (ProgressionContext -> ([[Note]], Int)
lookupCache ProgressionContext
ctx) Pattern Int
chordPat Pattern Int
ranged
       ) Pattern ProgressionContext
progPat

-- |Cached onset-join: takes pre-computed (scales, nChords) and pre-built ranged pattern.
arrangeLookup :: ([[Note]], Int)
              -> Pattern Int        -- ^ Chord selection pattern (1-indexed)
              -> Pattern Int        -- ^ Pre-computed range-filtered note pattern
              -> Pattern ValueMap
arrangeLookup :: ([[Note]], Int) -> Pattern Int -> Pattern Int -> Pattern ValueMap
arrangeLookup ([[Note]]
scales, Int
nChords) Pattern Int
chordPat Pattern Int
ranged
  | Int
nChords Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Pattern ValueMap
forall a. Pattern a
silence
  | Bool
otherwise =
      let 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

          mapped :: Pattern Note
mapped = (State -> [Event Note]) -> Maybe Time -> Maybe Note -> Pattern Note
forall a.
(State -> [Event a]) -> Maybe Time -> Maybe a -> Pattern a
Pattern (\State
st ->
            let noteEvs :: [Event Int]
noteEvs = Pattern Int -> State -> [Event Int]
forall a. Pattern a -> State -> [Event a]
query Pattern Int
ranged State
st
            in (Event Int -> [Event Note]) -> [Event Int] -> [Event Note]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Event Int
nEv -> case Event Int -> Maybe (ArcF Time)
forall a b. EventF a b -> Maybe a
whole Event Int
nEv of
              Maybe (ArcF Time)
Nothing -> []
              Just ArcF Time
wArc ->
                let onsetT :: Time
onsetT  = ArcF Time -> Time
forall a. ArcF a -> a
start ArcF Time
wArc
                    ci :: Int
ci      = Time -> Pattern Int -> Int
lookupChordAt Time
onsetT Pattern Int
chordIdx
                    sc :: [Note]
sc      = [[Note]]
scales [[Note]] -> Int -> [Note]
forall a. HasCallStack => [a] -> Int -> a
!! (Int
ci Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
nChords)
                    noteVal :: Int
noteVal = Event Int -> Int
forall a b. EventF a b -> b
value Event Int
nEv
                    scLen :: Int
scLen   = [Note] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Note]
sc
                    octv :: Int
octv    = Int
noteVal Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
scLen
                    idx :: Int
idx     = Int
noteVal Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
scLen
                -- A bar with no pitch content (e.g. a typo'd empty chord
                -- in a hand-written prog) emits nothing rather than
                -- indexing [] on the audio thread.
                in [ Event Int
nEv { value = (sc !! idx) + fromIntegral (octv * 12) }
                   | Int
scLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 ]
              ) [Event Int]
noteEvs
            ) Maybe Time
forall a. Maybe a
Nothing Maybe Note
forall a. Maybe a
Nothing

      in Pattern Note -> Pattern ValueMap
note Pattern Note
mapped

-------------------------------------------------------------------------------
-- Natural harmonics: harmonics (one string)
-------------------------------------------------------------------------------

-- | Open strings of an overtone instrument as (name, scientific octave):
-- @(A,1)@ is A1 = MIDI 33.
type Tuning = [(Pitch.NoteName, Int)]

-- | The instrument behind @hmnx@: the Electric Contrabass Cittern as the MPC
-- harmonics keymap holds it — open strings A2 E3 G3 (thesis §2.1: EAeGB is
-- E2 A2 E3 G3 B3) and the top string in both Hipshot lever positions, B3 and
-- C4. B and C are one physical string,
-- but the keygroup carries both sets of samples, so both are always available
-- to a pattern; the harmonic context is what limits the space. Fixed on
-- purpose: the keymap never changes, so no launcher states a tuning.
ecbc :: Tuning
ecbc :: Tuning
ecbc = [(NoteName
Pitch.A, Int
2), (NoteName
Pitch.E, Int
3), (NoteName
Pitch.G, Int
3), (NoteName
Pitch.B, Int
3), (NoteName
Pitch.C, Int
4)]

-- | Semitones from a string's fundamental to its @n@-th partial:
-- @round (12 * logBase 2 n)@, so partials 2..5 sit at +12 +19 +24 +28.
partialOffset :: Int -> Int
partialOffset :: Int -> Int
partialOffset Int
partial = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
12 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase Double
2 (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
partial :: Double))

-- | The four playable partials of the 2016 thesis — octave, fifth, double
-- octave, third (partials 2 3 4 5) — of one open string, as MIDI pitches.
stringPitches :: (Pitch.NoteName, Int) -> [Int]
stringPitches :: (NoteName, Int) -> [Int]
stringPitches (NoteName
nm, Int
octv) =
  let fund :: Int
fund = Int
12 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
octv Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ PitchClass -> Int
Pitch.unPitchClass (NoteName -> PitchClass
Pitch.pitchClass NoteName
nm)
  in [ Int
fund Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int
partialOffset Int
partial | Int
partial <- [Int
2, Int
3, Int
4, Int
5] ]

-- | The composite overtone series (thesis §2.2): every pitch any string of a
-- tuning can sound as a natural harmonic, ascending, once each.
-- @compositeSeries ecbc@ is the keymap:
-- @57 64 67 69 71 72 73 74 76 78 79 80 83 84 87 88@.
compositeSeries :: Tuning -> [Int]
compositeSeries :: Tuning -> [Int]
compositeSeries = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]) -> (Tuning -> [Int]) -> Tuning -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ([Int] -> [Int]) -> (Tuning -> [Int]) -> Tuning -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((NoteName, Int) -> [Int]) -> Tuning -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (NoteName, Int) -> [Int]
stringPitches

-- The instrument's series filtered to the harmony: per bar, the pitches whose
-- class the layer voices. The pitch classes are read through the same route
-- 'arrange' uses to see a bar's tones; no voice function is exposed because
-- flow and grid voice the same classes.
viableSeries :: Layer -> PC.ProgressionContext -> ([[Int]], Int)
viableSeries :: Layer -> ProgressionContext -> ([[Int]], Int)
viableSeries Layer
lyr ProgressionContext
ctx =
  let (Bool
chroma, Progression
p) = Layer -> ProgressionContext -> (Bool, Progression)
layerForVoicing Layer
lyr ProgressionContext
ctx
      vs :: [[Int]]
vs  = if Bool
chroma then VoiceFunction
A.strataModeFlow Progression
p else VoiceFunction
A.flow Progression
p
      ser :: [Int]
ser = Tuning -> [Int]
compositeSeries Tuning
ecbc
      per :: [[Int]]
per = [ [ Int
m | Int
m <- [Int]
ser, (Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) [Int]
bar ] | [Int]
bar <- [[Int]]
vs ]
  in ([[Int]]
per, [[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
vs)

-- | The whole overtone instrument. Pattern ints index the bar's viable
-- composite series — the harmonics of 'ecbc' whose pitch class the layer
-- voices — compressed to @0, 1, 2 …@ ascending and looped by floor-mod, so
-- @"[0,1,2]"@ is the lowest three available tones from the bottom up and
-- @"[-1,-2,-3]"@ the highest three from the top down, whatever the size of the
-- structure in play. A pitch class present in two octaves is two ints. Never an
-- octave wrap: these are fixed sample pitches. A bar whose voicing has no
-- instrument tone rests. Polyphonic; 'harmonics' is the per-string filter over
-- the same mapping. The harmonic context is the only limit on the space:
-- generating inside the instrument's palette (@hcOvertones@) keeps every tone
-- reachable, and 'overtoneMap' shows what each int hits.
--
-- @, composite (0,1) k T ["~", "[0,1,2]/4"] # ch 11@
composite :: (Double, Double)                     -- ^ Kinetics gate, as 'arrange'
          -> IK                                   -- ^ Performance context
          -> Layer                                -- ^ Harmonic state: T (chord tones) or S (pentatonic)
          -> [Pattern Int]                        -- ^ Contours: ints into the bar's viable series
          -> Pattern ValueMap
composite :: (Double, Double)
-> IK -> Layer -> [Pattern Int] -> Pattern ValueMap
composite = (Int -> Bool)
-> Bool
-> (Double, Double)
-> IK
-> Layer
-> [Pattern Int]
-> Pattern ValueMap
seriesPlay (Bool -> Int -> Bool
forall a b. a -> b -> a
const Bool
True) Bool
False

-- | One string of 'ecbc', named by its open note (A E G B C; enharmonics
-- collapse): the SAME int → pitch mapping as 'composite', but only the pitches
-- that string can sound pass — the rest are silent, not remapped — so a string
-- block isolates or mutes a string and owns its sustain. Within the string the
-- result is 'mono'' (latest-note priority: a new harmonic damps the previous,
-- as on the instrument).
--
-- @, harmonics A (0,1) k T ["~", pat] # ch 11@
harmonics :: Pitch.NoteName -> (Double, Double) -> IK -> Layer -> [Pattern Int] -> Pattern ValueMap
harmonics :: NoteName
-> (Double, Double)
-> IK
-> Layer
-> [Pattern Int]
-> Pattern ValueMap
harmonics NoteName
str = (Int -> Bool)
-> Bool
-> (Double, Double)
-> IK
-> Layer
-> [Pattern Int]
-> Pattern ValueMap
seriesPlay (Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
owned) Bool
True
  where
    owned :: [Int]
owned = [[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ (NoteName, Int) -> [Int]
stringPitches (NoteName, Int)
st | st :: (NoteName, Int)
st@(NoteName
nm, Int
_) <- Tuning
ecbc
                   , NoteName -> PitchClass
Pitch.pitchClass NoteName
nm PitchClass -> PitchClass -> Bool
forall a. Eq a => a -> a -> Bool
== NoteName -> PitchClass
Pitch.pitchClass NoteName
str ]

-- Shared engine of 'composite' and 'harmonics': the 'arrange' cache shape over
-- 'kProgs', an onset-join of the contour against the bar's viable series, a
-- keep-predicate on the resulting pitch, and optional monophony after it.
seriesPlay :: (Int -> Bool) -> Bool -> (Double, Double) -> IK -> Layer -> [Pattern Int] -> Pattern ValueMap
seriesPlay :: (Int -> Bool)
-> Bool
-> (Double, Double)
-> IK
-> Layer
-> [Pattern Int]
-> Pattern ValueMap
seriesPlay Int -> Bool
keep Bool
monoString (Double
lo, Double
hi) (Kinetics
kin, Pattern Int
chordPat) Layer
lyr [Pattern Int]
pats =
  let contour :: Pattern Int
contour = [Pattern Int] -> Pattern Int
forall a. [Pattern a] -> Pattern a
stack [Pattern Int]
pats
      progPat :: Pattern ProgressionContext
progPat = Kinetics -> Pattern ProgressionContext
kProg Kinetics
kin
      cache :: [(ProgressionContext, ([[Int]], Int))]
cache = [ (ProgressionContext
ctx, Layer -> ProgressionContext -> ([[Int]], Int)
viableSeries Layer
lyr ProgressionContext
ctx) | ProgressionContext
ctx <- Kinetics -> [ProgressionContext]
kProgs Kinetics
kin ]
      cacheForced :: ()
cacheForced = ((ProgressionContext, ([[Int]], Int)) -> () -> ())
-> () -> [(ProgressionContext, ([[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 (\(ProgressionContext
_, ([[Int]]
vs, Int
cnt)) ()
acc -> [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Int]]
vs) Int -> () -> ()
forall a b. a -> b -> b
`seq` Int
cnt Int -> () -> ()
forall a b. a -> b -> b
`seq` ()
acc) () [(ProgressionContext, ([[Int]], Int))]
cache
      lookupCache :: ProgressionContext -> ([[Int]], Int)
lookupCache ProgressionContext
ctx = case ProgressionContext
-> [(ProgressionContext, ([[Int]], Int))] -> Maybe ([[Int]], Int)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ProgressionContext
ctx [(ProgressionContext, ([[Int]], Int))]
cache of
        Just ([[Int]], Int)
hit -> ([[Int]], Int)
hit
        Maybe ([[Int]], Int)
Nothing  -> Layer -> ProgressionContext -> ([[Int]], Int)
viableSeries Layer
lyr ProgressionContext
ctx
      voicing :: Pattern a -> Pattern a
voicing = if Bool
monoString then Pattern a -> Pattern a
forall a. Pattern a -> Pattern a
mono' else Pattern a -> Pattern a
forall a. a -> a
id
  in ()
cacheForced () -> Pattern ValueMap -> Pattern ValueMap
forall a b. a -> b -> b
`seq` (Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall a. Num a => Pattern a -> Pattern a -> Pattern a
|* [Char] -> Pattern Double -> Pattern ValueMap
pF [Char]
"amp" (Kinetics -> Pattern Double
kDynamic Kinetics
kin)) (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
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
x -> Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
lo Bool -> Bool -> Bool
&& Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
hi) (Kinetics -> Pattern Double
kSignal Kinetics
kin)) (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 (Pattern (Pattern ValueMap) -> Pattern ValueMap)
-> Pattern (Pattern ValueMap) -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ (ProgressionContext -> Pattern ValueMap)
-> Pattern ProgressionContext -> 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 (\ProgressionContext
ctx ->
         Pattern Note -> Pattern ValueMap
midinote ((Int -> Note) -> Pattern Int -> Pattern Note
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Note
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pattern Int -> Pattern Int
forall a. Pattern a -> Pattern a
voicing (([[Int]], Int)
-> (Int -> Bool) -> Pattern Int -> Pattern Int -> Pattern Int
seriesLookup (ProgressionContext -> ([[Int]], Int)
lookupCache ProgressionContext
ctx) Int -> Bool
keep Pattern Int
chordPat Pattern Int
contour)))
       ) Pattern ProgressionContext
progPat

-- | Onset-join of a contour against per-bar viable series: floor-mod index
-- (negative = from the top), pitch sampled once at the onset, kept only if
-- the predicate admits it.
seriesLookup :: ([[Int]], Int) -> (Int -> Bool) -> Pattern Int -> Pattern Int -> Pattern Int
seriesLookup :: ([[Int]], Int)
-> (Int -> Bool) -> Pattern Int -> Pattern Int -> Pattern Int
seriesLookup ([[Int]]
viable, Int
nChords) Int -> Bool
keep Pattern Int
chordPat Pattern Int
contour
  | Int
nChords Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Pattern Int
forall a. Pattern a
silence
  | Bool
otherwise =
      let 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
      in (State -> [Event Int]) -> Maybe Time -> Maybe Int -> Pattern Int
forall a.
(State -> [Event a]) -> Maybe Time -> Maybe a -> Pattern a
Pattern (\State
st ->
           (Event Int -> [Event Int]) -> [Event Int] -> [Event Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Event Int
ev -> case Event Int -> Maybe (ArcF Time)
forall a b. EventF a b -> Maybe a
whole Event Int
ev of
             Maybe (ArcF Time)
Nothing -> []
             Just ArcF Time
w  ->
               let ci :: Int
ci = Time -> Pattern Int -> Int
lookupChordAt (ArcF Time -> Time
forall a. ArcF a -> a
start ArcF Time
w) Pattern Int
chordIdx
                   vs :: [Int]
vs = [[Int]]
viable [[Int]] -> Int -> [Int]
forall a. HasCallStack => [a] -> Int -> a
!! (Int
ci Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
nChords)
               in [ Event Int
ev { value = m } | Bool -> Bool
not ([Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
vs)
                                     , let m :: Int
m = [Int]
vs [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! (Event Int -> Int
forall a b. EventF a b -> b
value Event Int
ev Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
vs)
                                     , Int -> Bool
keep Int
m ]
             ) (Pattern Int -> State -> [Event Int]
forall a. Pattern a -> State -> [Event a]
query Pattern Int
contour State
st)
           ) Maybe Time
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing

-- | The basic series over a set of voiced pitch classes, on 'ecbc': @(int,
-- MIDI pitch, sources)@, a source being @(string, overtone number)@ in the
-- thesis's numbering — OT1 the fundamental's class (partials 2 and 4), OT2 the
-- fifth, OT3 the third. Pure core of 'overtoneMap'.
overtoneTable :: [Int] -> [(Int, Int, [(Pitch.NoteName, Int)])]
overtoneTable :: [Int] -> [(Int, Int, Tuning)]
overtoneTable [Int]
pcs =
  let viable :: [Int]
viable = [ Int
m | Int
m <- Tuning -> [Int]
compositeSeries Tuning
ecbc, (Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) [Int]
pcs ]
  in [ (Int
i, Int
m, Int -> Tuning
sourcesOf Int
m) | (Int
i, Int
m) <- [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [Int]
viable ]
  where
    sourcesOf :: Int -> Tuning
sourcesOf Int
m = [ (NoteName
nm, Int -> Int
forall {a}. (Eq a, Num a) => a -> a
otNumber Int
partial)
                  | st :: (NoteName, Int)
st@(NoteName
nm, Int
_) <- Tuning
ecbc
                  , (Int
partial, Int
pitch) <- [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
2, Int
3, Int
4, Int
5 :: Int] ((NoteName, Int) -> [Int]
stringPitches (NoteName, Int)
st)
                  , Int
pitch Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
m ]
    otNumber :: a -> a
otNumber a
partial = case a
partial of { a
2 -> a
1; a
3 -> a
2; a
4 -> a
1; a
5 -> a
3; a
other -> a
other }

-- | Print, per chord of a progression, what the ints of the basic series map
-- to on the instrument — pitch, MIDI number and sources in thesis notation
-- (@E2@ = string E, overtone 2; @\/@ = alternative sources) — with the
-- top-down alias beside each int; then the distinct ints of the contour over
-- its first bar, resolved per chord. Takes the progression context and the
-- layer the block plays, so what it prints is what 'composite' sounds.
--
-- @overtoneMap s T ["[0,1,2]/4"]@
overtoneMap :: PC.ProgressionContext -> Layer -> [Pattern Int] -> IO ()
overtoneMap :: ProgressionContext -> Layer -> [Pattern Int] -> IO ()
overtoneMap ProgressionContext
ctx Layer
lyr [Pattern Int]
pats = do
  [Char] -> IO ()
putStrLn [Char]
"pitch names are scientific (60 = C4); the MPC and MIDI Monitor show one octave lower — compare by number"
  let ints :: [Int]
ints = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub [ Event Int -> Int
forall a b. EventF a b -> b
value Event Int
e | Event Int
e <- Pattern Int -> ArcF Time -> [Event Int]
forall a. Pattern a -> ArcF Time -> [Event a]
queryArc ([Pattern Int] -> Pattern Int
forall a. [Pattern a] -> Pattern a
stack [Pattern Int]
pats) (Time -> Time -> ArcF Time
forall a. a -> a -> ArcF a
Arc Time
0 Time
4), Event Int -> Bool
forall a. Event a -> Bool
eventHasOnset Event Int
e ]
      pcName :: Int -> a
pcName Int
pc = [a
"C",a
"C#",a
"D",a
"D#",a
"E",a
"F",a
"F#",a
"G",a
"G#",a
"A",a
"A#",a
"B"] [a] -> Int -> a
forall a. HasCallStack => [a] -> Int -> a
!! (Int
pc Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12)
      pitchName :: Int -> [Char]
pitchName Int
m = Int -> [Char]
forall {a}. IsString a => Int -> a
pcName Int
m [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
12 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      srcText :: [(a, a)] -> [Char]
srcText [(a, a)]
srcs = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
" / " [ a -> [Char]
forall a. Show a => a -> [Char]
show a
nm [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
ot | (a
nm, a
ot) <- [(a, a)]
srcs ]
      (Bool
chroma, Progression
p) = Layer -> ProgressionContext -> (Bool, Progression)
layerForVoicing Layer
lyr ProgressionContext
ctx
      bars :: [[Int]]
bars = if Bool
chroma then VoiceFunction
A.strataModeFlow Progression
p else VoiceFunction
A.flow Progression
p
  ((Int, [Int]) -> IO ()) -> [(Int, [Int])] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Int
bi, [Int]
bar) -> do
      let pcs :: [Int]
pcs  = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ((Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) [Int]
bar)
          rows :: [(Int, Int, Tuning)]
rows = [Int] -> [(Int, Int, Tuning)]
overtoneTable [Int]
pcs
          cnt :: Int
cnt  = [(Int, Int, Tuning)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, Int, Tuning)]
rows
      [Char] -> IO ()
putStrLn ([Char]
"chord " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Int
bi :: Int) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  [" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords ((Int -> [Char]) -> [Int] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Int -> [Char]
forall {a}. IsString a => Int -> a
pcName [Int]
pcs) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"]"
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (if Int
cnt Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then [Char]
"  — no instrument tone" else [Char]
""))
      ((Int, Int, Tuning) -> IO ()) -> [(Int, Int, Tuning)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Int
i, Int
m, Tuning
srcs) ->
          [Char] -> IO ()
putStrLn ([Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" / " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
cnt) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\t" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
pitchName Int
m
                    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\t" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
m [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\t" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Tuning -> [Char]
forall {a} {a}. (Show a, Show a) => [(a, a)] -> [Char]
srcText Tuning
srcs)) [(Int, Int, Tuning)]
rows
      if [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
ints Bool -> Bool -> Bool
|| Int
cnt Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () else
        [Char] -> IO ()
putStrLn ([Char]
"  contour " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords ((Int -> [Char]) -> [Int] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Int -> [Char]
forall a. Show a => a -> [Char]
show [Int]
ints) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  ->  "
                  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords [ Int -> [Char]
pitchName ([Int]
vs [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
cnt)) | let vs :: [Int]
vs = [ Int
m | (Int
_, Int
m, Tuning
_) <- [(Int, Int, Tuning)]
rows ], Int
i <- [Int]
ints ])
    ) ([Int] -> [[Int]] -> [(Int, [Int])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] [[Int]]
bars)

-------------------------------------------------------------------------------
-- Arrangement: arrange' (squeeze)
-------------------------------------------------------------------------------

-- |Map notes through chords using squeeze, with kinetics range gating.
--
-- Same kinetics\/modifier pattern as 'arrange', but uses squeeze strategy:
-- each chord slot gets the full input pattern compressed to fit.
arrange' :: (Double, Double)                     -- ^ Kinetics range
         -> IK                                    -- ^ Performance context
         -> (Int, Int)                            -- ^ Degree-index trim for the input patterns (scale degrees, not MIDI; instrument-range clipping happens later via clip)
         -> Layer                                 -- ^ Progression layer (T | S | M)
         -> VoiceFunction                         -- ^ Voice function
         -> (P.Progression -> P.Progression)      -- ^ Progression modifier
         -> [Pattern Int]                         -- ^ Input patterns to harmonize
         -> Pattern ValueMap
arrange' :: (Double, Double)
-> IK
-> (Int, Int)
-> Layer
-> VoiceFunction
-> (Progression -> Progression)
-> [Pattern Int]
-> Pattern ValueMap
arrange' (Double
lo, Double
hi) (Kinetics
kin, Pattern Int
chordPat) (Int, Int)
register Layer
lyr VoiceFunction
voiceFunc Progression -> Progression
modifier [Pattern Int]
pats =
  let -- Pre-compute note range filter ONCE (shared across all innerJoin invocations)
      ranged :: Pattern Int
ranged = (Int -> Bool) -> Pattern Int -> Pattern Int
forall a. (a -> Bool) -> Pattern a -> Pattern a
filterValues (Kinetics -> Int -> Bool
kDegrees Kinetics
kin) ((Int, Int) -> Pattern Int -> Pattern Int
voiceRange (Int, Int)
register ([Pattern Int] -> Pattern Int
forall a. [Pattern a] -> Pattern a
stack [Pattern Int]
pats))  -- the line's range, then the launcher's ('isolate')
      -- Context-keyed cache; see 'arrange' — projection, modifier and
      -- voicing all run at build, never per query.
      progPat :: Pattern ProgressionContext
progPat = Kinetics -> Pattern ProgressionContext
kProg Kinetics
kin
      effectiveVF :: (Bool, Progression) -> [[Int]]
effectiveVF (Bool
chroma, Progression
p) =
        if Bool
chroma then VoiceFunction
A.strataModeFlow Progression
p else VoiceFunction
voiceFunc Progression
p
      voicingsOf :: ProgressionContext -> ([[Note]], Int)
voicingsOf ProgressionContext
ctx =
        let vs :: [[Int]]
vs = (Bool, Progression) -> [[Int]]
effectiveVF ((Progression -> Progression)
-> (Bool, Progression) -> (Bool, Progression)
forall a b. (a -> b) -> (Bool, a) -> (Bool, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Progression -> Progression
modifier (Layer -> ProgressionContext -> (Bool, Progression)
layerForVoicing Layer
lyr ProgressionContext
ctx))
            sc :: [[Note]]
sc = ([Int] -> [Note]) -> [[Int]] -> [[Note]]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Note) -> [Int] -> [Note]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Note
forall a b. (Integral a, Num b) => a -> b
fromIntegral) [[Int]]
vs :: [[Note]]
        in [[Note]] -> ()
forceAll [[Note]]
sc () -> ([[Note]], Int) -> ([[Note]], Int)
forall a b. a -> b -> b
`seq` ([[Note]]
sc, [[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
vs)
      cache :: [(ProgressionContext, ([[Note]], Int))]
cache = [ (ProgressionContext
ctx, ProgressionContext -> ([[Note]], Int)
voicingsOf ProgressionContext
ctx) | ProgressionContext
ctx <- Kinetics -> [ProgressionContext]
kProgs Kinetics
kin ]
      cacheForced :: ()
cacheForced = ((ProgressionContext, ([[Note]], Int)) -> () -> ())
-> () -> [(ProgressionContext, ([[Note]], Int))] -> ()
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(ProgressionContext
_, ([[Note]]
scs, Int
_)) ()
acc -> [[Note]] -> ()
forceAll [[Note]]
scs () -> () -> ()
forall a b. a -> b -> b
`seq` ()
acc) () [(ProgressionContext, ([[Note]], Int))]
cache
      lookupCache :: ProgressionContext -> ([[Note]], Int)
lookupCache ProgressionContext
ctx = case ProgressionContext
-> [(ProgressionContext, ([[Note]], Int))] -> Maybe ([[Note]], Int)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ProgressionContext
ctx [(ProgressionContext, ([[Note]], Int))]
cache of
        Just ([[Note]], Int)
hit -> ([[Note]], Int)
hit
        Maybe ([[Note]], Int)
Nothing  -> ProgressionContext -> ([[Note]], Int)
voicingsOf ProgressionContext
ctx
  in ()
cacheForced () -> Pattern ValueMap -> Pattern ValueMap
forall a b. a -> b -> b
`seq` (Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall a. Num a => Pattern a -> Pattern a -> Pattern a
|* [Char] -> Pattern Double -> Pattern ValueMap
pF [Char]
"amp" (Kinetics -> Pattern Double
kDynamic Kinetics
kin)) (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
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
x -> Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
lo Bool -> Bool -> Bool
&& Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
hi) (Kinetics -> Pattern Double
kSignal Kinetics
kin)) (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 (Pattern (Pattern ValueMap) -> Pattern ValueMap)
-> Pattern (Pattern ValueMap) -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ (ProgressionContext -> Pattern ValueMap)
-> Pattern ProgressionContext -> 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 (\ProgressionContext
ctx ->
         ([[Note]], Int) -> Pattern Int -> Pattern Int -> Pattern ValueMap
arrangeLookup' (ProgressionContext -> ([[Note]], Int)
lookupCache ProgressionContext
ctx) Pattern Int
chordPat Pattern Int
ranged
       ) Pattern ProgressionContext
progPat

-- |Cached squeeze: takes pre-computed (scales, nChords) and pre-built ranged pattern.
arrangeLookup' :: ([[Note]], Int)
               -> Pattern Int        -- ^ Chord selection pattern (1-indexed)
               -> Pattern Int        -- ^ Pre-computed range-filtered note pattern
               -> Pattern ValueMap
arrangeLookup' :: ([[Note]], Int) -> Pattern Int -> Pattern Int -> Pattern ValueMap
arrangeLookup' ([[Note]]
scales, Int
nChords) Pattern Int
chordPat Pattern Int
ranged
  | Int
nChords Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Pattern ValueMap
forall a. Pattern a
silence
  | Bool
otherwise =
      let 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
          chordPats :: [Pattern ValueMap]
chordPats = ([Note] -> Pattern ValueMap) -> [[Note]] -> [Pattern ValueMap]
forall a b. (a -> b) -> [a] -> [b]
map (\[Note]
sc -> Pattern Note -> Pattern ValueMap
note ([Note] -> Pattern Int -> Pattern Note
forall a. Num a => [a] -> Pattern Int -> Pattern a
toScale [Note]
sc Pattern Int
ranged)) [[Note]]
scales
      in Pattern Int -> [Pattern ValueMap] -> Pattern ValueMap
forall a. Pattern Int -> [Pattern a] -> Pattern a
squeeze Pattern Int
chordIdx [Pattern ValueMap]
chordPats

-------------------------------------------------------------------------------
-- Parallelism Harmoniser
-------------------------------------------------------------------------------

-- |Stack fixed-interval parallel voices over an arranged ControlPattern.
-- The offset pattern is the FULL voice spec in absolute semitones: each note
-- of @pat@ is replaced by one copy per simultaneous offset, shifted by that
-- offset. Include @0@ to retain the original note; omit it to drop the root.
--
-- Comma = simultaneous voices, space = time-sequenced offsets (standard
-- mininotation, natively evaluated). Applied post-voicing\/post-range-filter,
-- so offsets are not gated by the @arrange@ MIDI range.
--
-- @
-- parallel "0 7"      $ arrange ... -- root + perfect fifth above
-- parallel "7"        $ arrange ... -- fifth only (root dropped)
-- parallel "[0,-5,4]" $ arrange ... -- root, fourth below, major third above
-- @
parallel :: Pattern Note -> ControlPattern -> ControlPattern
parallel :: Pattern Note -> Pattern ValueMap -> Pattern ValueMap
parallel Pattern Note
offs Pattern ValueMap
pat = Pattern ValueMap
pat Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall a. Num a => Pattern a -> Pattern a -> Pattern a
|+ Pattern Note -> Pattern ValueMap
note Pattern Note
offs

-------------------------------------------------------------------------------
-- Harmonic state for an external note-mapper
-------------------------------------------------------------------------------

-- | The chosen layer's pitch classes as held MIDI notes, for a device that locks
-- a played keyboard to the harmony (the rig's MiDiNiNjA X3).
--
-- One note per distinct pitch class, MIDI 108-119 (pitch class = note mod 12),
-- on MIDI channel 10, each held for the length of its chord: the structure
-- follows the chord grid (@snd k@), so two chords in a bar give two held sets.
-- Any layer or combination ('T', 'S', 'M', 'TS', ...) and any set size. Degree
-- indices 0-11 cover the largest set; the indices past a chord's size fold back
-- onto pitch classes already sent and are dropped, so each chord change costs
-- one message per pitch class on a DIN line shared with the music.
--
-- Each set goes out 'stateLead' ahead of its chord: on the wire before the
-- chord's own notes, and in place for keys played just before the downbeat.
--
-- Channel 10, notes 108-119 sits above everything else on that channel in both
-- rigs: the JV-map kit (0-9, 60-80), metronome and count, the MPC sub (35-48).
-- The X3 consumes these notes before they reach the MPC.
--
-- @kmap f k lyr = p \"kmap\" $ f $ harmonicState lyr k@   (BootTidal)
harmonicState :: Layer -> IK -> ControlPattern
harmonicState :: Layer -> IK -> Pattern ValueMap
harmonicState Layer
lyr IK
k =
  Time -> Pattern Time
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Time
stateLead Pattern Time -> Pattern ValueMap -> Pattern ValueMap
forall a. Pattern Time -> Pattern a -> Pattern a
<~ ([Event ValueMap] -> [Event ValueMap])
-> Pattern ValueMap -> Pattern ValueMap
forall a b. ([Event a] -> [Event b]) -> Pattern a -> Pattern b
withEvents ((Event ValueMap -> Event ValueMap -> Bool)
-> [Event ValueMap] -> [Event ValueMap]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy Event ValueMap -> Event ValueMap -> Bool
forall {a} {a}. (Eq a, Eq a) => EventF a a -> EventF a a -> Bool
sameNote)
    ((Double, Double)
-> IK
-> (Int, Int)
-> Layer
-> VoiceFunction
-> (Progression -> Progression)
-> [Pattern Int]
-> Pattern ValueMap
arrange (Double
0, Double
1) (IK -> IK
forall {b}. (Kinetics, b) -> (Kinetics, b)
allDegrees IK
k) (Int
0, Int
11) Layer
lyr VoiceFunction
A.lite Progression -> Progression
forall a. a -> a
id
      [Pattern Bool -> Pattern Int -> Pattern Int
forall a. Pattern Bool -> Pattern a -> Pattern a
struct ((Int -> Bool) -> Pattern Int -> Pattern Bool
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Int -> Bool
forall a b. a -> b -> a
const Bool
True) (IK -> Pattern Int
forall a b. (a, b) -> b
snd IK
k)) Pattern Int
"[0,1,2,3,4,5,6,7,8,9,10,11]"]
      Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall a. Moddable a => Pattern a -> Pattern a -> Pattern a
|% Pattern Note -> Pattern ValueMap
note Pattern Note
12 Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall a. Num a => Pattern a -> Pattern a -> Pattern a
|+ Pattern Note -> Pattern ValueMap
note Pattern Note
48
      # s "thru" # midichan 9 # legato 1 # pF "amp" 1)
  where
    sameNote :: EventF a a -> EventF a a -> Bool
sameNote EventF a a
x EventF a a
y = EventF a a -> Maybe a
forall a b. EventF a b -> Maybe a
whole EventF a a
x Maybe a -> Maybe a -> Bool
forall a. Eq a => a -> a -> Bool
== EventF a a -> Maybe a
forall a b. EventF a b -> Maybe a
whole EventF a a
y Bool -> Bool -> Bool
&& EventF a a -> a
forall a b. EventF a b -> a
part EventF a a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== EventF a a -> a
forall a b. EventF a b -> a
part EventF a a
y Bool -> Bool -> Bool
&& EventF a a -> a
forall a b. EventF a b -> b
value EventF a a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== EventF a a -> a
forall a b. EventF a b -> b
value EventF a a
y
    -- The mapper always gets the whole set, whatever the launcher isolates.
    allDegrees :: (Kinetics, b) -> (Kinetics, b)
allDegrees (Kinetics
kin, b
chordPat) = (Kinetics
kin { kDegrees = const True }, b
chordPat)

-- | How far ahead of its chord 'harmonicState' sends a set, in cycles (beats):
-- 7/64, just under a 32nd note. A key played a 64th before the downbeat
-- already maps to the new chord; one played a 32nd before still maps to the
-- old one.
stateLead :: Time
stateLead :: Time
stateLead = Time
7Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/Time
64

-------------------------------------------------------------------------------
-- Chord Lookup
-------------------------------------------------------------------------------

-- |Point-query a chord selection pattern at a specific time.
-- Returns the chord index (0-indexed) active at time @t@.
-- Falls back to chord 0 if no events found.
lookupChordAt :: Time -> Pattern Int -> Int
lookupChordAt :: Time -> Pattern Int -> Int
lookupChordAt Time
t Pattern Int
cpat =
  case Pattern Int -> ArcF Time -> [Event Int]
forall a. Pattern a -> ArcF Time -> [Event a]
queryArc Pattern Int
cpat (Time -> Time -> ArcF Time
forall a. a -> a -> ArcF a
Arc Time
t (Time
t Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
1Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/Time
10000000)) of
    []    -> Int
0
    (Event Int
e:[Event Int]
_) -> Event Int -> Int
forall a b. EventF a b -> b
value Event Int
e

-- |Lookup a chord from a progression context by index with modulo wrap.
-- Operates on the triad layer (the harmonic content).
lookupChord :: PC.ProgressionContext -> Int -> H.Chord
lookupChord :: ProgressionContext -> Int -> Chord
lookupChord ProgressionContext
pc Int
idx =
  let prog :: Progression
prog = ProgressionContext -> Progression
PC.triadLayer ProgressionContext
pc
      len :: Int
len = Progression -> Int
P.progLength Progression
prog
      chords :: [Chord]
chords = Progression -> [Chord]
P.progChords Progression
prog
      wrappedIdx :: Int
wrappedIdx = Int
idx Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
len
  in if Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
       then [Char] -> Chord
forall a. HasCallStack => [Char] -> a
error [Char]
"lookupChord: empty progression"
       else [Chord]
chords [Chord] -> Int -> Chord
forall a. HasCallStack => [a] -> Int -> a
!! Int
wrappedIdx

-- |Lookup progression (triad layer) as a pattern of voicings via 'A.flow'.
lookupProgression :: PC.ProgressionContext -> Pattern Int -> Pattern [Int]
lookupProgression :: ProgressionContext -> Pattern Int -> Pattern [Int]
lookupProgression ProgressionContext
pc Pattern Int
idxPat =
  let prog :: Progression
prog = ProgressionContext -> Progression
PC.triadLayer ProgressionContext
pc
      len :: Int
len = Progression -> Int
P.progLength Progression
prog
      voicings :: [[Int]]
voicings = VoiceFunction
A.flow Progression
prog
  in if Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
       then Pattern [Int]
forall a. Pattern a
silence
       else (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
idx -> [[Int]]
voicings [[Int]] -> Int -> [Int]
forall a. HasCallStack => [a] -> Int -> a
!! (Int
idx Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
len)) Pattern Int
idxPat

-------------------------------------------------------------------------------
-- Progression Overlap (Re-exports from Arranger)
-------------------------------------------------------------------------------

-- |Forward overlap: merge pitches from n bars ahead
overlapF :: Int -> P.Progression -> P.Progression
overlapF :: Int -> Progression -> Progression
overlapF = Int -> Progression -> Progression
A.progOverlapF

-- |Backward overlap: merge pitches from n bars behind
overlapB :: Int -> P.Progression -> P.Progression
overlapB :: Int -> Progression -> Progression
overlapB = Int -> Progression -> Progression
A.progOverlapB

-- |Bidirectional overlap: merge pitches from n bars in both directions
overlap :: Int -> P.Progression -> P.Progression
overlap :: Int -> Progression -> Progression
overlap = Int -> Progression -> Progression
A.progOverlap