-- |
-- Module      : Harmonic.Traversal.WalkingBass
-- Description : Three-pass walking-bass line generator with derived entropy
--
-- Produces a walking-bass line for a cyclic Progression as a pure function
-- of (progression, voiceFn) via three sequential passes:
--
--   1. Pass 1 — beat 1s. Every bar's beat 1 is a singleton PC derived from
--      the user-supplied VoiceFunction ('Harmonic.Interface.Tidal.Groove.fund' or 'Harmonic.Interface.Tidal.Arranger.root'). Octave placement
--      is greedy left-to-right by smoothness to the previous beat 1, with a
--      soft direction-persistence bias, a half-weight loop-closure pull on
--      the final bar, and a root-fifth alternation option inside runs of
--      consecutive identical chords. Bar 0 anchors at the register centre.
--   2. Pass 2 — beat 3s. Per bar, choose from a tiered pool minimising
--      smoothness to b1_i plus smoothness to b1_{i+1} plus consonance-to-
--      fund cost (via @beat3ConsTable@) plus a tier surcharge: a target
--      tone is free, a non-target anchor, a favourable passing tone and a
--      bare palette tone cost progressively more, and avoid tones are not
--      in the pool at all. Unison repeats carry a dedicated penalty so a
--      non-repeat chord tone wins when nearby. Symmetric chords
--      (dim \/ aug \/ dim7 \/ whole-tone) bypass the consonance term since no
--      chord tone is privileged in a rotation-invariant shape.
--   3. Pass 3 — beats 2 and 4. Per beat, choose from a (cyclic) local-scale
--      pool. Connector heuristics favour chord tones adjacent to the next
--      beat 1, penalise copying the next beat 1 outright on beat 4, reward
--      chromatic approaches to the next beat 1 regardless of scale\/chord
--      membership (so root-as-leading-tone can win), resolve static
--      (b1==b3) bars via the chord's P5 or — on symmetric chords — any
--      non-root chord tone, and reward root-on-b4 (full weight) or P5-on-b4
--      (half weight) when that tone sits 1–2 semitones from the next b1.
--      If b3 already used the root \/ P5 at tone distance, the approach
--      bonus shifts to the chromatic in-between tone so the line avoids a
--      b3→b4 unison. Stranded connectors (neither flank within a whole
--      step) pay a sandwich penalty; quality-defining chord tones are
--      reserved for strong beats (only root\/P5 earn the beat-4 chord-tone
--      bonus).
--
-- The entropy parameter that used to be user-facing is now derived from the
-- progression's root-motion angularity and chord-internal dissonance. Calm
-- diatonic progressions land near 0 (more settled repeats allowed); angular
-- tritone-heavy progressions land near 1 (fewer repeats, more chromatic
-- motion). Progression-level consonance ('progConsonance') independently
-- scales strong-beat strictness and connector tension licence. Pure-function
-- guarantees are preserved: same progression and voiceFn always produce the
-- same line.
--
-- Three family variants share these passes, differing only in what they
-- feed them: 'walkLine' walks the plain per-bar tone sets at whatever
-- cardinality each bar carries ('Harmonic.Framework.Builder.gen' and
-- 'Harmonic.Framework.Builder.genE'), 'walkLineP' narrows the pools to the
-- octatripentatonic strata ('Harmonic.Framework.Builder.genP'), and
-- 'walkLineJ' reads each bar through a
-- 'Harmonic.Rules.Import.Jazz.BassVocab' derived from its chord symbol
-- ('Harmonic.Framework.Builder.genJ'). Each has a @Dyn@ twin taking a
-- per-bar dynamics vector. Callers normally reach them through
-- 'Harmonic.Interface.Tidal.LineHarmony.lineHarmony', which dispatches on
-- the progression's family.

module Harmonic.Traversal.WalkingBass
  ( -- * Main entry
    walkLine
  , walkLineP
  , walkLineJ
  , walkLineDyn
  , walkLinePDyn
  , walkLineJDyn
  , ChromaSources(..)

    -- * Derived entropy (exported for tests \/ diagnostics)
  , progressionEntropy
  , progConsonance

    -- * Utilities (exported for tests)
  , hashProgEntropy
  , closestLowMidi
  , closestMidMidi
  , lowestMidi
  , highestMidi
  , beatsPerBar
  , isSymmetricChord
  ) where

import qualified Data.Vector as V
import qualified Data.Set as Set
import Data.Set (Set)
import Data.List (minimumBy)
import Data.Function (on)
import Data.Bits (xor)
import Data.Foldable (toList)
import Data.Word (Word64)
import GHC.Float (castDoubleToWord64)
import System.Random (StdGen, mkStdGen, random)

import qualified Harmonic.Rules.Types.Pitch as Pt
import qualified Harmonic.Rules.Types.Harmony as Hm
import qualified Harmonic.Rules.Types.Progression as Pr
import Harmonic.Evaluation.Scoring.Dissonance (rootMotionScore, dissonanceScore)
import Harmonic.Evaluation.Analysis.KeyArea (barPalettes)
import Harmonic.Interface.Tidal.Bridge (VoiceFunction)
import qualified Harmonic.Rules.Import.Jazz as J

-------------------------------------------------------------------------------
-- Constants
-------------------------------------------------------------------------------

-- | Walking-bass register and metre constants. @lowestMidi@ 28 and
-- @highestMidi@ 48 bound the line to a double-bass register; @beatsPerBar@ is
-- 4 (the walking idiom is quarter-note based); @registerCenter@ 38 is the pitch
-- the line is drawn back toward when free to choose.
lowestMidi, highestMidi, beatsPerBar, registerCenter :: Int
lowestMidi :: Int
lowestMidi     = Int
28
highestMidi :: Int
highestMidi    = Int
48
beatsPerBar :: Int
beatsPerBar    = Int
4
registerCenter :: Int
registerCenter = Int
38

-- | Pass 3 repeat-gate costs (unchanged from v3).
kappaStaticBase, kappaStaticBlocked :: Int
kappaStaticBase :: Int
kappaStaticBase    = Int
3
kappaStaticBlocked :: Int
kappaStaticBlocked = Int
200

-- | Pass 3 scale-fit and chromatic-approach weights.
kappaChromatic, kappaChromaticBonus, kappaChromaticBonusBeat4 :: Int
kappaChromatic :: Int
kappaChromatic           = Int
8
kappaChromaticBonus :: Int
kappaChromaticBonus      = Int
5
kappaChromaticBonusBeat4 :: Int
kappaChromaticBonusBeat4 = Int
10

-- | Pass 2 beat-3 consonance multiplier over @beat3ConsTable@. Calibrated so
-- an adjacent 3rd overcomes a P5 whose combined smoothness cost is more than
-- ~6 semitones worse, while 7ths and tension tones stay reachable only when
-- the consonant options all demand large leaps.
kappaB3Consonance :: Int
kappaB3Consonance :: Int
kappaB3Consonance = Int
2

-- | Beat-3 anchor cost by interval above the bar's fundamental. The strong
-- beat wants the chord's most grounding tones: P5 first, then root\/octave,
-- then the quality-defining 3rds; 7ths and colour tones cost enough that
-- they surface mainly when register pressure or an imminent chord change
-- leaves no cheap consonant option.
beat3ConsTable :: Int -> Int
beat3ConsTable :: Int -> Int
beat3ConsTable Int
iv = case Int
iv Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12 of
  Int
7             -> Int
0    -- perfect fifth
  Int
0             -> Int
2    -- root / octave
  Int
3             -> Int
3    -- minor third
  Int
4             -> Int
3    -- major third
  Int
5             -> Int
5    -- fourth / eleventh
  Int
10            -> Int
6    -- minor seventh
  Int
11            -> Int
6    -- major seventh
  Int
6             -> Int
12   -- tritone
  Int
_             -> Int
9    -- seconds and sixths

-- | Pass 2 repeat penalty. Strong enough that a unison b1=b3 repeat loses to
-- the P5 (or another consonant chord tone) whenever one sits within a fifth,
-- keeping static-harmony bars in motion.
kappaPassiveRepeat :: Int
kappaPassiveRepeat :: Int
kappaPassiveRepeat = Int
9

-- | Pass 3 connector enrichment weights (new in iteration 4).
kappaDiatonicApproach, kappaChordToneBonus, kappaCopyNext, kappaStaticRecovery :: Int
kappaDiatonicApproach :: Int
kappaDiatonicApproach = Int
3   -- whole-step in-scale approach to target
kappaChordToneBonus :: Int
kappaChordToneBonus   = Int
7   -- chord tone within 2 semitones of next beat 1 (beat 4 only)
kappaCopyNext :: Int
kappaCopyNext         = Int
15  -- beat 4 MIDI equals next bar's beat 1 MIDI
kappaStaticRecovery :: Int
kappaStaticRecovery   = Int
10  -- P5 of bar's fundamental when b1==b3 this bar

-- | Pass 3 approach bonus (iteration 6). Full strength for root, half for P5.
-- Fires on beat 4 when the target PC is 1–2 semitones from next b1, or when
-- b3 already used the target and m is the chromatic in-between. Calibrated
-- (32) to overcome squared-smoothness overshoot when the root sits 5 above
-- b3 at tone distance from next b1 (desc-tone middle bars).
kappaRootApproach :: Int
kappaRootApproach :: Int
kappaRootApproach = Int
32

-- | Pass 1 dynamics-arc weight (in the doubled scoring units of
-- 'pass1Beat1s'). Per-bar dynamic levels are mean-centred over the walked
-- period: bars quieter than the piece's own mean bias the beat-1 contour
-- UPWARD, louder bars DOWNWARD, with penalty up to this weight on
-- opposing candidates at the dynamic extremes. Mean-centring makes a
-- constant dynamic exactly neutral, so the coupling shapes contour against
-- a piece's swell without dragging a flat-dynamic line anywhere. A bar
-- whose level falls 0.25+ below its predecessor instead RESETS beat 1 to
-- the lowest register instance (the line falls with the drop).
kappaDynArc :: Int
kappaDynArc :: Int
kappaDynArc = Int
4

-- | Pass 1 direction-persistence bonus (in the doubled scoring units of
-- 'pass1Beat1s'). A candidate continuing the previous beat-1 step's
-- direction by a step-or-third earns this small discount, so the beat-1
-- contour tends to run in lines rather than oscillate — while never
-- overriding a nearest candidate that is more than a third closer.
kappaB1Direction :: Int
kappaB1Direction :: Int
kappaB1Direction = Int
2

-- | Pass 3 sandwich penalty: a connector with NEITHER flanking strong beat
-- within a whole step is a stranded tone; it pays this on top of its
-- smoothness cost. Willis's sandwich rule as a strong preference rather
-- than a hard constraint. Chord tones are exempt — a tone of the sounding
-- chord is never stranded.
kappaSandwich :: Int
kappaSandwich :: Int
kappaSandwich = Int
4

-- | Pass 3 beat-2 chord-tone bonus. Beat 2 prefers the bar's own chord
-- tones (the quality-defining 3rd especially) over scale or approach
-- tones, keeping the first half of the bar inside the sounding harmony.
kappaB2ChordTone :: Int
kappaB2ChordTone :: Int
kappaB2ChordTone = Int
5

-- | Pass 3 dominant-fall bonus: on beat 4, the bar's ROOT when the next
-- bar's root lies a fourth above (dominant relation) — the classic V-I
-- fourth-fall approach, rewarded at close to the chromatic root-approach
-- weight so it can overcome the squared-smoothness cost of the leap.
kappaDominantFall :: Int
kappaDominantFall :: Int
kappaDominantFall = Int
30

-- | Pass 2 anticipation penalty: beat 3 landing on exactly the next bar's
-- beat-1 MIDI robs the arrival; discouraged, not banned.
kappaB3Anticipate :: Int
kappaB3Anticipate :: Int
kappaB3Anticipate = Int
3

-- | Pass 3 fourth-chain bonus. A connector that is a CHORD TONE a perfect
-- fourth\/fifth from its left flank, and that resolves onward (by step,
-- chromatic, or another fourth), traces a cycle-of-fifths route to the
-- target. Tie-breaker weight only: squared smoothness prices the fourth
-- leap at 25+, so this decides between near-equal candidates but never
-- drives one. Full chains through beats 2-3-4 need beat 3 to participate,
-- which the pass ordering forbids — that belongs to a future bar-shape
-- (lane) pass.
kappaFourthChain :: Int
kappaFourthChain :: Int
kappaFourthChain = Int
4

-- | Pass 3 mid-phrase damping. The beat-4 repeat-push (beat 4 repeating
-- beat 3, typically a doubled leading tone) is maximal tension: favoured
-- into a 4-bar phrase top, surcharged mid-phrase where it would make an
-- interior bar feel like a phrase start. The 4-bar grid anchors at the
-- (performed) progression's bar 0.
kappaPhraseMid :: Int
kappaPhraseMid :: Int
kappaPhraseMid = Int
6

-- | Pass 2 passing-tone surcharge: the middle beat-3 tier for tones a
-- quality's bass vocabulary marks as favourable passing material (the 9,
-- the 11 over minor and 13th chords) — cheaper than a bare key-area
-- tone, dearer than a strong anchor.
kappaB3Passing :: Int
kappaB3Passing :: Int
kappaB3Passing = Int
4

-- | Pass 2 non-target surcharge: a chord's seventh (or sixth) is legal on
-- a strong beat but is not what a line aims AT — the triadic core is.
-- Small, so it breaks ties toward the triad without overriding the
-- interval-quality ranking of 'beat3ConsTable'.
kappaB3NonTarget :: Int
kappaB3NonTarget :: Int
kappaB3NonTarget = Int
2

-- | Pass 2 non-chord surcharge. Beat 3's pool admits key-area tones
-- (the bar's stratum in the genP path) beyond the chord tones, but they
-- pay this on top of their @beat3ConsTable@ cost — surfacing only where
-- every consonant chord tone would force a leap or an anticipation.
kappaB3NonChord :: Int
kappaB3NonChord :: Int
kappaB3NonChord = Int
8

-- | Pass 1 duplicate-run weights. Within a run of consecutive identical
-- chords, an odd occurrence's beat 1 admits the fundamental's P5 as a soft
-- alternative: repeating the previous beat-1 MIDI pays 'kappaB1DupRepeat',
-- a P5 candidate pays 'kappaB1P5Option'. Calibrated so a P5 within a fifth
-- of the previous beat 1 wins (runs walk root-fifth-root-fifth) while a P5
-- only reachable by upward leap loses to the held root.
kappaB1DupRepeat, kappaB1P5Option :: Int
kappaB1DupRepeat :: Int
kappaB1DupRepeat = Int
10
kappaB1P5Option :: Int
kappaB1P5Option  = Int
2

-- | Pass 3 Minor Thirds Rule bonus. A minor-third gap between a connector's
-- flanks admits exactly two passing tones: the key-area scale tone
-- (strata tone in the genP path) earns the full bonus; the chromatic one an
-- entropy-scaled fraction, so low-entropy material prefers the diatonic fill
-- and high-entropy material may take the chromatic. A major-third gap
-- prefers its balanced whole-step passing tone at full bonus.
kappaMinorThird :: Int
kappaMinorThird :: Int
kappaMinorThird = Int
4

-- | Pass 3 octatripentatonic tier weights ('walkLineP' only).
-- Strata candidates win the tier-fit term (most preferred), overlap is
-- neutral (matching legacy in-scale fit cost = 0), mode is a mild penalty
-- above neutral but still admissible (plays the role chromatic plays in
-- 'walkLine'). Calibrated so smoothness can override a tier-mismatch on
-- adjacent candidates, but a strata pick wins over an equally-smooth
-- overlap pick, and overlap wins over an equally-smooth mode pick.
kappaStrataPref, kappaModePenalty :: Int
kappaStrataPref :: Int
kappaStrataPref  = Int
4   -- bonus (subtracted)
kappaModePenalty :: Int
kappaModePenalty = Int
6   -- penalty (added)

-------------------------------------------------------------------------------
-- Seed derivation
-------------------------------------------------------------------------------

-- | Deterministic mixing of progression shape and entropy into a seed.
hashProgEntropy :: Pr.Progression -> Double -> Int
hashProgEntropy :: Progression -> Double -> Int
hashProgEntropy Progression
prog Double
e = Int
progHash Int -> Int -> Int
forall a. Bits a => a -> a -> a
`xor` Int
entropyHash
  where
    css :: [CadenceState]
css       = Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Pr.unProgression Progression
prog)
    progHash :: Int
progHash  = (Int -> CadenceState -> Int) -> Int -> [CadenceState] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Int -> CadenceState -> Int
step Int
0 [CadenceState]
css
    step :: Int -> CadenceState -> Int
step Int
h CadenceState
cs =
      let r :: Int
r   = PitchClass -> Int
Pt.unPitchClass (NoteName -> PitchClass
Pt.pitchClass (CadenceState -> NoteName
Hm.stateCadenceRoot CadenceState
cs))
          ivs :: Int
ivs = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
Pt.unPitchClass (Cadence -> [PitchClass]
Hm.cadenceIntervals (CadenceState -> Cadence
Hm.stateCadence CadenceState
cs)))
      in Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
31 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
13 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ivs
    entropyHash :: Int
entropyHash =
      let w :: Word64
w = Double -> Word64
castDoubleToWord64 Double
e :: Word64
      in Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
w Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` (Word64
w Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
4294967296))

-------------------------------------------------------------------------------
-- Per-bar metadata
-------------------------------------------------------------------------------

rootPCInt :: Hm.CadenceState -> Int
rootPCInt :: CadenceState -> Int
rootPCInt = PitchClass -> Int
Pt.unPitchClass (PitchClass -> Int)
-> (CadenceState -> PitchClass) -> CadenceState -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteName -> PitchClass
Pt.pitchClass (NoteName -> PitchClass)
-> (CadenceState -> NoteName) -> CadenceState -> PitchClass
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CadenceState -> NoteName
Hm.stateCadenceRoot

chordPCs :: Hm.CadenceState -> Set Int
chordPCs :: CadenceState -> Set Int
chordPCs CadenceState
cs =
  let r :: Int
r   = CadenceState -> Int
rootPCInt CadenceState
cs
      ivs :: [Int]
ivs = (PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
Pt.unPitchClass (Cadence -> [PitchClass]
Hm.cadenceIntervals (CadenceState -> Cadence
Hm.stateCadence CadenceState
cs))
  in [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList [ (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
iv) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12 | Int
iv <- [Int]
ivs ]

-- | True iff the chord contains no perfect-fourth\/fifth (5 or 7 semitones)
-- between any pair of tones. Covers diminished triads ([0,3,6]), augmented
-- triads ([0,4,8]), diminished sevenths ([0,3,6,9]), and whole-tone
-- hexachords — synthetic shapes with no privileged fifth, where every chord
-- tone is equally anchor-worthy.
isSymmetricChord :: Set Int -> Bool
isSymmetricChord :: Set Int -> Bool
isSymmetricChord Set Int
s =
  Set Int -> Int
forall a. Set a -> Int
Set.size Set Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3 Bool -> Bool -> Bool
&&
  ((Int, Int) -> Bool) -> [(Int, Int)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Int
a, Int
b) -> let d :: Int
d = Int -> Int
forall a. Num a => a -> a
abs (Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
b) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
                  in Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
5 Bool -> Bool -> Bool
&& Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
7)
      [ (Int
a, Int
b) | Int
a <- Set Int -> [Int]
forall a. Set a -> [a]
Set.toList Set Int
s, Int
b <- Set Int -> [Int]
forall a. Set a -> [a]
Set.toList Set Int
s, Int
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
b ]

-- | The fifth a bar actually walks, as an absolute pitch class.
--
-- Every fifth-driven term — the beat-1 alternation inside duplicate-chord
-- runs, the static-cell recovery, the half-weight approach bonus, the
-- beat-3 role pricing — needs the fifth the CHORD has, not the fifth its
-- root would imply. A diminished bar's fifth is its b5, an augmented
-- bar's its #5; reaching for the natural fifth there sounds a semitone
-- against a tone the chord is sounding. 'J.bassVocabFor' reads that from
-- the tone set (and restores a natural fifth where a quality implies one
-- its voicing omits), so the three walk variants share one rule.
chordFifthPC :: Hm.CadenceState -> Int
chordFifthPC :: CadenceState -> Int
chordFifthPC CadenceState
cs =
  let absPCs :: [Int]
absPCs = Set Int -> [Int]
forall a. Set a -> [a]
Set.toList (CadenceState -> Set Int
chordPCs CadenceState
cs)
      -- Read the quality from ROOT POSITION: 'fromCadenceState' runs
      -- inversion detection, so a first-inversion major triad is asked
      -- about as a major triad rather than as a #5 chord built on its
      -- own third.
      hRoot :: Int
hRoot  = PitchClass -> Int
Pt.unPitchClass
                 (NoteName -> PitchClass
Pt.pitchClass (Chord -> NoteName
Hm.chordNoteName (CadenceState -> Chord
Hm.fromCadenceState CadenceState
cs)))
      ivs :: [Int]
ivs    = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
pc -> (Int
pc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
hRoot) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) [Int]
absPCs
  in (Int
hRoot Int -> Int -> Int
forall a. Num a => a -> a -> a
+ BassVocab -> Int
J.bvFifth ([Int] -> BassVocab
J.bassVocabFor [Int]
ivs)) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12

-- | Cyclic union of the previous, current, and next bar's chord-PC sets.
-- Loop-closure consistent: bar 0's prev is bar n-1; bar n-1's next is bar 0.
localScale :: V.Vector (Set Int) -> Int -> Set Int
localScale :: Vector (Set Int) -> Int -> Set Int
localScale Vector (Set Int)
chordPCsV Int
i =
  let n :: Int
n    = Vector (Set Int) -> Int
forall a. Vector a -> Int
V.length Vector (Set Int)
chordPCsV
      prev :: Set Int
prev = Vector (Set Int)
chordPCsV Vector (Set Int) -> Int -> Set Int
forall a. Vector a -> Int -> a
V.! ((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
n)
      curr :: Set Int
curr = Vector (Set Int)
chordPCsV Vector (Set Int) -> Int -> Set Int
forall a. Vector a -> Int -> a
V.!  Int
i
      next :: Set Int
next = Vector (Set Int)
chordPCsV Vector (Set Int) -> Int -> Set Int
forall a. Vector a -> Int -> a
V.! ((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
n)
  in Set Int
prev Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Int
curr Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Int
next

-- | Lowest MIDI in [lowestMidi, highestMidi] whose pitch class equals @pc@.
-- Always in range: the register spans more than an octave, so the lowest
-- PC-matching value sits at most 11 semitones above 'lowestMidi'.
closestLowMidi :: Int -> Int
closestLowMidi :: Int -> Int
closestLowMidi Int
pc =
  let pc' :: Int
pc' = Int
pc Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
  in Int
lowestMidi Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ((Int
pc' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lowestMidi) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12)

-- | In-register instance of a pitch class nearest @registerCenter@ (lower on tie).
-- Anchoring bar 0 here gives the greedy beat-1 chain headroom in both
-- directions and evens out the single-instance asymmetry of the PCs that
-- occur only once in the register.
closestMidMidi :: Int -> Int
closestMidMidi :: Int -> Int
closestMidMidi Int
pc =
  let lo :: Int
lo    = Int -> Int
closestLowMidi Int
pc
      cands :: [Int]
cands = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
highestMidi) [Int
lo, Int
lo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
12 ..]
  in (Int -> Int -> Ordering) -> [Int] -> Int
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy
       (\Int
a Int
b -> (Int, Int) -> (Int, Int) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int
forall a. Num a => a -> a
abs (Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
registerCenter), Int
a)
                        (Int -> Int
forall a. Num a => a -> a
abs (Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
registerCenter), Int
b))
       [Int]
cands

-- | All MIDI values in the register whose pitch class is in the given set.
midisIn :: Set Int -> V.Vector Int
midisIn :: Set Int -> Vector Int
midisIn Set Int
s =
  [Int] -> Vector Int
forall a. [a] -> Vector a
V.fromList [ Int
m | Int
m <- [Int
lowestMidi..Int
highestMidi], (Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
s ]

-------------------------------------------------------------------------------
-- Derived entropy
-------------------------------------------------------------------------------

-- | Entropy derived from the progression's harmonic character. Calm diatonic
-- progressions land near 0; angular \/ tritone-heavy progressions approach 1.
-- Deterministic: same progression always yields the same value.
progressionEntropy :: Pr.Progression -> Double
progressionEntropy :: Progression -> Double
progressionEntropy Progression
prog
  | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0    = Double
0.0
  | Bool
otherwise = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0 (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
1 (Double
base Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
jitter))
  where
    bars :: Vector CadenceState
bars     = [CadenceState] -> Vector CadenceState
forall a. [a] -> Vector a
V.fromList (Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Pr.unProgression Progression
prog))
    n :: Int
n        = Vector CadenceState -> Int
forall a. Vector a -> Int
V.length Vector CadenceState
bars

    -- Root-motion angularity: mean rootMotionScore across cyclic transitions.
    -- rootMotionScore range is [1, 6]; normalise to [0, 1].
    rootPCs :: Vector Int
rootPCs  = (CadenceState -> Int) -> Vector CadenceState -> Vector Int
forall a b. (a -> b) -> Vector a -> Vector b
V.map CadenceState -> Int
rootPCInt Vector CadenceState
bars
    motions :: [Integer]
motions  = [ Int -> Integer
rootMotionScore
                   ((Vector Int
rootPCs Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! ((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
n) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Vector Int
rootPCs Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12)
               | Int
i <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ]
    meanMot :: Double
meanMot  = Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer]
motions) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n :: Double
    normMot :: Double
normMot  = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0 (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
1 ((Double
meanMot Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
1) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
5))

    -- Chord-internal dissonance: mean dissonanceScore over bars. Major and
    -- minor triads score 6; every seventh chord scores 19+ and saturates the
    -- /20 cap, so on all-tetrad progressions this term is a near-constant
    -- offset and root-motion angularity dominates the derived entropy.
    chordDiss :: [Double]
chordDiss = [ Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Int] -> Integer
dissonanceScore
                    (CadenceState -> Int
rootPCInt CadenceState
cs
                      Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [ (CadenceState -> Int
rootPCInt CadenceState
cs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
iv) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
                        | Int
iv <- (PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
Pt.unPitchClass
                                  (Cadence -> [PitchClass]
Hm.cadenceIntervals (CadenceState -> Cadence
Hm.stateCadence CadenceState
cs)) ]))
                | CadenceState
cs <- Vector CadenceState -> [CadenceState]
forall a. Vector a -> [a]
V.toList Vector CadenceState
bars ] :: [Double]
    meanDiss :: Double
meanDiss  = [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Double]
chordDiss Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
    normDiss :: Double
normDiss  = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
1.0 (Double
meanDiss Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
20.0)

    base :: Double
base      = Double
0.70 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
normMot Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
0.30 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
normDiss
    jitter :: Double
jitter    = (Int -> Int -> Double
seededUniform (Progression -> Double -> Int
hashProgEntropy Progression
prog Double
0) Int
0 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
0.5) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
0.1

-- | Mean per-bar consonance of the progression in [0, 1], 1 = consonant.
-- 'dissonanceScore' grows with chord cardinality (major\/minor triads score
-- 6 while the most consonant tetrads score 19), so each bar is normalised
-- against anchors for its own chord size before averaging — otherwise every
-- tetrad progression would read as maximally dissonant. Consumed by the
-- walk to scale strong-beat strictness and connector tension licence;
-- orthogonal to 'progressionEntropy', which is dominated by root motion.
progConsonance :: Pr.Progression -> Double
progConsonance :: Progression -> Double
progConsonance Progression
prog
  | [CadenceState] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CadenceState]
css  = Double
1.0
  | Bool
otherwise = [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Double]
barVals Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
barVals)
  where
    css :: [CadenceState]
css     = Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Pr.unProgression Progression
prog)
    barVals :: [Double]
barVals = (CadenceState -> Double) -> [CadenceState] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map CadenceState -> Double
barCons [CadenceState]
css
    -- Score the root-position interval set (root at 0), not absolute PCs:
    -- 'dissonanceScore' privileges a perfect fifth above its lowest tone,
    -- so an absolute-PC set would score the same chord differently
    -- depending on which pitch class happens to sort lowest.
    barCons :: CadenceState -> Double
barCons CadenceState
c =
      let pcs :: [Int]
pcs = Set Int -> [Int]
forall a. Set a -> [a]
Set.toList ([Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList
                  [ PitchClass -> Int
Pt.unPitchClass PitchClass
iv Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
                  | PitchClass
iv <- Cadence -> [PitchClass]
Hm.cadenceIntervals (CadenceState -> Cadence
Hm.stateCadence CadenceState
c) ])
          d :: Double
d   = Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Int] -> Integer
dissonanceScore [Int]
pcs) :: Double
      -- Anchors per cardinality from observed landmarks: triads 6..32,
      -- tetrads 19..55; 5-6 tone sets calibrated on the jazz corpus
      -- census (frequency-weighted dissonanceScore over the quality
      -- table: mellowest pentads 37, weighted mean ~72, crunch ~122) so
      -- everyday extended harmony spreads across the whole band instead
      -- of saturating.
      in case [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
pcs of
           Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
2    -> Double
1.0
             | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3    -> Double -> Double
clamp01 (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double
d Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
6)  Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
26)
             | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4    -> Double -> Double
clamp01 (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double
d Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
19) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
36)
             | Bool
otherwise -> Double -> Double
clamp01 (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double
d Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
37) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
85)
    clamp01 :: Double -> Double
clamp01 = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0 (Double -> Double) -> (Double -> Double) -> Double -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
1

-------------------------------------------------------------------------------
-- Regional key inference (retired)
-------------------------------------------------------------------------------

-- The vote-window key detector ('inferKeyCentre') and its palette reader
-- ('paletteSetsFor') retired in favour of the whole-progression key-area
-- analysis in "Harmonic.Evaluation.Analysis.KeyArea" ('barPalettes') —
-- one detector now feeds the walk's palettes AND the chordscale S/M
-- layers, so the bass walks the same sets the layers display. The Markov
-- boundary is unchanged: the analysis is a pure, derived quantity over a
-- finished progression and never feeds back into generation.

-------------------------------------------------------------------------------
-- Pass 1 — Beat 1s (skeleton)
-------------------------------------------------------------------------------

-- | Extract per-bar beat-1 PC from the supplied voice function. Falls back
-- to the cadence-state root PC if the voice function returns [] for a bar.
beat1PCs :: VoiceFunction -> Pr.Progression -> V.Vector Int
beat1PCs :: VoiceFunction -> Progression -> Vector Int
beat1PCs VoiceFunction
voiceFn Progression
prog =
  let voicings :: [[Int]]
voicings = VoiceFunction
voiceFn Progression
prog
      barsL :: [CadenceState]
barsL    = Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Pr.unProgression Progression
prog)
      n :: Int
n        = [CadenceState] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CadenceState]
barsL
      pcAt :: Int -> Int
pcAt Int
i   =
        let cs :: CadenceState
cs = [CadenceState]
barsL [CadenceState] -> Int -> CadenceState
forall a. HasCallStack => [a] -> Int -> a
!! Int
i
        in if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
voicings
           then case [[Int]]
voicings [[Int]] -> Int -> [Int]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i of
                  []    -> CadenceState -> Int
rootPCInt CadenceState
cs
                  (Int
x:[Int]
_) -> Int
x Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
           else CadenceState -> Int
rootPCInt CadenceState
cs
  in [Int] -> Vector Int
forall a. [a] -> Vector a
V.fromList [ Int -> Int
pcAt Int
i | Int
i <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ]

-- | Occurrence parity within runs of consecutive identical bars: True for
-- the 2nd, 4th, ... bar of a run of equal 'Harmonic.Rules.Types.Harmony.CadenceState's, False elsewhere.
-- Detection is acyclic (bar 0 always starts a run) so the loop wrap never
-- flips a line's opening beat 1.
dupOddFlags :: V.Vector Hm.CadenceState -> V.Vector Bool
dupOddFlags :: Vector CadenceState -> Vector Bool
dupOddFlags Vector CadenceState
barsV = [Bool] -> Vector Bool
forall a. [a] -> Vector a
V.fromList ((Integer -> Bool) -> [Integer] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Bool
forall a. Integral a => a -> Bool
odd (Maybe (CadenceState, Integer) -> [CadenceState] -> [Integer]
forall {a} {b}. (Eq a, Num b) => Maybe (a, b) -> [a] -> [b]
go Maybe (CadenceState, Integer)
forall a. Maybe a
Nothing (Vector CadenceState -> [CadenceState]
forall a. Vector a -> [a]
V.toList Vector CadenceState
barsV) :: [Integer]))
  where
    go :: Maybe (a, b) -> [a] -> [b]
go Maybe (a, b)
_ [] = []
    go Maybe (a, b)
mPrev (a
c:[a]
cs') =
      let k :: b
k = case Maybe (a, b)
mPrev of
                Just (a
p, b
kPrev) | a
p a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
c -> b
kPrev b -> b -> b
forall a. Num a => a -> a -> a
+ b
1
                Maybe (a, b)
_                        -> b
0
      in b
k b -> [b] -> [b]
forall a. a -> [a] -> [a]
: Maybe (a, b) -> [a] -> [b]
go ((a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (a
c, b
k)) [a]
cs'

-- | Place each bar's beat 1. Bar 0 anchors on the register-centre instance
-- of its PC; later bars pick greedily by closeness to the previous beat 1
-- (lower MIDI on tie). Scores are in half-semitone units so the final bar
-- can add a half-weight pull toward bar 0's beat 1, closing the register
-- loop instead of leaving the whole drift to the last seam. Odd occurrences
-- within duplicate runs admit the fundamental's P5 as a soft alternative
-- (see 'kappaB1DupRepeat' \/ 'kappaB1P5Option').
pass1Beat1s
  :: V.Vector Double   -- mean-centred dynamic bias per bar (0 = neutral)
  -> V.Vector Bool     -- dynamic drop-reset flags per bar
  -> V.Vector Int -> V.Vector Int -> V.Vector Bool -> V.Vector Int
pass1Beat1s :: Vector Double
-> Vector Bool
-> Vector Int
-> Vector Int
-> Vector Bool
-> Vector Int
pass1Beat1s Vector Double
biasV Vector Bool
dropV Vector Int
pcs Vector Int
p5pcs Vector Bool
dupOdd
  | Vector Int -> Bool
forall a. Vector a -> Bool
V.null Vector Int
pcs = Vector Int
forall a. Vector a
V.empty
  | Bool
otherwise  =
      let n :: Int
n  = Vector Int -> Int
forall a. Vector a -> Int
V.length Vector Int
pcs
          b0 :: Int
b0 = Int -> Int
closestMidMidi (Vector Int
pcs Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
0)
          candidates :: Int -> [(Int, Bool)]
candidates Int
i =
            let roots :: [(Int, Bool)]
roots = [ (Int
m, Bool
False)
                        | Int
m <- Vector Int -> [Int]
forall a. Vector a -> [a]
V.toList (Set Int -> Vector Int
midisIn (Int -> Set Int
forall a. a -> Set a
Set.singleton (Vector Int
pcs Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i))) ]
                p5s :: [(Int, Bool)]
p5s   = if Vector Bool
dupOdd Vector Bool -> Int -> Bool
forall a. Vector a -> Int -> a
V.! Int
i
                        then [ (Int
m, Bool
True)
                             | Int
m <- Vector Int -> [Int]
forall a. Vector a -> [a]
V.toList (Set Int -> Vector Int
midisIn (Int -> Set Int
forall a. a -> Set a
Set.singleton (Vector Int
p5pcs Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i))) ]
                        else []
            in [(Int, Bool)]
roots [(Int, Bool)] -> [(Int, Bool)] -> [(Int, Bool)]
forall a. [a] -> [a] -> [a]
++ [(Int, Bool)]
p5s
          go :: Int -> Int -> Int -> [Int]
go Int
i Int
prev Int
prevStep
            | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n    = []
            | Vector Bool
dropV Vector Bool -> Int -> Bool
forall a. Vector a -> Int -> a
V.! Int
i =
                -- Sudden dynamic drop: the line falls with it, resetting
                -- to the lowest viable instance of the bar's PC.
                let pick :: Int
pick = Int -> Int
closestLowMidi (Vector Int
pcs Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i)
                in Int
pick Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Int -> Int -> Int -> [Int]
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
pick (Int
pick Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
prev)
            | Bool
otherwise =
                let closure :: Int -> Int
closure Int
m = if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 then Int -> Int
forall a. Num a => a -> a
abs (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
b0) else Int
0
                    continues :: Int -> Bool
continues Int
m =
                      let step :: Int
step = Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
prev
                      in Int
prevStep Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 Bool -> Bool -> Bool
&& Int
step Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 Bool -> Bool -> Bool
&& Int -> Int
forall a. Num a => a -> a
abs Int
step Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
4
                         Bool -> Bool -> Bool
&& Int -> Int
forall a. Num a => a -> a
signum Int
step Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Int
forall a. Num a => a -> a
signum Int
prevStep
                    arcPen :: Int -> b
arcPen Int
m =
                      let step :: Int
step = Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
prev
                          b :: Double
b    = Vector Double
biasV Vector Double -> Int -> Double
forall a. Vector a -> Int -> a
V.! Int
i
                      in if Int
step Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 Bool -> Bool -> Bool
&& Double
b Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
0
                            Bool -> Bool -> Bool
&& Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int
forall a. Num a => a -> a
signum Int
step) Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double -> Double
forall a. Num a => a -> a
negate (Double -> Double
forall a. Num a => a -> a
signum Double
b)
                         then Double -> b
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
kappaDynArc Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Num a => a -> a
abs Double
b)
                         else b
0
                    score :: (Int, Bool) -> Int
score (Int
m, Bool
isP5) =
                      Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int -> Int
forall a. Num a => a -> a
abs (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
prev)
                      Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int
closure Int
m
                      Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int
forall {b}. Integral b => Int -> b
arcPen Int
m
                      Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (if Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
prev Bool -> Bool -> Bool
&& Vector Bool
dupOdd Vector Bool -> Int -> Bool
forall a. Vector a -> Int -> a
V.! Int
i
                         then Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
kappaB1DupRepeat else Int
0)
                      Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (if Bool
isP5 then Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
kappaB1P5Option else Int
0)
                      Int -> Int -> Int
forall a. Num a => a -> a -> a
- (if Int -> Bool
continues Int
m then Int
kappaB1Direction else Int
0)
                    pick :: Int
pick = (Int, Bool) -> Int
forall a b. (a, b) -> a
fst (((Int, Bool) -> (Int, Bool) -> Ordering)
-> [(Int, Bool)] -> (Int, Bool)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy
                                 (\(Int, Bool)
a (Int, Bool)
b -> (Int, Int) -> (Int, Int) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((Int, Bool) -> Int
score (Int, Bool)
a, (Int, Bool) -> Int
forall a b. (a, b) -> a
fst (Int, Bool)
a)
                                                  ((Int, Bool) -> Int
score (Int, Bool)
b, (Int, Bool) -> Int
forall a b. (a, b) -> a
fst (Int, Bool)
b))
                                 (Int -> [(Int, Bool)]
candidates Int
i))
                in Int
pick Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Int -> Int -> Int -> [Int]
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
pick (Int
pick Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
prev)
      in [Int] -> Vector Int
forall a. [a] -> Vector a
V.fromList (Int
b0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Int -> Int -> Int -> [Int]
go Int
1 Int
b0 Int
0)

-- | Expand an optional per-bar dynamic vector into (mean-centred bias,
-- drop-reset flags), clamped and padded\/truncated to n bars. 'Nothing'
-- yields all-neutral vectors — the walk is then byte-identical to the
-- dynamics-blind behaviour.
dynVectors :: Int -> Maybe [Double] -> (V.Vector Double, V.Vector Bool)
dynVectors :: Int -> Maybe [Double] -> (Vector Double, Vector Bool)
dynVectors Int
n Maybe [Double]
Nothing = (Int -> Double -> Vector Double
forall a. Int -> a -> Vector a
V.replicate Int
n Double
0, Int -> Bool -> Vector Bool
forall a. Int -> a -> Vector a
V.replicate Int
n Bool
False)
dynVectors Int
n (Just [Double]
ds) =
  let lvls :: Vector Double
lvls  = [Double] -> Vector Double
forall a. [a] -> Vector a
V.fromList (Int -> [Double] -> [Double]
forall a. Int -> [a] -> [a]
take Int
n ([Double]
ds [Double] -> [Double] -> [Double]
forall a. [a] -> [a] -> [a]
++ Double -> [Double]
forall a. a -> [a]
repeat (if [Double] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Double]
ds then Double
0.5 else [Double] -> Double
forall a. HasCallStack => [a] -> a
last [Double]
ds)))
      mean :: Double
mean  = Vector Double -> Double
forall a. Num a => Vector a -> a
V.sum Vector Double
lvls Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Vector Double -> Int
forall a. Vector a -> Int
V.length Vector Double
lvls))
      clamp :: Double -> Double
clamp = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (-Double
0.5) (Double -> Double) -> (Double -> Double) -> Double -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
0.5
      biasV :: Vector Double
biasV = (Double -> Double) -> Vector Double -> Vector Double
forall a b. (a -> b) -> Vector a -> Vector b
V.map (\Double
lvl -> Double -> Double
clamp (Double
mean Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
lvl)) Vector Double
lvls
      dropV :: Vector Bool
dropV = Int -> (Int -> Bool) -> Vector Bool
forall a. Int -> (Int -> a) -> Vector a
V.generate Int
n (\Int
i ->
                Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Vector Double
lvls Vector Double -> Int -> Double
forall a. Vector a -> Int -> a
V.! Int
i Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Vector Double
lvls Vector Double -> Int -> Double
forall a. Vector a -> Int -> a
V.! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
0.25)
  in (Vector Double
biasV, Vector Bool
dropV)

-------------------------------------------------------------------------------
-- Pass 2 — Beat 3s (re-anchor)
-------------------------------------------------------------------------------

-- | Per-bar beat-3 tiering. The vectors are structurally identical, so
-- they travel as a record rather than six positional arguments the
-- compiler cannot tell apart.
data B3Tiers = B3Tiers
  { B3Tiers -> Vector (Set Int)
b3Target  :: V.Vector (Set Int)  -- ^ landing tones (no surcharge)
  , B3Tiers -> Vector (Set Int)
b3Strong  :: V.Vector (Set Int)  -- ^ legal anchors ('kappaB3NonTarget')
  , B3Tiers -> Vector (Set Int)
b3Passing :: V.Vector (Set Int)  -- ^ favourable passing ('kappaB3Passing')
  , B3Tiers -> Vector (Set Int)
b3Avoid   :: V.Vector (Set Int)  -- ^ excluded from the pool entirely
  , B3Tiers -> Vector (Set Int)
b3Palette :: V.Vector (Set Int)  -- ^ key-area palette ('kappaB3NonChord')
  , B3Tiers -> Vector Int
b3Fifth   :: V.Vector Int        -- ^ THE fifth's PC per bar, priced as a fifth
  }

-- | Per bar, pick the beat-3 MIDI minimising
--   (|m - b1_i| + |b1_{i+1} - m| + consonance-to-fund + repeat-penalty).
-- Linear (not quadratic) smoothness so moderate leaps to the P5 aren't
-- over-penalised. Consonance cost comes from @beat3ConsTable@ on the
-- interval above the fundamental, so the strong beat anchors on P5 \/ root \/
-- 3rds and reaches tension tones only under register pressure. The repeat
-- penalty ('kappaPassiveRepeat') is stronger than Pass 3's connector repeat
-- cost so a non-repeat chord tone wins when nearby. For symmetric chords
-- (dim \/ aug \/ dim7 \/ whole-tone) the consonance term is neutralised because
-- no chord tone is privileged over the others.
-- Four surcharge tiers, cheapest first: a target lands free, a non-target
-- anchor pays 'kappaB3NonTarget', a favourable passing tone
-- 'kappaB3Passing', anything else 'kappaB3NonChord'. Avoid tones are not
-- a tier — they are removed from the pool. Legacy callers pass
-- target == strong with empty passing and avoid sets, collapsing this to
-- the original two tiers exactly.
pass2Beat3s
  :: Int                  -- consonance strictness percentage
  -> V.Vector Bool        -- per-bar symmetric-chord flags (raw chord sets)
  -> B3Tiers
  -> V.Vector Int -> V.Vector Int -> V.Vector Int
pass2Beat3s :: Int
-> Vector Bool -> B3Tiers -> Vector Int -> Vector Int -> Vector Int
pass2Beat3s Int
consPct Vector Bool
symFlagV B3Tiers
tiers Vector Int
b1s Vector Int
fundPCs =
  let n :: Int
n = Vector Int -> Int
forall a. Vector a -> Int
V.length Vector Int
b1s
      pick :: Int -> Int
pick Int
i =
        let target :: Set Int
target = B3Tiers -> Vector (Set Int)
b3Target  B3Tiers
tiers Vector (Set Int) -> Int -> Set Int
forall a. Vector a -> Int -> a
V.! Int
i
            strong :: Set Int
strong = B3Tiers -> Vector (Set Int)
b3Strong  B3Tiers
tiers Vector (Set Int) -> Int -> Set Int
forall a. Vector a -> Int -> a
V.! Int
i
            passes :: Set Int
passes = B3Tiers -> Vector (Set Int)
b3Passing B3Tiers
tiers Vector (Set Int) -> Int -> Set Int
forall a. Vector a -> Int -> a
V.! Int
i
            avoid :: Set Int
avoid  = B3Tiers -> Vector (Set Int)
b3Avoid   B3Tiers
tiers Vector (Set Int) -> Int -> Set Int
forall a. Vector a -> Int -> a
V.! Int
i
            p5PC :: Int
p5PC   = B3Tiers -> Vector Int
b3Fifth   B3Tiers
tiers Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i
            sym :: Bool
sym    = Vector Bool
symFlagV Vector Bool -> Int -> Bool
forall a. Vector a -> Int -> a
V.! Int
i
            -- Avoid tones are removed outright, not merely surcharged:
            -- the guarantee is that a notated colour alteration never
            -- lands on a strong beat. They stay reachable as weak-beat
            -- tension through the connector pools.
            pool :: [Int]
pool   = Vector Int -> [Int]
forall a. Vector a -> [a]
V.toList (Set Int -> Vector Int
midisIn
                       ((Set Int
strong Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Int
passes Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` (B3Tiers -> Vector (Set Int)
b3Palette B3Tiers
tiers Vector (Set Int) -> Int -> Set Int
forall a. Vector a -> Int -> a
V.! Int
i))
                          Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Int
avoid))
            b1L :: Int
b1L    = Vector Int
b1s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i
            b1R :: Int
b1R    = Vector Int
b1s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! ((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
n)
            fundPC :: Int
fundPC = Vector Int
fundPCs Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i
            score :: Int -> Int
score Int
m =
              let smL :: Int
smL  = Int -> Int
forall a. Num a => a -> a
abs (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
b1L)
                  smR :: Int
smR  = Int -> Int
forall a. Num a => a -> a
abs (Int
b1R Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m)
                  -- Role pricing: whatever semitone the quality's own
                  -- fifth occupies (b5, natural, #5) is priced AS a
                  -- fifth. Legacy callers pass fund+7, so this is the
                  -- identity for them.
                  iv :: Int
iv   = (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fundPC) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
                  iv' :: Int
iv'  = if (Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
p5PC then Int
7 else Int
iv
                  cons :: Int
cons = if Bool
sym then Int
0
                         else (Int
consPct Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
kappaB3Consonance
                               Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int -> Int
beat3ConsTable Int
iv')
                              Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100
                  nchP :: Int
nchP | (Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
target = Int
0
                       | (Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
strong = Int
kappaB3NonTarget
                       | (Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
passes = Int
kappaB3Passing
                       | Bool
otherwise                        = Int
kappaB3NonChord
                  repP :: Int
repP = if Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
b1L then Int
kappaPassiveRepeat else Int
0
                  antP :: Int
antP = if Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
b1R then Int
kappaB3Anticipate else Int
0
              in Int
smL Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
smR Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cons Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nchP Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
repP Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
antP
        in case [Int]
pool of
             [] -> Int
b1L   -- degenerate bar (no chord tones): hold beat 1
             [Int]
_  -> (Int -> Int -> Ordering) -> [Int] -> Int
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering) -> (Int -> Int) -> Int -> Int -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Int -> Int
score) [Int]
pool
  in Int -> (Int -> Int) -> Vector Int
forall a. Int -> (Int -> a) -> Vector a
V.generate Int
n Int -> Int
pick

-------------------------------------------------------------------------------
-- Pass 3 — Beats 2 and 4 (connectors)
-------------------------------------------------------------------------------

data ConnectorPos = Beat2 | Beat4 deriving (ConnectorPos -> ConnectorPos -> Bool
(ConnectorPos -> ConnectorPos -> Bool)
-> (ConnectorPos -> ConnectorPos -> Bool) -> Eq ConnectorPos
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConnectorPos -> ConnectorPos -> Bool
== :: ConnectorPos -> ConnectorPos -> Bool
$c/= :: ConnectorPos -> ConnectorPos -> Bool
/= :: ConnectorPos -> ConnectorPos -> Bool
Eq, Int -> ConnectorPos -> ShowS
[ConnectorPos] -> ShowS
ConnectorPos -> String
(Int -> ConnectorPos -> ShowS)
-> (ConnectorPos -> String)
-> ([ConnectorPos] -> ShowS)
-> Show ConnectorPos
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConnectorPos -> ShowS
showsPrec :: Int -> ConnectorPos -> ShowS
$cshow :: ConnectorPos -> String
show :: ConnectorPos -> String
$cshowList :: [ConnectorPos] -> ShowS
showList :: [ConnectorPos] -> ShowS
Show)

-- | Deterministic Double in [0, 1) from (seed, position).
seededUniform :: Int -> Int -> Double
seededUniform :: Int -> Int -> Double
seededUniform Int
seed Int
pos =
  (Double, StdGen) -> Double
forall a b. (a, b) -> a
fst (StdGen -> (Double, StdGen)
forall g. RandomGen g => g -> (Double, g)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random (Int -> StdGen
mkStdGen (Int
seed Int -> Int -> Int
forall a. Bits a => a -> a -> a
`xor` (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2654435761))) :: (Double, StdGen))

-- | Repeat-rate probability: 0.20 at e=0, 0.05 at e=1 (clamped to [0,1]).
pRepeat :: Double -> Double
pRepeat :: Double -> Double
pRepeat Double
e = Double
0.20 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
0.15 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0.0 (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
1.0 Double
e)

-- | Controlled-repeat cost at a connector position.
repeatCostAt :: Int -> Double -> Int -> Int -> Int -> Int
repeatCostAt :: Int -> Double -> Int -> Int -> Int -> Int
repeatCostAt Int
pos Double
e Int
seed Int
m Int
l
  | Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
l                              = Int
0
  | Int -> Int -> Double
seededUniform Int
seed Int
pos Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double -> Double
pRepeat Double
e  = Int
kappaStaticBase
  | Bool
otherwise                           = Int
kappaStaticBlocked

-- | Connector candidate pool: local-scale tones union chromatic approaches
-- to the right-flank target (clipped to the register).
connectorPool :: Set Int -> Int -> [Int]
connectorPool :: Set Int -> Int -> [Int]
connectorPool Set Int
scale Int
target =
  let scaleMidis :: [Int]
scaleMidis = Vector Int -> [Int]
forall a. Vector a -> [a]
V.toList (Set Int -> Vector Int
midisIn Set Int
scale)
      chromas :: [Int]
chromas    = [ Int
m | Int
m <- [Int
target Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
target Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1]
                       , Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
lowestMidi, Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
highestMidi ]
  in Set Int -> [Int]
forall a. Set a -> [a]
Set.toList ([Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList ([Int]
scaleMidis [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
chromas))

-- | Per-beat scoring. Beat 4 picks up extra bonuses (chord-tone near target,
-- stronger chromatic-leading-tone bonus, root \/ P5 approach) and a copy-next
-- penalty; both beats pick up a diatonic-approach bonus and a static-cell
-- recovery bonus. The chromatic-approach bonus applies to any candidate at
-- |m - r| == 1 — in-scale, in-chord, or chromatic. For symmetric chords the
-- static-cell recovery rewards any non-root chord tone (not just the phantom
-- P5). The approach bonus (iter 6) rewards the current bar's root on beat 4
-- when it sits 1 or 2 semitones from next b1 (half strength for the P5); if
-- b3 already used the root \/ P5, the bonus shifts to the chromatic
-- in-between tone so the line doesn't repeat itself into a static cell.
scoreConnector
  :: ConnectorPos
  -> Int            -- tension licence percentage (scales chromatic bonus)
  -> Set Int        -- key-area scale PCs (Minor Thirds Rule)
  -> Set Int        -- localScale_i (cyclic)
  -> Set Int        -- chord-tone gate (bass vocabulary: strong + passing)
  -> Set Int        -- strong-tier PCs (full beat-2 preference)
  -> Int -> Int     -- L, R
  -> Bool           -- isStatic (b1 == b3 for this bar)
  -> Bool           -- isSymmetric (this bar's chord is rotation-invariant)
  -> Int            -- rootPC of this bar
  -> Int            -- p5PC of this bar
  -> Int            -- b3 MIDI of this bar
  -> Int -> Double -> Int -> Int -> Int
scoreConnector :: ConnectorPos
-> Int
-> Set Int
-> Set Int
-> Set Int
-> Set Int
-> Int
-> Int
-> Bool
-> Bool
-> Int
-> Int
-> Int
-> Int
-> Double
-> Int
-> Int
-> Int
scoreConnector ConnectorPos
pos Int
tensionPct Set Int
keySet Set Int
scale Set Int
chord Set Int
anchors Int
l Int
r Bool
isStatic Bool
isSymmetric
               Int
rootPC Int
p5PC Int
b3 Int
posIdx Double
e Int
seed Int
m =
  let smooth :: Int
smooth      = (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m)
      inScale :: Bool
inScale     = (Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
scale
      inChord :: Bool
inChord     = (Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
chord
      scaleFit :: Int
scaleFit    = if Bool
inScale then Int
0 else Int
kappaChromatic
      chromaticB :: Int
chromaticB  = if Int -> Int
forall a. Num a => a -> a
abs (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
                    then -((ConnectorPos -> Int
bonusK ConnectorPos
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
tensionPct) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100) else Int
0
      diatonicAp :: Int
diatonicAp  = if Int -> Int
forall a. Num a => a -> a
abs (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 Bool -> Bool -> Bool
&& Bool
inScale
                    then -Int
kappaDiatonicApproach else Int
0
      -- Wasted-tone rule: weak beats reserve the quality-defining chord
      -- tones (3rds \/ 7ths) for strong beats; only root and P5 earn the
      -- beat-4 chord-tone approach bonus.
      chordToneB :: Int
chordToneB  = if ConnectorPos
pos ConnectorPos -> ConnectorPos -> Bool
forall a. Eq a => a -> a -> Bool
== ConnectorPos
Beat4 Bool -> Bool -> Bool
&& Bool
inChord Bool -> Bool -> Bool
&& Int -> Int
forall a. Num a => a -> a
abs (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r) Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
1, Int
2]
                       Bool -> Bool -> Bool
&& (Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
rootPC, Int
p5PC]
                    then -Int
kappaChordToneBonus else Int
0
      -- Beat 2 reads the bar in tiers: the chord's own tones (triad plus
      -- the defining seventh) take the full preference, its favourable
      -- passing extensions half — so the minor 3rd outranks the 11th in
      -- that slot, while the seventh still outranks a mere scale tone.
      -- Legacy paths pass one set for both tiers, preserving their
      -- behaviour exactly.
      b2ChordB :: Int
b2ChordB
        | ConnectorPos
pos ConnectorPos -> ConnectorPos -> Bool
forall a. Eq a => a -> a -> Bool
/= ConnectorPos
Beat2 Bool -> Bool -> Bool
|| Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
l            = Int
0
        | (Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
anchors = -Int
kappaB2ChordTone
        | Bool
inChord                           = -(Int
kappaB2ChordTone Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)
        | Bool
otherwise                         = Int
0
      sandwichPen :: Int
sandwichPen = if Bool -> Bool
not Bool
inChord Bool -> Bool -> Bool
&& Int -> Int
forall a. Num a => a -> a
abs (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2 Bool -> Bool -> Bool
&& Int -> Int
forall a. Num a => a -> a
abs (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2
                    then Int
kappaSandwich else Int
0
      copyPen :: Int
copyPen     = if ConnectorPos
pos ConnectorPos -> ConnectorPos -> Bool
forall a. Eq a => a -> a -> Bool
== ConnectorPos
Beat4 Bool -> Bool -> Bool
&& Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
r
                    then Int
kappaCopyNext else Int
0
      staticRec :: Int
staticRec   = if Bool
isStatic Bool -> Bool -> Bool
&& Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
l Bool -> Bool -> Bool
&&
                       ((Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
p5PC Bool -> Bool -> Bool
|| (Bool
isSymmetric Bool -> Bool -> Bool
&& Bool
inChord))
                    then -Int
kappaStaticRecovery else Int
0
      approachB :: Int -> a -> a
approachB Int
targetPC a
weight =
        if ConnectorPos
pos ConnectorPos -> ConnectorPos -> Bool
forall a. Eq a => a -> a -> Bool
== ConnectorPos
Beat4 Bool -> Bool -> Bool
&&
           ( ((Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
targetPC Bool -> Bool -> Bool
&&
              Int -> Int
forall a. Num a => a -> a
abs (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r) Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
1, Int
2] Bool -> Bool -> Bool
&&
              (Int
b3 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
targetPC)
           Bool -> Bool -> Bool
||
             (Int -> Int
forall a. Num a => a -> a
abs (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&&
              (Int
b3 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
targetPC Bool -> Bool -> Bool
&&
              Int -> Int
forall a. Num a => a -> a
abs (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 Bool -> Bool -> Bool
&&
              (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) )
        then -a
weight else a
0
      -- Root approach, P5 approach, and the dominant fall are alternative
      -- readings of one gesture: a candidate qualifying under several takes
      -- the strongest bonus only.
      dominantFallB :: Int
dominantFallB = if ConnectorPos
pos ConnectorPos -> ConnectorPos -> Bool
forall a. Eq a => a -> a -> Bool
== ConnectorPos
Beat4 Bool -> Bool -> Bool
&& (Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
rootPC
                         Bool -> Bool -> Bool
&& ((Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5
                      then -Int
kappaDominantFall else Int
0
      approachTotal :: Int
approachTotal = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum
        [ Int -> Int -> Int
forall {a}. Num a => Int -> a -> a
approachB Int
rootPC Int
kappaRootApproach
        , Int -> Int -> Int
forall {a}. Num a => Int -> a -> a
approachB Int
p5PC (Int
kappaRootApproach Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)
        , Int
dominantFallB ]
      -- Minor Thirds Rule (see 'kappaMinorThird').
      gapLR :: Int
gapLR    = Int -> Int
forall a. Num a => a -> a
abs (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r)
      betweenLR :: Bool
betweenLR = (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
      mtRule :: Int
mtRule
        | Int
gapLR Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3 Bool -> Bool -> Bool
&& Bool
betweenLR =
            if (Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
keySet
              then -Int
kappaMinorThird
              else -((Int
kappaMinorThird Int -> Int -> Int
forall a. Num a => a -> a -> a
* Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
100 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
e)) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100)
        | Int
gapLR Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4 Bool -> Bool -> Bool
&& Bool
betweenLR Bool -> Bool -> Bool
&& Int -> Int
forall a. Num a => a -> a
abs (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 = -Int
kappaMinorThird
        | Bool
otherwise = Int
0
      fourthChainB :: Int
fourthChainB = if Bool
inChord Bool -> Bool -> Bool
&& Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
r Bool -> Bool -> Bool
&& Int -> Int
forall a. Num a => a -> a
abs (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l) Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
5, Int
7]
                        Bool -> Bool -> Bool
&& (Int -> Int
forall a. Num a => a -> a
abs (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
2 Bool -> Bool -> Bool
|| Int -> Int
forall a. Num a => a -> a
abs (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r) Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
5, Int
7])
                     then -Int
kappaFourthChain else Int
0
      repC :: Int
repC        = let base :: Int
base      = Int -> Double -> Int -> Int -> Int -> Int
repeatCostAt Int
posIdx Double
e Int
seed Int
m Int
l
                        phrasePos :: Int
phrasePos = (Int
posIdx Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
4
                    in if ConnectorPos
pos ConnectorPos -> ConnectorPos -> Bool
forall a. Eq a => a -> a -> Bool
== ConnectorPos
Beat4 Bool -> Bool -> Bool
&& Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
l
                       then if Int
phrasePos Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3
                            then Int
kappaStaticBase
                            else Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
kappaPhraseMid
                       else Int
base
  in Int
smooth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
scaleFit Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
chromaticB Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
diatonicAp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
chordToneB Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b2ChordB
           Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sandwichPen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
copyPen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
staticRec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
approachTotal Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
mtRule
           Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
fourthChainB Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
repC
  where
    bonusK :: ConnectorPos -> Int
bonusK ConnectorPos
Beat2 = Int
kappaChromaticBonus
    bonusK ConnectorPos
Beat4 = Int
kappaChromaticBonusBeat4

-- | Fill beats 2 and 4 per bar.
pass3Connectors
  :: Int                  -- tension licence percentage
  -> V.Vector (Set Int)   -- key-area scale PCs per bar
  -> V.Vector (Set Int)   -- local scales
  -> V.Vector Bool        -- per-bar symmetric-chord flags (raw chord sets)
  -> V.Vector (Set Int)   -- chord-tone gate PCs (bass vocabulary per bar)
  -> V.Vector (Set Int)   -- strong-tier PCs per bar (full beat-2 tier)
  -> V.Vector Int         -- THE fifth's PC per bar (vocabulary-corrected)
  -> V.Vector Int         -- b1s
  -> V.Vector Int         -- b3s
  -> V.Vector Int         -- fund PCs (for P5 recovery)
  -> Int -> Double
  -> (V.Vector Int, V.Vector Int)
pass3Connectors :: Int
-> Vector (Set Int)
-> Vector (Set Int)
-> Vector Bool
-> Vector (Set Int)
-> Vector (Set Int)
-> Vector Int
-> Vector Int
-> Vector Int
-> Vector Int
-> Int
-> Double
-> (Vector Int, Vector Int)
pass3Connectors Int
tensionPct Vector (Set Int)
keySetsV Vector (Set Int)
localsV Vector Bool
symV Vector (Set Int)
gatesV Vector (Set Int)
anchorsV Vector Int
p5PCsV Vector Int
b1s Vector Int
b3s Vector Int
fundPCs Int
seed Double
e =
  let n :: Int
n = Vector Int -> Int
forall a. Vector a -> Int
V.length Vector Int
b1s
      isStaticAt :: Int -> Bool
isStaticAt Int
i = Vector Int
b1s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Vector Int
b3s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i
      isSymAt :: Int -> Bool
isSymAt Int
i    = Vector Bool
symV Vector Bool -> Int -> Bool
forall a. Vector a -> Int -> a
V.! Int
i
      rootPCAt :: Int -> Int
rootPCAt Int
i   = Vector Int
fundPCs Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i
      p5PCAt :: Int -> Int
p5PCAt Int
i     = Vector Int
p5PCsV Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i
      b3At :: Int -> Int
b3At Int
i       = Vector Int
b3s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i
      chooseBeat2 :: Int -> Int
chooseBeat2 Int
i =
        let scale :: Set Int
scale = Vector (Set Int)
localsV Vector (Set Int) -> Int -> Set Int
forall a. Vector a -> Int -> a
V.! Int
i
            chord :: Set Int
chord = Vector (Set Int)
gatesV Vector (Set Int) -> Int -> Set Int
forall a. Vector a -> Int -> a
V.! Int
i
            l :: Int
l     = Vector Int
b1s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i
            r :: Int
r     = Vector Int
b3s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i
            pool :: [Int]
pool  = Set Int -> Int -> [Int]
connectorPool Set Int
scale Int
r
            sc :: Int -> Int
sc    = ConnectorPos
-> Int
-> Set Int
-> Set Int
-> Set Int
-> Set Int
-> Int
-> Int
-> Bool
-> Bool
-> Int
-> Int
-> Int
-> Int
-> Double
-> Int
-> Int
-> Int
scoreConnector ConnectorPos
Beat2 Int
tensionPct (Vector (Set Int)
keySetsV Vector (Set Int) -> Int -> Set Int
forall a. Vector a -> Int -> a
V.! Int
i) Set Int
scale Set Int
chord (Vector (Set Int)
anchorsV Vector (Set Int) -> Int -> Set Int
forall a. Vector a -> Int -> a
V.! Int
i) Int
l Int
r
                                   (Int -> Bool
isStaticAt Int
i) (Int -> Bool
isSymAt Int
i)
                                   (Int -> Int
rootPCAt Int
i) (Int -> Int
p5PCAt Int
i) (Int -> Int
b3At Int
i)
                                   (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i) Double
e Int
seed
        in case [Int]
pool of
             [] -> Int
l
             [Int]
_  -> (Int -> Int -> Ordering) -> [Int] -> Int
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering) -> (Int -> Int) -> Int -> Int -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Int -> Int
sc) [Int]
pool
      chooseBeat4 :: Int -> Int
chooseBeat4 Int
i =
        let scale :: Set Int
scale = Vector (Set Int)
localsV Vector (Set Int) -> Int -> Set Int
forall a. Vector a -> Int -> a
V.! Int
i
            chord :: Set Int
chord = Vector (Set Int)
gatesV Vector (Set Int) -> Int -> Set Int
forall a. Vector a -> Int -> a
V.! Int
i
            l :: Int
l     = Vector Int
b3s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i
            r :: Int
r     = Vector Int
b1s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! ((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
n)
            pool :: [Int]
pool  = Set Int -> Int -> [Int]
connectorPool Set Int
scale Int
r
            sc :: Int -> Int
sc    = ConnectorPos
-> Int
-> Set Int
-> Set Int
-> Set Int
-> Set Int
-> Int
-> Int
-> Bool
-> Bool
-> Int
-> Int
-> Int
-> Int
-> Double
-> Int
-> Int
-> Int
scoreConnector ConnectorPos
Beat4 Int
tensionPct (Vector (Set Int)
keySetsV Vector (Set Int) -> Int -> Set Int
forall a. Vector a -> Int -> a
V.! Int
i) Set Int
scale Set Int
chord (Vector (Set Int)
anchorsV Vector (Set Int) -> Int -> Set Int
forall a. Vector a -> Int -> a
V.! Int
i) Int
l Int
r
                                   (Int -> Bool
isStaticAt Int
i) (Int -> Bool
isSymAt Int
i)
                                   (Int -> Int
rootPCAt Int
i) (Int -> Int
p5PCAt Int
i) (Int -> Int
b3At Int
i)
                                   (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Double
e Int
seed
        in case [Int]
pool of
             [] -> Int
l
             [Int]
_  -> (Int -> Int -> Ordering) -> [Int] -> Int
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering) -> (Int -> Int) -> Int -> Int -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Int -> Int
sc) [Int]
pool
  in (Int -> (Int -> Int) -> Vector Int
forall a. Int -> (Int -> a) -> Vector a
V.generate Int
n Int -> Int
chooseBeat2, Int -> (Int -> Int) -> Vector Int
forall a. Int -> (Int -> a) -> Vector a
V.generate Int
n Int -> Int
chooseBeat4)

-------------------------------------------------------------------------------
-- Main entry
-------------------------------------------------------------------------------

-- | Generate a walking-bass line. Entropy is derived from the progression's
-- harmonic character; the caller supplies only the progression and a voice
-- function ('Harmonic.Interface.Tidal.Groove.fund' or 'Harmonic.Interface.Tidal.Arranger.root') defining each bar's beat 1.
walkLine :: VoiceFunction -> Pr.Progression -> [[Int]]
walkLine :: VoiceFunction -> VoiceFunction
walkLine = Maybe [Double] -> VoiceFunction -> VoiceFunction
walkLineDyn Maybe [Double]
forall a. Maybe a
Nothing

-- | 'walkLine' with an optional per-bar dynamic vector coupling the beat-1
-- register arc to the piece's dynamics (see @kappaDynArc@). 'Nothing' is
-- byte-identical to 'walkLine'.
walkLineDyn :: Maybe [Double] -> VoiceFunction -> Pr.Progression -> [[Int]]
walkLineDyn :: Maybe [Double] -> VoiceFunction -> VoiceFunction
walkLineDyn Maybe [Double]
mDyn VoiceFunction
voiceFn Progression
prog
  | Int
nBars Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = []
  | Bool
otherwise  = [ [Vector Int
b1s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i, Vector Int
b2s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i, Vector Int
b3s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i, Vector Int
b4s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i]
                 | Int
i <- [Int
0 .. Int
nBars Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ]
  where
    e :: Double
e         = Progression -> Double
progressionEntropy Progression
prog
    seed :: Int
seed      = Progression -> Double -> Int
hashProgEntropy Progression
prog Double
e

    -- Progression-level consonance scales the walk's character: consonant
    -- material anchors harder (stricter beat-3 table) and licenses less
    -- chromatic tension in the connectors; dissonant material the reverse.
    -- The band is deliberately narrow so scaling shades the line's colour
    -- without erasing strong-beat variety at either extreme.
    consPct :: Int
consPct    = Int
70 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
60 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Progression -> Double
progConsonance Progression
prog) :: Int
    tensionPct :: Int
tensionPct = Int
200 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
consPct

    barsV :: Vector CadenceState
barsV     = [CadenceState] -> Vector CadenceState
forall a. [a] -> Vector a
V.fromList (Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Pr.unProgression Progression
prog))
    nBars :: Int
nBars     = Vector CadenceState -> Int
forall a. Vector a -> Int
V.length Vector CadenceState
barsV

    chordPCsV :: Vector (Set Int)
chordPCsV = (CadenceState -> Set Int)
-> Vector CadenceState -> Vector (Set Int)
forall a b. (a -> b) -> Vector a -> Vector b
V.map CadenceState -> Set Int
chordPCs Vector CadenceState
barsV
    localsV :: Vector (Set Int)
localsV   = Int -> (Int -> Set Int) -> Vector (Set Int)
forall a. Int -> (Int -> a) -> Vector a
V.generate Int
nBars (Vector (Set Int) -> Int -> Set Int
localScale Vector (Set Int)
chordPCsV)

    -- Pass-2 consonance target is the cadence-state fundamental regardless
    -- of voice function supplied for beat 1.
    fundPCs :: Vector Int
fundPCs   = (CadenceState -> Int) -> Vector CadenceState -> Vector Int
forall a b. (a -> b) -> Vector a -> Vector b
V.map CadenceState -> Int
rootPCInt Vector CadenceState
barsV

    pcs1 :: Vector Int
pcs1      = VoiceFunction -> Progression -> Vector Int
beat1PCs VoiceFunction
voiceFn Progression
prog
    p5PCs :: Vector Int
p5PCs     = (CadenceState -> Int) -> Vector CadenceState -> Vector Int
forall a b. (a -> b) -> Vector a -> Vector b
V.map CadenceState -> Int
chordFifthPC Vector CadenceState
barsV
    dupOdd :: Vector Bool
dupOdd    = Vector CadenceState -> Vector Bool
dupOddFlags Vector CadenceState
barsV
    (Vector Double
biasV, Vector Bool
dropV) = Int -> Maybe [Double] -> (Vector Double, Vector Bool)
dynVectors Int
nBars Maybe [Double]
mDyn
    b1s :: Vector Int
b1s       = Vector Double
-> Vector Bool
-> Vector Int
-> Vector Int
-> Vector Bool
-> Vector Int
pass1Beat1s Vector Double
biasV Vector Bool
dropV Vector Int
pcs1 Vector Int
p5PCs Vector Bool
dupOdd
    keySetsV :: Vector (Set Int)
keySetsV  = Progression -> Vector (Set Int)
barPalettes Progression
prog

    symV :: Vector Bool
symV      = (Set Int -> Bool) -> Vector (Set Int) -> Vector Bool
forall a b. (a -> b) -> Vector a -> Vector b
V.map Set Int -> Bool
isSymmetricChord Vector (Set Int)
chordPCsV
    emptyV :: Vector (Set a)
emptyV    = Int -> Set a -> Vector (Set a)
forall a. Int -> a -> Vector a
V.replicate Int
nBars Set a
forall a. Set a
Set.empty
    -- target == strong, no passing, no avoid: the original two tiers.
    tiers :: B3Tiers
tiers     = Vector (Set Int)
-> Vector (Set Int)
-> Vector (Set Int)
-> Vector (Set Int)
-> Vector (Set Int)
-> Vector Int
-> B3Tiers
B3Tiers Vector (Set Int)
chordPCsV Vector (Set Int)
chordPCsV Vector (Set Int)
forall {a}. Vector (Set a)
emptyV Vector (Set Int)
forall {a}. Vector (Set a)
emptyV Vector (Set Int)
keySetsV Vector Int
p5PCs
    b3s :: Vector Int
b3s       = Int
-> Vector Bool -> B3Tiers -> Vector Int -> Vector Int -> Vector Int
pass2Beat3s Int
consPct Vector Bool
symV B3Tiers
tiers Vector Int
b1s Vector Int
fundPCs
    (Vector Int
b2s, Vector Int
b4s) = Int
-> Vector (Set Int)
-> Vector (Set Int)
-> Vector Bool
-> Vector (Set Int)
-> Vector (Set Int)
-> Vector Int
-> Vector Int
-> Vector Int
-> Vector Int
-> Int
-> Double
-> (Vector Int, Vector Int)
pass3Connectors Int
tensionPct Vector (Set Int)
keySetsV Vector (Set Int)
localsV Vector Bool
symV Vector (Set Int)
chordPCsV Vector (Set Int)
chordPCsV Vector Int
p5PCs Vector Int
b1s Vector Int
b3s Vector Int
fundPCs Int
seed Double
e

-------------------------------------------------------------------------------
-- Octatripentatonic-aware variant
-------------------------------------------------------------------------------

-- | Per-bar chroma sources for the 'walkLineP' Pass-3 connector pool.
-- 'csStrata' is the bar's full 5-PC strata chroma; 'csMode' is the full
-- 7-PC mode chroma. Both are supplied by the caller (typically derived from
-- 'PC.strataLayer' \/ 'PC.modeLayer' of a genP-origin ProgressionContext).
data ChromaSources = ChromaSources
  { ChromaSources -> Set Int
csStrata :: !(Set Int)
  , ChromaSources -> Set Int
csMode   :: !(Set Int)
  } deriving (ChromaSources -> ChromaSources -> Bool
(ChromaSources -> ChromaSources -> Bool)
-> (ChromaSources -> ChromaSources -> Bool) -> Eq ChromaSources
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChromaSources -> ChromaSources -> Bool
== :: ChromaSources -> ChromaSources -> Bool
$c/= :: ChromaSources -> ChromaSources -> Bool
/= :: ChromaSources -> ChromaSources -> Bool
Eq, Int -> ChromaSources -> ShowS
[ChromaSources] -> ShowS
ChromaSources -> String
(Int -> ChromaSources -> ShowS)
-> (ChromaSources -> String)
-> ([ChromaSources] -> ShowS)
-> Show ChromaSources
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChromaSources -> ShowS
showsPrec :: Int -> ChromaSources -> ShowS
$cshow :: ChromaSources -> String
show :: ChromaSources -> String
$cshowList :: [ChromaSources] -> ShowS
showList :: [ChromaSources] -> ShowS
Show)

-- | Octatripentatonic-aware connector pool. Replaces the chromatic ±1
-- candidates of 'connectorPool' with strata \/ mode chroma — chromatic
-- approaches that aren't independently in strata, overlap, mode, or chord
-- are excluded entirely (no chromatic lines in genP context).
connectorPoolP :: Set Int -> Set Int -> Set Int -> Set Int -> [Int]
connectorPoolP :: Set Int -> Set Int -> Set Int -> Set Int -> [Int]
connectorPoolP Set Int
strata Set Int
overlap Set Int
mode Set Int
chord =
  let allPCs :: Set Int
allPCs = Set Int
strata Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Int
overlap Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Int
mode Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Int
chord
  in Vector Int -> [Int]
forall a. Vector a -> [a]
V.toList (Set Int -> Vector Int
midisIn Set Int
allPCs)

-- | Tier-aware scoring for the genP path. Mirrors 'scoreConnector' but:
--   * the leading-tone bonus applies only to in-pool candidates (the pool
--     admits no chromatic outsiders, so a semitone approach is always a
--     strata \/ overlap \/ mode tone — purity is preserved).
--   * replaces the binary 'kappaChromatic' fit penalty with a three-tier
--     preference: strata (bonus), overlap (neutral), mode (mild penalty).
--   * keeps every other term unchanged (smoothness, diatonic approach,
--     chord-tone bonus on beat 4, copy-next penalty, static recovery,
--     root\/P5 approach, repeat cost).
scoreConnectorP
  :: ConnectorPos
  -> Int            -- tension licence percentage (scales chromatic bonus)
  -> Set Int        -- strata PCs (5)
  -> Set Int        -- overlap (localScale) PCs
  -> Set Int        -- mode PCs (7)
  -> Set Int        -- chord PCs (3)
  -> Int -> Int     -- L, R
  -> Bool           -- isStatic
  -> Bool           -- isSymmetric
  -> Int            -- rootPC
  -> Int            -- p5PC
  -> Int            -- b3 MIDI
  -> Int -> Double -> Int -> Int -> Int
scoreConnectorP :: ConnectorPos
-> Int
-> Set Int
-> Set Int
-> Set Int
-> Set Int
-> Int
-> Int
-> Bool
-> Bool
-> Int
-> Int
-> Int
-> Int
-> Double
-> Int
-> Int
-> Int
scoreConnectorP ConnectorPos
pos Int
tensionPct Set Int
strata Set Int
overlap Set Int
mode Set Int
chord Int
l Int
r Bool
isStatic Bool
isSymmetric
                Int
rootPC Int
p5PC Int
b3 Int
posIdx Double
e Int
seed Int
m =
  let smooth :: Int
smooth      = (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m)
      pcMod :: Int
pcMod       = Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
      inStrata :: Bool
inStrata    = Int
pcMod Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
strata
      inOverlap :: Bool
inOverlap   = Int
pcMod Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
overlap
      inMode :: Bool
inMode      = Int
pcMod Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
mode
      inChord :: Bool
inChord     = Int
pcMod Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
chord
      inAny :: Bool
inAny       = Bool
inStrata Bool -> Bool -> Bool
|| Bool
inOverlap Bool -> Bool -> Bool
|| Bool
inMode Bool -> Bool -> Bool
|| Bool
inChord
      -- Chord tones are subsumed by strata (pcStrictContainment guarantees
      -- chord ⊆ strata ⊆ mode for every genP bar), so three tiers suffice:
      -- own-stratum tone, neighbour-triad tone outside the stratum, and
      -- partner-contributed mode tone.
      tierFit :: Int
tierFit
        | Bool
inStrata  = -Int
kappaStrataPref     -- bonus for the bar's own stratum
        | Bool
inOverlap = Int
0                    -- neighbour-triad tone, neutral
        | Bool
otherwise = Int
kappaModePenalty     -- mode-only (partner stratum) tone
      chromaticB :: Int
chromaticB  = if Int -> Int
forall a. Num a => a -> a
abs (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
                    then -((ConnectorPos -> Int
bonusK ConnectorPos
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
tensionPct) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100) else Int
0
      diatonicAp :: Int
diatonicAp  = if Int -> Int
forall a. Num a => a -> a
abs (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 Bool -> Bool -> Bool
&& Bool
inAny
                    then -Int
kappaDiatonicApproach else Int
0
      -- Wasted-tone rule: weak beats reserve the quality-defining chord
      -- tones (3rds \/ 7ths) for strong beats; only root and P5 earn the
      -- beat-4 chord-tone approach bonus.
      chordToneB :: Int
chordToneB  = if ConnectorPos
pos ConnectorPos -> ConnectorPos -> Bool
forall a. Eq a => a -> a -> Bool
== ConnectorPos
Beat4 Bool -> Bool -> Bool
&& Bool
inChord Bool -> Bool -> Bool
&& Int -> Int
forall a. Num a => a -> a
abs (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r) Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
1, Int
2]
                       Bool -> Bool -> Bool
&& (Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
rootPC, Int
p5PC]
                    then -Int
kappaChordToneBonus else Int
0
      b2ChordB :: Int
b2ChordB    = if ConnectorPos
pos ConnectorPos -> ConnectorPos -> Bool
forall a. Eq a => a -> a -> Bool
== ConnectorPos
Beat2 Bool -> Bool -> Bool
&& Bool
inChord Bool -> Bool -> Bool
&& Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
l
                    then -Int
kappaB2ChordTone else Int
0
      sandwichPen :: Int
sandwichPen = if Bool -> Bool
not Bool
inChord Bool -> Bool -> Bool
&& Int -> Int
forall a. Num a => a -> a
abs (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2 Bool -> Bool -> Bool
&& Int -> Int
forall a. Num a => a -> a
abs (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2
                    then Int
kappaSandwich else Int
0
      copyPen :: Int
copyPen     = if ConnectorPos
pos ConnectorPos -> ConnectorPos -> Bool
forall a. Eq a => a -> a -> Bool
== ConnectorPos
Beat4 Bool -> Bool -> Bool
&& Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
r
                    then Int
kappaCopyNext else Int
0
      staticRec :: Int
staticRec   = if Bool
isStatic Bool -> Bool -> Bool
&& Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
l Bool -> Bool -> Bool
&&
                       ((Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
p5PC Bool -> Bool -> Bool
|| (Bool
isSymmetric Bool -> Bool -> Bool
&& Bool
inChord))
                    then -Int
kappaStaticRecovery else Int
0
      approachB :: Int -> a -> a
approachB Int
targetPC a
weight =
        if ConnectorPos
pos ConnectorPos -> ConnectorPos -> Bool
forall a. Eq a => a -> a -> Bool
== ConnectorPos
Beat4 Bool -> Bool -> Bool
&&
           ( ((Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
targetPC Bool -> Bool -> Bool
&&
              Int -> Int
forall a. Num a => a -> a
abs (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r) Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
1, Int
2] Bool -> Bool -> Bool
&&
              (Int
b3 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
targetPC)
           Bool -> Bool -> Bool
||
             (Int -> Int
forall a. Num a => a -> a
abs (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&&
              (Int
b3 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
targetPC Bool -> Bool -> Bool
&&
              Int -> Int
forall a. Num a => a -> a
abs (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 Bool -> Bool -> Bool
&&
              (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) )
        then -a
weight else a
0
      -- Root approach, P5 approach, and the dominant fall are alternative
      -- readings of one gesture: a candidate qualifying under several takes
      -- the strongest bonus only.
      dominantFallB :: Int
dominantFallB = if ConnectorPos
pos ConnectorPos -> ConnectorPos -> Bool
forall a. Eq a => a -> a -> Bool
== ConnectorPos
Beat4 Bool -> Bool -> Bool
&& (Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
rootPC
                         Bool -> Bool -> Bool
&& ((Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5
                      then -Int
kappaDominantFall else Int
0
      approachTotal :: Int
approachTotal = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum
        [ Int -> Int -> Int
forall {a}. Num a => Int -> a -> a
approachB Int
rootPC Int
kappaRootApproach
        , Int -> Int -> Int
forall {a}. Num a => Int -> a -> a
approachB Int
p5PC (Int
kappaRootApproach Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)
        , Int
dominantFallB ]
      -- Minor Thirds Rule, strata vocabulary: the bar's own stratum plays
      -- the diatonic role; anything else in the pool is the tension fill.
      gapLR :: Int
gapLR    = Int -> Int
forall a. Num a => a -> a
abs (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r)
      betweenLR :: Bool
betweenLR = (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
      mtRule :: Int
mtRule
        | Int
gapLR Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3 Bool -> Bool -> Bool
&& Bool
betweenLR =
            if Bool
inStrata
              then -Int
kappaMinorThird
              else -((Int
kappaMinorThird Int -> Int -> Int
forall a. Num a => a -> a -> a
* Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
100 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
e)) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100)
        | Int
gapLR Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4 Bool -> Bool -> Bool
&& Bool
betweenLR Bool -> Bool -> Bool
&& Int -> Int
forall a. Num a => a -> a
abs (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 = -Int
kappaMinorThird
        | Bool
otherwise = Int
0
      fourthChainB :: Int
fourthChainB = if Bool
inChord Bool -> Bool -> Bool
&& Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
r Bool -> Bool -> Bool
&& Int -> Int
forall a. Num a => a -> a
abs (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l) Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
5, Int
7]
                        Bool -> Bool -> Bool
&& (Int -> Int
forall a. Num a => a -> a
abs (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
2 Bool -> Bool -> Bool
|| Int -> Int
forall a. Num a => a -> a
abs (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r) Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
5, Int
7])
                     then -Int
kappaFourthChain else Int
0
      repC :: Int
repC        = let base :: Int
base      = Int -> Double -> Int -> Int -> Int -> Int
repeatCostAt Int
posIdx Double
e Int
seed Int
m Int
l
                        phrasePos :: Int
phrasePos = (Int
posIdx Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
4
                    in if ConnectorPos
pos ConnectorPos -> ConnectorPos -> Bool
forall a. Eq a => a -> a -> Bool
== ConnectorPos
Beat4 Bool -> Bool -> Bool
&& Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
l
                       then if Int
phrasePos Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3
                            then Int
kappaStaticBase
                            else Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
kappaPhraseMid
                       else Int
base
  in Int
smooth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
tierFit Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
chromaticB Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
diatonicAp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
chordToneB Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b2ChordB
           Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sandwichPen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
copyPen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
staticRec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
approachTotal Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
mtRule
           Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
fourthChainB Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
repC
  where
    bonusK :: ConnectorPos -> Int
bonusK ConnectorPos
Beat2 = Int
kappaChromaticBonus
    bonusK ConnectorPos
Beat4 = Int
kappaChromaticBonusBeat4

-- | Octatripentatonic Pass 3. Same shape as 'pass3Connectors' but with
-- per-bar 'ChromaSources' driving the candidate pool and tier scoring.
pass3ConnectorsP
  :: Int                        -- tension licence percentage
  -> V.Vector (Set Int)         -- local scales (overlap)
  -> V.Vector (Set Int)         -- chord PCs
  -> V.Vector (ChromaSources)   -- per-bar (strata, mode)
  -> V.Vector Int               -- b1s
  -> V.Vector Int               -- b3s
  -> V.Vector Int               -- fund PCs (for P5 recovery)
  -> Int -> Double
  -> (V.Vector Int, V.Vector Int)
pass3ConnectorsP :: Int
-> Vector (Set Int)
-> Vector (Set Int)
-> Vector ChromaSources
-> Vector Int
-> Vector Int
-> Vector Int
-> Int
-> Double
-> (Vector Int, Vector Int)
pass3ConnectorsP Int
tensionPct Vector (Set Int)
localsV Vector (Set Int)
chordsV Vector ChromaSources
chromasV Vector Int
b1s Vector Int
b3s Vector Int
fundPCs Int
seed Double
e =
  let n :: Int
n = Vector Int -> Int
forall a. Vector a -> Int
V.length Vector Int
b1s
      isStaticAt :: Int -> Bool
isStaticAt Int
i = Vector Int
b1s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Vector Int
b3s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i
      isSymAt :: Int -> Bool
isSymAt Int
i    = Set Int -> Bool
isSymmetricChord (Vector (Set Int)
chordsV Vector (Set Int) -> Int -> Set Int
forall a. Vector a -> Int -> a
V.! Int
i)
      rootPCAt :: Int -> Int
rootPCAt Int
i   = Vector Int
fundPCs Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i
      p5PCAt :: Int -> Int
p5PCAt Int
i     = (Vector Int
fundPCs Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
      b3At :: Int -> Int
b3At Int
i       = Vector Int
b3s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i
      strataAt :: Int -> Set Int
strataAt Int
i   = ChromaSources -> Set Int
csStrata (Vector ChromaSources
chromasV Vector ChromaSources -> Int -> ChromaSources
forall a. Vector a -> Int -> a
V.! Int
i)
      modeAt :: Int -> Set Int
modeAt Int
i     = ChromaSources -> Set Int
csMode   (Vector ChromaSources
chromasV Vector ChromaSources -> Int -> ChromaSources
forall a. Vector a -> Int -> a
V.! Int
i)
      chooseBeat2 :: Int -> Int
chooseBeat2 Int
i =
        let overlap :: Set Int
overlap = Vector (Set Int)
localsV Vector (Set Int) -> Int -> Set Int
forall a. Vector a -> Int -> a
V.! Int
i
            chord :: Set Int
chord   = Vector (Set Int)
chordsV Vector (Set Int) -> Int -> Set Int
forall a. Vector a -> Int -> a
V.! Int
i
            strata :: Set Int
strata  = Int -> Set Int
strataAt Int
i
            mode :: Set Int
mode    = Int -> Set Int
modeAt Int
i
            l :: Int
l       = Vector Int
b1s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i
            r :: Int
r       = Vector Int
b3s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i
            pool :: [Int]
pool    = Set Int -> Set Int -> Set Int -> Set Int -> [Int]
connectorPoolP Set Int
strata Set Int
overlap Set Int
mode Set Int
chord
            sc :: Int -> Int
sc      = ConnectorPos
-> Int
-> Set Int
-> Set Int
-> Set Int
-> Set Int
-> Int
-> Int
-> Bool
-> Bool
-> Int
-> Int
-> Int
-> Int
-> Double
-> Int
-> Int
-> Int
scoreConnectorP ConnectorPos
Beat2 Int
tensionPct Set Int
strata Set Int
overlap Set Int
mode Set Int
chord Int
l Int
r
                                      (Int -> Bool
isStaticAt Int
i) (Int -> Bool
isSymAt Int
i)
                                      (Int -> Int
rootPCAt Int
i) (Int -> Int
p5PCAt Int
i) (Int -> Int
b3At Int
i)
                                      (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i) Double
e Int
seed
        in case [Int]
pool of
             [] -> Int
l
             [Int]
_  -> (Int -> Int -> Ordering) -> [Int] -> Int
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering) -> (Int -> Int) -> Int -> Int -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Int -> Int
sc) [Int]
pool
      chooseBeat4 :: Int -> Int
chooseBeat4 Int
i =
        let overlap :: Set Int
overlap = Vector (Set Int)
localsV Vector (Set Int) -> Int -> Set Int
forall a. Vector a -> Int -> a
V.! Int
i
            chord :: Set Int
chord   = Vector (Set Int)
chordsV Vector (Set Int) -> Int -> Set Int
forall a. Vector a -> Int -> a
V.! Int
i
            strata :: Set Int
strata  = Int -> Set Int
strataAt Int
i
            mode :: Set Int
mode    = Int -> Set Int
modeAt Int
i
            l :: Int
l       = Vector Int
b3s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i
            r :: Int
r       = Vector Int
b1s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! ((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
n)
            pool :: [Int]
pool    = Set Int -> Set Int -> Set Int -> Set Int -> [Int]
connectorPoolP Set Int
strata Set Int
overlap Set Int
mode Set Int
chord
            sc :: Int -> Int
sc      = ConnectorPos
-> Int
-> Set Int
-> Set Int
-> Set Int
-> Set Int
-> Int
-> Int
-> Bool
-> Bool
-> Int
-> Int
-> Int
-> Int
-> Double
-> Int
-> Int
-> Int
scoreConnectorP ConnectorPos
Beat4 Int
tensionPct Set Int
strata Set Int
overlap Set Int
mode Set Int
chord Int
l Int
r
                                      (Int -> Bool
isStaticAt Int
i) (Int -> Bool
isSymAt Int
i)
                                      (Int -> Int
rootPCAt Int
i) (Int -> Int
p5PCAt Int
i) (Int -> Int
b3At Int
i)
                                      (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Double
e Int
seed
        in case [Int]
pool of
             [] -> Int
l
             [Int]
_  -> (Int -> Int -> Ordering) -> [Int] -> Int
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering) -> (Int -> Int) -> Int -> Int -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Int -> Int
sc) [Int]
pool
  in (Int -> (Int -> Int) -> Vector Int
forall a. Int -> (Int -> a) -> Vector a
V.generate Int
n Int -> Int
chooseBeat2, Int -> (Int -> Int) -> Vector Int
forall a. Int -> (Int -> a) -> Vector a
V.generate Int
n Int -> Int
chooseBeat4)

-- | Octatripentatonic-aware walking-bass line. Pass 1 (beat 1s from voiceFn)
-- and Pass 2 (beat 3s) are unchanged from 'walkLine'; Pass 3 (beats 2 & 4)
-- swaps the chromatic-±1 candidate path for tier-scored strata \/ overlap \/
-- mode candidates supplied per bar via 'ChromaSources'. Caller is responsible
-- for matching @length chromas@ to @progLength prog@ (mismatch falls back to
-- the legacy 'walkLine' path for safety).
walkLineP :: VoiceFunction -> Pr.Progression -> [ChromaSources] -> [[Int]]
walkLineP :: VoiceFunction -> Progression -> [ChromaSources] -> [[Int]]
walkLineP = Maybe [Double]
-> VoiceFunction -> Progression -> [ChromaSources] -> [[Int]]
walkLinePDyn Maybe [Double]
forall a. Maybe a
Nothing

-- | 'walkLineP' with the optional dynamic vector of 'walkLineDyn'.
walkLinePDyn :: Maybe [Double] -> VoiceFunction -> Pr.Progression -> [ChromaSources] -> [[Int]]
walkLinePDyn :: Maybe [Double]
-> VoiceFunction -> Progression -> [ChromaSources] -> [[Int]]
walkLinePDyn Maybe [Double]
mDyn VoiceFunction
voiceFn Progression
prog [ChromaSources]
chromas
  | Int
nBars Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0                         = []
  | [ChromaSources] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ChromaSources]
chromas Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
nBars            = Maybe [Double] -> VoiceFunction -> VoiceFunction
walkLineDyn Maybe [Double]
mDyn VoiceFunction
voiceFn Progression
prog
  | Bool
otherwise =
      [ [Vector Int
b1s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i, Vector Int
b2s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i, Vector Int
b3s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i, Vector Int
b4s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i]
      | Int
i <- [Int
0 .. Int
nBars Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ]
  where
    e :: Double
e         = Progression -> Double
progressionEntropy Progression
prog
    seed :: Int
seed      = Progression -> Double -> Int
hashProgEntropy Progression
prog Double
e

    -- Progression-level consonance scales the walk's character: consonant
    -- material anchors harder (stricter beat-3 table) and licenses less
    -- chromatic tension in the connectors; dissonant material the reverse.
    consPct :: Int
consPct    = Int
70 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
60 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Progression -> Double
progConsonance Progression
prog) :: Int
    tensionPct :: Int
tensionPct = Int
200 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
consPct

    barsV :: Vector CadenceState
barsV     = [CadenceState] -> Vector CadenceState
forall a. [a] -> Vector a
V.fromList (Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Pr.unProgression Progression
prog))
    nBars :: Int
nBars     = Vector CadenceState -> Int
forall a. Vector a -> Int
V.length Vector CadenceState
barsV

    chordPCsV :: Vector (Set Int)
chordPCsV = (CadenceState -> Set Int)
-> Vector CadenceState -> Vector (Set Int)
forall a b. (a -> b) -> Vector a -> Vector b
V.map CadenceState -> Set Int
chordPCs Vector CadenceState
barsV
    localsV :: Vector (Set Int)
localsV   = Int -> (Int -> Set Int) -> Vector (Set Int)
forall a. Int -> (Int -> a) -> Vector a
V.generate Int
nBars (Vector (Set Int) -> Int -> Set Int
localScale Vector (Set Int)
chordPCsV)
    chromasV :: Vector ChromaSources
chromasV  = [ChromaSources] -> Vector ChromaSources
forall a. [a] -> Vector a
V.fromList [ChromaSources]
chromas

    fundPCs :: Vector Int
fundPCs   = (CadenceState -> Int) -> Vector CadenceState -> Vector Int
forall a b. (a -> b) -> Vector a -> Vector b
V.map CadenceState -> Int
rootPCInt Vector CadenceState
barsV

    pcs1 :: Vector Int
pcs1      = VoiceFunction -> Progression -> Vector Int
beat1PCs VoiceFunction
voiceFn Progression
prog
    -- The octatripentatonic contract admits no tone outside the bar's
    -- chroma, and the generator enforces it for the bass too
    -- ('pcStrictContainment' disables the usual bass exemption). So the
    -- fifth offered on beat 1 must itself be chroma-resident: where the
    -- chroma has no fifth to give — a diminished bar whose natural fifth
    -- is not even in the octatripentatonic universe — the bar holds its
    -- root and a repeat displaces by octave instead.
    p5PCs :: Vector Int
p5PCs     = Int -> (Int -> Int) -> Vector Int
forall a. Int -> (Int -> a) -> Vector a
V.generate Int
nBars ((Int -> Int) -> Vector Int) -> (Int -> Int) -> Vector Int
forall a b. (a -> b) -> a -> b
$ \Int
i ->
      let fifth :: Int
fifth = CadenceState -> Int
chordFifthPC (Vector CadenceState
barsV Vector CadenceState -> Int -> CadenceState
forall a. Vector a -> Int -> a
V.! Int
i)
          ChromaSources Set Int
st Set Int
md = Vector ChromaSources
chromasV Vector ChromaSources -> Int -> ChromaSources
forall a. Vector a -> Int -> a
V.! Int
i
      in if Int
fifth Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` (Set Int
st Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Int
md)
           then Int
fifth
           else Vector Int
fundPCs Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i
    dupOdd :: Vector Bool
dupOdd    = Vector CadenceState -> Vector Bool
dupOddFlags Vector CadenceState
barsV
    (Vector Double
biasV, Vector Bool
dropV) = Int -> Maybe [Double] -> (Vector Double, Vector Bool)
dynVectors Int
nBars Maybe [Double]
mDyn
    b1s :: Vector Int
b1s       = Vector Double
-> Vector Bool
-> Vector Int
-> Vector Int
-> Vector Bool
-> Vector Int
pass1Beat1s Vector Double
biasV Vector Bool
dropV Vector Int
pcs1 Vector Int
p5PCs Vector Bool
dupOdd
    strataV :: Vector (Set Int)
strataV   = (ChromaSources -> Set Int)
-> Vector ChromaSources -> Vector (Set Int)
forall a b. (a -> b) -> Vector a -> Vector b
V.map ChromaSources -> Set Int
csStrata Vector ChromaSources
chromasV
    symV :: Vector Bool
symV      = (Set Int -> Bool) -> Vector (Set Int) -> Vector Bool
forall a b. (a -> b) -> Vector a -> Vector b
V.map Set Int -> Bool
isSymmetricChord Vector (Set Int)
chordPCsV
    emptyV :: Vector (Set a)
emptyV    = Int -> Set a -> Vector (Set a)
forall a. Int -> a -> Vector a
V.replicate Int
nBars Set a
forall a. Set a
Set.empty
    tiers :: B3Tiers
tiers     = Vector (Set Int)
-> Vector (Set Int)
-> Vector (Set Int)
-> Vector (Set Int)
-> Vector (Set Int)
-> Vector Int
-> B3Tiers
B3Tiers Vector (Set Int)
chordPCsV Vector (Set Int)
chordPCsV Vector (Set Int)
forall {a}. Vector (Set a)
emptyV Vector (Set Int)
forall {a}. Vector (Set a)
emptyV Vector (Set Int)
strataV Vector Int
p5PCs
    b3s :: Vector Int
b3s       = Int
-> Vector Bool -> B3Tiers -> Vector Int -> Vector Int -> Vector Int
pass2Beat3s Int
consPct Vector Bool
symV B3Tiers
tiers Vector Int
b1s Vector Int
fundPCs
    (Vector Int
b2s, Vector Int
b4s) = Int
-> Vector (Set Int)
-> Vector (Set Int)
-> Vector ChromaSources
-> Vector Int
-> Vector Int
-> Vector Int
-> Int
-> Double
-> (Vector Int, Vector Int)
pass3ConnectorsP Int
tensionPct Vector (Set Int)
localsV Vector (Set Int)
chordPCsV Vector ChromaSources
chromasV Vector Int
b1s Vector Int
b3s Vector Int
fundPCs Int
seed Double
e

-------------------------------------------------------------------------------
-- Jazz-vocabulary variant
-------------------------------------------------------------------------------

-- | Jazz-aware walking-bass line: 'walkLineJDyn' with no dynamics vector.
walkLineJ :: VoiceFunction -> Pr.Progression -> [J.BassVocab] -> [[Int]]
walkLineJ :: VoiceFunction -> Progression -> [BassVocab] -> [[Int]]
walkLineJ = Maybe [Double]
-> VoiceFunction -> Progression -> [BassVocab] -> [[Int]]
walkLineJDyn Maybe [Double]
forall a. Maybe a
Nothing

-- | Walking-bass line over a jazz-corpus progression, guided by per-bar
-- 'J.BassVocab' (typically @bassVocabFor . cadenceIntervals@ per bar, as
-- LineHarmony derives for FJazz contexts). Corpus tone sets describe
-- working voicings, not bass vocabulary: 13th chords omit the 5th and
-- 11th, altered qualities replace the 5th, and notated colour tones
-- (b9 \/ #9 \/ #11 \/ b13) must not land on strong beats. The vocabulary
-- restores THE fifth for every fifth-driven term, anchors strong beats on
-- 'J.bvStrong', prices 'J.bvPassing' at a middle beat-3 tier, and gates
-- the connector chord-tone bonuses on strong-plus-passing membership —
-- while the raw notated set still shapes the connector pools, so colour
-- tones remain reachable as weak-beat tension. Caller matches
-- @length vocabs@ to the progression (mismatch falls back to
-- 'walkLineDyn').
walkLineJDyn :: Maybe [Double] -> VoiceFunction -> Pr.Progression -> [J.BassVocab] -> [[Int]]
walkLineJDyn :: Maybe [Double]
-> VoiceFunction -> Progression -> [BassVocab] -> [[Int]]
walkLineJDyn Maybe [Double]
mDyn VoiceFunction
voiceFn Progression
prog [BassVocab]
vocabs
  | Int
nBars Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0              = []
  | [BassVocab] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BassVocab]
vocabs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
nBars  = Maybe [Double] -> VoiceFunction -> VoiceFunction
walkLineDyn Maybe [Double]
mDyn VoiceFunction
voiceFn Progression
prog
  | Bool
otherwise =
      [ [Vector Int
b1s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i, Vector Int
b2s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i, Vector Int
b3s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i, Vector Int
b4s Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i]
      | Int
i <- [Int
0 .. Int
nBars Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ]
  where
    e :: Double
e         = Progression -> Double
progressionEntropy Progression
prog
    seed :: Int
seed      = Progression -> Double -> Int
hashProgEntropy Progression
prog Double
e

    consPct :: Int
consPct    = Int
70 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
60 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Progression -> Double
progConsonance Progression
prog) :: Int
    tensionPct :: Int
tensionPct = Int
200 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
consPct

    barsV :: Vector CadenceState
barsV     = [CadenceState] -> Vector CadenceState
forall a. [a] -> Vector a
V.fromList (Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Pr.unProgression Progression
prog))
    nBars :: Int
nBars     = Vector CadenceState -> Int
forall a. Vector a -> Int
V.length Vector CadenceState
barsV
    vocabV :: Vector BassVocab
vocabV    = [BassVocab] -> Vector BassVocab
forall a. [a] -> Vector a
V.fromList [BassVocab]
vocabs

    chordPCsV :: Vector (Set Int)
chordPCsV = (CadenceState -> Set Int)
-> Vector CadenceState -> Vector (Set Int)
forall a b. (a -> b) -> Vector a -> Vector b
V.map CadenceState -> Set Int
chordPCs Vector CadenceState
barsV
    localsV :: Vector (Set Int)
localsV   = Int -> (Int -> Set Int) -> Vector (Set Int)
forall a. Int -> (Int -> a) -> Vector a
V.generate Int
nBars (Vector (Set Int) -> Int -> Set Int
localScale Vector (Set Int)
chordPCsV)
    fundPCs :: Vector Int
fundPCs   = (CadenceState -> Int) -> Vector CadenceState -> Vector Int
forall a b. (a -> b) -> Vector a -> Vector b
V.map CadenceState -> Int
rootPCInt Vector CadenceState
barsV

    absSet :: Int -> [Int] -> Set Int
absSet Int
i [Int]
xs = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList [ ((Vector Int
fundPCs Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12 | Int
x <- [Int]
xs ]
    -- The triadic core is what a line aims AT; sevenths and extensions are
    -- colour that shapes the route. Targets drive the beat-2 anchor
    -- preference, strong tones stay legal on strong beats, and the bar's
    -- own extensions widen the palette that feeds passing selection.
    targetV :: Vector (Set Int)
targetV   = Int -> (Int -> Set Int) -> Vector (Set Int)
forall a. Int -> (Int -> a) -> Vector a
V.generate Int
nBars (\Int
i -> Int -> [Int] -> Set Int
absSet Int
i (BassVocab -> [Int]
J.bvTarget  (Vector BassVocab
vocabV Vector BassVocab -> Int -> BassVocab
forall a. Vector a -> Int -> a
V.! Int
i)))
    strongV :: Vector (Set Int)
strongV   = Int -> (Int -> Set Int) -> Vector (Set Int)
forall a. Int -> (Int -> a) -> Vector a
V.generate Int
nBars (\Int
i -> Int -> [Int] -> Set Int
absSet Int
i (BassVocab -> [Int]
J.bvStrong  (Vector BassVocab
vocabV Vector BassVocab -> Int -> BassVocab
forall a. Vector a -> Int -> a
V.! Int
i)))
    passV :: Vector (Set Int)
passV     = Int -> (Int -> Set Int) -> Vector (Set Int)
forall a. Int -> (Int -> a) -> Vector a
V.generate Int
nBars (\Int
i -> Int -> [Int] -> Set Int
absSet Int
i (BassVocab -> [Int]
J.bvPassing (Vector BassVocab
vocabV Vector BassVocab -> Int -> BassVocab
forall a. Vector a -> Int -> a
V.! Int
i)))
    avoidV :: Vector (Set Int)
avoidV    = Int -> (Int -> Set Int) -> Vector (Set Int)
forall a. Int -> (Int -> a) -> Vector a
V.generate Int
nBars (\Int
i -> Int -> [Int] -> Set Int
absSet Int
i (BassVocab -> [Int]
J.bvAvoid   (Vector BassVocab
vocabV Vector BassVocab -> Int -> BassVocab
forall a. Vector a -> Int -> a
V.! Int
i)))
    gatesV :: Vector (Set Int)
gatesV    = (Set Int -> Set Int -> Set Int)
-> Vector (Set Int) -> Vector (Set Int) -> Vector (Set Int)
forall a b c. (a -> b -> c) -> Vector a -> Vector b -> Vector c
V.zipWith Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
Set.union Vector (Set Int)
strongV Vector (Set Int)
passV
    p5PCs :: Vector Int
p5PCs     = Int -> (Int -> Int) -> Vector Int
forall a. Int -> (Int -> a) -> Vector a
V.generate Int
nBars
                  (\Int
i -> ((Vector Int
fundPCs Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ BassVocab -> Int
J.bvFifth (Vector BassVocab
vocabV Vector BassVocab -> Int -> BassVocab
forall a. Vector a -> Int -> a
V.! Int
i)) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12)
    -- Symmetry is a property of the sounding set, not the vocabulary.
    symV :: Vector Bool
symV      = (Set Int -> Bool) -> Vector (Set Int) -> Vector Bool
forall a b. (a -> b) -> Vector a -> Vector b
V.map Set Int -> Bool
isSymmetricChord Vector (Set Int)
chordPCsV

    pcs1 :: Vector Int
pcs1      = VoiceFunction -> Progression -> Vector Int
beat1PCs VoiceFunction
voiceFn Progression
prog
    dupOdd :: Vector Bool
dupOdd    = Vector CadenceState -> Vector Bool
dupOddFlags Vector CadenceState
barsV
    (Vector Double
biasV, Vector Bool
dropV) = Int -> Maybe [Double] -> (Vector Double, Vector Bool)
dynVectors Int
nBars Maybe [Double]
mDyn
    b1s :: Vector Int
b1s       = Vector Double
-> Vector Bool
-> Vector Int
-> Vector Int
-> Vector Bool
-> Vector Int
pass1Beat1s Vector Double
biasV Vector Bool
dropV Vector Int
pcs1 Vector Int
p5PCs Vector Bool
dupOdd
    -- Two palettes, deliberately different widths. The WIDE one feeds the
    -- beat-3 pool: the bar's own chord tones join the key-area scale so
    -- notated colour stays reachable even on a gap bar whose set cannot
    -- contain the whole chord (avoid tones are subtracted inside
    -- pass2Beat3s). The NARROW one — the bar's key-area scale itself
    -- (its key form, or the override mode where the chord escapes every
    -- form) — is what Pass 3's minor-thirds rule sees: on that bar those
    -- tones ARE the scale, so the fill bonus is theirs, while fully
    -- chromatic midpoints still pay the entropy-scaled price. Spot-tested
    -- against a pure-form narrow variant (archive/analysis/mt_narrow.md):
    -- zero walked beats distinguish the two on override-heavy material,
    -- so the single palette source is kept.
    keyNarrowV :: Vector (Set Int)
keyNarrowV = Progression -> Vector (Set Int)
barPalettes Progression
prog
    keyWideV :: Vector (Set Int)
keyWideV   = (Set Int -> Set Int -> Set Int)
-> Vector (Set Int) -> Vector (Set Int) -> Vector (Set Int)
forall a b c. (a -> b -> c) -> Vector a -> Vector b -> Vector c
V.zipWith Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
Set.union Vector (Set Int)
keyNarrowV Vector (Set Int)
chordPCsV
    tiers :: B3Tiers
tiers     = Vector (Set Int)
-> Vector (Set Int)
-> Vector (Set Int)
-> Vector (Set Int)
-> Vector (Set Int)
-> Vector Int
-> B3Tiers
B3Tiers Vector (Set Int)
targetV Vector (Set Int)
strongV Vector (Set Int)
passV Vector (Set Int)
avoidV Vector (Set Int)
keyWideV Vector Int
p5PCs
    b3s :: Vector Int
b3s       = Int
-> Vector Bool -> B3Tiers -> Vector Int -> Vector Int -> Vector Int
pass2Beat3s Int
consPct Vector Bool
symV B3Tiers
tiers Vector Int
b1s Vector Int
fundPCs
    (Vector Int
b2s, Vector Int
b4s) = Int
-> Vector (Set Int)
-> Vector (Set Int)
-> Vector Bool
-> Vector (Set Int)
-> Vector (Set Int)
-> Vector Int
-> Vector Int
-> Vector Int
-> Vector Int
-> Int
-> Double
-> (Vector Int, Vector Int)
pass3Connectors Int
tensionPct Vector (Set Int)
keyNarrowV Vector (Set Int)
localsV Vector Bool
symV Vector (Set Int)
gatesV Vector (Set Int)
strongV Vector Int
p5PCs Vector Int
b1s Vector Int
b3s Vector Int
fundPCs Int
seed Double
e