-- |
-- Module      : Harmonic.Framework.Builder.JazzGen
-- Description : genJ — walk generation over the jazz (Change) graph
--
-- The jazz counterpart of the triadic walk, decomposed R→E→T with every
-- shared concern imported from its home module rather than re-implemented:
--
-- * __R__ — the @Change@ graph's adjacency (no consonance fallback: the
--   corpus measures rich enough that none is needed — 0 dead ends,
--   ~219-candidate typical pools) intersected with the caller's
--   'HarmonicContext' via the same
--   'Harmonic.Framework.Builder.Core.matchesContextWithTarget' filter the
--   classical walk applies (it is arity-agnostic and anchors exactly as
--   jazz movement does) — including the rise\/fall bass-direction spec
--   (resolved per step, 1-based, so rotate selectors stay in phase with
--   the classical walk), the dissonance drift and the pedal-tone
--   filters. Inversion spacing (@invSkip@) is inert here by design:
--   jazz slash structures are graph vocabulary, not a voicing choice
--   the walk makes. A step whose R-filter empties the pool relaxes down
--   a ladder, each stage with a notice: exact rise\/fall target, then
--   any arrival in the spec's direction (step size freed), then the
--   direction with only chord-colour containment freed (bass still
--   lands on an allowed root), then plain membership, then everything —
--   there is no fallback pool to fill from, and continuity beats a
--   hard stop, but a pedal repeat is the last resort under an active
--   direction, never the first.
-- * __E__ — corpus frequency under the seek spec
--   ('Harmonic.Evaluation.Database.Query.resolveWeights'), plus the
--   classical steer boost when the spec names classical composers.
-- * __T__ — the shared gamma entropy dial
--   ('Harmonic.Traversal.Probabilistic.gammaIndexScaledWith').
--
-- == Seek semantics (genJ)
--
-- One spec drives both corpora, split by
-- 'Harmonic.Evaluation.Database.Query.splitSeekByCorpus':
--
-- * @"*"@ — aggregate corpus-frequency walk over the whole jazz graph.
-- * Jazz names (@"monk:60 coltrane:40"@) — composer-blend scoring over
--   jazz edge weights (substring-matched against jazz keys).
-- * Classical names (@"debussy"@) — the jazz walk runs on @"*"@ and each
--   step is steered: the current chord's most consonant embedded triad
--   queries the classical graph under that blend, and jazz candidates
--   containing one of the top recommended triads (arriving by the same
--   movement) are boosted by the 'Harmonic.Framework.Builder.steer'
--   strength.
-- * Mixed (@"monk debussy"@) — blend and steer together.
-- * @"none"@ — refused: the jazz graph IS the generator; no offline mode.
module Harmonic.Framework.Builder.JazzGen (
    runJazzGen,
    runJazzGenFrom,
    jazzGuardSeek,
    jazzStartCue,
) where

import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import           Data.Char (toLower)
import           Data.List (sortBy)
import           Data.Ord (Down(..), comparing)
import           Control.Monad (when)
import           Data.IORef (IORef, newIORef, readIORef, modifyIORef')
import           System.Random.MWC (GenIO, createSystemRandom, uniformRM)
import qualified Data.IntSet as IntSet

import           Harmonic.Database (DbConn, runDb)
import qualified Harmonic.Evaluation.Database.Query as Q
import qualified Harmonic.Rules.Import.Jazz as J
import qualified Harmonic.Rules.Types.Harmony as H
import qualified Harmonic.Rules.Types.Pitch as P
import qualified Harmonic.Rules.Types.Progression as Prog
import qualified Harmonic.Rules.Types.ProgressionContext as PC
import           Harmonic.Rules.Import.Graph (connectNeo4j)
import           Harmonic.Framework.Builder.Types
import           Harmonic.Evaluation.Analysis.KeyArea (chordscale)
import           Harmonic.Framework.Builder.Core (matchesContextWithTarget, rootPositionCue, applyDriftFilter, applyPedalFilter, resolveBassDirection)
import           Harmonic.Rules.Constraints.Filter (nthAbove, nthBelow)
import           Harmonic.Traversal.Probabilistic (gammaIndexScaledWith)

-- Everything one walk step needs, resolved once per generation.
data JazzEnv = JazzEnv
  { JazzEnv -> DbConn
jeConn     :: DbConn
  , JazzEnv -> GenIO
jeGen      :: GenIO
  , JazzEnv -> ComposerWeights
jeBlend    :: Q.ComposerWeights  -- ^ Jazz half of the seek spec.
  , JazzEnv -> ComposerWeights
jeSteer    :: Q.ComposerWeights  -- ^ Classical-steer half.
  , JazzEnv -> Double
jeStrength :: Double             -- ^ Steer boost strength ('_gcSteer').
  , JazzEnv -> Double
jeEntropy  :: Double
  , JazzEnv -> ParsedContext
jePctx     :: ParsedContext      -- ^ Parsed 'HarmonicContext' (R filter).
  , JazzEnv -> Bool
jeVerbose  :: Bool
  , JazzEnv -> Bool
jeSingle   :: Bool               -- ^ Single-pass run (no attempt loop): warnings may print immediately.
  , JazzEnv -> IORef [[Char]]
jeTrace    :: IORef [String]     -- ^ Walk-trace accumulator (reversed); drained into 'gdJazzTrace' so only the attempt winner's trace is emitted.
  }

-- Collect one trace line; emitFinalised prints the winner's collected
-- lines exactly once, restoring the emit-once contract under attempt.
trace' :: JazzEnv -> String -> IO ()
trace' :: JazzEnv -> [Char] -> IO ()
trace' JazzEnv
env [Char]
l = IORef [[Char]] -> ([[Char]] -> [[Char]]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (JazzEnv -> IORef [[Char]]
jeTrace JazzEnv
env) ([Char]
l [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:)

-- |Refuse @seek "none"@ before any Neo4j contact: the jazz graph IS the
-- generator — there is no offline fallback. Exported so the attempt loop
-- can guard before opening its scoring connection.
jazzGuardSeek :: GenConfig -> IO ()
jazzGuardSeek :: GenConfig -> IO ()
jazzGuardSeek GenConfig
gc =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((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") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"genJ: seek \"none\" has no meaning here — the jazz graph IS the generator (no offline fallback exists). Use seek \"*\" or a composer spec."

-- | Execute a 'JazzMode' 'GenConfig': fresh jazz generation. The cue is
-- honoured as bar 1 (the human aberration channel, as in every family)
-- and mapped onto a jazz start node; the walk fills the remaining bars.
-- Output is stamped 'PC.FJazz'.
runJazzGen :: GenConfig -> IO (PC.ProgressionContext, GenerationDiagnostics)
runJazzGen :: GenConfig -> IO (ProgressionContext, GenerationDiagnostics)
runJazzGen GenConfig
gc = do
  env  <- GenConfig -> IO JazzEnv
mkEnv GenConfig
gc
  cue0 <- if _gcCueExplicit gc then _gcCue gc else jazzStartCue gc
  startKey <- resolveStart env False cue0
  states <- jazzWalk env startKey cue0 (max 1 (_gcLen gc) - 1)
  traceLines <- drainTrace env
  let allStates = CadenceState
cue0 CadenceState -> [CadenceState] -> [CadenceState]
forall a. a -> [a] -> [a]
: [CadenceState]
states
      prog      = [CadenceState] -> Progression
Prog.fromCadenceStates [CadenceState]
allStates
      pc        = ProgressionContext -> ProgressionContext
chordscale ((Progression -> ProgressionContext
PC.fromProgression Progression
prog) { PC.pcFamily = PC.FJazz })
  pure (pc, jazzDiag gc cue0 prog traceLines)

-- | Regenerate bars @s..e@ (1-indexed, wrap-aware; @len@ expands the
-- range like the classical 'Harmonic.Framework.Builder.genFrom') of a
-- jazz-family source in place. The cue is the bar before @s@ (or the
-- caller's override); regenerated bars are spliced back via
-- 'PC.pcSplice', whose triad-layer path applies the standard seam
-- movement-fix — the bar after the range keeps its chord but its
-- movement metadata is corrected to the actual arrival interval, exactly
-- the legacy-family regen contract.
runJazzGenFrom :: PC.ProgressionContext -> Int -> Int -> GenConfig
               -> IO (PC.ProgressionContext, GenerationDiagnostics)
runJazzGenFrom :: ProgressionContext
-> Int
-> Int
-> GenConfig
-> IO (ProgressionContext, GenerationDiagnostics)
runJazzGenFrom ProgressionContext
srcPC Int
s Int
_e GenConfig
gc = do
  env  <- GenConfig -> IO JazzEnv
mkEnv GenConfig
gc
  cue0 <- _gcCue gc
  startKey <- resolveStart env True cue0
  let n     = ProgressionContext -> Int
PC.pcLength ProgressionContext
srcPC
      rSize = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (GenConfig -> Int
_gcLen GenConfig
gc)
      effE  = ((Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
n) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
  newBars <- jazzWalk env startKey cue0 rSize
  traceLines <- drainTrace env
  let insertPC = (Progression -> ProgressionContext
PC.fromProgression ([CadenceState] -> Progression
Prog.fromCadenceStates [CadenceState]
newBars))
                   { PC.pcFamily = PC.FJazz }
      -- Rebuild from the movement-fixed triad splice (pcSplice would leave
      -- stale movement metadata on the duplicated layers), then re-derive
      -- the chordscale S/M layers over the WHOLE spliced progression — key
      -- boundaries are a global property, so a regen recomputes them.
      spliced  = ProgressionContext -> ProgressionContext
chordscale ((Progression -> ProgressionContext
PC.fromProgression
                    (ProgressionContext -> Progression
PC.triadLayer (ProgressionContext
-> Int -> Int -> ProgressionContext -> ProgressionContext
PC.pcSplice ProgressionContext
srcPC Int
s Int
effE ProgressionContext
insertPC)))
                   { PC.pcFamily = PC.FJazz })
  pure (spliced, jazzDiag gc cue0 (PC.triadLayer spliced) traceLines)

-- Reverse-accumulated trace back into emission order.
drainTrace :: JazzEnv -> IO [String]
drainTrace :: JazzEnv -> IO [[Char]]
drainTrace JazzEnv
env = [[Char]] -> [[Char]]
forall a. [a] -> [a]
Prelude.reverse ([[Char]] -> [[Char]]) -> IO [[Char]] -> IO [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [[Char]] -> IO [[Char]]
forall a. IORef a -> IO a
readIORef (JazzEnv -> IORef [[Char]]
jeTrace JazzEnv
env)

-- Shared construction of the per-generation environment: connection,
-- RNG, seek split (with the Verbose resolution report), parsed tonal
-- context.
mkEnv :: GenConfig -> IO JazzEnv
mkEnv :: GenConfig -> IO JazzEnv
mkEnv GenConfig
gc = do
  GenConfig -> IO ()
jazzGuardSeek GenConfig
gc
  conn <- IO DbConn
connectNeo4j
  gen  <- createSystemRandom
  traceRef <- newIORef []
  let blend   = Text -> ComposerWeights
Q.parseComposerWeights ([Char] -> Text
T.pack (GenConfig -> [Char]
_gcSeek GenConfig
gc))
      verbose = GenConfig -> Verbosity
_gcVerbosity GenConfig
gc Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
/= Verbosity
Silent
  (jazzBlend, steerBlend) <-
    if Map.null blend
      then pure (Map.empty, Map.empty)
      else do
        keys <- runDb conn Q.fetchJazzComposers
        pure (Q.splitSeekByCorpus keys blend)
  let env = JazzEnv
        { jeConn :: DbConn
jeConn = DbConn
conn, jeGen :: GenIO
jeGen = Gen RealWorld
GenIO
gen
        , jeBlend :: ComposerWeights
jeBlend = ComposerWeights
jazzBlend, jeSteer :: ComposerWeights
jeSteer = ComposerWeights
steerBlend
        , jeStrength :: Double
jeStrength = GenConfig -> Double
_gcSteer GenConfig
gc
        , jeEntropy :: Double
jeEntropy  = GenConfig -> Double
_gcEntropy GenConfig
gc
        , jePctx :: ParsedContext
jePctx     = HarmonicContext -> ParsedContext
parseContextOnce (GenConfig -> HarmonicContext
_gcTonal GenConfig
gc)
        , jeVerbose :: Bool
jeVerbose  = Bool
verbose
        , jeSingle :: Bool
jeSingle   = GenConfig -> Int
_gcMaxAttempts GenConfig
gc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1
        , jeTrace :: IORef [[Char]]
jeTrace    = IORef [[Char]]
traceRef
        }
  when (verbose && not (Map.null blend)) $ do
    trace' env $ "genJ seek resolution: jazz blend " ++ showBlend jazzBlend
               ++ " | classical steer " ++ showBlend steerBlend
    when (Map.null jazzBlend) $
      trace' env "  (no jazz composers named — jazz walk runs on \"*\", classical names steer)"
  pure env
  where
    showBlend :: Map Text b -> [Char]
showBlend Map Text b
m
      | Map Text b -> Bool
forall k a. Map k a -> Bool
Map.null Map Text b
m = [Char]
"(none)"
      | Bool
otherwise  = [([Char], b)] -> [Char]
forall a. Show a => a -> [Char]
show [ (Text -> [Char]
T.unpack Text
k, b
v) | (Text
k, b
v) <- Map Text b -> [(Text, b)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text b
m ]

-- Map a cue state onto a jazz start node. Two intents:
--
-- * FRESH walks resolve by the bare functionality's HUB (pedal arrival
--   preferred, then most outgoing corpus mass — 'Q.resolveChangeCue').
--   Bar 1's stored movement is fictional (leadJ randomises it for
--   display variety, an auto-cue carries its drawn node's), and keying
--   node choice on it stranded rare qualities on skeletal
--   arrival-variant nodes: @( asc 4 -> m9 )@ has ONE out-edge where the
--   @( pedal -> m9 )@ hub has 127. The cue's structure still opens
--   bar 1 verbatim; only the walk's departure point changes.
-- * REGEN walks ('runJazzGenFrom') keep the exact (movement, name) key
--   when the graph has it — their cue is a real previous bar whose
--   arrival movement is genuine.
resolveStart :: JazzEnv -> Bool -> H.CadenceState -> IO T.Text
resolveStart :: JazzEnv -> Bool -> CadenceState -> IO Text
resolveStart JazzEnv
env Bool
exactFirst CadenceState
cue0 = do
  let conn :: DbConn
conn    = JazzEnv -> DbConn
jeConn JazzEnv
env
      cueSet :: [Int]
cueSet  = (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
cue0))
      cueMv :: Movement
cueMv   = Cadence -> Movement
H.cadenceMovement (CadenceState -> Cadence
H.stateCadence CadenceState
cue0)
      exactKey :: Text -> Text
exactKey Text
nm = Text
"( " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (Movement -> [Char]
forall a. Show a => a -> [Char]
show Movement
cueMv) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" )"
  case [Int] -> Maybe Text
J.jazzFunctionality [Int]
cueSet of
    Maybe Text
Nothing -> do
      let notice :: [Char]
notice = [Char]
"genJ: cue chord is outside the jazz vocabulary — starting from ( pedal -> m7 )"
      if JazzEnv -> Bool
jeSingle JazzEnv
env then [Char] -> IO ()
putStrLn [Char]
notice else JazzEnv -> [Char] -> IO ()
trace' JazzEnv
env [Char]
notice
      DbConn -> IO (Maybe Text) -> IO Text
orDefault DbConn
conn (Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing)
    Just Text
nm
      | Bool
exactFirst -> do
          probe <- DbConn
-> DbActionT [(ChangeCandidate, Double)]
-> IO [(ChangeCandidate, Double)]
forall a. DbConn -> DbActionT a -> IO a
runDb DbConn
conn (Text -> DbActionT [(ChangeCandidate, Double)]
Q.fetchChangeAggregate (Text -> Text
exactKey Text
nm))
          if not (null probe)
            then pure (exactKey nm)
            else do
              when (jeVerbose env) $
                trace' env $ "genJ: no jazz node " ++ T.unpack (exactKey nm)
                           ++ " — resolving by functionality"
              orDefault conn (runDb conn (Q.resolveChangeCue nm))
      | Bool
otherwise -> DbConn -> IO (Maybe Text) -> IO Text
orDefault DbConn
conn (DbConn -> DbActionT (Maybe Text) -> IO (Maybe Text)
forall a. DbConn -> DbActionT a -> IO a
runDb DbConn
conn (Text -> DbActionT (Maybe Text)
Q.resolveChangeCue Text
nm))
  where
    orDefault :: DbConn -> IO (Maybe Text) -> IO Text
orDefault DbConn
conn IO (Maybe Text)
action = do
      found <- IO (Maybe Text)
action
      case found of
        Just Text
k  -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
k
        Maybe Text
Nothing -> do
          fallback <- DbConn -> DbActionT (Maybe Text) -> IO (Maybe Text)
forall a. DbConn -> DbActionT a -> IO a
runDb DbConn
conn (Text -> DbActionT (Maybe Text)
Q.resolveChangeCue Text
"m7")
          maybe (error "genJ: jazz graph appears empty — run `stack run -- jazz` to ingest") pure fallback

-- The walk: n steps of fetch → blend → R-filter → steer → gamma pick.
jazzWalk :: JazzEnv -> T.Text -> H.CadenceState -> Int
         -> IO [H.CadenceState]
jazzWalk :: JazzEnv -> Text -> CadenceState -> Int -> IO [CadenceState]
jazzWalk JazzEnv
env Text
key0 CadenceState
cue0 Int
total = Text -> CadenceState -> Int -> IO [CadenceState]
go Text
key0 CadenceState
cue0 Int
total
  where
    conn :: DbConn
conn = JazzEnv -> DbConn
jeConn JazzEnv
env
    verbose :: Bool
verbose = JazzEnv -> Bool
jeVerbose JazzEnv
env
    go :: Text -> CadenceState -> Int -> IO [CadenceState]
go Text
_ CadenceState
_ Int
0 = [CadenceState] -> IO [CadenceState]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    go Text
key CadenceState
prevState Int
remaining = do
      -- 1-based like the classical chain, so BDRotate <a b> selectors
      -- stay phase-identical across families.
      let stepNum :: Int
stepNum = Int
total Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
remaining Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
      -- E: candidates under the jazz blend (aggregate for wildcard).
      pool0 <- if ComposerWeights -> Bool
forall k a. Map k a -> Bool
Map.null (JazzEnv -> ComposerWeights
jeBlend JazzEnv
env)
        then DbConn
-> DbActionT [(ChangeCandidate, Double)]
-> IO [(ChangeCandidate, Double)]
forall a. DbConn -> DbActionT a -> IO a
runDb DbConn
conn (Text -> DbActionT [(ChangeCandidate, Double)]
Q.fetchChangeAggregate Text
key)
        else do
          cands <- DbConn
-> DbActionT [(ChangeCandidate, ComposerWeights)]
-> IO [(ChangeCandidate, ComposerWeights)]
forall a. DbConn -> DbActionT a -> IO a
runDb DbConn
conn (Text -> DbActionT [(ChangeCandidate, ComposerWeights)]
Q.fetchChangeTransitions Text
key)
          pure (filter ((> 0) . snd) (Q.resolveWeights (jeBlend env) cands))
      pool1 <- if not (null pool0) then pure pool0 else do
        when verbose $ trace' env $ "  genJ: composer subgraph dead-ends at "
                                  ++ T.unpack key ++ " — widening to \"*\" for this step"
        runDb conn (Q.fetchChangeAggregate key)
      when (null pool1) $
        error ("genJ: no outgoing transitions from " ++ T.unpack key)
      -- R: the caller's tonal context, applied by the classical filter
      -- (arity-agnostic; roots resolve from the previous anchor exactly
      -- as jazz movement semantics require), including the rise\/fall
      -- direction spec resolved per step against the allowed root set —
      -- @hcRoots "3b fall1"@ walks the bass stepwise down the key's
      -- roots here exactly as it does in the classical walk. No fallback
      -- exists, so an emptied pool relaxes in stages, each with a
      -- notice: direction first (key\/roots membership kept), then the
      -- whole filter.
      mDir <- resolveBassDirection (jeGen env) stepNum (pcBassDirectionSpec (jePctx env))
      let prevBassPC = PitchClass -> Int
P.unPitchClass (NoteName -> PitchClass
P.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
prevState))
          bassTarget = case Maybe BassDirection
mDir of
            Maybe BassDirection
Nothing       -> Maybe Int
forall a. Maybe a
Nothing
            Just (Rise Int
n) -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> IntSet -> Int
nthAbove Int
n Int
prevBassPC (ParsedContext -> IntSet
pcAllowedBassNotes (JazzEnv -> ParsedContext
jePctx JazzEnv
env))
            Just (Fall Int
n) -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> IntSet -> Int
nthBelow Int
n Int
prevBassPC (ParsedContext -> IntSet
pcAllowedBassNotes (JazzEnv -> ParsedContext
jePctx JazzEnv
env))
          asCadence ChangeCandidate
c = [Char] -> Movement -> [PitchClass] -> Cadence
H.Cadence [Char]
"" (ChangeCandidate -> Movement
Q.ccMovement ChangeCandidate
c) ((Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
P.mkPitchClass (ChangeCandidate -> [Int]
Q.ccSet ChangeCandidate
c))
          rWith Maybe Int
t = [ (ChangeCandidate, Double)
p | p :: (ChangeCandidate, Double)
p@(ChangeCandidate
c, Double
_) <- [(ChangeCandidate, Double)]
pool1
                        , Maybe Int -> ParsedContext -> CadenceState -> Cadence -> Bool
matchesContextWithTarget Maybe Int
t (JazzEnv -> ParsedContext
jePctx JazzEnv
env) CadenceState
prevState (ChangeCandidate -> Cadence
asCadence ChangeCandidate
c) ]
          rPassed = Maybe Int -> [(ChangeCandidate, Double)]
rWith Maybe Int
bassTarget
          -- Kind-preserving middle stage: the exact nth-root target is
          -- unreachable, but the bass can still MOVE in the spec's
          -- direction (any falling arrival under fall, any rising under
          -- rise). Without this stage the corpus's heavy pedal edges
          -- (Unison, top corpus mass) win every relaxed step and a
          -- fall1 walk stalls on repeated roots.
          sameKind ChangeCandidate
c = case (Maybe BassDirection
mDir, ChangeCandidate -> Movement
Q.ccMovement ChangeCandidate
c) of
            (Just (Fall Int
_), H.Desc PitchClass
_) -> Bool
True
            (Just (Rise Int
_), H.Asc PitchClass
_)  -> Bool
True
            (Maybe BassDirection, Movement)
_                         -> Bool
False
          -- Direction with only the chord-colour containment freed: the
          -- bass still moves the right way onto an allowed root, but the
          -- structure above it may carry out-of-key colour tones —
          -- idiomatic for the corpus, and far truer to a fall spec than
          -- a pedal repeat.
          arrivalPC ChangeCandidate
c = (Int
prevBassPC Int -> Int -> Int
forall a. Num a => a -> a -> a
+ PitchClass -> Int
P.unPitchClass (Movement -> PitchClass
H.fromMovement (ChangeCandidate -> Movement
Q.ccMovement ChangeCandidate
c))) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
          rootOk ChangeCandidate
c = ParsedContext -> Bool
pcIsRootsWild (JazzEnv -> ParsedContext
jePctx JazzEnv
env)
                     Bool -> Bool -> Bool
|| ChangeCandidate -> Int
arrivalPC ChangeCandidate
c Int -> IntSet -> Bool
`IntSet.member` ParsedContext -> IntSet
pcAllowedBassNotes (JazzEnv -> ParsedContext
jePctx JazzEnv
env)
      pool2a <- if not (null rPassed) then pure rPassed else
        case bassTarget of
          Just Int
_
            | rKind :: [(ChangeCandidate, Double)]
rKind@((ChangeCandidate, Double)
_:[(ChangeCandidate, Double)]
_) <- ((ChangeCandidate, Double) -> Bool)
-> [(ChangeCandidate, Double)] -> [(ChangeCandidate, Double)]
forall a. (a -> Bool) -> [a] -> [a]
filter (ChangeCandidate -> Bool
sameKind (ChangeCandidate -> Bool)
-> ((ChangeCandidate, Double) -> ChangeCandidate)
-> (ChangeCandidate, Double)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChangeCandidate, Double) -> ChangeCandidate
forall a b. (a, b) -> a
fst) (Maybe Int -> [(ChangeCandidate, Double)]
rWith Maybe Int
forall a. Maybe a
Nothing) -> do
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ JazzEnv -> [Char] -> IO ()
trace' JazzEnv
env ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"  genJ: rise/fall target unreachable at "
                                          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
key [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" — held to direction, step size freed"
                [(ChangeCandidate, Double)] -> IO [(ChangeCandidate, Double)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(ChangeCandidate, Double)]
rKind
            | rChroma :: [(ChangeCandidate, Double)]
rChroma@((ChangeCandidate, Double)
_:[(ChangeCandidate, Double)]
_) <- [ (ChangeCandidate, Double)
p | p :: (ChangeCandidate, Double)
p@(ChangeCandidate
c, Double
_) <- [(ChangeCandidate, Double)]
pool1, ChangeCandidate -> Bool
sameKind ChangeCandidate
c, ChangeCandidate -> Bool
rootOk ChangeCandidate
c ] -> do
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ JazzEnv -> [Char] -> IO ()
trace' JazzEnv
env ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"  genJ: no in-key structure moves in the rise/fall direction at "
                                          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
key [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" — held to direction, colour tones freed"
                [(ChangeCandidate, Double)] -> IO [(ChangeCandidate, Double)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(ChangeCandidate, Double)]
rChroma
            | rNoDir :: [(ChangeCandidate, Double)]
rNoDir@((ChangeCandidate, Double)
_:[(ChangeCandidate, Double)]
_) <- Maybe Int -> [(ChangeCandidate, Double)]
rWith Maybe Int
forall a. Maybe a
Nothing -> do
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ JazzEnv -> [Char] -> IO ()
trace' JazzEnv
env ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"  genJ: no candidate moves in the rise/fall direction at "
                                          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
key [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" — direction relaxed for this step"
                [(ChangeCandidate, Double)] -> IO [(ChangeCandidate, Double)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(ChangeCandidate, Double)]
rNoDir
          Maybe Int
_ -> do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ JazzEnv -> [Char] -> IO ()
trace' JazzEnv
env ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"  genJ: tonal constraints exclude every candidate at "
                                      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
key [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" — relaxed for this step"
            [(ChangeCandidate, Double)] -> IO [(ChangeCandidate, Double)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(ChangeCandidate, Double)]
pool1
      -- Drift and pedal ride the same classical filters (both self-relax,
      -- so neither can empty the pool). Inversion spacing stays inert
      -- here: jazz slash structures are graph vocabulary, not a voicing
      -- choice the walk makes.
      let withCad [(ChangeCandidate, b)]
ps = [ (ChangeCandidate -> Cadence
asCadence ChangeCandidate
c, (ChangeCandidate, b)
p) | p :: (ChangeCandidate, b)
p@(ChangeCandidate
c, b
_) <- [(ChangeCandidate, b)]
ps ]
          pool2 = ((Cadence, (ChangeCandidate, Double)) -> (ChangeCandidate, Double))
-> [(Cadence, (ChangeCandidate, Double))]
-> [(ChangeCandidate, Double)]
forall a b. (a -> b) -> [a] -> [b]
map (Cadence, (ChangeCandidate, Double)) -> (ChangeCandidate, Double)
forall a b. (a, b) -> b
snd ([(Cadence, (ChangeCandidate, Double))]
 -> [(ChangeCandidate, Double)])
-> [(Cadence, (ChangeCandidate, Double))]
-> [(ChangeCandidate, Double)]
forall a b. (a -> b) -> a -> b
$ ParsedContext
-> CadenceState
-> [(Cadence, (ChangeCandidate, Double))]
-> [(Cadence, (ChangeCandidate, Double))]
forall a.
ParsedContext -> CadenceState -> [(Cadence, a)] -> [(Cadence, a)]
applyPedalFilter (JazzEnv -> ParsedContext
jePctx JazzEnv
env) CadenceState
prevState
                          ([(Cadence, (ChangeCandidate, Double))]
 -> [(Cadence, (ChangeCandidate, Double))])
-> [(Cadence, (ChangeCandidate, Double))]
-> [(Cadence, (ChangeCandidate, Double))]
forall a b. (a -> b) -> a -> b
$ Drift
-> CadenceState
-> [(Cadence, (ChangeCandidate, Double))]
-> [(Cadence, (ChangeCandidate, Double))]
forall a. Drift -> CadenceState -> [(Cadence, a)] -> [(Cadence, a)]
applyDriftFilter (ParsedContext -> Drift
pcDrift (JazzEnv -> ParsedContext
jePctx JazzEnv
env)) CadenceState
prevState
                          ([(Cadence, (ChangeCandidate, Double))]
 -> [(Cadence, (ChangeCandidate, Double))])
-> [(Cadence, (ChangeCandidate, Double))]
-> [(Cadence, (ChangeCandidate, Double))]
forall a b. (a -> b) -> a -> b
$ [(ChangeCandidate, Double)]
-> [(Cadence, (ChangeCandidate, Double))]
forall {b}.
[(ChangeCandidate, b)] -> [(Cadence, (ChangeCandidate, b))]
withCad [(ChangeCandidate, Double)]
pool2a
      -- E: classical steer.
      pool <- if Map.null (jeSteer env) then pure pool2 else do
        let triadKey = [Char] -> Text
T.pack (Cadence -> [Char]
forall a. Show a => a -> [Char]
show (CadenceState -> Cadence
H.stateCadence (CadenceState -> CadenceState
H.walkTriadState CadenceState
prevState)))
        recs0 <- runDb conn (Q.fetchTransitions triadKey)
        -- Steer on the blend's strongest recommendations only: the top
        -- of the classical ranking is "what this composer would most
        -- likely do next"; matching their entire vocabulary would boost
        -- nearly everything and discriminate nothing.
        let recs = Int -> [(Cadence, Double)] -> [(Cadence, Double)]
forall a. Int -> [a] -> [a]
take Int
12 (((Cadence, Double) -> Bool)
-> [(Cadence, Double)] -> [(Cadence, Double)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0) (Double -> Bool)
-> ((Cadence, Double) -> Double) -> (Cadence, Double) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cadence, Double) -> Double
forall a b. (a, b) -> b
snd) (ComposerWeights
-> [(Cadence, ComposerWeights)] -> [(Cadence, Double)]
forall a.
ComposerWeights -> [(a, ComposerWeights)] -> [(a, Double)]
Q.resolveWeights (JazzEnv -> ComposerWeights
jeSteer JazzEnv
env) [(Cadence, ComposerWeights)]
recs0))
            maxW = [Double] -> Double
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Double
1 Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: ((Cadence, Double) -> Double) -> [(Cadence, Double)] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (Cadence, Double) -> Double
forall a b. (a, b) -> b
snd [(Cadence, Double)]
recs)
            matches ChangeCandidate
cand (Cadence
rc, b
_) =
              (Movement, [PitchClass]) -> Movement
forall a b. (a, b) -> a
fst (Cadence -> (Movement, [PitchClass])
H.deconstructCadence Cadence
rc) Movement -> Movement -> Bool
forall a. Eq a => a -> a -> Bool
== ChangeCandidate -> Movement
Q.ccMovement ChangeCandidate
cand
              Bool -> Bool -> Bool
&& let triad :: [Int]
triad = (PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
P.unPitchClass ((Movement, [PitchClass]) -> [PitchClass]
forall a b. (a, b) -> b
snd (Cadence -> (Movement, [PitchClass])
H.deconstructCadence Cadence
rc))
                 in [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ChangeCandidate -> [Int]
Q.ccSet ChangeCandidate
cand) [Int]
triad) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
triad
            boost (ChangeCandidate
cand, Double
sc) =
              (ChangeCandidate
cand, Double
sc Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ JazzEnv -> Double
jeStrength JazzEnv
env Double -> Double -> Double
forall a. Num a => a -> a -> a
* [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ Double
w Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
maxW | r :: (Cadence, Double)
r@(Cadence
_, Double
w) <- [(Cadence, Double)]
recs, ChangeCandidate -> (Cadence, Double) -> Bool
forall {b}. ChangeCandidate -> (Cadence, b) -> Bool
matches ChangeCandidate
cand (Cadence, Double)
r ]))
            boosted = ((ChangeCandidate, Double) -> (ChangeCandidate, Double))
-> [(ChangeCandidate, Double)] -> [(ChangeCandidate, Double)]
forall a b. (a -> b) -> [a] -> [b]
map (ChangeCandidate, Double) -> (ChangeCandidate, Double)
boost [(ChangeCandidate, Double)]
pool2
            nBoosted = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ () | ((ChangeCandidate
_, Double
b), (ChangeCandidate
_, Double
o)) <- [(ChangeCandidate, Double)]
-> [(ChangeCandidate, Double)]
-> [((ChangeCandidate, Double), (ChangeCandidate, Double))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(ChangeCandidate, Double)]
boosted [(ChangeCandidate, Double)]
pool2, Double
b Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
o ]
        when verbose $
          trace' env $ "  steer: classical recs " ++ show (length recs)
                   ++ ", boosted " ++ show nBoosted ++ "/" ++ show (length pool2) ++ " candidates"
        pure (sortBy (comparing (Down . snd)) boosted)
      -- T: the shared entropy dial.
      idx <- gammaIndexScaledWith (jeGen env) (jeEntropy env) (length pool)
      let (cand, score) = pool !! idx
          prevRootPC = NoteName -> PitchClass
P.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
prevState)
          nextRootPC = PitchClass
prevRootPC PitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+ Movement -> PitchClass
H.fromMovement (ChangeCandidate -> Movement
Q.ccMovement ChangeCandidate
cand)
          nextRoot   = PitchClass -> NoteName
P.flat PitchClass
nextRootPC
          nextState0 = NoteName -> Movement -> [Int] -> CadenceState
H.mkCadenceStatePCs NoteName
nextRoot (ChangeCandidate -> Movement
Q.ccMovement ChangeCandidate
cand) (ChangeCandidate -> [Int]
Q.ccSet ChangeCandidate
cand)
          -- Rename with the jazz namer so grids show corpus vocabulary
          -- ("13sus4") rather than the generic chord namer's spelling.
          nextState  = case [Int] -> Maybe Text
J.jazzFunctionality (ChangeCandidate -> [Int]
Q.ccSet ChangeCandidate
cand) of
            Just Text
nm -> CadenceState
nextState0
              { H.stateCadence = (H.stateCadence nextState0)
                  { H.cadenceFunctionality = T.unpack nm } }
            Maybe Text
Nothing -> CadenceState
nextState0
      when verbose $
        trace' env $ "  " ++ T.unpack key ++ " -> " ++ T.unpack (Q.ccShow cand)
                 ++ "  [pick " ++ show (idx + 1) ++ "/" ++ show (length pool)
                 ++ ", score " ++ show (fromIntegral (round (score * 100) :: Int) / 100 :: Double) ++ "]"
      rest <- go (Q.ccShow cand) nextState (remaining - 1 :: Int)
      pure (nextState : rest)

-- Minimal diagnostics record: the jazz walk renders its trace during
-- generation into 'gdJazzTrace'; gdSteps stays empty and emitFinalised
-- prints header + collected trace + grid — once, for the attempt winner.
jazzDiag :: GenConfig -> H.CadenceState -> Prog.Progression -> [String] -> GenerationDiagnostics
jazzDiag :: GenConfig
-> CadenceState -> Progression -> [[Char]] -> GenerationDiagnostics
jazzDiag GenConfig
gc CadenceState
cue0 Progression
prog [[Char]]
traceLines = GenerationDiagnostics
  { gdStartCadence :: [Char]
gdStartCadence = Cadence -> [Char]
forall a. Show a => a -> [Char]
show (CadenceState -> Cadence
H.stateCadence CadenceState
cue0)
  , gdStartRoot :: [Char]
gdStartRoot    = NoteName -> [Char]
forall a. Show a => a -> [Char]
show (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
cue0)
  , gdRequestedLen :: Int
gdRequestedLen = GenConfig -> Int
_gcLen GenConfig
gc
  , gdActualLen :: Int
gdActualLen    = Progression -> Int
Prog.progLength Progression
prog
  , gdEntropy :: Double
gdEntropy      = GenConfig -> Double
_gcEntropy GenConfig
gc
  , gdSteps :: [StepDiagnostic]
gdSteps        = []
  , gdProgression :: Progression
gdProgression  = Progression
prog
  , gdJazzTrace :: [[Char]]
gdJazzTrace    = [[Char]]
traceLines
  }


-- |Draw an uncued 'Harmonic.Framework.Builder.genJ' starting chord from
-- the jazz graph itself: the STRUCTURE is sampled from the Change nodes
-- proportionally to outgoing corpus mass (the corpus's own sense of a
-- common departure point), and the ROOT comes from the caller's tonal
-- context — Change nodes are zero-form, so the two are independent.
-- Structure-in-key containment is preferred but relaxes when the
-- context admits no node whole, mirroring the walk's own per-step
-- relaxation; roots stay hard-filtered. Replaces the whole-corpus
-- random major triad, which is not jazz vocabulary at all — and which
-- @resolveStart@ then flagged as outside it on every uncued run.
jazzStartCue :: GenConfig -> IO H.CadenceState
jazzStartCue :: GenConfig -> IO CadenceState
jazzStartCue GenConfig
gc = do
  GenConfig -> IO ()
jazzGuardSeek GenConfig
gc
  conn <- IO DbConn
connectNeo4j
  rng  <- createSystemRandom
  starts0 <- runDb conn Q.fetchChangeStarts
  when (null starts0) $
    error "genJ: jazz graph appears empty — run `stack run -- jazz` to ingest"
  -- Never open on a slash structure: chord-over-degree nodes (a "/" in
  -- the node key — 7/3, 69/4 …) stay walkable but are not departure
  -- points, and a triad-sized node that would re-name as an inversion
  -- is rejected the same way the classical pools reject it.
  let notSlash (ChangeCandidate
cand, b
_) =
        Bool -> Bool
not (Text
"/" Text -> Text -> Bool
`T.isInfixOf` ChangeCandidate -> Text
Q.ccShow ChangeCandidate
cand)
        Bool -> Bool -> Bool
&& CadenceState -> Bool
rootPositionCue (NoteName -> Movement -> [Int] -> CadenceState
H.mkCadenceStatePCs NoteName
P.C (ChangeCandidate -> Movement
Q.ccMovement ChangeCandidate
cand) (ChangeCandidate -> [Int]
Q.ccSet ChangeCandidate
cand))
      starts = case ((ChangeCandidate, Double) -> Bool)
-> [(ChangeCandidate, Double)] -> [(ChangeCandidate, Double)]
forall a. (a -> Bool) -> [a] -> [a]
filter (ChangeCandidate, Double) -> Bool
forall {b}. (ChangeCandidate, b) -> Bool
notSlash [(ChangeCandidate, Double)]
starts0 of
                 [] -> [(ChangeCandidate, Double)]
starts0
                 [(ChangeCandidate, Double)]
ss -> [(ChangeCandidate, Double)]
ss
      pctx = HarmonicContext -> ParsedContext
parseContextOnce (GenConfig -> HarmonicContext
_gcTonal GenConfig
gc)
      keyConstrained = Bool -> Bool
not (ParsedContext -> Bool
pcIsKeyWild ParsedContext
pctx Bool -> Bool -> Bool
&& ParsedContext -> Bool
pcIsOvertonesWild ParsedContext
pctx)
      allowed = ParsedContext -> IntSet
pcEffectiveOvertones ParsedContext
pctx
      roots | Bool -> Bool
not (ParsedContext -> Bool
pcIsRootsWild ParsedContext
pctx) = IntSet -> [Int]
IntSet.toList (ParsedContext -> IntSet
pcAllowedBassNotes ParsedContext
pctx)
            | Bool
keyConstrained           = IntSet -> [Int]
IntSet.toList IntSet
allowed
            | Bool
otherwise                = [Int
0 .. Int
11]
      inCtx Int
r ChangeCandidate
cand =
        (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Int
i -> let p :: Int
p = (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
r) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
                   in Int
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
r Bool -> Bool -> Bool
|| Int
p Int -> IntSet -> Bool
`IntSet.member` IntSet
allowed)
            (ChangeCandidate -> [Int]
Q.ccSet ChangeCandidate
cand)
      pool0 = [ ((ChangeCandidate
cand, Int
r), Double
w) | (ChangeCandidate
cand, Double
w) <- [(ChangeCandidate, Double)]
starts, Int
r <- [Int]
roots ]
      pool  | Bool -> Bool
not Bool
keyConstrained = [((ChangeCandidate, Int), Double)]
pool0
            | Bool
otherwise = case [ ((ChangeCandidate, Int), Double)
p | p :: ((ChangeCandidate, Int), Double)
p@((ChangeCandidate
cand, Int
r), Double
_) <- [((ChangeCandidate, Int), Double)]
pool0, Int -> ChangeCandidate -> Bool
inCtx Int
r ChangeCandidate
cand ] of
                            [] -> [((ChangeCandidate, Int), Double)]
pool0
                            [((ChangeCandidate, Int), Double)]
ps -> [((ChangeCandidate, Int), Double)]
ps
      total = [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((((ChangeCandidate, Int), Double) -> Double)
-> [((ChangeCandidate, Int), Double)] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map ((ChangeCandidate, Int), Double) -> Double
forall a b. (a, b) -> b
snd [((ChangeCandidate, Int), Double)]
pool)
  case pool of
    [] -> [Char] -> IO CadenceState
forall a. HasCallStack => [Char] -> a
error [Char]
"genJ: no viable start (roots filter resolved to nothing?)"
    (((ChangeCandidate, Int), Double)
p0 : [((ChangeCandidate, Int), Double)]
_) -> do
      u <- (Double, Double) -> Gen RealWorld -> IO Double
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *).
StatefulGen g m =>
(Double, Double) -> g -> m Double
uniformRM (Double
0, Double
total) Gen RealWorld
rng
      let walkTo Double
_ []  = ((ChangeCandidate, Int), Double) -> (ChangeCandidate, Int)
forall a b. (a, b) -> a
fst ((ChangeCandidate, Int), Double)
p0
          walkTo Double
_ [((ChangeCandidate, Int), Double)
x] = ((ChangeCandidate, Int), Double) -> (ChangeCandidate, Int)
forall a b. (a, b) -> a
fst ((ChangeCandidate, Int), Double)
x
          walkTo Double
acc (x :: ((ChangeCandidate, Int), Double)
x@((ChangeCandidate, Int)
_, Double
w) : [((ChangeCandidate, Int), Double)]
xs)
            | Double
acc Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
u = ((ChangeCandidate, Int), Double) -> (ChangeCandidate, Int)
forall a b. (a, b) -> a
fst ((ChangeCandidate, Int), Double)
x
            | Bool
otherwise    = Double
-> [((ChangeCandidate, Int), Double)] -> (ChangeCandidate, Int)
walkTo (Double
acc Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w) [((ChangeCandidate, Int), Double)]
xs
          (cand, rootPC) = walkTo 0 pool
          spelling = EnharmonicSpelling
-> (EnharmonicSpelling -> EnharmonicSpelling)
-> Maybe EnharmonicSpelling
-> EnharmonicSpelling
forall b a. b -> (a -> b) -> Maybe a -> b
maybe EnharmonicSpelling
H.FlatSpelling EnharmonicSpelling -> EnharmonicSpelling
forall a. a -> a
id (ParsedContext -> Maybe EnharmonicSpelling
pcKeySpelling ParsedContext
pctx)
          rootName = EnharmonicSpelling -> PitchClass -> NoteName
H.enharmonicFunc EnharmonicSpelling
spelling (Int -> PitchClass
P.mkPitchClass Int
rootPC)
          cue0 = NoteName -> Movement -> [Int] -> CadenceState
H.mkCadenceStatePCs NoteName
rootName (ChangeCandidate -> Movement
Q.ccMovement ChangeCandidate
cand) (ChangeCandidate -> [Int]
Q.ccSet ChangeCandidate
cand)
      -- Stamp the corpus vocabulary name, exactly as the walk does, so
      -- bar 1 prints "13sus4" rather than the generic chord namer's
      -- spelling. Auto-cues are never slash shapes (filtered above), so
      -- the name is always a plain quality.
      pure $ case J.jazzFunctionality (Q.ccSet cand) of
        Just Text
nm -> CadenceState
cue0 { H.stateCadence = (H.stateCadence cue0)
                            { H.cadenceFunctionality = T.unpack nm } }
        Maybe Text
Nothing -> CadenceState
cue0