{-# LANGUAGE OverloadedStrings #-}

-- |
-- 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.
-- These functions run inside the Bolt action monad for Neo4j access.

module Harmonic.Framework.Builder.Core
  ( -- * Chain Building (online, requires Neo4j)
    buildChain
  , buildChainWithDiag
  , buildChainWithDiagV

    -- * Chain Building (offline, no Neo4j required)
  , buildChainOffline
  , buildChainOfflineWithDiag
  , buildChainOfflineWithDiagV

    -- * Strata chain building (per-bar narrowed ParsedContext)
  , buildStrataChain
  , buildStrataChainOffline

    -- * Step primitives (exposed for genP-style per-bar context narrowing)
  , stepChainCore
  , fuseState
  , stepChainOffline

    -- * Conversion
  , chainToProgression
  , extractCadence

    -- * Filtering (exposed for testing)
  , matchesContext
  , matchesContextWithTarget
  , applyDriftFilter
  ) where

import qualified Database.Bolt as Bolt
import qualified Data.Text as T
import qualified Data.IntSet as IntSet
import           Control.Monad (foldM)
import           Control.Monad.IO.Class (liftIO)
import           Data.List (sort, sortBy)
import           Data.Function (on)
import           Data.Ord (Down(..))
import           System.Random.MWC (GenIO, createSystemRandom, uniform, uniformR)
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           Harmonic.Evaluation.Database.Query (ComposerWeights, fetchTransitions)
import qualified Harmonic.Evaluation.Database.Query as Q
import           Harmonic.Traversal.Probabilistic (gammaIndexScaledWith)
import           Harmonic.Rules.Constraints.Filter (parseOvertones', parseKey, isWildcard, resolveRoots,
                                                    nthAbove, nthBelow,
                                                    BassDirectionSpec(..), BDKind(..), BDSelector(..))
import           Harmonic.Rules.Constraints.Overtone (overtoneSets)
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 Bolt Action)
-------------------------------------------------------------------------------

-- |Build the cadence chain step by step.
--
-- Simplified algorithm:
--   1. Start from initial CadenceState
--   2. For each step: build candidate pool, gamma-select next
--   3. Pool = filtered graph transitions + consonanceFallback (unlimited)
buildChain :: GeneratorConfig
           -> GenIO            -- ^ Shared random generator
           -> Double           -- ^ Entropy [0,1]
           -> HarmonicContext
           -> ParsedContext    -- ^ Pre-parsed context for O(1) lookups
           -> ComposerWeights  -- ^ Composer blend weights
           -> H.CadenceState   -- ^ Starting state
           -> Int              -- ^ Number of steps to generate
           -> Bolt.BoltActionT IO [H.CadenceState]
buildChain :: GeneratorConfig
-> GenIO
-> Double
-> HarmonicContext
-> ParsedContext
-> ComposerWeights
-> CadenceState
-> Int
-> BoltActionT IO [CadenceState]
buildChain GeneratorConfig
config GenIO
gen Double
ent HarmonicContext
context ParsedContext
pctx ComposerWeights
composerWeights 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
  ((CadenceState
_current, [CadenceState]
revChain, Int
_counter), [StepDiagnostic]
_noDiags) <-
    (((CadenceState, [CadenceState], Int), [StepDiagnostic])
 -> Int
 -> BoltActionT
      IO ((CadenceState, [CadenceState], Int), [StepDiagnostic]))
-> ((CadenceState, [CadenceState], Int), [StepDiagnostic])
-> [Int]
-> BoltActionT
     IO ((CadenceState, [CadenceState], Int), [StepDiagnostic])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (GeneratorConfig
-> GenIO
-> Maybe Int
-> Double
-> HarmonicContext
-> ParsedContext
-> ComposerWeights
-> ((CadenceState, [CadenceState], Int), [StepDiagnostic])
-> Int
-> BoltActionT
     IO ((CadenceState, [CadenceState], Int), [StepDiagnostic])
stepChainCore GeneratorConfig
config GenIO
gen Maybe Int
forall a. Maybe a
Nothing Double
ent HarmonicContext
context ParsedContext
pctx ComposerWeights
composerWeights)
          ((CadenceState
start, [CadenceState
start], Int
initCounter), [])
          [Int
1..Int
totalSteps]
  [CadenceState] -> BoltActionT IO [CadenceState]
forall a. a -> BoltActionT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CadenceState] -> BoltActionT IO [CadenceState])
-> [CadenceState] -> BoltActionT IO [CadenceState]
forall a b. (a -> b) -> a -> b
$ [CadenceState] -> [CadenceState]
forall a. [a] -> [a]
reverse [CadenceState]
revChain

-- |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
  Bool
active <- if BassDirectionSpec -> Bool
bdsOptional BassDirectionSpec
spec
              then do
                Double
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
                Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double
r Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0.5)
              else Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  if Bool -> Bool
not Bool
active
    then 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
    else do
      let cs :: [Int]
cs = BassDirectionSpec -> [Int]
bdsChoices BassDirectionSpec
spec
      Int
n <- case BassDirectionSpec -> BDSelector
bdsSelector BassDirectionSpec
spec of
        BDSelector
BDFixed      -> Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Int] -> Int
forall a. HasCallStack => [a] -> a
head [Int]
cs)
        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
          Int
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
          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
i)
      Maybe BassDirection -> IO (Maybe BassDirection)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe BassDirection -> IO (Maybe BassDirection))
-> Maybe BassDirection -> IO (Maybe BassDirection)
forall a b. (a -> b) -> a -> b
$ BassDirection -> Maybe BassDirection
forall a. a -> Maybe a
Just (BassDirection -> Maybe BassDirection)
-> BassDirection -> Maybe BassDirection
forall a b. (a -> b) -> a -> b
$ case BassDirectionSpec -> BDKind
bdsKind BassDirectionSpec
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 Bolt dependency).
--
-- Takes pre-fetched transitions and executes the full filtering\/scoring\/selection logic.
-- Used by both the online Bolt wrapper ('stepChainCore') and offline path ('stepChainOffline').
-- When transitions is empty (offline mode), generation relies entirely on consonanceFallback.
stepChainBody :: GeneratorConfig
              -> GenIO
              -> Maybe Int        -- ^ Nothing = no diagnostics, Just n = verbosity level
              -> Double           -- ^ Entropy [0,1]
              -> HarmonicContext
              -> ParsedContext
              -> ComposerWeights
              -> ((H.CadenceState, [H.CadenceState], Int), [StepDiagnostic])
              -> Int
              -> [(H.Cadence, ComposerWeights)]   -- ^ Pre-fetched transitions (empty for offline)
              -> IO ((H.CadenceState, [H.CadenceState], Int), [StepDiagnostic])
stepChainBody :: GeneratorConfig
-> GenIO
-> Maybe Int
-> Double
-> HarmonicContext
-> ParsedContext
-> ComposerWeights
-> ((CadenceState, [CadenceState], Int), [StepDiagnostic])
-> Int
-> [(Cadence, ComposerWeights)]
-> IO ((CadenceState, [CadenceState], Int), [StepDiagnostic])
stepChainBody GeneratorConfig
config GenIO
gen Maybe Int
mVerbosity Double
ent HarmonicContext
_context ParsedContext
pctx ComposerWeights
composerWeights ((CadenceState
current, [CadenceState]
revChain, Int
nonInvCount), [StepDiagnostic]
revDiags) Int
stepNum [(Cadence, ComposerWeights)]
transitions = do
  -- Walk shadow (gen4): 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, i.e. all plain gen\/genP steps.
  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)
  Maybe BassDirection
mDir <- GenIO -> Int -> Maybe BassDirectionSpec -> IO (Maybe BassDirection)
resolveBassDirection GenIO
gen Int
stepNum (ParsedContext -> Maybe BassDirectionSpec
pcBassDirectionSpec ParsedContext
pctx)
  let prevBassPC :: Int
prevBassPC = PitchClass -> Int
P.unPitchClass (NoteName -> PitchClass
P.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
current))
      bassTarget :: Maybe Int
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 :: [(Cadence, ComposerWeights)]
filtered = Maybe Int
-> ParsedContext
-> CadenceState
-> [(Cadence, ComposerWeights)]
-> [(Cadence, ComposerWeights)]
applyRConstraintsWithTarget Maybe Int
bassTarget ParsedContext
pctx CadenceState
walkCur [(Cadence, ComposerWeights)]
transitions

  -- Score by composer blend
  -- Filter to confidence > 0 and sort highest first
  let scored :: [(Cadence, Double)]
scored = ComposerWeights
-> [(Cadence, ComposerWeights)] -> [(Cadence, Double)]
scoreByConfidence ComposerWeights
composerWeights [(Cadence, ComposerWeights)]
filtered
      -- 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 :: Double
boost = ParsedContext -> Double
pcSoftBoost ParsedContext
pctx
      graphCandidates :: [(Cadence, Double)]
graphCandidates
        | Double
boost Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
1.0 = [(Cadence, Double)]
scored
        | 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)]
scored]
            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 :: Int
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 + consonanceFallback
  -- 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.
  [(Cadence, Double, Double, Double, Double)]
fallbackAll <- GenIO
-> CadenceState
-> ParsedContext
-> IO [(Cadence, Double, Double, Double, Double)]
consonanceFallbackParsed GenIO
gen CadenceState
walkCur ParsedContext
pctx
  -- Apply R constraints to fallback candidates (same as graph candidates)
  let unfilteredFallback :: [(Cadence, Double)]
unfilteredFallback = [(Cadence
cad, Double
score) | (Cadence
cad, Double
score, Double
_, Double
_, Double
_) <- [(Cadence, Double, Double, Double, Double)]
fallbackAll]
      filteredFallback :: [(Cadence, Double)]
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 :: Int
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)]
pool = [(Cadence, Double)]
graphCandidates [(Cadence, Double)] -> [(Cadence, Double)] -> [(Cadence, Double)]
forall a. [a] -> [a] -> [a]
++ [(Cadence, Double)]
filteredFallback

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

      -- Apply inversion spacing constraint
      invSpacing :: Int
invSpacing = ParsedContext -> Int
pcInversionSpacing ParsedContext
pctx
      inversionAllowed :: Bool
inversionAllowed = Int
nonInvCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
invSpacing
      spacedPool :: [(Cadence, Double)]
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 :: [(Cadence, Double)]
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 :: [(Cadence, Double)]
finalPool = ParsedContext
-> CadenceState -> [(Cadence, Double)] -> [(Cadence, Double)]
applyPedalFilter ParsedContext
pctx CadenceState
walkCur [(Cadence, Double)]
prepedalPool

  -- Select next cadence using gamma sampling
  if [(Cadence, Double)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Cadence, Double)]
finalPool
    then do
      -- Absorbing state
      let diags :: [StepDiagnostic]
diags = case Maybe Int
mVerbosity of
            Maybe Int
Nothing -> [StepDiagnostic]
revDiags
            Just Int
_  ->
              let diag :: StepDiagnostic
diag = StepDiagnostic
                    { sdStepNumber :: Int
sdStepNumber = Int
stepNum
                    , sdPriorCadence :: String
sdPriorCadence = Cadence -> String
forall a. Show a => a -> String
show (CadenceState -> Cadence
extractCadence CadenceState
current)
                    , sdPriorRoot :: String
sdPriorRoot = NoteName -> String
forall a. Show a => a -> String
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 :: String
sdSelectedDbIntervals = String
"N/A"
                    , sdSelectedDbMovement :: String
sdSelectedDbMovement = String
"N/A"
                    , sdSelectedDbFunctionality :: String
sdSelectedDbFunctionality = String
"N/A"
                    , sdGraphCount :: Int
sdGraphCount = Int
0
                    , sdGraphTop6 :: [(String, Double)]
sdGraphTop6 = []
                    , sdFallbackCount :: Int
sdFallbackCount = Int
0
                    , sdFallbackTop6 :: [(String, Double, Double, Double, Double)]
sdFallbackTop6 = []
                    , sdPoolSize :: Int
sdPoolSize = Int
0
                    , sdEntropyUsed :: Double
sdEntropyUsed = Double
ent
                    , sdGammaIndex :: Int
sdGammaIndex = -Int
1
                    , sdSelectedFrom :: String
sdSelectedFrom = String
"none (absorbing)"
                    , sdPosteriorRoot :: String
sdPosteriorRoot = NoteName -> String
forall a. Show a => a -> String
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 String
sdRenderedChord = Maybe String
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
                    , sdFusion :: Maybe FusionDiag
sdFusion = Maybe FusionDiag
forall a. Maybe a
Nothing
                    }
              in StepDiagnostic
diag StepDiagnostic -> [StepDiagnostic] -> [StepDiagnostic]
forall a. a -> [a] -> [a]
: [StepDiagnostic]
revDiags
      ((CadenceState, [CadenceState], Int), [StepDiagnostic])
-> IO ((CadenceState, [CadenceState], Int), [StepDiagnostic])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((CadenceState
current, CadenceState
current CadenceState -> [CadenceState] -> [CadenceState]
forall a. a -> [a] -> [a]
: [CadenceState]
revChain, Int
nonInvCount), [StepDiagnostic]
diags)
    else do
      Int
idx <- GenIO -> Double -> Int -> IO Int
gammaIndexScaledWith GenIO
gen Double
ent ([(Cadence, Double)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Cadence, Double)]
finalPool)
      let nextCadence :: Cadence
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)
          (CadenceState
newState, AdvanceTrace
advTrace) = Maybe EnharmonicSpelling
-> CadenceState -> Cadence -> (CadenceState, AdvanceTrace)
advanceStateTraced (ParsedContext -> Maybe EnharmonicSpelling
pcKeySpelling ParsedContext
pctx) CadenceState
walkCur Cadence
nextCadence
          newCounter :: Int
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

      -- gen4: fuse one palette tone into the selected triad; the fused
      -- state becomes the emitted bar AND the next walk state (whose
      -- stage-1 shadow is its most-consonant embedded triad — the added
      -- tone can reinterpret the harmony and steer the next step).
      (CadenceState
emitState, Maybe FusionDiag
mFusion) <-
        if GeneratorConfig -> Bool
gcQuad GeneratorConfig
config
          then GenIO
-> Double
-> ParsedContext
-> Maybe CadenceState
-> CadenceState
-> IO (CadenceState, Maybe FusionDiag)
fuseState GenIO
gen Double
ent ParsedContext
pctx (CadenceState -> Maybe CadenceState
forall a. a -> Maybe a
Just CadenceState
current) CadenceState
newState
          else (CadenceState, Maybe FusionDiag)
-> IO (CadenceState, Maybe FusionDiag)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CadenceState
newState, Maybe FusionDiag
forall a. Maybe a
Nothing)

          -- Build diagnostics only when requested
      let diags :: [StepDiagnostic]
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 :: [String]
finalShows = ((Cadence, Double) -> String) -> [(Cadence, Double)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Cadence -> String
forall a. Show a => a -> String
show (Cadence -> String)
-> ((Cadence, Double) -> Cadence) -> (Cadence, Double) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cadence, Double) -> Cadence
forall a b. (a, b) -> a
fst) [(Cadence, Double)]
finalPool
                  graphShows :: [String]
graphShows = ((Cadence, Double) -> String) -> [(Cadence, Double)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Cadence -> String
forall a. Show a => a -> String
show (Cadence -> String)
-> ((Cadence, Double) -> Cadence) -> (Cadence, Double) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cadence, Double) -> Cadence
forall a b. (a, b) -> a
fst) [(Cadence, Double)]
graphCandidates
                  selectedFrom :: String
selectedFrom = if Cadence -> String
forall a. Show a => a -> String
show Cadence
nextCadence String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
graphShows
                                   then String
"graph" else String
"fallback"
                  graphTop6 :: [(String, Double)]
graphTop6 = Int -> [(String, Double)] -> [(String, Double)]
forall a. Int -> [a] -> [a]
take Int
6 [(String
s', Double
conf) | (Cadence
cad, Double
conf) <- [(Cadence, Double)]
graphCandidates
                                                 , let s' :: String
s' = Cadence -> String
forall a. Show a => a -> String
show Cadence
cad, String
s' String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
finalShows]
                  fallbackTop6' :: [(String, Double, Double, Double, Double)]
fallbackTop6' = Int
-> [(String, Double, Double, Double, Double)]
-> [(String, Double, Double, Double, Double)]
forall a. Int -> [a] -> [a]
take Int
6 [(String
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' :: String
s' = Cadence -> String
forall a. Show a => a -> String
show Cadence
cad, String
s' String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
finalShows]
                  (Maybe String
renderedChord, Maybe TransformTrace
transformTrace) = Int -> CadenceState -> (Maybe String, 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 :: String
sdPriorCadence = Cadence -> String
forall a. Show a => a -> String
show (CadenceState -> Cadence
extractCadence CadenceState
current)
                    , sdPriorRoot :: String
sdPriorRoot = NoteName -> String
forall a. Show a => a -> String
show NoteName
priorRoot
                    , sdPriorRootPC :: Int
sdPriorRootPC = Int
priorRootPC
                    , sdSelectedDbIntervals :: String
sdSelectedDbIntervals = [PitchClass] -> String
forall a. Show a => a -> String
show (Cadence -> [PitchClass]
H.cadenceIntervals Cadence
nextCadence)
                    , sdSelectedDbMovement :: String
sdSelectedDbMovement = Movement -> String
forall a. Show a => a -> String
show (Cadence -> Movement
H.cadenceMovement Cadence
nextCadence)
                    , sdSelectedDbFunctionality :: String
sdSelectedDbFunctionality = Cadence -> String
H.cadenceFunctionality Cadence
nextCadence
                    , sdGraphCount :: Int
sdGraphCount = Int
graphCount
                    , sdGraphTop6 :: [(String, Double)]
sdGraphTop6 = [(String, Double)]
graphTop6
                    , sdFallbackCount :: Int
sdFallbackCount = Int
fallbackCount
                    , sdFallbackTop6 :: [(String, Double, Double, Double, Double)]
sdFallbackTop6 = [(String, 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 :: String
sdSelectedFrom = String
selectedFrom
                    , sdPosteriorRoot :: String
sdPosteriorRoot = NoteName -> String
forall a. Show a => a -> String
show NoteName
posteriorRoot
                    , sdPosteriorRootPC :: Int
sdPosteriorRootPC = Int
posteriorRootPC
                    , sdRenderedChord :: Maybe String
sdRenderedChord = Maybe String
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
                    , sdFusion :: Maybe FusionDiag
sdFusion = Maybe FusionDiag
mFusion
                    }
              in StepDiagnostic
diag StepDiagnostic -> [StepDiagnostic] -> [StepDiagnostic]
forall a. a -> [a] -> [a]
: [StepDiagnostic]
revDiags

      ((CadenceState, [CadenceState], Int), [StepDiagnostic])
-> IO ((CadenceState, [CadenceState], Int), [StepDiagnostic])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((CadenceState
emitState, CadenceState
emitState CadenceState -> [CadenceState] -> [CadenceState]
forall a. a -> [a] -> [a]
: [CadenceState]
revChain, Int
newCounter), [StepDiagnostic]
diags)

-- |Unified single step for chain building (online, requires Neo4j).
--
-- Fetches graph transitions via Bolt then delegates all logic to @stepChainBody@.
-- When verbosity is Nothing, skips diagnostic construction entirely.
-- When verbosity is Just n, collects diagnostics at level n:
--   Just 1 = standard diagnostics (rendered chord populated)
--   Just 2 = maximum diagnostics (full TransformTrace and AdvanceTrace)
stepChainCore :: GeneratorConfig
              -> GenIO
              -> Maybe Int
              -> Double
              -> HarmonicContext
              -> ParsedContext
              -> ComposerWeights
              -> ((H.CadenceState, [H.CadenceState], Int), [StepDiagnostic])
              -> Int
              -> Bolt.BoltActionT IO ((H.CadenceState, [H.CadenceState], Int), [StepDiagnostic])
stepChainCore :: GeneratorConfig
-> GenIO
-> Maybe Int
-> Double
-> HarmonicContext
-> ParsedContext
-> ComposerWeights
-> ((CadenceState, [CadenceState], Int), [StepDiagnostic])
-> Int
-> BoltActionT
     IO ((CadenceState, [CadenceState], Int), [StepDiagnostic])
stepChainCore GeneratorConfig
config GenIO
gen Maybe Int
mVerbosity Double
ent HarmonicContext
context ParsedContext
pctx ComposerWeights
composerWeights acc :: ((CadenceState, [CadenceState], Int), [StepDiagnostic])
acc@((CadenceState
current, [CadenceState]
_, Int
_), [StepDiagnostic]
_) Int
stepNum = do
  -- Fetch key via the walk projection: identity for triads (all corpus
  -- states); for 4-note states (gen4 chain, or a 4-note lead' cue under
  -- plain gen) the key is the most-consonant rooted embedded triad, which
  -- always exists in the corpus keyspace — the walk never silently goes
  -- offline on cardinality.
  let currentShow :: Text
currentShow = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Cadence -> String
forall a. Show a => a -> String
show (CadenceState -> Cadence
extractCadence (CadenceState -> CadenceState
H.walkTriadState CadenceState
current))
  [(Cadence, ComposerWeights)]
transitions <- Text -> BoltActionT IO [(Cadence, ComposerWeights)]
fetchTransitions Text
currentShow
  IO ((CadenceState, [CadenceState], Int), [StepDiagnostic])
-> BoltActionT
     IO ((CadenceState, [CadenceState], Int), [StepDiagnostic])
forall a. IO a -> BoltActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ((CadenceState, [CadenceState], Int), [StepDiagnostic])
 -> BoltActionT
      IO ((CadenceState, [CadenceState], Int), [StepDiagnostic]))
-> IO ((CadenceState, [CadenceState], Int), [StepDiagnostic])
-> BoltActionT
     IO ((CadenceState, [CadenceState], Int), [StepDiagnostic])
forall a b. (a -> b) -> a -> b
$ GeneratorConfig
-> GenIO
-> Maybe Int
-> Double
-> HarmonicContext
-> ParsedContext
-> ComposerWeights
-> ((CadenceState, [CadenceState], Int), [StepDiagnostic])
-> Int
-> [(Cadence, ComposerWeights)]
-> IO ((CadenceState, [CadenceState], Int), [StepDiagnostic])
stepChainBody GeneratorConfig
config GenIO
gen Maybe Int
mVerbosity Double
ent HarmonicContext
context ParsedContext
pctx ComposerWeights
composerWeights ((CadenceState, [CadenceState], Int), [StepDiagnostic])
acc Int
stepNum [(Cadence, ComposerWeights)]
transitions

-- |Offline single step for chain building (no Neo4j required).
--
-- Passes empty transitions to @stepChainBody@, so generation relies entirely
-- on the consonanceFallback mechanism (~660 candidates shaped by context filters).
stepChainOffline :: GeneratorConfig
                 -> GenIO
                 -> Maybe Int
                 -> Double
                 -> HarmonicContext
                 -> ParsedContext
                 -> ((H.CadenceState, [H.CadenceState], Int), [StepDiagnostic])
                 -> Int
                 -> IO ((H.CadenceState, [H.CadenceState], Int), [StepDiagnostic])
stepChainOffline :: GeneratorConfig
-> GenIO
-> Maybe Int
-> Double
-> HarmonicContext
-> ParsedContext
-> ((CadenceState, [CadenceState], Int), [StepDiagnostic])
-> Int
-> IO ((CadenceState, [CadenceState], Int), [StepDiagnostic])
stepChainOffline GeneratorConfig
config GenIO
gen Maybe Int
mVerbosity Double
ent HarmonicContext
context ParsedContext
pctx ((CadenceState, [CadenceState], Int), [StepDiagnostic])
acc Int
stepNum =
  GeneratorConfig
-> GenIO
-> Maybe Int
-> Double
-> HarmonicContext
-> ParsedContext
-> ComposerWeights
-> ((CadenceState, [CadenceState], Int), [StepDiagnostic])
-> Int
-> [(Cadence, ComposerWeights)]
-> IO ((CadenceState, [CadenceState], Int), [StepDiagnostic])
stepChainBody GeneratorConfig
config GenIO
gen Maybe Int
mVerbosity Double
ent HarmonicContext
context ParsedContext
pctx ComposerWeights
forall a. Monoid a => a
mempty ((CadenceState, [CadenceState], Int), [StepDiagnostic])
acc Int
stepNum []

-------------------------------------------------------------------------------
-- Chain Building with Diagnostics
-------------------------------------------------------------------------------

-- |Build cadence chain with diagnostic collection (verbosity level 1)
buildChainWithDiag :: GeneratorConfig
                   -> GenIO            -- ^ Shared random generator
                   -> Double           -- ^ Entropy [0,1]
                   -> HarmonicContext
                   -> ParsedContext    -- ^ Pre-parsed context for O(1) lookups
                   -> ComposerWeights  -- ^ Composer blend weights
                   -> H.CadenceState   -- ^ Starting state
                   -> Int              -- ^ Number of steps to generate
                   -> Bolt.BoltActionT IO ([H.CadenceState], [StepDiagnostic])
buildChainWithDiag :: GeneratorConfig
-> GenIO
-> Double
-> HarmonicContext
-> ParsedContext
-> ComposerWeights
-> CadenceState
-> Int
-> BoltActionT IO ([CadenceState], [StepDiagnostic])
buildChainWithDiag GeneratorConfig
config GenIO
gen Double
ent HarmonicContext
context ParsedContext
pctx ComposerWeights
composerWeights CadenceState
start Int
totalSteps =
  GeneratorConfig
-> GenIO
-> Int
-> Double
-> HarmonicContext
-> ParsedContext
-> ComposerWeights
-> CadenceState
-> Int
-> BoltActionT IO ([CadenceState], [StepDiagnostic])
buildChainWithDiagV GeneratorConfig
config GenIO
gen Int
1 Double
ent HarmonicContext
context ParsedContext
pctx ComposerWeights
composerWeights CadenceState
start Int
totalSteps

-- |Build cadence chain with diagnostic collection (configurable verbosity)
-- Verbosity levels:
--   1 = standard diagnostics (sdRenderedChord populated)
--   2 = maximum diagnostics (full TransformTrace and AdvanceTrace)
buildChainWithDiagV :: GeneratorConfig
                    -> GenIO           -- ^ Shared random generator
                    -> Int             -- ^ Verbosity level (1 or 2)
                    -> Double          -- ^ Entropy [0,1]
                    -> HarmonicContext
                    -> ParsedContext    -- ^ Pre-parsed context for O(1) lookups
                    -> ComposerWeights -- ^ Composer blend weights
                    -> H.CadenceState  -- ^ Starting state
                    -> Int             -- ^ Number of steps to generate
                    -> Bolt.BoltActionT IO ([H.CadenceState], [StepDiagnostic])
buildChainWithDiagV :: GeneratorConfig
-> GenIO
-> Int
-> Double
-> HarmonicContext
-> ParsedContext
-> ComposerWeights
-> CadenceState
-> Int
-> BoltActionT IO ([CadenceState], [StepDiagnostic])
buildChainWithDiagV GeneratorConfig
config GenIO
gen Int
verbosity Double
ent HarmonicContext
context ParsedContext
pctx ComposerWeights
composerWeights 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
  ((CadenceState
_current, [CadenceState]
revChain, Int
_counter), [StepDiagnostic]
revDiags) <-
    (((CadenceState, [CadenceState], Int), [StepDiagnostic])
 -> Int
 -> BoltActionT
      IO ((CadenceState, [CadenceState], Int), [StepDiagnostic]))
-> ((CadenceState, [CadenceState], Int), [StepDiagnostic])
-> [Int]
-> BoltActionT
     IO ((CadenceState, [CadenceState], Int), [StepDiagnostic])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (GeneratorConfig
-> GenIO
-> Maybe Int
-> Double
-> HarmonicContext
-> ParsedContext
-> ComposerWeights
-> ((CadenceState, [CadenceState], Int), [StepDiagnostic])
-> Int
-> BoltActionT
     IO ((CadenceState, [CadenceState], Int), [StepDiagnostic])
stepChainCore GeneratorConfig
config GenIO
gen (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
verbosity) Double
ent HarmonicContext
context ParsedContext
pctx ComposerWeights
composerWeights)
          ((CadenceState
start, [CadenceState
start], Int
initCounter), [])
          [Int
1..Int
totalSteps]
  ([CadenceState], [StepDiagnostic])
-> BoltActionT IO ([CadenceState], [StepDiagnostic])
forall a. a -> BoltActionT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CadenceState] -> [CadenceState]
forall a. [a] -> [a]
reverse [CadenceState]
revChain, [StepDiagnostic] -> [StepDiagnostic]
forall a. [a] -> [a]
reverse [StepDiagnostic]
revDiags)

-------------------------------------------------------------------------------
-- Offline Chain Building (plain IO, no Bolt\/Neo4j)
-------------------------------------------------------------------------------

-- |Build cadence chain offline (no Neo4j required).
--
-- Uses only the consonanceFallback mechanism — no graph traversal.
-- Progressions are shaped by context filters (overtones, key, roots, drift,
-- inversion spacing) and entropy. Fully musical without corpus-trained style.
buildChainOffline :: GeneratorConfig
                  -> GenIO
                  -> Double
                  -> HarmonicContext
                  -> ParsedContext
                  -> H.CadenceState
                  -> Int
                  -> IO [H.CadenceState]
buildChainOffline :: GeneratorConfig
-> GenIO
-> Double
-> HarmonicContext
-> ParsedContext
-> CadenceState
-> Int
-> IO [CadenceState]
buildChainOffline GeneratorConfig
config GenIO
gen Double
ent HarmonicContext
context ParsedContext
pctx 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
  ((CadenceState
_current, [CadenceState]
revChain, Int
_counter), [StepDiagnostic]
_noDiags) <-
    (((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 (GeneratorConfig
-> GenIO
-> Maybe Int
-> Double
-> HarmonicContext
-> ParsedContext
-> ((CadenceState, [CadenceState], Int), [StepDiagnostic])
-> Int
-> IO ((CadenceState, [CadenceState], Int), [StepDiagnostic])
stepChainOffline GeneratorConfig
config GenIO
gen Maybe Int
forall a. Maybe a
Nothing Double
ent HarmonicContext
context ParsedContext
pctx)
          ((CadenceState
start, [CadenceState
start], Int
initCounter), [])
          [Int
1..Int
totalSteps]
  [CadenceState] -> IO [CadenceState]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CadenceState] -> IO [CadenceState])
-> [CadenceState] -> IO [CadenceState]
forall a b. (a -> b) -> a -> b
$ [CadenceState] -> [CadenceState]
forall a. [a] -> [a]
reverse [CadenceState]
revChain

-- |Build cadence chain offline with standard diagnostic collection.
buildChainOfflineWithDiag :: GeneratorConfig
                           -> GenIO
                           -> Double
                           -> HarmonicContext
                           -> ParsedContext
                           -> H.CadenceState
                           -> Int
                           -> IO ([H.CadenceState], [StepDiagnostic])
buildChainOfflineWithDiag :: GeneratorConfig
-> GenIO
-> Double
-> HarmonicContext
-> ParsedContext
-> CadenceState
-> Int
-> IO ([CadenceState], [StepDiagnostic])
buildChainOfflineWithDiag GeneratorConfig
config GenIO
gen Double
ent HarmonicContext
context ParsedContext
pctx 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
  ((CadenceState
_current, [CadenceState]
revChain, Int
_counter), [StepDiagnostic]
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 (GeneratorConfig
-> GenIO
-> Maybe Int
-> Double
-> HarmonicContext
-> ParsedContext
-> ((CadenceState, [CadenceState], Int), [StepDiagnostic])
-> Int
-> IO ((CadenceState, [CadenceState], Int), [StepDiagnostic])
stepChainOffline GeneratorConfig
config GenIO
gen (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1) Double
ent HarmonicContext
context ParsedContext
pctx)
          ((CadenceState
start, [CadenceState
start], Int
initCounter), [])
          [Int
1..Int
totalSteps]
  ([CadenceState], [StepDiagnostic])
-> IO ([CadenceState], [StepDiagnostic])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CadenceState] -> [CadenceState]
forall a. [a] -> [a]
reverse [CadenceState]
revChain, [StepDiagnostic] -> [StepDiagnostic]
forall a. [a] -> [a]
reverse [StepDiagnostic]
revDiags)

-- |Build cadence chain offline with configurable verbosity diagnostics.
buildChainOfflineWithDiagV :: GeneratorConfig
                            -> GenIO
                            -> Int
                            -> Double
                            -> HarmonicContext
                            -> ParsedContext
                            -> H.CadenceState
                            -> Int
                            -> IO ([H.CadenceState], [StepDiagnostic])
buildChainOfflineWithDiagV :: GeneratorConfig
-> GenIO
-> Int
-> Double
-> HarmonicContext
-> ParsedContext
-> CadenceState
-> Int
-> IO ([CadenceState], [StepDiagnostic])
buildChainOfflineWithDiagV GeneratorConfig
config GenIO
gen Int
verbosity Double
ent HarmonicContext
context ParsedContext
pctx 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
  ((CadenceState
_current, [CadenceState]
revChain, Int
_counter), [StepDiagnostic]
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 (GeneratorConfig
-> GenIO
-> Maybe Int
-> Double
-> HarmonicContext
-> ParsedContext
-> ((CadenceState, [CadenceState], Int), [StepDiagnostic])
-> Int
-> IO ((CadenceState, [CadenceState], Int), [StepDiagnostic])
stepChainOffline GeneratorConfig
config GenIO
gen (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
verbosity) Double
ent HarmonicContext
context ParsedContext
pctx)
          ((CadenceState
start, [CadenceState
start], Int
initCounter), [])
          [Int
1..Int
totalSteps]
  ([CadenceState], [StepDiagnostic])
-> IO ([CadenceState], [StepDiagnostic])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CadenceState] -> [CadenceState]
forall a. [a] -> [a]
reverse [CadenceState]
revChain, [StepDiagnostic] -> [StepDiagnostic]
forall a. [a] -> [a]
reverse [StepDiagnostic]
revDiags)

-------------------------------------------------------------------------------
-- Strata Chain Building (per-bar narrowed ParsedContext)
-------------------------------------------------------------------------------

-- |Like 'buildChain' but accepts a per-bar 'ParsedContext' supplier.
-- Used by 'Harmonic.Framework.Builder.genP' to narrow '_hcOvertones' to the active strata's 5-PC
-- chroma at each bar while still running the full R→E→T pipeline
-- (graph candidates + fallback scoring + gamma selection).
--
-- The supplier is called once per bar with the 1-based bar index; it
-- should return a 'ParsedContext' whose 'pcEffectiveOvertones' is the
-- strata's chroma, with 'pcSoftBoost' set by the caller to reflect the
-- (strata, tristrata) continuity against prior bars.
buildStrataChain :: GeneratorConfig
                 -> GenIO
                 -> Maybe Int       -- ^ verbosity
                 -> Double          -- ^ entropy
                 -> HarmonicContext -- ^ base context (threaded unchanged for non-overtone R rules)
                 -> (Int -> ParsedContext)  -- ^ bar index (1-based) → per-bar pctx
                 -> ComposerWeights
                 -> H.CadenceState  -- ^ starting state
                 -> Int             -- ^ number of steps
                 -> Bolt.BoltActionT IO ([H.CadenceState], [StepDiagnostic])
buildStrataChain :: GeneratorConfig
-> GenIO
-> Maybe Int
-> Double
-> HarmonicContext
-> (Int -> ParsedContext)
-> ComposerWeights
-> CadenceState
-> Int
-> BoltActionT IO ([CadenceState], [StepDiagnostic])
buildStrataChain GeneratorConfig
config GenIO
gen Maybe Int
mVerb Double
ent HarmonicContext
ctx Int -> ParsedContext
pctxAt ComposerWeights
weights CadenceState
start Int
n = do
  let initCounter :: Int
initCounter = if Cadence -> Bool
H.isInversion (CadenceState -> Cadence
H.stateCadence CadenceState
start) then Int
0 else Int
1
  ((CadenceState
_, [CadenceState]
revChain, Int
_), [StepDiagnostic]
revDiags) <-
    (((CadenceState, [CadenceState], Int), [StepDiagnostic])
 -> Int
 -> BoltActionT
      IO ((CadenceState, [CadenceState], Int), [StepDiagnostic]))
-> ((CadenceState, [CadenceState], Int), [StepDiagnostic])
-> [Int]
-> BoltActionT
     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 -> GeneratorConfig
-> GenIO
-> Maybe Int
-> Double
-> HarmonicContext
-> ParsedContext
-> ComposerWeights
-> ((CadenceState, [CadenceState], Int), [StepDiagnostic])
-> Int
-> BoltActionT
     IO ((CadenceState, [CadenceState], Int), [StepDiagnostic])
stepChainCore GeneratorConfig
config GenIO
gen Maybe Int
mVerb Double
ent HarmonicContext
ctx (Int -> ParsedContext
pctxAt Int
i) ComposerWeights
weights ((CadenceState, [CadenceState], Int), [StepDiagnostic])
acc Int
i)
          ((CadenceState
start, [CadenceState
start], Int
initCounter), [])
          [Int
1..Int
n]
  ([CadenceState], [StepDiagnostic])
-> BoltActionT IO ([CadenceState], [StepDiagnostic])
forall a. a -> BoltActionT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CadenceState] -> [CadenceState]
forall a. [a] -> [a]
reverse [CadenceState]
revChain, [StepDiagnostic] -> [StepDiagnostic]
forall a. [a] -> [a]
reverse [StepDiagnostic]
revDiags)

-- |Offline counterpart of 'buildStrataChain'.
buildStrataChainOffline :: GeneratorConfig
                        -> GenIO
                        -> Maybe Int
                        -> Double
                        -> HarmonicContext
                        -> (Int -> ParsedContext)
                        -> H.CadenceState
                        -> Int
                        -> IO ([H.CadenceState], [StepDiagnostic])
buildStrataChainOffline :: GeneratorConfig
-> GenIO
-> Maybe Int
-> Double
-> HarmonicContext
-> (Int -> ParsedContext)
-> CadenceState
-> Int
-> IO ([CadenceState], [StepDiagnostic])
buildStrataChainOffline GeneratorConfig
config GenIO
gen Maybe Int
mVerb Double
ent HarmonicContext
ctx Int -> ParsedContext
pctxAt CadenceState
start Int
n = do
  let initCounter :: Int
initCounter = if Cadence -> Bool
H.isInversion (CadenceState -> Cadence
H.stateCadence CadenceState
start) then Int
0 else Int
1
  ((CadenceState
_, [CadenceState]
revChain, Int
_), [StepDiagnostic]
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 -> GeneratorConfig
-> GenIO
-> Maybe Int
-> Double
-> HarmonicContext
-> ParsedContext
-> ((CadenceState, [CadenceState], Int), [StepDiagnostic])
-> Int
-> IO ((CadenceState, [CadenceState], Int), [StepDiagnostic])
stepChainOffline GeneratorConfig
config GenIO
gen Maybe Int
mVerb Double
ent HarmonicContext
ctx (Int -> ParsedContext
pctxAt Int
i) ((CadenceState, [CadenceState], Int), [StepDiagnostic])
acc Int
i)
          ((CadenceState
start, [CadenceState
start], Int
initCounter), [])
          [Int
1..Int
n]
  ([CadenceState], [StepDiagnostic])
-> IO ([CadenceState], [StepDiagnostic])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CadenceState] -> [CadenceState]
forall a. [a] -> [a]
reverse [CadenceState]
revChain, [StepDiagnostic] -> [StepDiagnostic]
forall a. [a] -> [a]
reverse [StepDiagnostic]
revDiags)

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

-- |Score transitions by applying composer blend to edge weights.
-- Filters to confidence > 0 and sorts highest first.
-- Uses resolveWeights internally to multiply user blend by edge weights,
-- then filters out zero-score candidates.
scoreByConfidence :: ComposerWeights -> [(H.Cadence, ComposerWeights)] -> [(H.Cadence, Double)]
scoreByConfidence :: ComposerWeights
-> [(Cadence, ComposerWeights)] -> [(Cadence, Double)]
scoreByConfidence ComposerWeights
blend [(Cadence, ComposerWeights)]
transitions = ComposerWeights
-> [(Cadence, ComposerWeights)] -> [(Cadence, Double)]
Q.applyComposerBlend ComposerWeights
blend [(Cadence, ComposerWeights)]
transitions

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

-- |Generate fallback candidates from HarmonicContext filters.
--
-- This implements the legacy "constructive generation" pattern:
--   1. Get effective overtone palette (tuning filtered by key)
--   2. Get allowed roots (via resolveRoots which handles "key"\/"tones" options)
--   3. Generate all valid triads from roots × overtones (660 structures with wildcard)
--   4. Compute actual movement from current state to each candidate
--   5. Score with multiplicative formula: (rootMotionDiss × structureDiss × (gammaDraw+1))
--   6. 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.
--
-- The gamma draw adds organic randomness to scoring, preventing identical
-- scores for structurally similar triads with the same movement type.
-- Returns IO [(Cadence, score, chordDiss, motionDiss, gammaDraw)]
consonanceFallback :: H.CadenceState -> HarmonicContext -> IO [(H.Cadence, Double, Double, Double, Double)]
consonanceFallback :: CadenceState
-> HarmonicContext
-> IO [(Cadence, Double, Double, Double, Double)]
consonanceFallback CadenceState
currentState HarmonicContext
context = do
  Gen RealWorld
rng <- IO (Gen RealWorld)
IO GenIO
createSystemRandom
  GenIO
-> CadenceState
-> HarmonicContext
-> IO [(Cadence, Double, Double, Double, Double)]
consonanceFallbackWith Gen RealWorld
GenIO
rng CadenceState
currentState HarmonicContext
context

-- |Like 'consonanceFallback' but uses a shared random generator.
consonanceFallbackWith :: GenIO -> H.CadenceState -> HarmonicContext -> IO [(H.Cadence, Double, Double, Double, Double)]
consonanceFallbackWith :: GenIO
-> CadenceState
-> HarmonicContext
-> IO [(Cadence, Double, Double, Double, Double)]
consonanceFallbackWith GenIO
gen CadenceState
currentState HarmonicContext
context =
  let -- Get current root pitch class for movement computation
      currentRoot :: PitchClass
currentRoot = NoteName -> PitchClass
P.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
currentState)

      -- Get overtone palette (3 partials per fundamental: root, P5, M3)
      overtones :: [Int]
overtones = Int -> Text -> [Int]
parseOvertones' Int
3 (HarmonicContext -> Text
_hcOvertones HarmonicContext
context)

      -- Apply key filter to overtones
      keyPcs :: [Int]
keyPcs = Text -> [Int]
parseKey (HarmonicContext -> Text
_hcKey HarmonicContext
context)
      effectiveOvertones :: [Int]
effectiveOvertones = if Text -> Bool
isWildcard (HarmonicContext -> Text
_hcKey HarmonicContext
context)
                           then [Int]
overtones
                           else (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
keyPcs) [Int]
overtones

      -- Generate all valid triads: all ROOT+PAIR combinations
      -- For complete coverage: generate from effectiveOvertones (key-filtered overtone palette)
      -- Each root gets all possible 2-note pairs from the remaining pitches
      -- This preserves inversion distinctions: [0,4,7], [4,0,7], [7,0,4] are three unique structures
      -- NOTE: hcRoots is for BASS filtering (applied at line 1486), NOT for root generation!
      -- Always generate from all effective overtones, let the filter handle bass note constraints
      triads :: [[Int]]
triads = let allRoots :: [Int]
allRoots = [Int]
effectiveOvertones
               in (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]
allRoots

      -- No normalization deduplication: preserve ROOT+PAIR distinction for inversions
      -- Each triad is already distinct by its root position
      uniqueTriads :: [[Int]]
uniqueTriads = [[Int]]
triads
  in do
      -- Compute multiplicative badness score with gamma randomness for each triad
      -- Returns IO (score, chordDiss, motionDiss, gammaDraw) for each candidate
      [(Cadence, Double, Double, Double, Double)]
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
                         (Double
score, Double
cd, Double
md, Double
gd) <- GenIO
-> PitchClass
-> Cadence
-> [Int]
-> IO (Double, Double, Double, Double)
computeFallbackScoreWith GenIO
gen PitchClass
currentRoot Cadence
cad [Int]
t
                         (Cadence, Double, Double, Double, Double)
-> IO (Cadence, Double, Double, Double, Double)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cadence
cad, Double
score, Double
cd, Double
md, Double
gd)
                       ) [[Int]]
uniqueTriads

      -- Sort by score (highest first = lowest badness = best combination)
      [(Cadence, Double, Double, Double, Double)]
-> IO [(Cadence, Double, Double, Double, Double)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Cadence, Double, Double, Double, Double)]
 -> IO [(Cadence, Double, Double, Double, Double)])
-> [(Cadence, Double, Double, Double, Double)]
-> IO [(Cadence, Double, Double, Double, Double)]
forall a b. (a -> b) -> a -> b
$ ((Cadence, Double, Double, Double, Double)
 -> (Cadence, Double, Double, Double, Double) -> Ordering)
-> [(Cadence, Double, Double, Double, Double)]
-> [(Cadence, Double, Double, Double, 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, Double, Double, Double) -> Down Double)
-> (Cadence, Double, Double, Double, Double)
-> (Cadence, Double, Double, Double, Double)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (\(Cadence
_, Double
s, Double
_, Double
_, Double
_) -> Double -> Down Double
forall a. a -> Down a
Down Double
s)) [(Cadence, Double, Double, Double, Double)]
results

-- |Like 'consonanceFallbackWith' but uses pre-parsed context for efficiency.
--
-- Reads 'pcSoftBoost' from the context and applies it multiplicatively to
-- @badness@ inside 'computeFallbackScoreWith'. Values < 1.0 favour the
-- candidates (lower badness, higher score); = 1.0 is the no-op default.
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
      [(Cadence, Double, Double, Double, Double)]
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
                         (Double
score, Double
cd, Double
md, Double
gd) <- GenIO
-> PitchClass
-> Cadence
-> [Int]
-> Double
-> IO (Double, Double, Double, Double)
computeFallbackScoreWithBoost GenIO
gen PitchClass
currentRoot Cadence
cad [Int]
t Double
boost
                         (Cadence, Double, Double, Double, Double)
-> IO (Cadence, Double, Double, Double, Double)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cadence
cad, Double
score, Double
cd, Double
md, Double
gd)
                       ) [[Int]]
triads
      [(Cadence, Double, Double, Double, Double)]
-> IO [(Cadence, Double, Double, Double, Double)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Cadence, Double, Double, Double, Double)]
 -> IO [(Cadence, Double, Double, Double, Double)])
-> [(Cadence, Double, Double, Double, Double)]
-> IO [(Cadence, Double, Double, Double, Double)]
forall a b. (a -> b) -> a -> b
$ ((Cadence, Double, Double, Double, Double)
 -> (Cadence, Double, Double, Double, Double) -> Ordering)
-> [(Cadence, Double, Double, Double, Double)]
-> [(Cadence, Double, Double, Double, 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, Double, Double, Double) -> Down Double)
-> (Cadence, Double, Double, Double, Double)
-> (Cadence, Double, Double, Double, Double)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (\(Cadence
_, Double
s, Double
_, Double
_, Double
_) -> Double -> Down Double
forall a. a -> Down a
Down Double
s)) [(Cadence, Double, Double, Double, Double)]
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 ([Int] -> Int
forall a. HasCallStack => [a] -> a
head [Int]
pitches)  -- 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 :: String
functionality = [PitchClass] -> String
H.toFunctionality [PitchClass]
pcs
  in String -> Movement -> [PitchClass] -> Cadence
H.Cadence String
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)
computeFallbackScoreWithComponents :: P.PitchClass -> H.Cadence -> [Int] -> IO (Double, Double, Double, Double)
computeFallbackScoreWithComponents :: PitchClass
-> Cadence -> [Int] -> IO (Double, Double, Double, Double)
computeFallbackScoreWithComponents PitchClass
currentRoot Cadence
cad [Int]
triad = do
  Gen RealWorld
rng <- IO (Gen RealWorld)
IO GenIO
createSystemRandom
  GenIO
-> PitchClass
-> Cadence
-> [Int]
-> IO (Double, Double, Double, Double)
computeFallbackScoreWith Gen RealWorld
GenIO
rng PitchClass
currentRoot Cadence
cad [Int]
triad

-- |Like 'computeFallbackScoreWithComponents' but uses a shared random generator.
-- No soft-boost applied (boost = 1.0).
computeFallbackScoreWith :: GenIO -> P.PitchClass -> H.Cadence -> [Int] -> IO (Double, Double, Double, Double)
computeFallbackScoreWith :: GenIO
-> PitchClass
-> Cadence
-> [Int]
-> IO (Double, Double, Double, Double)
computeFallbackScoreWith GenIO
gen PitchClass
currentRoot Cadence
cad [Int]
triad =
  GenIO
-> PitchClass
-> Cadence
-> [Int]
-> Double
-> IO (Double, Double, Double, Double)
computeFallbackScoreWithBoost GenIO
gen PitchClass
currentRoot Cadence
cad [Int]
triad Double
1.0

-- |Variant that applies a multiplicative soft-boost to @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)
  Double
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
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
finalScore = Double
10000.0 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
badness

  (Double, Double, Double, Double)
-> IO (Double, Double, Double, Double)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double
finalScore, Double
chordDiss, Double
motionDiss, Double
gammaDraw)

-- Convenience wrapper returning only the score (now in IO)
computeFallbackScore :: P.PitchClass -> H.Cadence -> [Int] -> IO Double
computeFallbackScore :: PitchClass -> Cadence -> [Int] -> IO Double
computeFallbackScore PitchClass
root Cadence
cad [Int]
triad = do
  (Double
score, Double
_, Double
_, Double
_) <- PitchClass
-> Cadence -> [Int] -> IO (Double, Double, Double, Double)
computeFallbackScoreWithComponents PitchClass
root Cadence
cad [Int]
triad
  Double -> IO Double
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
score

-- |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
  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, Double)] -> [(H.Cadence, Double)]
applyDriftFilter :: Drift -> CadenceState -> [(Cadence, Double)] -> [(Cadence, Double)]
applyDriftFilter Drift
Free CadenceState
_ [(Cadence, Double)]
pool = [(Cadence, Double)]
pool
applyDriftFilter Drift
direction CadenceState
currentState [(Cadence, Double)]
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, Double)]
filtered = ((Cadence, Double) -> Bool)
-> [(Cadence, Double)] -> [(Cadence, Double)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Cadence, Double) -> Bool
forall {b}. (Cadence, b) -> Bool
predicate [(Cadence, Double)]
pool
  in if [(Cadence, Double)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Cadence, Double)]
filtered then [(Cadence, Double)]
pool else [(Cadence, Double)]
filtered

-------------------------------------------------------------------------------
-- gen4 Fusion (add one R-valid tone to a selected triad)
-------------------------------------------------------------------------------

-- |Fuse one palette tone into a triad state, producing the 4-note bar the
-- gen4 family emits. State-local by construction: the candidate set is
-- @pcEffectiveOvertones \\ triadAbsPCs@ — the set-theoretic collapse of
-- "every R-valid triad sharing exactly 2 pitches with the selected triad,
-- unioned over the original root" (any such triad unions to T ∪ {x}).
-- R adherence is therefore automatic: the added tone is always in the
-- palette, the bass never moves, and pedal tones can only gain members.
--
-- Selection: candidates ranked consonant-first by 'dissonanceScore' of the
-- full 4-PC set, drawn by the same entropy-scaled gamma as the walk. When
-- drift is active and the previous FUSED bar is supplied, candidates are
-- first advisorily filtered by fused-chord dissonance against it
-- (consonant → <=, dissonant → >=), relaxing to the full set when empty —
-- mirroring 'applyDriftFilter'. The triad stage has already drift-filtered
-- triad-vs-triad, so both the skeleton and the heard surface obey the
-- modifier.
--
-- Degenerate palette (palette == triad, only possible under a 3-tone
-- tonal context): returns the input unchanged — a plain triad bar.
-- Root, movement, and spelling are preserved verbatim.
fuseState :: GenIO
          -> Double                  -- ^ Entropy [0,1]
          -> ParsedContext
          -> Maybe H.CadenceState    -- ^ Previous fused bar (drift reference); Nothing for the cue
          -> H.CadenceState          -- ^ The selected triad state
          -> IO (H.CadenceState, Maybe FusionDiag)
fuseState :: GenIO
-> Double
-> ParsedContext
-> Maybe CadenceState
-> CadenceState
-> IO (CadenceState, Maybe FusionDiag)
fuseState GenIO
gen Double
ent ParsedContext
pctx Maybe CadenceState
mPrev CadenceState
triadState = do
  let rootPC :: Int
rootPC   = PitchClass -> Int
P.unPitchClass (NoteName -> PitchClass
P.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
triadState))
      ivs :: [Int]
ivs      = (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
triadState))
      absPCs :: IntSet
absPCs   = [Int] -> IntSet
IntSet.fromList [ (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rootPC) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12 | Int
i <- [Int]
ivs ]
      cands :: [Int]
cands    = IntSet -> [Int]
IntSet.toList (ParsedContext -> IntSet
pcEffectiveOvertones ParsedContext
pctx IntSet -> IntSet -> IntSet
IntSet.\\ IntSet
absPCs)
  if [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
cands
    then (CadenceState, Maybe FusionDiag)
-> IO (CadenceState, Maybe FusionDiag)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CadenceState
triadState, Maybe FusionDiag
forall a. Maybe a
Nothing)
    else do
      let fusedOf :: Int -> (Int, [Int], Integer)
fusedOf Int
x =
            let interval :: Int
interval = (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
rootPC) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
                zf :: [Int]
zf       = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort (Int
interval Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
ivs)
            in (Int
x, [Int]
zf, [Int] -> Integer
dissonanceScore [Int]
zf)
          scoredAll :: [(Int, [Int], Integer)]
scoredAll = (Int -> (Int, [Int], Integer)) -> [Int] -> [(Int, [Int], Integer)]
forall a b. (a -> b) -> [a] -> [b]
map Int -> (Int, [Int], Integer)
fusedOf [Int]
cands
          -- advisory drift on the fused surface vs the previous fused bar
          prevDiss :: Maybe Integer
prevDiss = case Maybe CadenceState
mPrev of
            Just CadenceState
prev | [PitchClass] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Cadence -> [PitchClass]
H.cadenceIntervals (CadenceState -> Cadence
H.stateCadence CadenceState
prev)) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
3 ->
              Integer -> Maybe Integer
forall a. a -> Maybe a
Just ([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
prev))))
            Maybe CadenceState
_ -> Maybe Integer
forall a. Maybe a
Nothing
          drifted :: [(Int, [Int], Integer)]
drifted = case (ParsedContext -> Drift
pcDrift ParsedContext
pctx, Maybe Integer
prevDiss) of
            (Drift
Consonant, Just Integer
d) -> ((Int, [Int], Integer) -> Bool)
-> [(Int, [Int], Integer)] -> [(Int, [Int], Integer)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Int
_, [Int]
_, Integer
ds) -> Integer
ds Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
d) [(Int, [Int], Integer)]
scoredAll
            (Drift
Dissonant, Just Integer
d) -> ((Int, [Int], Integer) -> Bool)
-> [(Int, [Int], Integer)] -> [(Int, [Int], Integer)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Int
_, [Int]
_, Integer
ds) -> Integer
ds Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
d) [(Int, [Int], Integer)]
scoredAll
            (Drift, Maybe Integer)
_                   -> [(Int, [Int], Integer)]
scoredAll
          pool :: [(Int, [Int], Integer)]
pool   = if [(Int, [Int], Integer)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, [Int], Integer)]
drifted then [(Int, [Int], Integer)]
scoredAll else [(Int, [Int], Integer)]
drifted
          ranked :: [(Int, [Int], Integer)]
ranked = ((Int, [Int], Integer) -> (Int, [Int], Integer) -> Ordering)
-> [(Int, [Int], Integer)] -> [(Int, [Int], Integer)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Integer -> Integer -> Ordering)
-> ((Int, [Int], Integer) -> Integer)
-> (Int, [Int], Integer)
-> (Int, [Int], Integer)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (\(Int
_, [Int]
_, Integer
d) -> Integer
d)) [(Int, [Int], Integer)]
pool
      Int
idx <- GenIO -> Double -> Int -> IO Int
gammaIndexScaledWith GenIO
gen Double
ent ([(Int, [Int], Integer)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, [Int], Integer)]
ranked)
      let (Int
x, [Int]
zf, Integer
_) = [(Int, [Int], Integer)]
ranked [(Int, [Int], Integer)] -> Int -> (Int, [Int], Integer)
forall a. HasCallStack => [a] -> Int -> a
!! Int
idx
          cad0 :: Cadence
cad0  = CadenceState -> Cadence
H.stateCadence CadenceState
triadState
          fused0 :: CadenceState
fused0 = NoteName -> Movement -> [Int] -> CadenceState
H.mkCadenceStatePCs (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
triadState)
                     (Cadence -> Movement
H.cadenceMovement Cadence
cad0) [Int]
zf
          -- keep the walk's spelling continuity decision for the bar
          fused :: CadenceState
fused = CadenceState
fused0 { H.stateSpelling = H.stateSpelling triadState }
          name :: String
name  = Cadence -> String
H.cadenceFunctionality (CadenceState -> Cadence
H.stateCadence CadenceState
fused)
      (CadenceState, Maybe FusionDiag)
-> IO (CadenceState, Maybe FusionDiag)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CadenceState
fused, FusionDiag -> Maybe FusionDiag
forall a. a -> Maybe a
Just (Int -> String -> Int -> Int -> FusionDiag
FusionDiag Int
x String
name Int
idx ([(Int, [Int], Integer)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, [Int], Integer)]
ranked)))

-------------------------------------------------------------------------------
-- 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, Double)] -> [(H.Cadence, Double)]
applyPedalFilter :: ParsedContext
-> CadenceState -> [(Cadence, Double)] -> [(Cadence, Double)]
applyPedalFilter ParsedContext
pctx CadenceState
currentState [(Cadence, Double)]
pool
  | IntSet -> Bool
IntSet.null IntSet
req Bool -> Bool -> Bool
&& IntSet -> Bool
IntSet.null IntSet
pref = [(Cadence, Double)]
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, Double)]
reqFiltered  = ((Cadence, Double) -> Bool)
-> [(Cadence, Double)] -> [(Cadence, Double)]
forall a. (a -> Bool) -> [a] -> [a]
filter (IntSet -> IntSet -> Bool
IntSet.isSubsetOf IntSet
req     (IntSet -> Bool)
-> ((Cadence, Double) -> IntSet) -> (Cadence, Double) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cadence -> IntSet
cadenceAbsPCs (Cadence -> IntSet)
-> ((Cadence, Double) -> Cadence) -> (Cadence, Double) -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cadence, Double) -> Cadence
forall a b. (a, b) -> a
fst) [(Cadence, Double)]
pool
          combFiltered :: [(Cadence, Double)]
combFiltered = ((Cadence, Double) -> Bool)
-> [(Cadence, Double)] -> [(Cadence, Double)]
forall a. (a -> Bool) -> [a] -> [a]
filter (IntSet -> IntSet -> Bool
IntSet.isSubsetOf IntSet
combined (IntSet -> Bool)
-> ((Cadence, Double) -> IntSet) -> (Cadence, Double) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cadence -> IntSet
cadenceAbsPCs (Cadence -> IntSet)
-> ((Cadence, Double) -> Cadence) -> (Cadence, Double) -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cadence, Double) -> Cadence
forall a b. (a, b) -> a
fst) [(Cadence, Double)]
pool
          result :: [(Cadence, Double)]
result
            | IntSet -> Bool
IntSet.null IntSet
pref                     = [(Cadence, Double)]
reqFiltered
            | [(Cadence, Double)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Cadence, Double)]
combFiltered Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
minPedalPool  = [(Cadence, Double)]
combFiltered
            | Bool -> Bool
not ([(Cadence, Double)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Cadence, Double)]
reqFiltered)               = [(Cadence, Double)]
reqFiltered
            | Bool
otherwise                            = [(Cadence, Double)]
pool   -- safety
      in [(Cadence, Double)]
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 to filter transitions
applyRConstraints :: HarmonicContext
                  -> H.CadenceState
                  -> [(H.Cadence, ComposerWeights)]
                  -> [(H.Cadence, ComposerWeights)]
applyRConstraints :: HarmonicContext
-> CadenceState
-> [(Cadence, ComposerWeights)]
-> [(Cadence, ComposerWeights)]
applyRConstraints HarmonicContext
context CadenceState
currentState = ((Cadence, ComposerWeights) -> Bool)
-> [(Cadence, ComposerWeights)] -> [(Cadence, ComposerWeights)]
forall a. (a -> Bool) -> [a] -> [a]
filter (HarmonicContext -> CadenceState -> Cadence -> Bool
matchesContext HarmonicContext
context CadenceState
currentState (Cadence -> Bool)
-> ((Cadence, ComposerWeights) -> Cadence)
-> (Cadence, ComposerWeights)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cadence, ComposerWeights) -> Cadence
forall a b. (a, b) -> a
fst)

-- |Check if a cadence matches the harmonic context filters.
--
-- Filter logic (matching legacy behavior):
--   1. Compute effective overtones: key-filtered overtone palette
--   2. All chord pitches must be in effective overtones
--   3. Root must be in resolved roots (handles "key"\/"tones" options)
matchesContext :: HarmonicContext -> H.CadenceState -> H.Cadence -> Bool
matchesContext :: HarmonicContext -> CadenceState -> Cadence -> Bool
matchesContext HarmonicContext
context CadenceState
currentState Cadence
cadence =
  let (Movement
movement, [PitchClass]
chord) = Cadence -> (Movement, [PitchClass])
H.deconstructCadence Cadence
cadence

      -- Get effective overtone palette (key-filtered)
      rawOvertones :: [Int]
rawOvertones = Int -> Text -> [Int]
parseOvertones' Int
3 (HarmonicContext -> Text
_hcOvertones HarmonicContext
context)
      keyPcs :: [Int]
keyPcs = Text -> [Int]
parseKey (HarmonicContext -> Text
_hcKey HarmonicContext
context)
      effectiveOvertones :: [Int]
effectiveOvertones = if Text -> Bool
isWildcard (HarmonicContext -> Text
_hcKey HarmonicContext
context)
                           then [Int]
rawOvertones
                           else (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
keyPcs) [Int]
rawOvertones

      -- Get allowed bass notes (the "roots" parameter actually filters bass notes, not harmonic roots)
      allowedBassNotes :: [Int]
allowedBassNotes = Text -> Text -> Text -> [Int]
resolveRoots (HarmonicContext -> Text
_hcOvertones HarmonicContext
context) (HarmonicContext -> Text
_hcKey HarmonicContext
context) (HarmonicContext -> Text
_hcRoots HarmonicContext
context)

      -- 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
      -- Example: [0,4,7] + root 4 (E) = [4,8,11] mod 12
      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!
      -- This matches how bassNotes and toTriad compute bass.
      bassInt :: Int
bassInt = if [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
absolutePitches then Int
0 else [Int] -> Int
forall a. HasCallStack => [a] -> a
head [Int]
absolutePitches

      -- All absolute chord pitches must be in effective overtones
      -- (effectiveOvertones already handles wildcard cases correctly)
      overtonesMatch :: Bool
overtonesMatch = (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
effectiveOvertones) [Int]
absolutePitches

      -- Bass note must be in allowed bass notes (or wildcard)
      bassMatch :: Bool
bassMatch = Text -> Bool
isWildcard (HarmonicContext -> Text
_hcRoots HarmonicContext
context)
                  Bool -> Bool -> Bool
|| Int
bassInt Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
allowedBassNotes

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

-- |Like 'applyRConstraints' but uses pre-parsed context for O(1) lookups.
applyRConstraintsParsed :: ParsedContext
                        -> H.CadenceState
                        -> [(H.Cadence, ComposerWeights)]
                        -> [(H.Cadence, ComposerWeights)]
applyRConstraintsParsed :: ParsedContext
-> CadenceState
-> [(Cadence, ComposerWeights)]
-> [(Cadence, ComposerWeights)]
applyRConstraintsParsed ParsedContext
pctx CadenceState
currentState = ((Cadence, ComposerWeights) -> Bool)
-> [(Cadence, ComposerWeights)] -> [(Cadence, ComposerWeights)]
forall a. (a -> Bool) -> [a] -> [a]
filter (ParsedContext -> CadenceState -> Cadence -> Bool
matchesContextParsed ParsedContext
pctx CadenceState
currentState (Cadence -> Bool)
-> ((Cadence, ComposerWeights) -> Cadence)
-> (Cadence, ComposerWeights)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cadence, ComposerWeights) -> Cadence
forall a b. (a, b) -> a
fst)

-- |Like 'applyRConstraintsParsed' but 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, ComposerWeights)]
                            -> [(H.Cadence, ComposerWeights)]
applyRConstraintsWithTarget :: Maybe Int
-> ParsedContext
-> CadenceState
-> [(Cadence, ComposerWeights)]
-> [(Cadence, ComposerWeights)]
applyRConstraintsWithTarget Maybe Int
bassTarget ParsedContext
pctx CadenceState
currentState =
  ((Cadence, ComposerWeights) -> Bool)
-> [(Cadence, ComposerWeights)] -> [(Cadence, ComposerWeights)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe Int -> ParsedContext -> CadenceState -> Cadence -> Bool
matchesContextWithTarget Maybe Int
bassTarget ParsedContext
pctx CadenceState
currentState (Cadence -> Bool)
-> ((Cadence, ComposerWeights) -> Cadence)
-> (Cadence, ComposerWeights)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cadence, ComposerWeights) -> Cadence
forall a b. (a, b) -> a
fst)

-- |Like 'matchesContext' but uses pre-parsed IntSet lookups instead of reparsing text.
matchesContextParsed :: ParsedContext -> H.CadenceState -> H.Cadence -> Bool
matchesContextParsed :: ParsedContext -> CadenceState -> Cadence -> Bool
matchesContextParsed = Maybe Int -> ParsedContext -> CadenceState -> Cadence -> Bool
matchesContextWithTarget Maybe Int
forall a. Maybe a
Nothing

-- |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 = if [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
absolutePitches then Int
0 else [Int] -> Int
forall a. HasCallStack => [a] -> a
head [Int]
absolutePitches

      -- 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 based on movement to a new cadence
advanceState :: H.CadenceState -> H.Cadence -> H.CadenceState
advanceState :: CadenceState -> Cadence -> CadenceState
advanceState CadenceState
currentState Cadence
newCadence =
  (CadenceState, AdvanceTrace) -> CadenceState
forall a b. (a, b) -> a
fst ((CadenceState, AdvanceTrace) -> CadenceState)
-> (CadenceState, AdvanceTrace) -> CadenceState
forall a b. (a -> b) -> a -> b
$ Maybe EnharmonicSpelling
-> CadenceState -> Cadence -> (CadenceState, AdvanceTrace)
advanceStateTraced Maybe EnharmonicSpelling
forall a. Maybe a
Nothing CadenceState
currentState Cadence
newCadence

-- |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 :: String
enharmName = case EnharmonicSpelling
newSpelling of
        EnharmonicSpelling
H.FlatSpelling -> String
"flat"
        EnharmonicSpelling
H.SharpSpelling -> String
"sharp"
      trace :: AdvanceTrace
trace = AdvanceTrace
        { atCurrentRoot :: String
atCurrentRoot = NoteName -> String
forall a. Show a => a -> String
show NoteName
currentRoot
        , atCurrentRootPC :: Int
atCurrentRootPC = PitchClass -> Int
P.unPitchClass PitchClass
currentRootPC
        , atMovement :: String
atMovement = Movement -> String
forall a. Show a => a -> String
show Movement
movement
        , atMovementInterval :: Int
atMovementInterval = PitchClass -> Int
P.unPitchClass PitchClass
movementInterval
        , atNewRootPC :: Int
atNewRootPC = PitchClass -> Int
P.unPitchClass PitchClass
newRootPC
        , atEnharmFunc :: String
atEnharmFunc = String
enharmName
        , atNewRoot :: String
atNewRoot = NoteName -> String
forall a. Show a => a -> String
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