-- |
-- Module      : Harmonic.Framework.Builder.Core
-- Description : Core generation engine for harmonic progressions
--
-- Internal chain building, candidate pool construction, R-constraint filtering,
-- consonance fallback generation, state advancement, and progression conversion.
-- Online vs offline is a 'TransitionSource' argument, not a code path:
-- one chain builder serves every family and both modes.

module Harmonic.Framework.Builder.Core
  ( -- * The transition seam
    TransitionSource
  , offlineSource
  , classicalSource
  , sourceFor

    -- * Chain building (one builder, any source)
  , buildChainWith
  , stepChainWith

    -- * Conversion
  , chainToProgression
  , extractCadence

    -- * Filtering (exposed for testing)
  , matchesContextWithTarget
  , applyDriftFilter
  , applyPedalFilter
  , resolveBassDirection

    -- * Context-aware starting cue
  , tonalStartCue
  , rootPositionCue
  , directionViolations
  ) where

import qualified Data.Text as T
import qualified Data.IntSet as IntSet
import           Control.Monad (foldM)
import           Data.List (sortBy, sort, nub, isInfixOf)
import           Data.Foldable (toList)
import           Data.Function (on)
import           Data.Ord (Down(..))
import           System.Random.MWC (GenIO, uniform, uniformR, createSystemRandom)
import qualified System.Random.MWC.Distributions as Dist

import qualified Harmonic.Rules.Types.Harmony as H
import qualified Harmonic.Rules.Types.Pitch as P
import qualified Harmonic.Rules.Types.Progression as Prog
import qualified Data.Map.Strict as Map
import           Data.IORef (IORef, newIORef, readIORef, writeIORef)
import qualified Data.Set as Set
import           Harmonic.Database (DbConn, runDb, connectNeo4j)
import           Harmonic.Evaluation.Database.Query (ComposerWeights)
import qualified Harmonic.Evaluation.Database.Query as Q
import           Harmonic.Traversal.Probabilistic (gammaIndexScaledWith)
import           Harmonic.Rules.Constraints.Filter (nthAbove, nthBelow)
import           Harmonic.Rules.Constraints.Overtone (overtoneSets, possibleTriads)
import           Harmonic.Evaluation.Scoring.Dissonance (dissonanceScore)
import qualified Harmonic.Evaluation.Scoring.Dissonance as D

import           Harmonic.Framework.Builder.Types
import           Harmonic.Framework.Builder.Diagnostics (computeChordTrace)

-------------------------------------------------------------------------------
-- Chain Building (Inside DbActionT)
-------------------------------------------------------------------------------

-- |How a walk key resolves to scored transitions: THE seam between the
-- step engine and any particular graph (or none). Sources return
-- positive scores sorted highest first — exactly the contract
-- @stepChainBody@ documents for its @transitions@ argument.
type TransitionSource = T.Text -> IO [(H.Cadence, Double)]

-- |The no-graph source: every step's pool is the consonance fallback
-- alone. This IS offline mode — nothing else distinguishes it.
offlineSource :: TransitionSource
offlineSource :: TransitionSource
offlineSource Text
_ = [(Cadence, Double)] -> IO [(Cadence, Double)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- |The classical @Cadence@ graph under a composer blend: the aggregate
-- fast path for the wildcard (empty) blend, the full weights fetch and
-- blend resolution otherwise.
classicalSource :: DbConn -> ComposerWeights -> TransitionSource
classicalSource :: DbConn -> ComposerWeights -> TransitionSource
classicalSource DbConn
conn ComposerWeights
weights Text
key
  | ComposerWeights -> Bool
forall k a. Map k a -> Bool
Map.null ComposerWeights
weights = DbConn -> DbActionT [(Cadence, Double)] -> IO [(Cadence, Double)]
forall a. DbConn -> DbActionT a -> IO a
runDb DbConn
conn (Text -> DbActionT [(Cadence, Double)]
Q.fetchTransitionsAggregate Text
key)
  | Bool
otherwise        = DbConn -> DbActionT [(Cadence, Double)] -> IO [(Cadence, Double)]
forall a. DbConn -> DbActionT a -> IO a
runDb DbConn
conn (ComposerWeights
-> [(Cadence, ComposerWeights)] -> [(Cadence, Double)]
forall a.
ComposerWeights -> [(a, ComposerWeights)] -> [(a, Double)]
Q.applyComposerBlend ComposerWeights
weights ([(Cadence, ComposerWeights)] -> [(Cadence, Double)])
-> ReaderT DbConn IO [(Cadence, ComposerWeights)]
-> DbActionT [(Cadence, Double)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ReaderT DbConn IO [(Cadence, ComposerWeights)]
Q.fetchTransitions Text
key)

-- |Resolve a seek string to its 'TransitionSource': @"none"@ (case-
-- insensitive) is 'offlineSource'; anything else opens the database and
-- blends per 'Q.parseComposerWeights'.
--
-- A named blend is additionally spell-checked against the graph as the
-- walk runs: a name that has not appeared on any fetched edge after a
-- few steps is reported once (a typo'd composer otherwise zeroes its
-- share silently and the walk quietly degrades toward fallback).
sourceFor :: T.Text -> IO TransitionSource
sourceFor :: Text -> IO TransitionSource
sourceFor Text
seekStr
  | Text -> Text
T.toLower (Text -> Text
T.strip Text
seekStr) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"none" = TransitionSource -> IO TransitionSource
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TransitionSource
offlineSource
  | Bool
otherwise = do
      conn <- IO DbConn
connectNeo4j
      let blend = Text -> ComposerWeights
Q.parseComposerWeights Text
seekStr
      if Map.null blend
        then pure (classicalSource conn blend)
        else do
          ref <- newIORef (Map.keysSet blend, 0 :: Int)
          pure (spellcheckedSource ref conn blend)

-- Wraps 'classicalSource' with the unseen-name tracker: each fetch
-- crosses off blend names present on any returned edge; after
-- 'spellcheckFetches' fetches, survivors are reported once (weights are
-- sparse per edge, so a single node proves nothing — a few steps of
-- absence is strong evidence of a typo, and the message says which).
spellcheckedSource :: IORef (Set.Set T.Text, Int) -> DbConn -> ComposerWeights -> TransitionSource
spellcheckedSource :: IORef (Set Text, Int)
-> DbConn -> ComposerWeights -> TransitionSource
spellcheckedSource IORef (Set Text, Int)
ref DbConn
conn ComposerWeights
blend Text
key = do
  rows <- DbConn
-> ReaderT DbConn IO [(Cadence, ComposerWeights)]
-> IO [(Cadence, ComposerWeights)]
forall a. DbConn -> DbActionT a -> IO a
runDb DbConn
conn (Text -> ReaderT DbConn IO [(Cadence, ComposerWeights)]
Q.fetchTransitions Text
key)
  (unseen, n) <- readIORef ref
  if Set.null unseen
    then pure ()
    else do
      let seen    = [Set Text] -> Set Text
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [ ComposerWeights -> Set Text
forall k a. Map k a -> Set k
Map.keysSet ComposerWeights
w | (Cadence
_, ComposerWeights
w) <- [(Cadence, ComposerWeights)]
rows ]
          unseen' = Set Text
unseen Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Text
seen
          n'      = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
      if n' >= spellcheckFetches && not (Set.null unseen')
        then do
          putStrLn $ "⚠ seek: " ++ show (map T.unpack (Set.toList unseen'))
                   ++ " matched no composer on any edge of the first "
                   ++ show n' ++ " steps — check the spelling against"
                   ++ " documents/COMPOSERS.md (walk continues; their"
                   ++ " share contributes nothing)"
          writeIORef ref (Set.empty, n')
        else writeIORef ref (unseen', n')
  pure (Q.applyComposerBlend blend rows)

-- Fetches to observe before calling a never-seen blend name a typo.
spellcheckFetches :: Int
spellcheckFetches :: Int
spellcheckFetches = Int
3

-- |Build the cadence chain step by step against any 'TransitionSource'.
--
-- The one chain builder: online\/offline is the source argument, fixed
-- vs per-bar R-context is the supplier argument (@const pctx@ for the
-- plain families; 'Harmonic.Framework.Builder.genP' narrows overtones
-- per bar), diagnostics collection is the verbosity argument (@Nothing@
-- skips construction entirely; @Just 1@ standard, @Just 2@ maximum).
--
-- Algorithm per step: fetch the walk key's transitions from the source
-- (the key is the current state's most-consonant rooted embedded triad —
-- identity for triads, so the walk never silently goes offline on
-- cardinality), then delegate the full R-filter\/scoring\/selection
-- logic to @stepChainBody@ (pool = graph candidates + unlimited
-- consonance fallback).
buildChainWith :: TransitionSource
               -> GenIO                    -- ^ Shared random generator
               -> Maybe Int                -- ^ Diagnostics verbosity (Nothing \/ Just 1 \/ Just 2)
               -> Double                   -- ^ Entropy (>= 0; rank-target dial)
               -> HarmonicContext
               -> (Int -> ParsedContext)   -- ^ Bar index (1-based) -> R context for that bar
               -> H.CadenceState           -- ^ Starting state
               -> Int                      -- ^ Number of steps to generate
               -> IO ([H.CadenceState], [StepDiagnostic])
buildChainWith :: TransitionSource
-> GenIO
-> Maybe Int
-> Double
-> HarmonicContext
-> (Int -> ParsedContext)
-> CadenceState
-> Int
-> IO ([CadenceState], [StepDiagnostic])
buildChainWith TransitionSource
source GenIO
gen Maybe Int
mVerbosity Double
ent HarmonicContext
context Int -> ParsedContext
pctxAt CadenceState
start Int
totalSteps = do
  let initCounter :: Int
initCounter = if Cadence -> Bool
H.isInversion (CadenceState -> Cadence
H.stateCadence CadenceState
start) then Int
0 else Int
1
  ((_current, revChain, _counter), revDiags) <-
    (((CadenceState, [CadenceState], Int), [StepDiagnostic])
 -> Int
 -> IO ((CadenceState, [CadenceState], Int), [StepDiagnostic]))
-> ((CadenceState, [CadenceState], Int), [StepDiagnostic])
-> [Int]
-> IO ((CadenceState, [CadenceState], Int), [StepDiagnostic])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\((CadenceState, [CadenceState], Int), [StepDiagnostic])
acc Int
i -> TransitionSource
-> GenIO
-> Maybe Int
-> Double
-> HarmonicContext
-> ParsedContext
-> ((CadenceState, [CadenceState], Int), [StepDiagnostic])
-> Int
-> IO ((CadenceState, [CadenceState], Int), [StepDiagnostic])
stepChainWith TransitionSource
source GenIO
gen Maybe Int
mVerbosity Double
ent HarmonicContext
context (Int -> ParsedContext
pctxAt Int
i) ((CadenceState, [CadenceState], Int), [StepDiagnostic])
acc Int
i)
          ((CadenceState
start, [CadenceState
start], Int
initCounter), [])
          [Int
1..Int
totalSteps]
  pure (reverse revChain, reverse revDiags)

-- |One step against a 'TransitionSource': fetch, then @stepChainBody@.
stepChainWith :: TransitionSource
              -> GenIO
              -> Maybe Int
              -> Double
              -> HarmonicContext
              -> ParsedContext
              -> ((H.CadenceState, [H.CadenceState], Int), [StepDiagnostic])
              -> Int
              -> IO ((H.CadenceState, [H.CadenceState], Int), [StepDiagnostic])
stepChainWith :: TransitionSource
-> GenIO
-> Maybe Int
-> Double
-> HarmonicContext
-> ParsedContext
-> ((CadenceState, [CadenceState], Int), [StepDiagnostic])
-> Int
-> IO ((CadenceState, [CadenceState], Int), [StepDiagnostic])
stepChainWith TransitionSource
source GenIO
gen Maybe Int
mVerbosity Double
ent HarmonicContext
context ParsedContext
pctx acc :: ((CadenceState, [CadenceState], Int), [StepDiagnostic])
acc@((CadenceState
current, [CadenceState]
_, Int
_), [StepDiagnostic]
_) Int
stepNum = do
  scored <- TransitionSource
source ([Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Cadence -> [Char]
forall a. Show a => a -> [Char]
show (CadenceState -> Cadence
extractCadence (CadenceState -> CadenceState
H.walkTriadState CadenceState
current)))
  stepChainBody gen mVerbosity ent context pctx acc stepNum scored


-- |Resolve a 'BassDirectionSpec' into a concrete 'BassDirection' for a
-- single generation step. Returns 'Nothing' when no spec is active, or
-- when the spec's optional @?@ flag caused the coin flip to come up tails.
--
-- Rotation (@BDRotate@) cycles through the choices by @stepNum@ (1-based).
-- Random pick (@BDRandomPick@) samples uniformly from the choices.
resolveBassDirection
  :: GenIO -> Int -> Maybe BassDirectionSpec -> IO (Maybe BassDirection)
resolveBassDirection :: GenIO -> Int -> Maybe BassDirectionSpec -> IO (Maybe BassDirection)
resolveBassDirection GenIO
_   Int
_       Maybe BassDirectionSpec
Nothing     = Maybe BassDirection -> IO (Maybe BassDirection)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe BassDirection
forall a. Maybe a
Nothing
resolveBassDirection GenIO
gen Int
stepNum (Just BassDirectionSpec
spec) = do
  active <- if BassDirectionSpec -> Bool
bdsOptional BassDirectionSpec
spec
              then do
                r <- GenIO -> IO Double
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
Gen (PrimState m) -> m a
forall (m :: * -> *). PrimMonad m => Gen (PrimState m) -> m Double
uniform GenIO
gen :: IO Double
                pure (r < 0.5)
              else Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  if not active
    then pure Nothing
    else do
      let cs = BassDirectionSpec -> [Int]
bdsChoices BassDirectionSpec
spec
      n <- case bdsSelector spec of
        -- bdsChoices is non-empty by parser construction; 1 = the bare
        -- rise/fall default, unreachable here.
        BDSelector
BDFixed      -> Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (case [Int]
cs of { (Int
c : [Int]
_) -> Int
c; [] -> Int
1 })
        BDSelector
BDRotate     -> Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Int]
cs [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! ((Int
stepNum Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
cs))
        BDSelector
BDRandomPick -> do
          i <- (Int, Int) -> GenIO -> IO Int
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
(a, a) -> Gen (PrimState m) -> m a
forall (m :: * -> *).
PrimMonad m =>
(Int, Int) -> Gen (PrimState m) -> m Int
uniformR (Int
0, [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
cs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) GenIO
gen
          pure (cs !! i)
      pure $ Just $ case bdsKind spec of
        BDKind
RiseK -> Int -> BassDirection
Rise Int
n
        BDKind
FallK -> Int -> BassDirection
Fall Int
n

-- |Core body for a single chain-building step (plain IO, no database dependency).
--
-- Takes pre-fetched transitions and executes the full filtering\/scoring\/selection logic.
-- Used by 'stepChainWith' for every family and mode (the source argument
-- decides online vs offline).
-- When transitions is empty (offline mode), generation relies entirely on the consonance fallback.
stepChainBody :: GenIO
              -> Maybe Int        -- ^ Nothing = no diagnostics, Just n = verbosity level
              -> Double           -- ^ Entropy [0,1]
              -> HarmonicContext
              -> ParsedContext
              -> ((H.CadenceState, [H.CadenceState], Int), [StepDiagnostic])
              -> Int
              -> [(H.Cadence, Double)]   -- ^ Pre-scored transitions, sorted desc (empty for offline)
              -> IO ((H.CadenceState, [H.CadenceState], Int), [StepDiagnostic])
stepChainBody :: GenIO
-> Maybe Int
-> Double
-> HarmonicContext
-> ParsedContext
-> ((CadenceState, [CadenceState], Int), [StepDiagnostic])
-> Int
-> [(Cadence, Double)]
-> IO ((CadenceState, [CadenceState], Int), [StepDiagnostic])
stepChainBody GenIO
gen Maybe Int
mVerbosity Double
ent HarmonicContext
_context ParsedContext
pctx ((CadenceState
current, [CadenceState]
revChain, Int
nonInvCount), [StepDiagnostic]
revDiags) Int
stepNum [(Cadence, Double)]
transitions = do
  -- Walk shadow: all stage-1 machinery runs against the current state's
  -- most-consonant rooted embedded triad, so drift comparisons stay
  -- triad-vs-triad and graph keys stay corpus-shaped. Identity for every
  -- <=3-interval state — it bites only when a >3-note bar seeds a walk
  -- (regen of hand-built extended material via 'genFrom').
  let walkCur :: CadenceState
walkCur = CadenceState -> CadenceState
H.walkTriadState CadenceState
current

  -- Resolve bass direction for this step (may consume randomness for
  -- optional @?@ tokens and for BDRandomPick comma-list selectors)
  mDir <- GenIO -> Int -> Maybe BassDirectionSpec -> IO (Maybe BassDirection)
resolveBassDirection GenIO
gen Int
stepNum (ParsedContext -> Maybe BassDirectionSpec
pcBassDirectionSpec ParsedContext
pctx)
  let prevBassPC = PitchClass -> Int
P.unPitchClass (NoteName -> PitchClass
P.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
current))
      bassTarget = case Maybe BassDirection
mDir of
        Maybe BassDirection
Nothing       -> Maybe Int
forall a. Maybe a
Nothing
        Just (Rise Int
n) -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> IntSet -> Int
nthAbove Int
n Int
prevBassPC (ParsedContext -> IntSet
pcAllowedBassNotes ParsedContext
pctx)
        Just (Fall Int
n) -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> IntSet -> Int
nthBelow Int
n Int
prevBassPC (ParsedContext -> IntSet
pcAllowedBassNotes ParsedContext
pctx)

  -- Apply R constraints (pure filter by ParsedContext)
  let filtered = Maybe Int
-> ParsedContext
-> CadenceState
-> [(Cadence, Double)]
-> [(Cadence, Double)]
forall a.
Maybe Int
-> ParsedContext
-> CadenceState
-> [(Cadence, a)]
-> [(Cadence, a)]
applyRConstraintsWithTarget Maybe Int
bassTarget ParsedContext
pctx CadenceState
walkCur [(Cadence, Double)]
transitions

  -- Transitions arrive pre-scored by the caller (composer blend or the
  -- r.confidence aggregate), positive and sorted highest first; the R-filter
  -- above preserves that order.
  let -- Apply per-bar soft-boost (inverted sense: graph "higher is better",
      -- so dividing a score by a sub-unit boost raises it — matching the
      -- fallback-side effect of lowering @badness@ via the same boost).
      boost = ParsedContext -> Double
pcSoftBoost ParsedContext
pctx
      graphCandidates
        | Double
boost Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
1.0 = [(Cadence, Double)]
filtered
        | Bool
otherwise    =
            let boosted :: [(Cadence, Double)]
boosted = [(Cadence
c, Double
s Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
boost) | (Cadence
c, Double
s) <- [(Cadence, Double)]
filtered]
            in ((Cadence, Double) -> (Cadence, Double) -> Ordering)
-> [(Cadence, Double)] -> [(Cadence, Double)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Down Double -> Down Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Down Double -> Down Double -> Ordering)
-> ((Cadence, Double) -> Down Double)
-> (Cadence, Double)
-> (Cadence, Double)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Double -> Down Double
forall a. a -> Down a
Down (Double -> Down Double)
-> ((Cadence, Double) -> Double)
-> (Cadence, Double)
-> Down Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cadence, Double) -> Double
forall a b. (a, b) -> b
snd)) [(Cadence, Double)]
boosted
      graphCount = [(Cadence, Double)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Cadence, Double)]
graphCandidates

  -- Build candidate pool: graph candidates + consonance fallback
  -- NO POOL SIZE LIMIT - use full 660-candidate fallback generation
  --
  -- The fallback is computed UNCONDITIONALLY every step, by design: that is
  -- what guarantees backfill is always present when graphCount is small
  -- (conditional computation was tried and proved fragile). Online, with a
  -- typical graphCount of 20-60, the fallback segment of the stacked
  -- ranking is effectively unreachable by the gamma draw — the cost is a
  -- ~660-candidate score-and-sort per step, negligible next to the per-step
  -- Neo4j round-trip. Offline the fallback IS the pool. Keep unconditional.
  fallbackAll <- consonanceFallbackParsed gen walkCur pctx
  -- Apply R constraints to fallback candidates (same as graph candidates)
  let unfilteredFallback = [(Cadence
cad, Double
score) | (Cadence
cad, Double
score, Double
_, Double
_, Double
_) <- [(Cadence, Double, Double, Double, Double)]
fallbackAll]
      filteredFallback = ((Cadence, Double) -> Bool)
-> [(Cadence, Double)] -> [(Cadence, Double)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Cadence
cad, Double
_) -> Maybe Int -> ParsedContext -> CadenceState -> Cadence -> Bool
matchesContextWithTarget Maybe Int
bassTarget ParsedContext
pctx CadenceState
walkCur Cadence
cad) [(Cadence, Double)]
unfilteredFallback
      fallbackCount = [(Cadence, Double)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Cadence, Double)]
filteredFallback
      -- Create unified pool with (Cadence, score) format
      -- Graph candidates first (preserves database priority), then filtered fallback
      pool = [(Cadence, Double)]
graphCandidates [(Cadence, Double)] -> [(Cadence, Double)] -> [(Cadence, Double)]
forall a. [a] -> [a] -> [a]
++ [(Cadence, Double)]
filteredFallback

      -- Apply dissonance drift filter
      driftedPool = Drift -> CadenceState -> [(Cadence, Double)] -> [(Cadence, Double)]
forall a. Drift -> CadenceState -> [(Cadence, a)] -> [(Cadence, a)]
applyDriftFilter (ParsedContext -> Drift
pcDrift ParsedContext
pctx) CadenceState
walkCur [(Cadence, Double)]
pool

      -- Apply inversion spacing constraint
      invSpacing = ParsedContext -> Int
pcInversionSpacing ParsedContext
pctx
      inversionAllowed = Int
nonInvCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
invSpacing
      spacedPool = if Bool
inversionAllowed
                   then [(Cadence, Double)]
driftedPool
                   else ((Cadence, Double) -> Bool)
-> [(Cadence, Double)] -> [(Cadence, Double)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Cadence, Double) -> Bool) -> (Cadence, Double) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cadence -> Bool
H.isInversion (Cadence -> Bool)
-> ((Cadence, Double) -> Cadence) -> (Cadence, Double) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cadence, Double) -> Cadence
forall a b. (a, b) -> a
fst) [(Cadence, Double)]
driftedPool
      prepedalPool = if [(Cadence, Double)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Cadence, Double)]
spacedPool then [(Cadence, Double)]
driftedPool else [(Cadence, Double)]
spacedPool
      finalPool = ParsedContext
-> CadenceState -> [(Cadence, Double)] -> [(Cadence, Double)]
forall a.
ParsedContext -> CadenceState -> [(Cadence, a)] -> [(Cadence, a)]
applyPedalFilter ParsedContext
pctx CadenceState
walkCur [(Cadence, Double)]
prepedalPool

  -- Select next cadence using gamma sampling
  if null finalPool
    then do
      -- Absorbing state
      let diags = case Maybe Int
mVerbosity of
            Maybe Int
Nothing -> [StepDiagnostic]
revDiags
            Just Int
_  ->
              let diag :: StepDiagnostic
diag = StepDiagnostic
                    { sdStepNumber :: Int
sdStepNumber = Int
stepNum
                    , sdPriorCadence :: [Char]
sdPriorCadence = Cadence -> [Char]
forall a. Show a => a -> [Char]
show (CadenceState -> Cadence
extractCadence CadenceState
current)
                    , sdPriorRoot :: [Char]
sdPriorRoot = NoteName -> [Char]
forall a. Show a => a -> [Char]
show (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
current)
                    , sdPriorRootPC :: Int
sdPriorRootPC = PitchClass -> Int
P.unPitchClass (NoteName -> PitchClass
P.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
current))
                    , sdSelectedDbIntervals :: [Char]
sdSelectedDbIntervals = [Char]
"N/A"
                    , sdSelectedDbMovement :: [Char]
sdSelectedDbMovement = [Char]
"N/A"
                    , sdSelectedDbFunctionality :: [Char]
sdSelectedDbFunctionality = [Char]
"N/A"
                    , sdGraphCount :: Int
sdGraphCount = Int
0
                    , sdGraphTop6 :: [([Char], Double)]
sdGraphTop6 = []
                    , sdFallbackCount :: Int
sdFallbackCount = Int
0
                    , sdFallbackTop6 :: [([Char], Double, Double, Double, Double)]
sdFallbackTop6 = []
                    , sdPoolSize :: Int
sdPoolSize = Int
0
                    , sdEntropyUsed :: Double
sdEntropyUsed = Double
ent
                    , sdGammaIndex :: Int
sdGammaIndex = -Int
1
                    , sdSelectedFrom :: [Char]
sdSelectedFrom = [Char]
"none (absorbing)"
                    , sdPosteriorRoot :: [Char]
sdPosteriorRoot = NoteName -> [Char]
forall a. Show a => a -> [Char]
show (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
current)
                    , sdPosteriorRootPC :: Int
sdPosteriorRootPC = PitchClass -> Int
P.unPitchClass (NoteName -> PitchClass
P.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
current))
                    , sdRenderedChord :: Maybe [Char]
sdRenderedChord = Maybe [Char]
forall a. Maybe a
Nothing
                    , sdTransformTrace :: Maybe TransformTrace
sdTransformTrace = Maybe TransformTrace
forall a. Maybe a
Nothing
                    , sdAdvanceTrace :: Maybe AdvanceTrace
sdAdvanceTrace = Maybe AdvanceTrace
forall a. Maybe a
Nothing
                    , sdTristrataIdx :: Maybe Int
sdTristrataIdx = Maybe Int
forall a. Maybe a
Nothing
                    , sdTristrata :: Maybe Tristrata
sdTristrata = Maybe Tristrata
forall a. Maybe a
Nothing
                    , sdStrataLabel :: Maybe StrataLabel
sdStrataLabel = Maybe StrataLabel
forall a. Maybe a
Nothing
                    , sdMode :: Maybe Mode
sdMode = Maybe Mode
forall a. Maybe a
Nothing
                    , sdStrataChroma :: Maybe [PitchClass]
sdStrataChroma = Maybe [PitchClass]
forall a. Maybe a
Nothing
                    , sdModeChroma :: Maybe [PitchClass]
sdModeChroma = Maybe [PitchClass]
forall a. Maybe a
Nothing
                    , sdSoftBoost :: Maybe Double
sdSoftBoost = Maybe Double
forall a. Maybe a
Nothing
                    , sdHarmonicRootPC :: Maybe Int
sdHarmonicRootPC = Maybe Int
forall a. Maybe a
Nothing
                    , sdParentKey :: Maybe (PitchClass, ScaleFamily)
sdParentKey = Maybe (PitchClass, ScaleFamily)
forall a. Maybe a
Nothing
                    , sdModeResult :: Maybe ModeResult
sdModeResult = Maybe ModeResult
forall a. Maybe a
Nothing
                    , sdBarSpelling :: Maybe EnharmonicSpelling
sdBarSpelling = Maybe EnharmonicSpelling
forall a. Maybe a
Nothing
                    , sdPoly :: Maybe PolyDiag
sdPoly = Maybe PolyDiag
forall a. Maybe a
Nothing
                    }
              in StepDiagnostic
diag StepDiagnostic -> [StepDiagnostic] -> [StepDiagnostic]
forall a. a -> [a] -> [a]
: [StepDiagnostic]
revDiags
      pure ((current, current : revChain, nonInvCount), diags)
    else do
      idx <- gammaIndexScaledWith gen ent (length finalPool)
      let nextCadence = (Cadence, Double) -> Cadence
forall a b. (a, b) -> a
fst ([(Cadence, Double)]
finalPool [(Cadence, Double)] -> Int -> (Cadence, Double)
forall a. HasCallStack => [a] -> Int -> a
!! Int
idx)
          (newState, advTrace) = advanceStateTraced (pcKeySpelling pctx) walkCur nextCadence
          newCounter = if Cadence -> Bool
H.isInversion Cadence
nextCadence then Int
0 else Int
nonInvCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

      let emitState = CadenceState
newState

          -- Build diagnostics only when requested
      let diags = case Maybe Int
mVerbosity of
            Maybe Int
Nothing -> [StepDiagnostic]
revDiags
            Just Int
verbosity ->
              -- Candidates display: only chords actually present in finalPool
              -- (the list the gamma index sampled), so the trace never shows
              -- a chord that R or the advisory filters excluded this step.
              -- Membership by rendered form — Cadence has no Eq, and equal
              -- shows denote the same sonority. Provenance likewise: a
              -- selection is "graph" iff the chord exists among the graph
              -- candidates (indexing against the pre-filter graphCount
              -- mislabels whenever a soft filter shrank the graph segment).
              let finalShows :: [[Char]]
finalShows = ((Cadence, Double) -> [Char]) -> [(Cadence, Double)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Cadence -> [Char]
forall a. Show a => a -> [Char]
show (Cadence -> [Char])
-> ((Cadence, Double) -> Cadence) -> (Cadence, Double) -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cadence, Double) -> Cadence
forall a b. (a, b) -> a
fst) [(Cadence, Double)]
finalPool
                  graphShows :: [[Char]]
graphShows = ((Cadence, Double) -> [Char]) -> [(Cadence, Double)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Cadence -> [Char]
forall a. Show a => a -> [Char]
show (Cadence -> [Char])
-> ((Cadence, Double) -> Cadence) -> (Cadence, Double) -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cadence, Double) -> Cadence
forall a b. (a, b) -> a
fst) [(Cadence, Double)]
graphCandidates
                  selectedFrom :: [Char]
selectedFrom = if Cadence -> [Char]
forall a. Show a => a -> [Char]
show Cadence
nextCadence [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
graphShows
                                   then [Char]
"graph" else [Char]
"fallback"
                  graphTop6 :: [([Char], Double)]
graphTop6 = Int -> [([Char], Double)] -> [([Char], Double)]
forall a. Int -> [a] -> [a]
take Int
6 [([Char]
s', Double
conf) | (Cadence
cad, Double
conf) <- [(Cadence, Double)]
graphCandidates
                                                 , let s' :: [Char]
s' = Cadence -> [Char]
forall a. Show a => a -> [Char]
show Cadence
cad, [Char]
s' [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
finalShows]
                  fallbackTop6' :: [([Char], Double, Double, Double, Double)]
fallbackTop6' = Int
-> [([Char], Double, Double, Double, Double)]
-> [([Char], Double, Double, Double, Double)]
forall a. Int -> [a] -> [a]
take Int
6 [([Char]
s', Double
score, Double
cd, Double
md, Double
gd) | (Cadence
cad, Double
score, Double
cd, Double
md, Double
gd) <- [(Cadence, Double, Double, Double, Double)]
fallbackAll
                                                                  , let s' :: [Char]
s' = Cadence -> [Char]
forall a. Show a => a -> [Char]
show Cadence
cad, [Char]
s' [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
finalShows]
                  (Maybe [Char]
renderedChord, Maybe TransformTrace
transformTrace) = Int -> CadenceState -> (Maybe [Char], Maybe TransformTrace)
computeChordTrace Int
verbosity CadenceState
emitState
                  priorRoot :: NoteName
priorRoot = CadenceState -> NoteName
H.stateCadenceRoot CadenceState
current
                  priorRootPC :: Int
priorRootPC = PitchClass -> Int
P.unPitchClass (NoteName -> PitchClass
P.pitchClass NoteName
priorRoot)
                  posteriorRoot :: NoteName
posteriorRoot = CadenceState -> NoteName
H.stateCadenceRoot CadenceState
emitState
                  posteriorRootPC :: Int
posteriorRootPC = PitchClass -> Int
P.unPitchClass (NoteName -> PitchClass
P.pitchClass NoteName
posteriorRoot)
                  diag :: StepDiagnostic
diag = StepDiagnostic
                    { sdStepNumber :: Int
sdStepNumber = Int
stepNum
                    , sdPriorCadence :: [Char]
sdPriorCadence = Cadence -> [Char]
forall a. Show a => a -> [Char]
show (CadenceState -> Cadence
extractCadence CadenceState
current)
                    , sdPriorRoot :: [Char]
sdPriorRoot = NoteName -> [Char]
forall a. Show a => a -> [Char]
show NoteName
priorRoot
                    , sdPriorRootPC :: Int
sdPriorRootPC = Int
priorRootPC
                    , sdSelectedDbIntervals :: [Char]
sdSelectedDbIntervals = [PitchClass] -> [Char]
forall a. Show a => a -> [Char]
show (Cadence -> [PitchClass]
H.cadenceIntervals Cadence
nextCadence)
                    , sdSelectedDbMovement :: [Char]
sdSelectedDbMovement = Movement -> [Char]
forall a. Show a => a -> [Char]
show (Cadence -> Movement
H.cadenceMovement Cadence
nextCadence)
                    , sdSelectedDbFunctionality :: [Char]
sdSelectedDbFunctionality = Cadence -> [Char]
H.cadenceFunctionality Cadence
nextCadence
                    , sdGraphCount :: Int
sdGraphCount = Int
graphCount
                    , sdGraphTop6 :: [([Char], Double)]
sdGraphTop6 = [([Char], Double)]
graphTop6
                    , sdFallbackCount :: Int
sdFallbackCount = Int
fallbackCount
                    , sdFallbackTop6 :: [([Char], Double, Double, Double, Double)]
sdFallbackTop6 = [([Char], Double, Double, Double, Double)]
fallbackTop6'
                    , sdPoolSize :: Int
sdPoolSize = [(Cadence, Double)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Cadence, Double)]
finalPool
                    , sdEntropyUsed :: Double
sdEntropyUsed = Double
ent
                    , sdGammaIndex :: Int
sdGammaIndex = Int
idx
                    , sdSelectedFrom :: [Char]
sdSelectedFrom = [Char]
selectedFrom
                    , sdPosteriorRoot :: [Char]
sdPosteriorRoot = NoteName -> [Char]
forall a. Show a => a -> [Char]
show NoteName
posteriorRoot
                    , sdPosteriorRootPC :: Int
sdPosteriorRootPC = Int
posteriorRootPC
                    , sdRenderedChord :: Maybe [Char]
sdRenderedChord = Maybe [Char]
renderedChord
                    , sdTransformTrace :: Maybe TransformTrace
sdTransformTrace = Maybe TransformTrace
transformTrace
                    , sdAdvanceTrace :: Maybe AdvanceTrace
sdAdvanceTrace = if Int
verbosity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 then AdvanceTrace -> Maybe AdvanceTrace
forall a. a -> Maybe a
Just AdvanceTrace
advTrace else Maybe AdvanceTrace
forall a. Maybe a
Nothing
                    , sdTristrataIdx :: Maybe Int
sdTristrataIdx = Maybe Int
forall a. Maybe a
Nothing
                    , sdTristrata :: Maybe Tristrata
sdTristrata = Maybe Tristrata
forall a. Maybe a
Nothing
                    , sdStrataLabel :: Maybe StrataLabel
sdStrataLabel = Maybe StrataLabel
forall a. Maybe a
Nothing
                    , sdMode :: Maybe Mode
sdMode = Maybe Mode
forall a. Maybe a
Nothing
                    , sdStrataChroma :: Maybe [PitchClass]
sdStrataChroma = Maybe [PitchClass]
forall a. Maybe a
Nothing
                    , sdModeChroma :: Maybe [PitchClass]
sdModeChroma = Maybe [PitchClass]
forall a. Maybe a
Nothing
                    , sdSoftBoost :: Maybe Double
sdSoftBoost = Maybe Double
forall a. Maybe a
Nothing
                    , sdHarmonicRootPC :: Maybe Int
sdHarmonicRootPC = Maybe Int
forall a. Maybe a
Nothing
                    , sdParentKey :: Maybe (PitchClass, ScaleFamily)
sdParentKey = Maybe (PitchClass, ScaleFamily)
forall a. Maybe a
Nothing
                    , sdModeResult :: Maybe ModeResult
sdModeResult = Maybe ModeResult
forall a. Maybe a
Nothing
                    , sdBarSpelling :: Maybe EnharmonicSpelling
sdBarSpelling = Maybe EnharmonicSpelling
forall a. Maybe a
Nothing
                    , sdPoly :: Maybe PolyDiag
sdPoly = Maybe PolyDiag
forall a. Maybe a
Nothing
                    }
              in StepDiagnostic
diag StepDiagnostic -> [StepDiagnostic] -> [StepDiagnostic]
forall a. a -> [a] -> [a]
: [StepDiagnostic]
revDiags

      pure ((emitState, emitState : revChain, newCounter), diags)

-------------------------------------------------------------------------------
-- Scoring and Selection
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
-- Consonance Fallback
-------------------------------------------------------------------------------

-- |Generate fallback candidates from the pre-parsed context filters.
--
-- This implements the legacy "constructive generation" pattern:
--   1. Take the effective overtone palette (tuning filtered by key)
--   2. Generate all valid triads from roots × overtones (660 structures with wildcard)
--   3. Compute actual movement from current state to each candidate
--   4. Score with multiplicative formula: (rootMotionDiss × structureDiss × (gammaDraw+1))
--   5. Sort by score (lower badness = higher score)
--
-- Movement computation matches legacy getCadenceOptions which uses:
--   toCadence (transposeCadence enharm rootPC prev, nxt)
-- to derive proper movements from current position to each candidate.
-- This ensures fallback cadences have real movements, enabling subsequent
-- iterations to find graph matches and traverse freely.
--
-- Reads 'pcSoftBoost' from the context and applies it multiplicatively to
-- @badness@ inside 'computeFallbackScoreWithBoost'. Values < 1.0 favour the
-- candidates (lower badness, higher score); = 1.0 is the no-op default.
--
-- Returns IO [(Cadence, score, chordDiss, motionDiss, gammaDraw)]
consonanceFallbackParsed :: GenIO -> H.CadenceState -> ParsedContext -> IO [(H.Cadence, Double, Double, Double, Double)]
consonanceFallbackParsed :: GenIO
-> CadenceState
-> ParsedContext
-> IO [(Cadence, Double, Double, Double, Double)]
consonanceFallbackParsed GenIO
gen CadenceState
currentState ParsedContext
pctx =
  let currentRoot :: PitchClass
currentRoot = NoteName -> PitchClass
P.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
currentState)
      effectiveOvertones :: [Int]
effectiveOvertones = IntSet -> [Int]
IntSet.toList (ParsedContext -> IntSet
pcEffectiveOvertones ParsedContext
pctx)
      -- No dedup needed: overtoneSets emits distinct nCr combinations per
      -- root and each triad's head is its root, so the list is duplicate-free
      -- by construction.
      triads :: [[Int]]
triads = (Int -> [[Int]]) -> [Int] -> [[Int]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Int
r -> Int -> [Int] -> [Int] -> [[Int]]
forall a. (Eq a, Ord a) => Int -> [a] -> [a] -> [[a]]
overtoneSets Int
3 [Int
r] [Int]
effectiveOvertones) [Int]
effectiveOvertones
      boost :: Double
boost = ParsedContext -> Double
pcSoftBoost ParsedContext
pctx
  in do
      results <- ([Int] -> IO (Cadence, Double, Double, Double, Double))
-> [[Int]] -> IO [(Cadence, Double, Double, Double, Double)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\[Int]
t -> do
                         let cad :: Cadence
cad = PitchClass -> [Int] -> Cadence
triadToCadenceFrom PitchClass
currentRoot [Int]
t
                         (score, cd, md, gd) <- GenIO
-> PitchClass
-> Cadence
-> [Int]
-> Double
-> IO (Double, Double, Double, Double)
computeFallbackScoreWithBoost GenIO
gen PitchClass
currentRoot Cadence
cad [Int]
t Double
boost
                         pure (cad, score, cd, md, gd)
                       ) [[Int]]
triads
      pure $ sortBy (compare `on` (\(Cadence
_, Double
s, Double
_, Double
_, Double
_) -> Double -> Down Double
forall a. a -> Down a
Down Double
s)) results

-- |Convert a triad (list of pitch classes) to a Cadence with movement from current root.
-- Movement is computed from currentRoot to the triad's root (head of sorted triad).
-- This matches legacy getCadenceOptions which uses toCadence to derive proper movements.
-- |Convert fallback triad (absolute pitch classes) to Cadence with zero-form normalization.
-- Applies H.zeroFormPC to ensure all fallback-generated cadences store relative intervals,
-- matching database format. This guarantees naming consistency across all cadence sources.
-- IMPORTANT: overtoneSets generates [root, note1, note2] with root FIRST.
-- We must use the first element as root, not the minimum!
triadToCadenceFrom :: P.PitchClass -> [Int] -> H.Cadence
triadToCadenceFrom :: PitchClass -> [Int] -> Cadence
triadToCadenceFrom PitchClass
currentRoot [Int]
pitches =
  let triadRoot :: PitchClass
triadRoot = Int -> PitchClass
P.mkPitchClass (case [Int]
pitches of { (Int
p : [Int]
_) -> Int
p; [] -> Int
0 })  -- First element from overtoneSets is the root
      movement :: Movement
movement = PitchClass -> PitchClass -> Movement
H.toMovement PitchClass
currentRoot PitchClass
triadRoot
      -- Zero-form normalization: [P 4,P 7,P 11] → [P 0,P 3,P 7]
      -- zeroFormPC subtracts first element and sorts, so don't pre-sort!
      pcs :: [PitchClass]
pcs = [PitchClass] -> [PitchClass]
H.zeroFormPC ((Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
P.mkPitchClass [Int]
pitches)
      functionality :: [Char]
functionality = [PitchClass] -> [Char]
H.toFunctionality [PitchClass]
pcs
  in [Char] -> Movement -> [PitchClass] -> Cadence
H.Cadence [Char]
functionality Movement
movement [PitchClass]
pcs

-------------------------------------------------------------------------------
-- Fallback Scoring
-------------------------------------------------------------------------------

-- |Compute multiplicative fallback score with stochastic perturbation.
-- Formula: badness = rootMotionDiss × structureDiss × (gammaDraw + 1)
--          score = 10000 - badness
--
-- Chord dissonance range: 6 (major\/minor triad) to ~50 (dense cluster)
-- Root motion range: 1 (P5\/P4) to 6 (tritone)
-- Gamma draw range: mostly ~0-3, occasionally larger (fixed shape=1.01,
-- near-exponential)
--
-- The multiplicative formula spreads scores organically based on:
--   * Root motion quality (smooth vs rough)
--   * Vertical consonance (simple vs complex)
--   * Stochastic perturbation (via gamma draw)
--
-- The gamma draw is DELIBERATE tie-breaking noise and is independent of
-- '_gcEntropy' by design: the entropy dial acts at selection time
-- ('gammaIndexScaledWith' over the ranked pool), not at scoring time. A
-- consequence to know about: the fallback ranking is stochastic per step
-- even at entropy 0.0, so offline generation retains run-to-run variety at
-- the deterministic end of the dial.
--
-- This prevents score clustering and eliminates the need for pool size limits.
-- Returns IO (finalScore, chordDiss, motionDiss, gammaDraw)
--
-- @boost@ is a multiplicative soft-boost on @badness@: values below 1.0
-- favour the candidate (lower badness → higher score); 1.0 is the no-op;
-- values above 1.0 disfavour. Used by 'Harmonic.Framework.Builder.genP' to
-- bias candidates toward strata\/tristrata continuity via 'pcSoftBoost'.
computeFallbackScoreWithBoost :: GenIO -> P.PitchClass -> H.Cadence -> [Int] -> Double -> IO (Double, Double, Double, Double)
computeFallbackScoreWithBoost :: GenIO
-> PitchClass
-> Cadence
-> [Int]
-> Double
-> IO (Double, Double, Double, Double)
computeFallbackScoreWithBoost GenIO
gen PitchClass
_currentRoot Cadence
cad [Int]
triad Double
boost = do
  -- Chord vertical dissonance (raw Hindemith score)
  let chordDiss :: Double
chordDiss = Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Int] -> Integer
dissonanceScore [Int]
triad) :: Double

      -- Root motion dissonance (extract interval from Movement)
      interval :: Int
interval = Movement -> Int
extractMovementInterval (Cadence -> Movement
H.cadenceMovement Cadence
cad)
      motionDiss :: Double
motionDiss = Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer
D.rootMotionScore Int
interval) :: Double

  -- Draw gamma sample for entropy (minimum entropy: shape=1.01)
  gammaDraw <- Double -> Double -> Gen RealWorld -> IO Double
forall g (m :: * -> *).
StatefulGen g m =>
Double -> Double -> g -> m Double
Dist.gamma Double
1.01 Double
1.0 Gen RealWorld
GenIO
gen

  -- Multiplicative badness: all three factors contribute, soft-boost
  -- applied as an additional multiplicative term.
  let badness = Double
chordDiss Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
motionDiss Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
gammaDraw Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
1.0) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
boost

      -- Final score: 10000 - badness (higher is better)
      finalScore = Double
10000.0 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
badness

  pure (finalScore, chordDiss, motionDiss, gammaDraw)

-- |Extract interval class (0-6) from Movement type.
-- Maps Movement to interval class for rootMotionScore input.
-- Interval class folds intervals larger than tritone to their complement.
extractMovementInterval :: H.Movement -> Int
extractMovementInterval :: Movement -> Int
extractMovementInterval Movement
movement = case Movement
movement of
  H.Asc PitchClass
pc   -> Int -> Int
forall {a}. Integral a => a -> a
intervalClassFromPC (PitchClass -> Int
P.unPitchClass PitchClass
pc)
  H.Desc PitchClass
pc  -> Int -> Int
forall {a}. Integral a => a -> a
intervalClassFromPC (PitchClass -> Int
P.unPitchClass PitchClass
pc)
  Movement
H.Unison   -> Int
0
  Movement
H.Tritone  -> Int
6
  -- Empty is the missing-movement placeholder; no motion to score.
  Movement
H.Empty    -> Int
0
  where
    intervalClassFromPC :: a -> a
intervalClassFromPC a
semitones =
      let m :: a
m = a
semitones a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
12
      in if a
m a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
6 then a
m else a
12 a -> a -> a
forall a. Num a => a -> a -> a
- a
m

-------------------------------------------------------------------------------
-- Dissonance Drift Filter
-------------------------------------------------------------------------------

-- |Filter the candidate pool by dissonance drift direction.
--
-- * @Dissonant@: keep only candidates with dissonance >= current state's dissonance
-- * @Consonant@: keep only candidates with dissonance <= current state's dissonance
-- * @Free@: no filtering (return pool unchanged)
--
-- Safety fallback: if filtering empties the pool, returns the original
-- unfiltered pool so generation never fails.
applyDriftFilter :: Drift -> H.CadenceState -> [(H.Cadence, a)] -> [(H.Cadence, a)]
applyDriftFilter :: forall a. Drift -> CadenceState -> [(Cadence, a)] -> [(Cadence, a)]
applyDriftFilter Drift
Free CadenceState
_ [(Cadence, a)]
pool = [(Cadence, a)]
pool
applyDriftFilter Drift
direction CadenceState
currentState [(Cadence, a)]
pool =
  let currentDiss :: Integer
currentDiss = [Int] -> Integer
dissonanceScore
        ((PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
P.unPitchClass (Cadence -> [PitchClass]
H.cadenceIntervals (CadenceState -> Cadence
H.stateCadence CadenceState
currentState)))
      candidateDiss :: Cadence -> Integer
candidateDiss Cadence
cad = [Int] -> Integer
dissonanceScore ((PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
P.unPitchClass (Cadence -> [PitchClass]
H.cadenceIntervals Cadence
cad))
      predicate :: (Cadence, b) -> Bool
predicate = case Drift
direction of
        Drift
Dissonant -> \(Cadence
cad, b
_) -> Cadence -> Integer
candidateDiss Cadence
cad Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
currentDiss
        Drift
Consonant -> \(Cadence
cad, b
_) -> Cadence -> Integer
candidateDiss Cadence
cad Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
currentDiss
      filtered :: [(Cadence, a)]
filtered = ((Cadence, a) -> Bool) -> [(Cadence, a)] -> [(Cadence, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Cadence, a) -> Bool
forall {b}. (Cadence, b) -> Bool
predicate [(Cadence, a)]
pool
  in if [(Cadence, a)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Cadence, a)]
filtered then [(Cadence, a)]
pool else [(Cadence, a)]
filtered

-------------------------------------------------------------------------------
-- Pedal Tone Filter
-------------------------------------------------------------------------------

-- |Filter the candidate pool by pedal tone constraints.
--
-- Required tones must be present in every candidate chord (as absolute pitch
-- classes, anywhere in the chord — root or upper voices).
-- Preferred tones (@?@ suffix in input) are applied when doing so leaves at
-- least @minPedalPool@ candidates; otherwise they are relaxed and only required
-- tones are enforced. Safety fallback: never returns an empty pool.
applyPedalFilter :: ParsedContext -> H.CadenceState -> [(H.Cadence, a)] -> [(H.Cadence, a)]
applyPedalFilter :: forall a.
ParsedContext -> CadenceState -> [(Cadence, a)] -> [(Cadence, a)]
applyPedalFilter ParsedContext
pctx CadenceState
currentState [(Cadence, a)]
pool
  | IntSet -> Bool
IntSet.null IntSet
req Bool -> Bool -> Bool
&& IntSet -> Bool
IntSet.null IntSet
pref = [(Cadence, a)]
pool
  | Bool
otherwise =
      let cadenceAbsPCs :: Cadence -> IntSet
cadenceAbsPCs Cadence
cadence =
            let (Movement
movement, [PitchClass]
chord) = Cadence -> (Movement, [PitchClass])
H.deconstructCadence Cadence
cadence
                prevRoot :: PitchClass
prevRoot = NoteName -> PitchClass
P.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
currentState)
                newRoot :: PitchClass
newRoot = case Movement
movement of
                  Movement
H.Unison   -> PitchClass
prevRoot
                  Movement
H.Tritone  -> Int -> PitchClass -> PitchClass
P.transpose Int
6 PitchClass
prevRoot
                  H.Asc PitchClass
pc   -> Int -> PitchClass -> PitchClass
P.transpose (PitchClass -> Int
P.unPitchClass PitchClass
pc) PitchClass
prevRoot
                  H.Desc PitchClass
pc  -> Int -> PitchClass -> PitchClass
P.transpose (Int -> Int
forall a. Num a => a -> a
negate (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ PitchClass -> Int
P.unPitchClass PitchClass
pc) PitchClass
prevRoot
                  Movement
H.Empty    -> PitchClass
prevRoot
                rootInt :: Int
rootInt   = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PitchClass -> Int
P.unPitchClass PitchClass
newRoot)
                chordInts :: [Int]
chordInts = (PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> (PitchClass -> Int) -> PitchClass -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PitchClass -> Int
P.unPitchClass) [PitchClass]
chord
            in [Int] -> IntSet
IntSet.fromList ([Int] -> IntSet) -> [Int] -> IntSet
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rootInt) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) [Int]
chordInts
          combined :: IntSet
combined     = IntSet -> IntSet -> IntSet
IntSet.union IntSet
req IntSet
pref
          reqFiltered :: [(Cadence, a)]
reqFiltered  = ((Cadence, a) -> Bool) -> [(Cadence, a)] -> [(Cadence, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (IntSet -> IntSet -> Bool
IntSet.isSubsetOf IntSet
req     (IntSet -> Bool)
-> ((Cadence, a) -> IntSet) -> (Cadence, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cadence -> IntSet
cadenceAbsPCs (Cadence -> IntSet)
-> ((Cadence, a) -> Cadence) -> (Cadence, a) -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cadence, a) -> Cadence
forall a b. (a, b) -> a
fst) [(Cadence, a)]
pool
          combFiltered :: [(Cadence, a)]
combFiltered = ((Cadence, a) -> Bool) -> [(Cadence, a)] -> [(Cadence, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (IntSet -> IntSet -> Bool
IntSet.isSubsetOf IntSet
combined (IntSet -> Bool)
-> ((Cadence, a) -> IntSet) -> (Cadence, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cadence -> IntSet
cadenceAbsPCs (Cadence -> IntSet)
-> ((Cadence, a) -> Cadence) -> (Cadence, a) -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cadence, a) -> Cadence
forall a b. (a, b) -> a
fst) [(Cadence, a)]
pool
          result :: [(Cadence, a)]
result
            | IntSet -> Bool
IntSet.null IntSet
pref                     = [(Cadence, a)]
reqFiltered
            | [(Cadence, a)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Cadence, a)]
combFiltered Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
minPedalPool  = [(Cadence, a)]
combFiltered
            | Bool -> Bool
not ([(Cadence, a)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Cadence, a)]
reqFiltered)               = [(Cadence, a)]
reqFiltered
            | Bool
otherwise                            = [(Cadence, a)]
pool   -- safety
      in [(Cadence, a)]
result
  where
    req :: IntSet
req  = ParsedContext -> IntSet
pcPedalRequired ParsedContext
pctx
    pref :: IntSet
pref = ParsedContext -> IntSet
pcPedalPreferred ParsedContext
pctx

-- |Minimum candidate pool size when applying preferred pedal tones.
-- If fewer candidates remain after applying required+preferred tones,
-- the preferred constraint is relaxed to required-only.
minPedalPool :: Int
minPedalPool :: Int
minPedalPool = Int
10

-------------------------------------------------------------------------------
-- R Constraint Filtering
-------------------------------------------------------------------------------

-- |Apply R constraints, with an optional bass target override.
-- When bassTarget is Just, only candidates whose bass matches the target pass.
applyRConstraintsWithTarget :: Maybe Int
                            -> ParsedContext
                            -> H.CadenceState
                            -> [(H.Cadence, a)]
                            -> [(H.Cadence, a)]
applyRConstraintsWithTarget :: forall a.
Maybe Int
-> ParsedContext
-> CadenceState
-> [(Cadence, a)]
-> [(Cadence, a)]
applyRConstraintsWithTarget Maybe Int
bassTarget ParsedContext
pctx CadenceState
currentState =
  ((Cadence, a) -> Bool) -> [(Cadence, a)] -> [(Cadence, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe Int -> ParsedContext -> CadenceState -> Cadence -> Bool
matchesContextWithTarget Maybe Int
bassTarget ParsedContext
pctx CadenceState
currentState (Cadence -> Bool)
-> ((Cadence, a) -> Cadence) -> (Cadence, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cadence, a) -> Cadence
forall a b. (a, b) -> a
fst)

-- |Core filter with optional bass target override from rise\/fall direction.
-- When bassTarget is Just, the bass note must equal the target exactly.
-- When Nothing, falls back to the standard set-membership check.
matchesContextWithTarget :: Maybe Int -> ParsedContext -> H.CadenceState -> H.Cadence -> Bool
matchesContextWithTarget :: Maybe Int -> ParsedContext -> CadenceState -> Cadence -> Bool
matchesContextWithTarget Maybe Int
bassTarget ParsedContext
pctx CadenceState
currentState Cadence
cadence =
  let (Movement
movement, [PitchClass]
chord) = Cadence -> (Movement, [PitchClass])
H.deconstructCadence Cadence
cadence

      -- Compute current root from previous state + movement
      prevRoot :: PitchClass
prevRoot = NoteName -> PitchClass
P.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
currentState)
      currentRoot :: PitchClass
currentRoot = case Movement
movement of
        Movement
H.Unison -> PitchClass
prevRoot
        Movement
H.Tritone -> Int -> PitchClass -> PitchClass
P.transpose Int
6 PitchClass
prevRoot
        H.Asc PitchClass
pc -> Int -> PitchClass -> PitchClass
P.transpose (PitchClass -> Int
P.unPitchClass PitchClass
pc) PitchClass
prevRoot
        H.Desc PitchClass
pc -> Int -> PitchClass -> PitchClass
P.transpose (Int -> Int
forall a. Num a => a -> a
negate (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ PitchClass -> Int
P.unPitchClass PitchClass
pc) PitchClass
prevRoot
        Movement
H.Empty -> PitchClass
prevRoot

      -- Convert chord intervals to Int for transposition
      chordInts :: [Int]
chordInts = (PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> (PitchClass -> Int) -> PitchClass -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PitchClass -> Int
P.unPitchClass) [PitchClass]
chord
      currentRootInt :: Int
currentRootInt = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PitchClass -> Int
P.unPitchClass PitchClass
currentRoot)

      -- Transpose relative intervals (zero-form) to absolute pitches
      absolutePitches :: [Int]
absolutePitches = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
interval -> (Int
interval Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
currentRootInt) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) [Int]
chordInts

      -- Bass note is the FIRST interval (fundamental), not minimum!
      bassInt :: Int
bassInt = case [Int]
absolutePitches of { [] -> Int
0; (Int
p : [Int]
_) -> Int
p }

      -- All absolute chord pitches must be in effective overtones (IntSet lookup).
      -- When bass direction targets a specific note, exempt that pitch class
      -- from the overtone check — allows chromatic passing bass notes
      -- (e.g. D# in a G major context) while still constraining upper voices.
      -- 'pcStrictContainment' (set by 'Harmonic.Framework.Builder.genP') disables the bass exemption so
      -- the candidate's bass must also lie in the narrowed overtone set.
      pitchesToCheck :: [Int]
pitchesToCheck
        | ParsedContext -> Bool
pcStrictContainment ParsedContext
pctx = [Int]
absolutePitches
        | Bool
otherwise = case Maybe Int
bassTarget of
            Just Int
target -> (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
target) [Int]
absolutePitches
            Maybe Int
Nothing     -> [Int]
absolutePitches
      overtonesMatch :: Bool
overtonesMatch = (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> IntSet -> Bool
`IntSet.member` ParsedContext -> IntSet
pcEffectiveOvertones ParsedContext
pctx) [Int]
pitchesToCheck

      -- Bass note check: exact target if rise\/fall active, otherwise set membership
      bassMatch :: Bool
bassMatch = case Maybe Int
bassTarget of
        Just Int
target -> Int
bassInt Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
target
        Maybe Int
Nothing     -> ParsedContext -> Bool
pcIsRootsWild ParsedContext
pctx
                       Bool -> Bool -> Bool
|| Int
bassInt Int -> IntSet -> Bool
`IntSet.member` ParsedContext -> IntSet
pcAllowedBassNotes ParsedContext
pctx

  in Bool
overtonesMatch Bool -> Bool -> Bool
&& Bool
bassMatch

-------------------------------------------------------------------------------
-- State Advancement
-------------------------------------------------------------------------------

-- |Advance the CadenceState with full trace of intermediate values
-- Used for maximum verbosity diagnostics (gen'')
-- Enharmonic spelling is inferred from the new chord's absolute pitch content
-- using the 3-layer inferSpelling system (3-set match → 2-set match → root fallback).
advanceStateTraced :: Maybe H.EnharmonicSpelling -> H.CadenceState -> H.Cadence -> (H.CadenceState, AdvanceTrace)
advanceStateTraced :: Maybe EnharmonicSpelling
-> CadenceState -> Cadence -> (CadenceState, AdvanceTrace)
advanceStateTraced Maybe EnharmonicSpelling
keyBias CadenceState
currentState Cadence
newCadence =
  let currentRoot :: NoteName
currentRoot = CadenceState -> NoteName
H.stateCadenceRoot CadenceState
currentState
      currentRootPC :: PitchClass
currentRootPC = NoteName -> PitchClass
P.pitchClass NoteName
currentRoot
      movement :: Movement
movement = Cadence -> Movement
H.cadenceMovement Cadence
newCadence
      movementInterval :: PitchClass
movementInterval = Movement -> PitchClass
H.fromMovement Movement
movement
      newRootPC :: PitchClass
newRootPC = PitchClass
currentRootPC PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+ PitchClass
movementInterval
      -- Infer spelling from the new chord's absolute pitches
      tones :: [Int]
tones = (PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
P.unPitchClass ([PitchClass] -> [Int]) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> a -> b
$ Cadence -> [PitchClass]
H.cadenceIntervals Cadence
newCadence
      absolutePitches :: [Int]
absolutePitches = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
t -> (Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
+ PitchClass -> Int
P.unPitchClass PitchClass
newRootPC) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) [Int]
tones
      inferredSpelling :: EnharmonicSpelling
inferredSpelling = [Int] -> EnharmonicSpelling
H.inferSpelling [Int]
absolutePitches
      -- Spelling precedence:
      --   1. A declared key signature fixes the enharmonic side for the
      --      whole walk — a flat-side key never spells sharp.
      --   2. While the root pitch class stands still, the spelling stands
      --      still: per-bar re-inference alone can flip side when an upper
      --      tone changes over a stationary root.
      --   3. Enharmonically ambiguous patterns adopt the prior spelling.
      --   4. Otherwise, infer from absolute pitch content.
      newSpelling :: EnharmonicSpelling
newSpelling = case Maybe EnharmonicSpelling
keyBias of
        Just EnharmonicSpelling
ks -> EnharmonicSpelling
ks
        Maybe EnharmonicSpelling
Nothing
          | PitchClass
newRootPC PitchClass -> PitchClass -> Bool
forall a. Eq a => a -> a -> Bool
== PitchClass
currentRootPC       -> CadenceState -> EnharmonicSpelling
H.stateSpelling CadenceState
currentState
          | [Int] -> Bool
H.isAmbiguousPattern [Int]
absolutePitches -> CadenceState -> EnharmonicSpelling
H.stateSpelling CadenceState
currentState
          | Bool
otherwise                        -> EnharmonicSpelling
inferredSpelling
      newRoot :: NoteName
newRoot = EnharmonicSpelling -> PitchClass -> NoteName
H.enharmonicFunc EnharmonicSpelling
newSpelling PitchClass
newRootPC
      newState :: CadenceState
newState = Cadence -> NoteName -> EnharmonicSpelling -> CadenceState
H.CadenceState Cadence
newCadence NoteName
newRoot EnharmonicSpelling
newSpelling

      -- Build trace
      enharmName :: [Char]
enharmName = case EnharmonicSpelling
newSpelling of
        EnharmonicSpelling
H.FlatSpelling -> [Char]
"flat"
        EnharmonicSpelling
H.SharpSpelling -> [Char]
"sharp"
      trace :: AdvanceTrace
trace = AdvanceTrace
        { atCurrentRoot :: [Char]
atCurrentRoot = NoteName -> [Char]
forall a. Show a => a -> [Char]
show NoteName
currentRoot
        , atCurrentRootPC :: Int
atCurrentRootPC = PitchClass -> Int
P.unPitchClass PitchClass
currentRootPC
        , atMovement :: [Char]
atMovement = Movement -> [Char]
forall a. Show a => a -> [Char]
show Movement
movement
        , atMovementInterval :: Int
atMovementInterval = PitchClass -> Int
P.unPitchClass PitchClass
movementInterval
        , atNewRootPC :: Int
atNewRootPC = PitchClass -> Int
P.unPitchClass PitchClass
newRootPC
        , atEnharmFunc :: [Char]
atEnharmFunc = [Char]
enharmName
        , atNewRoot :: [Char]
atNewRoot = NoteName -> [Char]
forall a. Show a => a -> [Char]
show NoteName
newRoot
        }
  in (CadenceState
newState, AdvanceTrace
trace)

-------------------------------------------------------------------------------
-- Extraction and Conversion
-------------------------------------------------------------------------------

-- |Extract Cadence from CadenceState
extractCadence :: H.CadenceState -> H.Cadence
extractCadence :: CadenceState -> Cadence
extractCadence = CadenceState -> Cadence
H.stateCadence

-- |Convert a chain of CadenceStates to a Progression
chainToProgression :: [H.CadenceState] -> Prog.Progression
chainToProgression :: [CadenceState] -> Progression
chainToProgression = [CadenceState] -> Progression
Prog.fromCadenceStates


-------------------------------------------------------------------------------
-- Context-aware starting cue
-------------------------------------------------------------------------------

-- |True when a state names as a root-position structure — its bass IS
-- its named root. Triad-sized states re-name through the display seam's
-- own chord builder ('H.fromCadenceState'), whose functionality carries
-- an @Inv@ tag for every recognised inversion shape (maj\/min\/dim first
-- and second inversions, the sus4 inversions) — the same tags that make
-- 'Harmonic.Rules.Types.Progression.showTriad' render a slash chord. A
-- bare @\'\/\'@ test would misfire: @sus2\/4@ names carry the character
-- without being slash chords. Extended states pass — no triad-inversion
-- vocabulary applies; the jazz cue filters its slash structures by node
-- key instead. Every random-cue pool filters on this: an uncued bar 1
-- never opens on a slash chord, and inversions enter a progression only
-- by the walk's choice or the caller's explicit cue.
rootPositionCue :: H.CadenceState -> Bool
rootPositionCue :: CadenceState -> Bool
rootPositionCue CadenceState
cs
  | [PitchClass] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Cadence -> [PitchClass]
H.cadenceIntervals (CadenceState -> Cadence
H.stateCadence CadenceState
cs)) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
3 = Bool
True
  | Bool
otherwise = case CadenceState -> Chord
H.fromCadenceState CadenceState
cs of
      H.Chord NoteName
_ [Char]
fn [Integer]
_ -> Bool -> Bool
not ([Char]
"Inv" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
fn)

-- |Draw a random starting chord INSIDE the caller's tonal context: the
-- root from the resolved roots filter, the tones from the key-filtered
-- overtone set (via 'possibleTriads', the same pool builder the strata
-- cue uses), required pedal tones honoured where the pool allows —
-- and filtered to root-position structures via 'rootPositionCue'. A
-- fully wildcard context defers to the caller's '_gcCue' — plain
-- @seek "*" $ gen@ is unchanged. The gen \/ genE \/ grid counterpart of
-- 'Harmonic.Framework.Builder.StrataGen.strataStartCue': without it an
-- uncued walk under @hcKey "3b"@ opens out of key three draws in four
-- (only three major triads fit a seven-tone key set) and snaps into key
-- from bar 2 — the R constraints filter transitions, never bar 1.
--
-- The root keeps the walk's own bass exemption (@pcStrictContainment@
-- 'False'): a root named outside the key still cues, voiced over key
-- tones. An unsatisfiable context (empty pool even after the pedal
-- filter relaxes) falls back to the legacy draw rather than erroring —
-- bar 1 is the human aberration channel, never a wall.
tonalStartCue :: GenConfig -> IO H.CadenceState
tonalStartCue :: GenConfig -> IO CadenceState
tonalStartCue GenConfig
gc
  | ParsedContext -> Bool
pcIsKeyWild ParsedContext
pctx Bool -> Bool -> Bool
&& ParsedContext -> Bool
pcIsOvertonesWild ParsedContext
pctx Bool -> Bool -> Bool
&& ParsedContext -> Bool
pcIsRootsWild ParsedContext
pctx
      Bool -> Bool -> Bool
&& IntSet -> Bool
IntSet.null (ParsedContext -> IntSet
pcPedalRequired ParsedContext
pctx) = GenConfig -> IO CadenceState
_gcCue GenConfig
gc
  | Bool
otherwise = do
      rng <- IO (Gen RealWorld)
IO GenIO
createSystemRandom
      let allowed = IntSet -> [Int]
IntSet.toList (ParsedContext -> IntSet
pcEffectiveOvertones ParsedContext
pctx)
          roots | ParsedContext -> Bool
pcIsRootsWild ParsedContext
pctx = [Int]
allowed
                | Bool
otherwise          = IntSet -> [Int]
IntSet.toList (ParsedContext -> IntSet
pcAllowedBassNotes ParsedContext
pctx)
          probe (Int
r, [Int]
ivs) =
            let nm :: NoteName
nm = EnharmonicSpelling -> PitchClass -> NoteName
H.enharmonicFunc EnharmonicSpelling
H.FlatSpelling (Int -> PitchClass
P.mkPitchClass Int
r)
            in Int -> [Char] -> [Int] -> CadenceState
H.initCadenceState Int
0 (NoteName -> [Char]
forall a. Show a => a -> [Char]
show NoteName
nm) [Int]
ivs
          pool0 = [ (Int, [Int])
cand
                  | Int
r <- [Int]
roots
                  , [Int]
pcs <- (Int, [Int]) -> [[Int]]
possibleTriads (Int
r, [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ([Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort (Int
r Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
allowed)))
                  , let cand :: (Int, [Int])
cand = (Int
r, [ (Int
p 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
p <- [Int]
pcs ])
                  , CadenceState -> Bool
rootPositionCue ((Int, [Int]) -> CadenceState
probe (Int, [Int])
cand) ]
          pedalOk (Int
r, t Int
ivs) =
            (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Int
p -> (Int
p 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 -> t Int -> Bool
forall a. Eq a => a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Int
ivs)
                (IntSet -> [Int]
IntSet.toList (ParsedContext -> IntSet
pcPedalRequired ParsedContext
pctx))
          pool = case ((Int, [Int]) -> Bool) -> [(Int, [Int])] -> [(Int, [Int])]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int, [Int]) -> Bool
forall {t :: * -> *}. Foldable t => (Int, t Int) -> Bool
pedalOk [(Int, [Int])]
pool0 of
                   [] -> [(Int, [Int])]
pool0
                   [(Int, [Int])]
ps -> [(Int, [Int])]
ps
      case pool of
        [] -> GenConfig -> IO CadenceState
_gcCue GenConfig
gc
        [(Int, [Int])]
_  -> do
          i <- (Int, Int) -> GenIO -> IO Int
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
(a, a) -> Gen (PrimState m) -> m a
forall (m :: * -> *).
PrimMonad m =>
(Int, Int) -> Gen (PrimState m) -> m Int
uniformR (Int
0, [(Int, [Int])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, [Int])]
pool Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Gen RealWorld
GenIO
rng
          let (rootPC, ivs) = pool !! i
              spelling = EnharmonicSpelling
-> (EnharmonicSpelling -> EnharmonicSpelling)
-> Maybe EnharmonicSpelling
-> EnharmonicSpelling
forall b a. b -> (a -> b) -> Maybe a -> b
maybe EnharmonicSpelling
H.FlatSpelling EnharmonicSpelling -> EnharmonicSpelling
forall a. a -> a
id (ParsedContext -> Maybe EnharmonicSpelling
pcKeySpelling ParsedContext
pctx)
              rootName = EnharmonicSpelling -> PitchClass -> NoteName
H.enharmonicFunc EnharmonicSpelling
spelling (Int -> PitchClass
P.mkPitchClass Int
rootPC)
          pure (H.initCadenceState 0 (show rootName) ivs)
  where
    pctx :: ParsedContext
pctx = HarmonicContext -> ParsedContext
parseContextOnce (GenConfig -> HarmonicContext
_gcTonal GenConfig
gc)


-- |Count the bars of a finished progression that move AGAINST an active
-- rise\/fall spec — the post-hoc compliance measure the multi-attempt
-- ranker prefers on. Judged from each bar's stored arrival movement
-- ('H.cadenceMovement' of bars 2..N), which is exact where pitch-class
-- distance is ambiguous (a desc-7 arrival IS a fall, though its PC lands
-- a 4th up). Unison\/pedal and tritone arrivals count as violations
-- under either kind — neither moves in the spec's direction. No spec,
-- or an optional (@?@) spec whose steps may legitimately skip, counts
-- nothing. The walk's relaxation ladder still runs per step; this only
-- lets @attempt N K@ prefer the walks where relaxation never had to
-- surrender the direction — K buys rule character, not just score.
directionViolations :: ParsedContext -> Prog.Progression -> Int
directionViolations :: ParsedContext -> Progression -> Int
directionViolations ParsedContext
pctx Progression
prog =
  case ParsedContext -> Maybe BassDirectionSpec
pcBassDirectionSpec ParsedContext
pctx of
    Just BassDirectionSpec
spec | Bool -> Bool
not (BassDirectionSpec -> Bool
bdsOptional BassDirectionSpec
spec) ->
      let movements :: [Movement]
movements = (CadenceState -> Movement) -> [CadenceState] -> [Movement]
forall a b. (a -> b) -> [a] -> [b]
map (Cadence -> Movement
H.cadenceMovement (Cadence -> Movement)
-> (CadenceState -> Cadence) -> CadenceState -> Movement
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CadenceState -> Cadence
H.stateCadence)
                          (Int -> [CadenceState] -> [CadenceState]
forall a. Int -> [a] -> [a]
drop Int
1 (Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Prog.unProgression Progression
prog)))
          ok :: Movement -> Bool
ok Movement
m = case (BassDirectionSpec -> BDKind
bdsKind BassDirectionSpec
spec, Movement
m) of
            (BDKind
FallK, H.Desc PitchClass
_) -> Bool
True
            (BDKind
RiseK, H.Asc PitchClass
_)  -> Bool
True
            (BDKind, Movement)
_                 -> Bool
False
      in [Movement] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Movement -> Bool) -> [Movement] -> [Movement]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Movement -> Bool) -> Movement -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Movement -> Bool
ok) [Movement]
movements)
    Maybe BassDirectionSpec
_ -> Int
0