{-# LANGUAGE OverloadedStrings #-}

-- |
-- 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', gen', genWith'@ - Returns @(Progression, GenerationDiagnostics)@ tuple
--   * @generate'', gen'', genWith''@ - 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
  , gen4
  , gen4'
  , gen4''
  , quad
  , genFrom
  , genFrom'
  , genFrom''

    -- * 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
  , genWith

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

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

    -- * Unified Positional Interface
  , genSilent
  , genSilent'
  , genStandard
  , genStandard'
  , genVerbose
  , 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

    -- * Configuration
  , GeneratorConfig(..)
  , defaultConfig

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

import qualified Database.Bolt as Bolt
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 (GenIO, createSystemRandom, uniformRM)

import qualified Harmonic.Rules.Types.Harmony as H
import qualified Harmonic.Rules.Types.Pitch as P
import qualified Harmonic.Rules.Types.Progression as Prog
import qualified Harmonic.Rules.Types.ProgressionContext as PC
import qualified Harmonic.Rules.Types.Scale as Sc
import           Harmonic.Rules.Import.Graph (connectNeo4j)
import qualified Harmonic.Evaluation.Database.Query as Q
import qualified Harmonic.Evaluation.Scoring.Progression as PS
import           Control.Monad.IO.Class (liftIO)
import           Harmonic.Rules.Constraints.Filter (parseTuningNamed, isWildcard)
import           Harmonic.Rules.Constraints.Overtone (formatOvertoneAnnotation, formatOvertoneAnnotationPipe, possibleTriads)
import           Data.Foldable (toList)
import           Data.List (intercalate, sort, nub)
import           Data.Maybe (fromMaybe)
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 qualified Harmonic.Framework.Builder.Strata as Strata

-------------------------------------------------------------------------------
-- 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
len Text
composerStr Double
entropy HarmonicContext
context =
  GeneratorConfig
-> CadenceState
-> Int
-> Text
-> Double
-> HarmonicContext
-> IO Progression
generateWith GeneratorConfig
defaultConfig CadenceState
start Int
len Text
composerStr Double
entropy 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
len [Char]
composerStr Double
entropy HarmonicContext
ctx = do
  (Progression
prog, GenerationDiagnostics
_diag) <- CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
generate' CadenceState
start Int
len [Char]
composerStr Double
entropy HarmonicContext
ctx
  [Char] -> IO ()
putStrLn [Char]
""
  Text -> Double -> HarmonicContext -> IO ()
printHeader ([Char] -> Text
T.pack [Char]
composerStr) Double
entropy HarmonicContext
ctx
  Progression -> IO ()
forall a. Show a => a -> IO ()
print Progression
prog
  [Char] -> IO ()
putStrLn [Char]
""
  Progression -> IO Progression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Progression
prog

-- |String-friendly generateWith for TidalCycles live coding.
genWith :: GeneratorConfig -> H.CadenceState -> Int -> String -> Double -> HarmonicContext -> IO Prog.Progression
genWith :: GeneratorConfig
-> CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO Progression
genWith GeneratorConfig
config CadenceState
start Int
len [Char]
composerStr Double
entropy HarmonicContext
ctx = GeneratorConfig
-> CadenceState
-> Int
-> Text
-> Double
-> HarmonicContext
-> IO Progression
generateWith GeneratorConfig
config CadenceState
start Int
len ([Char] -> Text
T.pack [Char]
composerStr) Double
entropy HarmonicContext
ctx

-- |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 :: GeneratorConfig
             -> H.CadenceState
             -> Int
             -> Text
             -> Double
             -> HarmonicContext
             -> IO Prog.Progression
generateWith :: GeneratorConfig
-> CadenceState
-> Int
-> Text
-> Double
-> HarmonicContext
-> IO Progression
generateWith GeneratorConfig
config CadenceState
start Int
len Text
composerStr Double
entropy HarmonicContext
context = do
  let pctx :: ParsedContext
pctx = HarmonicContext -> ParsedContext
parseContextOnce HarmonicContext
context
  Gen RealWorld
rng <- IO (Gen RealWorld)
IO GenIO
createSystemRandom
  [CadenceState]
chain <- if (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (Text -> [Char]
T.unpack Text
composerStr) [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"none"
    then GeneratorConfig
-> GenIO
-> Double
-> HarmonicContext
-> ParsedContext
-> CadenceState
-> Int
-> IO [CadenceState]
buildChainOffline GeneratorConfig
config Gen RealWorld
GenIO
rng Double
entropy HarmonicContext
context ParsedContext
pctx CadenceState
start (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    else do
      let composerWeights :: ComposerWeights
composerWeights = Text -> ComposerWeights
Q.parseComposerWeights Text
composerStr
      Pipe
pipe <- IO Pipe
connectNeo4j
      [CadenceState]
result <- Pipe -> BoltActionT IO [CadenceState] -> IO [CadenceState]
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
Pipe -> BoltActionT m a -> m a
Bolt.run Pipe
pipe (BoltActionT IO [CadenceState] -> IO [CadenceState])
-> BoltActionT IO [CadenceState] -> IO [CadenceState]
forall a b. (a -> b) -> a -> b
$ GeneratorConfig
-> GenIO
-> Double
-> HarmonicContext
-> ParsedContext
-> ComposerWeights
-> CadenceState
-> Int
-> BoltActionT IO [CadenceState]
buildChain GeneratorConfig
config Gen RealWorld
GenIO
rng Double
entropy HarmonicContext
context ParsedContext
pctx ComposerWeights
composerWeights CadenceState
start (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      Pipe -> IO ()
forall (m :: * -> *). (MonadIO m, HasCallStack) => Pipe -> m ()
Bolt.close Pipe
pipe
      [CadenceState] -> IO [CadenceState]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [CadenceState]
result
  Progression -> IO Progression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Progression -> IO Progression) -> Progression -> IO Progression
forall a b. (a -> b) -> a -> b
$ [CadenceState] -> Progression
chainToProgression [CadenceState]
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
len [Char]
composerStr Double
entropy HarmonicContext
ctx =
  GeneratorConfig
-> CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
genWith' GeneratorConfig
defaultConfig CadenceState
start Int
len [Char]
composerStr Double
entropy 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
len [Char]
composerStr Double
entropy HarmonicContext
ctx = do
  (Progression
prog, GenerationDiagnostics
diag) <- CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
generate' CadenceState
start Int
len [Char]
composerStr Double
entropy HarmonicContext
ctx
  [Char] -> HarmonicContext -> GenerationDiagnostics -> IO ()
renderStandardSteps [Char]
composerStr HarmonicContext
ctx GenerationDiagnostics
diag
  [Char] -> IO ()
putStrLn [Char]
""
  Text -> Double -> HarmonicContext -> IO ()
printHeader ([Char] -> Text
T.pack [Char]
composerStr) Double
entropy HarmonicContext
ctx
  Progression -> IO ()
forall a. Show a => a -> IO ()
print Progression
prog
  [Char] -> IO ()
putStrLn [Char]
""
  Progression -> IO Progression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Progression
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.
renderStandardSteps :: String -> HarmonicContext -> GenerationDiagnostics -> IO ()
renderStandardSteps :: [Char] -> HarmonicContext -> GenerationDiagnostics -> IO ()
renderStandardSteps [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 (entropy " [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 = if Bool
hasAnnotation Bool -> Bool -> Bool
&& Bool -> Bool
not ([CadenceState] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CadenceState]
allStates)
                   then let ann :: [Char]
ann = CadenceState -> [Char]
annotateState ([CadenceState] -> CadenceState
forall a. HasCallStack => [a] -> a
head [CadenceState]
allStates)
                        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]
""
  [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"  1: " [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]
forall a. Show a => a -> [Char]
show 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

    -- gen4: one additive line describing the added-tone draw. The
    -- Candidates line above stays triad-stage only (final-pool members).
    case StepDiagnostic -> Maybe FusionDiag
sdFusion StepDiagnostic
step of
      Just FusionDiag
fd -> do
        let spelling :: EnharmonicSpelling
spelling = case 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)) of
              [CadenceState]
css | Int
barNum Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 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]
css -> CadenceState -> EnharmonicSpelling
H.stateSpelling ([CadenceState]
css [CadenceState] -> Int -> CadenceState
forall a. HasCallStack => [a] -> Int -> a
!! (Int
barNum Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
              [CadenceState]
_ -> EnharmonicSpelling
H.FlatSpelling
            toneName :: [Char]
toneName = NoteName -> [Char]
forall a. Show a => a -> [Char]
show (EnharmonicSpelling -> PitchClass -> NoteName
H.enharmonicFunc EnharmonicSpelling
spelling (Int -> PitchClass
P.mkPitchClass (FusionDiag -> Int
fdAddedPC FusionDiag
fd)))
        [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"     fused: +" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
toneName
                   [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]
++ FusionDiag -> [Char]
fdFusedName FusionDiag
fd
                   [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  [rank " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (FusionDiag -> Int
fdGammaIdx FusionDiag
fd Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [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 (FusionDiag -> Int
fdPoolK FusionDiag
fd) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"]"
      Maybe FusionDiag
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

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

-- |Generate with custom configuration, returning diagnostics tuple (internal).
genWith' :: GeneratorConfig -> H.CadenceState -> Int -> String -> Double -> HarmonicContext
         -> IO (Prog.Progression, GenerationDiagnostics)
genWith' :: GeneratorConfig
-> CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
genWith' GeneratorConfig
config CadenceState
start Int
len [Char]
composerStr Double
entropy HarmonicContext
context = do
  let pctx :: ParsedContext
pctx = HarmonicContext -> ParsedContext
parseContextOnce HarmonicContext
context
  Gen RealWorld
rng <- IO (Gen RealWorld)
IO GenIO
createSystemRandom
  ([CadenceState]
chain, [StepDiagnostic]
stepDiags) <- if (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
composerStr [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"none"
    then GeneratorConfig
-> GenIO
-> Double
-> HarmonicContext
-> ParsedContext
-> CadenceState
-> Int
-> IO ([CadenceState], [StepDiagnostic])
buildChainOfflineWithDiag GeneratorConfig
config Gen RealWorld
GenIO
rng Double
entropy HarmonicContext
context ParsedContext
pctx CadenceState
start (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    else do
      let composerWeights :: ComposerWeights
composerWeights = Text -> ComposerWeights
Q.parseComposerWeights ([Char] -> Text
T.pack [Char]
composerStr)
      Pipe
pipe <- IO Pipe
connectNeo4j
      ([CadenceState], [StepDiagnostic])
result <- Pipe
-> BoltActionT IO ([CadenceState], [StepDiagnostic])
-> IO ([CadenceState], [StepDiagnostic])
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
Pipe -> BoltActionT m a -> m a
Bolt.run Pipe
pipe (BoltActionT IO ([CadenceState], [StepDiagnostic])
 -> IO ([CadenceState], [StepDiagnostic]))
-> BoltActionT IO ([CadenceState], [StepDiagnostic])
-> IO ([CadenceState], [StepDiagnostic])
forall a b. (a -> b) -> a -> b
$ GeneratorConfig
-> GenIO
-> Double
-> HarmonicContext
-> ParsedContext
-> ComposerWeights
-> CadenceState
-> Int
-> BoltActionT IO ([CadenceState], [StepDiagnostic])
buildChainWithDiag GeneratorConfig
config Gen RealWorld
GenIO
rng Double
entropy HarmonicContext
context ParsedContext
pctx ComposerWeights
composerWeights CadenceState
start (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      Pipe -> IO ()
forall (m :: * -> *). (MonadIO m, HasCallStack) => Pipe -> m ()
Bolt.close Pipe
pipe
      ([CadenceState], [StepDiagnostic])
-> IO ([CadenceState], [StepDiagnostic])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CadenceState], [StepDiagnostic])
result
  let prog :: Progression
prog = [CadenceState] -> Progression
chainToProgression [CadenceState]
chain
      diag :: GenerationDiagnostics
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
len
        , gdActualLen :: Int
gdActualLen = Progression -> Int
Prog.progLength Progression
prog
        , gdEntropy :: Double
gdEntropy = Double
entropy
        , gdSteps :: [StepDiagnostic]
gdSteps = [StepDiagnostic]
stepDiags
        , gdProgression :: Progression
gdProgression = Progression
prog
        }
  (Progression, GenerationDiagnostics)
-> IO (Progression, GenerationDiagnostics)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Progression
prog, GenerationDiagnostics
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
len [Char]
composerStr Double
entropy HarmonicContext
ctx =
  GeneratorConfig
-> CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
genWith'' GeneratorConfig
defaultConfig CadenceState
start Int
len [Char]
composerStr Double
entropy 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
len [Char]
composerStr Double
entropy HarmonicContext
ctx = do
  (Progression
prog, GenerationDiagnostics
diag) <- CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
generate'' CadenceState
start Int
len [Char]
composerStr Double
entropy HarmonicContext
ctx
  [Char] -> GenerationDiagnostics -> IO ()
renderVerboseSteps [Char]
composerStr GenerationDiagnostics
diag
  [Char] -> IO ()
putStrLn [Char]
""
  Text -> Double -> HarmonicContext -> IO ()
printHeader ([Char] -> Text
T.pack [Char]
composerStr) Double
entropy HarmonicContext
ctx
  Progression -> IO ()
forall a. Show a => a -> IO ()
print Progression
prog
  [Char] -> IO ()
putStrLn [Char]
""
  Progression -> IO Progression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Progression
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.
renderVerboseSteps :: String -> GenerationDiagnostics -> IO ()
renderVerboseSteps :: [Char] -> GenerationDiagnostics -> IO ()
renderVerboseSteps [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 (entropy " [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 1: " [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]
forall a. Show a => a -> [Char]
show 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).
genWith'' :: GeneratorConfig -> H.CadenceState -> Int -> String -> Double -> HarmonicContext
          -> IO (Prog.Progression, GenerationDiagnostics)
genWith'' :: GeneratorConfig
-> CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
genWith'' GeneratorConfig
config CadenceState
start Int
len [Char]
composerStr Double
entropy HarmonicContext
context = do
  let pctx :: ParsedContext
pctx = HarmonicContext -> ParsedContext
parseContextOnce HarmonicContext
context
  Gen RealWorld
rng <- IO (Gen RealWorld)
IO GenIO
createSystemRandom
  ([CadenceState]
chain, [StepDiagnostic]
stepDiags) <- if (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
composerStr [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"none"
    then GeneratorConfig
-> GenIO
-> Int
-> Double
-> HarmonicContext
-> ParsedContext
-> CadenceState
-> Int
-> IO ([CadenceState], [StepDiagnostic])
buildChainOfflineWithDiagV GeneratorConfig
config Gen RealWorld
GenIO
rng Int
2 Double
entropy HarmonicContext
context ParsedContext
pctx CadenceState
start (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    else do
      let composerWeights :: ComposerWeights
composerWeights = Text -> ComposerWeights
Q.parseComposerWeights ([Char] -> Text
T.pack [Char]
composerStr)
      Pipe
pipe <- IO Pipe
connectNeo4j
      ([CadenceState], [StepDiagnostic])
result <- Pipe
-> BoltActionT IO ([CadenceState], [StepDiagnostic])
-> IO ([CadenceState], [StepDiagnostic])
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
Pipe -> BoltActionT m a -> m a
Bolt.run Pipe
pipe (BoltActionT IO ([CadenceState], [StepDiagnostic])
 -> IO ([CadenceState], [StepDiagnostic]))
-> BoltActionT IO ([CadenceState], [StepDiagnostic])
-> IO ([CadenceState], [StepDiagnostic])
forall a b. (a -> b) -> a -> b
$ GeneratorConfig
-> GenIO
-> Int
-> Double
-> HarmonicContext
-> ParsedContext
-> ComposerWeights
-> CadenceState
-> Int
-> BoltActionT IO ([CadenceState], [StepDiagnostic])
buildChainWithDiagV GeneratorConfig
config Gen RealWorld
GenIO
rng Int
2 Double
entropy HarmonicContext
context ParsedContext
pctx ComposerWeights
composerWeights CadenceState
start (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      Pipe -> IO ()
forall (m :: * -> *). (MonadIO m, HasCallStack) => Pipe -> m ()
Bolt.close Pipe
pipe
      ([CadenceState], [StepDiagnostic])
-> IO ([CadenceState], [StepDiagnostic])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CadenceState], [StepDiagnostic])
result
  let prog :: Progression
prog = [CadenceState] -> Progression
chainToProgression [CadenceState]
chain
      diag :: GenerationDiagnostics
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
len
        , gdActualLen :: Int
gdActualLen = Progression -> Int
Prog.progLength Progression
prog
        , gdEntropy :: Double
gdEntropy = Double
entropy
        , gdSteps :: [StepDiagnostic]
gdSteps = [StepDiagnostic]
stepDiags
        , gdProgression :: Progression
gdProgression = Progression
prog
        }
  (Progression, GenerationDiagnostics)
-> IO (Progression, GenerationDiagnostics)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Progression
prog, GenerationDiagnostics
diag)

-------------------------------------------------------------------------------
-- 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
len [Char]
composerStr Double
entropy HarmonicContext
ctx = do
  (Progression
prog, GenerationDiagnostics
_diag) <- CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
generate' CadenceState
start Int
len [Char]
composerStr Double
entropy HarmonicContext
ctx
  Progression -> IO Progression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Progression
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
len [Char]
composerStr Double
entropy HarmonicContext
ctx = do
  (Progression
prog, GenerationDiagnostics
diag) <- CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
generate' CadenceState
start Int
len [Char]
composerStr Double
entropy HarmonicContext
ctx
  Int -> GenerationDiagnostics -> IO ()
printDiagnostics Int
1 GenerationDiagnostics
diag
  Progression -> IO Progression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Progression
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
len [Char]
composerStr Double
entropy HarmonicContext
ctx = do
  (Progression
prog, GenerationDiagnostics
diag) <- CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
generate'' CadenceState
start Int
len [Char]
composerStr Double
entropy HarmonicContext
ctx
  Int -> GenerationDiagnostics -> IO ()
printDiagnostics Int
2 GenerationDiagnostics
diag
  Progression -> IO Progression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Progression
prog

-- |Silent mode with custom 'GeneratorConfig'.
genSilent' :: GeneratorConfig -> H.CadenceState -> Int -> String -> Double -> HarmonicContext -> IO Prog.Progression
genSilent' :: GeneratorConfig
-> CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO Progression
genSilent' GeneratorConfig
config CadenceState
start Int
len [Char]
composerStr Double
entropy HarmonicContext
ctx = do
  (Progression
prog, GenerationDiagnostics
_diag) <- GeneratorConfig
-> CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
genWith' GeneratorConfig
config CadenceState
start Int
len [Char]
composerStr Double
entropy HarmonicContext
ctx
  Progression -> IO Progression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Progression
prog

-- |Standard diagnostics with custom 'GeneratorConfig'.
genStandard' :: GeneratorConfig -> H.CadenceState -> Int -> String -> Double -> HarmonicContext -> IO Prog.Progression
genStandard' :: GeneratorConfig
-> CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO Progression
genStandard' GeneratorConfig
config CadenceState
start Int
len [Char]
composerStr Double
entropy HarmonicContext
ctx = do
  (Progression
prog, GenerationDiagnostics
diag) <- GeneratorConfig
-> CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
genWith' GeneratorConfig
config CadenceState
start Int
len [Char]
composerStr Double
entropy HarmonicContext
ctx
  Int -> GenerationDiagnostics -> IO ()
printDiagnostics Int
1 GenerationDiagnostics
diag
  Progression -> IO Progression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Progression
prog

-- |Verbose diagnostics with custom 'GeneratorConfig'.
genVerbose' :: GeneratorConfig -> H.CadenceState -> Int -> String -> Double -> HarmonicContext -> IO Prog.Progression
genVerbose' :: GeneratorConfig
-> CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO Progression
genVerbose' GeneratorConfig
config CadenceState
start Int
len [Char]
composerStr Double
entropy HarmonicContext
ctx = do
  (Progression
prog, GenerationDiagnostics
diag) <- GeneratorConfig
-> CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
genWith'' GeneratorConfig
config CadenceState
start Int
len [Char]
composerStr Double
entropy HarmonicContext
ctx
  Int -> GenerationDiagnostics -> IO ()
printDiagnostics Int
2 GenerationDiagnostics
diag
  Progression -> IO Progression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Progression
prog

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

-- |Execute a 'GenConfig', producing a progression.
--
-- Thin wrapper that calls @execGenConfigWithDiag@ (pure compute) and then
-- emits the appropriate diagnostics + header + grid via @emitFinalised@.
-- Single-pass callers see byte-identical output to today.
execGenConfig :: GenConfig -> IO Prog.Progression
execGenConfig :: GenConfig -> IO Progression
execGenConfig GenConfig
gc = do
  (Progression
prog, GenerationDiagnostics
diag) <- GenConfig -> IO (Progression, GenerationDiagnostics)
execGenConfigWithDiag GenConfig
gc
  GenConfig -> (ProgressionContext, GenerationDiagnostics) -> IO ()
emitFinalised GenConfig
gc (Progression -> ProgressionContext
PC.fromProgression Progression
prog, GenerationDiagnostics
diag)
  Progression -> IO Progression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Progression
prog

-- |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
  CadenceState
start0 <- GenConfig -> IO CadenceState
_gcCue GenConfig
gc
  -- gen4: fuse a triad cue once so the output is uniformly 4-note from
  -- bar 1 (user decision 2026-08-19). A 4-note lead' cue passes through
  -- untouched; sub-triad cues are left alone.
  CadenceState
start <- if GenConfig -> Bool
_gcQuad GenConfig
gc
                Bool -> Bool -> Bool
&& [PitchClass] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Cadence -> [PitchClass]
H.cadenceIntervals (CadenceState -> Cadence
H.stateCadence CadenceState
start0)) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3
             then do
               Gen RealWorld
rng <- IO (Gen RealWorld)
IO GenIO
createSystemRandom
               let pctx :: ParsedContext
pctx = HarmonicContext -> ParsedContext
parseContextOnce (GenConfig -> HarmonicContext
_gcTonal GenConfig
gc)
               (CadenceState
fused, Maybe FusionDiag
_) <- GenIO
-> Double
-> ParsedContext
-> Maybe CadenceState
-> CadenceState
-> IO (CadenceState, Maybe FusionDiag)
fuseState Gen RealWorld
GenIO
rng (GenConfig -> Double
_gcEntropy GenConfig
gc) ParsedContext
pctx Maybe CadenceState
forall a. Maybe a
Nothing CadenceState
start0
               CadenceState -> IO CadenceState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CadenceState
fused
             else CadenceState -> IO CadenceState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CadenceState
start0
  let cfg :: GeneratorConfig
cfg = GeneratorConfig
defaultConfig { gcQuad = _gcQuad gc }
  case GenConfig -> GenMode
_gcMode GenConfig
gc of
    GenMode
Fresh -> case GenConfig -> Verbosity
_gcVerbosity GenConfig
gc of
      Verbosity
Silent   -> GeneratorConfig
-> CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
genWith'  GeneratorConfig
cfg CadenceState
start (GenConfig -> Int
_gcLen GenConfig
gc) (GenConfig -> [Char]
_gcSeek GenConfig
gc) (GenConfig -> Double
_gcEntropy GenConfig
gc) (GenConfig -> HarmonicContext
_gcTonal GenConfig
gc)
      Verbosity
Standard -> GeneratorConfig
-> CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
genWith'  GeneratorConfig
cfg CadenceState
start (GenConfig -> Int
_gcLen GenConfig
gc) (GenConfig -> [Char]
_gcSeek GenConfig
gc) (GenConfig -> Double
_gcEntropy GenConfig
gc) (GenConfig -> HarmonicContext
_gcTonal GenConfig
gc)
      Verbosity
Verbose  -> GeneratorConfig
-> CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
genWith'' GeneratorConfig
cfg 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
            }
      (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
      -- Family uniformity: regeneration produces states of the family the
      -- source already is. genFrom auto-detects (uniform 4-note source →
      -- _gcQuad); an EXPLICIT quad on a non-4-note source would create the
      -- family mixing regeneration must never produce → fail fast.
      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) ]
          srcQuad :: Bool
srcQuad  = 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. Eq 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 (GenConfig -> Bool
_gcQuad GenConfig
gc Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
srcQuad) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"genFrom is family-aware: this source is not a uniform 4-note (gen4) progression — regenerate with plain genFrom (quad is inferred from the source)"
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
srcMixed (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.
      (Progression
fullProg, GenerationDiagnostics
regenDiag) <- GeneratorConfig
-> CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
genWith' GeneratorConfig
cfg 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 :: [CadenceState]
newChords = [CadenceState] -> [CadenceState]
forall a. HasCallStack => [a] -> [a]
tail ([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
result    = Progression -> Int -> Int -> [CadenceState] -> Progression
Prog.spliceProgression Progression
srcProg Int
s Int
e [CadenceState]
newChords
      (Progression, GenerationDiagnostics)
-> IO (Progression, GenerationDiagnostics)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Progression
result, GenerationDiagnostics
regenDiag)

    -- Strata modes are handled by the PC-returning path; they should not
    -- reach this function. Defensive fallback retains the old Fresh
    -- behaviour rather than crashing.
    StrataMode StrataLabel
_    -> CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
generate' CadenceState
start (GenConfig -> Int
_gcLen GenConfig
gc) (GenConfig -> [Char]
_gcSeek GenConfig
gc) (GenConfig -> Double
_gcEntropy GenConfig
gc) (GenConfig -> HarmonicContext
_gcTonal GenConfig
gc)
    FromProgPC {}   -> CadenceState
-> Int
-> [Char]
-> Double
-> HarmonicContext
-> IO (Progression, GenerationDiagnostics)
generate' CadenceState
start (GenConfig -> Int
_gcLen GenConfig
gc) (GenConfig -> [Char]
_gcSeek GenConfig
gc) (GenConfig -> Double
_gcEntropy GenConfig
gc) (GenConfig -> HarmonicContext
_gcTonal GenConfig
gc)

-- |Default generation configuration.
--
-- @
-- cue:     random root, major triad
-- len:     4
-- seek:    "*" (all composers)
-- entropy: 0.2
-- tonal:   hContext (chromatic)
-- @
defaultGenConfig :: GenConfig
defaultGenConfig :: GenConfig
defaultGenConfig = GenConfig
  { _gcCue :: IO CadenceState
_gcCue         = IO CadenceState
defaultCue
  , _gcLen :: Int
_gcLen         = Int
4
  , _gcSeek :: [Char]
_gcSeek        = [Char]
"*"
  , _gcEntropy :: Double
_gcEntropy     = Double
0.2
  , _gcTonal :: HarmonicContext
_gcTonal       = HarmonicContext
hContext
  , _gcVerbosity :: Verbosity
_gcVerbosity   = Verbosity
Silent
  , _gcMode :: GenMode
_gcMode        = GenMode
Fresh
  , _gcLenOverride :: Maybe Int
_gcLenOverride = Maybe Int
forall a. Maybe a
Nothing
  , _gcRelStrata :: Maybe [Int]
_gcRelStrata   = Maybe [Int]
forall a. Maybe a
Nothing
  , _gcAbsStrata :: Maybe [StrataLabel]
_gcAbsStrata   = Maybe [StrataLabel]
forall a. Maybe a
Nothing
  -- Plan defaults: same-strata 0.90, flip-flop 0.80, same-tristrata 0.70.
  -- Values < 1.0 multiply @badness@ down (favouring the candidate); 1.0 is
  -- the no-op. The product caps at 0.70 * 0.80 * 0.90 ≈ 0.50, giving
  -- ≤2× favouring — overpowerable by strong graph-side confidence.
  , _gcBoostSame :: Double
_gcBoostSame   = Double
0.90
  , _gcBoostFlip :: Double
_gcBoostFlip   = Double
0.80
  , _gcBoostTri :: Double
_gcBoostTri    = Double
0.70
  , _gcQuad :: Bool
_gcQuad        = Bool
False
  , _gcMaxAttempts :: Int
_gcMaxAttempts  = Int
1
  , _gcViableTarget :: Int
_gcViableTarget = Int
1
  -- Calibrated from a 30-sample online probe (gen, 8 bars, entropy 0.4,
  -- seek "*"): totalScore distribution observed at min 0.50, median 0.67,
  -- max 0.78 with the online default weights. T=0.6 catches the bottom
  -- ~20% of attempts (fallback-driven or tritone-leap runs), keeping
  -- 'attempt 3 12' reliable. Tune with the 'viability' modifier.
  , _gcViabilityFloor :: Double
_gcViabilityFloor = Double
0.6
  }
  where
    defaultCue :: IO CadenceState
defaultCue = do
      Gen RealWorld
rng <- IO (Gen RealWorld)
IO GenIO
createSystemRandom
      Int
rootIdx <- (Int, Int) -> Gen RealWorld -> IO Int
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *). StatefulGen g m => (Int, Int) -> g -> m Int
uniformRM (Int
0 :: Int, Int
11) Gen RealWorld
rng
      let rootName :: NoteName
rootName = EnharmonicSpelling -> PitchClass -> NoteName
H.enharmonicFunc EnharmonicSpelling
H.FlatSpelling (Int -> PitchClass
P.mkPitchClass Int
rootIdx)
      CadenceState -> IO CadenceState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CadenceState -> IO CadenceState)
-> CadenceState -> IO CadenceState
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> [Int] -> CadenceState
H.initCadenceState Int
0 (NoteName -> [Char]
forall a. Show a => a -> [Char]
show NoteName
rootName) [Int
0, Int
4, Int
7]

-- |Generation config with header + grid output (default).
--
-- @
-- s <- seek "*" $ gen
-- s <- seek "*" $ cue start $ tonal ctx $ len 4 $ entropy 0.3 $ gen
-- @
gen :: GenConfig
gen :: GenConfig
gen = GenConfig
defaultGenConfig

-- |Generation config with compact musical summary.
gen' :: GenConfig
gen' :: GenConfig
gen' = GenConfig
defaultGenConfig { _gcVerbosity = Standard }

-- |Generation config with verbose diagnostic traces.
gen'' :: GenConfig
gen'' :: GenConfig
gen'' = GenConfig
defaultGenConfig { _gcVerbosity = Verbose }

-- |Static grid: repeats the cue chord for 'len' bars. No database access.
--
-- @s <- seek "*" $ cue start $ len 4 $ genGrid@
genGrid :: GenConfig
genGrid :: GenConfig
genGrid = GenConfig
defaultGenConfig { _gcMode = GridMode }

-- |Switch on the gen4 family: every generated bar carries a 4-note chord.
--
-- Each step first selects a triad exactly as plain 'gen' (graph + fallback,
-- R filters, gamma draw), then fuses in one more R-valid palette tone —
-- ranked consonant-first by full-chord dissonance, drawn at the same
-- entropy. The walk continues from the fused chord's most-consonant
-- embedded triad, so the added tone can reinterpret the harmony and steer
-- the next step, while every graph key stays corpus-shaped (generation
-- stays online). A triad cue is fused once so output is uniformly 4-note;
-- a 4-note 'Harmonic.Interface.Tidal.Arranger.lead'' cue passes through untouched.
--
-- Composes with the usual modifier chain. Never applies to the strata
-- family ('genP') — strata progressions stay 3-5-7.
--
-- @s <- seek "*" $ cue start $ entropy 0.4 $ quad gen'@
quad :: GenConfig -> GenConfig
quad :: GenConfig -> GenConfig
quad GenConfig
gc = GenConfig
gc { _gcQuad = True }

-- |gen4 family sugar: 'quad' pre-applied to 'gen' \/ 'gen'' \/ 'gen'''.
--
-- @s <- seek "*" $ len 8 $ entropy 0.3 $ gen4'@
gen4 :: GenConfig
gen4 :: GenConfig
gen4 = GenConfig -> GenConfig
quad GenConfig
gen

-- |'gen4' with compact musical summary.
gen4' :: GenConfig
gen4' :: GenConfig
gen4' = GenConfig -> GenConfig
quad GenConfig
gen'

-- |'gen4' with verbose diagnostic traces.
gen4'' :: GenConfig
gen4'' :: GenConfig
gen4'' = GenConfig -> GenConfig
quad GenConfig
gen''

-- |Regenerate a range of bars within an existing progression.
-- The cue is inferred from the bar before the start position (wrapping).
--
-- FAMILY-AWARE: regeneration always produces uniform states of the family
-- the source progression already is — families never mix.
--
-- * @pcProvenance = Just _@ — strata-aware path: regenerates all three
--   layers + provenance in lockstep, with one-step lookahead at the
--   @e → e+1@ seam to keep the spliced bar sequence walk-graph valid
--   under 'Harmonic.Framework.Builder.Strata.allowedNext'.
-- * uniform 4-note triad layer (gen4 source) — regen bars come out 4-note
--   ('_gcQuad' set automatically).
-- * uniform 3-note (gen source) — plain triad regen.
-- * hand-mixed cardinalities — regenerated as plain triads with a printed
--   notice (hand-mixed material is the human aberration channel; regen
--   does not amplify it).
--
-- @s' <- seek "*" $ entropy 0.3 $ genFrom s 2 3@
-- @s' <- seek "*" $ cue start $ genFrom s 2 3    -- override inferred cue@
-- @s' <- seek "*" $ len 6 $ genFrom s 2 3        -- expand range@
-- @s' <- seek "*" $ genFrom'  s 2 3              -- Standard per-step trace@
-- @s' <- seek "*" $ genFrom'' s 2 3              -- Verbose trace (+ scoreboard with 'attempt')@
genFrom :: PC.ProgressionContext -> Int -> Int -> GenConfig
genFrom :: ProgressionContext -> Int -> Int -> GenConfig
genFrom ProgressionContext
pc Int
s Int
e = GenConfig
defaultGenConfig
  { _gcCue  = inferCue
  , _gcLen  = rSize
  , _gcQuad = sourceIsQuad
  , _gcMode = case PC.pcProvenance pc of
      Just Seq (Tristrata, StrataLabel)
_  -> ProgressionContext -> Int -> Int -> GenMode
FromProgPC ProgressionContext
pc Int
s Int
e
      Maybe (Seq (Tristrata, StrataLabel))
Nothing -> Progression -> Int -> Int -> GenMode
FromProg (ProgressionContext -> Progression
PC.triadLayer ProgressionContext
pc) Int
s Int
e
  }
  where
    triad :: Progression
triad = ProgressionContext -> Progression
PC.triadLayer ProgressionContext
pc
    n :: Int
n = Progression -> Int
Prog.progLength Progression
triad
    rSize :: Int
rSize = if Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
e then Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 else Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
e
    cuePos :: Int
cuePos = ((Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
n) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1  -- 1-indexed, wraps to N when s=1
    inferCue :: IO CadenceState
inferCue = case Progression -> Int -> Maybe CadenceState
Prog.getCadenceState Progression
triad Int
cuePos of
      Just CadenceState
cs -> CadenceState -> IO CadenceState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CadenceState
cs
      Maybe CadenceState
Nothing -> GenConfig -> IO CadenceState
_gcCue GenConfig
defaultGenConfig
    -- Family detection: every bar exactly 4 intervals → gen4 source.
    barSizes :: [Int]
barSizes = [ [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
triad) ]
    sourceIsQuad :: Bool
sourceIsQuad = Bool -> Bool
not ([Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
barSizes) Bool -> Bool -> Bool
&& (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4) [Int]
barSizes

-- |Standard-verbosity alias of 'genFrom'. Mirrors @gen'@, @genP'@ and @genI'@.
genFrom' :: PC.ProgressionContext -> Int -> Int -> GenConfig
genFrom' :: ProgressionContext -> Int -> Int -> GenConfig
genFrom' ProgressionContext
pc Int
s Int
e = (ProgressionContext -> Int -> Int -> GenConfig
genFrom ProgressionContext
pc Int
s Int
e) { _gcVerbosity = Standard }

-- |Verbose-verbosity alias of 'genFrom'. Mirrors @gen''@, @genP''@ and @genI''@.
genFrom'' :: PC.ProgressionContext -> Int -> Int -> GenConfig
genFrom'' :: ProgressionContext -> Int -> Int -> GenConfig
genFrom'' ProgressionContext
pc Int
s Int
e = (ProgressionContext -> Int -> Int -> GenConfig
genFrom ProgressionContext
pc Int
s Int
e) { _gcVerbosity = Verbose }

-------------------------------------------------------------------------------
-- Generation Modifiers
-------------------------------------------------------------------------------

-- |Set starting state.
--
-- @s <- seek "*" $ cue start $ gen@
cue :: H.CadenceState -> GenConfig -> GenConfig
cue :: CadenceState -> GenConfig -> GenConfig
cue CadenceState
start GenConfig
gc = GenConfig
gc { _gcCue = pure start }

-- |Set progression length (number of chords).
--
-- @s <- seek "*" $ len 8 $ gen@
len :: Int -> GenConfig -> GenConfig
len :: Int -> GenConfig -> GenConfig
len Int
n GenConfig
gc = GenConfig
gc { _gcLen = n, _gcLenOverride = Nothing }

-- |Set composer blend and execute. Terminal modifier — produces 'IO'
-- 'PC.ProgressionContext'. For legacy 'gen'-family configs, all three layers
-- duplicate the generated triad progression and @pcProvenance@ is 'Nothing';
-- the 'genP' paradigm produces distinct strata\/mode layers with 'Just'
-- provenance.
--
-- @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.
  case GenConfig -> GenMode
_gcMode GenConfig
gc of
    GenMode
Fresh    -> IO ()
emitCueNotice
    GenMode
GridMode -> IO ()
emitCueNotice
    GenMode
_        -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  let isStrata :: Bool
isStrata = case GenConfig -> GenMode
_gcMode GenConfig
gc of
        StrataMode StrataLabel
_    -> Bool
True
        FromProgPC {}   -> Bool
True
        GenMode
_               -> Bool
False
  case GenConfig -> Verbosity
_gcVerbosity GenConfig
gc of
    Verbosity
Silent   -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Verbosity
Standard -> if Bool
isStrata
                  then Int -> GenerationDiagnostics -> IO ()
printStrataDiagnostics Int
1 GenerationDiagnostics
diag
                  else [Char] -> HarmonicContext -> GenerationDiagnostics -> IO ()
renderStandardSteps (GenConfig -> [Char]
_gcSeek GenConfig
gc) (GenConfig -> HarmonicContext
_gcTonal GenConfig
gc) GenerationDiagnostics
diag
    Verbosity
Verbose  -> if Bool
isStrata
                  then Int -> GenerationDiagnostics -> IO ()
printStrataDiagnostics Int
2 GenerationDiagnostics
diag
                  else [Char] -> GenerationDiagnostics -> IO ()
renderVerboseSteps (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)
  [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
  (ProgressionContext
pc, GenerationDiagnostics
diag) <- GenConfig -> IO (ProgressionContext, GenerationDiagnostics)
singlePassExecPCWithDiag GenConfig
gc
  GenConfig -> (ProgressionContext, GenerationDiagnostics) -> IO ()
emitFinalised GenConfig
gc (ProgressionContext
pc, GenerationDiagnostics
diag)
  ProgressionContext -> IO ProgressionContext
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgressionContext
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
  -- Family separation: gen4 (quad) and the strata family (genP \/
  -- strata-aware genFrom) never mix — strata progressions stay 3-5-7.
  StrataMode StrataLabel
_ | GenConfig -> Bool
_gcQuad GenConfig
gc ->
    [Char] -> IO (ProgressionContext, GenerationDiagnostics)
forall a. HasCallStack => [Char] -> a
error [Char]
"quad/gen4 applies to the gen family only — genP (strata) stays 3-5-7"
  FromProgPC {} | GenConfig -> Bool
_gcQuad GenConfig
gc ->
    [Char] -> IO (ProgressionContext, GenerationDiagnostics)
forall a. HasCallStack => [Char] -> a
error [Char]
"quad/gen4 applies to the gen family only — this source is strata-aware (genP provenance); regenerate it with plain genFrom (family is inferred from the source)"
  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
_                    -> do
    (Progression
prog, GenerationDiagnostics
diag) <- GenConfig -> IO (Progression, GenerationDiagnostics)
execGenConfigWithDiag GenConfig
gc
    (ProgressionContext, GenerationDiagnostics)
-> IO (ProgressionContext, GenerationDiagnostics)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Progression -> ProgressionContext
PC.fromProgression Progression
prog, GenerationDiagnostics
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
-- 'Bolt.Pipe' 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
gc = 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 .."
  let online :: Bool
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"
  (ProgressionContext
winnerPC, GenerationDiagnostics
winnerDiag, [AttemptDiagnostic]
diags) <-
    if Bool
online then GenConfig
-> IO
     (ProgressionContext, GenerationDiagnostics, [AttemptDiagnostic])
runOnline GenConfig
gc else GenConfig
-> IO
     (ProgressionContext, GenerationDiagnostics, [AttemptDiagnostic])
runOffline GenConfig
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.
  GenConfig -> (ProgressionContext, GenerationDiagnostics) -> IO ()
emitFinalised GenConfig
gc (ProgressionContext
winnerPC, GenerationDiagnostics
winnerDiag)
  -- Verbose + multi-attempt: surface the full scoreboard.
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GenConfig -> Verbosity
_gcVerbosity GenConfig
gc Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
Verbose 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
$
    Double -> [AttemptDiagnostic] -> IO ()
printAttemptScoreboard (GenConfig -> Double
_gcViabilityFloor GenConfig
gc) [AttemptDiagnostic]
diags
  ProgressionContext -> IO ProgressionContext
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgressionContext
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
  [ScoredAttempt]
scored <- GenConfig -> Int -> Int -> Double -> IO [ScoredAttempt]
offlineLoop GenConfig
gc Int
maxN Int
target Double
floorT
  GenConfig
-> [ScoredAttempt]
-> IO
     (ProgressionContext, GenerationDiagnostics, [AttemptDiagnostic])
finaliseScored GenConfig
gc [ScoredAttempt]
scored

-- |Online arm of @generateBest@. Opens one 'Bolt.Pipe' for the entire
-- K-attempt loop; scores each attempt via 'PS.scoreProgressionOnline'
-- using @_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
pipe <- IO Pipe
connectNeo4j
  [ScoredAttempt]
scored <- Pipe -> BoltActionT IO [ScoredAttempt] -> IO [ScoredAttempt]
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
Pipe -> BoltActionT m a -> m a
Bolt.run Pipe
pipe (Text
-> GenConfig
-> Int
-> Int
-> Double
-> BoltActionT IO [ScoredAttempt]
onlineLoop Text
seekTxt GenConfig
gc Int
maxN Int
target Double
floorT)
  Pipe -> IO ()
forall (m :: * -> *). (MonadIO m, HasCallStack) => Pipe -> m ()
Bolt.close Pipe
pipe
  GenConfig
-> [ScoredAttempt]
-> IO
     (ProgressionContext, GenerationDiagnostics, [AttemptDiagnostic])
finaliseScored GenConfig
gc [ScoredAttempt]
scored

-- |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)

-- |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
          (ProgressionContext
pc, GenerationDiagnostics
diag) <- GenConfig -> IO (ProgressionContext, GenerationDiagnostics)
singlePassExecPCWithDiag GenConfig
gc
          let ps :: ProgressionScore
ps    = ProgressionContext -> ProgressionScore
PS.scoreProgression ProgressionContext
pc
              tot :: Double
tot   = ProgressionScoreWeights -> ProgressionScore -> Double
PS.totalScore ProgressionScoreWeights
PS.defaultWeightsOffline ProgressionScore
ps
              isOk :: Bool
isOk  = ProgressionScore -> Double
PS.psModeValidity ProgressionScore
ps Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
1.0 Bool -> Bool -> Bool
&& Double
tot Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
floorT
              acc' :: [ScoredAttempt]
acc'  = (ProgressionContext
pc, ProgressionScore
ps, Double
tot, Bool
isOk, GenerationDiagnostics
diag) ScoredAttempt -> [ScoredAttempt] -> [ScoredAttempt]
forall a. a -> [a] -> [a]
: [ScoredAttempt]
acc
              viable' :: Int
viable' = if Bool
isOk then Int
viableSoFar Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 else Int
viableSoFar
          Int -> [ScoredAttempt] -> t -> IO [ScoredAttempt]
go Int
viable' [ScoredAttempt]
acc' (t
remaining t -> t -> t
forall a. Num a => a -> a -> a
- t
1)

-- |Inner loop for the online arm, run under 'Bolt.run pipe'.
onlineLoop
  :: T.Text               -- ^ seek string (composer blend)
  -> GenConfig            -- ^ caller's config (printing already lifted out)
  -> Int                  -- ^ maxAttempts
  -> Int                  -- ^ viableTarget
  -> Double               -- ^ viabilityFloor
  -> Bolt.BoltActionT IO [ScoredAttempt]
onlineLoop :: Text
-> GenConfig
-> Int
-> Int
-> Double
-> BoltActionT IO [ScoredAttempt]
onlineLoop Text
seekTxt GenConfig
gc Int
maxN Int
target Double
floorT = Int -> [ScoredAttempt] -> Int -> BoltActionT IO [ScoredAttempt]
forall {t}.
(Eq t, Num t) =>
Int -> [ScoredAttempt] -> t -> BoltActionT IO [ScoredAttempt]
go Int
0 [] Int
maxN
  where
    go :: Int -> [ScoredAttempt] -> t -> BoltActionT IO [ScoredAttempt]
go Int
_ [ScoredAttempt]
acc t
0 = [ScoredAttempt] -> BoltActionT IO [ScoredAttempt]
forall a. a -> BoltActionT 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] -> BoltActionT IO [ScoredAttempt]
forall a. a -> BoltActionT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ScoredAttempt] -> [ScoredAttempt]
forall a. [a] -> [a]
reverse [ScoredAttempt]
acc)
      | Bool
otherwise = do
          (ProgressionContext
pc, GenerationDiagnostics
diag) <- IO (ProgressionContext, GenerationDiagnostics)
-> BoltActionT IO (ProgressionContext, GenerationDiagnostics)
forall a. IO a -> BoltActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (GenConfig -> IO (ProgressionContext, GenerationDiagnostics)
singlePassExecPCWithDiag GenConfig
gc)
          ProgressionScore
ps <- Text -> ProgressionContext -> BoltActionT IO ProgressionScore
PS.scoreProgressionOnline Text
seekTxt ProgressionContext
pc
          let tot :: Double
tot   = ProgressionScoreWeights -> ProgressionScore -> Double
PS.totalScore ProgressionScoreWeights
PS.defaultWeights ProgressionScore
ps
              isOk :: Bool
isOk  = ProgressionScore -> Double
PS.psModeValidity ProgressionScore
ps Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
1.0 Bool -> Bool -> Bool
&& Double
tot Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
floorT
              acc' :: [ScoredAttempt]
acc'  = (ProgressionContext
pc, ProgressionScore
ps, Double
tot, Bool
isOk, GenerationDiagnostics
diag) ScoredAttempt -> [ScoredAttempt] -> [ScoredAttempt]
forall a. a -> [a] -> [a]
: [ScoredAttempt]
acc
              viable' :: Int
viable' = if Bool
isOk then Int
viableSoFar Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 else Int
viableSoFar
          Int -> [ScoredAttempt] -> t -> BoltActionT IO [ScoredAttempt]
go Int
viable' [ScoredAttempt]
acc' (t
remaining t -> t -> t
forall a. Num a => a -> a -> a
- t
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
    (ProgressionContext
pc, GenerationDiagnostics
diag) <- GenConfig -> IO (ProgressionContext, GenerationDiagnostics)
singlePassExecPCWithDiag GenConfig
gc
    (ProgressionContext, GenerationDiagnostics, [AttemptDiagnostic])
-> IO
     (ProgressionContext, GenerationDiagnostics, [AttemptDiagnostic])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProgressionContext
pc, GenerationDiagnostics
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
        (Int
winnerIdx, (ProgressionContext
winnerPC, ProgressionScore
_, Double
_, Bool
_, GenerationDiagnostics
winnerDiag)) =
          ((Int, ScoredAttempt) -> Double)
-> [(Int, ScoredAttempt)] -> (Int, ScoredAttempt)
forall b a. Ord b => (a -> b) -> [a] -> a
maximumByKey (\(Int
_, (ProgressionContext
_, ProgressionScore
_, Double
tot, Bool
_, GenerationDiagnostics
_)) -> 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
                    , adChords :: [[Char]]
adChords = Progression -> [[Char]]
chordNamesOf (ProgressionContext -> Progression
PC.triadLayer ProgressionContext
pc)
                    }
                | (Int
i, (ProgressionContext
pc, ProgressionScore
ps, Double
tot, Bool
ok, GenerationDiagnostics
_)) <- [(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

-- |Set entropy in [0, 1] — mapped affinely to the gamma sampler's shape
-- (@shape = 1 + entropy * 9@). Higher values = more unusual choices.
--
-- @s <- seek "*" $ entropy 0.5 $ gen@
entropy :: Double -> GenConfig -> GenConfig
entropy :: Double -> GenConfig -> GenConfig
entropy Double
e GenConfig
gc = GenConfig
gc { _gcEntropy = e }

-- |Run multi-attempt rank-and-select generation: produce up to @maxAttempts@
-- candidate progressions, stop early once @viableTarget@ viable attempts
-- (all bars 'Harmonic.Rules.Types.Scale.ModeOk') have been collected, then return the highest-scoring
-- one. Scoring blends root motion, voice leading, and mode validity via
-- 'PS.defaultWeightsOffline'.
--
-- @s <- seek "*" $ attempt 3 24 $ entropy 0.4 $ gen@   -- best of up to 24
--
-- Defaults are @attempt 1 1@ — i.e. the modifier is a no-op when omitted,
-- preserving legacy single-pass behaviour.
attempt :: Int -> Int -> GenConfig -> GenConfig
attempt :: Int -> Int -> GenConfig -> GenConfig
attempt Int
viableTarget Int
maxAttempts GenConfig
gc = GenConfig
gc
  { _gcViableTarget = max 1 viableTarget
  , _gcMaxAttempts  = max 1 maxAttempts
  }

-- |Set the viability quality floor used by 'attempt'. An attempt is
-- /viable/ iff @psModeValidity >= 1.0@ (structural invariant) and
-- @totalScore >= floor@. Default is @0.5@; passing @0.0@ recovers the
-- original structural-only viability.
--
-- @s <- seek "*" $ viability 0.65 $ attempt 3 24 $ gen@
--
-- Tune downward if @attempt N K@ frequently fails to collect N viable
-- within K (raise K or lower the floor); tune upward if K is being hit
-- consistently with mediocre-quality picks (lower K or raise the floor).
viability :: Double -> GenConfig -> GenConfig
viability :: Double -> GenConfig -> GenConfig
viability Double
t GenConfig
gc = GenConfig
gc { _gcViabilityFloor = max 0 t }

-- |Set harmonic context (R constraints).
--
-- @s <- seek "*" $ tonal (hcKey "0#" $ hContext) $ gen@
tonal :: HarmonicContext -> GenConfig -> GenConfig
tonal :: HarmonicContext -> GenConfig -> GenConfig
tonal HarmonicContext
ctx GenConfig
gc = GenConfig
gc { _gcTonal = ctx }

-- |Per-bar position within the dynamically-changing active tristrata. Elements
-- @∈ {1,2,3}@ cycle circularly. Sets '_gcLenOverride' to the parsed list length
-- so '_gcLen' doesn't need to be set explicitly; 'len' applied later clears the
-- override (last-writer-wins).
--
-- @s <- seek "none" $ relStrata "1 1 2 2 3 3" $ genVI@  -- 6 bars
relStrata :: String -> GenConfig -> GenConfig
relStrata :: [Char] -> GenConfig -> GenConfig
relStrata [Char]
s GenConfig
gc =
  let ns :: [Int]
ns = [Char] -> [Int]
Sc.parseRelStrata [Char]
s
  in GenConfig
gc { _gcRelStrata = Just ns
        , _gcLenOverride = if null ns then Nothing else Just (length ns)
        }

-- |Per-bar absolute strata label across all tristratas. Elements are Roman
-- numerals @I..XI@ cycling circularly. Sets '_gcLenOverride' to the parsed
-- list length.
--
-- @s <- seek "none" $ absStrata "I V X" $ genI@  -- 3 bars
absStrata :: String -> GenConfig -> GenConfig
absStrata :: [Char] -> GenConfig -> GenConfig
absStrata [Char]
s GenConfig
gc =
  let ss :: [StrataLabel]
ss = [Char] -> [StrataLabel]
Sc.parseAbsStrata [Char]
s
  in GenConfig
gc { _gcAbsStrata = Just ss
        , _gcLenOverride = if null ss then Nothing else Just (length ss)
        }

-- |Override the same-strata continuity boost multiplier. Values below 1.0
-- favour candidates whose strata matches the previous bar's. Default 0.90.
-- Pass 1.0 to disable the bias.
--
-- @s <- seek "none" $ sameBoost 0.5 $ genVI@  -- strong same-strata pull
sameBoost :: Double -> GenConfig -> GenConfig
sameBoost :: Double -> GenConfig -> GenConfig
sameBoost Double
x GenConfig
gc = GenConfig
gc { _gcBoostSame = x }

-- |Override the flip-flop boost multiplier (candidates matching the
-- grandparent strata when the current /= previous). Default 0.80.
flipBoost :: Double -> GenConfig -> GenConfig
flipBoost :: Double -> GenConfig -> GenConfig
flipBoost Double
x GenConfig
gc = GenConfig
gc { _gcBoostFlip = x }

-- |Override the same-tristrata continuity boost multiplier. Values below
-- 1.0 favour candidates whose active tristrata matches the previous bar's.
-- Default 0.70 (strongest of the three).
triBoost :: Double -> GenConfig -> GenConfig
triBoost :: Double -> GenConfig -> GenConfig
triBoost Double
x GenConfig
gc = GenConfig
gc { _gcBoostTri = x }

-------------------------------------------------------------------------------
-- genP Paradigm (strata-first traversal)
-------------------------------------------------------------------------------

-- |Strata-first generation entrypoint. Seeded by a 'Sc.StrataLabel'; produces
-- a 'PC.ProgressionContext' with distinct triad, strata, and mode layers and
-- @pcProvenance = Just …@.
--
-- @s <- seek "none" $ cue start $ len 6 $ genP VI@
genP :: Sc.StrataLabel -> GenConfig
genP :: StrataLabel -> GenConfig
genP StrataLabel
s = GenConfig
defaultGenConfig { _gcMode = StrataMode s }

-- |Standard-verbosity variant of 'genP'.
genP' :: Sc.StrataLabel -> GenConfig
genP' :: StrataLabel -> GenConfig
genP' StrataLabel
s = (StrataLabel -> GenConfig
genP StrataLabel
s) { _gcVerbosity = Standard }

-- |Verbose-verbosity variant of 'genP'.
genP'' :: Sc.StrataLabel -> GenConfig
genP'' :: StrataLabel -> GenConfig
genP'' StrataLabel
s = (StrataLabel -> GenConfig
genP StrataLabel
s) { _gcVerbosity = Verbose }

-- | Silent-verbosity 'genP' aliases, one per Roman numeral — @genI@ pins the
-- starting tristrata to @I@, @genII@ to @II@, and so on through @genXI@.
--
-- @s \<- seek \"*\" $ attempt 3 12 $ entropy 0.4 $ genI@
--
-- Three verbosities throughout, by the usual prime convention: @genI@ silent,
-- @genI'@ standard, @genI''@ verbose.
genI, genII, genIII, genIV, genV, genVI, genVII, genVIII, genIX, genX, genXI :: GenConfig
genI :: GenConfig
genI     = StrataLabel -> GenConfig
genP StrataLabel
Sc.I
genII :: GenConfig
genII    = StrataLabel -> GenConfig
genP StrataLabel
Sc.II
genIII :: GenConfig
genIII   = StrataLabel -> GenConfig
genP StrataLabel
Sc.III
genIV :: GenConfig
genIV    = StrataLabel -> GenConfig
genP StrataLabel
Sc.IV
genV :: GenConfig
genV     = StrataLabel -> GenConfig
genP StrataLabel
Sc.V
genVI :: GenConfig
genVI    = StrataLabel -> GenConfig
genP StrataLabel
Sc.VI
genVII :: GenConfig
genVII   = StrataLabel -> GenConfig
genP StrataLabel
Sc.VII
genVIII :: GenConfig
genVIII  = StrataLabel -> GenConfig
genP StrataLabel
Sc.VIII
genIX :: GenConfig
genIX    = StrataLabel -> GenConfig
genP StrataLabel
Sc.IX
genX :: GenConfig
genX     = StrataLabel -> GenConfig
genP StrataLabel
Sc.X
genXI :: GenConfig
genXI    = StrataLabel -> GenConfig
genP StrataLabel
Sc.XI

-- | Standard-verbosity Roman numeral aliases: per-step musical context plus
-- the grid. See 'genI'.
genI', genII', genIII', genIV', genV', genVI', genVII', genVIII', genIX', genX', genXI' :: GenConfig
genI' :: GenConfig
genI'    = StrataLabel -> GenConfig
genP' StrataLabel
Sc.I
genII' :: GenConfig
genII'   = StrataLabel -> GenConfig
genP' StrataLabel
Sc.II
genIII' :: GenConfig
genIII'  = StrataLabel -> GenConfig
genP' StrataLabel
Sc.III
genIV' :: GenConfig
genIV'   = StrataLabel -> GenConfig
genP' StrataLabel
Sc.IV
genV' :: GenConfig
genV'    = StrataLabel -> GenConfig
genP' StrataLabel
Sc.V
genVI' :: GenConfig
genVI'   = StrataLabel -> GenConfig
genP' StrataLabel
Sc.VI
genVII' :: GenConfig
genVII'  = StrataLabel -> GenConfig
genP' StrataLabel
Sc.VII
genVIII' :: GenConfig
genVIII' = StrataLabel -> GenConfig
genP' StrataLabel
Sc.VIII
genIX' :: GenConfig
genIX'   = StrataLabel -> GenConfig
genP' StrataLabel
Sc.IX
genX' :: GenConfig
genX'    = StrataLabel -> GenConfig
genP' StrataLabel
Sc.X
genXI' :: GenConfig
genXI'   = StrataLabel -> GenConfig
genP' StrataLabel
Sc.XI

-- | Verbose-verbosity Roman numeral aliases: full traces, the grid, and the
-- multi-attempt scoreboard when paired with @attempt@. See 'genI'.
genI'', genII'', genIII'', genIV'', genV'', genVI'', genVII'', genVIII'', genIX'', genX'', genXI'' :: GenConfig
genI'' :: GenConfig
genI''    = StrataLabel -> GenConfig
genP'' StrataLabel
Sc.I
genII'' :: GenConfig
genII''   = StrataLabel -> GenConfig
genP'' StrataLabel
Sc.II
genIII'' :: GenConfig
genIII''  = StrataLabel -> GenConfig
genP'' StrataLabel
Sc.III
genIV'' :: GenConfig
genIV''   = StrataLabel -> GenConfig
genP'' StrataLabel
Sc.IV
genV'' :: GenConfig
genV''    = StrataLabel -> GenConfig
genP'' StrataLabel
Sc.V
genVI'' :: GenConfig
genVI''   = StrataLabel -> GenConfig
genP'' StrataLabel
Sc.VI
genVII'' :: GenConfig
genVII''  = StrataLabel -> GenConfig
genP'' StrataLabel
Sc.VII
genVIII'' :: GenConfig
genVIII'' = StrataLabel -> GenConfig
genP'' StrataLabel
Sc.VIII
genIX'' :: GenConfig
genIX''   = StrataLabel -> GenConfig
genP'' StrataLabel
Sc.IX
genX'' :: GenConfig
genX''    = StrataLabel -> GenConfig
genP'' StrataLabel
Sc.X
genXI'' :: GenConfig
genXI''   = StrataLabel -> GenConfig
genP'' StrataLabel
Sc.XI

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

-- |Walk the (strata, tristrata) sequence for a 'StrataMode' run and build a
-- 'PC.ProgressionContext' with distinct triad\/strata\/mode layers.
--
-- The triad layer is generated by the full R→E→T pipeline: at each bar, the
-- active context's '_hcOvertones' is narrowed to the current strata's 5-PC
-- chroma (prime-notation), 'parseContextOnce' is rerun, and @stepChainBody@
-- is invoked with a 'pcSoftBoost' multiplier computed from strata \/
-- tristrata continuity against prior bars. Graph candidates (Neo4j) and
-- consonance-fallback candidates both flow through the usual filter →
-- score → gamma-select pipeline, with the soft-boost applied to @badness@
-- at @computeFallbackScoreWithBoost@ (fallback) and inversely to
-- confidence in @scoreByConfidence@-output (graph). Single-strata
-- containment is guaranteed by construction: the narrowed overtone set
-- precludes any triad whose chroma escapes @s_i@.
--
-- Strata and mode layer bars are representative 3-PC slices of
-- 'strataChroma s_i' and 'modeChroma m_i' respectively, rooted on the
-- generated triad's root so they transpose with the progression.
runStrataGen :: Sc.StrataLabel -> GenConfig -> IO (PC.ProgressionContext, GenerationDiagnostics)
runStrataGen :: StrataLabel
-> GenConfig -> IO (ProgressionContext, GenerationDiagnostics)
runStrataGen StrataLabel
sStart GenConfig
gc = do
  CadenceState
start <- GenConfig -> IO CadenceState
_gcCue GenConfig
gc
  Gen RealWorld
rng   <- IO (Gen RealWorld)
IO GenIO
createSystemRandom
  let basePctx :: ParsedContext
basePctx = HarmonicContext -> ParsedContext
parseContextOnce (GenConfig -> HarmonicContext
_gcTonal GenConfig
gc)
      allowed :: [Tristrata]
allowed  = ParsedContext -> [Tristrata]
pcAllowedTristrata ParsedContext
basePctx
      allowed' :: [Tristrata]
allowed' = if [Tristrata] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Tristrata]
allowed then [Tristrata]
Sc.validTristrata else [Tristrata]
allowed
      n :: Int
n        = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (GenConfig -> Int
_gcLen GenConfig
gc) (GenConfig -> Maybe Int
_gcLenOverride GenConfig
gc))
      (StrataLabel
s0, Tristrata
t0) = [Tristrata] -> StrataLabel -> (StrataLabel, Tristrata)
Strata.initialPlacement [Tristrata]
allowed' StrataLabel
sStart

      -- relStrata \/ absStrata narrowing on the walk's candidate pool.
      narrow :: Int -> [(Sc.StrataLabel, Sc.Tristrata)] -> [(Sc.StrataLabel, Sc.Tristrata)]
      narrow :: Int -> [(StrataLabel, Tristrata)] -> [(StrataLabel, Tristrata)]
narrow Int
i [(StrataLabel, Tristrata)]
pool =
        let pool1 :: [(StrataLabel, Tristrata)]
pool1 = case GenConfig -> Maybe [Int]
_gcRelStrata GenConfig
gc of
              Just [Int]
ps | Bool -> Bool
not ([Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
ps) ->
                let p :: Int
p = [Int]
ps [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
ps)
                in [(StrataLabel
s',Tristrata
t') | (StrataLabel
s',Tristrata
t') <- [(StrataLabel, Tristrata)]
pool, Tristrata -> Int -> StrataLabel
Sc.tristrataStrataAt Tristrata
t' Int
p StrataLabel -> StrataLabel -> Bool
forall a. Eq a => a -> a -> Bool
== StrataLabel
s']
              Maybe [Int]
_ -> [(StrataLabel, Tristrata)]
pool
            pool2 :: [(StrataLabel, Tristrata)]
pool2 = case GenConfig -> Maybe [StrataLabel]
_gcAbsStrata GenConfig
gc of
              Just [StrataLabel]
ss | Bool -> Bool
not ([StrataLabel] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StrataLabel]
ss) ->
                let s :: StrataLabel
s = [StrataLabel]
ss [StrataLabel] -> Int -> StrataLabel
forall a. HasCallStack => [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` [StrataLabel] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StrataLabel]
ss)
                in [(StrataLabel
s',Tristrata
t') | (StrataLabel
s',Tristrata
t') <- [(StrataLabel, Tristrata)]
pool1, StrataLabel
s' StrataLabel -> StrataLabel -> Bool
forall a. Eq a => a -> a -> Bool
== StrataLabel
s]
              Maybe [StrataLabel]
_ -> [(StrataLabel, Tristrata)]
pool1
        in [(StrataLabel, Tristrata)]
pool2

  -- Sample one random seed per transition bar. Used by 'selectNextSeeded'
  -- to escape the pathological same-strata fixed point of the purely
  -- categorical 'selectNext'. 'n - 1' seeds cover bars 1..n-1; bar 0 is
  -- set by 'Harmonic.Framework.Builder.Strata.initialPlacement'.
  [Int]
walkSeeds <- (Int -> IO Int) -> [Int] -> IO [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (IO Int -> Int -> IO Int
forall a b. a -> b -> a
const ((Int, Int) -> Gen RealWorld -> IO Int
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *). StatefulGen g m => (Int, Int) -> g -> m Int
uniformRM (Int
forall a. Bounded a => a
minBound :: Int, Int
forall a. Bounded a => a
maxBound :: Int) Gen RealWorld
rng))
                    [Int
1 .. Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)]

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

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

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

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

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

      -- Cue validation: the starting CadenceState's absolute PCs must all
      -- be members of the starting strata's chroma. If the cue escapes
      -- the strata, abort with a helpful message listing viable triads.
      startAbsPCs :: [Int]
startAbsPCs =
        let rpc :: Int
rpc = PitchClass -> Int
P.unPitchClass (NoteName -> PitchClass
P.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
start))
            ivs :: [Int]
ivs = (PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
P.unPitchClass (Cadence -> [PitchClass]
H.cadenceIntervals (CadenceState -> Cadence
H.stateCadence CadenceState
start))
        in [ (Int
iv Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rpc) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12 | Int
iv <- [Int]
ivs ]
      s0PCs :: [Int]
s0PCs      = (PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
P.unPitchClass (StrataLabel -> [PitchClass]
Sc.strataChroma StrataLabel
s0)
      cueValid :: Bool
cueValid   = (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
s0PCs) [Int]
startAbsPCs

  if Bool -> Bool
not Bool
cueValid
    then do
      CadenceState -> StrataLabel -> IO ()
printInvalidCueError CadenceState
start StrataLabel
s0
      let emptyPC :: ProgressionContext
emptyPC = PC.ProgressionContext
            { triadLayer :: Progression
PC.triadLayer   = Progression
forall a. Monoid a => a
mempty
            , strataLayer :: Progression
PC.strataLayer  = Progression
forall a. Monoid a => a
mempty
            , modeLayer :: Progression
PC.modeLayer    = Progression
forall a. Monoid a => a
mempty
            , pcProvenance :: Maybe (Seq (Tristrata, StrataLabel))
PC.pcProvenance = Seq (Tristrata, StrataLabel)
-> Maybe (Seq (Tristrata, StrataLabel))
forall a. a -> Maybe a
Just Seq (Tristrata, StrataLabel)
forall a. Seq a
Seq.empty
            }
          emptyDiag :: GenerationDiagnostics
emptyDiag = GenerationDiagnostics
            { gdStartCadence :: [Char]
gdStartCadence = Cadence -> [Char]
forall a. Show a => a -> [Char]
show (CadenceState -> Cadence
H.stateCadence CadenceState
start)
            , gdStartRoot :: [Char]
gdStartRoot    = NoteName -> [Char]
forall a. Show a => a -> [Char]
show (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
start)
            , gdRequestedLen :: Int
gdRequestedLen = Int
n
            , gdActualLen :: Int
gdActualLen    = Int
0
            , gdEntropy :: Double
gdEntropy      = GenConfig -> Double
_gcEntropy GenConfig
gc
            , gdSteps :: [StepDiagnostic]
gdSteps        = []
            , gdProgression :: Progression
gdProgression  = Progression
forall a. Monoid a => a
mempty
            }
      (ProgressionContext, GenerationDiagnostics)
-> IO (ProgressionContext, GenerationDiagnostics)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProgressionContext
emptyPC, GenerationDiagnostics
emptyDiag)
    else StrataLabel
-> GenConfig
-> CadenceState
-> GenIO
-> StrataLabel
-> Tristrata
-> [(StrataLabel, Tristrata)]
-> (Int -> ParsedContext)
-> (Int -> Double)
-> Int
-> IO (ProgressionContext, GenerationDiagnostics)
runStrataGenBody StrataLabel
sStart GenConfig
gc CadenceState
start Gen RealWorld
GenIO
rng StrataLabel
s0 Tristrata
t0 [(StrataLabel, Tristrata)]
barSeq Int -> ParsedContext
pctxAt Int -> Double
boostFor Int
n

-- |Body of 'runStrataGen' after cue validation has passed. Separated so
-- the cue-invalid path can abort cleanly without wiring through the
-- full chain-building machinery.
runStrataGenBody
  :: Sc.StrataLabel
  -> GenConfig
  -> H.CadenceState
  -> GenIO
  -> Sc.StrataLabel
  -> Sc.Tristrata
  -> [(Sc.StrataLabel, Sc.Tristrata)]
  -> (Int -> ParsedContext)
  -> (Int -> Double)
  -> Int
  -> IO (PC.ProgressionContext, GenerationDiagnostics)
runStrataGenBody :: StrataLabel
-> GenConfig
-> CadenceState
-> GenIO
-> StrataLabel
-> Tristrata
-> [(StrataLabel, Tristrata)]
-> (Int -> ParsedContext)
-> (Int -> Double)
-> Int
-> IO (ProgressionContext, GenerationDiagnostics)
runStrataGenBody StrataLabel
_sStart GenConfig
gc CadenceState
start GenIO
rng StrataLabel
_s0 Tristrata
_t0 [(StrataLabel, Tristrata)]
barSeq Int -> ParsedContext
pctxAt Int -> Double
boostFor Int
n = do
  -- Keep the cue as bar 1 (matching 'gen' semantics). Generate n-1 more
  -- bars. Chain has n elements: [cue, gen_1, ..., gen_{n-1}]. Step i of
  -- generation produces chain[i] using barSeq[i]'s strata context.
  let pctxAtStep :: Int -> ParsedContext
      pctxAtStep :: Int -> ParsedContext
pctxAtStep = Int -> ParsedContext
pctxAt
      -- Verbosity: Silent → no diagnostics, Standard → Just 1, Verbose → Just 2.
      verbArg :: Maybe Int
verbArg = case GenConfig -> Verbosity
_gcVerbosity GenConfig
gc of
        Verbosity
Silent   -> Maybe Int
forall a. Maybe a
Nothing
        Verbosity
Standard -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
        Verbosity
Verbose  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2
  ([CadenceState]
chain, [StepDiagnostic]
rawDiags) <-
    if (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"
      then GeneratorConfig
-> GenIO
-> Maybe Int
-> Double
-> HarmonicContext
-> (Int -> ParsedContext)
-> CadenceState
-> Int
-> IO ([CadenceState], [StepDiagnostic])
buildStrataChainOffline GeneratorConfig
defaultConfig GenIO
rng Maybe Int
verbArg
             (GenConfig -> Double
_gcEntropy GenConfig
gc) (GenConfig -> HarmonicContext
_gcTonal GenConfig
gc) Int -> ParsedContext
pctxAtStep CadenceState
start (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
      else do
        let composerWeights :: ComposerWeights
composerWeights = Text -> ComposerWeights
Q.parseComposerWeights ([Char] -> Text
T.pack (GenConfig -> [Char]
_gcSeek GenConfig
gc))
        Pipe
pipe <- IO Pipe
connectNeo4j
        ([CadenceState], [StepDiagnostic])
result <- Pipe
-> BoltActionT IO ([CadenceState], [StepDiagnostic])
-> IO ([CadenceState], [StepDiagnostic])
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
Pipe -> BoltActionT m a -> m a
Bolt.run Pipe
pipe (BoltActionT IO ([CadenceState], [StepDiagnostic])
 -> IO ([CadenceState], [StepDiagnostic]))
-> BoltActionT IO ([CadenceState], [StepDiagnostic])
-> IO ([CadenceState], [StepDiagnostic])
forall a b. (a -> b) -> a -> b
$ GeneratorConfig
-> GenIO
-> Maybe Int
-> Double
-> HarmonicContext
-> (Int -> ParsedContext)
-> ComposerWeights
-> CadenceState
-> Int
-> BoltActionT IO ([CadenceState], [StepDiagnostic])
buildStrataChain GeneratorConfig
defaultConfig GenIO
rng Maybe Int
verbArg
                   (GenConfig -> Double
_gcEntropy GenConfig
gc) (GenConfig -> HarmonicContext
_gcTonal GenConfig
gc) Int -> ParsedContext
pctxAtStep ComposerWeights
composerWeights CadenceState
start (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
        Pipe -> IO ()
forall (m :: * -> *). (MonadIO m, HasCallStack) => Pipe -> m ()
Bolt.close Pipe
pipe
        ([CadenceState], [StepDiagnostic])
-> IO ([CadenceState], [StepDiagnostic])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CadenceState], [StepDiagnostic])
result

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  [Int]
walkSeeds <- (Int -> IO Int) -> [Int] -> IO [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (IO Int -> Int -> IO Int
forall a b. a -> b -> a
const ((Int, Int) -> Gen RealWorld -> IO Int
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *). StatefulGen g m => (Int, Int) -> g -> m Int
uniformRM (Int
forall a. Bounded a => a
minBound :: Int, Int
forall a. Bounded a => a
maxBound :: Int) Gen RealWorld
rng))
                    [Int
1 .. Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
rSize]

  let -- Walk rSize bars seeded at (s_seed, t_seed). The final bar's pool is
      -- filtered to predecessors of the target (s_target, t_target) so the
      -- spliced sequence retains allowedNext-adjacency at the e→e+1 seam.
      -- If the filter empties the pool, fall back to the unfiltered pool.
      walkRange :: Int -> [Int] -> (Sc.StrataLabel, Sc.Tristrata) -> [(Sc.StrataLabel, Sc.Tristrata)]
      walkRange :: Int
-> [Int] -> (StrataLabel, Tristrata) -> [(StrataLabel, Tristrata)]
walkRange Int
i [Int]
seeds (StrataLabel, Tristrata)
prev
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
rSize = []
        | Bool
otherwise =
            let rawCands :: [(StrataLabel, Tristrata)]
rawCands = Int -> [(StrataLabel, Tristrata)] -> [(StrataLabel, Tristrata)]
narrow Int
i ([Tristrata]
-> (StrataLabel, Tristrata) -> [(StrataLabel, Tristrata)]
Strata.allowedNext [Tristrata]
allowed' (StrataLabel, Tristrata)
prev)
                isFinal :: Bool
isFinal  = Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
rSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                filtered :: [(StrataLabel, Tristrata)]
filtered =
                  if Bool
isFinal
                    then ((StrataLabel, Tristrata) -> Bool)
-> [(StrataLabel, Tristrata)] -> [(StrataLabel, Tristrata)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(StrataLabel, Tristrata)
p -> (StrataLabel
s_target, Tristrata
t_target)
                                       (StrataLabel, Tristrata) -> [(StrataLabel, Tristrata)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Tristrata]
-> (StrataLabel, Tristrata) -> [(StrataLabel, Tristrata)]
Strata.allowedNext [Tristrata]
allowed' (StrataLabel, Tristrata)
p)
                                [(StrataLabel, Tristrata)]
rawCands
                    else [(StrataLabel, Tristrata)]
rawCands
                cands :: [(StrataLabel, Tristrata)]
cands     = if Bool
isFinal Bool -> Bool -> Bool
&& [(StrataLabel, Tristrata)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(StrataLabel, Tristrata)]
filtered then [(StrataLabel, Tristrata)]
rawCands else [(StrataLabel, Tristrata)]
filtered
                (Int
seed, [Int]
seedsRest) = case [Int]
seeds of
                  (Int
sd : [Int]
rest) -> (Int
sd, [Int]
rest)
                  []          -> (Int
0, [])
                chosen :: (StrataLabel, Tristrata)
chosen    = (StrataLabel, Tristrata)
-> Maybe (StrataLabel, Tristrata) -> (StrataLabel, Tristrata)
forall a. a -> Maybe a -> a
fromMaybe (StrataLabel, Tristrata)
prev (Int
-> (StrataLabel, Tristrata)
-> [(StrataLabel, Tristrata)]
-> Maybe (StrataLabel, Tristrata)
Strata.selectNextSeeded Int
seed (StrataLabel, Tristrata)
prev [(StrataLabel, Tristrata)]
cands)
            in (StrataLabel, Tristrata)
chosen (StrataLabel, Tristrata)
-> [(StrataLabel, Tristrata)] -> [(StrataLabel, Tristrata)]
forall a. a -> [a] -> [a]
: Int
-> [Int] -> (StrataLabel, Tristrata) -> [(StrataLabel, Tristrata)]
walkRange (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Int]
seedsRest (StrataLabel, Tristrata)
chosen

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

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

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

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

  -- Reuse runStrataGenBody for chain construction. Result has regenN bars
  -- across all layers: index 0 = the seed (cue) bar, indices 1..rSize =
  -- the regenerated bars.
  (ProgressionContext
regenPC, GenerationDiagnostics
regenDiag) <- StrataLabel
-> GenConfig
-> CadenceState
-> GenIO
-> StrataLabel
-> Tristrata
-> [(StrataLabel, Tristrata)]
-> (Int -> ParsedContext)
-> (Int -> Double)
-> Int
-> IO (ProgressionContext, GenerationDiagnostics)
runStrataGenBody StrataLabel
s_seed GenConfig
gc CadenceState
cueCS Gen RealWorld
GenIO
rng StrataLabel
s_seed Tristrata
t_seed
                                           [(StrataLabel, Tristrata)]
regenBarSeq Int -> ParsedContext
pctxAt Int -> Double
boostFor Int
regenN

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

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

  (ProgressionContext, GenerationDiagnostics)
-> IO (ProgressionContext, GenerationDiagnostics)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProgressionContext
splicedPC, GenerationDiagnostics
regenDiag)

-- |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]
")"

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

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