{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      : Harmonic.Rules.Import.Graph
-- Description : Neo4j graph database connection and cadence storage
--
-- Provides 'connectNeo4j' for database connection and write operations
-- for storing cadence nodes and transition edges during data ingestion.

module Harmonic.Rules.Import.Graph (
    -- * Connection
    connectNeo4j,

    -- * Schema
    initGraph, truncateCadenceGraph,

    -- * Writing cadence transitions
    ComposerWeights, writeCadenceEdges, buildQuery,

    -- * Cypher field rendering
    showText, movementText, chordText, dissonanceText,
    confidenceText, weightsLiteral,

    -- * Vestigial
    queryNextCadences,
) where

import           Harmonic.Config
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 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

-- | How much each composer contributes to one @NEXT@ edge. Written to the
-- edge as a JSON literal by 'weightsLiteral', and summed into a single
-- @confidence@ property by 'confidenceText'.
type ComposerWeights = Map T.Text Double

-- |Initialise schema. Node identity is the @show@ string (movement +
-- functionality) — the functionality half of every key follows the naming
-- contract documented at the head of "Harmonic.Rules.Import.Transform"
-- (the live DB carries legacy names; read the warning there BEFORE any
-- re-ingestion).
initGraph :: Bolt.BoltActionT IO ()
initGraph :: BoltActionT IO ()
initGraph = do
  [Record]
_ <- Text -> BoltActionT IO [Record]
forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Text -> BoltActionT m [Record]
Bolt.query Text
"CALL apoc.schema.assert({}, {})"
  [Record]
_ <- Text -> BoltActionT IO [Record]
forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Text -> BoltActionT m [Record]
Bolt.query Text
"CREATE CONSTRAINT IF NOT EXISTS FOR (n:Cadence) REQUIRE n.show IS UNIQUE"
  () -> BoltActionT IO ()
forall a. a -> BoltActionT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Delete every @Cadence@ node and its @NEXT@ edges, batched through
-- @apoc.periodic.iterate@ to avoid memory spikes on a full corpus. Run before
-- a re-ingestion.
truncateCadenceGraph :: Bolt.BoltActionT IO ()
truncateCadenceGraph :: BoltActionT IO ()
truncateCadenceGraph = do
  [Record]
_ <- Text -> BoltActionT IO [Record]
forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Text -> BoltActionT m [Record]
Bolt.query Text
deleteCadences
  () -> BoltActionT IO ()
forall a. a -> BoltActionT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    deleteCadences :: Text
deleteCadences = [Text] -> Text
T.unlines
      [ Text
"CALL apoc.periodic.iterate("
      , Text
"  \"MATCH (n:Cadence) RETURN n\"," -- batch MATCH avoids memory spikes
      , Text
"  \"DETACH DELETE n\"," -- deletes cadences plus NEXT edges
      , Text
"  {batchSize: 5000, parallel: true}"
      , Text
")"
      ]

-- | Write a batch of cadence transitions. Each triple merges both endpoint
-- nodes and the @NEXT@ edge between them. Transitions with no composer weight
-- are skipped rather than written with zero confidence.
writeCadenceEdges :: [(H.Cadence, H.Cadence, ComposerWeights)] -> Bolt.BoltActionT IO ()
writeCadenceEdges :: [(Cadence, Cadence, ComposerWeights)] -> BoltActionT IO ()
writeCadenceEdges = ((Cadence, Cadence, ComposerWeights) -> BoltActionT IO ())
-> [(Cadence, Cadence, ComposerWeights)] -> BoltActionT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Cadence, Cadence, ComposerWeights) -> BoltActionT IO ()
forall {m :: * -> *}.
MonadIO m =>
(Cadence, Cadence, ComposerWeights) -> BoltActionT m ()
writeOne
  where
    writeOne :: (Cadence, Cadence, ComposerWeights) -> BoltActionT m ()
writeOne (Cadence
fromCadence, Cadence
toCadence, ComposerWeights
weights)
      | ComposerWeights -> Bool
forall k a. Map k a -> Bool
Map.null ComposerWeights
weights = () -> BoltActionT m ()
forall a. a -> BoltActionT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise = Text -> BoltActionT m [Record]
forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Text -> BoltActionT m [Record]
Bolt.query (Cadence -> Cadence -> ComposerWeights -> Text
buildQuery Cadence
fromCadence Cadence
toCadence ComposerWeights
weights) BoltActionT m [Record] -> BoltActionT m () -> BoltActionT m ()
forall a b. BoltActionT m a -> BoltActionT m b -> BoltActionT m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> BoltActionT m ()
forall a. a -> BoltActionT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Build the Cypher @MERGE@ for one transition. Node identity is the @show@
-- string; see 'initGraph' for the naming contract that governs it.
buildQuery :: H.Cadence -> H.Cadence -> ComposerWeights -> T.Text
buildQuery :: Cadence -> Cadence -> ComposerWeights -> Text
buildQuery Cadence
fromCadence Cadence
toCadence ComposerWeights
weights =
  [Text] -> Text
T.concat
    [ Text
"MERGE (from:Cadence {show: '", Cadence -> Text
showText Cadence
fromCadence, Text
"'}) "
    , Text
"SET from.movement = '", Cadence -> Text
movementText Cadence
fromCadence, Text
"', from.chord = '", Cadence -> Text
chordText Cadence
fromCadence
    , Text
"', from.dissonance = ", Cadence -> Text
dissonanceText Cadence
fromCadence, Text
" "
    , Text
"MERGE (to:Cadence {show: '", Cadence -> Text
showText Cadence
toCadence, Text
"'}) "
    , Text
"SET to.movement = '", Cadence -> Text
movementText Cadence
toCadence, Text
"', to.chord = '", Cadence -> Text
chordText Cadence
toCadence
    , Text
"', to.dissonance = ", Cadence -> Text
dissonanceText Cadence
toCadence, Text
" "
    , Text
"MERGE (from)-[r:NEXT]->(to) "
    , Text
"SET r.confidence = ", ComposerWeights -> Text
confidenceText ComposerWeights
weights
    , Text
", r.weights = ", ComposerWeights -> Text
weightsLiteral ComposerWeights
weights
    ]

-- | Node identity: the cadence's @show@ string, used as the @MERGE@ key.
showText :: H.Cadence -> T.Text
showText :: Cadence -> Text
showText = 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

-- | The movement half of a cadence, as a Cypher string value.
movementText :: H.Cadence -> T.Text
movementText :: Cadence -> Text
movementText Cadence
cadence =
  let (Movement
movement, [PitchClass]
_) = Cadence -> (Movement, [PitchClass])
H.deconstructCadence Cadence
cadence
   in String -> Text
T.pack (Movement -> String
forall a. Show a => a -> String
show Movement
movement)

-- | The chord half of a cadence, as a Cypher string value.
chordText :: H.Cadence -> T.Text
chordText :: Cadence -> Text
chordText Cadence
cadence =
  let (Movement
_, [PitchClass]
chord) = Cadence -> (Movement, [PitchClass])
H.deconstructCadence Cadence
cadence
   in String -> Text
T.pack ([PitchClass] -> String
forall a. Show a => a -> String
show [PitchClass]
chord)

-- | The cadence's dissonance level, as a Cypher numeric value. Computed at
-- write time so queries can filter on it without recomputing.
dissonanceText :: H.Cadence -> T.Text
dissonanceText :: Cadence -> Text
dissonanceText Cadence
cadence =
  let (Movement
_, [PitchClass]
chord) = Cadence -> (Movement, [PitchClass])
H.deconstructCadence Cadence
cadence
      ints :: [Int]
ints = (PitchClass -> Int) -> [PitchClass] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PitchClass -> Int
P.unPitchClass [PitchClass]
chord
      (Integer
value, [Int]
_) = [Int] -> (Integer, [Int])
D.dissonanceLevel [Int]
ints
   in String -> Text
T.pack (Integer -> String
forall a. Show a => a -> String
show Integer
value)

-- | Total edge weight across all composers, stored as @r.confidence@. This is
-- what a @\"*\"@ (all-composers) query ranks on.
confidenceText :: ComposerWeights -> T.Text
confidenceText :: ComposerWeights -> Text
confidenceText ComposerWeights
weights = String -> Text
T.pack (String -> Text) -> (Double -> String) -> Double -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> String
forall a. Show a => a -> String
show (Double -> Text) -> Double -> Text
forall a b. (a -> b) -> a -> b
$ [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)

-- | Per-composer weights as a JSON literal, stored as @r.weights@. Single
-- composer and blend queries read this rather than @r.confidence@.
weightsLiteral :: ComposerWeights -> T.Text
weightsLiteral :: ComposerWeights -> Text
weightsLiteral ComposerWeights
weights =
  let entries :: [(Text, Double)]
entries = ComposerWeights -> [(Text, Double)]
forall k a. Map k a -> [(k, a)]
Map.toList ComposerWeights
weights
      pieces :: [Text]
pieces = ((Text, Double) -> Text) -> [(Text, Double)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Double) -> Text
forall {a}. Show a => (Text, a) -> Text
formatEntry [(Text, Double)]
entries
   in [Text] -> Text
T.concat [Text
"'", Text
"{", Text -> [Text] -> Text
T.intercalate Text
"," [Text]
pieces, Text
"}", Text
"'"]
  where
    formatEntry :: (Text, a) -> Text
formatEntry (Text
name, a
value) = [Text] -> Text
T.concat [Text
"\"", Text
name, Text
"\":", String -> Text
T.pack (a -> String
forall a. Show a => a -> String
show a
value)]

-- | Vestigial stub: always returns @[]@ and ignores its argument. Cadence
-- lookup lives in "Harmonic.Evaluation.Database.Query" instead. Retained only
-- so existing imports keep compiling; do not build on it.
queryNextCadences :: T.Text -> Bolt.BoltActionT IO [T.Text]
queryNextCadences :: Text -> BoltActionT IO [Text]
queryNextCadences Text
_ = [Text] -> BoltActionT IO [Text]
forall a. a -> BoltActionT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- | Open a Bolt connection to the local Neo4j on port 7687, using the
-- credentials in "Harmonic.Config". Every online generation path needs one.
connectNeo4j :: IO Bolt.Pipe
connectNeo4j :: IO Pipe
connectNeo4j = BoltCfg -> IO Pipe
forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
BoltCfg -> m Pipe
Bolt.connect (BoltCfg -> IO Pipe) -> BoltCfg -> IO Pipe
forall a b. (a -> b) -> a -> b
$ BoltCfg
forall a. Default a => a
def
  { Bolt.user = neo4jUser
  , Bolt.password = neo4jPassword
  , Bolt.host = "localhost"
  , Bolt.port = 7687
  }