-- |
-- Module      : Harmonic.Evaluation.Analysis.Markov
-- Description : Markov transition probability computation (ingestion-only)
--
-- This module is used exclusively during data ingestion (@app\/Main.hs@) to
-- compute transition probabilities from the YCACL corpus. These probabilities
-- are stored as edge weights in the Neo4j graph database.
--
-- This module is NOT used in the runtime generation path. At runtime,
-- transition weights are read from Neo4j edges by
-- "Harmonic.Evaluation.Database.Query".
--
-- == Academic Lineage
--
-- /Data Science In The Creative Process/ (South, 2018), Section: Markov
-- module. The Markov chain approach resolves "Generative Uninspiration" —
-- the problem of manually traversing exhaustive overtone combination charts
-- — by training transition probabilities on the Yale Classical Archives
-- Corpus (Bach chorales and other composers).

module Harmonic.Evaluation.Analysis.Markov
  ( Edge
  , TransitionCounts
  , transitionCounts
  , transitionProbabilities
  ) where

import           Harmonic.Rules.Types.Harmony (Cadence)

import qualified Data.Map.Strict as Map
import           Data.Map.Strict (Map)
import           Data.List (foldl')

-- |Representation of a transition between cadences.
type Edge = (Cadence, Cadence)

-- | Raw observed counts per edge, before normalisation.
type TransitionCounts = Map Edge Double

-- | Total outgoing weight per source cadence, the denominator used when
-- normalising counts into probabilities.
type Totals = Map Cadence Double

-- | Count each adjacent pair in a cadence sequence. Ingestion-only: the live
-- generator reads edge weights from Neo4j rather than recomputing these.
transitionCounts :: [Cadence] -> TransitionCounts
transitionCounts :: [Cadence] -> TransitionCounts
transitionCounts [Cadence]
cadences =
  (TransitionCounts -> Edge -> TransitionCounts)
-> TransitionCounts -> [Edge] -> TransitionCounts
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TransitionCounts -> Edge -> TransitionCounts
forall {k} {a}. (Ord k, Num a) => Map k a -> k -> Map k a
insertEdge TransitionCounts
forall k a. Map k a
Map.empty ([Cadence] -> [Cadence] -> [Edge]
forall a b. [a] -> [b] -> [(a, b)]
zip [Cadence]
cadences (Int -> [Cadence] -> [Cadence]
forall a. Int -> [a] -> [a]
drop Int
1 [Cadence]
cadences))
  where
    insertEdge :: Map k a -> k -> Map k a
insertEdge Map k a
acc k
edge = (a -> a -> a) -> k -> a -> Map k a -> Map k a
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith a -> a -> a
forall a. Num a => a -> a -> a
(+) k
edge a
1 Map k a
acc

-- | Normalise 'transitionCounts' into per-source transition probabilities, so
-- the outgoing edges of each cadence sum to 1.
transitionProbabilities :: [Cadence] -> Map Edge Double
transitionProbabilities :: [Cadence] -> TransitionCounts
transitionProbabilities [Cadence]
cadences =
  let counts :: TransitionCounts
counts = [Cadence] -> TransitionCounts
transitionCounts [Cadence]
cadences
      totals :: Totals
totals = TransitionCounts -> Totals
buildTotals TransitionCounts
counts
   in (Edge -> Double -> Double) -> TransitionCounts -> TransitionCounts
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (Totals -> Edge -> Double -> Double
normalise Totals
totals) TransitionCounts
counts
  where
    buildTotals :: TransitionCounts -> Totals
    buildTotals :: TransitionCounts -> Totals
buildTotals = (Totals -> (Edge, Double) -> Totals)
-> Totals -> [(Edge, Double)] -> Totals
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Totals -> (Edge, Double) -> Totals
forall {k} {a} {b}.
(Ord k, Num a) =>
Map k a -> ((k, b), a) -> Map k a
accumulate Totals
forall k a. Map k a
Map.empty ([(Edge, Double)] -> Totals)
-> (TransitionCounts -> [(Edge, Double)])
-> TransitionCounts
-> Totals
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransitionCounts -> [(Edge, Double)]
forall k a. Map k a -> [(k, a)]
Map.toList
      where
        accumulate :: Map k a -> ((k, b), a) -> Map k a
accumulate Map k a
acc ((k
from,b
_), a
weight) = (a -> a -> a) -> k -> a -> Map k a -> Map k a
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith a -> a -> a
forall a. Num a => a -> a -> a
(+) k
from a
weight Map k a
acc

    normalise :: Totals -> Edge -> Double -> Double
    normalise :: Totals -> Edge -> Double -> Double
normalise Totals
totals (Cadence
from, Cadence
_) Double
weight =
      case Cadence -> Totals -> Maybe Double
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Cadence
from Totals
totals of
        Just Double
total | Double
total Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 -> Double
weight Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
total
        Maybe Double
_                     -> Double
0