-- |
-- 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
  , computeCadenceFav
  ) where

import           Control.Monad (forM)
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 qualified Database.Bolt as Bolt

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.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.4@ fav, @0.2@ each on root motion,
-- voice leading, mode validity.
defaultWeights :: ProgressionScoreWeights
defaultWeights :: ProgressionScoreWeights
defaultWeights = ProgressionScoreWeights
  { wRootMotion :: Double
wRootMotion   = Double
0.2
  , wVoiceLeading :: Double
wVoiceLeading = Double
0.2
  , wCadenceFav :: Double
wCadenceFav   = Double
0.4
  , wModeValidity :: Double
wModeValidity = Double
0.2
  }

-- |Offline-mode weights — cadence favourability dropped, remaining three
-- renormalised to @1\/3@ each.
defaultWeightsOffline :: ProgressionScoreWeights
defaultWeightsOffline :: ProgressionScoreWeights
defaultWeightsOffline = ProgressionScoreWeights
  { wRootMotion :: Double
wRootMotion   = Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
3
  , wVoiceLeading :: Double
wVoiceLeading = Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
3
  , wCadenceFav :: Double
wCadenceFav   = Double
0
  , wModeValidity :: Double
wModeValidity = Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
3
  }

-------------------------------------------------------------------------------
-- 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, Int)] -> [(Int, Int)]
forall a. [a] -> [a] -> [a]
++ [([Int] -> Int
forall a. HasCallStack => [a] -> a
last [Int]
rootPCs, [Int] -> Int
forall a. HasCallStack => [a] -> a
head [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 \/ gen4 \/ genVI × len {8, 16} × entropy {0.2, 0.4, 0.6}, two runs
-- each (genVI cued in-strata; its random-cue empties excluded). Observed
-- per-edge cyclic costs: gen 2.5–5.75, gen4 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). gen4 chains now score the heard 4-note
    -- 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\/gen4 × 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@. For legacy 'Harmonic.Framework.Builder.gen' contexts (pcProvenance =
-- Nothing) the mode layer duplicates the triad layer (3 PCs), so this
-- check is not meaningful — returns @1.0@.
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

-------------------------------------------------------------------------------
-- 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 [(H.Cadence, 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 gen4 walk shadow ('walkTriadCadence',
  -- identity for triads) so 4-note chains score the same corpus edges the
  -- walk actually followed; without this a fused chain's keys miss the
  -- map entirely and psCadenceFav collapses to 0.
  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))
      n :: Int
n = [Cadence] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Cadence]
cads
  in if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 then Double
0
     else
       let edges :: [(Cadence, Cadence)]
edges = [Cadence] -> [Cadence] -> [(Cadence, Cadence)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Cadence]
cads (Int -> [Cadence] -> [Cadence]
forall a. Int -> [a] -> [a]
drop Int
1 [Cadence]
cads [Cadence] -> [Cadence] -> [Cadence]
forall a. [a] -> [a] -> [a]
++ [[Cadence] -> Cadence
forall a. HasCallStack => [a] -> a
head [Cadence]
cads])
           perEdge :: [Double]
perEdge = ((Cadence, Cadence) -> Double) -> [(Cadence, Cadence)] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (TransitionMap -> (Cadence, Cadence) -> Double
edgeScore TransitionMap
srcMap) [(Cadence, Cadence)]
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 -> (H.Cadence, H.Cadence) -> Double
edgeScore :: TransitionMap -> (Cadence, Cadence) -> Double
edgeScore TransitionMap
srcMap (Cadence
src, Cadence
dst) =
  let srcKey :: Text
srcKey = String -> Text
T.pack (Cadence -> String
forall a. Show a => a -> String
show Cadence
src)
      dstKey :: Text
dstKey = String -> Text
T.pack (Cadence -> String
forall a. Show a => a -> String
show Cadence
dst)
  in case Text -> TransitionMap -> Maybe [(Cadence, Double)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
srcKey TransitionMap
srcMap of
       Maybe [(Cadence, Double)]
Nothing           -> Double
0
       Just [(Cadence, 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 (((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)]
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 | (Cadence
c, Double
w) <- [(Cadence, Double)]
transitions
                                , String -> Text
T.pack (Cadence -> String
forall a. Show a => a -> String
show Cadence
c) 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 'Bolt.BoltActionT IO' so the caller controls connection
-- lifecycle (typically a single shared pipe across a multi-attempt loop).
scoreProgressionOnline
  :: Text                          -- ^ Seek string (composer blend; same format as @_gcSeek@).
  -> PC.ProgressionContext
  -> Bolt.BoltActionT IO ProgressionScore
scoreProgressionOnline :: Text -> ProgressionContext -> BoltActionT IO ProgressionScore
scoreProgressionOnline Text
seekStr ProgressionContext
pc = do
  let basePure :: ProgressionScore
basePure = ProgressionContext -> ProgressionScore
scoreProgression ProgressionContext
pc
  Double
cf <- Text -> Progression -> BoltActionT IO Double
computeCadenceFav Text
seekStr (ProgressionContext -> Progression
PC.triadLayer ProgressionContext
pc)
  ProgressionScore -> BoltActionT IO ProgressionScore
forall a. a -> BoltActionT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgressionScore
basePure { psCadenceFav = cf }

-- |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 (≤ N for an N-bar progression).
computeCadenceFav
  :: Text
  -> Prog.Progression
  -> Bolt.BoltActionT IO Double
computeCadenceFav :: Text -> Progression -> BoltActionT IO Double
computeCadenceFav 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
  [(Text, [(Cadence, Double)])]
pairs <- [Text]
-> (Text -> BoltActionT IO (Text, [(Cadence, Double)]))
-> BoltActionT IO [(Text, [(Cadence, Double)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Text]
srcKeys ((Text -> BoltActionT IO (Text, [(Cadence, Double)]))
 -> BoltActionT IO [(Text, [(Cadence, Double)])])
-> (Text -> BoltActionT IO (Text, [(Cadence, Double)]))
-> BoltActionT IO [(Text, [(Cadence, Double)])]
forall a b. (a -> b) -> a -> b
$ \Text
k -> do
    [(Cadence, ComposerWeights)]
raw <- Text -> BoltActionT IO [(Cadence, ComposerWeights)]
Q.fetchTransitions Text
k
    let resolved :: [(Cadence, Double)]
resolved = ComposerWeights
-> [(Cadence, ComposerWeights)] -> [(Cadence, Double)]
Q.resolveWeights ComposerWeights
blend [(Cadence, ComposerWeights)]
raw   -- [(Cadence, Double)]
    (Text, [(Cadence, Double)])
-> BoltActionT IO (Text, [(Cadence, Double)])
forall a. a -> BoltActionT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
k, [(Cadence, Double)]
resolved)
  let srcMap :: TransitionMap
srcMap = [(Text, [(Cadence, Double)])] -> TransitionMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, [(Cadence, Double)])]
pairs
  Double -> BoltActionT IO Double
forall a. a -> BoltActionT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TransitionMap -> Progression -> Double
cadenceFavFromMap TransitionMap
srcMap Progression
prog)

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