-- |
-- 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 a chord tone minimising smoothness
--      to b1_i plus smoothness to b1_{i+1} plus consonance-to-fund cost
--      (via @beat3ConsTable@). 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.

{-# LANGUAGE MultiWayIf #-}
module Harmonic.Traversal.WalkingBass
  ( -- * Main entry
    walkLine
  , walkLineP
  , walkLineDyn
  , walkLinePDyn
  , ChromaSources(..)

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

    -- * 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 (foldl', minimumBy)
import Data.Function (on)
import Data.Bits (xor)
import Data.Foldable (toList)
import Data.Word (Word64)
import GHC.Float (castDoubleToWord64)
import System.Random (mkStdGen, randoms)

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.Interface.Tidal.Bridge (VoiceFunction)

-------------------------------------------------------------------------------
-- 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 non-chord surcharge. Beat 3's pool admits regional-key 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 regional-key diatonic one
-- (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 ]

-- | 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
      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
30) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
60)
    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 (walk-internal)
-------------------------------------------------------------------------------

-- | Per-bar regional key centre, inferred from chord qualities over a local
-- window.
--
-- BOUNDARY: this is a PURE, DERIVED quantity computed over a finished
-- progression, consumed only inside the walk's connector selection. The
-- generation system deliberately operates without key awareness — each
-- state is abstract and deterministic, upholding the Markov property —
-- so this function must never feed back into generation, become part of
-- any state, or appear in a generation-path signature.
--
-- Heuristics (weights in votes): a dominant-quality chord is V of its key;
-- a major-quality chord is I (strong) or IV (weak), plain major triads also
-- V (weak); a minor-quality chord is ii (strong), vi, or iii (weak);
-- half-diminished is vii. Relative major\/minor are treated as one pool and
-- reported as the major-pool pitch class. Each bar takes the key with the
-- highest vote total over the surrounding window (cyclic, +/- 2 bars);
-- ties resolve to the lowest pitch class.
inferKeyCentre :: Pr.Progression -> [Pt.PitchClass]
inferKeyCentre :: Progression -> [PitchClass]
inferKeyCentre Progression
prog =
  [ Int -> PitchClass
Pt.mkPitchClass (Int -> Int
bestFor Int
i) | Int
i <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ]
  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

    -- (key offset from chord root, votes) per quality class.
    votesFor :: CadenceState -> [(Int, b)]
votesFor CadenceState
cs =
      let r :: Int
r   = CadenceState -> Int
rootPCInt CadenceState
cs
          ivs :: Set Int
ivs = [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
cs) ]
          has :: Int -> Bool
has = (Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
ivs)
          offsets :: [(Int, b)]
offsets
            | Int -> Bool
has Int
4 Bool -> Bool -> Bool
&& Int -> Bool
has Int
10            = [(Int
5, b
6)]                    -- V7
            | Int -> Bool
has Int
4 Bool -> Bool -> Bool
&& Int -> Bool
has Int
11            = [(Int
0, b
4), (Int
7, b
2)]            -- Imaj7 / IVmaj7
            | Int -> Bool
has Int
3 Bool -> Bool -> Bool
&& Int -> Bool
has Int
6             = [(Int
1, b
4)]                    -- vii (half-dim pool)
            | Int -> Bool
has Int
3 Bool -> Bool -> Bool
&& Int -> Bool
has Int
10            = [(Int
10, b
4), (Int
3, b
3), (Int
8, b
2)]   -- ii / vi / iii
            | Int -> Bool
has Int
3                      = [(Int
10, b
4), (Int
3, b
3), (Int
8, b
2)]   -- minor triad
            | Int -> Bool
has Int
4                      = [(Int
0, b
4), (Int
7, b
2), (Int
5, b
2)]    -- major triad: I / IV / V
            | Bool
otherwise                  = []
      in [ ((Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
off) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12, b
w) | (Int
off, b
w) <- [(Int, b)]
offsets ]

    -- Distinct bar indices only: on progressions shorter than the window
    -- the cyclic wrap must not count any bar's votes twice.
    windowVotes :: Int -> [(Int, b)]
windowVotes Int
i =
      let idxs :: [Int]
idxs = Set Int -> [Int]
forall a. Set a -> [a]
Set.toList ([Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList [ (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
n | Int
d <- [-Int
2 .. Int
2] ])
      in [[(Int, b)]] -> [(Int, b)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ CadenceState -> [(Int, b)]
forall {b}. Num b => CadenceState -> [(Int, b)]
votesFor (Vector CadenceState
bars Vector CadenceState -> Int -> CadenceState
forall a. Vector a -> Int -> a
V.! Int
j) | Int
j <- [Int]
idxs ]

    bestFor :: Int -> Int
bestFor Int
i =
      let votes :: [(Int, Integer)]
votes     = Int -> [(Int, Integer)]
forall {b}. Num b => Int -> [(Int, b)]
windowVotes Int
i
          total :: Int -> Integer
total Int
key = [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ Integer
w | (Int
k, Integer
w) <- [(Int, Integer)]
votes, Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
key ]
      in (Integer, Int) -> Int
forall a b. (a, b) -> b
snd ([(Integer, Int)] -> (Integer, Int)
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [ (Integer -> Integer
forall a. Num a => a -> a
negate (Int -> Integer
total Int
key), Int
key) | Int
key <- [Int
0 .. Int
11 :: Int] ])

-------------------------------------------------------------------------------
-- 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)))
  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, 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.
pass2Beat3s :: Int -> V.Vector (Set Int) -> V.Vector (Set Int) -> V.Vector Int -> V.Vector Int -> V.Vector Int
pass2Beat3s :: Int
-> Vector (Set Int)
-> Vector (Set Int)
-> Vector Int
-> Vector Int
-> Vector Int
pass2Beat3s Int
consPct Vector (Set Int)
keyV Vector (Set Int)
chordPCsV 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 chord :: Set Int
chord  = Vector (Set Int)
chordPCsV Vector (Set Int) -> Int -> Set Int
forall a. Vector a -> Int -> a
V.! Int
i
            sym :: Bool
sym    = Set Int -> Bool
isSymmetricChord Set Int
chord
            pool :: [Int]
pool   = Vector Int -> [Int]
forall a. Vector a -> [a]
V.toList (Set Int -> Vector Int
midisIn (Set Int
chord Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` (Vector (Set Int)
keyV Vector (Set Int) -> Int -> Set Int
forall a. Vector a -> Int -> a
V.! Int
i)))
            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)
                  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
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))
                              Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100
                  nchP :: Int
nchP = 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
chord then Int
0
                         else 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] -> Double
forall a. HasCallStack => [a] -> a
head (StdGen -> [Double]
forall g. RandomGen g => g -> [Double]
forall a g. (Random a, RandomGen g) => g -> [a]
randoms (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])

-- | 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        -- regional-key major-scale PCs (Minor Thirds Rule)
  -> Set Int        -- localScale_i (cyclic)
  -> Set Int        -- chordPCs_i
  -> 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
-> 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 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
      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 (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)   -- regional-key major-scale PCs per bar
  -> V.Vector (Set Int)   -- local scales
  -> V.Vector (Set Int)   -- chord PCs
  -> 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 (Set 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 (Set Int)
chordsV 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
      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)
chordsV 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
-> 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 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)
chordsV 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
-> 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 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     = (Int -> Int) -> Vector Int -> Vector Int
forall a b. (a -> b) -> Vector a -> Vector b
V.map (\Int
r -> (Int
r 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) Vector Int
fundPCs
    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
    -- Per-bar tonal palette (derived, walk-internal). Minor-turnaround
    -- bars modulate internally, so chord QUALITY overrides the regional
    -- key: a half-diminished bar takes the harmonic minor of the tonic a
    -- whole step below (ii of minor); an altered dominant (b9/#9) takes
    -- its altered scale (melodic minor a semitone up); a plain dominant
    -- resolving up a fourth to a minor chord takes the target's harmonic
    -- minor. All other bars take the major scale of the regional centre
    -- from 'inferKeyCentre'. Purely local and deterministic — the Markov
    -- boundary of 'inferKeyCentre' applies to the palettes too.
    keySetsV :: Vector (Set Int)
keySetsV  = [Set Int] -> Vector (Set Int)
forall a. [a] -> Vector a
V.fromList
      [ Int -> PitchClass -> Set Int
barPalette Int
i PitchClass
k
      | (Int
i, PitchClass
k) <- [Int] -> [PitchClass] -> [(Int, PitchClass)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] (Progression -> [PitchClass]
inferKeyCentre Progression
prog) ]
    barPalette :: Int -> PitchClass -> Set Int
barPalette Int
i PitchClass
k =
      let cs :: CadenceState
cs      = Vector CadenceState
barsV Vector CadenceState -> Int -> CadenceState
forall a. Vector a -> Int -> a
V.! Int
i
          r :: Int
r       = CadenceState -> Int
rootPCInt CadenceState
cs
          ivs :: Set Int
ivs     = [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
cs) ]
          has :: Int -> Bool
has     = (Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
ivs)
          nextCs :: CadenceState
nextCs  = Vector CadenceState
barsV Vector CadenceState -> Int -> CadenceState
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
nBars)
          nextR :: Int
nextR   = CadenceState -> Int
rootPCInt CadenceState
nextCs
          nextIvs :: Set Int
nextIvs = [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
nextCs) ]
          scaleAt :: a -> [a] -> Set a
scaleAt a
base [a]
steps = [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList [ (a
base a -> a -> a
forall a. Num a => a -> a -> a
+ a
st) a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
12 | a
st <- [a]
steps ]
          harmMinor :: a -> Set a
harmMinor a
t = a -> [a] -> Set a
forall {a}. Integral a => a -> [a] -> Set a
scaleAt a
t [a
0, a
2, a
3, a
5, a
7, a
8, a
11]
          altered :: Set Int
altered     = Int -> [Int] -> Set Int
forall {a}. Integral a => a -> [a] -> Set a
scaleAt Int
r [Int
0, Int
1, Int
3, Int
4, Int
6, Int
8, Int
10]
          domToMinor :: Bool
domToMinor  = Int -> Bool
has Int
4 Bool -> Bool -> Bool
&& Int -> Bool
has Int
10
                        Bool -> Bool -> Bool
&& (Int
nextR Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5
                        Bool -> Bool -> Bool
&& Int
3 Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
nextIvs
      in if | Int -> Bool
has Int
3 Bool -> Bool -> Bool
&& Int -> Bool
has Int
6            -> Int -> Set Int
forall {a}. Integral a => a -> Set a
harmMinor ((Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12)
            | Int -> Bool
has Int
4 Bool -> Bool -> Bool
&& Int -> Bool
has Int
10
                Bool -> Bool -> Bool
&& (Int -> Bool
has Int
1 Bool -> Bool -> Bool
|| Int -> Bool
has Int
3)     -> Set Int
altered
            | Bool
domToMinor                -> Int -> Set Int
forall {a}. Integral a => a -> Set a
harmMinor ((Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
5) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12)
            | Bool
otherwise                 -> Int -> [Int] -> Set Int
forall {a}. Integral a => a -> [a] -> Set a
scaleAt (PitchClass -> Int
Pt.unPitchClass PitchClass
k)
                                             [Int
0, Int
2, Int
4, Int
5, Int
7, Int
9, Int
11]

    b3s :: Vector Int
b3s       = Int
-> Vector (Set Int)
-> Vector (Set Int)
-> Vector Int
-> Vector Int
-> Vector Int
pass2Beat3s Int
consPct Vector (Set Int)
keySetsV Vector (Set Int)
chordPCsV Vector Int
b1s Vector Int
fundPCs
    (Vector Int
b2s, Vector Int
b4s) = Int
-> Vector (Set Int)
-> Vector (Set Int)
-> Vector (Set 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 (Set Int)
chordPCsV 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
    p5PCs :: Vector Int
p5PCs     = (Int -> Int) -> Vector Int -> Vector Int
forall a b. (a -> b) -> Vector a -> Vector b
V.map (\Int
r -> (Int
r 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) Vector Int
fundPCs
    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
    b3s :: Vector Int
b3s       = Int
-> Vector (Set Int)
-> Vector (Set Int)
-> Vector Int
-> Vector Int
-> Vector Int
pass2Beat3s Int
consPct Vector (Set Int)
strataV Vector (Set Int)
chordPCsV 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