{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      : Harmonic.Framework.Builder.Diagnostics
-- Description : Diagnostic printing and chord tracing for generation
--
-- Functions for printing generation diagnostics at various verbosity levels,
-- computing chord traces during generation, and rendering chord names.

module Harmonic.Framework.Builder.Diagnostics
  ( -- * Diagnostic Printing
    printDiagnostics
  , printHeader
  , printStrataDiagnostics

    -- * Chord Tracing
  , computeChordTrace
  , showChord

    -- * Candidate Rendering
  , parseCadenceFromString

    -- * Multi-attempt scoreboard (Verbose only)
  , printAttemptScoreboard
  ) where

import           Control.Monad (forM_, when)
import           Data.List (sort, sortBy)
import           Data.Ord (comparing, Down(..))
import qualified Data.Text as T
import           Data.Text (Text)
import           Text.Printf (printf)

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.Scale as Sc
import qualified Harmonic.Evaluation.Scoring.Progression as PS

import           Harmonic.Framework.Builder.Types
import           Harmonic.Framework.Builder.Portmanteau (makePortmanteau)

-------------------------------------------------------------------------------
-- Header Printing
-------------------------------------------------------------------------------

-- | Print generation header based on composer selection
-- Takes raw Text instead of parsed ComposerWeights, plus entropy
printHeader :: Text -> Double -> HarmonicContext -> IO ()
printHeader :: Text -> Double -> HarmonicContext -> IO ()
printHeader Text
composerStr Double
entropy HarmonicContext
ctx = do
  if Text -> Text
T.toLower Text
composerStr Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"none"
    then [Char] -> IO ()
putStrLn [Char]
"|= offline =| harmonic traversal (fallback only — no graph) -> https://github.com/OscarSouth/theHarmonicAlgorithm"
    else case Text -> Maybe Text
makePortmanteau Text
composerStr of
      Just Text
portmanteau ->
        [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"|= \"" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
portmanteau
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\" =| harmonic traversal -> https://github.com/OscarSouth/theHarmonicAlgorithm"
      Maybe Text
Nothing ->
        [Char] -> IO ()
putStrLn [Char]
"generated by 'The Harmonic Algorithm' -> https://github.com/OscarSouth/theHarmonicAlgorithm"
  [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"   entropy " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show Double
entropy [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

-------------------------------------------------------------------------------
-- Diagnostic Printing
-------------------------------------------------------------------------------

-- |Print diagnostics collected during generation.
--
-- Selects output level based on verbosity parameter:
--
-- [0 - Silent] No output
-- [1 - Standard] Per-step candidate pools, selections, rendered chords
-- [2 - Verbose] Standard plus transform and advance traces
--
-- Useful for manually reprinting diagnostics after extraction from tuple,
-- or batch processing multiple results at different verbosity levels.
printDiagnostics :: Int -> GenerationDiagnostics -> IO ()
printDiagnostics :: Int -> GenerationDiagnostics -> IO ()
printDiagnostics Int
0 GenerationDiagnostics
_ = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()  -- No output for verbosity 0
printDiagnostics Int
verbosity GenerationDiagnostics
diag = do
  -- Header with context
  [Char] -> IO ()
putStrLn [Char]
""
  [Char] -> IO ()
putStrLn [Char]
"═══════════════════════════════════════════════════════════════════"
  [Char] -> IO ()
putStrLn [Char]
"GENERATION DIAGNOSTICS"
  [Char] -> IO ()
putStrLn [Char]
"═══════════════════════════════════════════════════════════════════"
  [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Start: " [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]
++ GenerationDiagnostics -> [Char]
gdStartRoot GenerationDiagnostics
diag
  [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Length: " [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]
"/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (GenerationDiagnostics -> Int
gdRequestedLen GenerationDiagnostics
diag) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" chords"
  [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Entropy: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show (GenerationDiagnostics -> Double
gdEntropy GenerationDiagnostics
diag)
  [Char] -> IO ()
putStrLn [Char]
""

  -- Per-step diagnostics
  let steps :: [StepDiagnostic]
steps = GenerationDiagnostics -> [StepDiagnostic]
gdSteps GenerationDiagnostics
diag
  [StepDiagnostic] -> (StepDiagnostic -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [StepDiagnostic]
steps ((StepDiagnostic -> IO ()) -> IO ())
-> (StepDiagnostic -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \StepDiagnostic
step -> do
    let stepNum :: Int
stepNum = StepDiagnostic -> Int
sdStepNumber StepDiagnostic
step
    [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
stepNum [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" ────"
    [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"  Prior: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StepDiagnostic -> [Char]
sdPriorCadence StepDiagnostic
step [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" @ " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StepDiagnostic -> [Char]
sdPriorRoot StepDiagnostic
step

    -- Candidate pool summary
    let graphCount :: Int
graphCount = StepDiagnostic -> Int
sdGraphCount StepDiagnostic
step
        fallbackCount :: Int
fallbackCount = StepDiagnostic -> Int
sdFallbackCount StepDiagnostic
step
        poolSize :: Int
poolSize = StepDiagnostic -> Int
sdPoolSize StepDiagnostic
step
    [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"  Pool: graph=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
graphCount [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" fallback=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
fallbackCount [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" total=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
poolSize

    -- Top candidates (if available)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
graphCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (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]
"    Graph top 3: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [([Char], Double)] -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [([Char], Double)] -> [([Char], Double)]
forall a. Int -> [a] -> [a]
take Int
3 ([([Char], Double)] -> [([Char], Double)])
-> [([Char], Double)] -> [([Char], Double)]
forall a b. (a -> b) -> a -> b
$ StepDiagnostic -> [([Char], Double)]
sdGraphTop6 StepDiagnostic
step)

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
fallbackCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (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]
"    Fallback top 3: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [([Char], Double)] -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [([Char], Double)] -> [([Char], Double)]
forall a. Int -> [a] -> [a]
take Int
3 [([Char]
n, Double
s) | ([Char]
n, Double
s, Double
_, Double
_, Double
_) <- StepDiagnostic -> [([Char], Double, Double, Double, Double)]
sdFallbackTop6 StepDiagnostic
step])

    -- Selection details
    [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"  Selection: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StepDiagnostic -> [Char]
sdSelectedFrom StepDiagnostic
step [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" @ gamma index " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (StepDiagnostic -> Int
sdGammaIndex StepDiagnostic
step)
    [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"  Movement: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StepDiagnostic -> [Char]
sdSelectedDbMovement StepDiagnostic
step
    [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"  Posterior: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StepDiagnostic -> [Char]
sdPosteriorRoot StepDiagnostic
step

    -- Rendered chord (verbosity 1+)
    case StepDiagnostic -> Maybe [Char]
sdRenderedChord StepDiagnostic
step of
      Just [Char]
chord -> [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"  Chord: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
chord
      Maybe [Char]
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- gen4 fusion (added-tone draw)
    case StepDiagnostic -> Maybe FusionDiag
sdFusion StepDiagnostic
step of
      Just FusionDiag
fd -> [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"  Fusion: +PC" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (FusionDiag -> Int
fdAddedPC FusionDiag
fd)
                            [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 (m :: * -> *) a. Monad m => a -> m a
return ()

    -- Transform trace (verbosity 2+)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
verbosity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ case StepDiagnostic -> Maybe TransformTrace
sdTransformTrace StepDiagnostic
step of
      Just TransformTrace
tt -> do
        [Char] -> IO ()
putStrLn [Char]
"  [TRANSFORM TRACE]"
        [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"    DB tones: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Int] -> [Char]
forall a. Show a => a -> [Char]
show (TransformTrace -> [Int]
ttTones TransformTrace
tt)
        [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"    Transposed (root+tones): " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Int] -> [Char]
forall a. Show a => a -> [Char]
show (TransformTrace -> [Int]
ttTransposedPitches TransformTrace
tt)
        [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"    Normalized: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Int] -> [Char]
forall a. Show a => a -> [Char]
show (TransformTrace -> [Int]
ttNormalizedPs TransformTrace
tt)
        [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"    Zero-form: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Int] -> [Char]
forall a. Show a => a -> [Char]
show (TransformTrace -> [Int]
ttZeroForm TransformTrace
tt)
        [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"    Detected root: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TransformTrace -> [Char]
ttDetectedRoot TransformTrace
tt
        [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"    Computed name: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TransformTrace -> [Char]
ttFunctionality TransformTrace
tt
        [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"    DB stored name: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TransformTrace -> [Char]
ttStoredFunc TransformTrace
tt
      Maybe TransformTrace
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- Advance trace (verbosity 2+)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
verbosity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ case StepDiagnostic -> Maybe AdvanceTrace
sdAdvanceTrace StepDiagnostic
step of
      Just AdvanceTrace
at -> do
        [Char] -> IO ()
putStrLn [Char]
"  [ADVANCE TRACE]"
        [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"    Root motion: " [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]
++ 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]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (AdvanceTrace -> Int
atNewRootPC AdvanceTrace
at)
        [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"    Spelling: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AdvanceTrace -> [Char]
atNewRoot AdvanceTrace
at
      Maybe AdvanceTrace
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

  -- Final progression
  [Char] -> IO ()
putStrLn [Char]
"═══════════════════════════════════════════════════════════════════"
  [Char] -> IO ()
putStrLn [Char]
"FINAL PROGRESSION:"
  [Char] -> IO ()
putStrLn [Char]
"═══════════════════════════════════════════════════════════════════"
  Progression -> IO ()
forall a. Show a => a -> IO ()
print (GenerationDiagnostics -> Progression
gdProgression GenerationDiagnostics
diag)
  [Char] -> IO ()
putStrLn [Char]
""

-------------------------------------------------------------------------------
-- Chord Tracing
-------------------------------------------------------------------------------

-- |Compute chord rendering and transform trace based on verbosity level.
-- Note: Reads raw DB data from the cadence within the state (which is the selected cadence after advance).
computeChordTrace :: Int -> H.CadenceState -> (Maybe String, Maybe TransformTrace)
computeChordTrace :: Int -> CadenceState -> (Maybe [Char], Maybe TransformTrace)
computeChordTrace Int
verbosity CadenceState
state
  -- 4+ note states: the triad transform pipeline (fromCadenceStateTraced)
  -- would reduce them via mostConsonant and print a misleading trace —
  -- name via the cardinality dispatch instead, with no transform trace.
  | Int
verbosity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1
  , [PitchClass] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Cadence -> [PitchClass]
H.cadenceIntervals (CadenceState -> Cadence
H.stateCadence CadenceState
state)) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
3 =
      let enharm :: PitchClass -> NoteName
enharm = EnharmonicSpelling -> PitchClass -> NoteName
H.enharmonicFunc (CadenceState -> EnharmonicSpelling
H.stateSpelling CadenceState
state)
      in ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ (PitchClass -> NoteName) -> CadenceState -> [Char]
Prog.showHarmony PitchClass -> NoteName
enharm CadenceState
state, Maybe TransformTrace
forall a. Maybe a
Nothing)
  | Int
verbosity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 =
      let (Chord
chord, ToTriadTrace
ttt) = CadenceState -> (Chord, ToTriadTrace)
H.fromCadenceStateTraced CadenceState
state

          tt :: TransformTrace
tt = TransformTrace
            { ttRawDbIntervals :: [Char]
ttRawDbIntervals = ToTriadTrace -> [Char]
H.tttRawDbIntervals ToTriadTrace
ttt
            , ttRawDbMovement :: [Char]
ttRawDbMovement = ToTriadTrace -> [Char]
H.tttRawDbMovement ToTriadTrace
ttt
            , ttRawDbFunctionality :: [Char]
ttRawDbFunctionality = ToTriadTrace -> [Char]
H.tttRawDbFunctionality ToTriadTrace
ttt
            , ttRootPC :: Int
ttRootPC = ToTriadTrace -> Int
H.tttRootPC ToTriadTrace
ttt
            , ttRootNoteName :: [Char]
ttRootNoteName = ToTriadTrace -> [Char]
H.tttRootNoteName ToTriadTrace
ttt
            , ttTones :: [Int]
ttTones = ToTriadTrace -> [Int]
H.tttTones ToTriadTrace
ttt
            , ttTransposedPitches :: [Int]
ttTransposedPitches = ToTriadTrace -> [Int]
H.tttTransposedPitches ToTriadTrace
ttt
            , ttNormalizedPs :: [Int]
ttNormalizedPs = ToTriadTrace -> [Int]
H.tttNormalizedPs ToTriadTrace
ttt
            , ttZeroForm :: [Int]
ttZeroForm = ToTriadTrace -> [Int]
H.tttZeroForm ToTriadTrace
ttt
            , ttDetectedRoot :: [Char]
ttDetectedRoot = ToTriadTrace -> [Char]
H.tttDetectedRoot ToTriadTrace
ttt
            , ttFunctionality :: [Char]
ttFunctionality = ToTriadTrace -> [Char]
H.tttFunctionality ToTriadTrace
ttt
            , ttFinalChord :: [Char]
ttFinalChord = ToTriadTrace -> [Char]
H.tttFinalChord ToTriadTrace
ttt
            , ttStoredFunc :: [Char]
ttStoredFunc = ToTriadTrace -> [Char]
H.tttStoredFunc ToTriadTrace
ttt
            }
      in ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ Chord -> [Char]
showChord Chord
chord, TransformTrace -> Maybe TransformTrace
forall a. a -> Maybe a
Just TransformTrace
tt)
  | Int
verbosity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 =
      let chord :: Chord
chord = CadenceState -> Chord
H.fromCadenceState CadenceState
state
      in ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ Chord -> [Char]
showChord Chord
chord, Maybe TransformTrace
forall a. Maybe a
Nothing)
  | Bool
otherwise = (Maybe [Char]
forall a. Maybe a
Nothing, Maybe TransformTrace
forall a. Maybe a
Nothing)

-- |Show a chord as "Root Functionality"
showChord :: H.Chord -> String
showChord :: Chord -> [Char]
showChord Chord
c = NoteName -> [Char]
forall a. Show a => a -> [Char]
show (Chord -> NoteName
H.chordNoteName Chord
c) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Chord -> [Char]
H.chordFunctionality Chord
c

-------------------------------------------------------------------------------
-- Candidate Rendering
-------------------------------------------------------------------------------

-- | Parse candidate name like "( pedal -> min )" and render with posterior root
-- Returns "C min" for "( pedal -> min )" when posterior root is C
parseCadenceFromString :: String -> Int -> Maybe String
parseCadenceFromString :: [Char] -> Int -> Maybe [Char]
parseCadenceFromString [Char]
name Int
posteriorRootPC =
  let -- Strip parentheses: "( pedal -> min )" → " pedal -> min "
      cleaned :: [Char]
cleaned = (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'(' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
')') [Char]
name
      -- Find arrow position and split
      ([Char]
before, [Char]
after) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'>') ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') [Char]
cleaned)
  in if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
after Bool -> Bool -> Bool
|| [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
before
     then Maybe [Char]
forall a. Maybe a
Nothing
     else let functionality :: [Char]
functionality = [Char] -> [Char]
trim ([Char] -> [Char]
forall a. HasCallStack => [a] -> [a]
tail [Char]
after)  -- skip '>'
              posteriorRoot :: [Char]
posteriorRoot = NoteName -> [Char]
forall a. Show a => a -> [Char]
show (PitchClass -> NoteName
P.sharp (Int -> PitchClass
P.mkPitchClass Int
posteriorRootPC))
          in [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
posteriorRoot [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
functionality
  where
    trim :: String -> String
    trim :: [Char] -> [Char]
trim = (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
forall a. [a] -> [a]
reverse ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
forall a. [a] -> [a]
reverse

-------------------------------------------------------------------------------
-- Strata Diagnostics (genP paradigm)
-------------------------------------------------------------------------------

-- |Per-bar rendering for 'Harmonic.Framework.Builder.genP'/'genP\''/'genP\'\''. Shows the triad
-- (3 notes), the strata chroma (5 notes), the mode chroma (7 notes), the
-- active tristrata, and — at verbosity 2 — the soft-boost applied.
--
-- Noop when 'sdStrataLabel' is 'Nothing' for every step, so it's safe to
-- call unconditionally on any diagnostics value.
printStrataDiagnostics :: Int -> GenerationDiagnostics -> IO ()
printStrataDiagnostics :: Int -> GenerationDiagnostics -> IO ()
printStrataDiagnostics Int
verbosity GenerationDiagnostics
diag = do
  let steps :: [StepDiagnostic]
steps = GenerationDiagnostics -> [StepDiagnostic]
gdSteps GenerationDiagnostics
diag
      hasStrata :: Bool
hasStrata = (StepDiagnostic -> Bool) -> [StepDiagnostic] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\StepDiagnostic
s -> StepDiagnostic -> Maybe StrataLabel
sdStrataLabel StepDiagnostic
s Maybe StrataLabel -> Maybe StrataLabel -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe StrataLabel
forall a. Maybe a
Nothing) [StepDiagnostic]
steps
  if Bool -> Bool
not Bool
hasStrata
    then () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    else do
      [Char] -> IO ()
putStrLn [Char]
""
      [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Strata walk: " [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]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (GenerationDiagnostics -> Int
gdActualLen GenerationDiagnostics
diag) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" bars (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]
"━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━"
      [StepDiagnostic] -> (StepDiagnostic -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [StepDiagnostic]
steps ((StepDiagnostic -> IO ()) -> IO ())
-> (StepDiagnostic -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \StepDiagnostic
step -> Int -> StepDiagnostic -> IO ()
renderStrataStep Int
verbosity StepDiagnostic
step
      [Char] -> IO ()
putStrLn [Char]
"━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━"
      [Char] -> IO ()
putStrLn [Char]
""

-- |Per-bar renderer. Layout is a three-line block (header + strata +
-- mode) sharing a common indent (4 spaces) and four column widths:
-- label, identifier, info, chroma.
--
-- @
--     <barNum>:      <motion>         <chord>             [<src>] γ=<idx>
--     strata         <Roman>          #<idx> (<ts1>-<ts2>-<ts3>)  {<n1> <n2> ...}
--     mode           <Root Quality>   (<Parent Family>)           {<n1> <n2> ...}
-- @
--
-- For 'Harmonic.Rules.Types.Scale.ModeInvalid' (only via 'Harmonic.Framework.Builder.absStrata' overrides that violate
-- tristrata adjacency), the mode line reads
-- @mode           invalid overlap                                 {<overlap PCs>}@.
renderStrataStep :: Int -> StepDiagnostic -> IO ()
renderStrataStep :: Int -> StepDiagnostic -> IO ()
renderStrataStep Int
verbosity StepDiagnostic
step = do
  let isStarter :: Bool
isStarter = StepDiagnostic -> [Char]
sdSelectedFrom StepDiagnostic
step [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"starter"
      chord :: [Char]
chord  = case StepDiagnostic -> Maybe [Char]
sdRenderedChord StepDiagnostic
step of
                 Just [Char]
c  -> [Char]
c
                 Maybe [Char]
Nothing -> StepDiagnostic -> [Char]
sdPosteriorRoot StepDiagnostic
step
      motion :: [Char]
motion
        | Bool
isStarter = [Char]
"— → " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StepDiagnostic -> [Char]
sdPosteriorRoot StepDiagnostic
step
        | Bool
otherwise = 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
      pivotPC :: Int
pivotPC = case StepDiagnostic -> Maybe Int
sdHarmonicRootPC StepDiagnostic
step of
                  Just Int
pc -> Int
pc
                  Maybe Int
Nothing -> StepDiagnostic -> Int
sdPosteriorRootPC StepDiagnostic
step
      -- Per-bar spelling, inferred by 'runStrataGen' via 'H.inferSpelling'
      -- on the mode chroma. Falls back to 'defaultEnharm' when missing
      -- (non-genP callers).
      spelling :: EnharmonicSpelling
spelling = case StepDiagnostic -> Maybe EnharmonicSpelling
sdBarSpelling StepDiagnostic
step of
        Just EnharmonicSpelling
s  -> EnharmonicSpelling
s
        Maybe EnharmonicSpelling
Nothing -> PitchClass -> EnharmonicSpelling
H.defaultEnharm (Int -> PitchClass
P.mkPitchClass Int
pivotPC)
      enharm :: PitchClass -> NoteName
enharm = EnharmonicSpelling -> PitchClass -> NoteName
H.enharmonicFunc EnharmonicSpelling
spelling
      src :: [Char]
src
        | Bool
isStarter = [Char]
"[starter]"
        | Bool
otherwise = [Char]
"[" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StepDiagnostic -> [Char]
sdSelectedFrom 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
sdGammaIndex StepDiagnostic
step)

  -- Header row: aligned on the same four columns as strata\/mode.
  [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
indent
             [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char] -> [Char]
pad Int
labelWidth (Int -> [Char]
forall a. Show a => a -> [Char]
show (StepDiagnostic -> Int
sdStepNumber StepDiagnostic
step) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":")
             [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char] -> [Char]
pad Int
identWidth [Char]
motion
             [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char] -> [Char]
pad Int
infoWidth [Char]
chord
             [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
src

  -- Strata row — Roman label in ident column, tristrata tag in info
  -- column (merged), chroma in the final column.
  case (StepDiagnostic -> Maybe StrataLabel
sdStrataLabel StepDiagnostic
step, StepDiagnostic -> Maybe [PitchClass]
sdStrataChroma StepDiagnostic
step) of
    (Just StrataLabel
sl, Just [PitchClass]
chroma) ->
      let tagStr :: [Char]
tagStr = case (StepDiagnostic -> Maybe Int
sdTristrataIdx StepDiagnostic
step, StepDiagnostic -> Maybe Tristrata
sdTristrata StepDiagnostic
step) of
            (Just Int
idx, Just Tristrata
t) ->
              [Char]
"#" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
idx
                  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StrataLabel -> [Char]
forall a. Show a => a -> [Char]
show (Tristrata -> StrataLabel
Sc.ts1 Tristrata
t)
                  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StrataLabel -> [Char]
forall a. Show a => a -> [Char]
show (Tristrata -> StrataLabel
Sc.ts2 Tristrata
t)
                  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StrataLabel -> [Char]
forall a. Show a => a -> [Char]
show (Tristrata -> StrataLabel
Sc.ts3 Tristrata
t) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
            (Maybe Int, Maybe Tristrata)
_ -> [Char]
""
      in [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
indent
                    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char] -> [Char]
pad Int
labelWidth [Char]
"strata"
                    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char] -> [Char]
pad Int
identWidth (StrataLabel -> [Char]
forall a. Show a => a -> [Char]
show StrataLabel
sl)
                    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char] -> [Char]
pad Int
infoWidth [Char]
tagStr
                    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (PitchClass -> NoteName) -> Int -> [PitchClass] -> [Char]
showPCNamesCurly PitchClass -> NoteName
enharm Int
pivotPC [PitchClass]
chroma
    (Maybe StrataLabel, Maybe [PitchClass])
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  -- Mode row — handle ModeOk vs ModeInvalid.
  case StepDiagnostic -> Maybe ModeResult
sdModeResult StepDiagnostic
step of
    Just (Sc.ModeInvalid [PitchClass]
overlap) ->
      [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
indent
                 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char] -> [Char]
pad Int
labelWidth [Char]
"mode"
                 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char] -> [Char]
pad Int
identWidth [Char]
"invalid overlap"
                 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char] -> [Char]
pad Int
infoWidth [Char]
""
                 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (PitchClass -> NoteName) -> Int -> [PitchClass] -> [Char]
showPCNamesCurly PitchClass -> NoteName
enharm Int
0 [PitchClass]
overlap
    Maybe ModeResult
_ ->
      case (StepDiagnostic -> Maybe Mode
sdMode StepDiagnostic
step, StepDiagnostic -> Maybe [PitchClass]
sdModeChroma StepDiagnostic
step) of
        (Just Mode
m, Just [PitchClass]
chroma) ->
          let modeRootPC :: Int
modeRootPC  = PitchClass -> Int
P.unPitchClass (Mode -> PitchClass
Sc.modeRoot Mode
m)
              parentTag :: [Char]
parentTag   = case StepDiagnostic -> Maybe (PitchClass, ScaleFamily)
sdParentKey StepDiagnostic
step of
                Just (P.P Int
pr, ScaleFamily
fam) ->
                  [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NoteName -> [Char]
forall a. Show a => a -> [Char]
show (PitchClass -> NoteName
enharm (Int -> PitchClass
P.mkPitchClass Int
pr))
                      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ScaleFamily -> [Char]
Sc.showScaleFamily ScaleFamily
fam [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
                Maybe (PitchClass, ScaleFamily)
Nothing -> [Char]
""
          in [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
indent
                        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char] -> [Char]
pad Int
labelWidth [Char]
"mode"
                        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char] -> [Char]
pad Int
identWidth ((PitchClass -> NoteName) -> Mode -> [Char]
modeLabelWith PitchClass -> NoteName
enharm Mode
m)
                        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char] -> [Char]
pad Int
infoWidth [Char]
parentTag
                        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (PitchClass -> NoteName) -> Int -> [PitchClass] -> [Char]
showPCNamesCurly PitchClass -> NoteName
enharm Int
modeRootPC [PitchClass]
chroma
        (Maybe Mode, Maybe [PitchClass])
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
verbosity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    case StepDiagnostic -> Maybe Double
sdSoftBoost StepDiagnostic
step of
      Just Double
b  -> [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
indent [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char] -> [Char]
pad Int
labelWidth [Char]
"boost" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show Double
b
      Maybe Double
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  [Char] -> IO ()
putStrLn [Char]
""
  where
    indent :: [Char]
indent       = [Char]
"    "
    labelWidth :: Int
labelWidth   = Int
11   -- covers "tristrata", "strata", "mode", "N:"
    identWidth :: Int
identWidth   = Int
16   -- covers "F# Mixolydian" (13), tolerant to 16
    infoWidth :: Int
infoWidth    = Int
22   -- covers "#10 (IV-VI-XI)" (14) and "(F# Harmonic Major)" (19)

-- |Render a PC list inside curly brackets, ordered from the given pivot PC
-- up. The pivot is used to rotate the sorted list so the pivot (if
-- present) is first; otherwise sorted order is used. Note names are
-- spelled using the supplied enharmonic function (parent-key driven), so
-- "F# Phrygian (D Major)" renders chroma as "{F# G A B C# D E}", not
-- "{Gb Ab Bbb Cb Db Ebb Fb}".
showPCNamesCurly :: (P.PitchClass -> P.NoteName) -> Int -> [P.PitchClass] -> String
showPCNamesCurly :: (PitchClass -> NoteName) -> Int -> [PitchClass] -> [Char]
showPCNamesCurly PitchClass -> NoteName
enharm Int
pivot [PitchClass]
pcs =
  let ns :: [Int]
ns           = [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 [PitchClass]
pcs)
      ([Int]
before, [Int]
after) = (Int -> Bool) -> [Int] -> ([Int], [Int])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
pivot) [Int]
ns
      ordered :: [Int]
ordered      = [Int]
after [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
before
      renderPC :: Int -> [Char]
renderPC Int
n   = NoteName -> [Char]
forall a. Show a => a -> [Char]
show (PitchClass -> NoteName
enharm (Int -> PitchClass
P.mkPitchClass Int
n))
  in [Char]
"{" [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]
renderPC [Int]
ordered) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"}"

-- |Mode label in musician-readable form using a supplied enharmonic
-- function for the root + the legacy @toMode@ mode-quality strings:
-- @"C# Aeolian"@, @"A Mixo_b6"@, @"Db Lyd_Aug_#2"@. Passing
-- @P.sharp@ \/ @P.flat@ \/ @H.enharmonicFunc spelling@ selects the root's
-- accidental.
modeLabelWith :: (P.PitchClass -> P.NoteName) -> Sc.Mode -> String
modeLabelWith :: (PitchClass -> NoteName) -> Mode -> [Char]
modeLabelWith PitchClass -> NoteName
f (Sc.Mode ModeQuality
q (P.P Int
r)) =
  NoteName -> [Char]
forall a. Show a => a -> [Char]
show (PitchClass -> NoteName
f (Int -> PitchClass
P.mkPitchClass Int
r)) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ModeQuality -> [Char]
Sc.showModeQuality ModeQuality
q

pad :: Int -> String -> String
pad :: Int -> [Char] -> [Char]
pad Int
n [Char]
s = [Char]
s [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]
s)) Char
' '

-------------------------------------------------------------------------------
-- Multi-attempt scoreboard (Verbose only)
-------------------------------------------------------------------------------

-- |Render the multi-attempt rank-and-select scoreboard. Called from
-- @generateBest@ when @_gcVerbosity == Verbose@
-- and @_gcMaxAttempts > 1@. Silent and Standard verbosity print nothing
-- (the caller suppresses the call).
--
-- Rows sorted by 'adTotal' descending; the picked attempt is marked
-- with @← PICK@. The chord-name sequence is truncated to the first 8
-- chords with an ellipsis if longer.
printAttemptScoreboard :: Double -> [AttemptDiagnostic] -> IO ()
printAttemptScoreboard :: Double -> [AttemptDiagnostic] -> IO ()
printAttemptScoreboard Double
floorT [AttemptDiagnostic]
diags = do
  let viableCount :: Int
viableCount  = [AttemptDiagnostic] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((AttemptDiagnostic -> Bool)
-> [AttemptDiagnostic] -> [AttemptDiagnostic]
forall a. (a -> Bool) -> [a] -> [a]
filter AttemptDiagnostic -> Bool
adViable [AttemptDiagnostic]
diags)
      totalCount :: Int
totalCount   = [AttemptDiagnostic] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [AttemptDiagnostic]
diags
      sorted :: [AttemptDiagnostic]
sorted       = (AttemptDiagnostic -> AttemptDiagnostic -> Ordering)
-> [AttemptDiagnostic] -> [AttemptDiagnostic]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((AttemptDiagnostic -> Down Double)
-> AttemptDiagnostic -> AttemptDiagnostic -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Double -> Down Double
forall a. a -> Down a
Down (Double -> Down Double)
-> (AttemptDiagnostic -> Double)
-> AttemptDiagnostic
-> Down Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttemptDiagnostic -> Double
adTotal)) [AttemptDiagnostic]
diags
      barLine :: [Char]
barLine      = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
91 Char
'═'
      sepLine :: [Char]
sepLine      = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
91 Char
'─'
  [Char] -> IO ()
putStrLn [Char]
""
  [Char] -> IO ()
putStrLn [Char]
barLine
  [Char] -> Int -> Int -> Double -> IO ()
forall r. PrintfType r => [Char] -> r
printf [Char]
"Multi-attempt rank-and-select  (%d viable in %d attempts, floor T=%.2f)\n"
         Int
viableCount Int
totalCount Double
floorT
  [Char] -> IO ()
putStrLn [Char]
barLine
  [Char]
-> [Char]
-> [Char]
-> [Char]
-> [Char]
-> [Char]
-> [Char]
-> [Char]
-> [Char]
-> IO ()
forall r. PrintfType r => [Char] -> r
printf [Char]
"   %-3s %-6s %-6s %-6s %-6s %-7s %-6s %s\n"
         ([Char]
"#" :: String) ([Char]
"rm" :: String) ([Char]
"vl" :: String)
         ([Char]
"cf" :: String) ([Char]
"mv" :: String)
         ([Char]
"total" :: String) ([Char]
"viable" :: String) ([Char]
"chords" :: String)
  [Char] -> IO ()
putStrLn ([Char]
"   " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
sepLine)
  [AttemptDiagnostic] -> (AttemptDiagnostic -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [AttemptDiagnostic]
sorted (AttemptDiagnostic -> IO ()
renderRow)
  [Char] -> IO ()
putStrLn ([Char]
"   " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
sepLine)
  case (AttemptDiagnostic -> Bool)
-> [AttemptDiagnostic] -> [AttemptDiagnostic]
forall a. (a -> Bool) -> [a] -> [a]
filter AttemptDiagnostic -> Bool
adPicked [AttemptDiagnostic]
diags of
    (AttemptDiagnostic
a:[AttemptDiagnostic]
_) -> [Char] -> Int -> Double -> IO ()
forall r. PrintfType r => [Char] -> r
printf [Char]
"   picked: #%d (total %.3f)\n" (AttemptDiagnostic -> Int
adIndex AttemptDiagnostic
a) (AttemptDiagnostic -> Double
adTotal AttemptDiagnostic
a)
    []    -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  [Char] -> IO ()
putStrLn [Char]
barLine
  [Char] -> IO ()
putStrLn [Char]
""
  where
    renderRow :: AttemptDiagnostic -> IO ()
    renderRow :: AttemptDiagnostic -> IO ()
renderRow AttemptDiagnostic
a = do
      let ps :: ProgressionScore
ps        = AttemptDiagnostic -> ProgressionScore
adScore AttemptDiagnostic
a
          viableMk :: [Char]
viableMk  = if AttemptDiagnostic -> Bool
adViable AttemptDiagnostic
a then [Char]
"✓" else [Char]
"·"
          pickedMk :: [Char]
pickedMk  = if AttemptDiagnostic -> Bool
adPicked AttemptDiagnostic
a then [Char]
"  ← PICK" else [Char]
""
          chordPrev :: [Char]
chordPrev = Int -> [[Char]] -> [Char]
truncateChords Int
8 (AttemptDiagnostic -> [[Char]]
adChords AttemptDiagnostic
a)
      [Char]
-> Int
-> Double
-> Double
-> Double
-> Double
-> Double
-> [Char]
-> [Char]
-> [Char]
-> IO ()
forall r. PrintfType r => [Char] -> r
printf [Char]
"  %2d   %.3f  %.3f  %.3f  %.3f  %.3f  %-6s  %s%s\n"
             (AttemptDiagnostic -> Int
adIndex AttemptDiagnostic
a)
             (ProgressionScore -> Double
PS.psRootMotion ProgressionScore
ps)
             (ProgressionScore -> Double
PS.psVoiceLeading ProgressionScore
ps)
             (ProgressionScore -> Double
PS.psCadenceFav ProgressionScore
ps)
             (ProgressionScore -> Double
PS.psModeValidity ProgressionScore
ps)
             (AttemptDiagnostic -> Double
adTotal AttemptDiagnostic
a)
             ([Char]
viableMk :: String)
             [Char]
chordPrev
             ([Char]
pickedMk :: String)

    truncateChords :: Int -> [String] -> String
    truncateChords :: Int -> [[Char]] -> [Char]
truncateChords Int
_ []     = [Char]
"(empty)"
    truncateChords Int
k [[Char]]
cs
      | [[Char]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
cs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
k = [[Char]] -> [Char]
commaSep [[Char]]
cs
      | Bool
otherwise      = [[Char]] -> [Char]
commaSep (Int -> [[Char]] -> [[Char]]
forall a. Int -> [a] -> [a]
take Int
k [[Char]]
cs) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", …"
      where
        commaSep :: [[Char]] -> [Char]
commaSep = ([Char] -> [Char] -> [Char]) -> [[Char]] -> [Char]
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\[Char]
x [Char]
y -> [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
y)