-- |
-- Module      : Harmonic.Rules.Import.Graph
-- Description : Neo4j graph database connection and cadence storage
--
-- Write operations for storing cadence nodes and transition edges during
-- data ingestion, plus a re-export of 'connectNeo4j' (the connection itself
-- lives in "Harmonic.Database").
--
-- Writes are BATCHED and PARAMETERISED: edges travel as a @$rows@ JSON
-- parameter into one @UNWIND@ + @MERGE@ statement per batch, so a full
-- corpus write is a few hundred transactional round trips rather than one
-- auto-committing request per edge, and no value is ever spliced into
-- Cypher text.

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

    -- * Schema
    initGraph, truncateCadenceGraph,

    -- * Writing cadence transitions
    ComposerWeights, writeCadenceEdges, edgeRow, batchCypher,

    -- * Writing jazz (Change) transitions
    initChangeGraph, truncateChangeGraph,
    writeChangeEdges, changeEdgeRow, changeBatchCypher,
) where

import           Harmonic.Database (DbActionT, connectNeo4j, runQuery, runQueryP)
import qualified Harmonic.Rules.Types.Harmony as H
import qualified Harmonic.Rules.Import.Jazz as J
import qualified Harmonic.Rules.Types.Pitch as P
import qualified Harmonic.Evaluation.Scoring.Dissonance as D

import qualified Data.Aeson as A
import           Data.Aeson ((.=))
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map.Strict as Map
import           Data.Map.Strict (Map)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE

-- | How much each composer contributes to one @NEXT@ edge. Serialised to a
-- JSON object string on the edge's @weights@ property (sparse: absent
-- composer = weight 0), and summed into a single @confidence@ property.
type ComposerWeights = Map T.Text Double

-- |Initialise schema: the uniqueness constraint on the @show@ node key.
-- Idempotent (@IF NOT EXISTS@) and non-destructive — it touches nothing
-- else in the database. 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".
initGraph :: DbActionT ()
initGraph :: DbActionT ()
initGraph = do
  _ <- Text -> DbActionT [Map Text Value]
runQuery Text
"CREATE CONSTRAINT IF NOT EXISTS FOR (n:Cadence) REQUIRE n.show IS UNIQUE"
  pure ()

-- | Delete every @Cadence@ node and its @NEXT@ edges. Run before a
-- re-ingestion. The cadence graph is small by construction (at most
-- 55 zero-forms x 12 movements = 660 nodes), so a plain @DETACH DELETE@
-- suffices — no batching machinery required.
truncateCadenceGraph :: DbActionT ()
truncateCadenceGraph :: DbActionT ()
truncateCadenceGraph = do
  _ <- Text -> DbActionT [Map Text Value]
runQuery Text
"MATCH (n:Cadence) DETACH DELETE n"
  pure ()

-- | Write cadence transitions in parameterised batches of 1000 rows.
-- Each batch is one transactional @UNWIND@ round trip; @MERGE@ keeps every
-- row idempotent, so a failed run can simply be re-run. Node properties
-- are set only @ON CREATE@ (they are pure functions of the node key, so
-- re-setting them per edge would be redundant writes). Transitions with
-- no composer weight are skipped rather than written with zero confidence.
writeCadenceEdges :: [(H.Cadence, H.Cadence, ComposerWeights)] -> DbActionT ()
writeCadenceEdges :: [(Cadence, Cadence, ComposerWeights)] -> DbActionT ()
writeCadenceEdges [(Cadence, Cadence, ComposerWeights)]
edges =
  ([(Cadence, Cadence, ComposerWeights)] -> DbActionT ())
-> [[(Cadence, Cadence, ComposerWeights)]] -> DbActionT ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [(Cadence, Cadence, ComposerWeights)] -> DbActionT ()
writeBatch (([(Cadence, Cadence, ComposerWeights)] -> Bool)
-> [[(Cadence, Cadence, ComposerWeights)]]
-> [[(Cadence, Cadence, ComposerWeights)]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ([(Cadence, Cadence, ComposerWeights)] -> Bool)
-> [(Cadence, Cadence, ComposerWeights)]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Cadence, Cadence, ComposerWeights)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (Int
-> [(Cadence, Cadence, ComposerWeights)]
-> [[(Cadence, Cadence, ComposerWeights)]]
forall {a}. Int -> [a] -> [[a]]
chunksOf Int
1000 (((Cadence, Cadence, ComposerWeights) -> Bool)
-> [(Cadence, Cadence, ComposerWeights)]
-> [(Cadence, Cadence, ComposerWeights)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Cadence, Cadence, ComposerWeights) -> Bool
forall {a} {b} {k} {a}. (a, b, Map k a) -> Bool
hasWeight [(Cadence, Cadence, ComposerWeights)]
edges)))
  where
    hasWeight :: (a, b, Map k a) -> Bool
hasWeight (a
_, b
_, Map k a
weights) = Bool -> Bool
not (Map k a -> Bool
forall k a. Map k a -> Bool
Map.null Map k a
weights)
    writeBatch :: [(Cadence, Cadence, ComposerWeights)] -> DbActionT ()
writeBatch [(Cadence, Cadence, ComposerWeights)]
batch = do
      let rows :: Value
rows = [Value] -> Value
forall a. ToJSON a => a -> Value
A.toJSON (((Cadence, Cadence, ComposerWeights) -> Value)
-> [(Cadence, Cadence, ComposerWeights)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (Cadence, Cadence, ComposerWeights) -> Value
edgeRow [(Cadence, Cadence, ComposerWeights)]
batch)
      _ <- Text -> Map Text Value -> DbActionT [Map Text Value]
runQueryP Text
batchCypher (Text -> Value -> Map Text Value
forall k a. k -> a -> Map k a
Map.singleton Text
"rows" Value
rows)
      pure ()
    chunksOf :: Int -> [a] -> [[a]]
chunksOf Int
n [a]
xs = case Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
xs of
      ([a]
chunk, [])   -> [[a]
chunk]
      ([a]
chunk, [a]
rest) -> [a]
chunk [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: Int -> [a] -> [[a]]
chunksOf Int
n [a]
rest

-- | The one write statement: unwind the batch, merge both endpoint nodes
-- and the @NEXT@ edge, stamp the edge's confidence and per-composer
-- weights.
batchCypher :: T.Text
batchCypher :: Text
batchCypher = [Text] -> Text
T.unlines
  [ Text
"UNWIND $rows AS row"
  , Text
"MERGE (from:Cadence {show: row.fromShow})"
  , Text
"  ON CREATE SET from.movement = row.fromMovement,"
  , Text
"                from.chord = row.fromChord,"
  , Text
"                from.dissonance = row.fromDissonance"
  , Text
"MERGE (to:Cadence {show: row.toShow})"
  , Text
"  ON CREATE SET to.movement = row.toMovement,"
  , Text
"                to.chord = row.toChord,"
  , Text
"                to.dissonance = row.toDissonance"
  , Text
"MERGE (from)-[r:NEXT]->(to)"
  , Text
"SET r.confidence = row.confidence, r.weights = row.weights"
  ]

-- | One edge as a @$rows@ element. Node fields are pure functions of the
-- cadence (the @show@ key, its movement and chord halves, and the
-- dissonance level computed at write time so queries can filter on it).
-- @weights@ is the JSON object string the read side
-- ('Harmonic.Evaluation.Database.Query.parseWeightsJson') parses back;
-- @confidence@ is the sum of all composer weights (what a @"*"@ query
-- ranks on).
edgeRow :: (H.Cadence, H.Cadence, ComposerWeights) -> A.Value
edgeRow :: (Cadence, Cadence, ComposerWeights) -> Value
edgeRow (Cadence
fromCadence, Cadence
toCadence, ComposerWeights
weights) = [Pair] -> Value
A.object
  [ Key
"fromShow"       Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Cadence -> String
forall a. Show a => a -> String
show Cadence
fromCadence
  , Key
"fromMovement"   Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Movement -> String
forall a. Show a => a -> String
show ((Movement, [PitchClass]) -> Movement
forall a b. (a, b) -> a
fst (Cadence -> (Movement, [PitchClass])
H.deconstructCadence Cadence
fromCadence))
  , Key
"fromChord"      Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [PitchClass] -> String
forall a. Show a => a -> String
show ((Movement, [PitchClass]) -> [PitchClass]
forall a b. (a, b) -> b
snd (Cadence -> (Movement, [PitchClass])
H.deconstructCadence Cadence
fromCadence))
  , Key
"fromDissonance" Key -> Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Cadence -> Integer
dissonanceOf Cadence
fromCadence
  , Key
"toShow"         Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Cadence -> String
forall a. Show a => a -> String
show Cadence
toCadence
  , Key
"toMovement"     Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Movement -> String
forall a. Show a => a -> String
show ((Movement, [PitchClass]) -> Movement
forall a b. (a, b) -> a
fst (Cadence -> (Movement, [PitchClass])
H.deconstructCadence Cadence
toCadence))
  , Key
"toChord"        Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [PitchClass] -> String
forall a. Show a => a -> String
show ((Movement, [PitchClass]) -> [PitchClass]
forall a b. (a, b) -> b
snd (Cadence -> (Movement, [PitchClass])
H.deconstructCadence Cadence
toCadence))
  , Key
"toDissonance"   Key -> Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Cadence -> Integer
dissonanceOf Cadence
toCadence
  , Key
"confidence"     Key -> Double -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [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)
  , Key
"weights"        Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
TE.decodeUtf8 (LazyByteString -> ByteString
BL.toStrict (ComposerWeights -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
A.encode ComposerWeights
weights))
  ]
  where
    dissonanceOf :: Cadence -> Integer
dissonanceOf Cadence
cadence =
      let (Movement
_, [PitchClass]
chord) = Cadence -> (Movement, [PitchClass])
H.deconstructCadence Cadence
cadence
          (Integer
value, [Int]
_) = [Int] -> (Integer, [Int])
D.dissonanceLevel ((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)
       in Integer
value

-- | Initialise the jazz-graph schema: uniqueness on the @Change@ node
-- key. Idempotent and label-scoped — resident @Cadence@ data is
-- untouched.
initChangeGraph :: DbActionT ()
initChangeGraph :: DbActionT ()
initChangeGraph = do
  _ <- Text -> DbActionT [Map Text Value]
runQuery Text
"CREATE CONSTRAINT IF NOT EXISTS FOR (n:Change) REQUIRE n.show IS UNIQUE"
  pure ()

-- | Delete every @Change@ node and its edges — and nothing else: the
-- statement matches by label only, so the classical graph cannot be
-- touched. The jazz graph is small (994 nodes / 9,235 edges from the
-- full Bunks corpus), so a plain @DETACH DELETE@ suffices.
truncateChangeGraph :: DbActionT ()
truncateChangeGraph :: DbActionT ()
truncateChangeGraph = do
  _ <- Text -> DbActionT [Map Text Value]
runQuery Text
"MATCH (n:Change) DETACH DELETE n"
  pure ()

-- | Write jazz transitions in parameterised batches of 1000 rows, the
-- same idempotent @UNWIND@ + @MERGE@ shape as 'writeCadenceEdges'.
writeChangeEdges :: [((J.JazzCadence, J.JazzCadence), ComposerWeights)] -> DbActionT ()
writeChangeEdges :: [((JazzCadence, JazzCadence), ComposerWeights)] -> DbActionT ()
writeChangeEdges [((JazzCadence, JazzCadence), ComposerWeights)]
edges =
  ([((JazzCadence, JazzCadence), ComposerWeights)] -> DbActionT ())
-> [[((JazzCadence, JazzCadence), ComposerWeights)]]
-> DbActionT ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [((JazzCadence, JazzCadence), ComposerWeights)] -> DbActionT ()
writeBatch (([((JazzCadence, JazzCadence), ComposerWeights)] -> Bool)
-> [[((JazzCadence, JazzCadence), ComposerWeights)]]
-> [[((JazzCadence, JazzCadence), ComposerWeights)]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ([((JazzCadence, JazzCadence), ComposerWeights)] -> Bool)
-> [((JazzCadence, JazzCadence), ComposerWeights)]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [((JazzCadence, JazzCadence), ComposerWeights)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (Int
-> [((JazzCadence, JazzCadence), ComposerWeights)]
-> [[((JazzCadence, JazzCadence), ComposerWeights)]]
forall {a}. Int -> [a] -> [[a]]
chunksOf Int
1000 ((((JazzCadence, JazzCadence), ComposerWeights) -> Bool)
-> [((JazzCadence, JazzCadence), ComposerWeights)]
-> [((JazzCadence, JazzCadence), ComposerWeights)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((JazzCadence, JazzCadence), ComposerWeights) -> Bool
forall {a} {k} {a}. (a, Map k a) -> Bool
hasWeight [((JazzCadence, JazzCadence), ComposerWeights)]
edges)))
  where
    hasWeight :: (a, Map k a) -> Bool
hasWeight (a
_, Map k a
weights) = Bool -> Bool
not (Map k a -> Bool
forall k a. Map k a -> Bool
Map.null Map k a
weights)
    writeBatch :: [((JazzCadence, JazzCadence), ComposerWeights)] -> DbActionT ()
writeBatch [((JazzCadence, JazzCadence), ComposerWeights)]
batch = do
      let rows :: Value
rows = [Value] -> Value
forall a. ToJSON a => a -> Value
A.toJSON ((((JazzCadence, JazzCadence), ComposerWeights) -> Value)
-> [((JazzCadence, JazzCadence), ComposerWeights)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map ((JazzCadence, JazzCadence), ComposerWeights) -> Value
changeEdgeRow [((JazzCadence, JazzCadence), ComposerWeights)]
batch)
      _ <- Text -> Map Text Value -> DbActionT [Map Text Value]
runQueryP Text
changeBatchCypher (Text -> Value -> Map Text Value
forall k a. k -> a -> Map k a
Map.singleton Text
"rows" Value
rows)
      pure ()
    chunksOf :: Int -> [a] -> [[a]]
chunksOf Int
n [a]
xs = case Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
xs of
      ([a]
chunk, [])   -> [[a]
chunk]
      ([a]
chunk, [a]
rest) -> [a]
chunk [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: Int -> [a] -> [[a]]
chunksOf Int
n [a]
rest

-- | The jazz write statement: identical shape to 'batchCypher' with the
-- @Change@ label.
changeBatchCypher :: T.Text
changeBatchCypher :: Text
changeBatchCypher = [Text] -> Text
T.unlines
  [ Text
"UNWIND $rows AS row"
  , Text
"MERGE (from:Change {show: row.fromShow})"
  , Text
"  ON CREATE SET from.movement = row.fromMovement,"
  , Text
"                from.chord = row.fromChord,"
  , Text
"                from.dissonance = row.fromDissonance"
  , Text
"MERGE (to:Change {show: row.toShow})"
  , Text
"  ON CREATE SET to.movement = row.toMovement,"
  , Text
"                to.chord = row.toChord,"
  , Text
"                to.dissonance = row.toDissonance"
  , Text
"MERGE (from)-[r:NEXT]->(to)"
  , Text
"SET r.confidence = row.confidence, r.weights = row.weights"
  ]

-- | One jazz edge as a @$rows@ element. The @show@ key comes from
-- 'J.jazzShow' (same @( movement -> functionality )@ shape as the
-- classical key); @chord@ is the plain zero-form interval list (no
-- legacy naming contract in the jazz keyspace); @dissonance@ reuses the
-- classical scorer, which is arity-agnostic.
changeEdgeRow :: ((J.JazzCadence, J.JazzCadence), ComposerWeights) -> A.Value
changeEdgeRow :: ((JazzCadence, JazzCadence), ComposerWeights) -> Value
changeEdgeRow ((JazzCadence
fromCadence, JazzCadence
toCadence), ComposerWeights
weights) = [Pair] -> Value
A.object
  [ Key
"fromShow"       Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= JazzCadence -> Text
J.jazzShow JazzCadence
fromCadence
  , Key
"fromMovement"   Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Movement -> String
forall a. Show a => a -> String
show (JazzCadence -> Movement
J.jzMovement JazzCadence
fromCadence)
  , Key
"fromChord"      Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Int] -> String
forall a. Show a => a -> String
show (JazzCadence -> [Int]
J.jzSet JazzCadence
fromCadence)
  , Key
"fromDissonance" Key -> Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Integer, [Int]) -> Integer
forall a b. (a, b) -> a
fst ([Int] -> (Integer, [Int])
D.dissonanceLevel (JazzCadence -> [Int]
J.jzSet JazzCadence
fromCadence))
  , Key
"toShow"         Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= JazzCadence -> Text
J.jazzShow JazzCadence
toCadence
  , Key
"toMovement"     Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Movement -> String
forall a. Show a => a -> String
show (JazzCadence -> Movement
J.jzMovement JazzCadence
toCadence)
  , Key
"toChord"        Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Int] -> String
forall a. Show a => a -> String
show (JazzCadence -> [Int]
J.jzSet JazzCadence
toCadence)
  , Key
"toDissonance"   Key -> Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Integer, [Int]) -> Integer
forall a b. (a, b) -> a
fst ([Int] -> (Integer, [Int])
D.dissonanceLevel (JazzCadence -> [Int]
J.jzSet JazzCadence
toCadence))
  , Key
"confidence"     Key -> Double -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [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)
  , Key
"weights"        Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
TE.decodeUtf8 (LazyByteString -> ByteString
BL.toStrict (ComposerWeights -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
A.encode ComposerWeights
weights))
  ]