-- |
-- Module      : Harmonic.Interface.Tidal.LineHarmony
-- Description : TidalCycles walking-bass interface
--
-- Wraps 'Harmonic.Traversal.WalkingBass.walkLine' in the cache + innerJoin
-- pattern used by 'Harmonic.Interface.Tidal.Bridge.arrange':
--
--   * The chord-selection pattern is resolved into a PERFORMED bar sequence
--     at eval time ('resolvePerformedSeq'); the walk runs over the bars in
--     performed order, so warp\/rep reorderings and repeats are walked as
--     the audience hears them. Non-periodic selections fall back to stored
--     order with a printed notice.
--   * Progressions seen on 'kProg' are pre-materialised once into walking-
--     bass lines keyed by (triads, chroma sources, performed sequence),
--     forced eagerly so synthesis stays off the audio thread. The forcing
--     horizon is 'Arc 0 1000' — a key first seen beyond cycle 1000 is
--     synthesised on demand (with a printed notice).
--   * 'innerJoin' switches lines reactively when the form changes progression.
--   * The input pattern list is dispatched by 'kinPick': [0,1] is partitioned
--     into N equal windows (N = length of the list) and only the pattern
--     whose window contains the current kinetics signal plays. Output is
--     scaled by 'kDynamic' and the user-supplied dynamics scalar (applied
--     once here — launchers must not multiply by the same dynamic again).
--
-- Each integer in a pattern selects a 1-indexed beat position (1..4).
-- Values outside [1..4] shift by full octaves, matching the div\/mod
-- convention of 'Harmonic.Interface.Tidal.Bridge.arrange': 5 → beat 1 +12, 0 → beat 4 −12, -1 → beat 3 −12.
--
-- In a launcher, the walking line is an ordinary block alongside the
-- orchestral ones:
--
-- @
-- walk f k d = p \"walk\" $ f
--   $ lineHarmony k [\"1 2 3 4\"] |* vel d
-- @
--
-- Because each integer picks a beat position, the pattern controls /which/
-- beats of the generated line sound — @\"1 ~ 3 ~\"@ plays a half-time
-- version of the same line rather than a different line.
module Harmonic.Interface.Tidal.LineHarmony
  ( lineHarmony
  , resolvePerformedSeq
  ) where

import qualified Harmonic.Rules.Types.Progression as P
import qualified Harmonic.Rules.Types.ProgressionContext as PC
import qualified Harmonic.Rules.Types.Harmony as H
import qualified Harmonic.Rules.Types.Pitch as Pt
import Harmonic.Interface.Tidal.Form (Kinetics(..), IK, kinPick)
import Harmonic.Interface.Tidal.Bridge (VoiceFunction, lookupChordAt, forceAll)
import Harmonic.Traversal.WalkingBass
  ( walkLineDyn, walkLinePDyn, ChromaSources(..), beatsPerBar )

import Data.List (nub)
import Data.Maybe (isJust, listToMaybe)
import Data.Foldable (toList)
import qualified Data.Set as Set
import Debug.Trace (trace)
import Sound.Tidal.Context hiding (voice)

-- | Empirical offset between 'Harmonic.Traversal.WalkingBass.walkLine' absolute MIDI and the downstream
-- synth's note-0 pitch on the default patch. Subtract before emitting so the
-- E1..C3 range is audibly faithful without manual @|- oct n@ compensation.
tidalNoteOffset :: Int
tidalNoteOffset :: Int
tidalNoteOffset = Int
48

-- | Walking-bass arrangement with kinetics gating.
--
-- Fixed to the double-bass register (E1..C3, MIDI 28..48) inside 'Harmonic.Traversal.WalkingBass.walkLine';
-- the emitted Tidal @note@ values are pre-shifted by @tidalNoteOffset@ so
-- this range is audibly true at default synth tuning — no @|- oct n@
-- compensation needed. Runtime register shifts via @|+ oct n@ \/ @|- oct n@
-- on the launcher side still compose normally.
--
-- For octatripentatonic progressions (@pcProvenance@ = 'Just'), the Pass-3
-- connector pool is reweighted: strata pitches (5 PCs) are most preferred,
-- overlap (cyclic union of adjacent chord-PCs) is neutral, mode pitches
-- (7 PCs) are admissible with a mild penalty, and chromatic ±1 approaches
-- outside any of those sets are removed entirely. For 'Harmonic.Framework.Builder.gen' (legacy)
-- progressions the line is byte-identical to the previous behaviour.
--
-- Entropy is derived internally from the progression's harmonic character.
lineHarmony
  :: Pattern Double       -- ^ Dynamics scalar (amp multiplier)
  -> IK                    -- ^ Performance context (kinetics + chord-selection)
  -> VoiceFunction         -- ^ Beat-1 voicing (fund or root)
  -> [Pattern Int]         -- ^ Polyphonic layers (1-indexed beat positions)
  -> Pattern ValueMap
lineHarmony :: Pattern Double
-> IK -> VoiceFunction -> [Pattern Int] -> Pattern ValueMap
lineHarmony Pattern Double
dyn (Kinetics
kin, Pattern Int
chordPat) VoiceFunction
voiceFn [Pattern Int]
pats =
  let stacked :: Pattern Int
stacked     = IK -> [Pattern Int] -> Pattern Int
forall a. IK -> [Pattern a] -> Pattern a
kinPick (Kinetics
kin, Pattern Int
chordPat) [Pattern Int]
pats
      ctxPat :: Pattern ProgressionContext
ctxPat      = Kinetics -> Pattern ProgressionContext
kProg Kinetics
kin
      -- Resolve the PERFORMED bar sequence from the chord-selection
      -- pattern: the walk then runs over the bars in the order (and with
      -- the duplications) the audience actually hears, so approach tones
      -- aim at true performed successors and repeated bars walk as
      -- neighbours. Non-periodic selections fall back to stored order.
      performedVals0 :: Maybe [Int]
performedVals0 = Pattern Int -> Maybe [Int]
resolvePerformedSeq Pattern Int
chordPat
      -- Couple the walk to the piece's dynamics: the eval-time-sampleable
      -- dynamic signal (launcher scalar x form-node dynamic) is quantised
      -- per bar; if the (chord, dynamic) pair sequence is periodic within
      -- the cap, the walked period extends to cover one full dynamic cycle
      -- and the per-bar levels steer the beat-1 register arc. Live control
      -- signals resolve to their defaults at eval time, so live-driven
      -- dynamics stay walk-neutral by construction.
      dynSig :: Pattern Double
dynSig = Pattern Double
dyn Pattern Double -> Pattern Double -> Pattern Double
forall a. Num a => a -> a -> a
* Kinetics -> Pattern Double
kDynamic Kinetics
kin
      (Maybe [Int]
performedVals, Maybe [Int]
dynTiers) = Pattern Double -> Maybe [Int] -> (Maybe [Int], Maybe [Int])
resolveDynTiers Pattern Double
dynSig Maybe [Int]
performedVals0
      keyPat :: Pattern WalkKey
keyPat      = (ProgressionContext -> WalkKey)
-> Pattern ProgressionContext -> Pattern WalkKey
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe [Int] -> Maybe [Int] -> ProgressionContext -> WalkKey
walkKey Maybe [Int]
performedVals Maybe [Int]
dynTiers) Pattern ProgressionContext
ctxPat
      allEvents :: [Event WalkKey]
allEvents   = Pattern WalkKey -> Arc -> [Event WalkKey]
forall a. Pattern a -> Arc -> [Event a]
queryArc Pattern WalkKey
keyPat (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc Time
0 Time
1000)
      uniqueKeys :: [WalkKey]
uniqueKeys  = [WalkKey] -> [WalkKey]
forall a. Eq a => [a] -> [a]
nub ((Event WalkKey -> WalkKey) -> [Event WalkKey] -> [WalkKey]
forall a b. (a -> b) -> [a] -> [b]
map Event WalkKey -> WalkKey
forall a b. EventF a b -> b
value [Event WalkKey]
allEvents)
      -- Build the cache and deeply force each entry so the 3-pass
      -- walking-bass synthesis runs at REPL evaluation time, not on the
      -- audio thread. Mirrors the eager-forcing pattern in 'Harmonic.Interface.Tidal.Bridge.arrange'.
      cache :: [(WalkKey, ([[Note]], Int))]
cache       = [ (WalkKey
k, VoiceFunction -> WalkKey -> ([[Note]], Int)
buildCacheKey VoiceFunction
voiceFn WalkKey
k) | WalkKey
k <- [WalkKey]
uniqueKeys ]
      cacheForced :: ()
cacheForced = ((WalkKey, ([[Note]], Int)) -> () -> ())
-> () -> [(WalkKey, ([[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 (\(WalkKey
_, ([[Note]]
b, Int
_)) ()
acc -> [[Note]] -> ()
forceAll [[Note]]
b () -> () -> ()
forall a b. a -> b -> b
`seq` ()
acc) () [(WalkKey, ([[Note]], Int))]
cache
      lookupCache :: WalkKey -> ([[Note]], Int)
lookupCache WalkKey
k = case WalkKey -> [(WalkKey, ([[Note]], Int))] -> Maybe ([[Note]], Int)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup WalkKey
k [(WalkKey, ([[Note]], Int))]
cache of
        Just ([[Note]], Int)
hit -> ([[Note]], Int)
hit
        Maybe ([[Note]], Int)
Nothing  -> String -> ([[Note]], Int) -> ([[Note]], Int)
forall a. String -> a -> a
trace String
"walk: uncached progression - synthesising line on demand"
                          (let pair :: ([[Note]], Int)
pair@([[Note]]
bars, Int
_) = VoiceFunction -> WalkKey -> ([[Note]], Int)
buildCacheKey VoiceFunction
voiceFn WalkKey
k
                           in [[Note]] -> ()
forceAll [[Note]]
bars () -> ([[Note]], Int) -> ([[Note]], Int)
forall a b. a -> b -> b
`seq` ([[Note]], Int)
pair)
  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 ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall a. Num a => Pattern a -> Pattern a -> Pattern a
|* String -> Pattern Double -> Pattern ValueMap
pF String
"amp" Pattern Double
dyn) (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
$ (WalkKey -> Pattern ValueMap)
-> Pattern WalkKey -> 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 (\WalkKey
k ->
         ([[Note]], Int)
-> Pattern Int -> Pattern Int -> Bool -> Pattern ValueMap
renderWalk (WalkKey -> ([[Note]], Int)
lookupCache WalkKey
k) Pattern Int
chordPat Pattern Int
stacked (Maybe [Int] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [Int]
performedVals)
       ) Pattern WalkKey
keyPat

-- | Quantise the dynamic signal per bar (mean of four in-bar samples,
-- eighth-step grid) and extend the performed period so one walked cycle
-- covers both the chord sequence and the dynamic envelope: the smallest
-- multiple k*P <= 64 bars at which the (chord, tier) pair sequence repeats.
-- Returns the (possibly extended) performed values and the aligned tiers;
-- a dynamic signal with no such period leaves the chord period unchanged
-- and the walk dynamics-blind.
resolveDynTiers :: Pattern Double -> Maybe [Int] -> (Maybe [Int], Maybe [Int])
resolveDynTiers :: Pattern Double -> Maybe [Int] -> (Maybe [Int], Maybe [Int])
resolveDynTiers Pattern Double
_   Maybe [Int]
Nothing     = (Maybe [Int]
forall a. Maybe a
Nothing, Maybe [Int]
forall a. Maybe a
Nothing)
resolveDynTiers Pattern Double
sig (Just [Int]
vals) =
  case Maybe [Int]
mTiers of
    Maybe [Int]
Nothing    -> ([Int] -> Maybe [Int]
forall a. a -> Maybe a
Just [Int]
vals, Maybe [Int]
forall a. Maybe a
Nothing)
    Just [Int]
tiers ->
      let p :: Int
p      = [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
vals
          pairs :: [(Int, Int)]
pairs  = [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Int] -> [Int]
forall a. HasCallStack => [a] -> [a]
cycle [Int]
vals) [Int]
tiers
          maxP :: Int
maxP   = Int
64
          exts :: [Int]
exts   = [ Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
p | Int
k <- [Int
1 ..], Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxP ]
          fits :: Int -> Bool
fits Int
n = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ [(Int, Int)]
pairs [(Int, Int)] -> Int -> (Int, Int)
forall a. HasCallStack => [a] -> Int -> a
!! Int
i (Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
== [(Int, Int)]
pairs [(Int, Int)] -> Int -> (Int, Int)
forall a. HasCallStack => [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)
                       | Int
i <- [Int
0 .. [(Int, Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, Int)]
pairs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ]
      in case (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter Int -> Bool
fits [Int]
exts of
           (Int
n:[Int]
_) -> ( [Int] -> Maybe [Int]
forall a. a -> Maybe a
Just (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
n ([Int] -> [Int]
forall a. HasCallStack => [a] -> [a]
cycle [Int]
vals))
                    , [Int] -> Maybe [Int]
forall a. a -> Maybe a
Just (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
n [Int]
tiers) )
           []    -> ([Int] -> Maybe [Int]
forall a. a -> Maybe a
Just [Int]
vals, Maybe [Int]
forall a. Maybe a
Nothing)
  where
    horizon :: Int
horizon = Int
128
    barTier :: p -> Maybe Int
barTier p
k =
      let pointVal :: Time -> Maybe Double
pointVal Time
t = case Pattern Double -> Arc -> [Event Double]
forall a. Pattern a -> Arc -> [Event a]
queryArc Pattern Double
sig (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc Time
t Time
t) of
                         [Event Double
ev] -> Double -> Maybe Double
forall a. a -> Maybe a
Just (Event Double -> Double
forall a b. EventF a b -> b
value Event Double
ev)
                         [Event Double]
_    -> Maybe Double
forall a. Maybe a
Nothing
          samples :: [Maybe Double]
samples = [ Time -> Maybe Double
pointVal (Time
4 Time -> Time -> Time
forall a. Num a => a -> a -> a
* p -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral p
k Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
off)
                    | Time
off <- [Time
0.5, Time
1.5, Time
2.5, Time
3.5 :: Time] ]
      in case [Maybe Double] -> Maybe [Double]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe Double]
samples of
           Just [Double]
vs -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
8 Double -> Double -> Double
forall a. Num a => a -> a -> a
* [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Double]
vs Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
4) :: Int)
           Maybe [Double]
Nothing -> Maybe Int
forall a. Maybe a
Nothing
    mTiers :: Maybe [Int]
mTiers = (Int -> Maybe Int) -> [Int] -> Maybe [Int]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Int -> Maybe Int
forall {p}. Integral p => p -> Maybe Int
barTier [Int
0 .. Int
horizon Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 :: Int]

-- | Resolve the performed bar sequence from a chord-selection pattern.
-- Succeeds when the pattern is bar-quantised (one constant value per
-- 4-cycle bar window) and periodic with the smallest period P <= 64 bars;
-- the result is the raw 1-indexed selector values of one period, in
-- performed order. 'rep s 1' resolves to [1..n]; 'rep s N' to each value
-- N times; 'warp "[..]\/k"' to the written sequence. Degraded (@?@),
-- euclidean, and sub-bar selections return Nothing, and the walk falls
-- back to stored bar order with a one-line notice.
resolvePerformedSeq :: Pattern Int -> Maybe [Int]
resolvePerformedSeq :: Pattern Int -> Maybe [Int]
resolvePerformedSeq Pattern Int
pat =
  case Maybe [Int]
mVals Maybe [Int] -> ([Int] -> Maybe [Int]) -> Maybe [Int]
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Int] -> Maybe [Int]
forall {a}. Eq a => [a] -> Maybe [a]
findPeriod of
    Just [Int]
vs -> [Int] -> Maybe [Int]
forall a. a -> Maybe a
Just [Int]
vs
    Maybe [Int]
Nothing -> String -> Maybe [Int] -> Maybe [Int]
forall a. String -> a -> a
trace String
"walk: non-periodic chord selection - walking stored bar order"
                     Maybe [Int]
forall a. Maybe a
Nothing
  where
    maxPeriod :: Int
maxPeriod = Int
64
    horizon :: Int
horizon   = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
maxPeriod
    barVal :: p -> Maybe Int
barVal p
k =
      let pointVal :: Time -> Maybe Int
pointVal Time
t = case Pattern Int -> Arc -> [Event Int]
forall a. Pattern a -> Arc -> [Event a]
queryArc Pattern Int
pat (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc Time
t Time
t) of
                         [Event Int
ev] -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Event Int -> Int
forall a b. EventF a b -> b
value Event Int
ev)
                         [Event Int]
_    -> Maybe Int
forall a. Maybe a
Nothing
          samples :: [Maybe Int]
samples = [ Time -> Maybe Int
pointVal (Time
4 Time -> Time -> Time
forall a. Num a => a -> a -> a
* p -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral p
k Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
off)
                    | Time
off <- [Time
0.5, Time
1.5, Time
2.5, Time
3.5 :: Time] ]
      in case [Maybe Int] -> Maybe [Int]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe Int]
samples of
           Just (Int
v:[Int]
vs) | (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
v) [Int]
vs -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
v
           Maybe [Int]
_                           -> Maybe Int
forall a. Maybe a
Nothing
    mVals :: Maybe [Int]
mVals = (Int -> Maybe Int) -> [Int] -> Maybe [Int]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Int -> Maybe Int
forall {p}. Integral p => p -> Maybe Int
barVal [Int
0 .. Int
horizon Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 :: Int]
    findPeriod :: [a] -> Maybe [a]
findPeriod [a]
vs =
      [[a]] -> Maybe [a]
forall a. [a] -> Maybe a
listToMaybe
        [ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
p [a]
vs
        | Int
p <- [Int
1 .. Int
maxPeriod]
        , [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ [a]
vs [a] -> Int -> a
forall a. HasCallStack => [a] -> Int -> a
!! Int
k a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== [a]
vs [a] -> Int -> a
forall a. HasCallStack => [a] -> Int -> a
!! (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
p) | Int
k <- [Int
0 .. [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
vs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ]
        ]

-- | Cache key carrying the triad layer plus, when the source is an
-- octatripentatonic ProgressionContext, the per-bar 'ChromaSources' that
-- drive 'Harmonic.Traversal.WalkingBass.walkLineP'. Two contexts with identical triads but different
-- strata walks produce different lines; without the 'ChromaSources' in
-- the key the cache would silently collide. The third component is the
-- resolved performed sequence (raw selector values), so two launches
-- differing only in warp\/rep never collide either; the fourth is the
-- per-bar dynamic tier vector steering the register arc.
type WalkKey = (P.Progression, Maybe [ChromaSources], Maybe [Int], Maybe [Int])

-- | Project a 'Harmonic.Rules.Types.ProgressionContext.ProgressionContext' into the cache key. For 'Harmonic.Framework.Builder.gen'
-- (no provenance) the second component is 'Nothing' — legacy 'Harmonic.Traversal.WalkingBass.walkLine'
-- handles those. For 'Harmonic.Framework.Builder.genP' it carries the per-bar 5-PC strata and 7-PC
-- mode chroma read directly off the auxiliary layers, which after the
-- 3-5-7 fix carry the full chroma rooted on each bar's harmonic root.
walkKey :: Maybe [Int] -> Maybe [Int] -> PC.ProgressionContext -> WalkKey
walkKey :: Maybe [Int] -> Maybe [Int] -> ProgressionContext -> WalkKey
walkKey Maybe [Int]
performedVals Maybe [Int]
dynTiers ProgressionContext
ctx =
  ( ProgressionContext -> Progression
PC.triadLayer ProgressionContext
ctx
  , case ProgressionContext -> Maybe (Seq (Tristrata, StrataLabel))
PC.pcProvenance ProgressionContext
ctx of
      Maybe (Seq (Tristrata, StrataLabel))
Nothing -> Maybe [ChromaSources]
forall a. Maybe a
Nothing
      Just Seq (Tristrata, StrataLabel)
_  -> [ChromaSources] -> Maybe [ChromaSources]
forall a. a -> Maybe a
Just (ProgressionContext -> [ChromaSources]
chromaSourcesFor ProgressionContext
ctx)
  , Maybe [Int]
performedVals
  , Maybe [Int]
dynTiers
  )

-- | Read per-bar (strata, mode) absolute-PC sets from the strata \/ mode
-- auxiliary layers. After the Builder fix these carry 5 \/ 7 PCs as
-- intervals from the bar's harmonic root, so we add the root back to
-- recover absolute pitch classes.
chromaSourcesFor :: PC.ProgressionContext -> [ChromaSources]
chromaSourcesFor :: ProgressionContext -> [ChromaSources]
chromaSourcesFor ProgressionContext
ctx =
  let strataCSs :: [CadenceState]
strataCSs = 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.strataLayer ProgressionContext
ctx))
      modeCSs :: [CadenceState]
modeCSs   = 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))
      pcsAbs :: CadenceState -> Set Int
pcsAbs CadenceState
cs =
        let r :: Int
r = PitchClass -> Int
Pt.unPitchClass (NoteName -> PitchClass
Pt.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
cs))
            ints :: [Int]
ints = (PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
Pt.unPitchClass (Cadence -> [PitchClass]
H.cadenceIntervals (CadenceState -> Cadence
H.stateCadence CadenceState
cs))
        in [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList [ (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
r) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12 | Int
i <- [Int]
ints ]
  in [ Set Int -> Set Int -> ChromaSources
ChromaSources (CadenceState -> Set Int
pcsAbs CadenceState
s) (CadenceState -> Set Int
pcsAbs CadenceState
m)
     | (CadenceState
s, CadenceState
m) <- [CadenceState] -> [CadenceState] -> [(CadenceState, CadenceState)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CadenceState]
strataCSs [CadenceState]
modeCSs ]

-- | Pre-compute walking line for a single cache key; convert to 'Note',
-- shifted by @tidalNoteOffset@ so absolute MIDI from 'Harmonic.Traversal.WalkingBass.walkLine' aligns with
-- Tidal's @note@ convention. When the key carries a performed sequence,
-- the stored bars (and ChromaSources, for genP) are reordered\/duplicated
-- into performed order first and the walk runs over THAT progression —
-- the cached line is then indexed by performed ordinal in 'renderWalk'.
-- Dispatches on the 'ChromaSources' presence:
-- 'Just' → 'Harmonic.Traversal.WalkingBass.walkLineP'; 'Nothing' → legacy 'Harmonic.Traversal.WalkingBass.walkLine'.
buildCacheKey :: VoiceFunction -> WalkKey -> ([[Note]], Int)
buildCacheKey :: VoiceFunction -> WalkKey -> ([[Note]], Int)
buildCacheKey VoiceFunction
voiceFn (Progression
prog, Maybe [ChromaSources]
mChromas, Maybe [Int]
mVals, Maybe [Int]
mTiers) =
  let barsL :: [CadenceState]
barsL = Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
P.unProgression Progression
prog)
      n :: Int
n     = [CadenceState] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CadenceState]
barsL
      mIdxs :: Maybe [Int]
mIdxs = case Maybe [Int]
mVals of
                Just [Int]
vals | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> [Int] -> Maybe [Int]
forall a. a -> Maybe a
Just [ (Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
n | Int
v <- [Int]
vals ]
                Maybe [Int]
_                 -> Maybe [Int]
forall a. Maybe a
Nothing
      (Progression
prog', Maybe [ChromaSources]
mChromas') = case Maybe [Int]
mIdxs of
        Maybe [Int]
Nothing -> (Progression
prog, Maybe [ChromaSources]
mChromas)
        Just [Int]
is -> ( [CadenceState] -> Progression
P.fromCadenceStates [ [CadenceState]
barsL [CadenceState] -> Int -> CadenceState
forall a. HasCallStack => [a] -> Int -> a
!! Int
i | Int
i <- [Int]
is ]
                   , ([ChromaSources] -> [ChromaSources])
-> Maybe [ChromaSources] -> Maybe [ChromaSources]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[ChromaSources]
chs -> [ [ChromaSources]
chs [ChromaSources] -> Int -> ChromaSources
forall a. HasCallStack => [a] -> Int -> a
!! Int
i | Int
i <- [Int]
is ]) Maybe [ChromaSources]
mChromas )
      mDyn :: Maybe [Double]
mDyn = ([Int] -> [Double]) -> Maybe [Int] -> Maybe [Double]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> Double) -> [Int] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
t -> Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
8)) Maybe [Int]
mTiers
      line :: [[Int]]
line = case Maybe [ChromaSources]
mChromas' of
               Maybe [ChromaSources]
Nothing      -> Maybe [Double] -> VoiceFunction -> VoiceFunction
walkLineDyn  Maybe [Double]
mDyn VoiceFunction
voiceFn Progression
prog'
               Just [ChromaSources]
chromas -> Maybe [Double]
-> VoiceFunction -> Progression -> [ChromaSources] -> [[Int]]
walkLinePDyn Maybe [Double]
mDyn VoiceFunction
voiceFn Progression
prog' [ChromaSources]
chromas
  in (([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
m -> Int -> Note
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
tidalNoteOffset))) [[Int]]
line, [[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
line)

-- | Map stacked beat-position events through the cached walking line.
-- In performed mode the cached line is already in performed order, one
-- bar per performed ordinal: the bar index is the global bar count
-- (onset \/ 4) modulo the period. In stored-order fallback the bar index
-- comes from the chord-selection pattern's value at the onset.
renderWalk
  :: ([[Note]], Int)
  -> Pattern Int            -- ^ Bar-selection pattern (1-indexed)
  -> Pattern Int            -- ^ Stacked beat-index input
  -> Bool                   -- ^ Performed mode (line is in performed order)
  -> Pattern ValueMap
renderWalk :: ([[Note]], Int)
-> Pattern Int -> Pattern Int -> Bool -> Pattern ValueMap
renderWalk ([[Note]]
bars, Int
nBars) Pattern Int
chordPat Pattern Int
stacked Bool
performed
  | Int
nBars 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
nBars) 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
stacked 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      = if Bool
performed
                                 then Time -> Int
forall b. Integral b => Time -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Time
onsetT Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Time
4)
                                 else Time -> Pattern Int -> Int
lookupChordAt Time
onsetT Pattern Int
chordIdx
                       bar :: [Note]
bar     = [[Note]]
bars [[Note]] -> Int -> [Note]
forall a. HasCallStack => [a] -> Int -> a
!! (Int
ci Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
nBars)
                       noteVal :: Int
noteVal = Event Int -> Int
forall a b. EventF a b -> b
value Event Int
nEv
                       vShift :: Int
vShift  = Int
noteVal Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1            -- 1-indexed → 0-indexed
                       idx :: Int
idx     = Int
vShift Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
beatsPerBar
                       octave :: Int
octave  = Int
vShift Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
beatsPerBar
                   in [Event Int
nEv { value = (bar !! 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