From df82cdeae9a4fab82ad6144371ef862fd91003b9 Mon Sep 17 00:00:00 2001 From: Judah Daniels Date: Sun, 21 Apr 2024 14:13:55 +0100 Subject: [PATCH] Neatening --- src/Algorithm/Templating.hs | 11 +- src/Harmony.hs | 27 +- src/HarmonyModel.hs | 488 ------------------------------------ src/Heuristics.hs | 55 +--- 4 files changed, 16 insertions(+), 565 deletions(-) delete mode 100644 src/HarmonyModel.hs diff --git a/src/Algorithm/Templating.hs b/src/Algorithm/Templating.hs index 099d531e8..5e43738dc 100644 --- a/src/Algorithm/Templating.hs +++ b/src/Algorithm/Templating.hs @@ -45,16 +45,7 @@ genSlice slc = -- segment -- 2. PRIOR PROBABILITY: Choose the template with higher prior probability of occurence -- 3. DIM7 RESOLUTION: If al top templates are fully diminished 7th chords, select the template whose roott is one - -- half-step below the root of the top scorig template in the following segment. - - -- maxElems 0 mins [] = mins - -- maxElems n mins [] = mins - -- maxElems 0 (m : mins) (x : rst) - -- | fst x < fst m = maxElems 0 (ins x mins) rst - -- | otherwise = maxElems 0 (m : mins) rst - -- maxElems n mins (x : rst) = maxElems (n - 1) (ins x mins) rst - -- - -- ins = L.insertBy ((flip . comparing) fst) + -- half-step below the root of the top scoring template in the following segment. scoreTemplate :: [InputSlice SPitch] diff --git a/src/Harmony.hs b/src/Harmony.hs index 167c76e30..ca6bcaa1c 100644 --- a/src/Harmony.hs +++ b/src/Harmony.hs @@ -4,7 +4,6 @@ {-# HLINT ignore "Use second" #-} module Harmony ( - rotateVector , pChordTones , mostLikelyLabelFromSliceWithProb @@ -21,39 +20,25 @@ module Harmony , notePos , notesVector , noteVector - -- , ornamentLogLikelihoodDouble - -- , sliceChordLogLikelihood - -- , sliceChordWeightedLogLikelihoods - -- , sliceChordWeightedLogLikelihood , ornamentLogLikelihood , chordToneLogLikelihood - -- , scoreSegment , scoreSegments ) where +import PVGrammar import Probability + import Harmony.Params import Harmony.ChordLabel -import Common -import Data.Aeson -import Data.ByteString.Lazy qualified as BL -import Data.Maybe -import Data.Ord -import Debug.Trace -import GHC.Float (double2Int) -import GHC.Generics -import Internal.MultiSet qualified as MS -import Musicology.Core (AdditiveGroup) import Musicology.Core qualified as Music import Musicology.Pitch.Spelled -import Numeric.Log (Log (..)) -import PVGrammar -import System.Random.MWC.Probability (multinomial, categorical) + +import Data.Maybe +import Internal.MultiSet qualified as MS import Data.Vector qualified as V -import Data.Bifunctor (bimap) import Data.Tuple (swap) -import Data.List + transposeNote :: Music.Pitch SIC -> SPitch -> SIC diff --git a/src/HarmonyModel.hs b/src/HarmonyModel.hs deleted file mode 100644 index fdd83e18c..000000000 --- a/src/HarmonyModel.hs +++ /dev/null @@ -1,488 +0,0 @@ --- {- | This module contains --- -} -module HarmonyModel -where - --- ( --- HarmonicProfileData (..) --- , loadParams --- , ChordLabel (..) --- , evaluateSlice, mostLikelyChordFromSlice --- , chordToneLogLikelihood --- , transposeNote --- , ornamentLogLikelihood --- , ornamentLogLikelihoodDouble --- , sliceChordLogLikelihood --- , chordToneLogLikelihoodDouble --- , sliceChordWeightedLogLikelihoods --- , sliceChordWeightedLogLikelihood --- , scoreSegment --- , scoreSegment' --- , scoreSegments --- ) --- where --- --- import Params --- import Common --- import Data.Aeson --- import Data.ByteString.Lazy qualified as BL --- import Data.List as List --- import Data.Maybe --- import Data.Ord --- import Debug.Trace --- import GHC.Float (double2Int) --- import GHC.Generics --- import GHC.Real (infinity) --- import Internal.MultiSet qualified as MS --- import Musicology.Core (AdditiveGroup) --- import Musicology.Core qualified as Music --- import Musicology.Pitch.Spelled --- import Numeric.Log (Log (..)) --- import Numeric.SpecFunctions (logGamma) --- import PVGrammar --- import System.Random.MWC.Probability (multinomial) --- --- --- --- chordTypes = ["M", "m", "Mm7", "o", "o7", "mm7", "%7", "MM7", "+", "Ger", "It", "Fr", "mM7", "+7"] --- --- -- | DCML Chord Types --- data ChordType --- = Major --- | Minor --- | DominantSeventh --- | Diminished --- | FullDiminished --- | MinorSeventh --- | HalfDiminished --- | MajorSeventh --- | Augmented --- | GermanSixth --- | ItalianSixth --- | FrenchSixth --- | MinorMajorSeventh --- | AugmentedSeventh --- deriving (Eq, Enum, Bounded) --- --- instance Read ChordType where --- readsPrec _ str = --- case str of --- "M" -> [(Major, "")] --- "m" -> [(Minor, "")] --- "Mm7" -> [(DominantSeventh, "")] --- "o" -> [(Diminished, "")] --- "o7" -> [(FullDiminished, "")] --- "mm7" -> [(MinorSeventh, "")] --- "%7" -> [(HalfDiminished, "")] --- "MM7" -> [(MajorSeventh, "")] --- "+" -> [(Augmented, "")] --- "Ger" -> [(GermanSixth, "")] --- "It" -> [(ItalianSixth, "")] --- "Fr" -> [(FrenchSixth, "")] --- "mM7" -> [(MinorMajorSeventh, "")] --- "+7" -> [(AugmentedSeventh, "")] --- _ -> [] --- --- instance Show ChordType where --- show chordType = --- case chordType of --- Major -> "M" --- Minor -> "m" --- DominantSeventh -> "Mm7" --- Diminished -> "o" --- FullDiminished -> "o7" --- MinorSeventh -> "mm7" --- HalfDiminished -> "%7" --- MajorSeventh -> "MM7" --- Augmented -> "+" --- GermanSixth -> "Ger" --- ItalianSixth -> "It" --- FrenchSixth -> "Fr" --- MinorMajorSeventh -> "mM7" --- AugmentedSeventh -> "+7" --- --- data ChordLabel = ChordLabel --- { chordType :: String --- , rootNote :: SPC --- } --- deriving (Generic, Eq) --- --- -- | Returns the most likely chord labels for each input group of notes --- -- guessChords :: HarmonicProfileData -> [Notes SPitch] -> [ChordLabel] --- -- guessChords params slices = sLbl <$> (wrapSlice (SliceWrapper $ \ns -> let (r, l, p) = mostLikelyChordFromSlice params ns in SliceWrapped ns (ChordLabel l r) p) <$> slices) --- --- --- --- instance Show ChordLabel where --- show (ChordLabel lbl root) = Music.showNotation root <> lbl --- --- mkLbl rootInt chordType = ChordLabel chordType (spc (rootInt - 14)) --- --- instance FromJSON HarmonicProfileData --- --- data Params = Params --- { params_p_harmony :: [Double] --- , params_p_chordtones :: [[Double]] --- , params_p_ornaments :: [[Double]] --- , alpha_p_ict :: [Double] --- , beta_p_ict :: [Double] --- , alpha_rate_notes :: Double --- , beta_rate_notes :: Double --- } --- deriving (Generic, Show) --- --- instance FromJSON Params --- --- -- | Load the paramaters from the JSON --- loadParams :: FilePath -> IO HarmonicProfileData --- loadParams file = do --- json <- BL.readFile "preprocessing/dcml_params.json" --- -- print json --- case (decode json :: Maybe HarmonicProfileData) of --- Just hpData -> pure hpData' --- where --- hpData' = --- hpData --- { params = --- (params hpData) --- { params_p_chordtones = --- (map . map) (+ 1) (params_p_chordtones (params hpData)) --- , params_p_ornaments = --- (map . map) (+ 1) (params_p_ornaments (params hpData)) --- , params_p_harmony = --- map (+ 1) (params_p_harmony (params hpData)) --- } --- } --- Nothing -> error "JSON parameter file not found or corrupted" --- --- -- Take the average score given a score function that takes slices and chord labels --- scoreSegments --- :: HarmonicProfileData --- -> (HarmonicProfileData -> Notes SPitch -> ChordLabel -> Double) --- -> [Notes SPitch] --- -> [ChordLabel] --- -> Double --- scoreSegments params scoreSegment segments labels = --- let --- scores = zipWith (scoreSegment params) segments labels --- in --- sum scores / fromIntegral (length scores) --- --- -- | Provides a score measuring how much the slice matches the chord annoation --- scoreSegment' :: HarmonicProfileData -> Notes SPitch -> ChordLabel -> Double --- scoreSegment' hpData (Notes slc) (ChordLabel chordLbl root) = mlp + clp --- where --- -- slc' = Notes $ MS.map (\spitch' -> Music.pfrom (spc (fifths spitch')) root) slc --- slc' = Notes $ MS.map (transposeNote root) slc --- -- Calculate Likelihoods of each chord type --- chordToneParams = getChordToneParams hpData --- --- valueVector = genSliceVector slc' --- --- mlp = (multinomialLogProb valueVector <$> chordToneParams) !! chordTypeIndex --- --- clp = categoricalLogProb chordTypeIndex pChordTones --- --- pChordTones = getChordToneParams hpData !! chordTypeIndex --- --- chordTypeIndex = fromJust $ elemIndex chordLbl (chordtypes hpData) --- --- transposeNote :: Music.Pitch SIC -> SPitch -> SIC --- transposeNote root = Music.pto root . spc . fifths --- --- -- | Provides a score measuring how much the slice matches the chord annoation --- scoreSegment :: HarmonicProfileData -> Notes SPitch -> ChordLabel -> Double --- scoreSegment hpData (Notes slc) (ChordLabel chordLbl root) = mlp --- where --- slc' = Notes $ MS.map (transposeNote root) slc --- --- -- Calculate Likelihoods of each chord type --- chordToneParams = getChordToneParams hpData --- --- valueVector = genSliceVector slc' --- --- mlp = (multinomialLogProb valueVector <$> chordToneParams) !! chordTypeIndex --- --- chordTypeIndex = fromMaybe undefined $ elemIndex chordLbl (chordtypes hpData) --- --- -- | Provides a score measuring how much the slice matches the chord annoation --- evaluateSlice :: HarmonicProfileData -> Notes SIC -> String -> Double --- evaluateSlice hpData pitchClasses chordType = --- trace --- ( "Evaluating Slice:" --- <> "\n Slice: " --- <> show pitchClasses --- <> "\n Label: " --- <> show chordType --- <> "\n Score: " --- <> show (likelihoods !! chordTypeIndex) --- ) --- -- <> "\nWeighted Likelihoods: " <> showList ((zip (chordtypes hpData) weightedlikelihoods)) "") --- -- weightedlikelihoods --- likelihoods --- !! chordTypeIndex --- where --- -- Calculate Likelihoods of each chord type --- chordToneParams = getChordToneParams hpData --- --- valueVector = genSliceVector pitchClasses --- --- likelihoods = multinomialLogProb valueVector <$> chordToneParams --- -- likelihoods' = exp <$> ((multinomialLogProb valueVector <$> chordToneParams)) --- --- -- clp = categoricalLogProb chordTypeIndex pHarmony --- --- -- weightedlikelihoods = (/ maximum likelihoods) <$> likelihoods --- --- chordTypeIndex = fromMaybe undefined $ elemIndex chordType (chordtypes hpData) --- --- -- SIC from C as a base --- mostLikelyChordFromSlice :: HarmonicProfileData -> Notes SPitch -> (SPC, String, Double) --- mostLikelyChordFromSlice hpData slc = (root, chordtypes hpData !! chordTypeIndex, p) --- where --- (p, root, chordTypeIndex) = maximum (sliceChordWeightedLogLikelihoods hpData slc) --- --- -- notes = Notes $ MS.map transformPitch slc --- --- -- transformSlice :: --- -- Notes Music.SPitch -> Notes SIC --- --- -- transformSlice r (Notes slc) = Notes $ MS.map (transformPitch r) slc --- --- -- transformPitch :: --- -- Music.SPitch -> SIC --- -- transformPitch p = let q = Music.pc p in Music.pfrom q (spc 0) --- --- -- transformPitch :: Music.SPitch -> Music.Pitch p -> Music.ICOf p --- -- transformPitch r p = Music.pfrom (Music.pc p) r --- --- maxi xs = maximumBy (comparing fst) (zip xs [0 ..]) --- --- -- Gives Likelihoods for all possible chord types in all root positions --- -- Could ignore root positions which don't have a chord tone? Maybe --- -- Assuming all are chordtoneyyyyyyys --- --- -- sliceChordLogLikelihoods :: HarmonicProfileData -> Notes SPitch -> [(Double, Int, Int)] --- -- sliceChordLogLikelihoods hpData notes = allChords (map go [0 .. 28]) -- map go [0..11] --- -- where --- -- go :: Int -> [Double] --- -- go root = map go' chordTypes --- -- where --- -- go' :: String -> Double --- -- go' lbl = sliceChordLogLikelihood hpData (ChordLabel lbl (sic 0) (spc root)) notes' --- -- where --- -- notes' = transposeSlice (spc root) notes --- -- --- -- chordTypes = chordtypes hpData --- --- -- chordTypeIndex = fromMaybe 0 $ elemIndex undefined chordTypes --- --- -- Gives Likelihoods for all possible chord types in all root positions --- -- Could ignore root positions which don't have a chord tone? Maybe --- -- Assuming all are chordtones --- -- Scaled by prob of each chordtype --- --- allChords :: [[Double]] -> [(Double, SPC, Int)] --- allChords d = do --- (rootOffset, chordProbs) <- zip [0 ..] d --- (chordTypeIndex, chordProb) <- zip [0 ..] chordProbs --- pure (chordProb, spc (rootOffset - 14), chordTypeIndex) --- --- -- chordTypeIndex = fromMaybe 0 $ elemIndex undefined chordTypes --- --- -- (root, (chordTypeIndex, p)) = maximumBy (comparing (snd . snd)) (zip [0 ..] (mostLikelyChordType <$> sliceChordWeightedLogLikelihoods hpData slc)) --- -- where --- -- mostLikelyChordType :: [Double] -> (Int, Double) --- -- mostLikelyChordType chordTypeProbs = maximumBy (comparing snd) (zip [0 ..] chordTypeProbs) --- --- sliceChordWeightedLogLikelihood :: HarmonicProfileData -> String -> Notes SIC -> Double --- sliceChordWeightedLogLikelihood hpData label notes = --- -- trace --- -- ("\nSlice: " <> show notes <> "\nChord Prob: " --- -- <> show logLikelihood <> --- -- "\nmlp:" <> show mlp --- -- <> "\nvector" <> show valueVector --- -- <> "slice Vec: " <> --- -- ) --- logLikelihood --- where --- -- myF i = fromIntegral $ MS.lookup (sic (i - 14)) notes --- clp = categoricalLogProb chordIndex pHarmony --- mlp = case multinomialLogProb valueVector pChordTones of --- 0 -> -100000 --- x -> x --- logLikelihood = clp + mlp --- PARAMETER --- valueVector = genSliceVector notes --- pChordTones = getChordToneParams hpData !! chordIndex --- chordIndex = fromJust $ chordIndexFromLabel hpData label -- fromMaybe undefined (elemIndex label chordTypes) --- pHarmony = getHarmonyParams hpData --- chordTypes = chordtypes hpData --- --- chordIndexFromLabel :: HarmonicProfileData -> String -> Maybe Int --- chordIndexFromLabel hpData label = elemIndex label chordTypes --- where --- chordTypes = chordtypes hpData --- --- sliceChordLogLikelihood :: HarmonicProfileData -> ChordLabel -> Notes SIC -> Double --- sliceChordLogLikelihood hpData label notes = logLikelihood --- where --- logLikelihood = multinomialLogProb valueVector pChordTones --- valueVector = genSliceVector notes --- pChordTones = getChordToneParams hpData !! fromMaybe 0 (elemIndex (chordType label) chordTypes) --- chordTypes = chordtypes hpData --- --- allIntervals = map sic [-14 .. 14] --- allNotes = map spc [-14 .. 14] --- --- sliceChordWeightedLogLikelihoods :: HarmonicProfileData -> Notes SPitch -> [(Double, SPC, Int)] --- sliceChordWeightedLogLikelihoods hpData (Notes notes) = allChords (map likelihoodsGivenRootNote allNotes) --- where --- chordTypes = chordtypes hpData --- -- chordTypes = ["M"] --- -- chordtypes hpData --- --- -- root note from 0 to 28 --- likelihoodsGivenRootNote :: SPC -> [Double] --- likelihoodsGivenRootNote root = --- -- trace --- -- ("Considering root note: " <> show root) --- map go chordTypes --- where --- go :: String -> Double --- go chordType = --- -- trace --- -- ("ChordType: " <> chordType <> "\n ll: " <> show ll) --- ll --- where --- -- x = --- ll = sliceChordWeightedLogLikelihood hpData chordType notes' --- notes' = --- -- let y = --- -- trace ("Notes " <> show notes') undefined in --- Notes $ MS.map (transposeNote root) notes --- --- -- notes' = transposeSlice (spc (root - 14)) notes --- --- genSliceVector :: Notes SIC -> [Double] --- genSliceVector (Notes notes) --- | sum res == fromIntegral (MS.size notes) = --- -- trace ("Slice Vector: \n" <> show (zip [-14 ..] (map double2Int res))) --- res --- -- Return empty list if any of the intervals are out of bound (eg. dddd4) --- | otherwise = replicate 29 0 --- where --- res = myF <$> allIntervals :: [Double] --- myF i = fromIntegral $ MS.lookup i notes --- --- ornamentLogLikelihood :: HarmonicProfileData -> ChordLabel -> SIC -> Double --- ornamentLogLikelihood hpData label note = logLikelihood --- where --- logLikelihood = categoricalLogProb notePos pOrnaments --- pOrnaments = getOrnamentParams hpData !! fromJust (chordIndexFromLabel hpData (chordType label)) --- notePos = 14 + sFifth note --- --- chordToneLogLikelihood :: HarmonicProfileData -> ChordLabel -> SIC -> Double --- chordToneLogLikelihood hpData label note = logLikelihood --- where --- logLikelihood = categoricalLogProb notePos pChordTones --- pChordTones = getChordToneParams hpData !! fromMaybe undefined (chordIndexFromLabel hpData (chordType label)) --- notePos = 14 + sFifth note --- --- genMixture :: [Double] -> [Double] -> [Double] --- genMixture vec1 vec2 = (/ 2) <$> zipWith (+) vec1 vec2 --- --- ornamentLogLikelihoodDouble :: HarmonicProfileData -> ChordLabel -> ChordLabel -> SPitch -> Double --- ornamentLogLikelihoodDouble hpData lbll@(ChordLabel chordTypel rootl) lblr@(ChordLabel chordTyper rootr) note = logLikelihood --- where --- -- logLikelihood = categoricalLogProb notePos pOrnamentsm --- pOrnamentsl = getOrnamentParams hpData !! fromJust (chordIndexFromLabel hpData chordTypel) --- pOrnamentsr = getOrnamentParams hpData !! fromJust (chordIndexFromLabel hpData chordTyper) --- logLikelihood = (ornamentLogLikelihood hpData lbll (transposeNote rootl note) + ornamentLogLikelihood hpData lblr (transposeNote rootr note)) / 2 --- --- -- pOrnamentsm = genMixture pOrnamentsl pOrnamentsr --- -- notePos = 14 + sFifth note --- --- chordToneLogLikelihoodDouble :: HarmonicProfileData -> ChordLabel -> ChordLabel -> SPitch -> Double --- chordToneLogLikelihoodDouble hpData lbll@(ChordLabel chordTypel rootl) lblr@(ChordLabel chordTyper rootr) note = logLikelihood --- where --- pChordTonesl = getChordToneParams hpData !! fromJust (chordIndexFromLabel hpData chordTyper) --- pChordTonesr = getChordToneParams hpData !! fromJust (chordIndexFromLabel hpData chordTypel) --- logLikelihood = (chordToneLogLikelihood hpData lbll (transposeNote rootl note) + chordToneLogLikelihood hpData lblr (transposeNote rootr note)) / 2 --- --- ---- -- -- -- -- -- -- -- -- -- -- -- --- -- EXTRACTING INFO FROM THE HARMONIC PROFILES --- ---- -- -- -- -- -- -- -- -- -- -- -- --- --- -- Takes the MLE estimate of the dirchetlet distribution --- -- to get a categorical distribution for ornmanet probs... --- getOrnamentParams :: HarmonicProfileData -> [[Double]] --- getOrnamentParams hpData = normaliseList <$> pOrnaments --- where --- pOrnaments = params_p_ornaments $ params hpData --- --- getChordToneParams :: HarmonicProfileData -> [[Double]] --- getChordToneParams hpData = normaliseList <$> pChordTones --- where --- pChordTones = params_p_chordtones $ params hpData --- --- -- MLE sample of dirchlet to get categorical distibution for haromy. --- getHarmonyParams :: HarmonicProfileData -> [Double] --- getHarmonyParams hpData = normaliseList pHarmony --- where --- pHarmony = params_p_harmony $ params hpData --- --- normaliseList :: (Fractional a) => [a] -> [a] --- normaliseList xs = (/ sum xs) <$> xs --- --- ---- -- -- -- -- -- -- -- -- -- -- -- --- -- EXTRACTING INFO FROM THE HARMONIC PROFILES --- ---- -- -- -- -- -- -- -- -- -- -- -- --- --- -- evalPath :: --- -- Path es (Notes SPitch) -> --- -- [ChordLabel] -> --- -- HarmonicProfileData -> --- -- Double --- -- evalPath (PathEnd _) _ _ = 0 --- -- evalPath _ [] _ = trace "WARNING: Chords don't line up with parsed slices." 0 --- -- evalPath (Path _ (Notes slc) rst) (lbl : lbls) hpData = trace (show slc' <> show lbl') $ evaluateSlice hpData slc' lbl' + evalPath rst lbls hpData --- -- where --- -- key = keyCenter lbl --- -- rOffset = rootOffset lbl --- -- chordRootNote = key Music.+^ rOffset --- -- --- -- lbl' = chordType lbl --- -- slc' = Notes $ MS.map transformPitch slc --- -- where --- -- transformPitch :: --- -- Music.SPitch -> SIC --- -- transformPitch p = Music.pfrom (Music.pc p) chordRootNote --- -- --- --- -- transposeSlice :: SPC -> Notes SPitch -> Notes SIC --- -- transposeSlice root (Notes slc) = Notes $ MS.map transformPitch slc --- -- where --- -- transformPitch :: --- -- SPitch -> SIC --- -- transformPitch p = Music.pfrom (Music.pc p) root --- --- -- Calculates the probability density of a multinomial distribution at the given point --- multinomialLogProb :: [Double] -> [Double] -> Double --- multinomialLogProb xs probs --- | n == 0 = trace "empty multinomial" (-100000000) --- | otherwise = logFactorialN + logPowers --- where --- n = sum xs --- logFactorialN = logGamma $ n + 1 --- logPowers = sum $ zipWith powers xs probs --- where --- powers x y = x * log y - logGamma (x + 1) --- --- -- Calculates the probability density of a multinomial distribution at the given point --- categoricalLogProb :: Int -> [Double] -> Double --- categoricalLogProb x probs = log $ probs !! x --- --- -- TODO @@@ --- -- categoricalLogProb :: Int -> Vector Double -> Double --- -- categoricalLogProb x probs = log $ probs !! x --- -- diff --git a/src/Heuristics.hs b/src/Heuristics.hs index b3ea91c0f..ad39a22bb 100644 --- a/src/Heuristics.hs +++ b/src/Heuristics.hs @@ -8,7 +8,6 @@ module Heuristics ) where --- LOGGING import Control.Logging qualified as Log import Data.Text qualified as T import Common hiding (log) @@ -69,7 +68,7 @@ heuristicZero :: Double -> Double -> ( State SPitch, State SPitch) -> ExceptT St heuristicZero alpha splitWeight (prevState, state) = case getOpFromState state of Nothing -> pure 0 -- Initial state Just op -> do - log $ "Prev State: " <> show (prevState) + log $ "Prev State: " <> show prevState log $ "Next State: " <> show state let t = evalOP op log $ show op @@ -143,11 +142,11 @@ heuristicZero alpha splitWeight (prevState, state) = case getOpFromState state o ,(\(SliceWrapped lns sLbl prob) -> sLbl) <$> slcR) leftScore' = scoreParent (probsParent lbll) leftParents rightScore' = scoreParent (probsParent lblr) rightParents - leftScore = case probl of - Nothing -> [] + leftScore = case probl of + Nothing -> [] Just a -> [a ] - rightScore = case probr of - Nothing -> [] + rightScore = case probr of + Nothing -> [] Just a -> [a ] -- scoreParent (probsParent lblr) rightParents bothScores = (leftScore ++ rightScore ++ leftScore' ++ rightScore') @@ -204,7 +203,7 @@ heuristicZero alpha splitWeight (prevState, state) = case getOpFromState state o -- Parents are all evaluated using chord-tone profiles leftParents = leftRegParents <> leftPassingParents <> fromLeftParents rightParents = rightRegParents <> rightPassingParents <> fromRightParents - + -- Single children are evaluated using the profiles from parents/ chordtone or ornament childFromRights = allSingleChildren fromRight @@ -241,49 +240,13 @@ heuristicZero alpha splitWeight (prevState, state) = case getOpFromState state o childPasses = (\(l, r) -> (l, PassingMid)) <$> allInnerEdges edgesPass childRegs = (\(Inner l,r) -> (l, FullRepeat)) <$> allRegEdges edgesReg childFactor = scoreChildren childRegs childPasses [] [] slcL slcR - -- (Notes $ MS.fromList rightParents) slcL slcR - -- in trace ("spread: " <> (show $ (-50 * go lbll lblr) )) (- go lbll lblr) * 50 - in - (childFactor * alpha + (go slcL slcR)) + in - (childFactor * alpha + go slcL slcR) where go Nothing Nothing = 100 go (Just a) Nothing = 100 go Nothing (Just a) = 100 - go (Just a ) (Just b) = ((scoreParents (sWContent a) (sWContent b) (slcL) (slcR))) - -- let - -- probsRegs = map scoreReg (S.toList edgesReg) - -- probsPasses = map scorePass (MS.toList edgesPass) - -- aggregateProbs = probsRegs <> probsPasses - -- l = length aggregateProbs - -- score = if l == 0 then 5 else - (sum aggregateProbs / fromIntegral (length aggregateProbs)) - -- in - -- scoreReg :: Edge n -> Float - -- scoreReg (Start ,Inner y) = evaluateChordTone slcR y - -- scoreReg (Inner x ,Stop) = evaluateChordTone slcL x - -- scoreReg (Inner x , Inner y) = evaluateChordTone slcL x + evaluateChordTone slcR y - -- - -- -- scorePass :: InnerEdge n -> Float - -- scorePass (x , y) = evaluateChordTone slcL x + evaluateChordTone slcR y - - -- scoreParents - -- :: Notes SPitch - -- -> Notes SPitch - -- -> Maybe (SliceWrapped nx) - -- -> Maybe (SliceWrapped nx) - -- -> Double - -- scoreParents leftParents rightParents slcL slcR = - -- let (lbll, lblr) = - -- ((\(SliceWrapped _ sLbl _) -> sLbl) <$> slcL - -- ,(\(SliceWrapped _ sLbl _) -> sLbl) <$> slcR) - -- leftScore = scoreParent (probsParent lbll) leftParents - -- rightScore = scoreParent (probsParent lblr) rightParents - -- bothScores = (maybeToList leftScore ++ maybeToList rightScore) - -- n = fromIntegral $ length bothScores - -- in - -- if n == 0 then 0 else sum bothScores / n - -- where - -- scoreParent mps v = do - -- multinomialLogProb (notesVector v) <$> mps - -- + go (Just a ) (Just b) = scoreParents (sWContent a) (sWContent b) slcL slcR + getParentDouble :: State ns -> ( StartStop (SliceWrapped (Notes ns)) --midslice or start (in open case)