{-# LANGUAGE OverloadedStrings #-}

-- |
-- 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
  
    -- * Graph Queries
  , fetchTransitions
  
    -- * Weight Resolution
  , resolveWeights
  , applyComposerBlend
  ) where

import qualified Database.Bolt as Bolt
import           Data.Default (def)
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.Char (isSpace, isDigit)
import           Data.List (sortBy)
import           Data.Ord (Down(..))
import           Data.Function (on)
import           Control.Monad (forM)
import qualified Data.Aeson as Aeson
import           Data.Aeson (FromJSON(..), Value(..), (.:))
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KM
import qualified Data.ByteString.Lazy as BL

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 -> Bolt.BoltActionT IO [(H.Cadence, ComposerWeights)]
fetchTransitions :: Text -> BoltActionT IO [(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
Bolt.T Text
cadenceShow)]
  
  [Map Text Value]
records <- Text -> Map Text Value -> BoltActionT IO [Map Text Value]
forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Text -> Map Text Value -> BoltActionT m [Map Text Value]
Bolt.queryP Text
query Map Text Value
params
  [(Cadence, ComposerWeights)]
-> BoltActionT IO [(Cadence, ComposerWeights)]
forall a. a -> BoltActionT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Cadence, ComposerWeights)]
 -> BoltActionT IO [(Cadence, ComposerWeights)])
-> [(Cadence, ComposerWeights)]
-> BoltActionT IO [(Cadence, ComposerWeights)]
forall a b. (a -> b) -> a -> b
$ (Map Text Value -> Maybe (Cadence, ComposerWeights))
-> [Map Text Value] -> [(Cadence, ComposerWeights)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Map Text Value -> Maybe (Cadence, ComposerWeights)
parseRecord [Map Text Value]
records
  where
    parseRecord :: Bolt.Record -> Maybe (H.Cadence, ComposerWeights)
    parseRecord :: Map Text Value -> Maybe (Cadence, ComposerWeights)
parseRecord Map Text Value
record = do
      Value
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
      Value
chordVal <- Text -> Map Text Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"chord" Map Text Value
record
      Value
weightsVal <- Text -> Map Text Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"weights" Map Text Value
record
      
      Text
mvmtStr <- Value -> Maybe Text
extractText Value
mvmtVal
      Text
chordStr <- Value -> Maybe Text
extractText Value
chordVal
      Text
weightsStr <- Value -> Maybe Text
extractText Value
weightsVal
      
      let cadence :: Cadence
cadence = (String, String) -> Cadence
H.constructCadence (Text -> String
T.unpack Text
mvmtStr, Text -> String
T.unpack Text
chordStr)
      let weights :: ComposerWeights
weights = Text -> ComposerWeights
parseWeightsJson Text
weightsStr
      
      (Cadence, ComposerWeights) -> Maybe (Cadence, ComposerWeights)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cadence
cadence, ComposerWeights
weights)

-------------------------------------------------------------------------------
-- 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 -> [(H.Cadence, ComposerWeights)] -> [(H.Cadence, Double)]
resolveWeights :: ComposerWeights
-> [(Cadence, ComposerWeights)] -> [(Cadence, Double)]
resolveWeights ComposerWeights
blend [(Cadence, ComposerWeights)]
candidates =
  let scored :: [(Cadence, Double)]
scored = ((Cadence, ComposerWeights) -> (Cadence, Double))
-> [(Cadence, ComposerWeights)] -> [(Cadence, Double)]
forall a b. (a -> b) -> [a] -> [b]
map (ComposerWeights -> (Cadence, ComposerWeights) -> (Cadence, Double)
scoreCandidate ComposerWeights
blend) [(Cadence, ComposerWeights)]
candidates
      sorted :: [(Cadence, Double)]
sorted = ((Cadence, Double) -> (Cadence, Double) -> Ordering)
-> [(Cadence, Double)] -> [(Cadence, 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)
-> ((Cadence, Double) -> Down Double)
-> (Cadence, Double)
-> (Cadence, 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)
-> ((Cadence, Double) -> Double)
-> (Cadence, Double)
-> Down Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cadence, Double) -> Double
forall a b. (a, b) -> b
snd)) [(Cadence, Double)]
scored  -- Highest first
   in [(Cadence, Double)]
sorted
  where
    scoreCandidate :: ComposerWeights -> (H.Cadence, ComposerWeights) -> (H.Cadence, Double)
    scoreCandidate :: ComposerWeights -> (Cadence, ComposerWeights) -> (Cadence, Double)
scoreCandidate ComposerWeights
userBlend (Cadence
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)
          (Cadence
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 (Cadence
cadence, Double
score)

-- |Apply composer blend to filter transitions, keeping only those with score > 0
applyComposerBlend :: ComposerWeights -> [(H.Cadence, ComposerWeights)] -> [(H.Cadence, Double)]
applyComposerBlend :: ComposerWeights
-> [(Cadence, ComposerWeights)] -> [(Cadence, Double)]
applyComposerBlend ComposerWeights
blend = ((Cadence, Double) -> Bool)
-> [(Cadence, Double)] -> [(Cadence, Double)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0) (Double -> Bool)
-> ((Cadence, Double) -> Double) -> (Cadence, Double) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cadence, Double) -> Double
forall a b. (a, b) -> b
snd) ([(Cadence, Double)] -> [(Cadence, Double)])
-> ([(Cadence, ComposerWeights)] -> [(Cadence, Double)])
-> [(Cadence, ComposerWeights)]
-> [(Cadence, Double)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComposerWeights
-> [(Cadence, ComposerWeights)] -> [(Cadence, 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 (ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
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)

-------------------------------------------------------------------------------
-- Bolt Value Extractors
-------------------------------------------------------------------------------

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

extractDouble :: Bolt.Value -> Maybe Double
extractDouble :: Value -> Maybe Double
extractDouble (Bolt.F Double
d) = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
d
extractDouble (Bolt.I Int
i) = Double -> Maybe Double
forall a. a -> Maybe a
Just (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)
extractDouble Value
_          = Maybe Double
forall a. Maybe a
Nothing