-- |
-- 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 d k fund [\"1 2 3 4\"]
-- @
--
-- (dynamics scalar, context, beat-1 voicing, then the beat-position
-- patterns; the scalar multiplies the form's 'kDynamic' internally — do
-- not also apply @|* 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, walkLineJDyn, ChromaSources(..), beatsPerBar )
import qualified Harmonic.Rules.Import.Jazz as J

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.
--
-- The walk adapts to the generation family of the context it is given.
-- 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 jazz progressions
-- (@pcFamily@ = 'Harmonic.Rules.Types.ProgressionContext.FJazz') each bar
-- carries a 'Harmonic.Rules.Import.Jazz.BassVocab' derived from its chord
-- symbol, so the line reads the harmony as a bass player does — the fifth
-- a 13th chord omits is restored, an altered dominant's \#5 replaces the
-- natural 5, and notated colour alterations stay off strong beats.
-- 'Harmonic.Framework.Builder.gen' and 'Harmonic.Framework.Builder.genE'
-- progressions walk their plain per-bar tone sets (for genE that is the
-- foundation layer — the layer that owns the bass); connector tones draw
-- on the key-area palette
-- ('Harmonic.Evaluation.Analysis.KeyArea.barPalettes') — the same
-- analysis behind the chordscale S\/M layers.
--
-- 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@). Only the bass pitch class of each bar is read, so a solving strategy buys nothing here: @grid@ returns the root by its own invariant, at the price of a voicing solve
  -> [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
      -- Cache keyed on the CONTEXT, not on the derived walk key. The form
      -- can only ever emit the progressions in 'kProgs', so each one's key
      -- and line are derived exactly once, here. Deriving the key inside
      -- the query instead (@fmap (walkKey …) ctxPat@) rebuilt the jazz bass
      -- vocabulary — and the genP chroma sets — for every bar on every
      -- query, i.e. once per audio tick per bar.
      --
      -- Entries are deeply forced so the 3-pass walking-bass synthesis runs
      -- at REPL evaluation time rather than on the audio thread. Mirrors
      -- the eager-forcing pattern in 'Harmonic.Interface.Tidal.Bridge.arrange'.
      lineFor :: ProgressionContext -> ([[Note]], Int)
lineFor ProgressionContext
ctx = VoiceFunction -> WalkKey -> ([[Note]], Int)
buildCacheKey VoiceFunction
voiceFn (Maybe [Int] -> Maybe [Int] -> ProgressionContext -> WalkKey
walkKey Maybe [Int]
performedVals Maybe [Int]
dynTiers ProgressionContext
ctx)
      cache :: [(ProgressionContext, ([[Note]], Int))]
cache       = [ (ProgressionContext
ctx, ProgressionContext -> ([[Note]], Int)
lineFor ProgressionContext
ctx) | ProgressionContext
ctx <- [ProgressionContext] -> [ProgressionContext]
forall a. Eq a => [a] -> [a]
nub (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]]
b, Int
_)) ()
acc -> [[Note]] -> ()
forceAll [[Note]]
b () -> () -> ()
forall a b. a -> b -> b
`seq` ()
acc) () [(ProgressionContext, ([[Note]], Int))]
cache
      -- Unreachable for both kinetics constructors ('formK' emits only
      -- values drawn from its node list, 'lK' a single one), so this is a
      -- safety net, not a path. Silent by design: it runs inside the query,
      -- where a Debug.Trace write would take the stderr lock on the clock
      -- thread every tick and turn a miss into a permanent dropout.
      lookupLine :: ProgressionContext -> ([[Note]], Int)
lookupLine 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  -> let pair :: ([[Note]], Int)
pair@([[Note]]
bars, Int
_) = ProgressionContext -> ([[Note]], Int)
lineFor ProgressionContext
ctx
                    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
$ (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 -> Bool -> Pattern ValueMap
renderWalk (ProgressionContext -> ([[Note]], Int)
lookupLine ProgressionContext
ctx) Pattern Int
chordPat Pattern Int
stacked (Maybe [Int] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [Int]
performedVals)
       ) Pattern ProgressionContext
ctxPat

-- | 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)
-- No performed values means no period to extend, and `cycle []` diverges.
resolveDynTiers Pattern Double
_    (Just [])   = ([Int] -> Maybe [Int]
forall a. a -> Maybe a
Just [], Maybe [Int]
forall a. Maybe a
Nothing)
resolveDynTiers Pattern Double
sigP (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
          -- takeWhile, NOT a filter guard. `[k * p | k <- [1..], k * p <= maxP]`
          -- draws from an infinite source and simply stops yielding once the
          -- guard fails — it never ends. `filter fits` over that hangs forever
          -- whenever no extension fits, which made the `[]` branch below
          -- unreachable and could freeze a live set outright. Any multi-node
          -- form with ramping dynamics produces a non-periodic tier vector and
          -- reaches exactly that case.
          exts :: [Int]
exts   = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxP) [ Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
p | Int
k <- [Int
1 ..] ]
          fits :: Int -> Bool
fits Int
m = [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
m)
                       | 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
m 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
m:[Int]
_) -> ( [Int] -> Maybe [Int]
forall a. a -> Maybe a
Just (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
m ([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
m [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
sigP (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
          beatVals :: [Maybe Double]
beatVals = [ 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
beatOff)
                     | Time
beatOff <- [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]
beatVals 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
          beatVals :: [Maybe Int]
beatVals = [ 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
beatOff)
                     | Time
beatOff <- [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]
beatVals 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 is the per-bar
-- jazz bass vocabulary, which distinguishes an FJazz context from an
-- FTriad one carrying a byte-identical triad layer. The fourth is the
-- resolved performed sequence (raw selector values), so two launches
-- differing only in warp\/rep never collide either; the fifth is the
-- per-bar dynamic tier vector steering the register arc.
type WalkKey =
  ( P.Progression
  , Maybe [ChromaSources]   -- genP strata/mode chroma
  , Maybe [J.BassVocab]     -- genJ per-bar bass vocabulary
  , Maybe [Int]             -- performed sequence
  , Maybe [Int]             -- dynamic tiers
  )

-- | 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)
  , ProgressionContext -> Maybe [BassVocab]
jazzVocabFor ProgressionContext
ctx
  , Maybe [Int]
performedVals
  , Maybe [Int]
dynTiers
  )

-- | Per-bar walking-bass vocabulary for jazz-family contexts: corpus tone
-- sets are working voicings (13th chords omit the 5th and 11th; altered
-- qualities replace the 5th; notated colours are not strong-beat targets),
-- so FJazz bars walk from 'J.bassVocabFor' over their stored intervals
-- rather than the raw shapes. Other families return 'Nothing' and walk
-- exactly as before.
jazzVocabFor :: PC.ProgressionContext -> Maybe [J.BassVocab]
jazzVocabFor :: ProgressionContext -> Maybe [BassVocab]
jazzVocabFor ProgressionContext
ctx
  | ProgressionContext -> Family
PC.pcFamily ProgressionContext
ctx Family -> Family -> Bool
forall a. Eq a => a -> a -> Bool
/= Family
PC.FJazz = Maybe [BassVocab]
forall a. Maybe a
Nothing
  | Bool
otherwise = [BassVocab] -> Maybe [BassVocab]
forall a. a -> Maybe a
Just
      [ [Int] -> BassVocab
J.bassVocabFor
          ((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)))
      | CadenceState
cs <- 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.triadLayer ProgressionContext
ctx)) ]

-- | 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
sc) (CadenceState -> Set Int
pcsAbs CadenceState
mc)
     | (CadenceState
sc, CadenceState
mc) <- [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 two family side-channels, chroma first: strata
-- chroma → 'Harmonic.Traversal.WalkingBass.walkLineP'; jazz vocabulary →
-- 'Harmonic.Traversal.WalkingBass.walkLineJ'; neither → legacy
-- 'Harmonic.Traversal.WalkingBass.walkLine'. The two are mutually
-- exclusive in practice — genP carries provenance and genJ does not — so
-- the order only fixes a case that cannot currently arise.
--
-- Performed order, deliberately: the walk analyses (and walks) the bar
-- sequence AS PLAYED — under a non-identity chord selection its key-area
-- palettes come from a fresh analysis of the performed sequence, not a
-- permutation of the stored one that the chordscale S\/M layers carry.
-- Same theory, two applications (generation-time annotation vs runtime
-- line), and the walk adds chromatic approach tones beyond either. Ruled
-- 2026-08-29.
buildCacheKey :: VoiceFunction -> WalkKey -> ([[Note]], Int)
buildCacheKey :: VoiceFunction -> WalkKey -> ([[Note]], Int)
buildCacheKey VoiceFunction
voiceFn (Progression
prog, Maybe [ChromaSources]
mChromas, Maybe [BassVocab]
mVocab, 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)
      nBars :: Int
nBars = [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
nBars 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
nBars | Int
v <- [Int]
vals ]
                Maybe [Int]
_                 -> Maybe [Int]
forall a. Maybe a
Nothing
      (Progression
prog', Maybe [ChromaSources]
mChromas', Maybe [BassVocab]
mVocab') = case Maybe [Int]
mIdxs of
        Maybe [Int]
Nothing -> (Progression
prog, Maybe [ChromaSources]
mChromas, Maybe [BassVocab]
mVocab)
        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
                   , ([BassVocab] -> [BassVocab])
-> Maybe [BassVocab] -> Maybe [BassVocab]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[BassVocab]
vs  -> [ [BassVocab]
vs  [BassVocab] -> Int -> BassVocab
forall a. HasCallStack => [a] -> Int -> a
!! Int
i | Int
i <- [Int]
is ]) Maybe [BassVocab]
mVocab )
      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', Maybe [BassVocab]
mVocab') of
               (Just [ChromaSources]
chromas, Maybe [BassVocab]
_) -> Maybe [Double]
-> VoiceFunction -> Progression -> [ChromaSources] -> [[Int]]
walkLinePDyn Maybe [Double]
mDyn VoiceFunction
voiceFn Progression
prog' [ChromaSources]
chromas
               (Maybe [ChromaSources]
_, Just [BassVocab]
vocabs)  -> Maybe [Double]
-> VoiceFunction -> Progression -> [BassVocab] -> [[Int]]
walkLineJDyn Maybe [Double]
mDyn VoiceFunction
voiceFn Progression
prog' [BassVocab]
vocabs
               (Maybe [ChromaSources], Maybe [BassVocab])
_                 -> Maybe [Double] -> VoiceFunction -> VoiceFunction
walkLineDyn  Maybe [Double]
mDyn VoiceFunction
voiceFn Progression
prog'
  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
                       octv :: Int
octv    = Int
vShift Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
beatsPerBar
                   in [Event Int
nEv { value = (bar !! idx) + fromIntegral (octv * 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