-- |
-- Module      : Harmonic.Rules.Import.Merge
-- Description : Composer normalisation, curation, and transition merging
--
-- The stages of the ingestion pipeline that sit between the per-piece
-- cadence expansion ("Harmonic.Rules.Import.Transform") and the graph
-- write ("Harmonic.Rules.Import.Graph"): normalising raw composer names
-- to corpus keys, applying the curated allow-list, and merging
-- per-composer transition maps into per-edge composer weight maps.
--
-- == The composer-key contract
--
-- 'slug' is the ingester's normaliser. The exporter
-- (@scripts\/export_ycacl.R@, @normalize_composer@) must apply the SAME
-- rule: any curation list matched against keys produced under a
-- different normalisation silently drops every composer whose two keys
-- disagree. Any change here must be mirrored in the exporter.
module Harmonic.Rules.Import.Merge (
    ComposerPieces,
    slug,
    normalizeComposers,
    filterComposers,
    mergeComposerTransitions,
) where

import qualified Data.Map.Strict as Map
import           Data.Map.Strict (Map)
import qualified Data.Text as T
import           Data.Text (Text)
import           Data.Char (isAlphaNum)

import           Harmonic.Rules.Import.CSV (YCACLData)
import           Harmonic.Rules.Import.Types (ChordSlice)
import           Harmonic.Rules.Import.Graph (ComposerWeights)
import           Harmonic.Evaluation.Analysis.Markov (Edge)
import qualified Harmonic.Rules.Types.Harmony as H

-- | Composer catalogues keyed by normalised ('slug') composer name.
type ComposerPieces = Map Text (Map Text [ChordSlice])

-- | Normalise a raw corpus composer string to a graph composer key:
-- lowercase, keep alphanumerics and spaces, then map spaces (and any
-- other retained non-alphanumeric) to @_@.
--
-- This is the key under which every edge weight is stored and fetched
-- (@r.weights@ in Neo4j, parsed by "Harmonic.Evaluation.Database.Query").
slug :: Text -> Text
slug :: Text -> Text
slug = Text -> Text
sanitize (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower
  where
    sanitize :: Text -> Text
sanitize = (Char -> Char) -> Text -> Text
T.map Char -> Char
replaceChar (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.filter Char -> Bool
validChar
    validChar :: Char -> Bool
validChar Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' '
    replaceChar :: Char -> Char
replaceChar Char
c
      | Char -> Bool
isAlphaNum Char
c = Char
c
      | Bool
otherwise    = Char
'_'

-- | Re-key the parsed corpus by 'slug', merging composers whose raw
-- names normalise identically.
normalizeComposers :: YCACLData -> ComposerPieces
normalizeComposers :: YCACLData -> YCACLData
normalizeComposers YCACLData
dataset = (YCACLData -> (Text, Map Text [ChordSlice]) -> YCACLData)
-> YCACLData -> [(Text, Map Text [ChordSlice])] -> YCACLData
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' YCACLData -> (Text, Map Text [ChordSlice]) -> YCACLData
forall {k} {a}.
Ord k =>
Map Text (Map k [a]) -> (Text, Map k [a]) -> Map Text (Map k [a])
insertComposer YCACLData
forall k a. Map k a
Map.empty (YCACLData -> [(Text, Map Text [ChordSlice])]
forall k a. Map k a -> [(k, a)]
Map.toList YCACLData
dataset)
  where
    insertComposer :: Map Text (Map k [a]) -> (Text, Map k [a]) -> Map Text (Map k [a])
insertComposer Map Text (Map k [a])
acc (Text
composer, Map k [a]
pieces) =
      let key :: Text
key = Text -> Text
slug Text
composer
       in (Map k [a] -> Map k [a] -> Map k [a])
-> Text
-> Map k [a]
-> Map Text (Map k [a])
-> Map Text (Map k [a])
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (([a] -> [a] -> [a]) -> Map k [a] -> Map k [a] -> Map k [a]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++)) Text
key Map k [a]
pieces Map Text (Map k [a])
acc

-- | Apply curation: an allow-list (empty admits everything) and an
-- exclude-list. Returns the kept catalogues and the dropped keys (with
-- piece counts), so the caller can REPORT every refusal instead of
-- losing composers silently.
filterComposers :: [Text] -> [Text] -> ComposerPieces -> (ComposerPieces, [(Text, Int)])
filterComposers :: [Text] -> [Text] -> YCACLData -> (YCACLData, [(Text, Int)])
filterComposers [Text]
include [Text]
exclude YCACLData
dataset =
  let admits :: Text -> Bool
admits Text
key = ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
include Bool -> Bool -> Bool
|| Text
key Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
include)
                   Bool -> Bool -> Bool
&& Text
key Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
exclude
      (YCACLData
kept, YCACLData
dropped) = (Text -> Map Text [ChordSlice] -> Bool)
-> YCACLData -> (YCACLData, YCACLData)
forall k a. (k -> a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partitionWithKey (\Text
k Map Text [ChordSlice]
_ -> Text -> Bool
admits Text
k) YCACLData
dataset
   in (YCACLData
kept, [ (Text
k, Map Text [ChordSlice] -> Int
forall k a. Map k a -> Int
Map.size Map Text [ChordSlice]
pieces) | (Text
k, Map Text [ChordSlice]
pieces) <- YCACLData -> [(Text, Map Text [ChordSlice])]
forall k a. Map k a -> [(k, a)]
Map.toList YCACLData
dropped ])

-- | Merge per-composer transition probability maps into one map per
-- edge, keyed by composer. Edges whose total weight is zero are
-- excluded. Weights are SPARSE: a composer absent from an edge's map
-- carries implicit weight 0 — the read side
-- ('Harmonic.Evaluation.Database.Query.resolveWeights') reads a missing
-- key as 0, so dense zero-padding would only inflate the store.
mergeComposerTransitions
  :: Map Text (Map Edge Double)
  -> [(H.Cadence, H.Cadence, ComposerWeights)]
mergeComposerTransitions :: Map Text (Map Edge Double) -> [(Cadence, Cadence, ComposerWeights)]
mergeComposerTransitions Map Text (Map Edge Double)
transitionMaps =
  let merged :: Map Edge ComposerWeights
merged = (Map Edge ComposerWeights
 -> Text -> Map Edge Double -> Map Edge ComposerWeights)
-> Map Edge ComposerWeights
-> Map Text (Map Edge Double)
-> Map Edge ComposerWeights
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' Map Edge ComposerWeights
-> Text -> Map Edge Double -> Map Edge ComposerWeights
forall {k} {k} {a}.
(Ord k, Ord k, Num a) =>
Map k (Map k a) -> k -> Map k a -> Map k (Map k a)
accumulate Map Edge ComposerWeights
forall k a. Map k a
Map.empty Map Text (Map Edge Double)
transitionMaps
   in [ (Cadence
from, Cadence
to, ComposerWeights
weights)
      | ((Cadence
from, Cadence
to), ComposerWeights
weights) <- Map Edge ComposerWeights -> [(Edge, ComposerWeights)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Edge ComposerWeights
merged
      , [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) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0
      ]
  where
    accumulate :: Map k (Map k a) -> k -> Map k a -> Map k (Map k a)
accumulate Map k (Map k a)
acc k
composer Map k a
edgeMap =
      (Map k (Map k a) -> (k, a) -> Map k (Map k a))
-> Map k (Map k a) -> [(k, a)] -> Map k (Map k a)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (k -> Map k (Map k a) -> (k, a) -> Map k (Map k a)
forall {k} {k} {a}.
(Ord k, Ord k, Num a) =>
k -> Map k (Map k a) -> (k, a) -> Map k (Map k a)
insertWeight k
composer) Map k (Map k a)
acc (Map k a -> [(k, a)]
forall k a. Map k a -> [(k, a)]
Map.toList Map k a
edgeMap)

    insertWeight :: k -> Map k (Map k a) -> (k, a) -> Map k (Map k a)
insertWeight k
composer Map k (Map k a)
acc (k
edge, a
weight) =
      (Map k a -> Map k a -> Map k a)
-> k -> Map k a -> Map k (Map k a) -> Map k (Map k a)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith ((a -> a -> a) -> Map k a -> Map k a -> Map k a
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith a -> a -> a
forall a. Num a => a -> a -> a
(+)) k
edge (k -> a -> Map k a
forall k a. k -> a -> Map k a
Map.singleton k
composer a
weight) Map k (Map k a)
acc