-- |
-- Module      : Harmonic.Evaluation.Database.Query
-- Description : Read-only interface to Neo4j for cadence graph traversal
--
-- This module implements the Evaluation (E) component of the Creative Systems
-- Framework. It fetches transition probabilities from Neo4j and resolves
-- composer-weighted scores for candidate cadences.
--
-- The database is treated as abstract\/pitch-agnostic. Root notes and voicings
-- are computed at runtime from user-defined starting conditions.

module Harmonic.Evaluation.Database.Query
  ( -- * Composer Weight Parsing
    ComposerWeights
  , parseComposerWeights
  , normalizeWeights
  , parseWeightsJson
  
    -- * Graph Queries
  , fetchTransitions
  , fetchTransitionsAggregate

    -- * Jazz (Change) Graph Queries
  , ChangeCandidate(..)
  , fetchChangeTransitions
  , fetchChangeAggregate
  , fetchChangeStarts
  , resolveChangeCue
  , fetchJazzComposers
  , splitSeekByCorpus

    -- * Weight Resolution
  , resolveWeights
  , applyComposerBlend
  ) where

import qualified Data.Aeson as A
import qualified Data.Map.Strict as Map
import           Data.Map.Strict (Map)
import qualified Data.Text as T
import           Data.Text (Text)
import qualified Data.Text.Encoding as TE
import           Data.Maybe (fromMaybe, mapMaybe)
import           Data.Either (partitionEithers)
import           Data.List (sortBy)
import           Data.Ord (Down(..))
import           Data.Function (on)
import qualified Data.Aeson as Aeson
import           Data.Aeson (Value(..))
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KM
import qualified Data.ByteString.Lazy as BL
import           Data.Scientific (toRealFloat)

import qualified Data.Set as Set
import           Harmonic.Database (DbActionT, runQuery, runQueryP)
import           Text.Read (readMaybe)
import qualified Harmonic.Rules.Types.Harmony as H

-- | Map from composer name to weight (e.g., "bach" -> 0.7)
type ComposerWeights = Map Text Double

-------------------------------------------------------------------------------
-- Composer Weight Parsing
-------------------------------------------------------------------------------

-- |Parse a composer selection string into normalized weights.
--
-- Composer names are matched case-insensitively against the corpus —
-- @"Bach"@, @"bach"@, @"BACH"@, @"bAcH"@ all collapse to the same key.
-- Names are lower-cased here at parse time; 'resolveWeights' lowercases
-- corpus edge keys at lookup time so the match is robust regardless of
-- the case convention used during corpus ingestion.
--
-- Supported formats:
--   "bach debussy"           -> equal weights, normalized to sum 1.0
--   "Bach:30 Debussy:70"     -> weighted, normalized; case-insensitive
--   "bach:0.3, debussy:0.7"  -> already normalized (or re-normalized if needed)
--
-- Examples:
--   parseComposerWeights "bach debussy"
--     == Map.fromList [("bach", 0.5), ("debussy", 0.5)]
--   parseComposerWeights "Bach:30 DEBUSSY:70"
--     == Map.fromList [("bach", 0.3), ("debussy", 0.7)]
parseComposerWeights :: Text -> ComposerWeights
parseComposerWeights :: Text -> ComposerWeights
parseComposerWeights Text
input
  | Text -> Text
T.strip Text
input Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"*" = ComposerWeights
forall k a. Map k a
Map.empty  -- wildcard: empty → aggregate path
  | Bool
otherwise =
      let tokens :: [Text]
tokens = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> [Text]
T.split Char -> Bool
isSeparator Text
input
          parsed :: [(Text, Double)]
parsed = (Text -> Maybe (Text, Double)) -> [Text] -> [(Text, Double)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe (Text, Double)
parseToken [Text]
tokens
       in ComposerWeights -> ComposerWeights
normalizeWeights (ComposerWeights -> ComposerWeights)
-> ComposerWeights -> ComposerWeights
forall a b. (a -> b) -> a -> b
$ (Double -> Double -> Double) -> [(Text, Double)] -> ComposerWeights
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Double -> Double -> Double
forall a. Num a => a -> a -> a
(+) [(Text, Double)]
parsed
  where
    isSeparator :: Char -> Bool
isSeparator Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
','

    parseToken :: Text -> Maybe (Text, Double)
    parseToken :: Text -> Maybe (Text, Double)
parseToken Text
tok =
      case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
":" Text
tok of
        [Text
name]        -> (Text, Double) -> Maybe (Text, Double)
forall a. a -> Maybe a
Just (Text -> Text
T.toLower (Text -> Text
T.strip Text
name), Double
1.0)  -- Equal weight
        [Text
name, Text
wStr]  ->
          let weight :: Double
weight = Text -> Double
parseWeight (Text -> Text
T.strip Text
wStr)
           in (Text, Double) -> Maybe (Text, Double)
forall a. a -> Maybe a
Just (Text -> Text
T.toLower (Text -> Text
T.strip Text
name), Double
weight)
        [Text]
_             -> Maybe (Text, Double)
forall a. Maybe a
Nothing

    parseWeight :: Text -> Double
    parseWeight :: Text -> Double
parseWeight Text
wStr =
      let str :: String
str = Text -> String
T.unpack Text
wStr
       in case ReadS Double
forall a. Read a => ReadS a
reads String
str of
            [(Double
d, String
"")] -> Double
d
            [(Double, String)]
_         -> Double
1.0  -- Default to 1.0 if parse fails

-- |Normalize weights so they sum to 1.0
normalizeWeights :: ComposerWeights -> ComposerWeights
normalizeWeights :: ComposerWeights -> ComposerWeights
normalizeWeights ComposerWeights
weights
  | Double
total Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0 = ComposerWeights
weights
  | Bool
otherwise  = (Double -> Double) -> ComposerWeights -> ComposerWeights
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
total) ComposerWeights
weights
  where
    total :: Double
total = [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (ComposerWeights -> [Double]
forall k a. Map k a -> [a]
Map.elems ComposerWeights
weights)

-------------------------------------------------------------------------------
-- Graph Queries
-------------------------------------------------------------------------------

-- |Fetch all outgoing transitions from a cadence node.
-- 
-- Returns: List of (Cadence, ComposerWeights) pairs for all [:NEXT] edges.
-- The Cadence is reconstructed from Neo4j node properties (movement, chord).
--
-- Query: MATCH (c:Cadence {show: $show})-[r:NEXT]->(n:Cadence) 
--        RETURN n.movement, n.chord, r.weights
fetchTransitions :: Text -> DbActionT [(H.Cadence, ComposerWeights)]
fetchTransitions :: Text -> DbActionT [(Cadence, ComposerWeights)]
fetchTransitions Text
cadenceShow = do
  let query :: Text
query = [Text] -> Text
T.unlines
        [ Text
"MATCH (c:Cadence {show: $show})-[r:NEXT]->(n:Cadence)"
        , Text
"RETURN n.movement AS movement, n.chord AS chord, r.weights AS weights"
        ]
      params :: Map Text Value
params = [(Text, Value)] -> Map Text Value
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text
"show", Text -> Value
A.String Text
cadenceShow)]

  records <- Text -> Map Text Value -> DbActionT [Map Text Value]
runQueryP Text
query Map Text Value
params
  pure $ mapMaybe parseRecord records
  where
    parseRecord :: Map Text A.Value -> Maybe (H.Cadence, ComposerWeights)
    parseRecord :: Map Text Value -> Maybe (Cadence, ComposerWeights)
parseRecord Map Text Value
record = do
      mvmtVal <- Text -> Map Text Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"movement" Map Text Value
record
      chordVal <- Map.lookup "chord" record
      weightsVal <- Map.lookup "weights" record
      
      mvmtStr <- extractText mvmtVal
      chordStr <- extractText chordVal
      weightsStr <- extractText weightsVal
      
      let cadence = (String, String) -> Cadence
H.constructCadence (Text -> String
T.unpack Text
mvmtStr, Text -> String
T.unpack Text
chordStr)
      let weights = Text -> ComposerWeights
parseWeightsJson Text
weightsStr
      
      pure (cadence, weights)

-- |Fetch outgoing transitions with the pre-aggregated corpus score.
--
-- Fast path for the wildcard composer spec (@"*"@, i.e. an empty blend):
-- every edge stores @r.confidence@, written at ingestion as exactly
-- @sum (Map.elems weights)@ ("Harmonic.Rules.Import.Graph"), which is the
-- score 'resolveWeights' computes for an empty blend. Projecting it directly
-- skips the @r.weights@ JSON payload (all corpus composers per edge, ~1MB\/
-- fetch on high-degree nodes) — measured ~30x faster and ~115x less
-- allocation per generation step.
--
-- Result contract matches @'applyComposerBlend' Map.empty <$> 'fetchTransitions'@
-- exactly: positive scores only (always true by the ingestion invariant —
-- zero-total edges are never written), sorted highest first.
--
-- Query: MATCH (c:Cadence {show: $show})-[r:NEXT]->(n:Cadence)
--        RETURN n.movement, n.chord, r.confidence
fetchTransitionsAggregate :: Text -> DbActionT [(H.Cadence, Double)]
fetchTransitionsAggregate :: Text -> DbActionT [(Cadence, Double)]
fetchTransitionsAggregate Text
cadenceShow = do
  let query :: Text
query = [Text] -> Text
T.unlines
        [ Text
"MATCH (c:Cadence {show: $show})-[r:NEXT]->(n:Cadence)"
        , Text
"RETURN n.movement AS movement, n.chord AS chord, r.confidence AS confidence"
        ]
      params :: Map Text Value
params = [(Text, Value)] -> Map Text Value
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text
"show", Text -> Value
A.String Text
cadenceShow)]

  records <- Text -> Map Text Value -> DbActionT [Map Text Value]
runQueryP Text
query Map Text Value
params
  pure $ sortBy (compare `on` (Down . snd))
       $ filter ((> 0) . snd)
       $ mapMaybe parseRecord records
  where
    parseRecord :: Map Text A.Value -> Maybe (H.Cadence, Double)
    parseRecord :: Map Text Value -> Maybe (Cadence, Double)
parseRecord Map Text Value
record = do
      mvmtVal <- Text -> Map Text Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"movement" Map Text Value
record
      chordVal <- Map.lookup "chord" record
      confVal <- Map.lookup "confidence" record

      mvmtStr <- extractText mvmtVal
      chordStr <- extractText chordVal
      conf <- extractDouble confVal

      let cadence = (String, String) -> Cadence
H.constructCadence (Text -> String
T.unpack Text
mvmtStr, Text -> String
T.unpack Text
chordStr)

      pure (cadence, conf)

-------------------------------------------------------------------------------
-- Weight Resolution
-------------------------------------------------------------------------------

-- |Resolve transition weights using the active composer blend.
-- 
-- For each candidate (Cadence, ComposerWeights), compute a single score
-- by multiplying each composer's edge weight by the user's blend weight
-- and summing.
--
-- Example:
--   candidate weights: {"bach": 5, "debussy": 3}
--   user blend: {"bach": 0.7, "debussy": 0.3}
--   score = 5 * 0.7 + 3 * 0.3 = 4.4
resolveWeights :: ComposerWeights -> [(a, ComposerWeights)] -> [(a, Double)]
resolveWeights :: forall a.
ComposerWeights -> [(a, ComposerWeights)] -> [(a, Double)]
resolveWeights ComposerWeights
blend [(a, ComposerWeights)]
candidates =
  let scored :: [(a, Double)]
scored = ((a, ComposerWeights) -> (a, Double))
-> [(a, ComposerWeights)] -> [(a, Double)]
forall a b. (a -> b) -> [a] -> [b]
map (ComposerWeights -> (a, ComposerWeights) -> (a, Double)
forall a. ComposerWeights -> (a, ComposerWeights) -> (a, Double)
scoreCandidate ComposerWeights
blend) [(a, ComposerWeights)]
candidates
      sorted :: [(a, Double)]
sorted = ((a, Double) -> (a, Double) -> Ordering)
-> [(a, Double)] -> [(a, Double)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Down Double -> Down Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Down Double -> Down Double -> Ordering)
-> ((a, Double) -> Down Double)
-> (a, Double)
-> (a, Double)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Double -> Down Double
forall a. a -> Down a
Down (Double -> Down Double)
-> ((a, Double) -> Double) -> (a, Double) -> Down Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Double) -> Double
forall a b. (a, b) -> b
snd)) [(a, Double)]
scored  -- Highest first
   in [(a, Double)]
sorted
  where
    scoreCandidate :: ComposerWeights -> (a, ComposerWeights) -> (a, Double)
    scoreCandidate :: forall a. ComposerWeights -> (a, ComposerWeights) -> (a, Double)
scoreCandidate ComposerWeights
userBlend (a
cadence, ComposerWeights
edgeWeights)
      | ComposerWeights -> Bool
forall k a. Map k a -> Bool
Map.null ComposerWeights
userBlend =
          -- Wildcard "*": use aggregate (sum of all composer weights = r.confidence equivalent)
          (a
cadence, [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (ComposerWeights -> [Double]
forall k a. Map k a -> [a]
Map.elems ComposerWeights
edgeWeights))
      | Bool
otherwise =
          -- Case-fold both sides so the match is robust regardless of corpus
          -- case convention (current corpus is lowercase; doc example showed
          -- capitalised) and regardless of how the user constructed the blend
          -- (parseComposerWeights lower-cases at parse time, but a directly-
          -- constructed Map bypassing the parser may have arbitrary case).
          -- Sum on collision so two case-variant keys merge rather than drop.
          let edgeLower :: ComposerWeights
edgeLower = (Double -> Double -> Double) -> [(Text, Double)] -> ComposerWeights
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Double -> Double -> Double
forall a. Num a => a -> a -> a
(+)
                            [ (Text -> Text
T.toLower Text
k, Double
v) | (Text
k, Double
v) <- ComposerWeights -> [(Text, Double)]
forall k a. Map k a -> [(k, a)]
Map.toList ComposerWeights
edgeWeights ]
              score :: Double
score = [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
                [ Double
userWeight Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0 (Text -> ComposerWeights -> Maybe Double
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> Text
T.toLower Text
composer) ComposerWeights
edgeLower)
                | (Text
composer, Double
userWeight) <- ComposerWeights -> [(Text, Double)]
forall k a. Map k a -> [(k, a)]
Map.toList ComposerWeights
userBlend
                ]
           in (a
cadence, Double
score)

-- |Apply composer blend to filter transitions, keeping only those with score > 0
applyComposerBlend :: ComposerWeights -> [(a, ComposerWeights)] -> [(a, Double)]
applyComposerBlend :: forall a.
ComposerWeights -> [(a, ComposerWeights)] -> [(a, Double)]
applyComposerBlend ComposerWeights
blend = ((a, Double) -> Bool) -> [(a, Double)] -> [(a, Double)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0) (Double -> Bool) -> ((a, Double) -> Double) -> (a, Double) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Double) -> Double
forall a b. (a, b) -> b
snd) ([(a, Double)] -> [(a, Double)])
-> ([(a, ComposerWeights)] -> [(a, Double)])
-> [(a, ComposerWeights)]
-> [(a, Double)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComposerWeights -> [(a, ComposerWeights)] -> [(a, Double)]
forall a.
ComposerWeights -> [(a, ComposerWeights)] -> [(a, Double)]
resolveWeights ComposerWeights
blend

-------------------------------------------------------------------------------
-- JSON Parsing Helpers
-------------------------------------------------------------------------------

-- |Parse the weights JSON string from Neo4j.
-- Format: '{"Debussy":3.0,"Stravinsky":2.0}'
parseWeightsJson :: Text -> ComposerWeights
parseWeightsJson :: Text -> ComposerWeights
parseWeightsJson Text
jsonStr =
  case ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode (StrictByteString -> ByteString
BL.fromStrict (StrictByteString -> ByteString) -> StrictByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> StrictByteString
TE.encodeUtf8 Text
jsonStr) of
    Just (Object Object
obj) -> 
      [(Text, Double)] -> ComposerWeights
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Key -> Text
Key.toText Key
k, Value -> Double
forall {b}. Fractional b => Value -> b
extractNum Value
v) | (Key
k, Value
v) <- Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KM.toList Object
obj]
    Maybe Value
_ -> ComposerWeights
forall k a. Map k a
Map.empty
  where
    extractNum :: Value -> b
extractNum (Number Scientific
n) = Scientific -> b
forall a b. (Real a, Fractional b) => a -> b
realToFrac Scientific
n
    extractNum Value
_          = b
0

-- |Convert Aeson Key to Text
-- (Aeson uses Key type for object keys in newer versions)

-------------------------------------------------------------------------------
-- Result Value Extractors
-------------------------------------------------------------------------------

extractText :: A.Value -> Maybe Text
extractText :: Value -> Maybe Text
extractText (A.String Text
t) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
extractText Value
_            = Maybe Text
forall a. Maybe a
Nothing

-- | JSON numbers carry both stored FLOATs and INTEGERs, so this covers an
-- integral-stored confidence from any past ingestion as well.
extractDouble :: A.Value -> Maybe Double
extractDouble :: Value -> Maybe Double
extractDouble (A.Number Scientific
n) = Double -> Maybe Double
forall a. a -> Maybe a
Just (Scientific -> Double
forall a. RealFloat a => Scientific -> a
toRealFloat Scientific
n)
extractDouble Value
_            = Maybe Double
forall a. Maybe a
Nothing

-------------------------------------------------------------------------------
-- Jazz (Change) Graph Queries
-------------------------------------------------------------------------------

-- | One candidate next node in the jazz graph: its @show@ key (the walk
-- state), plus the movement and anchor-relative zero-form set parsed
-- back from node properties.
data ChangeCandidate = ChangeCandidate
  { ChangeCandidate -> Text
ccShow     :: Text        -- ^ Node key, e.g. @( asc 5 -> 7 )@.
  , ChangeCandidate -> Movement
ccMovement :: H.Movement  -- ^ Anchor motion arriving at the node.
  , ChangeCandidate -> [Int]
ccSet      :: [Int]       -- ^ Zero-form tone set above the anchor.
  } deriving (Int -> ChangeCandidate -> String -> String
[ChangeCandidate] -> String -> String
ChangeCandidate -> String
(Int -> ChangeCandidate -> String -> String)
-> (ChangeCandidate -> String)
-> ([ChangeCandidate] -> String -> String)
-> Show ChangeCandidate
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ChangeCandidate -> String -> String
showsPrec :: Int -> ChangeCandidate -> String -> String
$cshow :: ChangeCandidate -> String
show :: ChangeCandidate -> String
$cshowList :: [ChangeCandidate] -> String -> String
showList :: [ChangeCandidate] -> String -> String
Show, ChangeCandidate -> ChangeCandidate -> Bool
(ChangeCandidate -> ChangeCandidate -> Bool)
-> (ChangeCandidate -> ChangeCandidate -> Bool)
-> Eq ChangeCandidate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChangeCandidate -> ChangeCandidate -> Bool
== :: ChangeCandidate -> ChangeCandidate -> Bool
$c/= :: ChangeCandidate -> ChangeCandidate -> Bool
/= :: ChangeCandidate -> ChangeCandidate -> Bool
Eq)

-- | Outgoing jazz transitions with full per-composer weights — the blend
-- path, mirroring 'fetchTransitions' for the @Change@ label.
fetchChangeTransitions :: Text -> DbActionT [(ChangeCandidate, ComposerWeights)]
fetchChangeTransitions :: Text -> DbActionT [(ChangeCandidate, ComposerWeights)]
fetchChangeTransitions Text
showKey = do
  let query :: Text
query = [Text] -> Text
T.unlines
        [ Text
"MATCH (c:Change {show: $show})-[r:NEXT]->(n:Change)"
        , Text
"RETURN n.show AS show, n.movement AS movement, n.chord AS chord, r.weights AS weights"
        ]
  records <- Text -> Map Text Value -> DbActionT [Map Text Value]
runQueryP Text
query ([(Text, Value)] -> Map Text Value
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text
"show", Text -> Value
A.String Text
showKey)])
  pure $ mapMaybe parseRecord records
  where
    parseRecord :: Map Text Value -> Maybe (ChangeCandidate, ComposerWeights)
parseRecord Map Text Value
record = do
      cand <- Map Text Value -> Maybe ChangeCandidate
parseCandidate Map Text Value
record
      weightsStr <- extractText =<< Map.lookup "weights" record
      pure (cand, parseWeightsJson weightsStr)

-- | Outgoing jazz transitions on the pre-aggregated corpus score — the
-- wildcard fast path, mirroring 'fetchTransitionsAggregate'. Sorted
-- highest first.
fetchChangeAggregate :: Text -> DbActionT [(ChangeCandidate, Double)]
fetchChangeAggregate :: Text -> DbActionT [(ChangeCandidate, Double)]
fetchChangeAggregate Text
showKey = do
  let query :: Text
query = [Text] -> Text
T.unlines
        [ Text
"MATCH (c:Change {show: $show})-[r:NEXT]->(n:Change)"
        , Text
"RETURN n.show AS show, n.movement AS movement, n.chord AS chord, r.confidence AS confidence"
        ]
  records <- Text -> Map Text Value -> DbActionT [Map Text Value]
runQueryP Text
query ([(Text, Value)] -> Map Text Value
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text
"show", Text -> Value
A.String Text
showKey)])
  pure $ sortBy (compare `on` (Down . snd))
       $ filter ((> 0) . snd)
       $ mapMaybe parseRecord records
  where
    parseRecord :: Map Text Value -> Maybe (ChangeCandidate, Double)
parseRecord Map Text Value
record = do
      cand <- Map Text Value -> Maybe ChangeCandidate
parseCandidate Map Text Value
record
      conf <- extractDouble =<< Map.lookup "confidence" record
      pure (cand, conf)

-- Shared row parser for Change node columns (show, movement, chord).
parseCandidate :: Map Text A.Value -> Maybe ChangeCandidate
parseCandidate :: Map Text Value -> Maybe ChangeCandidate
parseCandidate Map Text Value
record = do
  showTxt  <- Value -> Maybe Text
extractText (Value -> Maybe Text) -> Maybe Value -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Map Text Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"show" Map Text Value
record
  mvmtStr  <- extractText =<< Map.lookup "movement" record
  chordStr <- extractText =<< Map.lookup "chord" record
  mvmt     <- readMaybe (T.unpack mvmtStr)
  set      <- readMaybe (T.unpack chordStr)
  pure (ChangeCandidate showTxt mvmt set)

-- | Every jazz start candidate with its outgoing corpus mass — the
-- popularity-weighted pool the uncued 'Harmonic.Framework.Builder.genJ'
-- cue draws from (structure only: Change nodes are zero-form, the root
-- comes from the caller's tonal context). Nodes with no outgoing edges
-- are excluded — a walk could not leave them.
fetchChangeStarts :: DbActionT [(ChangeCandidate, Double)]
fetchChangeStarts :: DbActionT [(ChangeCandidate, Double)]
fetchChangeStarts = do
  let query :: Text
query = [Text] -> Text
T.unlines
        [ Text
"MATCH (c:Change)-[r:NEXT]->(:Change)"
        , Text
"WITH c, sum(r.confidence) AS out"
        , Text
"RETURN c.show AS show, c.movement AS movement, c.chord AS chord, out AS out"
        ]
  records <- Text -> DbActionT [Map Text Value]
runQuery Text
query
  pure $ filter ((> 0) . snd) $ mapMaybe parseRow records
  where
    parseRow :: Map Text Value -> Maybe (ChangeCandidate, Double)
parseRow Map Text Value
record = do
      cand <- Map Text Value -> Maybe ChangeCandidate
parseCandidate Map Text Value
record
      out  <- extractDouble =<< Map.lookup "out" record
      pure (cand, out)

-- | Resolve a cue functionality to a jazz walk-start node. Exact
-- movement+name keys are the caller's own lookup; this finds the best
-- node for a bare functionality: prefer the pedal arrival, then the
-- node with the most outgoing corpus mass.
resolveChangeCue :: Text -> DbActionT (Maybe Text)
resolveChangeCue :: Text -> DbActionT (Maybe Text)
resolveChangeCue Text
functionality = do
  let query :: Text
query = [Text] -> Text
T.unlines
        [ Text
"MATCH (n:Change) WHERE n.show ENDS WITH $suffix"
        , Text
"OPTIONAL MATCH (n)-[r:NEXT]->(:Change)"
        , Text
"WITH n.show AS s, sum(r.confidence) AS out"
        , Text
"RETURN s ORDER BY (CASE WHEN s STARTS WITH '( pedal' THEN 1 ELSE 0 END) DESC, out DESC"
        , Text
"LIMIT 1"
        ]
      suffix :: Text
suffix = Text
"-> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
functionality Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" )"
  records <- Text -> Map Text Value -> DbActionT [Map Text Value]
runQueryP Text
query ([(Text, Value)] -> Map Text Value
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text
"suffix", Text -> Value
A.String Text
suffix)])
  pure $ case records of
    (Map Text Value
r:[Map Text Value]
_) -> Value -> Maybe Text
extractText (Value -> Maybe Text) -> Maybe Value -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Map Text Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"s" Map Text Value
r
    []    -> Maybe Text
forall a. Maybe a
Nothing

-- | Split a parsed seek blend into its (jazz, classical-steer) halves
-- against the jazz graph's key set. A token names a jazz composer when
-- it matches a key exactly or as a substring (@"monk"@ matches
-- @"theloniousmonk"@ and co-credits); its weight is split equally across
-- all matching keys. Unmatched tokens are classical steer names. Both
-- halves are renormalised. Pure — callers fetch the key set once
-- ('fetchJazzComposers') and reuse it.
splitSeekByCorpus :: Set.Set Text -> ComposerWeights -> (ComposerWeights, ComposerWeights)
splitSeekByCorpus :: Set Text -> ComposerWeights -> (ComposerWeights, ComposerWeights)
splitSeekByCorpus Set Text
jazzKeys ComposerWeights
blend =
  let expand :: (Text, b) -> Either [(Text, b)] (Text, b)
expand (Text
tok, b
w)
        | Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Text
tok Set Text
jazzKeys = [(Text, b)] -> Either [(Text, b)] (Text, b)
forall a b. a -> Either a b
Left [(Text
tok, b
w)]
        | Bool -> Bool
not ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
subs)         = [(Text, b)] -> Either [(Text, b)] (Text, b)
forall a b. a -> Either a b
Left [ (Text
k, b
w b -> b -> b
forall a. Fractional a => a -> a -> a
/ Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
subs)) | Text
k <- [Text]
subs ]
        | Bool
otherwise               = (Text, b) -> Either [(Text, b)] (Text, b)
forall a b. b -> Either a b
Right (Text
tok, b
w)
        where subs :: [Text]
subs = [ Text
k | Text
k <- Set Text -> [Text]
forall a. Set a -> [a]
Set.toList Set Text
jazzKeys, Text
tok Text -> Text -> Bool
`T.isInfixOf` Text
k ]
      ([[(Text, Double)]]
js, [(Text, Double)]
cs) = [Either [(Text, Double)] (Text, Double)]
-> ([[(Text, Double)]], [(Text, Double)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers (((Text, Double) -> Either [(Text, Double)] (Text, Double))
-> [(Text, Double)] -> [Either [(Text, Double)] (Text, Double)]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Double) -> Either [(Text, Double)] (Text, Double)
forall {b}.
Fractional b =>
(Text, b) -> Either [(Text, b)] (Text, b)
expand (ComposerWeights -> [(Text, Double)]
forall k a. Map k a -> [(k, a)]
Map.toList ComposerWeights
blend))
  in ( ComposerWeights -> ComposerWeights
normalizeWeights ((Double -> Double -> Double) -> [(Text, Double)] -> ComposerWeights
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Double -> Double -> Double
forall a. Num a => a -> a -> a
(+) ([[(Text, Double)]] -> [(Text, Double)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Text, Double)]]
js))
     , ComposerWeights -> ComposerWeights
normalizeWeights ([(Text, Double)] -> ComposerWeights
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Double)]
cs) )

-- | Every composer key present in the jazz graph — the corpus membership
-- test that splits a mixed seek spec into its jazz-blend and
-- classical-steer halves. One scan of the (small) @Change@ edge set,
-- keys unioned client-side.
fetchJazzComposers :: DbActionT (Set.Set Text)
fetchJazzComposers :: DbActionT (Set Text)
fetchJazzComposers = do
  records <- Text -> DbActionT [Map Text Value]
runQuery Text
"MATCH (:Change)-[r:NEXT]->(:Change) RETURN r.weights AS w"
  pure $ Set.fromList
    [ T.toLower k
    | record <- records
    , Just wtxt <- [extractText =<< Map.lookup "w" record]
    , k <- Map.keys (parseWeightsJson wtxt)
    ]