-- |
-- Module      : Harmonic.Framework.Builder.StrataGen
-- Description : The strata-first generator behind 'Harmonic.Framework.Builder.genP'
--
-- Walks a (strata, tristrata) sequence and builds a
-- 'PC.ProgressionContext' with distinct triad\/strata\/mode layers
-- ('runStrataGen'), and regenerates a contiguous range of such a context
-- in place with a walk-valid e→e+1 seam ('runStrataGenFrom'). Pure
-- adjacency rules live in "Harmonic.Framework.Builder.Strata"; this
-- module is the IO runner the facade dispatches to.

module Harmonic.Framework.Builder.StrataGen
  ( runStrataGen
  , strataStartCue
  , runStrataGenFrom
  , printInvalidCueError
  , viableTriadLines
  , mkStarterDiag
  ) where

import qualified Data.Text as T
import           Control.Monad (when)
import           Data.Foldable (toList)
import           Data.List (nub, sort)
import           Data.Maybe (fromMaybe)
import qualified Data.Sequence as Seq
import           System.Random.MWC (GenIO, createSystemRandom, uniformRM)

import qualified Harmonic.Rules.Types.Harmony as H
import qualified Harmonic.Rules.Types.Pitch as P
import qualified Harmonic.Rules.Types.Progression as Prog
import qualified Harmonic.Rules.Types.ProgressionContext as PC
import qualified Harmonic.Rules.Types.Scale as Sc
import           Harmonic.Rules.Constraints.Overtone (possibleTriads)

import           Harmonic.Framework.Builder.Types
import           Harmonic.Framework.Builder.Core
import qualified Harmonic.Framework.Builder.Strata as Strata

-------------------------------------------------------------------------------
-- Strata traversal runner
-------------------------------------------------------------------------------

-- |Walk the (strata, tristrata) sequence for a 'StrataMode' run and build a
-- 'PC.ProgressionContext' with distinct triad\/strata\/mode layers.
--
-- The triad layer is generated by the full R→E→T pipeline: at each bar, the
-- active context's '_hcOvertones' is narrowed to the current strata's 5-PC
-- chroma (prime-notation), 'parseContextOnce' is rerun, and @stepChainBody@
-- is invoked with a 'pcSoftBoost' multiplier computed from strata \/
-- tristrata continuity against prior bars. Graph candidates (Neo4j) and
-- consonance-fallback candidates both flow through the usual filter →
-- score → gamma-select pipeline, with the soft-boost applied to @badness@
-- at @computeFallbackScoreWithBoost@ (fallback) and inversely to
-- confidence in @scoreByConfidence@-output (graph). Single-strata
-- containment is guaranteed by construction: the narrowed overtone set
-- precludes any triad whose chroma escapes @s_i@.
--
-- Strata and mode layer bars are representative 3-PC slices of
-- 'strataChroma s_i' and 'modeChroma m_i' respectively, rooted on the
-- generated triad's root so they transpose with the progression.
runStrataGen :: Sc.StrataLabel -> GenConfig -> IO (PC.ProgressionContext, GenerationDiagnostics)
runStrataGen :: StrataLabel
-> GenConfig -> IO (ProgressionContext, GenerationDiagnostics)
runStrataGen StrataLabel
sStart GenConfig
gc = do
  rng   <- IO (Gen RealWorld)
IO GenIO
createSystemRandom
  let basePctx = HarmonicContext -> ParsedContext
parseContextOnce (GenConfig -> HarmonicContext
_gcTonal GenConfig
gc)
      allowed  = ParsedContext -> [Tristrata]
pcAllowedTristrata ParsedContext
basePctx
      allowed' = if [Tristrata] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Tristrata]
allowed then [Tristrata]
Sc.validTristrata else [Tristrata]
allowed
      n        = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (GenConfig -> Int
_gcLen GenConfig
gc) (GenConfig -> Maybe Int
_gcLenOverride GenConfig
gc))
      (s0, t0) = Strata.initialPlacement allowed' sStart
  -- The starting strata is only known here — it depends on the tonal
  -- context's allowed tristrata, not on the label alone — so the cue is
  -- drawn here rather than fixed in the config.
  start <- if _gcCueExplicit gc then _gcCue gc else strataCue rng s0
  let
      -- relStrata \/ absStrata narrowing on the walk's candidate pool.
      narrow :: Int -> [(Sc.StrataLabel, Sc.Tristrata)] -> [(Sc.StrataLabel, Sc.Tristrata)]
      narrow Int
i [(StrataLabel, Tristrata)]
pool =
        let pool1 :: [(StrataLabel, Tristrata)]
pool1 = case GenConfig -> Maybe [Int]
_gcRelStrata GenConfig
gc of
              Just [Int]
ps | Bool -> Bool
not ([Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
ps) ->
                let p :: Int
p = [Int]
ps [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! (Int
i 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]
ps)
                in [(StrataLabel
s',Tristrata
t') | (StrataLabel
s',Tristrata
t') <- [(StrataLabel, Tristrata)]
pool, Tristrata -> Int -> StrataLabel
Sc.tristrataStrataAt Tristrata
t' Int
p StrataLabel -> StrataLabel -> Bool
forall a. Eq a => a -> a -> Bool
== StrataLabel
s']
              Maybe [Int]
_ -> [(StrataLabel, Tristrata)]
pool
            pool2 :: [(StrataLabel, Tristrata)]
pool2 = case GenConfig -> Maybe [StrataLabel]
_gcAbsStrata GenConfig
gc of
              Just [StrataLabel]
ss | Bool -> Bool
not ([StrataLabel] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StrataLabel]
ss) ->
                let s :: StrataLabel
s = [StrataLabel]
ss [StrataLabel] -> Int -> StrataLabel
forall a. HasCallStack => [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` [StrataLabel] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StrataLabel]
ss)
                in [(StrataLabel
s',Tristrata
t') | (StrataLabel
s',Tristrata
t') <- [(StrataLabel, Tristrata)]
pool1, StrataLabel
s' StrataLabel -> StrataLabel -> Bool
forall a. Eq a => a -> a -> Bool
== StrataLabel
s]
              Maybe [StrataLabel]
_ -> [(StrataLabel, Tristrata)]
pool1
        in [(StrataLabel, Tristrata)]
pool2

  -- Sample one random seed per transition bar. Used by 'selectNextSeeded'
  -- to escape the pathological same-strata fixed point of the purely
  -- categorical 'selectNext'. 'n - 1' seeds cover bars 1..n-1; bar 0 is
  -- set by 'Harmonic.Framework.Builder.Strata.initialPlacement'.
  walkSeeds <- mapM (const (uniformRM (minBound :: Int, maxBound :: Int) rng))
                    [1 .. max 0 (n - 1)]

  let -- Pre-compute the (s_i, t_i) sequence for all n bars using the
      -- seeded stochastic selector (allows genuine traversal rather than
      -- sticking on the starting strata).
      walk :: Int -> [Int] -> (Sc.StrataLabel, Sc.Tristrata) -> [(Sc.StrataLabel, Sc.Tristrata)]
      walk Int
i [Int]
seeds (StrataLabel, Tristrata)
prev
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = []
        | Bool
otherwise =
            let cands :: [(StrataLabel, Tristrata)]
cands  = Int -> [(StrataLabel, Tristrata)] -> [(StrataLabel, Tristrata)]
narrow Int
i ([Tristrata]
-> (StrataLabel, Tristrata) -> [(StrataLabel, Tristrata)]
Strata.allowedNext [Tristrata]
allowed' (StrataLabel, Tristrata)
prev)
                (Int
seed, [Int]
seedsRest) = case [Int]
seeds of
                  (Int
s : [Int]
rest) -> (Int
s, [Int]
rest)
                  []         -> (Int
0, [])
                chosen :: (StrataLabel, Tristrata)
chosen = (StrataLabel, Tristrata)
-> Maybe (StrataLabel, Tristrata) -> (StrataLabel, Tristrata)
forall a. a -> Maybe a -> a
fromMaybe (StrataLabel, Tristrata)
prev (Int
-> (StrataLabel, Tristrata)
-> [(StrataLabel, Tristrata)]
-> Maybe (StrataLabel, Tristrata)
Strata.selectNextSeeded Int
seed (StrataLabel, Tristrata)
prev [(StrataLabel, Tristrata)]
cands)
            in (StrataLabel, Tristrata)
chosen (StrataLabel, Tristrata)
-> [(StrataLabel, Tristrata)] -> [(StrataLabel, Tristrata)]
forall a. a -> [a] -> [a]
: Int
-> [Int] -> (StrataLabel, Tristrata) -> [(StrataLabel, Tristrata)]
walk (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Int]
seedsRest (StrataLabel, Tristrata)
chosen

      barSeq :: [(Sc.StrataLabel, Sc.Tristrata)]
      barSeq = (StrataLabel
s0, Tristrata
t0) (StrataLabel, Tristrata)
-> [(StrataLabel, Tristrata)] -> [(StrataLabel, Tristrata)]
forall a. a -> [a] -> [a]
: Int
-> [Int] -> (StrataLabel, Tristrata) -> [(StrataLabel, Tristrata)]
walk Int
1 [Int]
walkSeeds (StrataLabel
s0, Tristrata
t0)

      -- Build an overtones string of prime-notation tokens ("C#' D' E'") for
      -- a strata's 5-PC chroma. 'parseOvertones'' treats "X'" as a pinned
      -- single PC (no overtone series expansion), so pcEffectiveOvertones
      -- after parseContextOnce is exactly the 5 PCs of the strata.
      strataOvertonesString :: Sc.StrataLabel -> String
      strataOvertonesString StrataLabel
s =
        [[Char]] -> [Char]
unwords [ NoteName -> [Char]
forall a. Show a => a -> [Char]
show (PitchClass -> NoteName
P.sharp (Int -> PitchClass
P.mkPitchClass (PitchClass -> Int
P.unPitchClass PitchClass
pc))) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'"
                | PitchClass
pc <- StrataLabel -> [PitchClass]
Sc.strataChroma StrataLabel
s ]

      -- Per-bar soft-boost: compare bar i's (s,t) with bar i-1 and i-2.
      -- sameMult  ← candidate matches s_{i-1}      (strata continuity)
      -- flipMult  ← matches s_{i-2} AND not s_{i-1} (flip-flop return)
      -- triMult   ← t_i == t_{i-1}                 (tristrata continuity)
      -- Because the candidate pool is strata-narrowed, every candidate in
      -- bar i has strata s_i; so the (s', t') vs (s_{prev}, t_{prev}) test
      -- collapses to an s_i-vs-s_{prev} scalar. Boost is a per-bar scalar,
      -- applied uniformly across the bar's pool.
      boostFor :: Int -> Double
      boostFor Int
0 = Double
1.0  -- bar 0: no prior
      boostFor Int
i =
        let (StrataLabel
sCurr, Tristrata
tCurr) = [(StrataLabel, Tristrata)]
barSeq [(StrataLabel, Tristrata)] -> Int -> (StrataLabel, Tristrata)
forall a. HasCallStack => [a] -> Int -> a
!! Int
i
            (StrataLabel
sPrev, Tristrata
tPrev) = [(StrataLabel, Tristrata)]
barSeq [(StrataLabel, Tristrata)] -> Int -> (StrataLabel, Tristrata)
forall a. HasCallStack => [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
            sGrand :: Maybe StrataLabel
sGrand         = if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 then StrataLabel -> Maybe StrataLabel
forall a. a -> Maybe a
Just ((StrataLabel, Tristrata) -> StrataLabel
forall a b. (a, b) -> a
fst ([(StrataLabel, Tristrata)]
barSeq [(StrataLabel, Tristrata)] -> Int -> (StrataLabel, Tristrata)
forall a. HasCallStack => [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2))) else Maybe StrataLabel
forall a. Maybe a
Nothing
            mSame :: Double
mSame = if StrataLabel
sCurr StrataLabel -> StrataLabel -> Bool
forall a. Eq a => a -> a -> Bool
== StrataLabel
sPrev then GenConfig -> Double
_gcBoostSame GenConfig
gc else Double
1.0
            mFlip :: Double
mFlip = case Maybe StrataLabel
sGrand of
                      Just StrataLabel
sg | StrataLabel
sCurr StrataLabel -> StrataLabel -> Bool
forall a. Eq a => a -> a -> Bool
== StrataLabel
sg Bool -> Bool -> Bool
&& StrataLabel
sCurr StrataLabel -> StrataLabel -> Bool
forall a. Eq a => a -> a -> Bool
/= StrataLabel
sPrev -> GenConfig -> Double
_gcBoostFlip GenConfig
gc
                      Maybe StrataLabel
_                                        -> Double
1.0
            mTri :: Double
mTri  = if Tristrata
tCurr Tristrata -> Tristrata -> Bool
forall a. Eq a => a -> a -> Bool
== Tristrata
tPrev then GenConfig -> Double
_gcBoostTri GenConfig
gc else Double
1.0
            Tristrata
_     = Tristrata
tPrev  -- keep reference (silence unused warning if any)
        in Double
mSame Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
mFlip Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
mTri

      -- Build the per-bar ParsedContext by narrowing _hcOvertones to the
      -- bar's strata chroma and attaching the bar's soft-boost.
      -- The supplier is 1-indexed (bar 1 = first generated bar, which is
      -- barSeq index 1 since barSeq[0] is the starting state).
      pctxAt :: Int -> ParsedContext
      pctxAt Int
barIdx1 =
        let i :: Int
i      = Int
barIdx1  -- barSeq index for the generated bar
            (StrataLabel
s, Tristrata
_) = [(StrataLabel, Tristrata)]
barSeq [(StrataLabel, Tristrata)] -> Int -> (StrataLabel, Tristrata)
forall a. HasCallStack => [a] -> Int -> a
!! Int
i
            ctx' :: HarmonicContext
ctx'   = [Char] -> HarmonicContext -> HarmonicContext
hcOvertones (StrataLabel -> [Char]
strataOvertonesString StrataLabel
s) (GenConfig -> HarmonicContext
_gcTonal GenConfig
gc)
            pctx :: ParsedContext
pctx   = HarmonicContext -> ParsedContext
parseContextOnce HarmonicContext
ctx'
            boost :: Double
boost  = Int -> Double
boostFor Int
i
        in ParsedContext
pctx { pcSoftBoost = boost
                , pcStrictContainment = True
                }

      -- Cue validation: the starting CadenceState's absolute PCs must all
      -- be members of the starting strata's chroma. If the cue escapes
      -- the strata, abort with a helpful message listing viable triads.
      startAbsPCs =
        let rpc :: Int
rpc = PitchClass -> Int
P.unPitchClass (NoteName -> PitchClass
P.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
start))
            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
start))
        in [ (Int
iv Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rpc) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12 | Int
iv <- [Int]
ivs ]
      s0PCs      = (PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
P.unPitchClass (StrataLabel -> [PitchClass]
Sc.strataChroma StrataLabel
s0)
      -- The strata triad layer is triadic by contract (3-5-7): a wider
      -- cue would put a tetrad into an FStrata triad layer, so cue
      -- cardinality is bounded alongside chroma containment.
      cueValid   = [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
startAbsPCs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3 Bool -> Bool -> Bool
&& (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]
s0PCs) [Int]
startAbsPCs

  if not cueValid
    then do
      -- Inside a multi-attempt loop every emission is suppressed (the
      -- winner is emitted once); the invalid-cue warning would otherwise
      -- print up to K times. Single-pass keeps the full block.
      when (_gcMaxAttempts gc <= 1) $ do
        when (length startAbsPCs /= 3) $
          putStrLn "genP cues are triadic (the 3-5-7 layer contract) — reduce the cue to three tones inside the stratum:"
        printInvalidCueError start s0
      let emptyPC = PC.ProgressionContext
            { triadLayer :: Progression
PC.triadLayer   = Progression
forall a. Monoid a => a
mempty
            , strataLayer :: Progression
PC.strataLayer  = Progression
forall a. Monoid a => a
mempty
            , modeLayer :: Progression
PC.modeLayer    = Progression
forall a. Monoid a => a
mempty
            , pcProvenance :: Maybe (Seq (Tristrata, StrataLabel))
PC.pcProvenance = Seq (Tristrata, StrataLabel)
-> Maybe (Seq (Tristrata, StrataLabel))
forall a. a -> Maybe a
Just Seq (Tristrata, StrataLabel)
forall a. Seq a
Seq.empty
            , pcFamily :: Family
PC.pcFamily     = Family
PC.FStrata
            }
          emptyDiag = GenerationDiagnostics
            { gdStartCadence :: [Char]
gdStartCadence = Cadence -> [Char]
forall a. Show a => a -> [Char]
show (CadenceState -> Cadence
H.stateCadence CadenceState
start)
            , gdStartRoot :: [Char]
gdStartRoot    = NoteName -> [Char]
forall a. Show a => a -> [Char]
show (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
start)
            , gdRequestedLen :: Int
gdRequestedLen = Int
n
            , gdActualLen :: Int
gdActualLen    = Int
0
            , gdEntropy :: Double
gdEntropy      = GenConfig -> Double
_gcEntropy GenConfig
gc
            , gdSteps :: [StepDiagnostic]
gdSteps        = []
            , gdProgression :: Progression
gdProgression  = Progression
forall a. Monoid a => a
mempty
            , gdJazzTrace :: [[Char]]
gdJazzTrace    = []
            }
      pure (emptyPC, emptyDiag)
    else runStrataGenBody sStart gc start rng s0 t0 barSeq pctxAt boostFor n

-- |Body of 'runStrataGen' after cue validation has passed. Separated so
-- the cue-invalid path can abort cleanly without wiring through the
-- full chain-building machinery.
runStrataGenBody
  :: Sc.StrataLabel
  -> GenConfig
  -> H.CadenceState
  -> GenIO
  -> Sc.StrataLabel
  -> Sc.Tristrata
  -> [(Sc.StrataLabel, Sc.Tristrata)]
  -> (Int -> ParsedContext)
  -> (Int -> Double)
  -> Int
  -> IO (PC.ProgressionContext, GenerationDiagnostics)
runStrataGenBody :: StrataLabel
-> GenConfig
-> CadenceState
-> GenIO
-> StrataLabel
-> Tristrata
-> [(StrataLabel, Tristrata)]
-> (Int -> ParsedContext)
-> (Int -> Double)
-> Int
-> IO (ProgressionContext, GenerationDiagnostics)
runStrataGenBody StrataLabel
_sStart GenConfig
gc CadenceState
start GenIO
rng StrataLabel
_s0 Tristrata
_t0 [(StrataLabel, Tristrata)]
barSeq Int -> ParsedContext
pctxAt Int -> Double
boostFor Int
n = do
  -- Keep the cue as bar 1 (matching 'gen' semantics). Generate n-1 more
  -- bars. Chain has n elements: [cue, gen_1, ..., gen_{n-1}]. Step i of
  -- generation produces chain[i] using barSeq[i]'s strata context.
  let pctxAtStep :: Int -> ParsedContext
      pctxAtStep :: Int -> ParsedContext
pctxAtStep = Int -> ParsedContext
pctxAt
      -- Verbosity: Silent → no diagnostics, Standard → Just 1, Verbose → Just 2.
      verbArg :: Maybe Int
verbArg = case GenConfig -> Verbosity
_gcVerbosity GenConfig
gc of
        Verbosity
Silent   -> Maybe Int
forall a. Maybe a
Nothing
        Verbosity
Standard -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
        Verbosity
Verbose  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2
  source <- Text -> IO TransitionSource
sourceFor ([Char] -> Text
T.pack (GenConfig -> [Char]
_gcSeek GenConfig
gc))
  (chain, rawDiags) <- buildChainWith source rng verbArg
                         (_gcEntropy gc) (_gcTonal gc) pctxAtStep start (max 0 (n - 1))

  -- Assemble ProgressionContext. The triadLayer is the R→E→T chain.
  -- Strata & mode layers carry the full chroma (5 PCs \/ 7 PCs respectively)
  -- expressed as intervals from the bar's harmonic root, so they transpose
  -- with the progression and can be voiced as 5- or 7-pitch sets downstream.
  let -- Triad's harmonic root PC (post-detectInversion). For inversions
      -- 'H.stateCadenceRoot' is the bass; we want the harmonic root.
      -- 'H.fromCadenceState' runs detectInversion to set 'chordNoteName'
      -- to the harmonic root.
      harmonicRootOf :: H.CadenceState -> Int
      harmonicRootOf CadenceState
cs =
        PitchClass -> Int
P.unPitchClass (NoteName -> PitchClass
P.pitchClass (Chord -> NoteName
H.chordNoteName (CadenceState -> Chord
H.fromCadenceState CadenceState
cs)))

      -- Triad's harmonic root note (used for spelling-aware rootName).
      harmonicRootNote :: H.CadenceState -> P.NoteName
      harmonicRootNote CadenceState
cs = Chord -> NoteName
H.chordNoteName (CadenceState -> Chord
H.fromCadenceState CadenceState
cs)

      -- Express a chroma set as intervals from a chosen root PC. Preserves
      -- full cardinality (no truncation). Always starts at 0 because the
      -- root is in its own chroma by construction (every strata\/mode contains
      -- its own root).
      chromaIntervals :: Int -> [P.PitchClass] -> [Int]
      chromaIntervals Int
rootPC [PitchClass]
chroma =
        [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub [ (PitchClass -> Int
P.unPitchClass PitchClass
p 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 | PitchClass
p <- [PitchClass]
chroma ]

      -- Per-bar mode classification, triad-anchored and history-aware.
      modeResults :: [Sc.ModeResult]
      modeResults =
        [ [(StrataLabel, Tristrata)] -> Int -> Int -> ModeResult
Strata.modeForTriad [(StrataLabel, Tristrata)]
barSeq Int
i (CadenceState -> Int
harmonicRootOf CadenceState
cs)
        | (Int
i, CadenceState
cs) <- [Int] -> [CadenceState] -> [(Int, CadenceState)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [CadenceState]
chain
        ]

      -- Per-bar chroma stored in the mode layer. 'Harmonic.Rules.Types.Scale.ModeOk' contributes the
      -- 7-PC mode chroma; 'ModeInvalid' contributes its 6-PC overlap PCs
      -- as-is. No Aeolian masquerade — the layer faithfully reflects what
      -- 'modeForTriad' produced. Natural walks always yield 'Harmonic.Rules.Types.Scale.ModeOk' (proven
      -- from 'Harmonic.Framework.Builder.Strata.allowedNext' adjacency); 'ModeInvalid' is reachable only via
      -- explicit 'absStrata' \/ 'relStrata' overrides that violate tristrata
      -- adjacency.
      modeChromaList :: [[P.PitchClass]]
      modeChromaList =
        [ case ModeResult
mr of
            Sc.ModeOk Mode
m         -> Mode -> [PitchClass]
Sc.modeChroma Mode
m
            Sc.ModeInvalid [PitchClass]
pcs  -> [PitchClass]
pcs
        | ModeResult
mr <- [ModeResult]
modeResults
        ]

      -- Build a CadenceState from a root and root-relative intervals,
      -- preserving full cardinality (no initCadenceState\/toCadence
      -- truncation). Delegates to the exported non-truncating constructor;
      -- unlike the historical local version this also populates
      -- cadenceFunctionality, which the display seam (showHarmony) would
      -- otherwise recompute identically.
      mkChromaCS :: P.NoteName -> [Int] -> H.CadenceState
      mkChromaCS NoteName
root [Int]
intervals = NoteName -> Movement -> [Int] -> CadenceState
H.mkCadenceStatePCs NoteName
root Movement
H.Unison [Int]
intervals

      -- Build per-bar strata-layer + mode-layer CadenceStates rooted on
      -- each generated triad's harmonic root, carrying the full 5 \/ 7 PC
      -- chroma respectively (6 PCs for override-driven 'ModeInvalid' bars).
      mkAuxLayers :: H.CadenceState
                  -> Sc.StrataLabel
                  -> [P.PitchClass]              -- mode/overlap chroma
                  -> (H.CadenceState, H.CadenceState)
      mkAuxLayers CadenceState
triadCS StrataLabel
sCurr [PitchClass]
modeChromaPCs =
        let rootPC :: Int
rootPC     = CadenceState -> Int
harmonicRootOf CadenceState
triadCS
            rootNote :: NoteName
rootNote   = CadenceState -> NoteName
harmonicRootNote CadenceState
triadCS
            strataInts :: [Int]
strataInts = Int -> [PitchClass] -> [Int]
chromaIntervals Int
rootPC (StrataLabel -> [PitchClass]
Sc.strataChroma StrataLabel
sCurr)
            modeInts :: [Int]
modeInts   = Int -> [PitchClass] -> [Int]
chromaIntervals Int
rootPC [PitchClass]
modeChromaPCs
            strataCS :: CadenceState
strataCS   = NoteName -> [Int] -> CadenceState
mkChromaCS NoteName
rootNote [Int]
strataInts
            modeCS :: CadenceState
modeCS     = NoteName -> [Int] -> CadenceState
mkChromaCS NoteName
rootNote [Int]
modeInts
        in (CadenceState
strataCS, CadenceState
modeCS)

      stratas = [CadenceState
s | (CadenceState
s, CadenceState
_) <- [(CadenceState, CadenceState)]
pairs]
      modes   = [CadenceState
m | (CadenceState
_, CadenceState
m) <- [(CadenceState, CadenceState)]
pairs]
      pairs   = (CadenceState
 -> StrataLabel -> [PitchClass] -> (CadenceState, CadenceState))
-> [CadenceState]
-> [StrataLabel]
-> [[PitchClass]]
-> [(CadenceState, CadenceState)]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 CadenceState
-> StrataLabel -> [PitchClass] -> (CadenceState, CadenceState)
mkAuxLayers [CadenceState]
chain (((StrataLabel, Tristrata) -> StrataLabel)
-> [(StrataLabel, Tristrata)] -> [StrataLabel]
forall a b. (a -> b) -> [a] -> [b]
map (StrataLabel, Tristrata) -> StrataLabel
forall a b. (a, b) -> a
fst [(StrataLabel, Tristrata)]
barSeq) [[PitchClass]]
modeChromaList

      provSeq          = [(Tristrata, StrataLabel)] -> Seq (Tristrata, StrataLabel)
forall a. [a] -> Seq a
Seq.fromList [(Tristrata
t, StrataLabel
s) | (StrataLabel
s, Tristrata
t) <- Int -> [(StrataLabel, Tristrata)] -> [(StrataLabel, Tristrata)]
forall a. Int -> [a] -> [a]
take ([CadenceState] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CadenceState]
chain) [(StrataLabel, Tristrata)]
barSeq]
      resultPC = PC.ProgressionContext
        { triadLayer :: Progression
PC.triadLayer   = [CadenceState] -> Progression
Prog.fromCadenceStates [CadenceState]
chain
        , strataLayer :: Progression
PC.strataLayer  = [CadenceState] -> Progression
Prog.fromCadenceStates [CadenceState]
stratas
        , modeLayer :: Progression
PC.modeLayer    = [CadenceState] -> Progression
Prog.fromCadenceStates [CadenceState]
modes
        , pcProvenance :: Maybe (Seq (Tristrata, StrataLabel))
PC.pcProvenance = Seq (Tristrata, StrataLabel)
-> Maybe (Seq (Tristrata, StrataLabel))
forall a. a -> Maybe a
Just Seq (Tristrata, StrataLabel)
provSeq
        , pcFamily :: Family
PC.pcFamily     = Family
PC.FStrata
        }

  -- Synthesize a "starter" StepDiagnostic for the cue bar (chain[0]) so
  -- the diagnostic loop has one entry per output bar. The cue has no
  -- prior state and wasn't selected from a candidate pool — 'sdSelectedFrom'
  -- = "starter" signals this to the renderer.
  let starterDiag = CadenceState -> StepDiagnostic
mkStarterDiag CadenceState
start
      allBaseDiags = StepDiagnostic
starterDiag StepDiagnostic -> [StepDiagnostic] -> [StepDiagnostic]
forall a. a -> [a] -> [a]
: [StepDiagnostic]
rawDiags

  -- Attach strata\/tristrata\/mode\/boost info. allBaseDiags has n entries
  -- aligned with chain \/ barSeq \/ modeList \/ modeResults.
  let tristrataIdxOf Tristrata
t =
        let tpairs :: [(Tristrata, Int)]
tpairs = [Tristrata] -> [Int] -> [(Tristrata, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Tristrata]
Sc.validTristrata [Int
1 :: Int ..]
        in Tristrata -> [(Tristrata, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Tristrata
t [(Tristrata, Int)]
tpairs
      -- Per-bar enharmonic spelling, derived from the mode's chroma via
      -- 'H.inferSpelling' with the triad's harmonic root as the leading
      -- pitch. Reuses the same tooling as the progression-grid chord
      -- naming (which also threads through 'inferSpelling' inside
      -- 'advanceStateTraced'), but scoped to the bar's full modal context
      -- rather than a single 3-note chord. This gives the diagnostic
      -- block one coherent accidental system.
      barSpellingOf :: [P.PitchClass] -> Int -> H.EnharmonicSpelling
      barSpellingOf [PitchClass]
chroma Int
rootPC =
        let pcs :: [Int]
pcs = Int
rootPC Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int
p | Int
p <- (PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
P.unPitchClass [PitchClass]
chroma, Int
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
rootPC]
        in [Int] -> EnharmonicSpelling
H.inferSpelling [Int]
pcs

      -- Slash-notation chord rendering using the bar's spelling.
      slashChordWith :: H.EnharmonicSpelling -> H.CadenceState -> String
      slashChordWith EnharmonicSpelling
spelling CadenceState
cs =
        (PitchClass -> NoteName) -> CadenceState -> [Char]
Prog.showHarmony (EnharmonicSpelling -> PitchClass -> NoteName
H.enharmonicFunc EnharmonicSpelling
spelling) CadenceState
cs

      attachedDiags =
        [ let rootPC :: Int
rootPC                = CadenceState -> Int
harmonicRootOf CadenceState
cs
              spelling :: EnharmonicSpelling
spelling              = [PitchClass] -> Int -> EnharmonicSpelling
barSpellingOf [PitchClass]
chroma Int
rootPC
              (Maybe Mode
mMode, Maybe (PitchClass, ScaleFamily)
mParentKey)   = case ModeResult
mr of
                Sc.ModeOk Mode
mode     -> (Mode -> Maybe Mode
forall a. a -> Maybe a
Just Mode
mode, (PitchClass, ScaleFamily) -> Maybe (PitchClass, ScaleFamily)
forall a. a -> Maybe a
Just (Mode -> (PitchClass, ScaleFamily)
Sc.parentKey Mode
mode))
                Sc.ModeInvalid [PitchClass]
_   -> (Maybe Mode
forall a. Maybe a
Nothing, Maybe (PitchClass, ScaleFamily)
forall a. Maybe a
Nothing)
          in StepDiagnostic
d { sdStepNumber     = i + 1
               , sdRenderedChord  = Just (slashChordWith spelling cs)
               , sdStrataLabel    = Just s
               , sdTristrata      = Just t
               , sdTristrataIdx   = tristrataIdxOf t
               , sdMode           = mMode
               , sdStrataChroma   = Just (Sc.strataChroma s)
               , sdModeChroma     = Just chroma
               , sdSoftBoost      = Just (boostFor i)
               , sdHarmonicRootPC = Just rootPC
               , sdParentKey      = mParentKey
               , sdModeResult     = Just mr
               , sdBarSpelling    = Just spelling
               }
        | (Int
i, StepDiagnostic
d, (StrataLabel
s, Tristrata
t), [PitchClass]
chroma, CadenceState
cs, ModeResult
mr) <- [Int]
-> [StepDiagnostic]
-> [(StrataLabel, Tristrata)]
-> [[PitchClass]]
-> [CadenceState]
-> [ModeResult]
-> [(Int, StepDiagnostic, (StrataLabel, Tristrata), [PitchClass],
     CadenceState, ModeResult)]
forall {a} {b} {c} {d} {e} {f}.
[a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [(a, b, c, d, e, f)]
zip6 [Int
0..] [StepDiagnostic]
allBaseDiags [(StrataLabel, Tristrata)]
barSeq [[PitchClass]]
modeChromaList [CadenceState]
chain [ModeResult]
modeResults
        ]
      attachedGen = GenerationDiagnostics
        { gdStartCadence :: [Char]
gdStartCadence = Cadence -> [Char]
forall a. Show a => a -> [Char]
show (CadenceState -> Cadence
H.stateCadence CadenceState
start)
        , gdStartRoot :: [Char]
gdStartRoot    = NoteName -> [Char]
forall a. Show a => a -> [Char]
show (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
start)
        , gdRequestedLen :: Int
gdRequestedLen = Int
n
        , gdActualLen :: Int
gdActualLen    = [CadenceState] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CadenceState]
chain
        , gdEntropy :: Double
gdEntropy      = GenConfig -> Double
_gcEntropy GenConfig
gc
        , gdSteps :: [StepDiagnostic]
gdSteps        = [StepDiagnostic]
attachedDiags
        , gdProgression :: Progression
gdProgression  = ProgressionContext -> Progression
PC.triadLayer ProgressionContext
resultPC
        , gdJazzTrace :: [[Char]]
gdJazzTrace    = []
        }

  -- No inline printing; diagnostics and footer are emitted by the
  -- top-level caller via @emitFinalised@, so that multi-attempt mode
  -- can suppress losing attempts and surface only the winner.
  let _ = verbArg

  pure (resultPC, attachedGen)
  where
    zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [(a, b, c, d, e, f)]
zip6 [a]
as [b]
bs [c]
cs [d]
ds [e]
es [f]
fs =
      [ (a
a, b
b, c
c, d
d, e
e, f
f)
      | ((a
a, b
b, c
c), (d
d, e
e, f
f)) <- [(a, b, c)] -> [(d, e, f)] -> [((a, b, c), (d, e, f))]
forall a b. [a] -> [b] -> [(a, b)]
zip ([a] -> [b] -> [c] -> [(a, b, c)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [a]
as [b]
bs [c]
cs) ([d] -> [e] -> [f] -> [(d, e, f)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [d]
ds [e]
es [f]
fs)
      ]

-- |Build a synthetic starter diagnostic for a 'Harmonic.Framework.Builder.genP' bar 0 (the cue).
-- The cue isn't selected from a candidate pool, so 'sdSelectedFrom' =
-- "starter" signals the renderer to omit the motion\/γ cells.
mkStarterDiag :: H.CadenceState -> StepDiagnostic
mkStarterDiag :: CadenceState -> StepDiagnostic
mkStarterDiag CadenceState
cs =
  let rootPC :: Int
rootPC = PitchClass -> Int
P.unPitchClass (NoteName -> PitchClass
P.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
cs))
  in StepDiagnostic
       { sdStepNumber :: Int
sdStepNumber              = Int
1
       , sdPriorCadence :: [Char]
sdPriorCadence            = [Char]
""
       , sdPriorRoot :: [Char]
sdPriorRoot               = [Char]
""
       , sdPriorRootPC :: Int
sdPriorRootPC             = Int
rootPC
       , sdSelectedDbIntervals :: [Char]
sdSelectedDbIntervals     = [Char]
""
       , sdSelectedDbMovement :: [Char]
sdSelectedDbMovement      = [Char]
""
       , sdSelectedDbFunctionality :: [Char]
sdSelectedDbFunctionality = [Char]
""
       , sdGraphCount :: Int
sdGraphCount              = Int
0
       , sdGraphTop6 :: [([Char], Double)]
sdGraphTop6               = []
       , sdFallbackCount :: Int
sdFallbackCount           = Int
0
       , sdFallbackTop6 :: [([Char], Double, Double, Double, Double)]
sdFallbackTop6            = []
       , sdPoolSize :: Int
sdPoolSize                = Int
0
       , sdEntropyUsed :: Double
sdEntropyUsed             = Double
0
       , sdGammaIndex :: Int
sdGammaIndex              = -Int
1
       , sdSelectedFrom :: [Char]
sdSelectedFrom            = [Char]
"starter"
       , sdPosteriorRoot :: [Char]
sdPosteriorRoot           = NoteName -> [Char]
forall a. Show a => a -> [Char]
show (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
cs)
       , sdPosteriorRootPC :: Int
sdPosteriorRootPC         = Int
rootPC
       , sdRenderedChord :: Maybe [Char]
sdRenderedChord           = Maybe [Char]
forall a. Maybe a
Nothing
       , sdTransformTrace :: Maybe TransformTrace
sdTransformTrace          = Maybe TransformTrace
forall a. Maybe a
Nothing
       , sdAdvanceTrace :: Maybe AdvanceTrace
sdAdvanceTrace            = Maybe AdvanceTrace
forall a. Maybe a
Nothing
       , sdTristrataIdx :: Maybe Int
sdTristrataIdx            = Maybe Int
forall a. Maybe a
Nothing
       , sdTristrata :: Maybe Tristrata
sdTristrata               = Maybe Tristrata
forall a. Maybe a
Nothing
       , sdStrataLabel :: Maybe StrataLabel
sdStrataLabel             = Maybe StrataLabel
forall a. Maybe a
Nothing
       , sdMode :: Maybe Mode
sdMode                    = Maybe Mode
forall a. Maybe a
Nothing
       , sdStrataChroma :: Maybe [PitchClass]
sdStrataChroma            = Maybe [PitchClass]
forall a. Maybe a
Nothing
       , sdModeChroma :: Maybe [PitchClass]
sdModeChroma              = Maybe [PitchClass]
forall a. Maybe a
Nothing
       , sdSoftBoost :: Maybe Double
sdSoftBoost               = Maybe Double
forall a. Maybe a
Nothing
       , sdHarmonicRootPC :: Maybe Int
sdHarmonicRootPC          = Maybe Int
forall a. Maybe a
Nothing
       , sdParentKey :: Maybe (PitchClass, ScaleFamily)
sdParentKey               = Maybe (PitchClass, ScaleFamily)
forall a. Maybe a
Nothing
       , sdModeResult :: Maybe ModeResult
sdModeResult              = Maybe ModeResult
forall a. Maybe a
Nothing
       , sdBarSpelling :: Maybe EnharmonicSpelling
sdBarSpelling             = Maybe EnharmonicSpelling
forall a. Maybe a
Nothing
       , sdPoly :: Maybe PolyDiag
sdPoly                    = Maybe PolyDiag
forall a. Maybe a
Nothing
       }

-------------------------------------------------------------------------------
-- Strata-aware partial regeneration
-------------------------------------------------------------------------------

-- |Regenerate a contiguous range of bars within an existing strata-aware
-- 'PC.ProgressionContext'. Mirrors 'runStrataGen' but seeded from the
-- source context's provenance instead of via 'Harmonic.Framework.Builder.Strata.initialPlacement', with a
-- one-step lookahead on the final regenerated bar so the @e → e+1@ seam
-- preserves walk-graph validity under 'Strata.allowedNext'.
--
-- By the Phase 1 invariant, any spliced sequence whose every edge satisfies
-- 'Harmonic.Framework.Builder.Strata.allowedNext' automatically produces only 'Harmonic.Rules.Types.Scale.ModeOk' bars. Maintaining
-- adjacency at both seams (the @s-1 → s@ seam is automatic via seeding;
-- the @e → e+1@ seam is the lookahead's job) is sufficient.
runStrataGenFrom :: PC.ProgressionContext
                 -> Int   -- ^ 1-indexed start of regen range (inclusive)
                 -> Int   -- ^ 1-indexed end of regen range (inclusive); wraps when @start > end@
                 -> GenConfig
                 -> IO (PC.ProgressionContext, GenerationDiagnostics)
runStrataGenFrom :: ProgressionContext
-> Int
-> Int
-> GenConfig
-> IO (ProgressionContext, GenerationDiagnostics)
runStrataGenFrom ProgressionContext
srcPC Int
s Int
_e GenConfig
gc = do
  let srcProvSeq :: Seq (Tristrata, StrataLabel)
srcProvSeq = case ProgressionContext -> Maybe (Seq (Tristrata, StrataLabel))
PC.pcProvenance ProgressionContext
srcPC of
        Just Seq (Tristrata, StrataLabel)
sq -> Seq (Tristrata, StrataLabel)
sq
        Maybe (Seq (Tristrata, StrataLabel))
Nothing -> [Char] -> Seq (Tristrata, StrataLabel)
forall a. HasCallStack => [Char] -> a
error [Char]
"runStrataGenFrom: source ProgressionContext lacks pcProvenance — call genFrom on a 'genI'/'genP'-derived context"
      srcProvList :: [(Tristrata, StrataLabel)]
srcProvList = Seq (Tristrata, StrataLabel) -> [(Tristrata, StrataLabel)]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Tristrata, StrataLabel)
srcProvSeq                -- [(Tristrata, StrataLabel)]
      srcN :: Int
srcN        = Seq (Tristrata, StrataLabel) -> Int
forall a. Seq a -> Int
Seq.length Seq (Tristrata, StrataLabel)
srcProvSeq
      -- 1-indexed positions (wrap-aware).
      seedPos :: Int
seedPos     = ((Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
srcN) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
      -- _gcLen carries the regen size: genFrom seeds it with the s..e
      -- range and the len modifier may expand it, exactly as on the
      -- legacy (FromProg) and jazz (FromProgJ) paths. The effective end
      -- bar and the seam target derive from it.
      rSize :: Int
rSize       = GenConfig -> Int
_gcLen GenConfig
gc
      effE :: Int
effE        = ((Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
srcN) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
      targetPos :: Int
targetPos   = (Int
effE Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
srcN) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
      (Tristrata
t_seed,   StrataLabel
s_seed)   = [(Tristrata, StrataLabel)]
srcProvList [(Tristrata, StrataLabel)] -> Int -> (Tristrata, StrataLabel)
forall a. HasCallStack => [a] -> Int -> a
!! (Int
seedPos   Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      (Tristrata
t_target, StrataLabel
s_target) = [(Tristrata, StrataLabel)]
srcProvList [(Tristrata, StrataLabel)] -> Int -> (Tristrata, StrataLabel)
forall a. HasCallStack => [a] -> Int -> a
!! (Int
targetPos Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

      -- Cue: the source's triad-layer chord at seedPos. This was originally
      -- generated under the seed strata's narrowed context, so its absolute
      -- PCs lie within 's_seed's chroma — cue-validity is automatic.
      triadStates :: [CadenceState]
triadStates = Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Prog.unProgression (ProgressionContext -> Progression
PC.triadLayer ProgressionContext
srcPC))
      cueCS :: CadenceState
cueCS       = [CadenceState]
triadStates [CadenceState] -> Int -> CadenceState
forall a. HasCallStack => [a] -> Int -> a
!! (Int
seedPos Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

  rng <- IO (Gen RealWorld)
IO GenIO
createSystemRandom
  let basePctx = HarmonicContext -> ParsedContext
parseContextOnce (GenConfig -> HarmonicContext
_gcTonal GenConfig
gc)
      allowed  = ParsedContext -> [Tristrata]
pcAllowedTristrata ParsedContext
basePctx
      allowed' = if [Tristrata] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Tristrata]
allowed then [Tristrata]
Sc.validTristrata else [Tristrata]
allowed

      narrow :: Int -> [(Sc.StrataLabel, Sc.Tristrata)] -> [(Sc.StrataLabel, Sc.Tristrata)]
      narrow Int
i [(StrataLabel, Tristrata)]
pool =
        let pool1 :: [(StrataLabel, Tristrata)]
pool1 = case GenConfig -> Maybe [Int]
_gcRelStrata GenConfig
gc of
              Just [Int]
ps | Bool -> Bool
not ([Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
ps) ->
                let p :: Int
p = [Int]
ps [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! (Int
i 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]
ps)
                in [(StrataLabel
s',Tristrata
t') | (StrataLabel
s',Tristrata
t') <- [(StrataLabel, Tristrata)]
pool, Tristrata -> Int -> StrataLabel
Sc.tristrataStrataAt Tristrata
t' Int
p StrataLabel -> StrataLabel -> Bool
forall a. Eq a => a -> a -> Bool
== StrataLabel
s']
              Maybe [Int]
_ -> [(StrataLabel, Tristrata)]
pool
            pool2 :: [(StrataLabel, Tristrata)]
pool2 = case GenConfig -> Maybe [StrataLabel]
_gcAbsStrata GenConfig
gc of
              Just [StrataLabel]
ss | Bool -> Bool
not ([StrataLabel] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StrataLabel]
ss) ->
                let lbl :: StrataLabel
lbl = [StrataLabel]
ss [StrataLabel] -> Int -> StrataLabel
forall a. HasCallStack => [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` [StrataLabel] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StrataLabel]
ss)
                in [(StrataLabel
s',Tristrata
t') | (StrataLabel
s',Tristrata
t') <- [(StrataLabel, Tristrata)]
pool1, StrataLabel
s' StrataLabel -> StrataLabel -> Bool
forall a. Eq a => a -> a -> Bool
== StrataLabel
lbl]
              Maybe [StrataLabel]
_ -> [(StrataLabel, Tristrata)]
pool1
        in [(StrataLabel, Tristrata)]
pool2

  walkSeeds <- mapM (const (uniformRM (minBound :: Int, maxBound :: Int) rng))
                    [1 .. max 0 rSize]

  let -- Full (strata, tristrata) state space under the allow-list.
      allPairs = [(StrataLabel, Tristrata)] -> [(StrataLabel, Tristrata)]
forall a. Eq a => [a] -> [a]
nub [ (Tristrata -> Int -> StrataLabel
Sc.tristrataStrataAt Tristrata
t Int
p, Tristrata
t) | Tristrata
t <- [Tristrata]
allowed', Int
p <- [Int
1, Int
2, Int
3] ]

      -- Backward reachability to the seam target: @viableTbl !! i@ is the
      -- set of states permitted at regen bar @i@ from which the target
      -- bar's (strata, tristrata) is reachable through every remaining
      -- bar. Filtering each step's pool by it makes the e→e+1 seam an
      -- allowedNext edge BY CONSTRUCTION — there is no unfiltered escape
      -- hatch, so the module's walk-validity invariant holds on every
      -- output. A walk that cannot reconnect at all refuses loudly below.
      viableTbl :: [[(Sc.StrataLabel, Sc.Tristrata)]]
      viableTbl = [ Int -> [(StrataLabel, Tristrata)]
viable Int
i | Int
i <- [Int
0 .. Int
rSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ]
        where
          viable :: Int -> [(StrataLabel, Tristrata)]
viable Int
i
            | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
rSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 =
                [ (StrataLabel, Tristrata)
p | (StrataLabel, Tristrata)
p <- Int -> [(StrataLabel, Tristrata)] -> [(StrataLabel, Tristrata)]
narrow Int
i [(StrataLabel, Tristrata)]
allPairs
                    , (StrataLabel
s_target, Tristrata
t_target) (StrataLabel, Tristrata) -> [(StrataLabel, Tristrata)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Tristrata]
-> (StrataLabel, Tristrata) -> [(StrataLabel, Tristrata)]
Strata.allowedNext [Tristrata]
allowed' (StrataLabel, Tristrata)
p ]
            | Bool
otherwise =
                let nxt :: [(StrataLabel, Tristrata)]
nxt = [[(StrataLabel, Tristrata)]]
viableTbl [[(StrataLabel, Tristrata)]] -> Int -> [(StrataLabel, Tristrata)]
forall a. HasCallStack => [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                in [ (StrataLabel, Tristrata)
p | (StrataLabel, Tristrata)
p <- Int -> [(StrataLabel, Tristrata)] -> [(StrataLabel, Tristrata)]
narrow Int
i [(StrataLabel, Tristrata)]
allPairs
                       , ((StrataLabel, Tristrata) -> Bool)
-> [(StrataLabel, Tristrata)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((StrataLabel, Tristrata) -> [(StrataLabel, Tristrata)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(StrataLabel, Tristrata)]
nxt) ([Tristrata]
-> (StrataLabel, Tristrata) -> [(StrataLabel, Tristrata)]
Strata.allowedNext [Tristrata]
allowed' (StrataLabel, Tristrata)
p) ]

      -- Walk rSize bars seeded at (s_seed, t_seed), each pool restricted
      -- to target-reachable states. By induction the pool can only be
      -- empty at bar 0 (the cue cannot reach the target in rSize steps
      -- under the active narrowing) — the error names the way out.
      walkRange :: Int -> [Int] -> (Sc.StrataLabel, Sc.Tristrata) -> [(Sc.StrataLabel, Sc.Tristrata)]
      walkRange Int
i [Int]
seeds (StrataLabel, Tristrata)
prev
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
rSize = []
        | Bool
otherwise =
            let rawCands :: [(StrataLabel, Tristrata)]
rawCands = Int -> [(StrataLabel, Tristrata)] -> [(StrataLabel, Tristrata)]
narrow Int
i ([Tristrata]
-> (StrataLabel, Tristrata) -> [(StrataLabel, Tristrata)]
Strata.allowedNext [Tristrata]
allowed' (StrataLabel, Tristrata)
prev)
                cands :: [(StrataLabel, Tristrata)]
cands    = ((StrataLabel, Tristrata) -> Bool)
-> [(StrataLabel, Tristrata)] -> [(StrataLabel, Tristrata)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((StrataLabel, Tristrata) -> [(StrataLabel, Tristrata)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([[(StrataLabel, Tristrata)]]
viableTbl [[(StrataLabel, Tristrata)]] -> Int -> [(StrataLabel, Tristrata)]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i)) [(StrataLabel, Tristrata)]
rawCands
                (Int
seed, [Int]
seedsRest) = case [Int]
seeds of
                  (Int
sd : [Int]
rest) -> (Int
sd, [Int]
rest)
                  []          -> (Int
0, [])
                chosen :: (StrataLabel, Tristrata)
chosen = case Int
-> (StrataLabel, Tristrata)
-> [(StrataLabel, Tristrata)]
-> Maybe (StrataLabel, Tristrata)
Strata.selectNextSeeded Int
seed (StrataLabel, Tristrata)
prev [(StrataLabel, Tristrata)]
cands of
                  Just (StrataLabel, Tristrata)
c  -> (StrataLabel, Tristrata)
c
                  Maybe (StrataLabel, Tristrata)
Nothing -> [Char] -> (StrataLabel, Tristrata)
forall a. HasCallStack => [Char] -> a
error
                    ([Char]
"genFrom: the regenerated range cannot reconnect to the bar after it under the active strata constraints — widen the range (len), relax relStrata/absStrata, or regenerate through the seam")
            in (StrataLabel, Tristrata)
chosen (StrataLabel, Tristrata)
-> [(StrataLabel, Tristrata)] -> [(StrataLabel, Tristrata)]
forall a. a -> [a] -> [a]
: Int
-> [Int] -> (StrataLabel, Tristrata) -> [(StrataLabel, Tristrata)]
walkRange (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Int]
seedsRest (StrataLabel, Tristrata)
chosen

      -- Local barSeq passed to runStrataGenBody. Index 0 = seed (the cue),
      -- indices 1..rSize = the regenerated bars.
      regenBarSeq :: [(Sc.StrataLabel, Sc.Tristrata)]
      regenBarSeq = (StrataLabel
s_seed, Tristrata
t_seed) (StrataLabel, Tristrata)
-> [(StrataLabel, Tristrata)] -> [(StrataLabel, Tristrata)]
forall a. a -> [a] -> [a]
: Int
-> [Int] -> (StrataLabel, Tristrata) -> [(StrataLabel, Tristrata)]
walkRange Int
0 [Int]
walkSeeds (StrataLabel
s_seed, Tristrata
t_seed)
      regenN      = [(StrataLabel, Tristrata)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(StrataLabel, Tristrata)]
regenBarSeq   -- = rSize + 1

      strataOvertonesString :: Sc.StrataLabel -> String
      strataOvertonesString StrataLabel
sl =
        [[Char]] -> [Char]
unwords [ NoteName -> [Char]
forall a. Show a => a -> [Char]
show (PitchClass -> NoteName
P.sharp (Int -> PitchClass
P.mkPitchClass (PitchClass -> Int
P.unPitchClass PitchClass
pc))) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'"
                | PitchClass
pc <- StrataLabel -> [PitchClass]
Sc.strataChroma StrataLabel
sl ]

      boostFor :: Int -> Double
      boostFor Int
0 = Double
1.0
      boostFor Int
i =
        let (StrataLabel
sCurr, Tristrata
tCurr) = [(StrataLabel, Tristrata)]
regenBarSeq [(StrataLabel, Tristrata)] -> Int -> (StrataLabel, Tristrata)
forall a. HasCallStack => [a] -> Int -> a
!! Int
i
            (StrataLabel
sPrev, Tristrata
tPrev) = [(StrataLabel, Tristrata)]
regenBarSeq [(StrataLabel, Tristrata)] -> Int -> (StrataLabel, Tristrata)
forall a. HasCallStack => [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
            sGrand :: Maybe StrataLabel
sGrand         = if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 then StrataLabel -> Maybe StrataLabel
forall a. a -> Maybe a
Just ((StrataLabel, Tristrata) -> StrataLabel
forall a b. (a, b) -> a
fst ([(StrataLabel, Tristrata)]
regenBarSeq [(StrataLabel, Tristrata)] -> Int -> (StrataLabel, Tristrata)
forall a. HasCallStack => [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2))) else Maybe StrataLabel
forall a. Maybe a
Nothing
            mSame :: Double
mSame = if StrataLabel
sCurr StrataLabel -> StrataLabel -> Bool
forall a. Eq a => a -> a -> Bool
== StrataLabel
sPrev then GenConfig -> Double
_gcBoostSame GenConfig
gc else Double
1.0
            mFlip :: Double
mFlip = case Maybe StrataLabel
sGrand of
                      Just StrataLabel
sg | StrataLabel
sCurr StrataLabel -> StrataLabel -> Bool
forall a. Eq a => a -> a -> Bool
== StrataLabel
sg Bool -> Bool -> Bool
&& StrataLabel
sCurr StrataLabel -> StrataLabel -> Bool
forall a. Eq a => a -> a -> Bool
/= StrataLabel
sPrev -> GenConfig -> Double
_gcBoostFlip GenConfig
gc
                      Maybe StrataLabel
_                                        -> Double
1.0
            mTri :: Double
mTri  = if Tristrata
tCurr Tristrata -> Tristrata -> Bool
forall a. Eq a => a -> a -> Bool
== Tristrata
tPrev then GenConfig -> Double
_gcBoostTri GenConfig
gc else Double
1.0
            Tristrata
_     = Tristrata
tPrev
        in Double
mSame Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
mFlip Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
mTri

      pctxAt :: Int -> ParsedContext
      pctxAt Int
barIdx1 =
        let i :: Int
i      = Int
barIdx1
            (StrataLabel
sl, Tristrata
_) = [(StrataLabel, Tristrata)]
regenBarSeq [(StrataLabel, Tristrata)] -> Int -> (StrataLabel, Tristrata)
forall a. HasCallStack => [a] -> Int -> a
!! Int
i
            ctx' :: HarmonicContext
ctx'   = [Char] -> HarmonicContext -> HarmonicContext
hcOvertones (StrataLabel -> [Char]
strataOvertonesString StrataLabel
sl) (GenConfig -> HarmonicContext
_gcTonal GenConfig
gc)
            pctx :: ParsedContext
pctx   = HarmonicContext -> ParsedContext
parseContextOnce HarmonicContext
ctx'
            boost :: Double
boost  = Int -> Double
boostFor Int
i
        in ParsedContext
pctx { pcSoftBoost = boost, pcStrictContainment = True }

  -- Reuse runStrataGenBody for chain construction. Result has regenN bars
  -- across all layers: index 0 = the seed (cue) bar, indices 1..rSize =
  -- the regenerated bars.
  (regenPC, regenDiag) <- runStrataGenBody s_seed gc cueCS rng s_seed t_seed
                                           regenBarSeq pctxAt boostFor regenN

  let -- Drop the cue bar (index 0) from each layer and from provenance.
      dropCue :: Prog.Progression -> Prog.Progression
      dropCue (Prog.Progression Seq CadenceState
sq) = Seq CadenceState -> Progression
Prog.Progression (Int -> Seq CadenceState -> Seq CadenceState
forall a. Int -> Seq a -> Seq a
Seq.drop Int
1 Seq CadenceState
sq)

      insertPC = PC.ProgressionContext
        { triadLayer :: Progression
PC.triadLayer   = Progression -> Progression
dropCue (ProgressionContext -> Progression
PC.triadLayer ProgressionContext
regenPC)
        , strataLayer :: Progression
PC.strataLayer  = Progression -> Progression
dropCue (ProgressionContext -> Progression
PC.strataLayer ProgressionContext
regenPC)
        , modeLayer :: Progression
PC.modeLayer    = Progression -> Progression
dropCue (ProgressionContext -> Progression
PC.modeLayer ProgressionContext
regenPC)
        , pcProvenance :: Maybe (Seq (Tristrata, StrataLabel))
PC.pcProvenance = case ProgressionContext -> Maybe (Seq (Tristrata, StrataLabel))
PC.pcProvenance ProgressionContext
regenPC of
            Just Seq (Tristrata, StrataLabel)
sq -> Seq (Tristrata, StrataLabel)
-> Maybe (Seq (Tristrata, StrataLabel))
forall a. a -> Maybe a
Just (Int -> Seq (Tristrata, StrataLabel) -> Seq (Tristrata, StrataLabel)
forall a. Int -> Seq a -> Seq a
Seq.drop Int
1 Seq (Tristrata, StrataLabel)
sq)
            Maybe (Seq (Tristrata, StrataLabel))
Nothing -> Maybe (Seq (Tristrata, StrataLabel))
forall a. Maybe a
Nothing
        , pcFamily :: Family
PC.pcFamily     = ProgressionContext -> Family
PC.pcFamily ProgressionContext
regenPC
        }
      splicedPC = ProgressionContext
-> Int -> Int -> ProgressionContext -> ProgressionContext
PC.pcSplice ProgressionContext
srcPC Int
s Int
effE ProgressionContext
insertPC

  pure (splicedPC, regenDiag)


-- |Report an invalid starting cue for 'Harmonic.Framework.Builder.genP'. Prints a warning naming
-- the cue's escape pitches alongside a grid of viable triads in the
-- starting strata. Returns silently — the caller emits an empty
-- 'Harmonic.Rules.Types.ProgressionContext.ProgressionContext' after this.
printInvalidCueError :: H.CadenceState -> Sc.StrataLabel -> IO ()
printInvalidCueError :: CadenceState -> StrataLabel -> IO ()
printInvalidCueError CadenceState
start StrataLabel
s = do
  let rootPC :: Int
rootPC       = PitchClass -> Int
P.unPitchClass (NoteName -> PitchClass
P.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
start))
      intervals :: [Int]
intervals    = (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
start))
      absPCs :: [Int]
absPCs       = [ (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]
intervals ]
      spelling :: EnharmonicSpelling
spelling     = [Int] -> EnharmonicSpelling
H.inferSpelling [Int]
absPCs
      enharm :: PitchClass -> NoteName
enharm       = EnharmonicSpelling -> PitchClass -> NoteName
H.enharmonicFunc EnharmonicSpelling
spelling
      chordName :: [Char]
chordName    = (PitchClass -> NoteName) -> CadenceState -> [Char]
Prog.showHarmony PitchClass -> NoteName
enharm CadenceState
start
      strataPCs :: [Int]
strataPCs    = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ((PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
P.unPitchClass (StrataLabel -> [PitchClass]
Sc.strataChroma StrataLabel
s))
      offenders :: [Int]
offenders    = [ Int
p | Int
p <- [Int]
absPCs, Int
p Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Int]
strataPCs ]
      spellPC :: Int -> [Char]
spellPC Int
p    = NoteName -> [Char]
forall a. Show a => a -> [Char]
show (PitchClass -> NoteName
enharm (Int -> PitchClass
P.mkPitchClass Int
p))
      strataNames :: [Char]
strataNames  = [[Char]] -> [Char]
unwords ((Int -> [Char]) -> [Int] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Int -> [Char]
spellPC [Int]
strataPCs)
      offenderStr :: [Char]
offenderStr  = [[Char]] -> [Char]
unwords ((Int -> [Char]) -> [Int] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Int -> [Char]
spellPC [Int]
offenders)
  [Char] -> IO ()
putStrLn [Char]
""
  [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"⚠ invalid starting state: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
chordName
             [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  (escapes strata " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StrataLabel -> [Char]
forall a. Show a => a -> [Char]
show StrataLabel
s
             [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" — contains " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
offenderStr [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" outside {" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
strataNames [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"})"
  [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"  viable triads in strata " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StrataLabel -> [Char]
forall a. Show a => a -> [Char]
show StrataLabel
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" {" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
strataNames [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"}:"
  ([Char] -> IO ()) -> [[Char]] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Char] -> IO ()
putStrLn ([Char] -> IO ()) -> ([Char] -> [Char]) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"    " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)) (StrataLabel -> (PitchClass -> NoteName) -> [[Char]]
viableTriadLines StrataLabel
s PitchClass -> NoteName
enharm)
  [Char] -> IO ()
putStrLn [Char]
""

-- |A starting chord drawn from inside the stratum a label resolves to under
-- this config's tonal context.
--
-- Shared with @generateBest@ so a K-attempt loop freezes ONE valid chord:
-- without it the loop's frozen cue is ignored (genP draws its own) and every
-- attempt starts somewhere different, which is exactly what freezing the cue
-- exists to prevent.
strataStartCue :: Sc.StrataLabel -> GenConfig -> IO H.CadenceState
strataStartCue :: StrataLabel -> GenConfig -> IO CadenceState
strataStartCue StrataLabel
sStart GenConfig
gc = do
  rng <- IO (Gen RealWorld)
IO GenIO
createSystemRandom
  let basePctx = HarmonicContext -> ParsedContext
parseContextOnce (GenConfig -> HarmonicContext
_gcTonal GenConfig
gc)
      allowed  = ParsedContext -> [Tristrata]
pcAllowedTristrata ParsedContext
basePctx
      allowed' = if [Tristrata] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Tristrata]
allowed then [Tristrata]
Sc.validTristrata else [Tristrata]
allowed
      (s0, _)  = Strata.initialPlacement allowed' sStart
  strataCue rng s0

-- |Draw a random triad lying wholly inside a stratum's chroma.
--
-- Without this, an uncued 'Harmonic.Framework.Builder.genP' inherits the
-- whole-corpus random cue, which a five-tone stratum almost never admits:
-- measured across all eleven labels, 86 of 88 uncued draws escaped the
-- stratum and returned an empty progression. The pool is the same
-- enumeration 'viableTriadLines' prints, so what the generator picks and
-- what the invalid-cue message offers can never disagree.
--
-- A deliberate cue is never overridden — an escaping one still earns the
-- teaching diagnostic.
strataCue :: GenIO -> Sc.StrataLabel -> IO H.CadenceState
strataCue :: GenIO -> StrataLabel -> IO CadenceState
strataCue GenIO
rng StrataLabel
s0 =
  let strataPCs :: [Int]
strataPCs = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ((PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
P.unPitchClass (StrataLabel -> [PitchClass]
Sc.strataChroma StrataLabel
s0))
      pool0 :: [(Int, [Int])]
pool0     = [ (Int
r, [ (Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12 | Int
p <- [Int]
pcs ])
                  | Int
r <- [Int]
strataPCs, [Int]
pcs <- (Int, [Int]) -> [[Int]]
possibleTriads (Int
r, [Int]
strataPCs) ]
      -- Never open on a slash chord: inversion shapes stay available to
      -- the walk, just not as the uncued bar 1.
      probe :: (Int, [Int]) -> CadenceState
probe (Int
r, [Int]
ivs) =
        let nm :: NoteName
nm = EnharmonicSpelling -> PitchClass -> NoteName
H.enharmonicFunc EnharmonicSpelling
H.FlatSpelling (Int -> PitchClass
P.mkPitchClass Int
r)
        in Int -> [Char] -> [Int] -> CadenceState
H.initCadenceState Int
0 (NoteName -> [Char]
forall a. Show a => a -> [Char]
show NoteName
nm) [Int]
ivs
      pool :: [(Int, [Int])]
pool = case ((Int, [Int]) -> Bool) -> [(Int, [Int])] -> [(Int, [Int])]
forall a. (a -> Bool) -> [a] -> [a]
filter (CadenceState -> Bool
rootPositionCue (CadenceState -> Bool)
-> ((Int, [Int]) -> CadenceState) -> (Int, [Int]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, [Int]) -> CadenceState
probe) [(Int, [Int])]
pool0 of
               [] -> [(Int, [Int])]
pool0
               [(Int, [Int])]
ps -> [(Int, [Int])]
ps
  in case [(Int, [Int])]
pool of
       -- Unreachable: every stratum admits triads. Answering with a bare
       -- major triad keeps the function total rather than exploding on the
       -- audio-adjacent path.
       []              -> CadenceState -> IO CadenceState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> [Char] -> [Int] -> CadenceState
H.initCadenceState Int
0 [Char]
"C" [Int
0, Int
4, Int
7])
       ((Int, [Int])
fallback : [(Int, [Int])]
_)  -> do
         i <- (Int, Int) -> Gen RealWorld -> IO Int
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *). StatefulGen g m => (Int, Int) -> g -> m Int
uniformRM (Int
0, [(Int, [Int])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, [Int])]
pool Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Gen RealWorld
GenIO
rng
         let (rootPC, ivs) = case drop i pool of
                               ((Int, [Int])
x : [(Int, [Int])]
_) -> (Int, [Int])
x
                               []      -> (Int, [Int])
fallback
             rootName = EnharmonicSpelling -> PitchClass -> NoteName
H.enharmonicFunc EnharmonicSpelling
H.FlatSpelling (Int -> PitchClass
P.mkPitchClass Int
rootPC)
         pure (H.initCadenceState 0 (show rootName) ivs)

-- |Produce one display line per root PC in the strata, listing every
-- distinct-by-name triad enumerated by 'possibleTriads' starting from
-- that root. Uses 'Prog.showTriad' for chord naming to match the grid
-- footer convention. Triads are padded to a uniform column width so
-- they align vertically across rows.
viableTriadLines :: Sc.StrataLabel -> (P.PitchClass -> P.NoteName) -> [String]
viableTriadLines :: StrataLabel -> (PitchClass -> NoteName) -> [[Char]]
viableTriadLines StrataLabel
s PitchClass -> NoteName
enharm =
  let strataPCs :: [Int]
strataPCs = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ((PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
P.unPitchClass (StrataLabel -> [PitchClass]
Sc.strataChroma StrataLabel
s))
      triadsFor :: Int -> [[Char]]
triadsFor Int
r =
        let ts :: [[Int]]
ts = (Int, [Int]) -> [[Int]]
possibleTriads (Int
r, [Int]
strataPCs)
            names :: [[Char]]
names = [[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a]
nub [ (PitchClass -> NoteName) -> Chord -> [Char]
Prog.showTriad PitchClass -> NoteName
enharm ((PitchClass -> NoteName) -> [Int] -> Chord
H.toTriad PitchClass -> NoteName
enharm [Int]
pcs) | [Int]
pcs <- [[Int]]
ts ]
        in [[Char]]
names
      allNames :: [[Char]]
allNames  = (Int -> [[Char]]) -> [Int] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Int -> [[Char]]
triadsFor [Int]
strataPCs
      colWidth :: Int
colWidth  = if [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
allNames then Int
0 else [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (([Char] -> Int) -> [[Char]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
allNames) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
      rootField :: Int -> [Char]
rootField = Int -> [Char] -> [Char]
padR Int
4 ([Char] -> [Char]) -> (Int -> [Char]) -> Int -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteName -> [Char]
forall a. Show a => a -> [Char]
show (NoteName -> [Char]) -> (Int -> NoteName) -> Int -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PitchClass -> NoteName
enharm (PitchClass -> NoteName) -> (Int -> PitchClass) -> Int -> NoteName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> PitchClass
P.mkPitchClass
  in [ Int -> [Char]
rootField Int
r [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([Char] -> [Char]) -> [[Char]] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> [Char] -> [Char]
padR Int
colWidth) (Int -> [[Char]]
triadsFor Int
r)
     | Int
r <- [Int]
strataPCs
     ]
  where
    padR :: Int -> [Char] -> [Char]
padR Int
n [Char]
str = [Char]
str [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
str)) Char
' '