-- |
-- Module      : Harmonic.Framework.Builder
-- Description : Generative engine for harmonic progressions with unified diagnostics interface
--
-- This module implements the main generation loop that connects:
--
--   * R (Rules): HarmonicContext constraints via Filter module
--   * E (Evaluation): Database-derived composer probabilities + dissonance
--   * T (Traversal): gamma-distributed sampling over the graph walk
--
-- == Academic Lineage
--
-- /Data Science In The Creative Process/ (South, 2018): Wiggins' Creative
-- Systems Framework \<R,T,E\> as the architectural blueprint. The Builder
-- orchestrates the R→E→T pipeline where R constrains the search space,
-- E scores candidates via database-derived probabilities, and T selects
-- via gamma-distributed probabilistic traversal.
--
-- == Unified Generation Interface
--
-- The module provides three public generation functions with /identical type signatures/:
--
-- @
--   genSilent    :: CadenceState -> Int -> String -> Double -> HarmonicContext -> IO Progression
--   genStandard  :: CadenceState -> Int -> String -> Double -> HarmonicContext -> IO Progression
--   genVerbose   :: CadenceState -> Int -> String -> Double -> HarmonicContext -> IO Progression
-- @
--
-- All three functions:
--   * Return @IO Progression@ (NOT tuples)
--   * Print diagnostics as /side effects/ based on verbosity level
--   * Enable seamless switching between verbosity levels without code changes
--
-- === Verbosity Levels
--
-- [0 - Silent] @genSilent@: No diagnostic output. Use when you only want the progression.
--
-- [1 - Standard] @genStandard@: Prints per-step diagnostics including:
--   * Prior and posterior cadence states
--   * Candidate pool composition (graph candidates, fallback candidates)
--   * Top candidates with scores
--   * Selected candidate source (graph or fallback)
--   * Rendered chord names
--
-- [2 - Verbose] @genVerbose@: Prints everything from Standard plus:
--   * TRANSFORM TRACE: Complete render pipeline (intervals, transposition, zero-form, naming)
--   * ADVANCE TRACE: Root motion computation with pitch class arithmetic
--   * Verification: DB stored name vs computed name
--
-- === Legacy Diagnostic Functions
--
-- For backward compatibility, the module still exports:
--   * @generate'@ - Returns @(Progression, GenerationDiagnostics)@ tuple
--   * @generate''@ - Returns @(Progression, GenerationDiagnostics)@ tuple with max diagnostics
--
-- Use these when you need to programmatically extract diagnostics rather than printing them.
--
-- == Score Composition Details
--
-- Fallback candidates are scored using the formula:
--
-- @
--   chordDiss     = Hindemith vertical dissonance (6-50 range)
--   motionDiss    = Root motion dissonance (1-6 range, vector-based)
--   gammaDraw     = Entropy-based random perturbation (~0-5, shape=1.01)
--
--   badness = chordDiss × motionDiss × (gammaDraw + 1)
--   score = 10000 - badness
-- @
--
-- The multiplicative formula spreads scores organically without artificial limits.
-- Full 660-candidate pool (12 roots × C(11,2) pairs) ensures maximum variety.
--
-- The database is treated as abstract\/pitch-agnostic. Root notes are
-- computed at runtime based on movement intervals from a user-defined
-- starting CadenceState.
--
-- == Filter Notation (from original README)
--
-- === Overtones\/Pitch Set Filter
-- * Fundamental pitches (derives overtones): @"E A D G"@ (bass tuning)
-- * Individual pitches with prime: @"E'"@ @"A'"@ @"A#'"@
-- * Combined: @"G E' A' A#'"@ (G overtones + E, A, A# pitches)
-- * Wildcard: @"*"@ (all pitches)
--
-- === Tonality (Key) Filter
-- * Key signature: @"bb"@, @"###"@, @"4b"@, @"0#"@
-- * Named key: @"C"@, @"G"@, @"F#"@, @"Bb"@
-- * Wildcard: @"*"@ (no key filtering)
--
-- === Root Notes Filter
-- * Pitches: @"E F# G"@
-- * Key signature: @"1b"@, @"#"@, @"##"@ (D major)
-- * Wildcard: @"*"@ (all roots)

module Harmonic.Framework.Builder
  ( -- * Modifier-Based Generation API
    gen
  , gen'
  , gen''
  , genGrid
  , genGrid'
  , genGrid''
  , genFrom
  , genFrom'
  , genFrom''

    -- * genE Paradigm (polytonal)
  , genE
  , genE'
  , genE''

    -- * genJ Paradigm (jazz Change graph)
  , genJ, genJ', genJ''
  , steer

    -- * genP Paradigm (strata-first)
  , genP
  , genP'
  , genP''
  , genI,   genII,   genIII,   genIV,   genV,   genVI,   genVII,   genVIII,   genIX,   genX,   genXI
  , genI',  genII',  genIII',  genIV',  genV',  genVI',  genVII',  genVIII',  genIX',  genX',  genXI'
  , genI'', genII'', genIII'', genIV'', genV'', genVI'', genVII'', genVIII'', genIX'', genX'', genXI''

    -- * Generation Modifiers
  , cue
  , len
  , seek
  , entropy
  , tonal
  , relStrata
  , absStrata
  , sameBoost
  , flipBoost
  , triBoost
  , attempt
  , viability

    -- * Generation Configuration
  , GenConfig(..)
  , GenMode(..)
  , Verbosity(..)
  , defaultGenConfig
  , execGenConfig
  , execGenConfigPC

    -- * Positional Generation (legacy\/internal)
  , generate
  , generateWith

    -- * Positional Generation with Diagnostics
  , generate'
  , generate''

    -- * Positional Generation with Print Output
  , genPrint
  , genPrint'
  , genPrint''

    -- * Unified Positional Interface
  , genSilent
  , genStandard
  , genVerbose
  , printDiagnostics

    -- * Diagnostics Types
  , StepDiagnostic(..)
  , GenerationDiagnostics(..)
  , TransformTrace(..)
  , AdvanceTrace(..)

    -- * Harmonic Context (R constraints)
  , HarmonicContext(..)
  , harmonicContext
  , hContext

    -- * Context Modifiers
  , Drift(..)
  , hcOvertones
  , hcKey
  , hcRoots
  , dissonant
  , consonant
  , invSkip
  , hcPedal
  , hcTristrata

    -- * Internal functions (exposed for testing)
  , parseComposersWithOrder
  , makePortmanteau
  , extractByPosition
  , takeFromBeginning
  , takeFromEnd
  , takeFromMiddle
  , printHeader
  ) where

import           Harmonic.Database (DbActionT, runDb)
import qualified Data.Text as T
import           Data.Text (Text)
import           Control.Monad (forM_, when)
import           Data.Char (toLower)
import           Data.List (intercalate)
import           System.Random.MWC (createSystemRandom)

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           Harmonic.Rules.Import.Graph (connectNeo4j)
import qualified Harmonic.Evaluation.Scoring.Progression as PS
import           Harmonic.Evaluation.Analysis.KeyArea (chordscale)
import           Control.Monad.IO.Class (liftIO)
import           Harmonic.Rules.Constraints.Filter (parseTuningNamed)
import           Harmonic.Rules.Constraints.Overtone (formatOvertoneAnnotationPipe)
import           Data.Foldable (toList)
import           Data.List (nub)
import qualified Data.IntSet as IntSet
import qualified Data.Sequence as Seq

-- Sub-module imports
import           Harmonic.Framework.Builder.Types
import           Harmonic.Framework.Builder.Portmanteau
import           Harmonic.Framework.Builder.Diagnostics
import           Harmonic.Framework.Builder.Core
import           Harmonic.Framework.Builder.Modifiers
import           Harmonic.Framework.Builder.StrataGen (runStrataGen, runStrataGenFrom, strataStartCue)
import           Harmonic.Framework.Builder.JazzGen (runJazzGen, runJazzGenFrom, jazzGuardSeek, jazzStartCue)
import           Harmonic.Framework.Builder.PolyGen (runPolyGen, runPolyGenFrom)

-------------------------------------------------------------------------------
-- Mode Display
-------------------------------------------------------------------------------

-- |Format the generation mode line for diagnostic output headers.
-- Shows offline status or the distinct composer names used for online generation.
composerModeStr :: String -> String
composerModeStr :: [Char] -> [Char]
composerModeStr [Char]
s
  | (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
s [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"none" = [Char]
"Mode: offline (fallback only — no graph)"
  | [Char]
s [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"*"                = [Char]
"Mode: online (composers: all)"
  | Bool
otherwise               = [Char]
"Mode: online (composers: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
names [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
  where
    names :: [Char]
names = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " (((Text, Double) -> [Char]) -> [(Text, Double)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> [Char]
T.unpack (Text -> [Char])
-> ((Text, Double) -> Text) -> (Text, Double) -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Double) -> Text
forall a b. (a, b) -> a
fst) (Text -> [(Text, Double)]
parseComposersWithOrder ([Char] -> Text
T.pack [Char]
s)))

-------------------------------------------------------------------------------
-- Main Generation Function
-------------------------------------------------------------------------------

-- |Generate a harmonic progression from a starting state.
--
-- Arguments:
--   * start: Initial CadenceState (defines starting root and quality)
--   * len: Number of chords to generate
--   * composerStr: Composer blend string ("bach:70 debussy:30")
--   * entropy: Gamma shape parameter (higher = more unusual choices)
--   * context: HarmonicContext filters (R constraints)
--
-- Algorithm:
--   1. Parse composer weights
--   2. For each step: query graph, apply R filter, apply E weights, gamma select
--   3. Apply voice leading optimization to the complete chain
--
-- Returns: Progression type (Phase B)
generate :: H.CadenceState       -- ^ Starting state (root + quality)
         -> Int                  -- ^ Number of chords
         -> Text                 -- ^ Composer blend string
         -> Double               -- ^ Entropy (gamma shape)
         -> HarmonicContext      -- ^ R constraints
         -> IO Prog.Progression
generate :: CadenceState
-> Int -> Text -> Double -> HarmonicContext -> IO Progression
generate CadenceState
start Int
nBars Text
composerStr Double
ent HarmonicContext
context =
  CadenceState
-> Int -> Text -> Double -> HarmonicContext -> IO Progression
generateWith CadenceState
start Int
nBars Text
composerStr Double
ent HarmonicContext
context

-------------------------------------------------------------------------------
-- String-Friendly Generation (TidalCycles Interface)
-------------------------------------------------------------------------------

-- |Positional generate with header + grid output (internal).
genPrint :: H.CadenceState -> Int -> String -> Double -> HarmonicContext -> IO Prog.Progression
genPrint :: CadenceState
-> Int -> [Char] -> Double -> HarmonicContext -> IO Progression
genPrint CadenceState
start Int
nBars [Char]
composerStr Double
ent HarmonicContext
ctx = do
  (prog, _diag) <- CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
generate' CadenceState
start Int
nBars [Char]
composerStr Double
ent HarmonicContext
ctx
  putStrLn ""
  printHeader (T.pack composerStr) ent ctx
  print prog
  putStrLn ""
  pure prog

-- |Generate with custom configuration
--
-- Simplified algorithm:
--   1. Start with user-provided CadenceState
--   2. For each step: build candidate pool, gamma-select next cadence
--   3. Candidate pool = graph transitions (filtered) + consonanceFallback
--      (unlimited — the pool is never truncated)
generateWith :: H.CadenceState
             -> Int
             -> Text
             -> Double
             -> HarmonicContext
             -> IO Prog.Progression
generateWith :: CadenceState
-> Int -> Text -> Double -> HarmonicContext -> IO Progression
generateWith CadenceState
start Int
nBars Text
composerStr Double
ent HarmonicContext
context = do
  let pctx :: ParsedContext
pctx = HarmonicContext -> ParsedContext
parseContextOnce HarmonicContext
context
  rng <- IO (Gen RealWorld)
IO GenIO
createSystemRandom
  source <- sourceFor composerStr
  (chain, _) <- buildChainWith source rng Nothing ent context (const pctx) start (nBars - 1)
  pure $ chainToProgression chain

-------------------------------------------------------------------------------
-- Generation with Diagnostics (Verbosity 1)
-------------------------------------------------------------------------------

-- |Generate a progression returning both result and diagnostics (internal).
--
-- This is the core internal function that generates progressions and collects
-- standard-level diagnostics (per-step candidate pools, selections, rendered chords).
--
-- For most users, use the unified interface instead:
--   * 'genSilent' - for silent generation
--   * 'genStandard' - for standard diagnostics
--   * 'genVerbose' - for verbose diagnostics
generate' :: H.CadenceState -> Int -> String -> Double -> HarmonicContext
          -> IO (Prog.Progression, GenerationDiagnostics)
generate' :: CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
generate' CadenceState
start Int
nBars [Char]
composerStr Double
ent HarmonicContext
ctx =
  Maybe Int
-> CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
genWithV (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1) CadenceState
start Int
nBars [Char]
composerStr Double
ent HarmonicContext
ctx

-- |Positional generate with compact musical summary (internal).
genPrint' :: H.CadenceState -> Int -> String -> Double -> HarmonicContext
          -> IO Prog.Progression
genPrint' :: CadenceState
-> Int -> [Char] -> Double -> HarmonicContext -> IO Progression
genPrint' CadenceState
start Int
nBars [Char]
composerStr Double
ent HarmonicContext
ctx = do
  (prog, diag) <- CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
generate' CadenceState
start Int
nBars [Char]
composerStr Double
ent HarmonicContext
ctx
  renderStandardSteps show composerStr ctx diag
  putStrLn ""
  printHeader (T.pack composerStr) ent ctx
  print prog
  putStrLn ""
  pure prog

-- |Per-step Standard renderer extracted from 'genPrint''. Emits the
-- compact summary + per-step lines, terminated by the trailing ━ rule.
-- Does NOT print the final header + grid; callers do that.
-- The first argument maps a trace position (1 = the starting\/seed row,
-- 2.. = walked bars) to its displayed bar number — identity ('show') for
-- fresh generation; regen paths map positions onto SOURCE bar numbers so
-- the trace rows line up with the printed full grid.
renderStandardSteps :: (Int -> String) -> String -> HarmonicContext -> GenerationDiagnostics -> IO ()
renderStandardSteps :: (Int -> [Char])
-> [Char] -> HarmonicContext -> GenerationDiagnostics -> IO ()
renderStandardSteps Int -> [Char]
barLabel [Char]
composerStr HarmonicContext
ctx GenerationDiagnostics
diag = do
  let tuningNames :: [([Char], Int)]
tuningNames = Text -> [([Char], Int)]
parseTuningNamed (HarmonicContext -> Text
_hcOvertones HarmonicContext
ctx)
      hasAnnotation :: Bool
hasAnnotation = Bool -> Bool
not ([([Char], Int)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([Char], Int)]
tuningNames)
      allStates :: [CadenceState]
allStates = Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Prog.unProgression (GenerationDiagnostics -> Progression
gdProgression GenerationDiagnostics
diag))
      annotateState :: CadenceState -> [Char]
annotateState CadenceState
cs =
        let rootPC :: Int
rootPC = PitchClass -> Int
P.unPitchClass (NoteName -> PitchClass
P.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
cs))
            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
cs))
            absPitches :: [Int]
absPitches = (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
rootPC) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) [Int]
intervals
            spelling :: EnharmonicSpelling
spelling = CadenceState -> EnharmonicSpelling
H.stateSpelling CadenceState
cs
            pcName :: Int -> [Char]
pcName Int
pc = NoteName -> [Char]
forall a. Show a => a -> [Char]
show (EnharmonicSpelling -> PitchClass -> NoteName
H.enharmonicFunc EnharmonicSpelling
spelling (Int -> PitchClass
P.mkPitchClass Int
pc))
        in [([Char], Int)] -> [Int] -> (Int -> [Char]) -> [Char]
formatOvertoneAnnotationPipe [([Char], Int)]
tuningNames [Int]
absPitches Int -> [Char]
pcName

  [Char] -> IO ()
putStrLn [Char]
""
  [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Generation: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ GenerationDiagnostics -> [Char]
gdStartRoot GenerationDiagnostics
diag [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ GenerationDiagnostics -> [Char]
gdStartCadence GenerationDiagnostics
diag
             [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" → " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (GenerationDiagnostics -> Int
gdActualLen GenerationDiagnostics
diag) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" chords (ent " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show (GenerationDiagnostics -> Double
gdEntropy GenerationDiagnostics
diag) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
  [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
composerModeStr [Char]
composerStr
  [Char] -> IO ()
putStrLn [Char]
"━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━"

  let bar1Suffix :: [Char]
bar1Suffix = case [CadenceState]
allStates of
        (CadenceState
a0 : [CadenceState]
_) | Bool
hasAnnotation ->
          let ann :: [Char]
ann = CadenceState -> [Char]
annotateState CadenceState
a0
          in if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
ann then [Char]
"" else [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ann
        [CadenceState]
_ -> [Char]
""
  [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
barLabel Int
1 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ GenerationDiagnostics -> [Char]
gdStartRoot GenerationDiagnostics
diag [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ GenerationDiagnostics -> [Char]
gdStartCadence GenerationDiagnostics
diag
             [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" [starting state]" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
bar1Suffix
  [Char] -> IO ()
putStrLn [Char]
""

  [StepDiagnostic] -> (StepDiagnostic -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (GenerationDiagnostics -> [StepDiagnostic]
gdSteps GenerationDiagnostics
diag) ((StepDiagnostic -> IO ()) -> IO ())
-> (StepDiagnostic -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \StepDiagnostic
step -> do
    let barNum :: Int
barNum = StepDiagnostic -> Int
sdStepNumber StepDiagnostic
step Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        stateInfo :: [Char]
stateInfo = StepDiagnostic -> [Char]
sdPriorRoot StepDiagnostic
step [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" → " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StepDiagnostic -> [Char]
sdPosteriorRoot StepDiagnostic
step
        poolInfo :: [Char]
poolInfo = [Char]
"[" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (StepDiagnostic -> Int
sdGraphCount StepDiagnostic
step) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"G/"
                   [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (StepDiagnostic -> Int
sdFallbackCount StepDiagnostic
step) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"F]"
        mvmt :: [Char]
mvmt = StepDiagnostic -> [Char]
sdSelectedDbMovement StepDiagnostic
step
        chord :: [Char]
chord = case StepDiagnostic -> Maybe [Char]
sdRenderedChord StepDiagnostic
step of
                  Just [Char]
c -> [Char]
c
                  Maybe [Char]
Nothing -> StepDiagnostic -> [Char]
sdPosteriorRoot StepDiagnostic
step
        src :: [Char]
src = [Char]
"[" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StepDiagnostic -> [Char]
sdSelectedFrom StepDiagnostic
step [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"]"
        selIdx :: [Char]
selIdx = [Char]
"γ=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (StepDiagnostic -> Int
sdGammaIndex StepDiagnostic
step)

    let overtoneSuffix :: [Char]
overtoneSuffix =
          if Bool
hasAnnotation
          then let stateIdx :: Int
stateIdx = Int
barNum Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
               in if Int
stateIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
stateIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [CadenceState] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CadenceState]
allStates
                  then let ann :: [Char]
ann = CadenceState -> [Char]
annotateState ([CadenceState]
allStates [CadenceState] -> Int -> CadenceState
forall a. HasCallStack => [a] -> Int -> a
!! Int
stateIdx)
                       in if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
ann then [Char]
"" else [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ann
                  else [Char]
""
          else [Char]
""

    [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
barLabel Int
barNum [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
stateInfo [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
poolInfo
               [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
mvmt [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" → " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
chord [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
src [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
selIdx
               [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
overtoneSuffix

    let posteriorRootPC :: Int
posteriorRootPC = StepDiagnostic -> Int
sdPosteriorRootPC StepDiagnostic
step
        renderCandidateName :: [Char] -> [Char]
renderCandidateName [Char]
name =
          case [Char] -> Int -> Maybe [Char]
parseCadenceFromString [Char]
name Int
posteriorRootPC of
            Just [Char]
renderedName -> [Char]
renderedName
            Maybe [Char]
Nothing -> [Char]
name

    let topCands :: [([Char], Double)]
topCands = if StepDiagnostic -> [Char]
sdSelectedFrom StepDiagnostic
step [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"graph"
                   then Int -> [([Char], Double)] -> [([Char], Double)]
forall a. Int -> [a] -> [a]
take Int
6 (StepDiagnostic -> [([Char], Double)]
sdGraphTop6 StepDiagnostic
step)
                   else Int -> [([Char], Double)] -> [([Char], Double)]
forall a. Int -> [a] -> [a]
take Int
6 [([Char]
n, Double
s) | ([Char]
n, Double
s, Double
_, Double
_, Double
_) <- StepDiagnostic -> [([Char], Double, Double, Double, Double)]
sdFallbackTop6 StepDiagnostic
step]

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([([Char], Double)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([Char], Double)]
topCands)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      let candNames :: [[Char]]
candNames = [[Char] -> [Char]
renderCandidateName [Char]
name | ([Char]
name, Double
_) <- [([Char], Double)]
topCands]
          candStr :: [Char]
candStr = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
" | " [[Char]]
candNames
      [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"     Candidates: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
candStr


    [Char] -> IO ()
putStrLn [Char]
""

  [Char] -> IO ()
putStrLn [Char]
"━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━"

-- |Shared body of the diagnostic-collecting generators, with the level as
-- an argument: @Nothing@ collects no per-step diagnostics at all (the
-- Silent path — skips the per-step trace construction entirely),
-- @Just 1@ Standard, @Just 2@ Verbose (full transform\/advance traces).
genWithV :: Maybe Int -> H.CadenceState -> Int -> String -> Double -> HarmonicContext
         -> IO (Prog.Progression, GenerationDiagnostics)
genWithV :: Maybe Int
-> CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
genWithV Maybe Int
mLevel CadenceState
start Int
nBars [Char]
composerStr Double
ent HarmonicContext
context = do
  let pctx :: ParsedContext
pctx = HarmonicContext -> ParsedContext
parseContextOnce HarmonicContext
context
  rng <- IO (Gen RealWorld)
IO GenIO
createSystemRandom
  source <- sourceFor (T.pack composerStr)
  (chain, stepDiags) <- buildChainWith source rng mLevel ent context (const pctx) start (nBars - 1)
  let prog = [CadenceState] -> Progression
chainToProgression [CadenceState]
chain
      diag = GenerationDiagnostics
        { gdStartCadence :: [Char]
gdStartCadence = Cadence -> [Char]
forall a. Show a => a -> [Char]
show (CadenceState -> Cadence
extractCadence CadenceState
start)
        , gdStartRoot :: [Char]
gdStartRoot = NoteName -> [Char]
forall a. Show a => a -> [Char]
show (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
start)
        , gdRequestedLen :: Int
gdRequestedLen = Int
nBars
        , gdActualLen :: Int
gdActualLen = Progression -> Int
Prog.progLength Progression
prog
        , gdEntropy :: Double
gdEntropy = Double
ent
        , gdSteps :: [StepDiagnostic]
gdSteps = [StepDiagnostic]
stepDiags
        , gdProgression :: Progression
gdProgression = Progression
prog
        , gdJazzTrace :: [[Char]]
gdJazzTrace = []
        }
  pure (prog, diag)

-------------------------------------------------------------------------------
-- Generation with Maximum Diagnostics (Verbosity 2)
-------------------------------------------------------------------------------

-- |Generate a progression with maximum diagnostic traces (internal).
--
-- Like 'generate\'' but populates full transform and advance traces for debugging.
-- This function collects:
--   * All standard diagnostics (per-step candidate pools, selections)
--   * Full transform traces (DB intervals, transposition, normalization, zero-form)
--   * Full advance traces (root motion PC arithmetic, enharmonic spelling)
--
-- This is SLOWER than 'generate\'' due to extra tracing computation.
-- Use only for debugging chord name discrepancies or voice leading issues.
generate'' :: H.CadenceState -> Int -> String -> Double -> HarmonicContext
           -> IO (Prog.Progression, GenerationDiagnostics)
generate'' :: CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
generate'' CadenceState
start Int
nBars [Char]
composerStr Double
ent HarmonicContext
ctx =
  Maybe Int
-> CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
genWithV (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2) CadenceState
start Int
nBars [Char]
composerStr Double
ent HarmonicContext
ctx

-- |Positional generate with verbose traces (internal).
genPrint'' :: H.CadenceState -> Int -> String -> Double -> HarmonicContext
           -> IO Prog.Progression
genPrint'' :: CadenceState
-> Int -> [Char] -> Double -> HarmonicContext -> IO Progression
genPrint'' CadenceState
start Int
nBars [Char]
composerStr Double
ent HarmonicContext
ctx = do
  (prog, diag) <- CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
generate'' CadenceState
start Int
nBars [Char]
composerStr Double
ent HarmonicContext
ctx
  renderVerboseSteps show composerStr diag
  putStrLn ""
  printHeader (T.pack composerStr) ent ctx
  print prog
  putStrLn ""
  pure prog

-- |Per-step Verbose renderer extracted from @genPrint'''@. Emits the
-- verbose summary + per-step trace, terminated by the trailing ━ rule.
-- Does NOT print the final header + grid; callers do that.
-- First argument as in 'renderStandardSteps': trace position → displayed
-- bar number.
renderVerboseSteps :: (Int -> String) -> String -> GenerationDiagnostics -> IO ()
renderVerboseSteps :: (Int -> [Char]) -> [Char] -> GenerationDiagnostics -> IO ()
renderVerboseSteps Int -> [Char]
barLabel [Char]
composerStr GenerationDiagnostics
diag = do
  [Char] -> IO ()
putStrLn [Char]
""
  [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Verbose Generation: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ GenerationDiagnostics -> [Char]
gdStartRoot GenerationDiagnostics
diag [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ GenerationDiagnostics -> [Char]
gdStartCadence GenerationDiagnostics
diag
             [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" → " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (GenerationDiagnostics -> Int
gdActualLen GenerationDiagnostics
diag) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" chords (ent " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show (GenerationDiagnostics -> Double
gdEntropy GenerationDiagnostics
diag) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
  [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
composerModeStr [Char]
composerStr
  [Char] -> IO ()
putStrLn [Char]
"━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━"

  [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"STEP " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
barLabel Int
1 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ GenerationDiagnostics -> [Char]
gdStartRoot GenerationDiagnostics
diag [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ GenerationDiagnostics -> [Char]
gdStartCadence GenerationDiagnostics
diag [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" [starting state]"
  [Char] -> IO ()
putStrLn [Char]
""

  [StepDiagnostic] -> (StepDiagnostic -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (GenerationDiagnostics -> [StepDiagnostic]
gdSteps GenerationDiagnostics
diag) ((StepDiagnostic -> IO ()) -> IO ())
-> (StepDiagnostic -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \StepDiagnostic
step -> do
    let barNum :: Int
barNum = StepDiagnostic -> Int
sdStepNumber StepDiagnostic
step Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        mvmt :: [Char]
mvmt = StepDiagnostic -> [Char]
sdSelectedDbMovement StepDiagnostic
step
        chord :: [Char]
chord = case StepDiagnostic -> Maybe [Char]
sdRenderedChord StepDiagnostic
step of
                  Just [Char]
c -> [Char]
c
                  Maybe [Char]
Nothing -> StepDiagnostic -> [Char]
sdPosteriorRoot StepDiagnostic
step
        src :: [Char]
src = [Char]
"[" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StepDiagnostic -> [Char]
sdSelectedFrom StepDiagnostic
step [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"]"
        selIdx :: [Char]
selIdx = [Char]
"(γ=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (StepDiagnostic -> Int
sdGammaIndex StepDiagnostic
step) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (StepDiagnostic -> Int
sdPoolSize StepDiagnostic
step) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"

    [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"STEP " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
barLabel Int
barNum [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StepDiagnostic -> [Char]
sdPriorRoot StepDiagnostic
step [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" → "
               [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StepDiagnostic -> [Char]
sdPosteriorRoot StepDiagnostic
step [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
mvmt [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" → " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
chord [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
src [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
selIdx

    [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"  Pool: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (StepDiagnostic -> Int
sdGraphCount StepDiagnostic
step) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" graph, "
               [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (StepDiagnostic -> Int
sdFallbackCount StepDiagnostic
step) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" fallback"

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StepDiagnostic -> [Char]
sdSelectedFrom StepDiagnostic
step [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"graph" Bool -> Bool -> Bool
&& Bool -> Bool
not ([([Char], Double)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (StepDiagnostic -> [([Char], Double)]
sdGraphTop6 StepDiagnostic
step))) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      [Char] -> IO ()
putStrLn [Char]
"  Top graph:"
      [([Char], Double)] -> (([Char], Double) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Int -> [([Char], Double)] -> [([Char], Double)]
forall a. Int -> [a] -> [a]
take Int
6 (StepDiagnostic -> [([Char], Double)]
sdGraphTop6 StepDiagnostic
step)) ((([Char], Double) -> IO ()) -> IO ())
-> (([Char], Double) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \([Char]
name, Double
conf) -> do
        [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"    " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show Double
conf [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StepDiagnostic -> [Char]
sdSelectedFrom StepDiagnostic
step [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"fallback" Bool -> Bool -> Bool
&& Bool -> Bool
not ([([Char], Double, Double, Double, Double)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (StepDiagnostic -> [([Char], Double, Double, Double, Double)]
sdFallbackTop6 StepDiagnostic
step))) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      [Char] -> IO ()
putStrLn [Char]
"  Top fallback:"
      [([Char], Double, Double, Double, Double)]
-> (([Char], Double, Double, Double, Double) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Int
-> [([Char], Double, Double, Double, Double)]
-> [([Char], Double, Double, Double, Double)]
forall a. Int -> [a] -> [a]
take Int
6 (StepDiagnostic -> [([Char], Double, Double, Double, Double)]
sdFallbackTop6 StepDiagnostic
step)) ((([Char], Double, Double, Double, Double) -> IO ()) -> IO ())
-> (([Char], Double, Double, Double, Double) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \([Char]
name, Double
score, Double
chordD, Double
motionD, Double
gammaD) -> do
        [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"    " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show Double
score
                   [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", c=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show Double
chordD
                   [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", m=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show Double
motionD
                   [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", γ=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show Double
gammaD [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
    case StepDiagnostic -> Maybe AdvanceTrace
sdAdvanceTrace StepDiagnostic
step of
      Just AdvanceTrace
at -> do
        [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"  Advance: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AdvanceTrace -> [Char]
atCurrentRoot AdvanceTrace
at [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (AdvanceTrace -> Int
atCurrentRootPC AdvanceTrace
at) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
                   [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" + " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (AdvanceTrace -> Int
atMovementInterval AdvanceTrace
at) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" → "
                   [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AdvanceTrace -> [Char]
atNewRoot AdvanceTrace
at [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (AdvanceTrace -> Int
atNewRootPC AdvanceTrace
at) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
      Maybe AdvanceTrace
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    [Char] -> IO ()
putStrLn [Char]
""

  [Char] -> IO ()
putStrLn [Char]
"━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━"

-- |Generate with custom configuration and maximum diagnostics (internal).
-------------------------------------------------------------------------------
-- Unified Interface
-------------------------------------------------------------------------------

-- |Generate a progression with NO diagnostic output (verbosity 0 - silent mode).
genSilent :: H.CadenceState -> Int -> String -> Double -> HarmonicContext -> IO Prog.Progression
genSilent :: CadenceState
-> Int -> [Char] -> Double -> HarmonicContext -> IO Progression
genSilent CadenceState
start Int
nBars [Char]
composerStr Double
ent HarmonicContext
ctx = do
  (prog, _diag) <- CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
generate' CadenceState
start Int
nBars [Char]
composerStr Double
ent HarmonicContext
ctx
  pure prog

-- |Generate a progression with STANDARD diagnostic output (verbosity 1).
genStandard :: H.CadenceState -> Int -> String -> Double -> HarmonicContext -> IO Prog.Progression
genStandard :: CadenceState
-> Int -> [Char] -> Double -> HarmonicContext -> IO Progression
genStandard CadenceState
start Int
nBars [Char]
composerStr Double
ent HarmonicContext
ctx = do
  (prog, diag) <- CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
generate' CadenceState
start Int
nBars [Char]
composerStr Double
ent HarmonicContext
ctx
  printDiagnostics 1 diag
  pure prog

-- |Generate a progression with VERBOSE diagnostic output (verbosity 2).
genVerbose :: H.CadenceState -> Int -> String -> Double -> HarmonicContext -> IO Prog.Progression
genVerbose :: CadenceState
-> Int -> [Char] -> Double -> HarmonicContext -> IO Progression
genVerbose CadenceState
start Int
nBars [Char]
composerStr Double
ent HarmonicContext
ctx = do
  (prog, diag) <- CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
generate'' CadenceState
start Int
nBars [Char]
composerStr Double
ent HarmonicContext
ctx
  printDiagnostics 2 diag
  pure prog

-------------------------------------------------------------------------------
-- Modifier-Based Generation API
-------------------------------------------------------------------------------

-- |Per-step diagnostic collection level for a 'Verbosity': Silent
-- collects nothing (nothing would render it), Standard the step trace,
-- Verbose the full transform\/advance traces.
diagLevelOf :: Verbosity -> Maybe Int
diagLevelOf :: Verbosity -> Maybe Int
diagLevelOf Verbosity
Silent   = Maybe Int
forall a. Maybe a
Nothing
diagLevelOf Verbosity
Standard = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
diagLevelOf Verbosity
Verbose  = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2

-- |Execute a 'GenConfig', producing a progression.
--
-- Progression-typed view of 'execGenConfigPC': one dispatcher and one
-- emission path for every family, and the attempt loop ('_gcMaxAttempts')
-- is honoured rather than silently ignored.
execGenConfig :: GenConfig -> IO Prog.Progression
execGenConfig :: GenConfig -> IO Progression
execGenConfig GenConfig
gc = ProgressionContext -> Progression
PC.triadLayer (ProgressionContext -> Progression)
-> IO ProgressionContext -> IO Progression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenConfig -> IO ProgressionContext
execGenConfigPC GenConfig
gc

-- |Compute-only variant of 'execGenConfig'. Returns the progression and
-- its diagnostics without printing anything. Used by 'singlePassExecPCWithDiag'
-- and by @generateBest@ inside the K-attempt loop so per-attempt output
-- can be suppressed and only the winner's emitted.
execGenConfigWithDiag :: GenConfig -> IO (Prog.Progression, GenerationDiagnostics)
execGenConfigWithDiag :: GenConfig -> IO (Progression, GenerationDiagnostics)
execGenConfigWithDiag GenConfig
gc = do
  start <- case GenConfig -> GenMode
_gcMode GenConfig
gc of
    GenMode
Fresh    | Bool -> Bool
not (GenConfig -> Bool
_gcCueExplicit GenConfig
gc) -> GenConfig -> IO CadenceState
tonalStartCue GenConfig
gc
    GenMode
GridMode | Bool -> Bool
not (GenConfig -> Bool
_gcCueExplicit GenConfig
gc) -> GenConfig -> IO CadenceState
tonalStartCue GenConfig
gc
    GenMode
_                                  -> GenConfig -> IO CadenceState
_gcCue GenConfig
gc
  case _gcMode gc of
    GenMode
JazzMode -> [Char] -> IO (Progression, GenerationDiagnostics)
forall a. HasCallStack => [Char] -> a
error [Char]
"unreachable: JazzMode dispatches to runJazzGen before this case"
    FromProgJ {} -> [Char] -> IO (Progression, GenerationDiagnostics)
forall a. HasCallStack => [Char] -> a
error [Char]
"unreachable: FromProgJ dispatches to runJazzGenFrom before this case"
    GenMode
PolyMode -> [Char] -> IO (Progression, GenerationDiagnostics)
forall a. HasCallStack => [Char] -> a
error [Char]
"unreachable: PolyMode dispatches to runPolyGen before this case"
    FromProgPoly {} -> [Char] -> IO (Progression, GenerationDiagnostics)
forall a. HasCallStack => [Char] -> a
error [Char]
"unreachable: FromProgPoly dispatches to runPolyGenFrom before this case"

    GenMode
Fresh ->
      Maybe Int
-> CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
genWithV (Verbosity -> Maybe Int
diagLevelOf (GenConfig -> Verbosity
_gcVerbosity GenConfig
gc)) CadenceState
start (GenConfig -> Int
_gcLen GenConfig
gc)
               (GenConfig -> [Char]
_gcSeek GenConfig
gc) (GenConfig -> Double
_gcEntropy GenConfig
gc) (GenConfig -> HarmonicContext
_gcTonal GenConfig
gc)

    GenMode
GridMode -> do
      let grid :: Progression
grid = [CadenceState] -> Progression
Prog.fromCadenceStates (Int -> CadenceState -> [CadenceState]
forall a. Int -> a -> [a]
replicate (GenConfig -> Int
_gcLen GenConfig
gc) CadenceState
start)
          diag :: GenerationDiagnostics
diag = 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 = GenConfig -> Int
_gcLen GenConfig
gc
            , gdActualLen :: Int
gdActualLen    = Progression -> Int
Prog.progLength Progression
grid
            , gdEntropy :: Double
gdEntropy      = GenConfig -> Double
_gcEntropy GenConfig
gc
            , gdSteps :: [StepDiagnostic]
gdSteps        = []
            , gdProgression :: Progression
gdProgression  = Progression
grid
            , gdJazzTrace :: [[Char]]
gdJazzTrace    = []
            }
      (Progression, GenerationDiagnostics)
-> IO (Progression, GenerationDiagnostics)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Progression
grid, GenerationDiagnostics
diag)

    FromProg Progression
srcProg Int
s Int
e -> do
      -- Regeneration walks triads. A uniform 4-note source (hand-built
      -- lead' material) keeps its untouched bars; the regenerated range
      -- comes back triadic — the walk seeds from the bar's most-consonant
      -- embedded triad — announced so the downgrade is never silent.
      let srcSizes :: [Int]
srcSizes = [ [PitchClass] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Cadence -> [PitchClass]
H.cadenceIntervals (CadenceState -> Cadence
H.stateCadence CadenceState
cs))
                     | CadenceState
cs <- Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Prog.unProgression Progression
srcProg) ]
          srcExtended :: Bool
srcExtended = Bool -> Bool
not ([Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
srcSizes) Bool -> Bool -> Bool
&& (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
4) [Int]
srcSizes
          srcMixed :: Bool
srcMixed = [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub [Int]
srcSizes) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
srcExtended Bool -> Bool -> Bool
&& GenConfig -> Int
_gcMaxAttempts GenConfig
gc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        [Char] -> IO ()
putStrLn [Char]
"genFrom: extended source — regenerated bars come back as plain triads (the walk seeds from each bar's most-consonant embedded triad)"
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
srcMixed Bool -> Bool -> Bool
&& GenConfig -> Int
_gcMaxAttempts GenConfig
gc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        [Char] -> IO ()
putStrLn [Char]
"genFrom: hand-mixed source cardinalities — regenerating as plain triads (regen never amplifies mixing)"
      -- Generate _gcLen+1 chords (cue + new), then drop cue, splice into source.
      (fullProg, regenDiag) <- Maybe Int
-> CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
genWithV (Verbosity -> Maybe Int
diagLevelOf (GenConfig -> Verbosity
_gcVerbosity GenConfig
gc)) CadenceState
start (GenConfig -> Int
_gcLen GenConfig
gc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                                 (GenConfig -> [Char]
_gcSeek GenConfig
gc) (GenConfig -> Double
_gcEntropy GenConfig
gc) (GenConfig -> HarmonicContext
_gcTonal GenConfig
gc)
      let newChords = Int -> [CadenceState] -> [CadenceState]
forall a. Int -> [a] -> [a]
drop Int
1 ([CadenceState] -> [CadenceState])
-> [CadenceState] -> [CadenceState]
forall a b. (a -> b) -> a -> b
$ Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq CadenceState -> [CadenceState])
-> Seq CadenceState -> [CadenceState]
forall a b. (a -> b) -> a -> b
$ Progression -> Seq CadenceState
Prog.unProgression Progression
fullProg
          result    = Progression -> Int -> Int -> [CadenceState] -> Progression
Prog.spliceProgression Progression
srcProg Int
s Int
e [CadenceState]
newChords
      pure (result, regenDiag)

    StrataMode StrataLabel
_  -> [Char] -> IO (Progression, GenerationDiagnostics)
forall a. HasCallStack => [Char] -> a
error [Char]
"unreachable: StrataMode dispatches to runStrataGen before this case"
    FromProgPC {} -> [Char] -> IO (Progression, GenerationDiagnostics)
forall a. HasCallStack => [Char] -> a
error [Char]
"unreachable: FromProgPC dispatches to runStrataGenFrom before this case"

-- |Set composer blend and execute. Terminal modifier — produces 'IO'
-- 'PC.ProgressionContext'. Every family returns distinct layers: 'genP'
-- carries curated strata\/mode chroma with 'Just' provenance, 'genE'
-- partner triads, and 'gen'\/'genJ' chordscale-derived pentatonic\/mode
-- layers ('Harmonic.Evaluation.Analysis.KeyArea.chordscale' is applied in
-- the dispatch fallthrough) with @pcProvenance@ 'Nothing'.
--
-- @s <- seek "*" $ gen@
-- @s <- seek "bach:70 debussy:30" $ cue start $ len 4 $ gen@
-- @s <- seek "none" $ cue start $ len 6 $ genVI@
seek :: String -> GenConfig -> IO PC.ProgressionContext
seek :: [Char] -> GenConfig -> IO ProgressionContext
seek [Char]
s GenConfig
gc = GenConfig -> IO ProgressionContext
execGenConfigPC GenConfig
gc { _gcSeek = s }

-- |Terminal executor producing a 'PC.ProgressionContext'.
--
-- When @_gcMaxAttempts > 1@, dispatches through @generateBest@ for
-- rank-and-select multi-attempt generation; otherwise runs a single pass.
--
-- The single-pass dispatch reads '_gcMode': 'StrataMode' runs the strata-
-- first traversal producing distinct layers; all other modes fall through
-- to 'execGenConfig' and wrap the resulting triad 'Prog.Progression' via
-- 'PC.fromProgression'.
execGenConfigPC :: GenConfig -> IO PC.ProgressionContext
execGenConfigPC :: GenConfig -> IO ProgressionContext
execGenConfigPC GenConfig
gc
  | GenConfig -> Int
_gcMaxAttempts GenConfig
gc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 = GenConfig -> IO ProgressionContext
generateBest GenConfig
gc
  | Bool
otherwise             = GenConfig -> IO ProgressionContext
singlePassExecPC GenConfig
gc

-- |Emit the final progression block — per-step diagnostics (if any) +
-- header + chord grid — under the caller's 'Verbosity' and 'GenMode'.
-- This is the single source of user-visible output for both the single-
-- pass path and the multi-attempt winner.
--
-- For strata modes ('StrataMode', 'FromProgPC') Standard\/Verbose use the
-- 'printStrataDiagnostics' renderer (legacy 'printDiagnostics' would mis-
-- render the strata trace). For legacy modes ('Fresh', 'GridMode',
-- 'FromProg') Standard uses 'renderStandardSteps' and Verbose uses
-- 'renderVerboseSteps' — matching the byte-for-byte output of the old
-- 'genPrint''/@genPrint''''@ wrappers.
--
-- The header + grid always reflect the full 'PC.triadLayer pc'. For
-- 'FromProgPC' \/ 'FromProg' that's the spliced result (full source
-- progression with regen bars inserted), not the regen segment alone.
emitFinalised :: GenConfig -> (PC.ProgressionContext, GenerationDiagnostics) -> IO ()
emitFinalised :: GenConfig -> (ProgressionContext, GenerationDiagnostics) -> IO ()
emitFinalised GenConfig
gc (ProgressionContext
pc, GenerationDiagnostics
diag) = do
  -- Cue-escapes-R notice (non-fatal). The cue is the human aberration
  -- channel by design and is always honoured; this makes an escape visible
  -- at the moment it happens. Emitted here because emitFinalised runs
  -- exactly once per user invocation (single-pass, or the attempt winner),
  -- and the emitted progression's first state IS the cue actually used —
  -- resolving _gcCue again would re-draw the random default cue. Scope:
  -- Fresh\/GridMode only; the regen modes infer their cue from existing
  -- material, and the strata path has its own containment check.
  -- Every FRESH mode gets the notice: strata's own containment check
  -- covers chroma only (not key/roots), and jazz has no other R report.
  case GenConfig -> GenMode
_gcMode GenConfig
gc of
    GenMode
Fresh        -> IO ()
emitCueNotice
    GenMode
GridMode     -> IO ()
emitCueNotice
    GenMode
PolyMode     -> IO ()
emitCueNotice
    GenMode
JazzMode     -> IO ()
emitCueNotice
    StrataMode StrataLabel
_ -> IO ()
emitCueNotice
    GenMode
_            -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  -- Typo'd filter tokens are named once per invocation — the parsers'
  -- silent-[] convention otherwise turns "hcRoots \"* -Bb'\"" with a bad
  -- token into an unconstrained walk with no signal. Printed at every
  -- verbosity: a wrong constraint is wrong even under Silent.
  ([Char] -> IO ()) -> [[Char]] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Char] -> IO ()
putStrLn (ParsedContext -> [[Char]]
pcWarnings (HarmonicContext -> ParsedContext
parseContextOnce (GenConfig -> HarmonicContext
_gcTonal GenConfig
gc)))
  let isStrata :: Bool
isStrata = case GenConfig -> GenMode
_gcMode GenConfig
gc of
        StrataMode StrataLabel
_    -> Bool
True
        FromProgPC {}   -> Bool
True
        GenMode
_               -> Bool
False
      isJazz :: Bool
isJazz = case GenConfig -> GenMode
_gcMode GenConfig
gc of
        GenMode
JazzMode     -> Bool
True
        FromProgJ {} -> Bool
True
        GenMode
_            -> Bool
False
      isPoly :: Bool
isPoly = case GenConfig -> GenMode
_gcMode GenConfig
gc of
        GenMode
PolyMode        -> Bool
True
        FromProgPoly {} -> Bool
True
        GenMode
_               -> Bool
False
  -- Regen traces describe only the regenerated segment (seed + new bars)
  -- while the grid below shows the FULL spliced progression. Mapping
  -- trace positions onto source bar numbers (wrap-aware) lets the reader
  -- line trace rows up with grid bars; position 1 is the seed bar.
  let nBars :: Int
nBars = Progression -> Int
Prog.progLength (ProgressionContext -> Progression
PC.triadLayer ProgressionContext
pc)
      regenLabel :: Int -> Int -> [Char]
regenLabel Int
s Int
k = Int -> [Char]
forall a. Show a => a -> [Char]
show (((Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k 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 -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
nBars) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      barLabel :: Int -> [Char]
barLabel = case GenConfig -> GenMode
_gcMode GenConfig
gc of
        FromProg Progression
_ Int
s Int
_     -> Int -> Int -> [Char]
regenLabel Int
s
        FromProgPC ProgressionContext
_ Int
s Int
_   -> Int -> Int -> [Char]
regenLabel Int
s
        FromProgJ ProgressionContext
_ Int
s Int
_    -> Int -> Int -> [Char]
regenLabel Int
s
        FromProgPoly ProgressionContext
_ Int
s Int
_ -> Int -> Int -> [Char]
regenLabel Int
s
        GenMode
_                  -> Int -> [Char]
forall a. Show a => a -> [Char]
show
      regenNote :: IO ()
regenNote = case GenConfig -> GenMode
_gcMode GenConfig
gc of
        FromProg Progression
_ Int
s Int
_ | GenConfig -> Verbosity
_gcVerbosity GenConfig
gc Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
/= Verbosity
Silent ->
          [Char] -> IO ()
putStrLn (Int -> [Char]
regenNoteStr Int
s)
        FromProgPC ProgressionContext
_ Int
s Int
_ | GenConfig -> Verbosity
_gcVerbosity GenConfig
gc Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
/= Verbosity
Silent ->
          [Char] -> IO ()
putStrLn (Int -> [Char]
regenNoteStr Int
s)
        FromProgJ ProgressionContext
_ Int
s Int
_ | GenConfig -> Verbosity
_gcVerbosity GenConfig
gc Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
/= Verbosity
Silent ->
          [Char] -> IO ()
putStrLn (Int -> [Char]
regenNoteStr Int
s)
        FromProgPoly ProgressionContext
_ Int
s Int
_ | GenConfig -> Verbosity
_gcVerbosity GenConfig
gc Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
/= Verbosity
Silent ->
          [Char] -> IO ()
putStrLn (Int -> [Char]
regenNoteStr Int
s)
        GenMode
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      regenNoteStr :: Int -> [Char]
regenNoteStr Int
s =
        let rN :: Int
rN   = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (GenerationDiagnostics -> Int
gdActualLen GenerationDiagnostics
diag Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
            eEff :: Int
eEff = ((Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rN) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
nBars) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        in [Char]
"regenerated bars " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".." [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
eEff [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" of "
           [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
nBars [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (trace numbers are source bars; first row is the seed)"
  IO ()
regenNote
  case GenConfig -> Verbosity
_gcVerbosity GenConfig
gc of
    Verbosity
Silent   -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    -- genJ renders its trace during generation; the winner's collected
    -- lines are emitted here — exactly once, attempt loop included.
    Verbosity
_ | Bool
isJazz -> ([Char] -> IO ()) -> [[Char]] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Char] -> IO ()
putStrLn (GenerationDiagnostics -> [[Char]]
gdJazzTrace GenerationDiagnostics
diag)
    Verbosity
Standard
      | Bool
isStrata  -> (Int -> [Char]) -> Int -> GenerationDiagnostics -> IO ()
printStrataDiagnostics Int -> [Char]
barLabel Int
1 GenerationDiagnostics
diag
      | Bool
isPoly    -> (Int -> [Char]) -> Int -> GenerationDiagnostics -> IO ()
printPolyDiagnostics Int -> [Char]
barLabel Int
1 GenerationDiagnostics
diag
      | Bool
otherwise -> (Int -> [Char])
-> [Char] -> HarmonicContext -> GenerationDiagnostics -> IO ()
renderStandardSteps Int -> [Char]
barLabel (GenConfig -> [Char]
_gcSeek GenConfig
gc) (GenConfig -> HarmonicContext
_gcTonal GenConfig
gc) GenerationDiagnostics
diag
    Verbosity
Verbose
      | Bool
isStrata  -> (Int -> [Char]) -> Int -> GenerationDiagnostics -> IO ()
printStrataDiagnostics Int -> [Char]
barLabel Int
2 GenerationDiagnostics
diag
      | Bool
isPoly    -> (Int -> [Char]) -> Int -> GenerationDiagnostics -> IO ()
printPolyDiagnostics Int -> [Char]
barLabel Int
2 GenerationDiagnostics
diag
      | Bool
otherwise -> (Int -> [Char]) -> [Char] -> GenerationDiagnostics -> IO ()
renderVerboseSteps Int -> [Char]
barLabel (GenConfig -> [Char]
_gcSeek GenConfig
gc) GenerationDiagnostics
diag
  [Char] -> IO ()
putStrLn [Char]
""
  Text -> Double -> HarmonicContext -> IO ()
printHeader ([Char] -> Text
T.pack (GenConfig -> [Char]
_gcSeek GenConfig
gc)) (GenConfig -> Double
_gcEntropy GenConfig
gc) (GenConfig -> HarmonicContext
_gcTonal GenConfig
gc)
  Progression -> IO ()
forall a. Show a => a -> IO ()
print (ProgressionContext -> Progression
PC.triadLayer ProgressionContext
pc)
  -- Polytonal zero-prime shows the combined harmony beside the
  -- foundation: the TSM union is what the three layers sound together.
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isPoly (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    [Char] -> IO ()
putStrLn [Char]
"   combined (TSM):"
    Progression -> IO ()
forall a. Show a => a -> IO ()
print (Layer -> ProgressionContext -> Progression
PC.layer Layer
PC.TSM ProgressionContext
pc)
  [Char] -> IO ()
putStrLn [Char]
""
  where
    emitCueNotice :: IO ()
emitCueNotice =
      case Seq CadenceState -> ViewL CadenceState
forall a. Seq a -> ViewL a
Seq.viewl (Progression -> Seq CadenceState
Prog.unProgression (ProgressionContext -> Progression
PC.triadLayer ProgressionContext
pc)) of
        CadenceState
firstState Seq.:< Seq CadenceState
_ -> HarmonicContext -> CadenceState -> IO ()
printCueEscapeNotice (GenConfig -> HarmonicContext
_gcTonal GenConfig
gc) CadenceState
firstState
        ViewL CadenceState
Seq.EmptyL          -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- |Single-pass body of 'execGenConfigPC' — used directly when no multi-
-- attempt selection is requested. Thin wrapper that performs pure
-- generation via 'singlePassExecPCWithDiag' then emits the appropriate
-- diagnostics + header + grid via @emitFinalised@.
singlePassExecPC :: GenConfig -> IO PC.ProgressionContext
singlePassExecPC :: GenConfig -> IO ProgressionContext
singlePassExecPC GenConfig
gc = do
  (pc, diag) <- GenConfig -> IO (ProgressionContext, GenerationDiagnostics)
singlePassExecPCWithDiag GenConfig
gc
  emitFinalised gc (pc, diag)
  pure pc

-- |Pure-compute variant of 'singlePassExecPC'. Returns the
-- 'Harmonic.Rules.Types.ProgressionContext.ProgressionContext' and its 'GenerationDiagnostics' without printing
-- anything. Used by the K-attempt loop inside @generateBest@ so per-
-- attempt output is suppressed and only the winner's emitted.
singlePassExecPCWithDiag :: GenConfig -> IO (PC.ProgressionContext, GenerationDiagnostics)
singlePassExecPCWithDiag :: GenConfig -> IO (ProgressionContext, GenerationDiagnostics)
singlePassExecPCWithDiag GenConfig
gc = case GenConfig -> GenMode
_gcMode GenConfig
gc of
  GenMode
JazzMode             -> GenConfig -> IO (ProgressionContext, GenerationDiagnostics)
runJazzGen GenConfig
gc
  FromProgJ ProgressionContext
srcPC Int
s Int
e  -> ProgressionContext
-> Int
-> Int
-> GenConfig
-> IO (ProgressionContext, GenerationDiagnostics)
runJazzGenFrom ProgressionContext
srcPC Int
s Int
e GenConfig
gc
  StrataMode StrataLabel
sStart    -> StrataLabel
-> GenConfig -> IO (ProgressionContext, GenerationDiagnostics)
runStrataGen StrataLabel
sStart GenConfig
gc
  FromProgPC ProgressionContext
srcPC Int
s Int
e -> ProgressionContext
-> Int
-> Int
-> GenConfig
-> IO (ProgressionContext, GenerationDiagnostics)
runStrataGenFrom ProgressionContext
srcPC Int
s Int
e GenConfig
gc
  GenMode
PolyMode             -> GenConfig -> IO (ProgressionContext, GenerationDiagnostics)
runPolyGen GenConfig
gc
  FromProgPoly ProgressionContext
srcPC Int
s Int
e -> ProgressionContext
-> Int
-> Int
-> GenConfig
-> IO (ProgressionContext, GenerationDiagnostics)
runPolyGenFrom ProgressionContext
srcPC Int
s Int
e GenConfig
gc
  GenMode
_                    -> do
    (prog, diag) <- GenConfig -> IO (Progression, GenerationDiagnostics)
execGenConfigWithDiag GenConfig
gc
    -- Chordscale annotation: derived S/M layers from the key-area analysis
    -- of the finished progression (identity on empty output).
    pure (chordscale (PC.fromProgression prog), diag)

-- |Generate up to @_gcMaxAttempts@ progressions and return the single
-- highest-scoring one. An attempt is /viable/ iff
-- @psModeValidity >= 1.0@ (structural invariant — walk-generated
-- progressions always pass) AND @totalScore >= _gcViabilityFloor@. The
-- loop stops early once @_gcViableTarget@ viable attempts have been
-- collected, then returns the highest-scoring attempt across the full
-- accumulator (so when zero clear the floor, the best non-viable is
-- still returned).
--
-- When @_gcSeek != "none"@, scoring runs against Neo4j: one shared
-- database connection is opened for the entire K-attempt loop and @psCadenceFav@
-- is populated via 'PS.scoreProgressionOnline' under the user's composer
-- blend. The online-weighted total ('PS.defaultWeights') is then used —
-- cadence-favourability is the dominant axis (0.4).
--
-- When @_gcSeek == "none"@, scoring is fully pure and uses
-- 'PS.defaultWeightsOffline' (cadence-fav weight zeroed, the other three
-- renormalised).
generateBest :: GenConfig -> IO PC.ProgressionContext
generateBest :: GenConfig -> IO ProgressionContext
generateBest GenConfig
gc0 = do
  -- Immediate user feedback before the K-attempt loop blocks. Tidal's
  -- GHCi stdout is line-buffered, so the newline flushes right away.
  [Char] -> IO ()
putStrLn [Char]
"composing .."
  -- One cue draw for the whole loop: the K attempts rank K walks from ONE
  -- starting chord. Without this, a random default cue re-draws per
  -- attempt and the scoreboard compares progressions in different keys.
  -- genE's partner chains still redraw per attempt, so the layer pass
  -- keeps its per-attempt variety.
  -- genP draws its cue from inside its stratum, so the frozen cue has to be
  -- drawn the same way or the generator would discard it and redraw per
  -- attempt — the very thing freezing prevents.
  start0 <- case GenConfig -> GenMode
_gcMode GenConfig
gc0 of
    StrataMode StrataLabel
sLbl | Bool -> Bool
not (GenConfig -> Bool
_gcCueExplicit GenConfig
gc0) -> StrataLabel -> GenConfig -> IO CadenceState
strataStartCue StrataLabel
sLbl GenConfig
gc0
    GenMode
JazzMode        | Bool -> Bool
not (GenConfig -> Bool
_gcCueExplicit GenConfig
gc0) -> GenConfig -> IO CadenceState
jazzStartCue GenConfig
gc0
    GenMode
Fresh           | Bool -> Bool
not (GenConfig -> Bool
_gcCueExplicit GenConfig
gc0) -> GenConfig -> IO CadenceState
tonalStartCue GenConfig
gc0
    GenMode
GridMode        | Bool -> Bool
not (GenConfig -> Bool
_gcCueExplicit GenConfig
gc0) -> GenConfig -> IO CadenceState
tonalStartCue GenConfig
gc0
    GenMode
PolyMode        | Bool -> Bool
not (GenConfig -> Bool
_gcCueExplicit GenConfig
gc0) -> GenConfig -> IO CadenceState
tonalStartCue GenConfig
gc0
    GenMode
_                                          -> GenConfig -> IO CadenceState
_gcCue GenConfig
gc0
  let gc = GenConfig
gc0 { _gcCue = pure start0, _gcCueExplicit = True }
      online = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (GenConfig -> [Char]
_gcSeek GenConfig
gc) [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
"none"
      isJazzGc = case GenConfig -> GenMode
_gcMode GenConfig
gc of
        GenMode
JazzMode        -> Bool
True
        FromProgJ {}    -> Bool
True
        GenMode
_               -> Bool
False
  (winnerPC, winnerDiag, diags) <-
    if isJazzGc then runJazzBest gc
      else if online then runOnline gc else runOffline gc
  -- All per-attempt printing was suppressed inside the loop (Phase 11
  -- moved every emission into @emitFinalised@). Emit the winner exactly
  -- once, at the caller's verbosity.
  -- An empty winner means every attempt failed structurally (the per-run
  -- explanation — e.g. genP's invalid-cue block — is suppressed inside
  -- the loop); say so rather than printing a bare empty grid.
  when (PC.pcLength winnerPC == 0) $
    putStrLn "⚠ attempt: every attempt produced an empty progression — run the same chain without attempt for the full diagnosis (e.g. an invalid genP cue)"
  emitFinalised gc (winnerPC, winnerDiag)
  -- Verbose + multi-attempt: surface the full scoreboard.
  when (_gcVerbosity gc == Verbose && _gcMaxAttempts gc > 1) $
    printAttemptScoreboard (_gcViabilityFloor gc) diags
  pure winnerPC

-- |Offline arm of @generateBest@. Pure scoring with
-- 'PS.defaultWeightsOffline'.
--
-- The loop receives the caller's 'GenConfig' as-is — per-attempt
-- diagnostics are collected at the caller's verbosity, which the
-- winner's @emitFinalised@ then renders. No printing happens inside the
-- loop (Phase 11 lifted every emission out of 'singlePassExecPCWithDiag').
runOffline :: GenConfig
           -> IO (PC.ProgressionContext, GenerationDiagnostics, [AttemptDiagnostic])
runOffline :: GenConfig
-> IO
     (ProgressionContext, GenerationDiagnostics, [AttemptDiagnostic])
runOffline GenConfig
gc = do
  let maxN :: Int
maxN   = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (GenConfig -> Int
_gcMaxAttempts GenConfig
gc)
      target :: Int
target = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (GenConfig -> Int
_gcViableTarget GenConfig
gc)
      floorT :: Double
floorT = GenConfig -> Double
_gcViabilityFloor GenConfig
gc
  scored <- GenConfig -> Int -> Int -> Double -> IO [ScoredAttempt]
offlineLoop GenConfig
gc Int
maxN Int
target Double
floorT
  finaliseScored gc scored

-- |Online arm of @generateBest@. SCORING shares one connection and one
-- 'PS.TransitionCache' across the entire K-attempt loop (attempts 2..K
-- score almost query-free); each attempt's GENERATION still opens its own
-- connection inside the walk (an HTTP manager — cheap, and the walk owns
-- its lifecycle). Scores via 'PS.scoreProgressionOnline' under @_gcSeek@
-- as the composer blend; ranks via 'PS.defaultWeights'.
--
-- If Neo4j is unreachable, 'connectNeo4j' will surface the error directly
-- — matching the existing generation pipeline's behaviour for the same
-- condition. Users who want to bypass Neo4j entirely opt in via
-- @seek "none"@.
runOnline :: GenConfig
          -> IO (PC.ProgressionContext, GenerationDiagnostics, [AttemptDiagnostic])
runOnline :: GenConfig
-> IO
     (ProgressionContext, GenerationDiagnostics, [AttemptDiagnostic])
runOnline GenConfig
gc = do
  let maxN :: Int
maxN    = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (GenConfig -> Int
_gcMaxAttempts GenConfig
gc)
      target :: Int
target  = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (GenConfig -> Int
_gcViableTarget GenConfig
gc)
      floorT :: Double
floorT  = GenConfig -> Double
_gcViabilityFloor GenConfig
gc
      seekTxt :: Text
seekTxt = [Char] -> Text
T.pack (GenConfig -> [Char]
_gcSeek GenConfig
gc)
  pipe <- IO DbConn
connectNeo4j
  cache <- PS.newTransitionCache
  scored <- runDb pipe (onlineLoop cache seekTxt gc maxN target floorT)
  finaliseScored gc scored

-- |Jazz arm of @generateBest@: identical loop shape to the online arm,
-- scored via 'PS.scoreProgressionJazz' — the same pure components, with
-- cadence favourability taken from the @Change@ graph under the seek
-- spec's jazz half. Ranked with 'PS.defaultWeights' (the jazz graph is
-- always online; @seek "none"@ was already refused by the walk).
runJazzBest :: GenConfig
            -> IO (PC.ProgressionContext, GenerationDiagnostics, [AttemptDiagnostic])
runJazzBest :: GenConfig
-> IO
     (ProgressionContext, GenerationDiagnostics, [AttemptDiagnostic])
runJazzBest GenConfig
gc = do
  -- Refuse seek "none" BEFORE opening the scoring connection: with the
  -- graph down the user must see the refusal, not a connection error.
  GenConfig -> IO ()
jazzGuardSeek GenConfig
gc
  let maxN :: Int
maxN    = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (GenConfig -> Int
_gcMaxAttempts GenConfig
gc)
      target :: Int
target  = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (GenConfig -> Int
_gcViableTarget GenConfig
gc)
      floorT :: Double
floorT  = GenConfig -> Double
_gcViabilityFloor GenConfig
gc
      seekTxt :: Text
seekTxt = [Char] -> Text
T.pack (GenConfig -> [Char]
_gcSeek GenConfig
gc)
  pipe <- IO DbConn
connectNeo4j
  cache <- PS.newTransitionCache
  scored <- runDb pipe (jazzLoop cache seekTxt gc maxN target floorT)
  finaliseScored gc scored

-- |Inner loop for the jazz arm, run under 'runDb'.
jazzLoop
  :: PS.TransitionCache -> T.Text -> GenConfig -> Int -> Int -> Double
  -> DbActionT [ScoredAttempt]
jazzLoop :: TransitionCache
-> Text
-> GenConfig
-> Int
-> Int
-> Double
-> DbActionT [ScoredAttempt]
jazzLoop TransitionCache
cache Text
seekTxt GenConfig
gc Int
maxN Int
target Double
floorT = do
  jazzBlend <- Text -> DbActionT ComposerWeights
PS.resolveJazzBlend Text
seekTxt
  let go Int
_ [(ProgressionContext, ProgressionScore, Double, Bool,
  GenerationDiagnostics, Maybe a)]
acc t
0 = [(ProgressionContext, ProgressionScore, Double, Bool,
  GenerationDiagnostics, Maybe a)]
-> ReaderT
     DbConn
     IO
     [(ProgressionContext, ProgressionScore, Double, Bool,
       GenerationDiagnostics, Maybe a)]
forall a. a -> ReaderT DbConn IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(ProgressionContext, ProgressionScore, Double, Bool,
  GenerationDiagnostics, Maybe a)]
-> [(ProgressionContext, ProgressionScore, Double, Bool,
     GenerationDiagnostics, Maybe a)]
forall a. [a] -> [a]
reverse [(ProgressionContext, ProgressionScore, Double, Bool,
  GenerationDiagnostics, Maybe a)]
acc)
      go Int
viableSoFar [(ProgressionContext, ProgressionScore, Double, Bool,
  GenerationDiagnostics, Maybe a)]
acc t
remaining
        | Int
viableSoFar Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
target = [(ProgressionContext, ProgressionScore, Double, Bool,
  GenerationDiagnostics, Maybe a)]
-> ReaderT
     DbConn
     IO
     [(ProgressionContext, ProgressionScore, Double, Bool,
       GenerationDiagnostics, Maybe a)]
forall a. a -> ReaderT DbConn IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(ProgressionContext, ProgressionScore, Double, Bool,
  GenerationDiagnostics, Maybe a)]
-> [(ProgressionContext, ProgressionScore, Double, Bool,
     GenerationDiagnostics, Maybe a)]
forall a. [a] -> [a]
reverse [(ProgressionContext, ProgressionScore, Double, Bool,
  GenerationDiagnostics, Maybe a)]
acc)
        | Bool
otherwise = do
            (pc, diag) <- IO (ProgressionContext, GenerationDiagnostics)
-> ReaderT DbConn IO (ProgressionContext, GenerationDiagnostics)
forall a. IO a -> ReaderT DbConn IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (GenConfig -> IO (ProgressionContext, GenerationDiagnostics)
singlePassExecPCWithDiag GenConfig
gc)
            ps <- PS.scoreProgressionJazz cache jazzBlend pc
            let tot   = ProgressionScoreWeights -> ProgressionScore -> Double
PS.totalScore ProgressionScoreWeights
PS.defaultWeights ProgressionScore
ps
                isOk  = ProgressionContext -> ProgressionScore -> Bool
viableAttempt ProgressionContext
pc ProgressionScore
ps Bool -> Bool -> Bool
&& Double
tot Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
floorT
                -- Jazz is single-layer for ranking purposes.
                acc'  = (ProgressionContext
pc, ProgressionScore
ps, Double
tot, Bool
isOk, GenerationDiagnostics
diag, Maybe a
forall a. Maybe a
Nothing) (ProgressionContext, ProgressionScore, Double, Bool,
 GenerationDiagnostics, Maybe a)
-> [(ProgressionContext, ProgressionScore, Double, Bool,
     GenerationDiagnostics, Maybe a)]
-> [(ProgressionContext, ProgressionScore, Double, Bool,
     GenerationDiagnostics, Maybe a)]
forall a. a -> [a] -> [a]
: [(ProgressionContext, ProgressionScore, Double, Bool,
  GenerationDiagnostics, Maybe a)]
acc
                viable' = if Bool
isOk then Int
viableSoFar Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 else Int
viableSoFar
            go viable' acc' (remaining - 1)
  go (0 :: Int) [] maxN

-- |Structural half of the viability gate: the mode invariant holds AND
-- the attempt actually produced bars. An invalid 'genP' cue yields an
-- empty progression whose pure axes all score their n<2 default of 1.0 —
-- without the length check it would rank as a perfect attempt.
viableAttempt :: PC.ProgressionContext -> PS.ProgressionScore -> Bool
viableAttempt :: ProgressionContext -> ProgressionScore -> Bool
viableAttempt ProgressionContext
pc ProgressionScore
ps =
  ProgressionScore -> Double
PS.psModeValidity ProgressionScore
ps Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
1.0 Bool -> Bool -> Bool
&& Progression -> Int
Prog.progLength (ProgressionContext -> Progression
PC.triadLayer ProgressionContext
pc) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0

-- |Inner-loop record: per-attempt (progression, score, totalScore,
-- viability flag, diagnostics). The diagnostics are carried so the
-- winner's per-step trace can be re-emitted at the caller's verbosity
-- without re-running generation. The accumulator is kept in generation
-- order; index is assigned in 'finaliseScored' so the scoreboard
-- reflects the actual trial sequence.
type ScoredAttempt =
  ( PC.ProgressionContext, PS.ProgressionScore, Double, Bool
  , GenerationDiagnostics, Maybe PS.PolyScore )

-- |Inner loop for the offline arm. Calls 'singlePassExecPCWithDiag'
-- (no printing) so per-attempt output is fully suppressed; diagnostics
-- are collected at the caller's verbosity for the winner's later render.
offlineLoop
  :: GenConfig            -- ^ caller's config (printing already lifted out)
  -> Int                  -- ^ maxAttempts
  -> Int                  -- ^ viableTarget
  -> Double               -- ^ viabilityFloor
  -> IO [ScoredAttempt]
offlineLoop :: GenConfig -> Int -> Int -> Double -> IO [ScoredAttempt]
offlineLoop GenConfig
gc Int
maxN Int
target Double
floorT = Int -> [ScoredAttempt] -> Int -> IO [ScoredAttempt]
forall {t}.
(Eq t, Num t) =>
Int -> [ScoredAttempt] -> t -> IO [ScoredAttempt]
go Int
0 [] Int
maxN
  where
    go :: Int -> [ScoredAttempt] -> t -> IO [ScoredAttempt]
go Int
_ [ScoredAttempt]
acc t
0 = [ScoredAttempt] -> IO [ScoredAttempt]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ScoredAttempt] -> [ScoredAttempt]
forall a. [a] -> [a]
reverse [ScoredAttempt]
acc)
    go Int
viableSoFar [ScoredAttempt]
acc t
remaining
      | Int
viableSoFar Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
target = [ScoredAttempt] -> IO [ScoredAttempt]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ScoredAttempt] -> [ScoredAttempt]
forall a. [a] -> [a]
reverse [ScoredAttempt]
acc)
      | Bool
otherwise = do
          (pc, diag) <- GenConfig -> IO (ProgressionContext, GenerationDiagnostics)
singlePassExecPCWithDiag GenConfig
gc
          -- genE is three progressions, not one: rank it on all three
          -- layers plus how far apart they stand.
          let ps    = ProgressionContext -> ProgressionScore
PS.scoreProgression ProgressionContext
pc
              poly  = if ProgressionContext -> Family
PC.pcFamily ProgressionContext
pc Family -> Family -> Bool
forall a. Eq a => a -> a -> Bool
== Family
PC.FPoly
                        then PolyScore -> Maybe PolyScore
forall a. a -> Maybe a
Just (ProgressionScoreWeights -> ProgressionContext -> PolyScore
PS.scorePoly ProgressionScoreWeights
PS.defaultWeightsOffline ProgressionContext
pc)
                        else Maybe PolyScore
forall a. Maybe a
Nothing
              tot   = Double -> (PolyScore -> Double) -> Maybe PolyScore -> Double
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ProgressionScoreWeights -> ProgressionScore -> Double
PS.totalScore ProgressionScoreWeights
PS.defaultWeightsOffline ProgressionScore
ps) PolyScore -> Double
PS.pyTotal Maybe PolyScore
poly
              isOk  = ProgressionContext -> ProgressionScore -> Bool
viableAttempt ProgressionContext
pc ProgressionScore
ps Bool -> Bool -> Bool
&& Double
tot Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
floorT
              acc'  = (ProgressionContext
pc, ProgressionScore
ps, Double
tot, Bool
isOk, GenerationDiagnostics
diag, Maybe PolyScore
poly) ScoredAttempt -> [ScoredAttempt] -> [ScoredAttempt]
forall a. a -> [a] -> [a]
: [ScoredAttempt]
acc
              viable' = if Bool
isOk then Int
viableSoFar Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 else Int
viableSoFar
          go viable' acc' (remaining - 1)

-- |Inner loop for the online arm, run under 'runDb'.
onlineLoop
  :: PS.TransitionCache   -- ^ cross-attempt fetch cache
  -> T.Text               -- ^ seek string (composer blend)
  -> GenConfig            -- ^ caller's config (printing already lifted out)
  -> Int                  -- ^ maxAttempts
  -> Int                  -- ^ viableTarget
  -> Double               -- ^ viabilityFloor
  -> DbActionT [ScoredAttempt]
onlineLoop :: TransitionCache
-> Text
-> GenConfig
-> Int
-> Int
-> Double
-> DbActionT [ScoredAttempt]
onlineLoop TransitionCache
cache Text
seekTxt GenConfig
gc Int
maxN Int
target Double
floorT = Int -> [ScoredAttempt] -> Int -> DbActionT [ScoredAttempt]
forall {t}.
(Eq t, Num t) =>
Int -> [ScoredAttempt] -> t -> DbActionT [ScoredAttempt]
go Int
0 [] Int
maxN
  where
    go :: Int -> [ScoredAttempt] -> t -> DbActionT [ScoredAttempt]
go Int
_ [ScoredAttempt]
acc t
0 = [ScoredAttempt] -> DbActionT [ScoredAttempt]
forall a. a -> ReaderT DbConn IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ScoredAttempt] -> [ScoredAttempt]
forall a. [a] -> [a]
reverse [ScoredAttempt]
acc)
    go Int
viableSoFar [ScoredAttempt]
acc t
remaining
      | Int
viableSoFar Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
target = [ScoredAttempt] -> DbActionT [ScoredAttempt]
forall a. a -> ReaderT DbConn IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ScoredAttempt] -> [ScoredAttempt]
forall a. [a] -> [a]
reverse [ScoredAttempt]
acc)
      | Bool
otherwise = do
          (pc, diag) <- IO (ProgressionContext, GenerationDiagnostics)
-> ReaderT DbConn IO (ProgressionContext, GenerationDiagnostics)
forall a. IO a -> ReaderT DbConn IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (GenConfig -> IO (ProgressionContext, GenerationDiagnostics)
singlePassExecPCWithDiag GenConfig
gc)
          ps <- PS.scoreProgressionOnline cache seekTxt pc
          poly <- if PC.pcFamily pc == PC.FPoly
                    then Just <$> PS.scorePolyOnline cache seekTxt PS.defaultWeights pc
                    else pure Nothing
          let tot   = Double -> (PolyScore -> Double) -> Maybe PolyScore -> Double
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ProgressionScoreWeights -> ProgressionScore -> Double
PS.totalScore ProgressionScoreWeights
PS.defaultWeights ProgressionScore
ps) PolyScore -> Double
PS.pyTotal Maybe PolyScore
poly
              isOk  = ProgressionContext -> ProgressionScore -> Bool
viableAttempt ProgressionContext
pc ProgressionScore
ps Bool -> Bool -> Bool
&& Double
tot Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
floorT
              acc'  = (ProgressionContext
pc, ProgressionScore
ps, Double
tot, Bool
isOk, GenerationDiagnostics
diag, Maybe PolyScore
poly) ScoredAttempt -> [ScoredAttempt] -> [ScoredAttempt]
forall a. a -> [a] -> [a]
: [ScoredAttempt]
acc
              viable' = if Bool
isOk then Int
viableSoFar Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 else Int
viableSoFar
          go viable' acc' (remaining - 1)

-- |Shared post-loop: builds 'AttemptDiagnostic' values with index +
-- picked flag set on the maximum-totalScore attempt, and returns the
-- picked 'Harmonic.Rules.Types.ProgressionContext.ProgressionContext', its 'GenerationDiagnostics' (for the
-- caller to emit via @emitFinalised@), and the per-attempt diagnostic
-- list (for the scoreboard).
--
-- The empty-scored defensive branch falls back to a non-silenced
-- 'singlePassExecPCWithDiag', mirroring the prior behaviour where the
-- fallback would print under the caller's verbosity.
finaliseScored
  :: GenConfig
  -> [ScoredAttempt]
  -> IO (PC.ProgressionContext, GenerationDiagnostics, [AttemptDiagnostic])
finaliseScored :: GenConfig
-> [ScoredAttempt]
-> IO
     (ProgressionContext, GenerationDiagnostics, [AttemptDiagnostic])
finaliseScored GenConfig
gc [ScoredAttempt]
scored = case [ScoredAttempt]
scored of
  [] -> do
    (pc, diag) <- GenConfig -> IO (ProgressionContext, GenerationDiagnostics)
singlePassExecPCWithDiag GenConfig
gc
    pure (pc, diag, [])
  [ScoredAttempt]
xs -> do
    let indexed :: [(Int, ScoredAttempt)]
indexed = [Int] -> [ScoredAttempt] -> [(Int, ScoredAttempt)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [ScoredAttempt]
xs
        -- Direction compliance ranks BEFORE score: an active rise/fall
        -- spec means a walk that held the direction beats a smoother one
        -- that surrendered it — K attempts buy rule character, not just
        -- polish. With no spec every dv is 0 and this is pure score
        -- order, byte-identical to the old pick.
        pctx :: ParsedContext
pctx = HarmonicContext -> ParsedContext
parseContextOnce (GenConfig -> HarmonicContext
_gcTonal GenConfig
gc)
        dvOf :: (ProgressionContext, b, c, d, e, f) -> Int
dvOf (ProgressionContext
pc, b
_, c
_, d
_, e
_, f
_) = ParsedContext -> Progression -> Int
directionViolations ParsedContext
pctx (ProgressionContext -> Progression
PC.triadLayer ProgressionContext
pc)
        (Int
winnerIdx, (ProgressionContext
winnerPC, ProgressionScore
_, Double
_, Bool
_, GenerationDiagnostics
winnerDiag, Maybe PolyScore
_)) =
          ((Int, ScoredAttempt) -> (Int, Double))
-> [(Int, ScoredAttempt)] -> (Int, ScoredAttempt)
forall b a. Ord b => (a -> b) -> [a] -> a
maximumByKey (\(Int
_, a :: ScoredAttempt
a@(ProgressionContext
_, ProgressionScore
_, Double
tot, Bool
_, GenerationDiagnostics
_, Maybe PolyScore
_)) -> (Int -> Int
forall a. Num a => a -> a
negate (ScoredAttempt -> Int
forall {b} {c} {d} {e} {f}.
(ProgressionContext, b, c, d, e, f) -> Int
dvOf ScoredAttempt
a), Double
tot)) [(Int, ScoredAttempt)]
indexed
        diags :: [AttemptDiagnostic]
diags = [ AttemptDiagnostic
                    { adIndex :: Int
adIndex  = Int
i
                    , adScore :: ProgressionScore
adScore  = ProgressionScore
ps
                    , adTotal :: Double
adTotal  = Double
tot
                    , adViable :: Bool
adViable = Bool
ok
                    , adPicked :: Bool
adPicked = Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
winnerIdx
                    , adDirViolations :: Int
adDirViolations = ScoredAttempt -> Int
forall {b} {c} {d} {e} {f}.
(ProgressionContext, b, c, d, e, f) -> Int
dvOf ScoredAttempt
a
                    , adChords :: [[Char]]
adChords = Progression -> [[Char]]
chordNamesOf (ProgressionContext -> Progression
PC.triadLayer ProgressionContext
pc)
                    , adPoly :: Maybe PolyScore
adPoly   = Maybe PolyScore
poly
                    }
                | (Int
i, a :: ScoredAttempt
a@(ProgressionContext
pc, ProgressionScore
ps, Double
tot, Bool
ok, GenerationDiagnostics
_, Maybe PolyScore
poly)) <- [(Int, ScoredAttempt)]
indexed
                ]
    (ProgressionContext, GenerationDiagnostics, [AttemptDiagnostic])
-> IO
     (ProgressionContext, GenerationDiagnostics, [AttemptDiagnostic])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProgressionContext
winnerPC, GenerationDiagnostics
winnerDiag, [AttemptDiagnostic]
diags)
  where
    maximumByKey :: Ord b => (a -> b) -> [a] -> a
    maximumByKey :: forall b a. Ord b => (a -> b) -> [a] -> a
maximumByKey a -> b
f = (a -> a -> a) -> [a] -> a
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\a
x a
y -> if a -> b
f a
x b -> b -> Bool
forall a. Ord a => a -> a -> Bool
>= a -> b
f a
y then a
x else a
y)

-- |Extract a chord-name sequence from a triad-layer 'Harmonic.Rules.Types.Progression.Progression' for
-- the scoreboard's diff column. Mirrors what 'Show Progression'
-- produces per cell, but as a plain list rather than a grid string.
chordNamesOf :: Prog.Progression -> [String]
chordNamesOf :: Progression -> [[Char]]
chordNamesOf Progression
prog =
  let cads :: [CadenceState]
cads = Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Prog.unProgression Progression
prog)
      enharms :: [PitchClass -> NoteName]
enharms = (CadenceState -> PitchClass -> NoteName)
-> [CadenceState] -> [PitchClass -> NoteName]
forall a b. (a -> b) -> [a] -> [b]
map (EnharmonicSpelling -> PitchClass -> NoteName
H.enharmonicFunc (EnharmonicSpelling -> PitchClass -> NoteName)
-> (CadenceState -> EnharmonicSpelling)
-> CadenceState
-> PitchClass
-> NoteName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CadenceState -> EnharmonicSpelling
H.stateSpelling) [CadenceState]
cads
  in ((PitchClass -> NoteName) -> CadenceState -> [Char])
-> [PitchClass -> NoteName] -> [CadenceState] -> [[Char]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (PitchClass -> NoteName) -> CadenceState -> [Char]
Prog.showHarmony [PitchClass -> NoteName]
enharms [CadenceState]
cads


-- |Non-fatal notice when the starting state escapes the active R context
-- (key\/overtone containment, allowed roots). The cue is always honoured —
-- 'cue' and the random default cue are the human aberration channel by
-- design — this only makes the escape visible. Prints nothing when the
-- state sits inside R or when the relevant filters are wildcards. Mirrors
-- 'matchesContextWithTarget' with no bass target and no strict containment
-- (its default treatment), so it never flags a state the step filter
-- itself would accept.
printCueEscapeNotice :: HarmonicContext -> H.CadenceState -> IO ()
printCueEscapeNotice :: HarmonicContext -> CadenceState -> IO ()
printCueEscapeNotice HarmonicContext
ctx CadenceState
start = do
  let pctx :: ParsedContext
pctx      = HarmonicContext -> ParsedContext
parseContextOnce HarmonicContext
ctx
      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 ]
      toneOff :: [Int]
toneOff   = if ParsedContext -> Bool
pcIsKeyWild ParsedContext
pctx Bool -> Bool -> Bool
&& ParsedContext -> Bool
pcIsOvertonesWild ParsedContext
pctx
                    then []
                    else [ Int
p | Int
p <- [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub [Int]
absPCs
                             , Bool -> Bool
not (Int -> IntSet -> Bool
IntSet.member Int
p (ParsedContext -> IntSet
pcEffectiveOvertones ParsedContext
pctx)) ]
      rootOff :: Bool
rootOff   = Bool -> Bool
not (ParsedContext -> Bool
pcIsRootsWild ParsedContext
pctx)
                  Bool -> Bool -> Bool
&& Bool -> Bool
not (Int -> IntSet -> Bool
IntSet.member Int
rootPC (ParsedContext -> IntSet
pcAllowedBassNotes ParsedContext
pctx))
      spelling :: EnharmonicSpelling
spelling  = [Int] -> EnharmonicSpelling
H.inferSpelling [Int]
absPCs
      enharm :: PitchClass -> NoteName
enharm    = EnharmonicSpelling -> PitchClass -> NoteName
H.enharmonicFunc EnharmonicSpelling
spelling
      spellPC :: Int -> [Char]
spellPC Int
p = NoteName -> [Char]
forall a. Show a => a -> [Char]
show (PitchClass -> NoteName
enharm (Int -> PitchClass
P.mkPitchClass Int
p))
      parts :: [[Char]]
parts     = [ [Char]
"contains " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords ((Int -> [Char]) -> [Int] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Int -> [Char]
spellPC [Int]
toneOff)
                    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" outside the key/overtone set" | Bool -> Bool
not ([Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
toneOff) ]
             [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [ [Char]
"root " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
spellPC Int
rootPC [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" outside the allowed roots"
                | Bool
rootOff ]
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
parts)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"⚠ cue escapes R: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"; " [[Char]]
parts
             [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ HarmonicContext -> [Char]
forall a. Show a => a -> [Char]
show HarmonicContext
ctx [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"