-- |
-- Module      : Harmonic.Evaluation.Scoring.Progression
-- Description : Whole-progression scoring for rank-and-select generation
--
-- Composable score of a 'PC.ProgressionContext' along four axes:
--
--   * 'psRootMotion'   — per-edge root motion smoothness (Hindemith-derived)
--   * 'psVoiceLeading' — cyclic voice-leading cost over the triad layer
--   * 'psCadenceFav'   — Neo4j-backed cadence transition favourability
--                        (0.0 if computed offline; online callers override)
--   * 'psModeValidity' — fraction of bars whose mode layer carries the
--                        expected 7-PC chroma (Phase 1 invariant guarantees
--                        walk-generated progressions score 1.0)
--
-- Each component lives in @[0, 1]@ with higher = better. 'totalScore'
-- combines components via a weighted sum; 'defaultWeights' makes
-- cadence-favourability the dominant axis (the user's stated preference).
--
-- The normalisations applied to per-component raw measurements are
-- intentionally simple placeholders — to be refined from observed
-- distributions once multi-attempt generation is live (see the project's
-- data-driven tuning memory). The function signatures are stable; only the
-- internal transforms inside @scoreRootMotion@ \/ @scoreVoiceLeading@ \/
-- @scoreModeValidity@ are subject to retuning.
module Harmonic.Evaluation.Scoring.Progression
  ( -- * Score record
    ProgressionScore(..)
  , ProgressionScoreWeights(..)
    -- * Default weights
  , defaultWeights
  , defaultWeightsOffline
    -- * Scoring (offline)
  , scoreProgression
  , totalScore
    -- * Cadence-favourability (online + pure helper)
  , TransitionMap
  , cadenceFavFromMap
  , scoreProgressionOnline
  , scoreProgressionJazz
    -- * Polytonal scoring (genE)
  , PolyScore(..)
  , polyLayerWeights
  , polyDivergenceWeight
  , polyDivergence
  , scorePoly
  , scorePolyOnline
  , jazzChangeKey
  , TransitionCache
  , newTransitionCache
  , resolveJazzBlend
  , cadenceFavFromKeys
  , computeCadenceFav
  ) where

import           Control.Monad (forM)
import           Control.Monad.IO.Class (liftIO)
import           Data.IORef (IORef, newIORef, readIORef, modifyIORef')
import           Data.Bifunctor (first)
import           Data.Foldable (toList)
import qualified Data.Map.Strict as Map
import           Data.Map.Strict (Map)
import qualified Data.Text as T
import           Data.Text (Text)
import           Data.List (nub, sort)

import           Harmonic.Database (DbActionT)

import qualified Harmonic.Rules.Types.Progression as Prog
import qualified Harmonic.Rules.Types.ProgressionContext as PC
import qualified Harmonic.Rules.Types.Harmony as H
import qualified Harmonic.Rules.Types.Pitch as P
import qualified Harmonic.Rules.Import.Jazz as J
import qualified Harmonic.Evaluation.Scoring.Dissonance as D
import qualified Harmonic.Evaluation.Scoring.VoiceLeading as VL
import qualified Harmonic.Evaluation.Database.Query as Q

-------------------------------------------------------------------------------
-- Score record
-------------------------------------------------------------------------------

-- |Per-progression scoring breakdown. Each component is in @[0, 1]@; higher
-- is better.
data ProgressionScore = ProgressionScore
  { ProgressionScore -> Double
psRootMotion   :: !Double
  , ProgressionScore -> Double
psVoiceLeading :: !Double
  , ProgressionScore -> Double
psCadenceFav   :: !Double
  , ProgressionScore -> Double
psModeValidity :: !Double
  } deriving (Int -> ProgressionScore -> ShowS
[ProgressionScore] -> ShowS
ProgressionScore -> String
(Int -> ProgressionScore -> ShowS)
-> (ProgressionScore -> String)
-> ([ProgressionScore] -> ShowS)
-> Show ProgressionScore
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProgressionScore -> ShowS
showsPrec :: Int -> ProgressionScore -> ShowS
$cshow :: ProgressionScore -> String
show :: ProgressionScore -> String
$cshowList :: [ProgressionScore] -> ShowS
showList :: [ProgressionScore] -> ShowS
Show, ProgressionScore -> ProgressionScore -> Bool
(ProgressionScore -> ProgressionScore -> Bool)
-> (ProgressionScore -> ProgressionScore -> Bool)
-> Eq ProgressionScore
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProgressionScore -> ProgressionScore -> Bool
== :: ProgressionScore -> ProgressionScore -> Bool
$c/= :: ProgressionScore -> ProgressionScore -> Bool
/= :: ProgressionScore -> ProgressionScore -> Bool
Eq)

-- |Weights applied to each scoring axis in 'totalScore'. Conventionally
-- sum to 1.0 so the resulting total stays in @[0, 1]@.
data ProgressionScoreWeights = ProgressionScoreWeights
  { ProgressionScoreWeights -> Double
wRootMotion   :: !Double
  , ProgressionScoreWeights -> Double
wVoiceLeading :: !Double
  , ProgressionScoreWeights -> Double
wCadenceFav   :: !Double
  , ProgressionScoreWeights -> Double
wModeValidity :: !Double
  } deriving (Int -> ProgressionScoreWeights -> ShowS
[ProgressionScoreWeights] -> ShowS
ProgressionScoreWeights -> String
(Int -> ProgressionScoreWeights -> ShowS)
-> (ProgressionScoreWeights -> String)
-> ([ProgressionScoreWeights] -> ShowS)
-> Show ProgressionScoreWeights
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProgressionScoreWeights -> ShowS
showsPrec :: Int -> ProgressionScoreWeights -> ShowS
$cshow :: ProgressionScoreWeights -> String
show :: ProgressionScoreWeights -> String
$cshowList :: [ProgressionScoreWeights] -> ShowS
showList :: [ProgressionScoreWeights] -> ShowS
Show, ProgressionScoreWeights -> ProgressionScoreWeights -> Bool
(ProgressionScoreWeights -> ProgressionScoreWeights -> Bool)
-> (ProgressionScoreWeights -> ProgressionScoreWeights -> Bool)
-> Eq ProgressionScoreWeights
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProgressionScoreWeights -> ProgressionScoreWeights -> Bool
== :: ProgressionScoreWeights -> ProgressionScoreWeights -> Bool
$c/= :: ProgressionScoreWeights -> ProgressionScoreWeights -> Bool
/= :: ProgressionScoreWeights -> ProgressionScoreWeights -> Bool
Eq)

-------------------------------------------------------------------------------
-- Default weights
-------------------------------------------------------------------------------

-- |Cadence-favourability dominant: @0.5@ fav, @0.25@ each on root motion
-- and voice leading. Mode validity carries NO weight: it is structurally
-- @1.0@ on every walk-generated progression (proven — see CLAUDE.md's
-- mode-invariant note), so weighting it only compressed the usable score
-- range to @[0.2, 1.0]@. It remains a hard viability /gate/
-- (@psModeValidity >= 1.0@) in the attempt loop, which is the one job it
-- can actually do. The three live weights are the old @0.2\/0.2\/0.4@
-- renormalised — rankings are order-identical to the previous scale via
-- @new = (old − 0.2) \/ 0.8@.
defaultWeights :: ProgressionScoreWeights
defaultWeights :: ProgressionScoreWeights
defaultWeights = ProgressionScoreWeights
  { wRootMotion :: Double
wRootMotion   = Double
0.25
  , wVoiceLeading :: Double
wVoiceLeading = Double
0.25
  , wCadenceFav :: Double
wCadenceFav   = Double
0.5
  , wModeValidity :: Double
wModeValidity = Double
0
  }

-- |Offline-mode weights — cadence favourability dropped (no graph), mode
-- validity gate-only as in 'defaultWeights', the two live axes
-- renormalised. Offline totals now span the full @[0, 1]@ instead of
-- having a @1\/3@ floor.
defaultWeightsOffline :: ProgressionScoreWeights
defaultWeightsOffline :: ProgressionScoreWeights
defaultWeightsOffline = ProgressionScoreWeights
  { wRootMotion :: Double
wRootMotion   = Double
0.5
  , wVoiceLeading :: Double
wVoiceLeading = Double
0.5
  , wCadenceFav :: Double
wCadenceFav   = Double
0
  , wModeValidity :: Double
wModeValidity = Double
0
  }

-------------------------------------------------------------------------------
-- Scoring
-------------------------------------------------------------------------------

-- |Pure score: computes root-motion, voice-leading, and mode-validity
-- components. 'psCadenceFav' is left at @0.0@ — online callers override
-- this field after consulting the graph.
scoreProgression :: PC.ProgressionContext -> ProgressionScore
scoreProgression :: ProgressionContext -> ProgressionScore
scoreProgression ProgressionContext
pc = ProgressionScore
  { psRootMotion :: Double
psRootMotion   = Progression -> Double
scoreRootMotion   (ProgressionContext -> Progression
PC.triadLayer ProgressionContext
pc)
  , psVoiceLeading :: Double
psVoiceLeading = Progression -> Double
scoreVoiceLeading (ProgressionContext -> Progression
PC.triadLayer ProgressionContext
pc)
  , psCadenceFav :: Double
psCadenceFav   = Double
0.0
  , psModeValidity :: Double
psModeValidity = ProgressionContext -> Double
scoreModeValidity ProgressionContext
pc
  }

-- |Average per-edge root-motion score, cyclic (includes wrap-around from
-- last to first bar), mapped from Hindemith penalty space @[1, 6]@ to
-- @[0, 1]@ where 1 = perfect (every edge a P4 or P5).
scoreRootMotion :: Prog.Progression -> Double
scoreRootMotion :: Progression -> Double
scoreRootMotion Progression
prog =
  let states :: [CadenceState]
states  = Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Prog.unProgression Progression
prog)
      n :: Int
n       = [CadenceState] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CadenceState]
states
  in if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 then Double
1.0
     else
       let rootPC :: CadenceState -> Int
rootPC CadenceState
s = PitchClass -> Int
P.unPitchClass (NoteName -> PitchClass
P.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
s))
           rootPCs :: [Int]
rootPCs  = (CadenceState -> Int) -> [CadenceState] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map CadenceState -> Int
rootPC [CadenceState]
states
           edges :: [(Int, Int)]
edges    = [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
rootPCs (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
1 [Int]
rootPCs [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
1 [Int]
rootPCs)
           rawSum :: Double
rawSum   = [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer
D.rootMotionScore ((Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
a) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12))
                          | (Int
a, Int
b) <- [(Int, Int)]
edges
                          ] :: Double
           avgRaw :: Double
avgRaw   = Double
rawSum Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([(Int, Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, Int)]
edges)
       in Double -> Double
clamp01 ((Double
6.0 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
avgRaw) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
5.0)

-- |Cyclic voice-leading cost over an HONEST voicing extraction (sorted
-- absolute PCs per bar, full cardinality), linearly mapped from per-edge
-- cost @[vlLowAnchorCal, vlHighAnchorCal]@ to score @[1, 0]@.
--
-- Anchor calibration (2026-08-20, data-driven): 36-sample online probe —
-- gen \/ genE \/ genVI × len {8, 16} × entropy {0.2, 0.4, 0.6}, two runs
-- each (genVI cued in-strata; its random-cue empties excluded). The genE
-- column predates the polytonal rewrite (it measured the retired fused
-- 4-note surface; today's genE scores its foundation, a plain classical
-- walk in gen's band) — anchors stand pending re-measurement. Observed
-- per-edge cyclic costs: gen 2.5–5.75, genE(fused) 3.25–12.0, genVI 3.0–7.1;
-- combined p10 ≈ 3.0, p90 ≈ 7.1. Anchors set at 3.0 (excellent) \/ 8.0
-- (poor) — p90 plus margin, so only genuinely rough runs bottom out.
-- (The previous 10\/30 anchors were calibrated against the old
-- unsorted\/mod-12-wrapped measurement artefact and do not transfer.)
vlLowAnchorCal, vlHighAnchorCal :: Double
vlLowAnchorCal :: Double
vlLowAnchorCal  = Double
3.0
vlHighAnchorCal :: Double
vlHighAnchorCal = Double
8.0

scoreVoiceLeading :: Prog.Progression -> Double
scoreVoiceLeading :: Progression -> Double
scoreVoiceLeading Progression
prog
  -- Fewer than two bars: no edges exist to measure — explicit neutral
  -- score (previously an accidental perfect 1.0 via the clamp).
  | [CadenceState] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CadenceState]
states Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 = Double
0.5
  | Bool
otherwise =
      let voicings :: [[Int]]
voicings = (CadenceState -> [Int]) -> [CadenceState] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map CadenceState -> [Int]
honestVoicing [CadenceState]
states
          n :: Int
n        = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 ([[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
voicings)
          cost :: Double
cost     = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([[Int]] -> Int
VL.cyclicCost [[Int]]
voicings) :: Double
          perEdge :: Double
perEdge  = Double
cost Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
      in Double -> Double
clamp01 ((Double
vlHighAnchor Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
perEdge) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
vlHighAnchor Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
vlLowAnchor))
  where
    states :: [CadenceState]
states = Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Prog.unProgression Progression
prog)
    -- Honest per-bar extraction: sorted absolute PCs at full cardinality.
    -- Replaces 'Prog.literalVoicing', which returned UNSORTED,
    -- mod-12-wrapped pseudo-voicings via the toTriad reduction (an
    -- A-rooted [0,4,7] bar read as [9,1,4], so C→A root motion measured
    -- 9 semitones instead of 3 — the old 10\/30 anchors were calibrated
    -- against that artefact). Hand-built 4-note chains score the heard
    -- surface; mixed-cardinality bars score real alignment costs.
    honestVoicing :: CadenceState -> [Int]
honestVoicing CadenceState
cs =
      let r :: Int
r = PitchClass -> Int
P.unPitchClass (NoteName -> PitchClass
P.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
cs))
      in [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort [ (PitchClass -> Int
P.unPitchClass PitchClass
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
              | PitchClass
i <- Cadence -> [PitchClass]
H.cadenceIntervals (CadenceState -> Cadence
H.stateCadence CadenceState
cs) ]
    -- Anchors recalibrated 2026-08-20 against the honest measurement:
    -- online probe gen\/genVI\/genE(fused, pre-rewrite) × len 8\/16 × entropy {0.2,0.4,0.6},
    -- per-edge cyclic costs of sorted absolute-PC voicings. See the
    -- calibration values below (updated by the probe in the VL pass).
    vlLowAnchor :: Double
vlLowAnchor  = Double
vlLowAnchorCal
    vlHighAnchor :: Double
vlHighAnchor = Double
vlHighAnchorCal

-- |Fraction of bars whose mode-layer cardinality is 7 (i.e. 'Harmonic.Rules.Types.Scale.ModeOk' shape).
--
-- For walk-generated 'Harmonic.Framework.Builder.genP' contexts (pcProvenance = Just) the Phase 1
-- invariant guarantees @1.0@. The gate is PROVENANCE, not layer content:
-- contexts without it (gen\/genJ chordscale-derived layers — 7-PC by
-- construction — genE partner triads, hand-built material) return @1.0@
-- because the strata mode-validity contract only exists where a strata
-- walk produced the layers.
scoreModeValidity :: PC.ProgressionContext -> Double
scoreModeValidity :: ProgressionContext -> Double
scoreModeValidity ProgressionContext
pc =
  case ProgressionContext -> Maybe (Seq (Tristrata, StrataLabel))
PC.pcProvenance ProgressionContext
pc of
    Maybe (Seq (Tristrata, StrataLabel))
Nothing -> Double
1.0
    Just Seq (Tristrata, StrataLabel)
_  ->
      let states :: [CadenceState]
states = Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Prog.unProgression (ProgressionContext -> Progression
PC.modeLayer ProgressionContext
pc))
          n :: Int
n      = [CadenceState] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CadenceState]
states
      in if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Double
1.0
         else let ok :: Int
ok = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ () | CadenceState
s <- [CadenceState]
states
                                   , [PitchClass] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Cadence -> [PitchClass]
H.cadenceIntervals (CadenceState -> Cadence
H.stateCadence CadenceState
s)) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
7
                                   ]
              in Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ok Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n

-- |Weighted sum of components. Conventional weights sum to 1.0 → total
-- in @[0, 1]@.
totalScore :: ProgressionScoreWeights -> ProgressionScore -> Double
totalScore :: ProgressionScoreWeights -> ProgressionScore -> Double
totalScore ProgressionScoreWeights
w ProgressionScore
ps =
    ProgressionScoreWeights -> Double
wRootMotion   ProgressionScoreWeights
w Double -> Double -> Double
forall a. Num a => a -> a -> a
* ProgressionScore -> Double
psRootMotion   ProgressionScore
ps
  Double -> Double -> Double
forall a. Num a => a -> a -> a
+ ProgressionScoreWeights -> Double
wVoiceLeading ProgressionScoreWeights
w Double -> Double -> Double
forall a. Num a => a -> a -> a
* ProgressionScore -> Double
psVoiceLeading ProgressionScore
ps
  Double -> Double -> Double
forall a. Num a => a -> a -> a
+ ProgressionScoreWeights -> Double
wCadenceFav   ProgressionScoreWeights
w Double -> Double -> Double
forall a. Num a => a -> a -> a
* ProgressionScore -> Double
psCadenceFav   ProgressionScore
ps
  Double -> Double -> Double
forall a. Num a => a -> a -> a
+ ProgressionScoreWeights -> Double
wModeValidity ProgressionScoreWeights
w Double -> Double -> Double
forall a. Num a => a -> a -> a
* ProgressionScore -> Double
psModeValidity ProgressionScore
ps

-------------------------------------------------------------------------------
-- Polytonal scoring (genE)
-------------------------------------------------------------------------------

-- |Composite score for a polytonal ('PC.FPoly') context. The other three
-- families are one progression wearing three hats; genE is genuinely three
-- progressions, so ranking its attempts on the foundation alone would leave
-- the partner chains — the whole point of the family — unselected.
data PolyScore = PolyScore
  { PolyScore -> ProgressionScore
pyT          :: !ProgressionScore  -- ^ Foundation layer, scored alone
  , PolyScore -> ProgressionScore
pyS          :: !ProgressionScore  -- ^ First partner chain
  , PolyScore -> ProgressionScore
pyM          :: !ProgressionScore  -- ^ Second partner chain
  , PolyScore -> Double
pyQuality    :: !Double            -- ^ Weighted blend of the three, @[0, 1]@
  , PolyScore -> Double
pyDivergence :: !Double            -- ^ How far apart the layers stand, @[0, 1]@
  , PolyScore -> Double
pyTotal      :: !Double            -- ^ Ranking value, @[0, 1]@
  } deriving (Int -> PolyScore -> ShowS
[PolyScore] -> ShowS
PolyScore -> String
(Int -> PolyScore -> ShowS)
-> (PolyScore -> String)
-> ([PolyScore] -> ShowS)
-> Show PolyScore
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PolyScore -> ShowS
showsPrec :: Int -> PolyScore -> ShowS
$cshow :: PolyScore -> String
show :: PolyScore -> String
$cshowList :: [PolyScore] -> ShowS
showList :: [PolyScore] -> ShowS
Show, PolyScore -> PolyScore -> Bool
(PolyScore -> PolyScore -> Bool)
-> (PolyScore -> PolyScore -> Bool) -> Eq PolyScore
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PolyScore -> PolyScore -> Bool
== :: PolyScore -> PolyScore -> Bool
$c/= :: PolyScore -> PolyScore -> Bool
/= :: PolyScore -> PolyScore -> Bool
Eq)

-- |Layer weights for 'pyQuality': foundation, then each partner. The
-- foundation owns the bass and the harmonic spine, so it carries half; the
-- partners colour it and split the rest.
polyLayerWeights :: (Double, Double, Double)
polyLayerWeights :: (Double, Double, Double)
polyLayerWeights = (Double
0.5, Double
0.25, Double
0.25)

-- |Share of 'pyTotal' carried by 'pyDivergence' rather than 'pyQuality'.
--
-- A weighted sum rather than a multiplier: quality still leads, and
-- divergence discriminates between walks that are otherwise equally good.
--
-- Calibrated 2026-08-29 against the requirement that raising @attempt@'s K
-- must raise BOTH the mean quality and the mean divergence of the selection.
-- Two independent offline pools of 60 genE walks (len 6, entropy 0.4), 20k
-- selection trials per cell, means of the selected attempt:
--
-- @
-- weight   divergence K=1 -> 4 -> 12      quality gain K=1->12
--  0.00    0.685  0.696  0.682  (FALLS)          +0.143
--  0.25    0.690  0.714  0.730  (+0.040)         +0.137
--  0.40    0.689  0.733  0.752  (+0.063)         +0.128
--  0.50    0.691  0.744  0.764  (+0.074)         +0.118
-- @
--
-- At zero the selection's divergence actually falls as K rises — quality
-- alone decides, which is the failure this axis exists to prevent. 0.25
-- rises but flattens between K=4 and K=12. 0.40 is the knee: it buys 57%
-- more divergence gain than 0.25 for less than a hundredth of quality gain,
-- and both means climb monotonically. Past 0.50 the quality gain erodes
-- faster than divergence improves.
polyDivergenceWeight :: Double
polyDivergenceWeight :: Double
polyDivergenceWeight = Double
0.40

-- |Absolute pitch classes of a bar, deduplicated.
barPCs :: H.CadenceState -> [Int]
barPCs :: CadenceState -> [Int]
barPCs CadenceState
cs =
  let r :: Int
r   = PitchClass -> Int
P.unPitchClass (NoteName -> PitchClass
P.pitchClass (CadenceState -> NoteName
H.stateCadenceRoot CadenceState
cs))
      ivs :: [Int]
ivs = (PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
P.unPitchClass (Cadence -> [PitchClass]
H.cadenceIntervals (CadenceState -> Cadence
H.stateCadence CadenceState
cs))
  in [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub [ (Int
iv Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
r) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12 | Int
iv <- [Int]
ivs ]

-- |Bar root as an absolute pitch class.
barRootPC :: H.CadenceState -> Int
barRootPC :: CadenceState -> Int
barRootPC = PitchClass -> Int
P.unPitchClass (PitchClass -> Int)
-> (CadenceState -> PitchClass) -> CadenceState -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteName -> PitchClass
P.pitchClass (NoteName -> PitchClass)
-> (CadenceState -> NoteName) -> CadenceState -> PitchClass
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CadenceState -> NoteName
H.stateCadenceRoot

-- |How far a polytonal context's three layers stand apart, @[0, 1]@,
-- averaged over bars. Two equally-weighted readings:
--
-- * GEOMETRY — the partners sharing exactly two tones is the common-dyad
--   shape; anything else is base-anchored, where S and M sound the full
--   pentad against each other. Deliberately the same test as @PolyGen@'s
--   @pdGeometry@, so the number the ranker optimises and the label the
--   diagnostics print can never disagree.
--
-- * ROOT SPREAD — summed interval-class distance between the three roots,
--   normalised by its maximum. Three triads on distant roots read as more
--   polytonal than three sharing a neighbourhood.
polyDivergence :: PC.ProgressionContext -> Double
polyDivergence :: ProgressionContext -> Double
polyDivergence ProgressionContext
pc =
  let bars :: [(CadenceState, CadenceState, CadenceState)]
bars = [CadenceState]
-> [CadenceState]
-> [CadenceState]
-> [(CadenceState, CadenceState, CadenceState)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 (Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Prog.unProgression (ProgressionContext -> Progression
PC.triadLayer  ProgressionContext
pc)))
                  (Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Prog.unProgression (ProgressionContext -> Progression
PC.strataLayer ProgressionContext
pc)))
                  (Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Prog.unProgression (ProgressionContext -> Progression
PC.modeLayer   ProgressionContext
pc)))
  in case [(CadenceState, CadenceState, CadenceState)]
bars of
       [] -> Double
0.0
       [(CadenceState, CadenceState, CadenceState)]
_  -> [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (((CadenceState, CadenceState, CadenceState) -> Double)
-> [(CadenceState, CadenceState, CadenceState)] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (CadenceState, CadenceState, CadenceState) -> Double
barDivergence [(CadenceState, CadenceState, CadenceState)]
bars) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([(CadenceState, CadenceState, CadenceState)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(CadenceState, CadenceState, CadenceState)]
bars)

-- |Per-bar term of 'polyDivergence'.
barDivergence :: (H.CadenceState, H.CadenceState, H.CadenceState) -> Double
barDivergence :: (CadenceState, CadenceState, CadenceState) -> Double
barDivergence (CadenceState
t, CadenceState
s, CadenceState
m) =
  let sPCs :: [Int]
sPCs   = CadenceState -> [Int]
barPCs CadenceState
s
      shared :: Int
shared = [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` CadenceState -> [Int]
barPCs CadenceState
m) [Int]
sPCs)
      geom :: Double
geom   = if Int
shared Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 then Double
0.0 else Double
1.0
      ic :: a -> a -> Double
ic a
a a
b = let d :: a
d = a -> a
forall a. Num a => a -> a
abs (a
a a -> a -> a
forall a. Num a => a -> a -> a
- a
b) in a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> a -> a
forall a. Ord a => a -> a -> a
min a
d (a
12 a -> a -> a
forall a. Num a => a -> a -> a
- a
d)) :: Double
      spread :: Double
spread = (Int -> Int -> Double
forall {a}. Integral a => a -> a -> Double
ic (CadenceState -> Int
barRootPC CadenceState
t) (CadenceState -> Int
barRootPC CadenceState
s)
              Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Int -> Int -> Double
forall {a}. Integral a => a -> a -> Double
ic (CadenceState -> Int
barRootPC CadenceState
t) (CadenceState -> Int
barRootPC CadenceState
m)
              Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Int -> Int -> Double
forall {a}. Integral a => a -> a -> Double
ic (CadenceState -> Int
barRootPC CadenceState
s) (CadenceState -> Int
barRootPC CadenceState
m)) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
18.0
  in Double
0.5 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
geom Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
0.5 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
spread

-- |A layer read as a progression in its own right, so the ordinary scorers
-- apply to it unchanged.
layerAlone :: (PC.ProgressionContext -> Prog.Progression)
           -> PC.ProgressionContext -> PC.ProgressionContext
layerAlone :: (ProgressionContext -> Progression)
-> ProgressionContext -> ProgressionContext
layerAlone ProgressionContext -> Progression
sel = Progression -> ProgressionContext
PC.fromProgression (Progression -> ProgressionContext)
-> (ProgressionContext -> Progression)
-> ProgressionContext
-> ProgressionContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgressionContext -> Progression
sel

-- |Assemble a 'PolyScore' from three per-layer scores and a divergence.
assemblePoly :: ProgressionScoreWeights
             -> ProgressionScore -> ProgressionScore -> ProgressionScore
             -> Double -> PolyScore
assemblePoly :: ProgressionScoreWeights
-> ProgressionScore
-> ProgressionScore
-> ProgressionScore
-> Double
-> PolyScore
assemblePoly ProgressionScoreWeights
w ProgressionScore
t ProgressionScore
s ProgressionScore
m Double
d =
  let (Double
wt, Double
ws, Double
wm) = (Double, Double, Double)
polyLayerWeights
      q :: Double
q  = Double
wt Double -> Double -> Double
forall a. Num a => a -> a -> a
* ProgressionScoreWeights -> ProgressionScore -> Double
totalScore ProgressionScoreWeights
w ProgressionScore
t Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
ws Double -> Double -> Double
forall a. Num a => a -> a -> a
* ProgressionScoreWeights -> ProgressionScore -> Double
totalScore ProgressionScoreWeights
w ProgressionScore
s Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
wm Double -> Double -> Double
forall a. Num a => a -> a -> a
* ProgressionScoreWeights -> ProgressionScore -> Double
totalScore ProgressionScoreWeights
w ProgressionScore
m
      wd :: Double
wd = Double
polyDivergenceWeight
  in PolyScore
       { pyT :: ProgressionScore
pyT = ProgressionScore
t, pyS :: ProgressionScore
pyS = ProgressionScore
s, pyM :: ProgressionScore
pyM = ProgressionScore
m
       , pyQuality :: Double
pyQuality = Double
q
       , pyDivergence :: Double
pyDivergence = Double
d
       , pyTotal :: Double
pyTotal = (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
wd) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
q Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
wd Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
d
       }

-- |Pure polytonal score — all three layers on the offline components.
scorePoly :: ProgressionScoreWeights -> PC.ProgressionContext -> PolyScore
scorePoly :: ProgressionScoreWeights -> ProgressionContext -> PolyScore
scorePoly ProgressionScoreWeights
w ProgressionContext
pc =
  ProgressionScoreWeights
-> ProgressionScore
-> ProgressionScore
-> ProgressionScore
-> Double
-> PolyScore
assemblePoly ProgressionScoreWeights
w
    (ProgressionContext -> ProgressionScore
scoreProgression ((ProgressionContext -> Progression)
-> ProgressionContext -> ProgressionContext
layerAlone ProgressionContext -> Progression
PC.triadLayer  ProgressionContext
pc))
    (ProgressionContext -> ProgressionScore
scoreProgression ((ProgressionContext -> Progression)
-> ProgressionContext -> ProgressionContext
layerAlone ProgressionContext -> Progression
PC.strataLayer ProgressionContext
pc))
    (ProgressionContext -> ProgressionScore
scoreProgression ((ProgressionContext -> Progression)
-> ProgressionContext -> ProgressionContext
layerAlone ProgressionContext -> Progression
PC.modeLayer   ProgressionContext
pc))
    (ProgressionContext -> Double
polyDivergence ProgressionContext
pc)

-- |Online polytonal score. Each partner bar is a real graph continuation of
-- its own chain, so cadence favourability is as meaningful for the partners
-- as for the foundation and all three are fetched. The shared
-- 'TransitionCache' keeps the extra passes cheap across a K-attempt loop.
scorePolyOnline :: TransitionCache -> Text -> ProgressionScoreWeights
                -> PC.ProgressionContext -> DbActionT PolyScore
scorePolyOnline :: TransitionCache
-> Text
-> ProgressionScoreWeights
-> ProgressionContext
-> DbActionT PolyScore
scorePolyOnline TransitionCache
cache Text
blend ProgressionScoreWeights
w ProgressionContext
pc = do
  t <- TransitionCache
-> Text -> ProgressionContext -> DbActionT ProgressionScore
scoreProgressionOnline TransitionCache
cache Text
blend ((ProgressionContext -> Progression)
-> ProgressionContext -> ProgressionContext
layerAlone ProgressionContext -> Progression
PC.triadLayer  ProgressionContext
pc)
  s <- scoreProgressionOnline cache blend (layerAlone PC.strataLayer pc)
  m <- scoreProgressionOnline cache blend (layerAlone PC.modeLayer   pc)
  pure (assemblePoly w t s m (polyDivergence pc))

-------------------------------------------------------------------------------
-- Cadence-favourability aggregation (pure helper for Phase 5)
-------------------------------------------------------------------------------

-- |A pre-fetched, composer-blend-resolved map from source cadence (keyed by
-- its 'show' representation) to its outgoing transitions. Each transition
-- carries the destination 'Harmonic.Rules.Types.Harmony.Cadence' and the blended weight (output of
-- 'Query.applyComposerBlend').
type TransitionMap = Map Text [(Text, Double)]

-- |Compute 'psCadenceFav' from a pre-fetched transition map. Pure — no IO.
--
-- The progression is treated as a /cyclic/ loop: edges are
-- @(C₀ → C₁), …, (C_{N-2} → C_{N-1}), (C_{N-1} → C₀)@. Each edge is
-- scored by @edgeScore@ (hybrid presence + share). The per-progression
-- score is the mean of per-edge scores — length-independent and in
-- @[0, 1]@.
--
-- Matching by 'show' (not 'Eq') matches the DB's identity convention
-- (@MATCH (c:Cadence {show: $show})@ at @Query.hs:113-137@). The DB-side
-- 'Harmonic.Rules.Types.Harmony.Cadence' is reconstructed via @constructCadence (movement, chord)@,
-- which may differ from a generated 'Harmonic.Rules.Types.Harmony.Cadence's @cadenceIntervals@ field;
-- the 'show' instance projects to @(movement, functionality)@ only.
cadenceFavFromMap :: TransitionMap -> Prog.Progression -> Double
cadenceFavFromMap :: TransitionMap -> Progression -> Double
cadenceFavFromMap TransitionMap
srcMap Progression
prog =
  -- Project each bar through the triad walk shadow ('walkTriadCadence',
  -- identity for triads) so 4-note chains score the same corpus edges the
  -- walk actually followed; without this a hand-built extended chain's keys miss the
  -- map entirely and psCadenceFav collapses to 0.
  TransitionMap -> [Text] -> Double
cadenceFavFromKeys TransitionMap
srcMap
    ((CadenceState -> Text) -> [CadenceState] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack (String -> Text)
-> (CadenceState -> String) -> CadenceState -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cadence -> String
forall a. Show a => a -> String
show (Cadence -> String)
-> (CadenceState -> Cadence) -> CadenceState -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cadence -> Cadence
H.walkTriadCadence (Cadence -> Cadence)
-> (CadenceState -> Cadence) -> CadenceState -> Cadence
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CadenceState -> Cadence
H.stateCadence)
         (Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Prog.unProgression Progression
prog)))

-- |Key-level core of 'cadenceFavFromMap': cyclic per-edge mean over an
-- arbitrary node-key sequence. The jazz scorer passes jazz node keys
-- (whose 'show' identity is the @Change@ graph's) through the same
-- arithmetic.
cadenceFavFromKeys :: TransitionMap -> [Text] -> Double
cadenceFavFromKeys :: TransitionMap -> [Text] -> Double
cadenceFavFromKeys TransitionMap
srcMap [Text]
keys =
  let n :: Int
n = [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
keys
  in if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 then Double
0
     else
       let edges :: [(Text, Text)]
edges = [Text] -> [Text] -> [(Text, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
keys (Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
1 [Text]
keys [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take Int
1 [Text]
keys)
           perEdge :: [Double]
perEdge = ((Text, Text) -> Double) -> [(Text, Text)] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (TransitionMap -> (Text, Text) -> Double
edgeScore TransitionMap
srcMap) [(Text, Text)]
edges
       in [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Double]
perEdge Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
perEdge)

-- |Per-edge favourability — hybrid of corpus presence and within-source share.
--
-- Returns @0@ when:
--   * the source cadence isn't in the corpus (e.g. fallback-generated), OR
--   * the source is in the corpus but the destination doesn't appear in its
--     outgoing transitions under the active composer blend.
--
-- Returns @0.5 + 0.5 * (w_dst \/ totalW)@ otherwise — i.e. the edge always
-- earns @0.5@ for being /present/ in the corpus, plus up to a further
-- @0.5@ proportional to its empirical share among the source's outgoing
-- transitions.
--
-- Rationale (from the data probe): pure per-source-prior values cluster
-- at @[0.005, 0.13]@ for typical corpus-rooted progressions because each
-- source has many valid outgoing transitions, so any single one carries
-- a low empirical probability. With the @0.4@ weight on 'psCadenceFav',
-- that compressed range neutralises the axis — the weighted contribution
-- becomes vanishingly small. The hybrid rewards /presence/ (the
-- progression follows a path the corpus has actually walked under the
-- chosen blend) plus a smaller share-of-source signal for commonness.
edgeScore :: TransitionMap -> (Text, Text) -> Double
edgeScore :: TransitionMap -> (Text, Text) -> Double
edgeScore TransitionMap
srcMap (Text
srcKey, Text
dstKey) =
  case Text -> TransitionMap -> Maybe [(Text, Double)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
srcKey TransitionMap
srcMap of
       Maybe [(Text, Double)]
Nothing           -> Double
0
       Just [(Text, Double)]
transitions  ->
         let totalW :: Double
totalW   = [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (((Text, Double) -> Double) -> [(Text, Double)] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Double) -> Double
forall a b. (a, b) -> b
snd [(Text, Double)]
transitions)
             matched :: Double
matched  = [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ Double
w | (Text
k, Double
w) <- [(Text, Double)]
transitions, Text
k Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
dstKey ]
         in if Double
totalW Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0 Bool -> Bool -> Bool
|| Double
matched Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0
              then Double
0
              else Double
0.5 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
0.5 Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
matched Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
totalW)

-------------------------------------------------------------------------------
-- Online scoring (Neo4j-backed)
-------------------------------------------------------------------------------

-- |Online variant of 'scoreProgression'. Pure components match the offline
-- version exactly; 'psCadenceFav' is populated from Neo4j edge weights
-- under the composer blend parsed from the supplied seek string.
--
-- Runs inside 'DbActionT' so the caller controls connection
-- lifecycle (typically a single shared pipe across a multi-attempt loop).
scoreProgressionOnline
  :: TransitionCache               -- ^ Cross-attempt fetch cache ('newTransitionCache').
  -> Text                          -- ^ Seek string (composer blend; same format as @_gcSeek@).
  -> PC.ProgressionContext
  -> DbActionT ProgressionScore
scoreProgressionOnline :: TransitionCache
-> Text -> ProgressionContext -> DbActionT ProgressionScore
scoreProgressionOnline TransitionCache
cache Text
seekStr ProgressionContext
pc = do
  let basePure :: ProgressionScore
basePure = ProgressionContext -> ProgressionScore
scoreProgression ProgressionContext
pc
  cf <- TransitionCache -> Text -> Progression -> DbActionT Double
computeCadenceFav TransitionCache
cache Text
seekStr (ProgressionContext -> Progression
PC.triadLayer ProgressionContext
pc)
  pure basePure { psCadenceFav = cf }

-- |Mutable fetch cache threaded through a multi-attempt loop: source key →
-- blend-resolved outgoing transitions. Attempts share source cadences
-- heavily (same cue, same key, same filters), so attempts 2..K score
-- almost query-free. Valid for ONE blend — create a fresh cache per
-- @generateBest@ call, never share across seek strings.
type TransitionCache = IORef TransitionMap

-- |A fresh, empty 'TransitionCache'.
newTransitionCache :: IO TransitionCache
newTransitionCache :: IO TransitionCache
newTransitionCache = TransitionMap -> IO TransitionCache
forall a. a -> IO (IORef a)
newIORef TransitionMap
forall k a. Map k a
Map.empty

-- |Cyclic per-edge favourability mean, computed against Neo4j. Builds the
-- 'TransitionMap' by fetching each unique source cadence's outgoing
-- transitions once, applying the composer blend, then delegating to the
-- pure 'cadenceFavFromMap'.
--
-- Number of graph queries = number of distinct source-cadence 'show' keys
-- in the progression NOT already in the cache (≤ N for an N-bar
-- progression on the first attempt; near zero on later attempts).
computeCadenceFav
  :: TransitionCache
  -> Text
  -> Prog.Progression
  -> DbActionT Double
computeCadenceFav :: TransitionCache -> Text -> Progression -> DbActionT Double
computeCadenceFav TransitionCache
cache Text
seekStr Progression
prog = do
  -- Walk-shadow projection: see 'cadenceFavFromMap'.
  let cads :: [Cadence]
cads      = (CadenceState -> Cadence) -> [CadenceState] -> [Cadence]
forall a b. (a -> b) -> [a] -> [b]
map (Cadence -> Cadence
H.walkTriadCadence (Cadence -> Cadence)
-> (CadenceState -> Cadence) -> CadenceState -> Cadence
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CadenceState -> Cadence
H.stateCadence) (Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Prog.unProgression Progression
prog))
      srcKeys :: [Text]
srcKeys   = [Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub ((Cadence -> Text) -> [Cadence] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack (String -> Text) -> (Cadence -> String) -> Cadence -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cadence -> String
forall a. Show a => a -> String
show) [Cadence]
cads)
      blend :: ComposerWeights
blend     = Text -> ComposerWeights
Q.parseComposerWeights Text
seekStr
  -- Wildcard blend: project the pre-aggregated r.confidence (identical to
  -- resolveWeights over the full weights map, by the ingestion invariant)
  -- instead of parsing every edge's weights JSON. edgeScore is
  -- share-of-total, so ordering is immaterial either way.
  pairs <- [Text]
-> (Text -> ReaderT DbConn IO (Text, [(Text, Double)]))
-> ReaderT DbConn IO [(Text, [(Text, Double)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Text]
srcKeys ((Text -> ReaderT DbConn IO (Text, [(Text, Double)]))
 -> ReaderT DbConn IO [(Text, [(Text, Double)])])
-> (Text -> ReaderT DbConn IO (Text, [(Text, Double)]))
-> ReaderT DbConn IO [(Text, [(Text, Double)])]
forall a b. (a -> b) -> a -> b
$ \Text
k -> do
    resolved <- TransitionCache
-> Text -> DbActionT [(Text, Double)] -> DbActionT [(Text, Double)]
fetchCached TransitionCache
cache Text
k (DbActionT [(Text, Double)] -> DbActionT [(Text, Double)])
-> DbActionT [(Text, Double)] -> DbActionT [(Text, Double)]
forall a b. (a -> b) -> a -> b
$ do
      raw <- if ComposerWeights -> Bool
forall k a. Map k a -> Bool
Map.null ComposerWeights
blend
               then Text -> DbActionT [(Cadence, Double)]
Q.fetchTransitionsAggregate Text
k
               else ComposerWeights
-> [(Cadence, ComposerWeights)] -> [(Cadence, Double)]
forall a.
ComposerWeights -> [(a, ComposerWeights)] -> [(a, Double)]
Q.resolveWeights ComposerWeights
blend ([(Cadence, ComposerWeights)] -> [(Cadence, Double)])
-> ReaderT DbConn IO [(Cadence, ComposerWeights)]
-> DbActionT [(Cadence, Double)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ReaderT DbConn IO [(Cadence, ComposerWeights)]
Q.fetchTransitions Text
k
      pure [ (T.pack (show c), w) | (c, w) <- raw ]
    pure (k, resolved)
  let srcMap = [(Text, [(Text, Double)])] -> TransitionMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, [(Text, Double)])]
pairs
  pure (cadenceFavFromMap srcMap prog)

-- Cache-through fetch: hit returns the stored transitions, miss runs the
-- supplied fetch and stores its result.
fetchCached :: TransitionCache -> Text -> DbActionT [(Text, Double)] -> DbActionT [(Text, Double)]
fetchCached :: TransitionCache
-> Text -> DbActionT [(Text, Double)] -> DbActionT [(Text, Double)]
fetchCached TransitionCache
cache Text
k DbActionT [(Text, Double)]
fetch = do
  m <- IO TransitionMap -> ReaderT DbConn IO TransitionMap
forall a. IO a -> ReaderT DbConn IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (TransitionCache -> IO TransitionMap
forall a. IORef a -> IO a
readIORef TransitionCache
cache)
  case Map.lookup k m of
    Just [(Text, Double)]
v  -> [(Text, Double)] -> DbActionT [(Text, Double)]
forall a. a -> ReaderT DbConn IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Text, Double)]
v
    Maybe [(Text, Double)]
Nothing -> do
      v <- DbActionT [(Text, Double)]
fetch
      liftIO (modifyIORef' cache (Map.insert k v))
      pure v

-- |Jazz analogue of 'H.walkTriadCadence': project a bar onto its
-- Change-graph node key. Identity for walk-generated bars (their
-- functionality was already set by the jazz namer); maps a lead-produced
-- cue onto the node the walk itself started from, so the cyclic
-- favourability score no longer charges both cue edges as misses. Sets
-- outside the jazz vocabulary keep their raw key and score 0 — honest.
jazzChangeKey :: H.CadenceState -> Text
jazzChangeKey :: CadenceState -> Text
jazzChangeKey CadenceState
cs =
  let cad :: Cadence
cad = CadenceState -> Cadence
H.stateCadence CadenceState
cs
      set :: [Int]
set = (PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PitchClass -> Int
P.unPitchClass (Cadence -> [PitchClass]
H.cadenceIntervals Cadence
cad)
  in case [Int] -> Maybe Text
J.jazzFunctionality [Int]
set of
       Just Text
nm -> Text
"( " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Movement -> String
forall a. Show a => a -> String
show (Cadence -> Movement
H.cadenceMovement Cadence
cad)) 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
" )"
       Maybe Text
Nothing -> String -> Text
T.pack (Cadence -> String
forall a. Show a => a -> String
show Cadence
cad)

-- |Jazz-family variant of 'scoreProgressionOnline': pure components are
-- identical (they are arity-agnostic); 'psCadenceFav' is computed against
-- the @Change@ graph under the seek spec's JAZZ half — the spec is split
-- by 'Q.splitSeekByCorpus' exactly as the genJ walk splits it, so an
-- attempt loop ranks by the same musical priorities the walk sampled
-- under. Node keys are the bars' own 'show' identities (jazz names) —
-- no triad projection.
scoreProgressionJazz
  :: TransitionCache               -- ^ Cross-attempt fetch cache ('newTransitionCache').
  -> Q.ComposerWeights             -- ^ Resolved jazz blend ('resolveJazzBlend'); empty = wildcard.
  -> PC.ProgressionContext
  -> DbActionT ProgressionScore
scoreProgressionJazz :: TransitionCache
-> ComposerWeights
-> ProgressionContext
-> DbActionT ProgressionScore
scoreProgressionJazz TransitionCache
cache ComposerWeights
jazzBlend ProgressionContext
pc = do
  let basePure :: ProgressionScore
basePure = ProgressionContext -> ProgressionScore
scoreProgression ProgressionContext
pc
      prog :: Progression
prog     = ProgressionContext -> Progression
PC.triadLayer ProgressionContext
pc
      keys :: [Text]
keys     = (CadenceState -> Text) -> [CadenceState] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map CadenceState -> Text
jazzChangeKey (Seq CadenceState -> [CadenceState]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Progression -> Seq CadenceState
Prog.unProgression Progression
prog))
  pairs <- [Text]
-> (Text -> ReaderT DbConn IO (Text, [(Text, Double)]))
-> ReaderT DbConn IO [(Text, [(Text, Double)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub [Text]
keys) ((Text -> ReaderT DbConn IO (Text, [(Text, Double)]))
 -> ReaderT DbConn IO [(Text, [(Text, Double)])])
-> (Text -> ReaderT DbConn IO (Text, [(Text, Double)]))
-> ReaderT DbConn IO [(Text, [(Text, Double)])]
forall a b. (a -> b) -> a -> b
$ \Text
k -> do
    resolved <- TransitionCache
-> Text -> DbActionT [(Text, Double)] -> DbActionT [(Text, Double)]
fetchCached TransitionCache
cache Text
k (DbActionT [(Text, Double)] -> DbActionT [(Text, Double)])
-> DbActionT [(Text, Double)] -> DbActionT [(Text, Double)]
forall a b. (a -> b) -> a -> b
$
      if ComposerWeights -> Bool
forall k a. Map k a -> Bool
Map.null ComposerWeights
jazzBlend
        then ((ChangeCandidate, Double) -> (Text, Double))
-> [(ChangeCandidate, Double)] -> [(Text, Double)]
forall a b. (a -> b) -> [a] -> [b]
map ((ChangeCandidate -> Text)
-> (ChangeCandidate, Double) -> (Text, Double)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ChangeCandidate -> Text
Q.ccShow) ([(ChangeCandidate, Double)] -> [(Text, Double)])
-> ReaderT DbConn IO [(ChangeCandidate, Double)]
-> DbActionT [(Text, Double)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ReaderT DbConn IO [(ChangeCandidate, Double)]
Q.fetchChangeAggregate Text
k
        else ((ChangeCandidate, Double) -> (Text, Double))
-> [(ChangeCandidate, Double)] -> [(Text, Double)]
forall a b. (a -> b) -> [a] -> [b]
map ((ChangeCandidate -> Text)
-> (ChangeCandidate, Double) -> (Text, Double)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ChangeCandidate -> Text
Q.ccShow) ([(ChangeCandidate, Double)] -> [(Text, Double)])
-> ([(ChangeCandidate, ComposerWeights)]
    -> [(ChangeCandidate, Double)])
-> [(ChangeCandidate, ComposerWeights)]
-> [(Text, Double)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComposerWeights
-> [(ChangeCandidate, ComposerWeights)]
-> [(ChangeCandidate, Double)]
forall a.
ComposerWeights -> [(a, ComposerWeights)] -> [(a, Double)]
Q.resolveWeights ComposerWeights
jazzBlend
               ([(ChangeCandidate, ComposerWeights)] -> [(Text, Double)])
-> ReaderT DbConn IO [(ChangeCandidate, ComposerWeights)]
-> DbActionT [(Text, Double)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ReaderT DbConn IO [(ChangeCandidate, ComposerWeights)]
Q.fetchChangeTransitions Text
k
    pure (k, resolved)
  let cf = TransitionMap -> [Text] -> Double
cadenceFavFromKeys ([(Text, [(Text, Double)])] -> TransitionMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, [(Text, Double)])]
pairs) [Text]
keys
  pure basePure { psCadenceFav = cf }

-- |Resolve a seek string's jazz half once (one 'Q.fetchJazzComposers'
-- round trip), for threading through a multi-attempt loop. An empty seek
-- blend (wildcard) resolves to the empty map without touching the graph.
resolveJazzBlend :: Text -> DbActionT Q.ComposerWeights
resolveJazzBlend :: Text -> DbActionT ComposerWeights
resolveJazzBlend Text
seekStr = do
  let blend :: ComposerWeights
blend = Text -> ComposerWeights
Q.parseComposerWeights Text
seekStr
  if ComposerWeights -> Bool
forall k a. Map k a -> Bool
Map.null ComposerWeights
blend
    then ComposerWeights -> DbActionT ComposerWeights
forall a. a -> ReaderT DbConn IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ComposerWeights
forall k a. Map k a
Map.empty
    else do
      jazzKeys <- DbActionT (Set Text)
Q.fetchJazzComposers
      pure (fst (Q.splitSeekByCorpus jazzKeys blend))

-------------------------------------------------------------------------------
-- Internal helpers
-------------------------------------------------------------------------------

clamp01 :: Double -> Double
clamp01 :: Double -> Double
clamp01 Double
x
  | Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0     = Double
0
  | Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
1     = Double
1
  | Bool
otherwise = Double
x