{-# LANGUAGE FlexibleContexts #-}

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

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

    -- * 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.Interface.Tidal.Arranger as A
import Harmonic.Interface.Tidal.Form (Kinetics(..), IK)

import Data.List (nub)
import Data.Maybe (isJust)
import Data.Foldable (toList)
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 MIDI note range
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 :: String -> Pattern Int
warp String
s = 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
$ String -> Pattern Int
forall a. (Enumerable a, Parseable a) => String -> Pattern a
parseBP_E String
s

-- |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 n :: Int
n = 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
n 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
n]

-------------------------------------------------------------------------------
-- 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. Strict-context routing: the S\/M layers of a genP-provenance
-- context are THE curated 5\/7-PC chroma (uniform per layer) and are
-- always voiced by 'A.strataModeFlow' — degree\/"key-signature" semantics:
-- pattern index @i@ plays the i-th scale degree of that bar's set. The T
-- layer always honours the user's 'VoiceFunction', as do S\/M layers of
-- gen\/gen4 contexts (ordinary-harmony duplicates of the triad layer).
--
-- Routing by provenance + layer 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).
layerForVoicing :: Layer -> PC.ProgressionContext -> (Bool, P.Progression)
layerForVoicing :: Layer -> ProgressionContext -> (Bool, Progression)
layerForVoicing Layer
lyr ProgressionContext
ctx =
  let 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)
  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 range
        -> 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 (T | S | M)
        -> 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, Int) -> Pattern Int -> Pattern Int
voiceRange (Int, Int)
register ([Pattern Int] -> Pattern Int
forall a. [Pattern a] -> Pattern a
stack [Pattern Int]
pats)
      -- Project the 3-layer kProg pattern to the requested layer once,
      -- carrying the provenance-based voicing route with it
      progPat :: Pattern (Bool, Progression)
progPat = (ProgressionContext -> (Bool, Progression))
-> Pattern ProgressionContext -> Pattern (Bool, Progression)
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Layer -> ProgressionContext -> (Bool, Progression)
layerForVoicing Layer
lyr) (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
      -- Pre-compute voicings at construction time. The 'forced' binding's
      -- WHNF requires walking every inner list spine, which in turn forces
      -- the lazy 'strataModeFlow' \/ 'flow' voicing computation per bar.
      -- This hoists the work from the audio thread (where it would cause
      -- 'skip:' events on first query) to REPL evaluation time.
      allEvents :: [Event (Bool, Progression)]
allEvents = Pattern (Bool, Progression) -> Arc -> [Event (Bool, Progression)]
forall a. Pattern a -> Arc -> [Event a]
queryArc Pattern (Bool, Progression)
progPat (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc Time
0 Time
1000)
      uniqueProgs :: [(Bool, Progression)]
uniqueProgs = [(Bool, Progression)] -> [(Bool, Progression)]
forall a. Eq a => [a] -> [a]
nub ((Event (Bool, Progression) -> (Bool, Progression))
-> [Event (Bool, Progression)] -> [(Bool, Progression)]
forall a b. (a -> b) -> [a] -> [b]
map Event (Bool, Progression) -> (Bool, Progression)
forall a b. EventF a b -> b
value [Event (Bool, Progression)]
allEvents)
      cache :: [((Bool, Progression), ([[Note]], Int))]
cache = [ ((Bool, Progression)
key, 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 (Bool, Progression)
key)
                          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]]
                          nc :: Int
nc     = [[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
vs
                          forced :: ()
forced = [[Note]] -> ()
forceAll [[Note]]
sc
                      in ()
forced () -> ([[Note]], Int) -> ([[Note]], Int)
forall a b. a -> b -> b
`seq` ([[Note]]
sc, Int
nc))
              | (Bool, Progression)
key <- [(Bool, Progression)]
uniqueProgs ]
      cacheForced :: ()
cacheForced = (((Bool, Progression), ([[Note]], Int)) -> () -> ())
-> () -> [((Bool, Progression), ([[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 (\((Bool, Progression)
_, ([[Note]]
s, Int
_)) ()
acc -> [[Note]] -> ()
forceAll [[Note]]
s () -> () -> ()
forall a b. a -> b -> b
`seq` ()
acc) () [((Bool, Progression), ([[Note]], Int))]
cache
      lookupCache :: (Bool, Progression) -> ([[Note]], Int)
lookupCache (Bool, Progression)
key = case (Bool, Progression)
-> [((Bool, Progression), ([[Note]], Int))]
-> Maybe ([[Note]], Int)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Bool, Progression)
key [((Bool, Progression), ([[Note]], Int))]
cache of
        Just ([[Note]], Int)
hit -> ([[Note]], Int)
hit
        Maybe ([[Note]], Int)
Nothing  -> 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 (Bool, Progression)
key)
                        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]]
                        forced :: ()
forced = [[Note]] -> ()
forceAll [[Note]]
sc
                    in ()
forced () -> ([[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)
  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
|* String -> Pattern Double -> Pattern ValueMap
pF String
"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
$ ((Bool, Progression) -> Pattern ValueMap)
-> Pattern (Bool, 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 (\(Bool, Progression)
key ->
         ([[Note]], Int) -> Pattern Int -> Pattern Int -> Pattern ValueMap
arrangeLookup ((Bool, Progression) -> ([[Note]], Int)
lookupCache (Bool, Progression)
key) Pattern Int
chordPat Pattern Int
ranged
       ) Pattern (Bool, Progression)
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 Arc
forall a b. EventF a b -> Maybe a
whole Event Int
nEv of
              Maybe Arc
Nothing -> []
              Just Arc
wArc ->
                let onsetT :: Time
onsetT  = Arc -> Time
forall a. ArcF a -> a
start Arc
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   = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 ([Note] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Note]
sc)
                    octave :: Int
octave  = Int
noteVal Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
scLen
                    idx :: Int
idx     = Int
noteVal Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
scLen
                in [Event Int
nEv { value = (sc !! idx) + fromIntegral (octave * 12) }]
              ) [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

-------------------------------------------------------------------------------
-- 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, Int) -> Pattern Int -> Pattern Int
voiceRange (Int, Int)
register ([Pattern Int] -> Pattern Int
forall a. [Pattern a] -> Pattern a
stack [Pattern Int]
pats)
      progPat :: Pattern (Bool, Progression)
progPat = (ProgressionContext -> (Bool, Progression))
-> Pattern ProgressionContext -> Pattern (Bool, Progression)
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Layer -> ProgressionContext -> (Bool, Progression)
layerForVoicing Layer
lyr) (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
      -- Pre-compute voicings at construction time. See 'arrange' for the
      -- forced\/cacheForced rationale: hoists per-bar voicing computation
      -- from the audio thread to REPL evaluation time.
      allEvents :: [Event (Bool, Progression)]
allEvents = Pattern (Bool, Progression) -> Arc -> [Event (Bool, Progression)]
forall a. Pattern a -> Arc -> [Event a]
queryArc Pattern (Bool, Progression)
progPat (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc Time
0 Time
1000)
      uniqueProgs :: [(Bool, Progression)]
uniqueProgs = [(Bool, Progression)] -> [(Bool, Progression)]
forall a. Eq a => [a] -> [a]
nub ((Event (Bool, Progression) -> (Bool, Progression))
-> [Event (Bool, Progression)] -> [(Bool, Progression)]
forall a b. (a -> b) -> [a] -> [b]
map Event (Bool, Progression) -> (Bool, Progression)
forall a b. EventF a b -> b
value [Event (Bool, Progression)]
allEvents)
      cache :: [((Bool, Progression), ([[Note]], Int))]
cache = [ ((Bool, Progression)
key, 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 (Bool, Progression)
key)
                          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]]
                          nc :: Int
nc     = [[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
vs
                          forced :: ()
forced = [[Note]] -> ()
forceAll [[Note]]
sc
                      in ()
forced () -> ([[Note]], Int) -> ([[Note]], Int)
forall a b. a -> b -> b
`seq` ([[Note]]
sc, Int
nc))
              | (Bool, Progression)
key <- [(Bool, Progression)]
uniqueProgs ]
      cacheForced :: ()
cacheForced = (((Bool, Progression), ([[Note]], Int)) -> () -> ())
-> () -> [((Bool, Progression), ([[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 (\((Bool, Progression)
_, ([[Note]]
s, Int
_)) ()
acc -> [[Note]] -> ()
forceAll [[Note]]
s () -> () -> ()
forall a b. a -> b -> b
`seq` ()
acc) () [((Bool, Progression), ([[Note]], Int))]
cache
      lookupCache :: (Bool, Progression) -> ([[Note]], Int)
lookupCache (Bool, Progression)
key = case (Bool, Progression)
-> [((Bool, Progression), ([[Note]], Int))]
-> Maybe ([[Note]], Int)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Bool, Progression)
key [((Bool, Progression), ([[Note]], Int))]
cache of
        Just ([[Note]], Int)
hit -> ([[Note]], Int)
hit
        Maybe ([[Note]], Int)
Nothing  -> 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 (Bool, Progression)
key)
                        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]]
                        forced :: ()
forced = [[Note]] -> ()
forceAll [[Note]]
sc
                    in ()
forced () -> ([[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)
  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
|* String -> Pattern Double -> Pattern ValueMap
pF String
"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
$ ((Bool, Progression) -> Pattern ValueMap)
-> Pattern (Bool, 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 (\(Bool, Progression)
key ->
         ([[Note]], Int) -> Pattern Int -> Pattern Int -> Pattern ValueMap
arrangeLookup' ((Bool, Progression) -> ([[Note]], Int)
lookupCache (Bool, Progression)
key) Pattern Int
chordPat Pattern Int
ranged
       ) Pattern (Bool, Progression)
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

-------------------------------------------------------------------------------
-- 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 -> Arc -> [Event Int]
forall a. Pattern a -> Arc -> [Event a]
queryArc Pattern Int
cpat (Time -> Time -> Arc
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 [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 (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