From 8c0fe99534f94e20e3e42c320b5e1bb0bb36d6e7 Mon Sep 17 00:00:00 2001 From: Judah Daniels Date: Tue, 2 Apr 2024 23:34:17 +0100 Subject: [PATCH] refactor: Move Parsers to /Parser/ --- .DS_Store | Bin 8196 -> 0 bytes .gitignore | 1 + app/MainFullParse.hs | 36 +- app/MainJudah.hs | 7 - src/Algorithm.hs | 56 +- src/Algorithm/HeuristicSearch.hs | 12 +- src/Algorithm/RandomSampleParser.hs | 2 +- src/ChartParser.hs | 841 ------------------------- src/Core.hs | 290 --------- src/FileHandling.hs | 2 +- src/GreedyParser.hs | 531 ---------------- src/HeuristicParser.hs | 933 ---------------------------- src/Heuristics.hs | 16 +- 13 files changed, 64 insertions(+), 2663 deletions(-) delete mode 100644 .DS_Store delete mode 100644 src/ChartParser.hs delete mode 100644 src/Core.hs delete mode 100644 src/GreedyParser.hs delete mode 100644 src/HeuristicParser.hs diff --git a/.DS_Store b/.DS_Store deleted file mode 100644 index 5d095b2511099fa80fd4b25e270862f88e51cc3f..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 8196 zcmeHMO-~a+7=DLVy9KH}XoQ1F6R&`6DMjL?6gZHm2Ws@-2kv%P*s$z2?Usf#Bt5IY z!N1^D|A;@syC;3-1F|2jF_M6UnPldjoq3;~ndg1qnVpu1ShH_eh~|jMK<2VIgJMkL z{XD1AlxmrWWWZC3r4WERaLp)NlDAxpdgvZ3TiO0*y`35AqUrmh%F-5r>Oqrai_ zM^Z{SF)=dUqef=xhQidxBRbG$8&pOx%{0?WwJMJ=8T*%W4vkY2ZL5H2msXa;@X?g?y5b{KghzgwIe4(sKWg;H&8?PQ@eT&tE* zU#_2=&=226V^LWmYZY;aFy_^4y@+@ z-4)h%;8{I*06a8q6CSTI3l;=sEb_7$uhkH@%jMN`GX94ZCfL8H_zS_|A|0W0VG9R! z9v3!h9wMU++gQlS*x>s`G}`mDgSc3yO?nDBW`AHj4x@++Y}TcA+F~)SX|ZcaFPY#U zeCLT-`Sv&r=Hv-)If#$Q<2HuQA_}=jg>gLwFO2CKr+VPZMBPm2^Ia{vd!+Ou9{26S zPmTHEaJgPXjMu8%<0{n(0=`~ZNgNy8%t#ZDjZf%IEiB<^;tf}&$jFJ#%|LEV{{8=| zEJx2%GoTsx2L@Pnv$fd-@brT@`3`>9E+M}|=85Z#q!bVo;yMl~uH%qre;A@(f-1)} elpINk7NiURAwZx1;!|9Zuh0L;wefnL|GxpG;F9 pure $ nullResultToJSON (show algo) -- runAlgo algo inputChords inputSlices (n - 1) - Just (time, mRes) -> + Just (time, mRes) -> do case mRes of Nothing -> runAlgo unsplitBias childBias deriv algo timeOut inputChords inputSlices (n - 1) id - Just (AlgoResult top ops lbls) -> + Just (PVResult ana@(Analysis ops top)) -> + let slices = pathBetweens top + lbls = guessChords slices + accuracy = chordAccuracy inputChords lbls + likelihood = scoreSegments slices inputChords + in + do + -- Plot derivation as PDF + plotDeriv deriv top ops + -- Write results to json file + pure $ writeResultsToJSON (JsonResult slices lbls (Just ana) accuracy likelihood (show algo) time (1 + numRetries - n) id Nothing) + + Just (BlackBoxResult lbls) -> let accuracy = chordAccuracy inputChords lbls + in + pure $ writeResultsToJSON (JsonResult [] lbls Nothing accuracy 0 (show algo) time (1 + numRetries - n) id Nothing) + + Just (ReductionResult top) -> + let lbls = guessChords top + accuracy = chordAccuracy inputChords lbls likelihood = scoreSegments top inputChords - in case ops of - Nothing -> let res = JsonResult top lbls ops accuracy likelihood (show algo) time (1 + numRetries - n) id Nothing - in - pure $ writeResultsToJSON res - Just (Analysis op to) -> do - -- plotDeriv (deriv) to op - pure $ writeResultsToJSON (JsonResult top lbls ops accuracy likelihood (show algo) time (1 + numRetries - n) id Nothing) - -- logD $ "Accuracy: " <> show accuracy - -- logD $ "Likelihood: " <> show likelihood + res = JsonResult top lbls Nothing accuracy likelihood (show algo) time (1 + numRetries - n) id Nothing + in + pure $ writeResultsToJSON res plotDeriv fn top deriv = do diff --git a/app/MainJudah.hs b/app/MainJudah.hs index 74ea1e2c3..2ed44c64a 100644 --- a/app/MainJudah.hs +++ b/app/MainJudah.hs @@ -35,10 +35,3 @@ main = do & Stream.fromAhead -- mapM is cocnurrent using Ahead style & Stream.drain - -- jeff <- ST.toList $ ST.mapM myf $ ST.fromList [0 .. 10000000] - -- putStrLn $ show $ length jeff - - -myf :: Int -> IO Int -myf x = pure $ x + 2 - diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 18c7d364b..4c2f8b721 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -22,7 +22,7 @@ import Data.Text qualified as T import FileHandling ( InputSlice (..), pathFromSlices, splitSlicesIntoSegments) import Heuristics -import HeuristicParser +import Parser.HeuristicParser import Harmony import Harmony.ChordLabel @@ -34,32 +34,34 @@ import Algorithm.HeuristicSearch import Algorithm.InformedReduction import Algorithm.Templating -import Data.Maybe +import Data.Maybe import qualified Internal.MultiSet as MS -import Control.Monad.Except +import Control.Monad.Except -import Common -import PVGrammar +import Common +import PVGrammar -import Musicology.Core +import Musicology.Core import PVGrammar.Parse -data AlgoInput +data AlgoInput = AlgoInputPure (Eval (Edges SPitch) [Edge SPitch] (Notes SPitch) [SPitch] (PVLeftmost SPitch)) [InputSlice SPitch] - [ChordLabel] + [ChordLabel] | AlgoInputImpure (EvalImpure (Edges SPitch) [Edge SPitch] (Notes SPitch) [SPitch] (PVLeftmost SPitch)) [InputSlice SPitch] [ChordLabel] -data AlgoResult = AlgoResult - { arTop :: [Notes SPitch] - , arOps :: Maybe (PVAnalysis SPitch) - , arLabels :: [ChordLabel] - } + +type ReductionAnalysis = [Notes SPitch] + +data AlgoResult + = BlackBoxResult [ChordLabel] + | ReductionResult ReductionAnalysis + | PVResult (PVAnalysis SPitch) deriving (Show) class ParseAlgo algo where @@ -77,7 +79,7 @@ data AlgoType | RandomWalkPerSegment | RandomSample | RandomReduction - | PerfectReduction + | PerfectReduction | BeamSearch BeamWidth | StochasticBeamSearch BeamWidth ResevoirSize | DualStochasticBeamSearch BeamWidth ResevoirSize @@ -93,10 +95,10 @@ showRoot algo = BeamSearch width -> "BeamSearch_" <> show width StochasticBeamSearch width res -> "StochasticBeamSearch_" <> show width <> "_" <> show res StochasticBeamSearchLimited width res n-> "StochasticBeamSearchLimited_" <> show width <> "_" <> show res <> "_" <> show n - DualStochasticBeamSearch width res -> "DualStochasticBeamSearch_" <> show width <> "_" <> show res - DualStochasticBeamSearch' width res a b -> "DualStochasticBeamSearch_" <> show width <> "_" <> show res <> "_" <> show a <> "_" <> show b + DualStochasticBeamSearch width res -> "DualStochasticBeamSearch_" <> show width <> "_" <> show res + DualStochasticBeamSearch' width res a b -> "DualStochasticBeamSearch_" <> show width <> "_" <> show res <> "_" <> show a <> "_" <> show b + BeamSearchPerSegment width -> "BeamSearchPerSegment_" <> show width -- DualBeamSearch a b -> "DualBeamSearch_" <> show a <> "_" <> show b - BeamSearchPerSegment width -> "BeamSearchPerSegment_" <> show width -- PerfectReduction threshold -> "BeamSearchPerSegment_" <> show threshold _ -> show algo @@ -125,7 +127,7 @@ instance ParseAlgo AlgoType where slices = pathBetweens p chordGuesses = guessChords slices in - pure $ Just $ AlgoResult slices (Just (Analysis ops p)) chordGuesses + pure $ Just $ PVResult (Analysis ops p) runParse unsplitBias childBias algoType (AlgoInputPure eval inputSlices chords) = case algoType of DualStochasticBeamSearch' beamWidth resevoirSize unsplitBias childBias -> @@ -152,7 +154,7 @@ instance ParseAlgo AlgoType where slices = pathBetweens p chordGuesses = guessChords slices in - pure $ Just $ AlgoResult slices (Just (Analysis ops p)) chordGuesses + pure $ Just $ PVResult (Analysis ops p) DualStochasticBeamSearch beamWidth resevoirSize -> let initialState = SSFrozen $ pathFromSlices eval sliceWrapper inputSlices @@ -178,7 +180,7 @@ instance ParseAlgo AlgoType where slices = pathBetweens p chordGuesses = guessChords slices in - pure $ Just $ AlgoResult slices (Just (Analysis ops p)) chordGuesses + pure $ Just $ PVResult (Analysis ops p) RandomWalk -> let initialState = SSFrozen $ pathFromSlices eval idWrapper inputSlices @@ -196,7 +198,7 @@ instance ParseAlgo AlgoType where slices = pathBetweens path chordGuesses = guessChords slices in - pure $ Just $ AlgoResult slices (Just (Analysis ops path)) chordGuesses + pure $ Just $ PVResult (Analysis ops path) RandomWalkPerSegment -> let initialState = SSFrozen $ pathFromSlices eval idWrapper inputSlices @@ -213,32 +215,32 @@ instance ParseAlgo AlgoType where slices = pathBetweens path chordGuesses = guessChords slices in - pure $ Just $ AlgoResult slices (Just (Analysis ops path)) chordGuesses + pure $ Just $ PVResult (Analysis ops path) RandomSample -> do path <- randomSamplePath (length chords) let slices = pathBetweens path chordGuesses = guessChords slices - in pure $ Just (AlgoResult slices Nothing chordGuesses) + in pure $ Just (ReductionResult slices) PerfectReduction -> let x = splitSlicesIntoSegments eval sliceWrapper inputSlices - slices = informedReduction x chords + slices = informedReduction x chords chordGuesses = guessChords slices - in pure $ Just (AlgoResult slices Nothing chordGuesses) + in pure $ Just (ReductionResult slices ) Templating -> let x = splitSlicesIntoSegments eval sliceWrapper inputSlices in Log.timedLog "Running Templating Baseline" $ do let (slices, chordGuesses) = templatingBaseline x - in pure $ Just $ AlgoResult slices Nothing chordGuesses + in pure $ Just $ ReductionResult slices RandomReduction -> let x = splitSlicesIntoSegments eval sliceWrapper inputSlices in Log.timedLog "Running Random Sample SBS Parse" $ do slices <- randomSamplePathSBS x let chordGuesses = guessChords slices - in pure $ Just $ AlgoResult slices Nothing chordGuesses + in pure $ Just $ ReductionResult slices -- StochasticBeamSearch beamWidth resevoirSize -> -- let initialState = SSFrozen $ pathFromSlices eval sliceWrapper inputSlices diff --git a/src/Algorithm/HeuristicSearch.hs b/src/Algorithm/HeuristicSearch.hs index f48cd7c23..1b49814ea 100644 --- a/src/Algorithm/HeuristicSearch.hs +++ b/src/Algorithm/HeuristicSearch.hs @@ -7,11 +7,11 @@ module Algorithm.HeuristicSearch ( -- heuristicSearch - aab - , stochasticSearch - ,stochasticBeamSearch - ,dualStochasticBeamSearch - ,stochasticBeamSearchLimited + aab + , stochasticSearch + , stochasticBeamSearch + , dualStochasticBeamSearch + , stochasticBeamSearchLimited , beamSearch ) where @@ -38,7 +38,7 @@ import Common import Control.Monad.Except (ExceptT, lift, throwError) -import HeuristicParser (SearchState, getOpFromState) +import Parser.HeuristicParser (SearchState, getOpFromState) import Data.List (sortBy) import Data.Function import System.Random.Stateful (newIOGenM, StatefulGen, uniformRM) diff --git a/src/Algorithm/RandomSampleParser.hs b/src/Algorithm/RandomSampleParser.hs index 5c6389ed1..28dace0e6 100644 --- a/src/Algorithm/RandomSampleParser.hs +++ b/src/Algorithm/RandomSampleParser.hs @@ -14,7 +14,7 @@ module Algorithm.RandomSampleParser import Common ( Path (..) ) import Control.Monad.Except (ExceptT, lift, runExceptT, throwError) import FileHandling (InputSlice) -import HeuristicParser (Slice, Trans) +import Parser.HeuristicParser (Slice, Trans) import Musicology.Pitch ( spelledp, SPitch ) import PVGrammar ( Edges (..), Notes(..) ) import Data.Vector qualified as V diff --git a/src/ChartParser.hs b/src/ChartParser.hs deleted file mode 100644 index 0c4245d9a..000000000 --- a/src/ChartParser.hs +++ /dev/null @@ -1,841 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE LambdaCase #-} - -{- | A chart-based semiring parser for path grammars (e.g. the PV grammar). -Path grammars operate on "paths" -consisting of nodes (slices) and edges (transitions), -both of which can contain arbitrary content. -Paths are elaborated through two operations, -@split@ting transitions and @spread@ing slices -(plus @freeze@, which terminates generation on a transition). - -The parser is polymorphic in the grammar -as well as the contents of slices (path nodes) and transitions (path edges). -The grammar to parse is definend in an "evaluator" ('Common.Eval') -which provides completions for parsing the splits, spreads and freezes. --} -module ChartParser - ( -- * Parsing Interface - parse - , parseSize - , parseSilent - , logSize - , logTikz - - -- * Charts - - -- ** Basic Elements - , Slice - , Transition - , transLen - , Item - , TItem - - -- ** Transition Chart - , TContents - , TChart - , tcGetByLength - - -- ** Verticalization Chart - , Vert - , VChart - , vcGetByLength - - -- * Constraint Aliases - , Parsable - , Normal - , Normal' - ) where - -import Common -import Scoring.FunTyped qualified as S - -import Data.HashMap.Strict qualified as HM -import Data.IntMap.Strict qualified as IM -import Data.Semiring qualified as R - -import Control.Monad.State as ST - -import Control.DeepSeq -import Control.Parallel.Strategies qualified as P -import Data.Foldable (foldl') -import Data.Hashable - ( Hashable - , hash - , hashWithSalt - ) -import Data.Kind (Constraint, Type) -import Data.Maybe - ( catMaybes - , fromMaybe - , mapMaybe - ) -import Data.Set qualified as Set -import GHC.Generics (Generic) - --- Basic Types --- =========== - --- | An alias for common constraints on slices and transitions -type Normal :: Type -> Constraint -type Normal x = (Eq x, Ord x, Show x, Hashable x, NFData x) - --- | An alias for common constraints on semiring values -type Normal' :: Type -> Constraint -type Normal' x = (Eq x, Show x, NFData x, R.Semiring x) - --- | A summary constraint for transitions, slices, and semiring values -type Parsable :: Type -> Type -> Type -> Constraint -type Parsable tr slc v = (Normal tr, Normal slc, Normal' v) - --- Slices ---------- - -{- | A slice during chart parsing. - Besides the slice content (e.g., notes), - it maintains indices to the first and last surface slice covered, - as well as an ID that is used for matching compatible parents of a spread. --} -data Slice slc = Slice - { sFirst :: !Int - -- ^ index of the first surface slice covered - , sContent :: !(StartStop slc) - -- ^ slice content (or 'Start'/'Stop') - , sID :: !Int - -- ^ unique slice ID - , sLast :: !Int - -- ^ index of the last surface slice covered - } - deriving (Eq, Ord, Generic, NFData) - -instance (Eq slc) => Hashable (Slice slc) where - hashWithSalt s (Slice _ _ i _) = hashWithSalt s i - -instance Show slc => Show (Slice slc) where - show (Slice f c i l) = - show f <> "-" <> show c <> "@" <> show i <> "-" <> show l - --- Transitions --------------- - -{- | A transition during chart parsing. - Has pointers to the two slices it connects, - a content (e.g., protovoice connections), - and a flag indicating whether it is the second (right) parent of a spread. --} -data Transition tr slc = Transition - { tLeftSlice :: !(Slice slc) - , tContent :: !tr - , tRightSlice :: !(Slice slc) - , t2nd :: !Bool - } - deriving (Eq, Ord, Generic, NFData, Hashable) - -instance (Show a, Show e) => Show (Transition e a) where - show (Transition l c r s) = - "<" - <> show l - <> "," - <> show c - <> "," - <> show r - <> ">" - <> if s - then "2" - else "" - --- | Returns the "length" of the transition in terms of surface slices covered. -transLen :: Transition e a -> Int -transLen (Transition l _ r _) = sLast r - sFirst l + 1 - --- Items --------- - -{- | A parsing item. - Combines an intermediate value (e.g. a transition) with a semiring score. --} -data Item i v = (:=) - { iItem :: !i - , iScore :: !(S.Score v Int) - } - deriving (Generic, NFData) - -instance (Show i, Show v) => Show (Item i v) where - show (i := v) = show i <> " := " <> show v - --- | A transition item. -type TItem tr slc v = Item (Transition tr slc) v - --- Vert Items - -{- | Represents the middle part of an incomplete unspread ("verticalization"). - Expresses how the middle transition and the two child slices (@vMiddle@) - are derived from the parent slice (@vTop@) using a spread operation (@vOp@). - - 'Vert' objects are stored in the 'VChart' - to record the intermediate steps of an unspread, - which is found by first parsing the middle transition into the parent slice - (generating a 'Vert') - and then combining the 'Vert' with the left and right child transitions - to generate the left and right parent transitions, respectively. --} -data Vert tr slc v = Vert - { vTop :: !(Slice slc) - , vOp :: !v - , vMiddle :: !(TItem tr slc v) - } - deriving (Generic, NFData) - -instance (Show e, Show a, Show v) => Show (Vert e a v) where - show (Vert top op m) = - "Vert" - <> "\n top: " - <> show top - <> "\n op: " - <> show op - <> "\n m: " - <> show m - --- slice and transition charts --- =========================== - --- vert chart -------------- - --- ops: --- - get all of len n --- - get all with left child = x --- - get all with right child = x --- - check ID for (top,left,leftid) - -{- | A verticalization chart. - Stores 'Vert' objects at certain chart positions. - To support efficient lookup of 'Vert' objects from different indices, - each 'Vert' is redundantly stored in several hash maps, - one for each index: - - - by surface length - - by surface length (only left border of a 'Vert') - - by left child slice ID and mid transition length - - by right child ID - - In addition, the 'VChart' maintains IDs of new slices. - (Every new slice is the parent of an unspread.) --} -data VChart tr slc v = VChart - { vcNextId :: !Int - -- ^ next free ID - , vcIDs :: !(HM.HashMap (Int, Int) Int) - -- ^ a mapping from child slice ids to the corresponding parent id - , vcByLength :: !(IM.IntMap [Vert tr slc v]) - -- ^ maps surface length to the 'Vert' with that length - , vcByLengthLeft :: !(IM.IntMap (Set.Set (Slice slc, Slice slc))) - -- ^ maps surface length to the "left borders" of 'Vert' objects with that length - -- (parent slice, left child slice) - , vcByLeftChild :: !(HM.HashMap (Int, Int) (Set.Set (Slice slc))) - -- ^ maps a left child slice ID and the surface length of the middle transition - -- to its potential parent slices - , vcByRightChild :: !(HM.HashMap (Int, Int) [Vert tr slc v]) - -- ^ maps a right child slice ID and the surface length of the middle transition - -- to all 'Vert' objects it is part of. - } - deriving (Generic, NFData) - -instance (Show e, Show a, Show v) => Show (VChart e a v) where - show (VChart n _ is _ _ _) = "VChart (next id: " <> show n <> ")" <> levels - where - levels = concatMap showLevel $ IM.toAscList is - showLevel (l, items) = "\nlevel " <> show l <> ":" <> sitems - where - sitems = concatMap (("\n " <>) . show) items - --- | Returns an empty 'VChart' with the next free ID set to @n + 1@. -vcEmpty :: Int -> VChart e a v -vcEmpty n = VChart (n + 1) HM.empty IM.empty IM.empty HM.empty HM.empty - --- | Insert a new 'Vert' object into a 'VChart'. -vcInsert - :: (Hashable slc, Ord slc) - => VChart tr slc v - -- ^ the old chart - -> (slc, v, TItem tr slc v) - -- ^ the new 'Vert' item's parent slice, operation, and middle child transition. - -> VChart tr slc v - -- ^ the new chart -vcInsert (VChart nextid ids bylen bylenleft byleft byright) (topContent, op, mid@(tmid := _)) = - let left = tLeftSlice tmid - right = tRightSlice tmid - idKey = (sID left, sID right) - (nextid', ids', i) = case HM.lookup idKey ids of - Just i' -> (nextid, ids, i') - Nothing -> (nextid + 1, HM.insert idKey nextid ids, nextid) - top = Slice (sFirst left) (Inner topContent) i (sLast right) - vert = [Vert top op mid] - vert' = Set.singleton (top, tLeftSlice tmid) - vertl = Set.singleton top - bylen' = IM.insertWith (<>) (transLen tmid) vert bylen - bylenleft' = IM.insertWith (<>) (transLen tmid) vert' bylenleft - byleft' = HM.insertWith (<>) (sID left, transLen tmid) vertl byleft - byright' = HM.insertWith (<>) (sID right, transLen tmid) vert byright - in VChart nextid' ids' bylen' bylenleft' byleft' byright' - --- | Merge a sequence of new items into a 'VChart' -vcMerge - :: (Foldable t, Ord slc, Hashable slc) - => VChart tr slc v - -> t (slc, v, TItem tr slc v) - -> VChart tr slc v -vcMerge = foldl' vcInsert - --- | Returns all 'Vert' objects in the 'VChart' with the same length. -vcGetByLength - :: VChart tr slc v - -- ^ the chart - -> Int - -- ^ surface length of a middle transition - -> [Vert tr slc v] - -- ^ all corresponding 'Vert' objects -vcGetByLength chart len = fromMaybe [] $ IM.lookup len $ vcByLength chart - --- | Returns the "left borders" of all 'Vert' objects in the 'VChart' with the same length. -vcGetByLengthLeft - :: VChart tr slc v - -- ^ the chart - -> Int - -- ^ the surface length of a middle transition - -> [(Slice slc, Slice slc)] - -- ^ (parent slice, left slice) of all corresponding 'Vert' objects (without duplicates) -vcGetByLengthLeft chart len = - maybe [] Set.toList $ IM.lookup len (vcByLengthLeft chart) - -{- | Returns the all potential parents of a left child slice - up to a certain middle transition length. --} -vcGetByLeftChild - :: (Ord slc, Hashable slc) - => Int - -- ^ maximum middle transition length - -> VChart tr slc v - -- ^ the chart - -> Slice slc - -- ^ the left child slice - -> [Slice slc] - -- ^ all potential parent slices -vcGetByLeftChild maxn chart left = - Set.toList $ Set.unions $ mapMaybe getN [2 .. maxn] - where - getN n = HM.lookup (sID left, n) $ vcByLeftChild chart - -{- | Returns all 'Vert' objects with the same right child - up to a certain middle transition length. --} -vcGetByRightChild - :: (Ord slc, Hashable slc) - => Int - -- ^ ID of the right child - -> VChart tr slc v - -> Slice slc - -> [Vert tr slc v] -vcGetByRightChild maxn chart right = - concat $ mapMaybe getN [2 .. maxn] - where - getN n = HM.lookup (sID right, n) $ vcByRightChild chart - --- transition chart -------------------- - --- ops: --- - get all of length n --- - get all with left slice l --- - get all with right slice r - -{- | The contents of a transition chart (under a particular index). - A mapping from transitions (with score ID constraints left and right) - to (partial) semiring scores. - This mapping usually contains all transition items that satisfy a certain criterion, - irrespective of their position in the chart (which is encoded in the transitions themselves). - - When new transition items are added, if the transition already exists in the chart - (as the result of a different partial parse), - the scores of the new and existing items are "added" (this also requires the score IDs to match). --} -type TContents tr slc v = - HM.HashMap - (Transition tr slc, Maybe (S.LeftId Int), Maybe (S.RightId Int)) - (S.Score v Int) - -{- | A transition chart. - Stores intermediate transition items redundantly under several indices: - - - by surface length - - by left slice - - by right slice --} -data TChart tr slc v = TChart - { tcByLength :: !(IM.IntMap (TContents tr slc v)) - , tcByLeft :: !(HM.HashMap (Slice slc) (TContents tr slc v)) - , tcByRight :: !(HM.HashMap (Slice slc) (TContents tr slc v)) - } - deriving (Show, Generic, NFData) - --- | Returns an empty transition chart. -tcEmpty :: TChart tr slc v -tcEmpty = TChart IM.empty HM.empty HM.empty - --- TODO: there might be room for improvement here - -{- | Insert a new transition item into the transition chart. - If the item's transition already exists, the existing and new score are "added". --} -tcInsert :: (Parsable tr slc v) => TChart tr slc v -> TItem tr slc v -> TChart tr slc v -tcInsert (TChart len left right) (t := v) = - let new = HM.singleton (t, S.leftSide v, S.rightSide v) v - len' = IM.insertWith insert (transLen t) new len - left' = HM.insertWith insert (tLeftSlice t) new left - right' = HM.insertWith insert (tRightSlice t) new right - in TChart len' left' right' - where - insert = HM.unionWithKey (\_ s1 s2 -> S.addScores s1 s2) - --- | Insert several transition items into the transition chart. -tcMerge - :: (Foldable t, Parsable tr slc v) - => TChart tr slc v - -> t (TItem tr slc v) - -> TChart tr slc v -tcMerge = foldl' tcInsert - --- | Helper function for getting transition items from the transition chart. -tcGetAny - :: (TChart tr slc v -> m) - -> (TContents tr slc v -> k -> m -> TContents tr slc v) - -> TChart tr slc v - -> k - -> [TItem tr slc v] -tcGetAny field getter chart key = - fmap mkItem $ HM.toList $ getter HM.empty key $ field chart - where - mkItem ((t, _, _), v) = t := v - --- | Returns all transition items with the same length. -tcGetByLength :: TChart tr slc v -> Int -> [TItem tr slc v] -tcGetByLength = tcGetAny tcByLength IM.findWithDefault - --- | Returns all transition items with the same left slice. -tcGetByLeft :: (Ord slc, Hashable slc) => TChart tr slc v -> Slice slc -> [TItem tr slc v] -tcGetByLeft = tcGetAny tcByLeft HM.findWithDefault - --- | Returns all transition items with the same right slice. -tcGetByRight :: (Ord slc, Hashable slc) => TChart tr slc v -> Slice slc -> [TItem tr slc v] -tcGetByRight = tcGetAny tcByRight HM.findWithDefault - --- parsing machinery --- ================= - --- applying evaluators ----------------------- --- TODO: add checks that adjacent transitions and slices match? - --- | Unspreads the two slices of a (middle) transition, if possible. -unspreadMiddle - :: UnspreadMiddle tr slc v - -- ^ the UnspreadMiddle evaluator - -> TItem tr slc v - -- ^ the middle transition - -> Maybe (slc, v, TItem tr slc v) - -- ^ the top slice, unspread operation, - -- and middle transition -unspreadMiddle unspreadm im@((Transition l m r _) := _) = do - il <- getInner $ sContent l - ir <- getInner $ sContent r - (top, op) <- unspreadm (il, m, ir) - pure (top, op, im) - --- | Infers the possible left parent transitions of an unspread. -unspreadLeft - :: (Show slc, Show tr, R.Semiring v, Show v) - => UnspreadLeft tr slc - -- ^ the UnspreadLeft evaluator - -> TItem tr slc v - -- ^ the left child transition - -> Slice slc - -- ^ the Vert's top slice and ID - -> [TItem tr slc v] - -- ^ all possible left parent transitions -unspreadLeft unspreadl (tleft@(Transition ll lt lr is2nd) := vleft) top - | is2nd = [] - | otherwise = fromMaybe err $ do - ir <- getInner $ sContent lr - itop <- getInner $ sContent top - pure $ mkParent v' <$> unspreadl (lt, ir) itop - where - err = - error $ - "Illegal left-unspread: left=" - <> show tleft - <> ", top=" - <> show top - v' = S.unspreadScoresLeft (sID top) vleft - mkParent v t = Transition ll t top False := v - --- | Infers the possible right parent transitions of an unspread. -unspreadRight - :: (R.Semiring v, NFData slc, NFData tr, NFData v, Show tr, Show slc, Show v) - => UnspreadRight tr slc - -- ^ the UnspreadRight evaluator - -> Vert tr slc v - -- ^ the center 'Vert' - -> TItem tr slc v - -- ^ the right child transition - -> [TItem tr slc v] - -- ^ all possible right parent transitions -unspreadRight unspreadr vert@(Vert top op (_ := vm)) tright@((Transition rl rt rr _) := vr) = - fromMaybe err $ do - ir <- getInner $ sContent rl - pure $ force $ mkParent v' <$> unspreadr (ir, rt) ir - where - err = - error $ - "Illegal right-unspread: vert=" - <> show vert - <> ", right=" - <> show tright - v' = S.unspreadScoresRight (sID top) op vm vr - mkParent v t = Transition top t rr True := v - --- | Infers the possible parent transitions of a split. -unsplit - :: (R.Semiring v, NFData slc, NFData tr, NFData v, Show v) - => Unsplit tr slc v - -- ^ the Unsplit evaluator - -> TItem tr slc v - -- ^ the left child transition - -> TItem tr slc v - -- ^ the right child transition - -> [TItem tr slc v] - -- ^ all possible parent transitions -unsplit mg ((Transition ll lt lr l2nd) := vl) ((Transition _ !rt !rr _) := vr) = - case getInner $ sContent lr of - Just m -> - force $ mkItem <$> mg (sContent ll) lt m rt (sContent rr) splitType - Nothing -> error "trying to unsplit at a non-content slice" - where - splitType - | l2nd = RightOfTwo - | isStop (sContent rr) = SingleOfOne - | otherwise = LeftOfTwo - mkItem (!top, !op) = Transition ll top rr l2nd := S.unsplitScores op vl vr - --- the parsing main loop ------------------------- - --- | parallelized map -pmap :: NFData b => (a -> b) -> [a] -> [b] -pmap f = P.withStrategy (P.parList P.rdeepseq) . map f - --- pmap = map - -{- | A type alias for pair of transition chart ('TChart') - and verticalization chart ('VChart'). --} -type ParseState tr slc v = (TChart tr slc v, VChart tr slc v) - -{- | Type alias for a monadic parsing operation. - A function that takes a level and a 'ParseState' - and produces a monadic parsing action yielding a new state. - - Used to express the main parsing loop - as well as all substeps that transform the charts on a specific level. --} -type ParseOp m tr slc v = Int -> ParseState tr slc v -> m (ParseState tr slc v) - --- | A single level iteration of the chart parser. -parseStep - :: (Parsable tr slc v) - => (TChart tr slc v -> VChart tr slc v -> Int -> IO ()) - -- ^ a logging function that takes charts and level number. - -> Eval tr tr' slc slc' v - -- ^ the grammar's evaluator - -> ParseOp IO tr slc v - -- ^ the parsing operation (from level number and charts to new charts). -parseStep logCharts (Eval eMid eLeft eRight eUnsplit _ _) n charts = do - uncurry logCharts charts n - unspreadAllMiddles eMid n charts - >>= unspreadAllLefts eLeft n - >>= unspreadAllRights eRight n - >>= unsplitAll eUnsplit n - --- | Verticalizes all edges of length @n@. -unspreadAllMiddles - :: (Monad m, Parsable tr slc v) => UnspreadMiddle tr slc v -> ParseOp m tr slc v -unspreadAllMiddles evalMid n (!tchart, !vchart) = do - let ts = tcGetByLength tchart n - !newVerts = catMaybes $ pmap (unspreadMiddle evalMid) $!! ts - vchart' = vcMerge vchart newVerts - return (tchart, vchart') - --- | Perform all left unspreads where either @l@ or @m@ have length @n@. -unspreadAllLefts - :: (Monad m, Parsable tr slc v) => UnspreadLeft tr slc -> ParseOp m tr slc v -unspreadAllLefts evalLeft n (!tchart, !vchart) = do - let - -- left = n (and middle <= n) - leftn = - pmap (uncurry $ unspreadLeft evalLeft) $!! do - -- in list monad - left <- tcGetByLength tchart n - top <- vcGetByLeftChild n vchart (tRightSlice $ iItem left) - pure (left, top) - - -- middle = n (and left < n) - midn = - pmap (uncurry $ unspreadLeft evalLeft) $!! do - -- in list monad - (top, lslice) <- vcGetByLengthLeft vchart n - left <- - filter (\item -> transLen (iItem item) < n) $ - tcGetByRight tchart lslice - pure (left, top) - - -- insert new transitions into chart - tchart' = foldl' tcMerge (foldl' tcMerge tchart leftn) midn - return (tchart', vchart) - --- | Perform all right unspreads where either @r@ or @m@ have length @n@ -unspreadAllRights - :: (Monad m, Parsable tr slc v) => UnspreadRight tr slc -> ParseOp m tr slc v -unspreadAllRights evalRight n (!tchart, !vchart) = do - let - -- right = n (and middle <= n) - !rightn = - force $ pmap (uncurry $ unspreadRight evalRight) $!! do - -- in list monad - right <- tcGetByLength tchart n - vert <- vcGetByRightChild n vchart (tLeftSlice $ iItem right) - pure (vert, right) - - -- middle = n (and left < n) - !midn = - force $ pmap (uncurry $ unspreadRight evalRight) $!! do - -- in list monad - vert <- vcGetByLength vchart n - right <- - filter (\i -> transLen (iItem i) < n) $ - tcGetByLeft tchart (tRightSlice $ iItem $ vMiddle vert) - pure (vert, right) - - -- insert new transitions into chart - !tchart' = foldl' tcMerge (foldl' tcMerge tchart rightn) midn - return (tchart', vchart) - --- | perform all unsplits where either @l@ or @r@ have length @n@ -unsplitAll - :: forall tr slc v m - . (Monad m, Parsable tr slc v) - => Unsplit tr slc v - -> ParseOp m tr slc v -unsplitAll unsplitter n (!tchart, !vchart) = do - let !byLen = force $ tcGetByLength tchart n - - -- left = n (and right <= n) - !leftn = - pmap (uncurry (unsplit unsplitter)) $!! do - left <- byLen - right <- - filter (\r -> transLen (iItem r) <= n) $ - tcGetByLeft tchart (tRightSlice $ iItem left) - pure (left, right) - - -- right = n (and left < n) - !rightn = - pmap (uncurry (unsplit unsplitter)) $!! do - right <- byLen - left <- - filter (\l -> transLen (iItem l) < n) $ - tcGetByRight tchart (tLeftSlice $ iItem right) - pure (left, right) - - -- insert new transitions into chart - !tchart' = foldl' tcMerge (foldl' tcMerge tchart leftn) rightn - return (tchart', vchart) - --- parsing entry point ----------------------- - -{- | The main entrypoint to the parser. - Expects an evaluator for the specific grammar - and an input path. - Returns the combined semiring value of all full derivations. --} -parse - :: Parsable tr slc v - => (TChart tr slc v -> Either (VChart tr slc v) [Slice slc] -> Int -> IO ()) - -- ^ logging function - -> Eval tr tr' slc slc' v - -- ^ the grammar's evaluator - -> Path slc' tr' - -- ^ the input path (from first to last slice, excluding 'Start' and 'Stop') - -> IO v - -- ^ the semiring value at the top -parse logCharts eval path = do - logCharts tinit (Right $ pathArounds slicePath) 1 - (tfinal, vfinal) <- - foldM - (flip $ parseStep (\t v i -> logCharts t (Left v) i) eval) - (tinit, vcEmpty len) - [2 .. len - 1] - logCharts tfinal (Left vfinal) len - let goals = tcGetByLength tfinal len - return $ R.sum $ S.getScoreVal . iScore <$> goals - where - wrapPath (Path a e rst) = Path (Inner a) (Just e) $ wrapPath rst - wrapPath (PathEnd a) = Path (Inner a) Nothing $ PathEnd Stop - path' = Path Start Nothing $ wrapPath path - len = pathLen path' - slicePath = - mapAroundsWithIndex - 0 - (\i notes -> Slice i (evalSlice eval <$> notes) i i) - path' - mkTrans l esurf r = - mk - <$> evalUnfreeze - eval - (sContent l) - esurf - (sContent r) - (isStop $ sContent r) - where - mk (e, v) = Transition l e r False := S.val v - trans0 = mapBetweens mkTrans slicePath - tinit = tcMerge tcEmpty $ concat trans0 - --- | A logging function that logs the sice of the charts at each level. -logSize - :: TChart tr1 slc1 v1 -> Either (VChart tr2 slc2 v2) [Slice slc2] -> Int -> IO () -logSize tc vc n = do - putStrLn $ "parsing level " <> show n - putStrLn $ "transitions: " <> show (length $ tcGetByLength tc n) - let nverts = case vc of - Left chart -> length $ vcGetByLength chart (n - 1) - Right lst -> length lst - putStrLn $ "verts: " <> show nverts - --- | Parse a piece using the 'logSize' logging function. -parseSize :: Parsable tr slc v => Eval tr tr' slc slc' v -> Path slc' tr' -> IO v -parseSize = parse logSize - --- | A logging function that does nothing. -logNone :: Applicative f => p1 -> p2 -> p3 -> f () -logNone _ _ _ = pure () - --- | Parse a piece without logging. -parseSilent :: Parsable tr slc v => Eval tr tr' slc slc' v -> Path slc' tr' -> IO v -parseSilent = parse logNone - --- fancier logging --- --------------- - --- | Generate TikZ code for a slice. -printTikzSlice :: Show slc => Slice slc -> IO () -printTikzSlice (Slice f sc sid l) = do - putStrLn $ - " \\node[slice,align=center] (slice" - <> show sid - <> ") at (" - <> show (fromIntegral (f + l) / 2.0) - <> ",0) {" - <> showTex sc - <> "\\\\ " - <> show sid - <> "};" - --- | Generate TikZ code for a verticalization. -printTikzVert neighbors (Vert top@(Slice f c i l) _ middle) = do - let index = f + l - xpos = fromIntegral (f + l) / 2.0 - ypos = IM.findWithDefault 0 index neighbors - neighbors' = - IM.alter - ( \case - Just n -> Just (n + 1) - Nothing -> Just 1 - ) - index - neighbors - putStrLn $ - " \\node[slice,align=center] (slice" - <> show i - <> ") at (" - <> show xpos - <> "," - <> show ypos - <> ") {" - <> showTex c - <> "\\\\ (" - <> show (sID $ tLeftSlice $ iItem middle) - <> ") - " - <> show i - <> " - (" - <> show (sID $ tRightSlice $ iItem middle) - <> ")};" - pure neighbors' - --- | Generate TikZ code for a transition. -printTikzTrans neighbors t@(Transition sl tc sr _) = do - let tid = "t" <> show (hash t) - index = sFirst sl + sLast sr - xpos = fromIntegral index / 2.0 - ypos = IM.findWithDefault 0 index neighbors - neighbors' = - IM.alter - ( \case - Just n -> Just (n + 1) - Nothing -> Just 1 - ) - index - neighbors - putStrLn $ - " \\begin{scope}[xshift=" - <> show xpos - <> "cm,yshift=" - <> show ypos - <> "cm]" - putStrLn $ - " \\node[slice] (" - <> tid - <> "left) at (-0.1,0) {" - <> show (sID sl) - <> "};" - putStrLn $ - " \\node[slice] (" - <> tid - <> "right) at (0.1,0) {" - <> show (sID sr) - <> "};" - -- printTikzSlice sl (tid <> "left") "(-0.2,0)" - -- printTikzSlice sr (tid <> "right") "(0.2,0)" - putStrLn $ - " \\draw[transition] (" - <> tid - <> "left) -- (" - <> tid - <> "right);" - putStrLn " \\end{scope}" - pure neighbors' - --- | A logging function that emits the state of the chart in TikZ code at every level. -logTikz tc vc n = do - putStrLn $ "\n% level " <> show n - let rel = - if n <= 2 - then "" - else ",shift={($(0,0 |- scope" <> show (n - 1) <> ".north)+(0,1cm)$)}" - putStrLn $ "\\begin{scope}[local bounding box=scope" <> show n <> rel <> "]" - putStrLn " % verticalizations:" - case vc of - Left chart -> foldM_ printTikzVert IM.empty $ vcGetByLength chart (n - 1) - Right lst -> mapM_ printTikzSlice lst - putStrLn "\n % transitions:" - foldM_ printTikzTrans IM.empty $ iItem <$> tcGetByLength tc n - putStrLn "\\end{scope}" diff --git a/src/Core.hs b/src/Core.hs deleted file mode 100644 index 915c9e075..000000000 --- a/src/Core.hs +++ /dev/null @@ -1,290 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Core - ( - ) - where - -import Common -import Control.Monad.Except (ExceptT, forM, lift, runExceptT, throwError, when, zipWithM) -import Data.Hashable -import Data.Maybe - ( catMaybes - , fromJust - , fromMaybe - , isNothing - , mapMaybe - , maybeToList - ) -import System.TimeIt qualified as Time -import System.Timeout - -import Control.Logging qualified as Log -import Data.Text qualified as T - -import Algorithm.HeuristicSearch -import Algorithm.RandomChoiceSearch -import Algorithm.RandomSampleParser -import FileHandling -import HeuristicParser -import Heuristics -import Harmony -import Harmony.ChordLabel -import Harmony.Params - -import Musicology.Core -import Musicology.Core qualified as Music -import Musicology.Pitch.Spelled -import PVGrammar -import PVGrammar.Parse -import Test.Hspec - -import Data.Aeson qualified as A -import Data.Aeson.Key qualified as A -import System.Environment -import System.Exit - -d = undefined --- --- data ParseAlgo --- = RandomParse --- | RandomParseSBS --- | RandomSample --- | RandomSampleSBS --- | Heuristic1 --- | HeuristicSBS1 --- | All --- deriving (Read, Show, Eq) --- --- data AlgoResult = AlgoResult [Notes SPitch] [ChordLabel] (Maybe (Path (Edges SPitch) (Notes SPitch))) Double Double --- deriving (Show) --- --- -- Main entry point --- --- timeOutMs = 400 * 1000000 :: Int --- --- {- | Runs a random search through the entire piece --- This can get stuck due to combinatoral blowup. --- This can also reach a deadend --- -} --- runRandomParse --- :: Eval (Edges SPitch) [Edge SPitch] (Notes SPitch) [SPitch] (PVLeftmost SPitch) --- -> ([Notes SPitch] -> [ChordLabel] -> Double) --- -> [ChordLabel] --- -> [InputSlice SPitch] --- -> IO AlgoResult --- runRandomParse eval scorer chords inputSlices = --- let --- initialState = SSFrozen $ pathFromSlices eval idWrapper inputSlices --- in --- do --- res <- --- runExceptT --- (randomChoiceSearch initialState (exploreStates idWrapper eval) (goalTest chords) (showOp . getOpsFromState)) --- --- finalState <- case res of --- Left err -> print err >>= return undefined --- Right s -> pure s --- --- let path = fromJust $ getPathFromState finalState --- slices = pathBetweens path --- chordGuesses = guessChords slices --- likelihood = scorer slices chords --- accuracy = chordAccuracy chords chordGuesses --- in pure $ AlgoResult slices chordGuesses Nothing accuracy likelihood --- --- runRandomParseSingleSegment --- :: Eval (Edges SPitch) [Edge SPitch] (Notes SPitch) [SPitch] (PVLeftmost SPitch) --- -> SliceWrapper (Notes SPitch) --- -> [InputSlice SPitch] --- -> ChordLabel --- -> IO (SliceWrapped (Notes SPitch)) --- runRandomParseSingleSegment eval wrap inputSlices chordLabel = do --- let initialState = SSFrozen $ pathFromSlices eval wrap inputSlices --- res <- runExceptT (randomChoiceSearch initialState (exploreStates wrap eval) goalTestSBS (showOp . getOpsFromState)) --- finalState <- case res of --- Left err -> Log.errorL $ T.pack err --- Right s -> pure s --- --- let p = fromJust $ getPathFromState' finalState --- let finalSlice = case pathBetweens p of --- [finalSlice] -> finalSlice --- _ -> Log.errorL "Run random Parse single Segment: Single slice not returned by heuristic search" --- pure finalSlice --- --- -- | Runs a random search within each segment --- runRandomParseSBS --- :: Eval (Edges SPitch) [Edge SPitch] (Notes SPitch) [SPitch] (PVLeftmost SPitch) --- -> ([Notes SPitch] -> [ChordLabel] -> Double) --- -> [ChordLabel] --- -> [InputSlice SPitch] --- -> IO AlgoResult --- runRandomParseSBS eval scorer chords inputSlices = --- let x = splitSlicesIntoSegments eval sliceWrapper inputSlices --- in Log.timedLog "Running Random Parse SBS" $ do --- res <- zipWithM (runRandomParseSingleSegment eval idWrapper) x chords --- --- let slices = sWContent <$> res --- chordGuesses = guessChords slices --- likelihood = scorer slices chords --- accuracy = chordAccuracy chords chordGuesses --- in pure $ AlgoResult slices chordGuesses Nothing accuracy likelihood --- --- -- | Samples random notes for every segment, without looking at the segment itself --- runRandomSample --- :: Eval (Edges SPitch) [Edge SPitch] (Notes SPitch) [SPitch] (PVLeftmost SPitch) --- -> ([Notes SPitch] -> [ChordLabel] -> Double) --- -> [ChordLabel] --- -> [InputSlice SPitch] --- -> IO AlgoResult --- runRandomSample eval scorer chords inputSlices = --- let x = splitSlicesIntoSegments eval sliceWrapper inputSlices --- in Log.timedLog "Running Random Sample Parse" $ do --- path <- randomSamplePath (length chords) --- let slices = pathBetweens path --- chordGuesses = guessChords slices --- likelihood = scorer slices chords --- accuracy = chordAccuracy chords chordGuesses --- in pure $ AlgoResult slices chordGuesses Nothing accuracy likelihood --- --- -- | Samples random notes from each segment --- runRandomSampleSBS --- :: Eval (Edges SPitch) [Edge SPitch] (Notes SPitch) [SPitch] (PVLeftmost SPitch) --- -> ([Notes SPitch] -> [ChordLabel] -> Double) --- -> [ChordLabel] --- -> [InputSlice SPitch] --- -> IO AlgoResult --- runRandomSampleSBS eval scorer chords inputSlices = --- let x = splitSlicesIntoSegments eval sliceWrapper inputSlices --- in Log.timedLog "Running Random Sample SBS Parse" $ do --- path <- randomSamplePathSBS x --- --- let slices = pathBetweens path --- chordGuesses = guessChords slices --- likelihood = scorer slices chords --- accuracy = chordAccuracy chords chordGuesses --- in pure $ AlgoResult slices chordGuesses Nothing accuracy likelihood --- --- -- {- | Uses a beam search, using chordtone and ornamentation probabilities as a score --- -- -} --- -- runHeuristic1 :: HarmonicProfileData -> [ChordLabel] -> [InputSlice SPitch] -> String -> IO () --- -- runHeuristic1 params chordsFile slicesFile jsonFile = do --- -- pure () --- -- --- --- -- | Uses a beam search, using chordtone and ornamentation probabilities as a score, but running separately for each segment --- runHeuristicSBS1 --- :: Eval (Edges SPitch) [Edge SPitch] (Notes SPitch) [SPitch] (PVLeftmost SPitch) --- -> ([Notes SPitch] -> [ChordLabel] -> Double) --- -> [ChordLabel] --- -> [InputSlice SPitch] --- -> IO AlgoResult --- runHeuristicSBS1 eval scorer chords inputSlices = --- let x = splitSlicesIntoSegments eval sliceWrapper inputSlices --- in Log.timedLog "Running Heuristic Search 1 SBS" $ do --- resultingSlices <- zipWithM (runHeuristicSearchSingleSegment eval sliceWrapper testHeuristic) x chords --- --- let chordGuesses = sLbl <$> resultingSlices --- slices = sWContent <$> resultingSlices --- likelihood = scorer slices chords --- accuracy = chordAccuracy chords chordGuesses --- in pure $ AlgoResult slices chordGuesses Nothing accuracy likelihood --- --- ----- --- runHeuristic1 --- :: Eval (Edges SPitch) [Edge SPitch] (Notes SPitch) [SPitch] (PVLeftmost SPitch) --- -> ([Notes SPitch] -> [ChordLabel] -> Double) --- -> [ChordLabel] --- -> [InputSlice SPitch] --- -> IO AlgoResult --- runHeuristic1 eval scorer chords inputSlices = Log.timedLog "Running Heuristic Search" $ do --- let initialState = SSFrozen $ pathFromSlices eval sliceWrapper inputSlices --- res <- runExceptT (heuristicSearch initialState (exploreStates sliceWrapper eval) (goalTest chords) (applyHeuristic testHeuristic) (showOp . getOpsFromState)) --- --- finalState <- case res of --- Left err -> do --- Log.warn $ T.pack err --- return undefined --- Right s -> pure s --- --- let resultingSlices = pathBetweens $ fromJust $ getPathFromState' finalState --- chordGuesses = sLbl <$> resultingSlices --- slices = sWContent <$> resultingSlices --- likelihood = scorer slices chords --- accuracy = chordAccuracy chords chordGuesses --- in pure $ AlgoResult slices chordGuesses Nothing accuracy likelihood --- --- runHeuristicSearch --- :: Eval (Edges SPitch) [Edge SPitch] (Notes SPitch) [SPitch] (PVLeftmost SPitch) --- -> SliceWrapper (Notes SPitch) --- -> ((Maybe (State SPitch), State SPitch) -> ExceptT String IO Double) --- -> [InputSlice SPitch] --- -> [ChordLabel] --- -> IO (Path (Edges SPitch) (Notes SPitch)) --- runHeuristicSearch eval wrap heuristic inputSlices chordLabels = do --- let initialState = SSFrozen $ pathFromSlices eval wrap inputSlices --- res <- runExceptT (heuristicSearch initialState getNeighboringStates (goalTest chordLabels) heuristic (showOp . getOpsFromState)) --- finalState <- case res of --- Left err -> do --- Log.warn $ T.pack err --- return undefined --- Right s -> pure s --- --- let p = fromJust $ getPathFromState finalState --- print p --- --- --- let ops = getOpsFromState finalState --- --- pure p --- where --- showOp [] = "" --- showOp (x : _) = case x of --- LMDouble y -> show y --- LMSingle y -> show y --- --- getNeighboringStates = exploreStates wrap eval --- --- runHeuristicSearchSingleSegment --- :: Eval (Edges SPitch) [Edge SPitch] (Notes SPitch) [SPitch] (PVLeftmost SPitch) --- -> SliceWrapper (Notes SPitch) --- -> ((Maybe (State SPitch), State SPitch) -> ExceptT String IO Double) --- -> [InputSlice SPitch] --- -> ChordLabel --- -> IO (SliceWrapped (Notes SPitch)) --- runHeuristicSearchSingleSegment eval wrap heuristic inputSlices chordLabel = do --- let initialState = SSFrozen $ pathFromSlices eval wrap inputSlices --- res <- runExceptT (heuristicSearch initialState (exploreStates wrap eval) goalTestSBS heuristic (showOp . getOpsFromState)) --- finalState <- case res of --- Left err -> Log.errorL $ T.pack err --- Right s -> pure s --- --- let p = fromJust $ getPathFromState' finalState --- finalSlice = case pathBetweens p of --- [finalSlice] -> finalSlice --- _ -> Log.errorL "runHeuristicSearchSingleSegment: Single slice not returned by heuristic search" --- in pure finalSlice --- --- resultToJSON :: ParseAlgo -> Double -> AlgoResult -> IO A.Value --- resultToJSON a time (AlgoResult sl ch pa ac li) = --- pure $ writeResultsToJSON sl ch Nothing ac li (show a) time --- --- runAlgo --- :: ParseAlgo --- -> ([Notes SPitch] -> [ChordLabel] -> Double) --- -> [ChordLabel] --- -> [InputSlice SPitch] --- -> IO AlgoResult --- runAlgo algo scorer arams inputChords inputSlices = --- let run = case algo of --- RandomParse -> runRandomParse --- RandomParseSBS -> runRandomParseSBS --- RandomSample -> runRandomSample --- RandomSampleSBS -> runRandomSampleSBS --- Heuristic1 -> runHeuristic1 --- HeuristicSBS1 -> runHeuristicSBS1 --- All -> error "" --- in run protoVoiceEvaluator scorer inputChords inputSlices diff --git a/src/FileHandling.hs b/src/FileHandling.hs index d39b13453..3db532765 100644 --- a/src/FileHandling.hs +++ b/src/FileHandling.hs @@ -46,7 +46,7 @@ import Data.Vector qualified as V import Debug.Trace import Display import GHC.Generics -import HeuristicParser +import Parser.HeuristicParser import Heuristics import Internal.MultiSet qualified as MS import Language.Haskell.DoNotation diff --git a/src/GreedyParser.hs b/src/GreedyParser.hs deleted file mode 100644 index 6c48a8a03..000000000 --- a/src/GreedyParser.hs +++ /dev/null @@ -1,531 +0,0 @@ -{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -{-# OPTIONS_HADDOCK ignore-exports #-} - -{- | This module contains a simple greedy parser for path grammars. - The grammar is provided by an evaluator ('Eval'). - In addition, the parser takes a policy function - that picks a reduction option in each step. --} -module GreedyParser where - --- TODO: add back export list once haddock's ignore-exports works again. --- ( parseGreedy --- , pickRandom --- , parseRandom --- , parseRandom' --- ) where - -import Common - -import Control.Monad.Except - ( ExceptT - , MonadError (throwError) - ) -import Control.Monad.IO.Class - ( MonadIO - ) -import Control.Monad.Trans.Class (lift) -import Data.Maybe - ( catMaybes - , mapMaybe - , maybeToList - ) -import System.Random (initStdGen) -import System.Random.Stateful - ( StatefulGen - , newIOGenM - , uniformRM - ) - --- * Parsing State - -{- | A transition during greedy parsing. - Augments transition data with a flag - that indicates whether the transition is a transitive right (2nd) parent of a spread. --} -data Trans tr = Trans - { _tContent :: !tr - -- ^ content of the transition - , _t2nd :: !Bool - -- ^ flag that indicates (transitive) right parents of spreads - } - deriving (Show) - -{- | The state of the greedy parse between steps. - Generally, the current reduction consists of frozen transitions - between the ⋊ and the current location - and open transitions between the current location and ⋉. - - > ⋊==[1]==[2]==[3]——[4]——[5]——⋉ - > └ frozen ┘ | └ open ┘ - > midSlice (current position) - > - > frozen: ==[2]==[1]== - > midSlice: [3] - > open: ——[4]——[5]—— - - This is the 'GSSemiOpen' case: - The slice at the current pointer (@[3]@) - is represented as an individual slice (@midSlice@). - The frozen part is represented by a 'Path' of frozen transitions (@tr'@) and slices (@slc@). - __in reverse direction__, i.e. from @midslice@ back to ⋊ (excluding ⋊). - The open part is a 'Path' of open transitions (@tr@) and slices (@slc@) - in forward direction from @midSlice@ up to ⋉. - - There are two special cases. - All transitions can be frozen ('GSFrozen'), - in which case state only contains the backward 'Path' of frozen transitions - (excluding ⋊ and ⋉): - - > ⋊==[1]==[2]==[3]==⋉ - > └ current position - > represented as: ==[3]==[2]==[1]== - - Or all transitions can be open ('GSOpen'), - in which case the state is just the forward path of open transitions: - - > ⋊——[1]——[2]——[3]——⋉ - > └ current position - > represented as: ——[1]——[2]——[3]—— - - The open and semiopen case additionally have a list of operations in generative order. --} -data GreedyState tr tr' slc op - = GSFrozen !(Path (Maybe tr') slc) - | GSSemiOpen - { _gsFrozen :: !(Path (Maybe tr') slc) - -- ^ frozen transitions and slices from current point leftward - , _gsMidSlice :: !slc - -- ^ the slice at the current posision between gsFrozen and gsOpen - , _gsOpen :: !(Path (Trans tr) slc) - -- ^ non-frozen transitions and slices from current point rightward - , _gsDeriv :: ![op] - -- ^ derivation from current reduction to original surface - } - | GSOpen !(Path (Trans tr) slc) ![op] - -instance (Show slc, Show o) => Show (GreedyState tr tr' slc o) where - show (GSFrozen frozen) = showFrozen frozen <> "⋉" - show (GSOpen open _ops) = "⋊" <> showOpen open -- <> " " <> show ops - show (GSSemiOpen frozen mid open _ops) = - showFrozen frozen <> show mid <> showOpen open -- <> " " <> show ops - --- | Helper function for showing the frozen part of a piece. -showFrozen :: Show slc => Path tr' slc -> String -showFrozen path = "⋊" <> go 5 path - where - go _ (PathEnd _) = "=" - go 0 (Path _ a rst) = "..." <> show a <> "=" - go n (Path _ a rst) = go (n - 1) rst <> show a <> "=" - --- | Helper function for showing the open part of a piece. -showOpen :: Show slc => Path tr slc -> String -showOpen path = go 5 path <> "⋉" - where - go _ (PathEnd _) = "-" - go 0 (Path _ a rst) = "-" <> show a <> "..." - go n (Path _ a rst) = "-" <> show a <> go (n - 1) rst - --- * Parsing Actions - -{- | A parsing action (reduction step) with a single parent transition. - Combines the parent elements with a single-transition derivation operation. --} -data ActionSingle slc tr s f - = ActionSingle - (StartStop slc, Trans tr, StartStop slc) - -- ^ parent transition (and adjacent slices) - (LeftmostSingle s f) - -- ^ single-transition operation - deriving (Show) - -{- | A parsing action (reduction step) with two parent transitions. - Combines the parent elements with a double-transition derivation operation. --} -data ActionDouble slc tr s f h - = ActionDouble - ( StartStop slc - , Trans tr - , slc - , Trans tr - , StartStop slc - ) - -- ^ parent transitions and slice - (LeftmostDouble s f h) - -- ^ double-transition operation - deriving (Show) - --- | An alias that combines 'ActionSingle' and 'ActionDouble', representing all possible reduction steps. -type Action slc tr s f h = Either (ActionSingle slc tr s f) (ActionDouble slc tr s f h) - --- * Parsing Algorithm - -{- | Parse a piece in a greedy fashion. - At each step, a policy chooses from the possible reduction actions, - the reduction is applied, and parsing continues - until the piece is fully reduced or no more reduction operations are available. - Returns the full derivation from the top (@⋊——⋉@) or an error message. --} -parseGreedy - :: forall m tr tr' slc slc' s f h - . (Monad m, MonadIO m, Show tr', Show slc, Show tr, Show s, Show f, Show h) - => Eval tr tr' slc slc' (Leftmost s f h) - -- ^ the evaluator of the grammar to be used - -> ([Action slc tr s f h] -> ExceptT String m (Action slc tr s f h)) - -- ^ the policy: picks a parsing action from a list of options - -- (determines the 'Monad' @m@, e.g., for randomness). - -> Path slc' tr' - -- ^ the input piece - -> ExceptT String m (Analysis s f h tr slc) - -- ^ the full parse or an error message -parseGreedy eval pick input = do - (top, deriv) <- parse initState - pure $ Analysis deriv $ PathEnd top - where - initState = GSFrozen $ wrapPath Nothing (reversePath input) - -- prepare the input: eval slices, wrap in Inner, add Start/Stop - wrapPath :: Maybe tr' -> Path slc' tr' -> Path (Maybe tr') slc - wrapPath eleft (PathEnd a) = Path eleft (evalSlice eval a) $ PathEnd Nothing - wrapPath eleft (Path a e rst) = - Path eleft (evalSlice eval a) $ wrapPath (Just e) rst - - -- parsing loop - parse - :: GreedyState tr tr' slc (Leftmost s f h) - -> ExceptT String m (tr, [Leftmost s f h]) - - -- case 1: everything frozen - parse state = do - -- liftIO $ putStrLn "" >> print state - case state of - GSFrozen frozen -> case frozen of - -- only one transition: unfreeze and terminate - PathEnd trans -> do - (Trans thawed _, op) <- - pickSingle $ - collectThawSingle Start trans Stop - pure (thawed, [LMSingle op]) - -- several transition: unfreeze last and continue - Path t slice rst -> do - (thawed, op) <- pickSingle $ collectThawSingle (Inner slice) t Stop - parse $ GSSemiOpen rst slice (PathEnd thawed) [LMSingle op] - - -- case 2: everything open - GSOpen open ops -> case open of - -- only one transition: terminate - PathEnd (Trans t _) -> pure (t, ops) - -- two transitions: unsplit single and terminate - Path tl slice (PathEnd tr) -> do - (Trans ttop _, optop) <- - pickSingle $ - collectUnsplitSingle Start tl slice tr Stop - pure (ttop, LMSingle optop : ops) - -- more than two transitions: pick double operation and continue - Path tl sl (Path tm sr rst) -> do - let doubles = collectDoubles Start tl sl tm sr rst - ((topl, tops, topr), op) <- pickDouble doubles - parse $ - GSOpen - (Path topl tops (pathSetHead rst topr)) - (LMDouble op : ops) - - -- case 3: some parts frozen, some open - GSSemiOpen frozen mid open ops -> case open of - -- only one open transition: thaw - PathEnd topen -> case frozen of - PathEnd tfrozen -> do - ((thawed, _, _), op) <- - pickDouble $ - collectThawLeft Start tfrozen mid topen Stop - parse $ GSOpen (Path thawed mid open) (LMDouble op : ops) - Path tfrozen sfrozen rstFrozen -> do - ((thawed, _, _), op) <- - pickDouble $ - collectThawLeft (Inner sfrozen) tfrozen mid topen Stop - parse $ - GSSemiOpen - rstFrozen - sfrozen - (Path thawed mid open) - (LMDouble op : ops) - -- two open transitions: thaw or unsplit single - Path topenl sopen (PathEnd topenr) -> do - let - unsplits = - Left <$> collectUnsplitSingle (Inner mid) topenl sopen topenr Stop - case frozen of - PathEnd tfrozen -> do - let - thaws = - Right - <$> collectThawLeft Start tfrozen mid topenl (Inner sopen) - action <- pick $ thaws <> unsplits - case action of - -- picked unsplit - Left (ActionSingle (_, parent, _) op) -> - parse $ - GSSemiOpen - frozen - mid - (PathEnd parent) - (LMSingle op : ops) - -- picked thaw - Right (ActionDouble (_, thawed, _, _, _) op) -> - parse $ GSOpen (Path thawed mid open) (LMDouble op : ops) - Path tfrozen sfrozen rstFrozen -> do - let thaws = - Right - <$> collectThawLeft - (Inner sfrozen) - tfrozen - mid - topenl - (Inner sopen) - action <- pick $ thaws <> unsplits - case action of - -- picked unsplit - Left (ActionSingle (_, parent, _) op) -> - parse $ - GSSemiOpen - frozen - mid - (PathEnd parent) - (LMSingle op : ops) - -- picked thaw - Right (ActionDouble (_, thawed, _, _, _) op) -> - parse $ - GSSemiOpen - rstFrozen - sfrozen - (Path thawed mid open) - (LMDouble op : ops) - -- more than two open transitions: thaw or any double operation - Path topenl sopenl (Path topenm sopenr rstOpen) -> do - let doubles = - collectDoubles (Inner mid) topenl sopenl topenm sopenr rstOpen - case frozen of - PathEnd tfrozen -> do - let thaws = - collectThawLeft Start tfrozen mid topenl (Inner sopenl) - action <- pickDouble $ thaws <> doubles - case action of - -- picked thaw - ((thawed, _, _), op@(LMDoubleFreezeLeft _)) -> - parse $ GSOpen (Path thawed mid open) (LMDouble op : ops) - -- picked non-thaw - ((topl, tops, topr), op) -> - parse $ - GSSemiOpen - frozen - mid - (Path topl tops (pathSetHead rstOpen topr)) - (LMDouble op : ops) - Path tfrozen sfrozen rstFrozen -> do - let - thaws = - collectThawLeft - (Inner sfrozen) - tfrozen - mid - topenl - (Inner sopenl) - action <- pickDouble $ thaws <> doubles - case action of - -- picked thaw - ((thawed, _, _), op@(LMDoubleFreezeLeft _)) -> - parse $ - GSSemiOpen - rstFrozen - sfrozen - (Path thawed mid open) - (LMDouble op : ops) - -- picked non-thaw - ((topl, tops, topr), op) -> - parse $ - GSSemiOpen - frozen - mid - (Path topl tops (pathSetHead rstOpen topr)) - (LMDouble op : ops) - - pickSingle - :: [ActionSingle slc tr s f] -> ExceptT String m (Trans tr, LeftmostSingle s f) - pickSingle actions = do - -- liftIO $ putStrLn $ "pickSingle " <> show actions - action <- pick $ Left <$> actions - case action of - Left (ActionSingle (_, top, _) op) -> pure (top, op) - Right _ -> throwError "pickSingle returned a double action" - - pickDouble - :: [ActionDouble slc tr s f h] - -> ExceptT String m ((Trans tr, slc, Trans tr), LeftmostDouble s f h) - pickDouble actions = do - -- liftIO $ putStrLn $ "pickDouble " <> show actions - action <- pick $ Right <$> actions - case action of - Left _ -> throwError "pickDouble returned a single action" - Right (ActionDouble (_, topl, tops, topr, _) op) -> - pure ((topl, tops, topr), op) - - collectThawSingle - :: (StartStop slc -> Maybe tr' -> StartStop slc -> [ActionSingle slc tr s f]) - collectThawSingle sl t sr = - mapMaybe - getAction - (evalUnfreeze eval sl t sr True) - where - getAction (t', op) = case op of - LMSingle sop -> Just $ ActionSingle (sl, Trans t' False, sr) sop - LMDouble _ -> Nothing - - collectThawLeft - :: ( StartStop slc - -> Maybe tr' - -> slc - -> Trans tr - -> StartStop slc - -> [ActionDouble slc tr s f h] - ) - collectThawLeft sl tl sm (Trans tr _) sr = - mapMaybe - getAction - (evalUnfreeze eval sl tl (Inner sm) False) - where - getAction (thawed, op) = case op of - LMDouble dop -> - Just $ ActionDouble (sl, Trans thawed False, sm, Trans tr False, sr) dop - LMSingle _ -> Nothing - - collectUnsplitSingle - :: ( StartStop slc - -> Trans tr - -> slc - -> Trans tr - -> StartStop slc - -> [ActionSingle slc tr s f] - ) - collectUnsplitSingle sl (Trans tl _) sm (Trans tr _) sr = - mapMaybe getAction $ evalUnsplit eval sl tl sm tr sr SingleOfOne - where - getAction (ttop, op) = case op of - LMSingle sop -> Just $ ActionSingle (sl, Trans ttop False, sr) sop - LMDouble _ -> Nothing - - collectUnsplitLeft - :: ( StartStop slc - -> Trans tr - -> slc - -> Trans tr - -> slc - -> Trans tr - -> StartStop slc - -> [ActionDouble slc tr s f h] - ) - collectUnsplitLeft sstart (Trans tl _) sl (Trans tm _) sr (Trans tr _) send = - mapMaybe getAction $ evalUnsplit eval sstart tl sl tm (Inner sr) LeftOfTwo - where - getAction (ttop, op) = case op of - LMSingle _ -> Nothing - LMDouble dop -> - Just $ - ActionDouble - (sstart, Trans ttop False, sr, Trans tr False, send) - dop - - collectUnsplitRight - :: ( StartStop slc - -> Trans tr - -> slc - -> Trans tr - -> slc - -> Trans tr - -> StartStop slc - -> [ActionDouble slc tr s f h] - ) - collectUnsplitRight sstart tl sl (Trans tm m2nd) sr (Trans tr _) send - | not m2nd = [] - | otherwise = - mapMaybe getAction $ - evalUnsplit eval (Inner sl) tm sr tr send RightOfTwo - where - getAction (ttop, op) = case op of - LMSingle _ -> Nothing - LMDouble dop -> - Just $ ActionDouble (sstart, tl, sl, Trans ttop True, send) dop - - collectUnspreads - :: ( StartStop slc - -> Trans tr - -> slc - -> Trans tr - -> slc - -> Trans tr - -> StartStop slc - -> [ActionDouble slc tr s f h] - ) - collectUnspreads sstart (Trans tl _) sl (Trans tm _) sr (Trans tr _) send = - catMaybes $ do - -- List - (sTop, op) <- maybeToList $ evalUnspreadMiddle eval (sl, tm, sr) - lTop <- evalUnspreadLeft eval (tl, sl) sTop - rTop <- evalUnspreadRight eval (sr, tr) sTop - pure $ getAction lTop sTop rTop op - where - -- pure $ getAction $ evalUnsplit eval (Inner sl) tm sr tr send RightOfTwo - - getAction lTop sTop rTop op = case op of - LMSingle _ -> Nothing - LMDouble dop -> - Just $ - ActionDouble - (sstart, Trans lTop False, sTop, Trans rTop True, send) - dop - - collectDoubles sstart tl sl tm sr rst = leftUnsplits <> rightUnsplits <> unspreads - where - (tr, send) = case rst of - PathEnd t -> (t, Stop) - Path t s _ -> (t, Inner s) - leftUnsplits = collectUnsplitLeft sstart tl sl tm sr tr send - rightUnsplits = collectUnsplitRight sstart tl sl tm sr tr send - unspreads = collectUnspreads sstart tl sl tm sr tr send - -{- | A policy that picks the next action at random. - Must be partially applied with a random generator before passing to 'parseGreedy'. --} -pickRandom :: StatefulGen g m => g -> [slc] -> ExceptT String m slc -pickRandom _ [] = throwError "No candidates for pickRandom!" -pickRandom gen xs = do - i <- lift $ uniformRM (0, length xs - 1) gen - pure $ xs !! i - --- * Entry Points - --- | Parse a piece randomly using a fresh random number generator. -parseRandom - :: (Show tr', Show slc, Show tr, Show s, Show f, Show h) - => Eval tr tr' slc slc' (Leftmost s f h) - -- ^ the grammar's evaluator - -> Path slc' tr' - -- ^ the input piece - -> ExceptT String IO (Analysis s f h tr slc) - -- ^ a random reduction of the piece (or an error message) -parseRandom eval input = do - gen <- lift initStdGen - mgen <- lift $ newIOGenM gen - parseGreedy eval (pickRandom mgen) input - --- | Parse a piece randomly using an existing random number generator. -parseRandom' - :: (Show tr', Show slc, Show tr, Show s, Show f, Show h, StatefulGen g IO) - => g - -- ^ a random number generator - -> Eval tr tr' slc slc' (Leftmost s f h) - -- ^ the grammar's evaluator - -> Path slc' tr' - -- ^ the input piece - -> ExceptT String IO (Analysis s f h tr slc) - -- ^ a random reduction of the piece (or an error message) -parseRandom' mgen eval input = do - parseGreedy eval (pickRandom mgen) input diff --git a/src/HeuristicParser.hs b/src/HeuristicParser.hs deleted file mode 100644 index 3c51db721..000000000 --- a/src/HeuristicParser.hs +++ /dev/null @@ -1,933 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -{- | A parser for the protovoice model, representials partial reductions as a search state that can be traversed - by applying operations such as 'Unspread', 'Unfreeze' and 'Unsplit'. --} -module HeuristicParser - ( - Slice (..) - , SliceWrapped (..) - , SliceWrapper (..) - , sliceWrapper - , idWrapper - - , Trans (..) - , Boundary - - , SearchState (..) - , SearchState' - - , ActionSingle (..) - , ActionDouble (..) - - , exploreStates - , exploreStates' - - , goalTest - , goalTestSBS - , heursiticSearchGoalTest - - , getPathFromState - , getPathLengthFromState - , getPathFromState' - , getSlicesFromState - , getOpFromState - , getOpsFromState - - , chordAccuracy - , guessChords - , showOp - ) - where - -import System.Timeout -import Common -import Control.Monad.Except (ExceptT, lift, throwError) -import Data.Bifunctor qualified as BF (second) -import Data.HashMap.Strict qualified as HM -import Data.Maybe (Maybe, catMaybes, fromJust, mapMaybe, maybeToList) -import Musicology.Pitch -import PVGrammar -import Harmony -import Harmony.Params -import Harmony.ChordLabel - --- | Slice datatype for parsing -newtype Slice ns = Slice - { sContent :: ns - -- ^ Content of the Slice - } - deriving (Eq) - -{- | Data type for a slice "wrapped" with additional information. Contains the content alongside - the guess of the most likely chord label, and our confidence in that label. --} -data SliceWrapped ns = SliceWrapped - { sWContent :: ns - , sLbl :: ChordLabel - , sLblProb :: Double - } - deriving (Eq) - --- | Type for functions that 'wrap' slices with additional information -newtype SliceWrapper ns = SliceWrapper - { wrapSlice :: ns -> SliceWrapped ns - -- ^ Converts a slice into a wrapped slice, giving additional information such as a guess of the chord it represents. - } - -idWrapper :: SliceWrapper ns -idWrapper = SliceWrapper{wrapSlice = \n -> SliceWrapped n undefined 1} - -instance Show ns => Show (Slice ns) where - show (Slice ns) = show ns - -instance Show ns => Show (SliceWrapped ns) where - show (SliceWrapped ns _ _) = show ns - --- | Boolean type synonym representing if a transition is a boundary between two segments -type Boundary = Bool - -{- | Transition wrapper datatype. Wraps a transition with a flag indicating whether or not the transition - is the 2nd right parent of a spread, and another flag marking whether or not this transition is at a boundary - between segments --} -data Trans es = Trans - { tContent :: !es - -- ^ The value inside the transition, i.e. protovoice edges - , t2nd :: !Bool - -- ^ Marks if this transition is the 2nd right parent of a spread - , tBoundary :: !Boundary - -- ^ Marks whether or not this transition is at a boundary between two segments - } - deriving (Eq) - -instance Show es => Show (Trans es) where - show (Trans t t2 True) = "|" <> show t - show (Trans t t2 False) = show t - -{- | The state of the search between steps. - Generally, the current reduction consists of frozen transitions - between the ⋊ and the current location - and open transitions between the current location and ⋉. - - > ⋊==[1]==[2]==[3]——[4]——[5]——⋉ - > └ frozen ┘ | └ open ┘ - > midSlice (current position) - > - > frozen: ==[2]==[1]== - > midSlice: [3] - > open: ——[4]——[5]—— - - This is the 'SSSemiOpen' case: - The slice at the current pointer (@[3]@) - is represented as an individual slice (@_ssMidSlice@). - The frozen part is represented by a 'Path' of frozen transitions (@tr'@) and slices (@slc@). - __in reverse direction__, i.e. from @midslice@ back to ⋊ (excluding ⋊). - The open part is a 'Path' of open transitions (@tr@) and slices (@slc@) - in forward direction from @midSlice@ up to ⋉. - - There are two special cases. - All transitions can be frozen ('SSFrozen'), - in which case state only contains the backward 'Path' of frozen transitions - (excluding ⋊ and ⋉): - - > ⋊==[1]==[2]==[3]==⋉ - > └ current position - > represented as: ==[3]==[2]==[1]== - - Or all transitions can be open ('SSOpen'), - in which case the state is just the forward path of open transitions: - - > ⋊——[1]——[2]——[3]——⋉ - > └ current position - > represented as: ——[1]——[2]——[3]—— - - The open and semiopen case additionally have a list of operations in generative order. - - -Types: -es' : Unparsed/frozen transitions -es : Unfrozen transitions -ns : Evaluated slice content -o : Operation type --} -data SearchState es es' ns o - = SSFrozen !(Path (Maybe es', Bool) (SliceWrapped ns)) -- Beginning of search - all frozen edges and slices - | SSSemiOpen -- Point between beginning and end of the path - { _ssFrozen :: !(Path (Maybe es', Bool) (SliceWrapped ns)) - -- ^ frozen transitions and slices from current point leftward - , _ssMidSlice :: !(SliceWrapped ns) - -- ^ the slice at the current posision between gsFrozen and gsOpen - , _ssOpen :: !(Path (Trans es) (SliceWrapped ns)) - -- ^ non-frozen transitions and slices from current point rightward - , _ssDeriv :: ![o] - -- ^ derivation from current reduction to original surface - } - | SSOpen !(Path (Trans es) (SliceWrapped ns)) ![o] -- Single path with unfrozen transition,slices and history - -type SearchState' = SearchState (Edges SPitch) [Edge SPitch] (Notes SPitch) (Leftmost (Split SPitch) Freeze (Spread SPitch)) - -instance (Show ns, Show o) => Show (SearchState es es' ns o) where - show (SSFrozen frozen) = showFrozen frozen <> "⋉" - show (SSOpen open ops) = "⋊" <> showOpen open - show (SSSemiOpen frozen midSlice open ops) = showFrozen frozen <> show midSlice <> showOpen open - --- | Helper function for showing the frozen part of a piece. -showFrozen :: Show slc => Path (Maybe es', Bool) slc -> String -showFrozen path = "⋊" <> go 1 path - where - go _ (PathEnd (_, True)) = "≠" - go _ (PathEnd (_, False)) = "=" - go 0 (Path (_, True) a rst) = "..." <> show a <> "≠" - go n (Path (_, True) a rst) = go (n - 1) rst <> show a <> "≠" - go 0 (Path (_, False) a rst) = "..." <> show a <> "=" - go n (Path (_, False) a rst) = go (n - 1) rst <> show a <> "=" - --- | Helper function for showing the open part of a piece. -showOpen :: Show slc => Path (Trans es') slc -> String -showOpen path = go 3 path <> "⋉" - where - go _ (PathEnd (Trans _ _ True)) = "⌿" - go _ (PathEnd (Trans _ _ False)) = "-" - go 0 (Path (Trans _ _ True) a rst) = "⌿" <> show a <> "..." - go n (Path (Trans _ _ True) a rst) = "⌿" <> show a <> go (n - 1) rst - go 0 (Path _ a rst) = "-" <> show a <> "..." - go n (Path _ a rst) = "-" <> show a <> go (n - 1) rst - -{- | Returns a list of possible next states given the current state. - Works by applying the inverse of the following operations, as returned by the protovoiceEvaluator. - > - > freeze left: split left: split right: spread: - > ...=[]——[]——[]—... ...=[]——[]——[]—... ...=[]——[]——[]—... ...=[]——[]——[]—... - > ...=[]==[]——[]—... \ / \ / \ /\ / - > [] [] []——[] --} -exploreStates - :: forall es es' ns ns' s f h - . (Show s, Show f, Show h, Show es, Show es', Show ns, Show ns') - => SliceWrapper ns - -> Eval es es' ns ns' (Leftmost s f h) - -> SearchState es es' ns (Leftmost s f h) - -> ExceptT String IO [SearchState es es' ns (Leftmost s f h)] - -- ^ Either a error message or a list of possible next states -exploreStates wrap eval state = do - -- lift $ putStrLn "_________________________________________________________" - -- lift $ putStrLn $ "\n Exploring state: " <> show state <> "\n" - case state of - SSFrozen frozen -> case frozen of - -- Only one trasition: we unfreeze and terminate - PathEnd t -> do - -- lift $ putStrLn "1 frozen transition: " - pure $ genState <$> actions - where - actions = collectUnfreezeSingle Start t Stop True - genState (ActionSingle (sl, top, sr) op) = SSOpen (PathEnd top) [LMSingle op] - -- Multiple transitions: unfreeze first and continue - Path t slice rest -> do - -- lift $ putStrLn "1+ frozen transitions only:" - pure $ genState <$> actions - where - actions = collectUnfreezeSingle Start t (Inner $ sWContent slice) True - genState (ActionSingle (sl, top, sr) op) = SSSemiOpen rest slice (PathEnd top) [LMSingle op] - - -- Case: Every transition is unfrozen - SSOpen open ops -> reductions - where - reductions = case open of - -- A single transition - No operations - PathEnd _ -> do - -- lift $ putStrLn "0 Frozen, 1 open: No operations\n" - pure [] - -- Two open transitions: unsplit single - Path tl slice (PathEnd tr) -> do - -- lift $ putStrLn "2 open transitions only: \n" - pure $ genState <$> actions - where - actions = collectUnsplitSingle Start tl (sWContent slice) tr Stop - genState (ActionSingle (sl, top, sr) op) = - SSOpen (PathEnd top) (LMSingle op : ops) - - -- Three open transitions: unsplitLeft, unsplitRight, or unspread (double ops) - Path tl sl (Path tm sr rst) -> do - -- lift $ putStrLn "3+ Open transitions:" - pure $ genState <$> actions - where - actions = collectDoubles Start tl (sWContent sl) tm (sWContent sr) (BF.second sWContent rst) - genState (ActionDouble (_, topl, tops, topr, _) op) = - SSOpen (Path topl (wrapSlice wrap tops) (pathSetHead rst topr)) (LMDouble op : ops) - - -- Mid Parse - -- - SSSemiOpen frozen midSlice open ops -> - let frozenBoundary = snd $ pathHead frozen - in case open of - -- Only one open transition: unfreeze - PathEnd topen -> case frozen of - PathEnd tfrozen -> do - -- lift $ putStrLn "1 Open Transition, 1 frozen transition: \n" - pure $ genState <$> actions - where - actions = collectUnfreezeLeft Start tfrozen (sWContent midSlice) topen Stop True - genState (ActionDouble (sl, tl, slice, tr, st) op) = - SSOpen - (Path tl (wrapSlice wrap slice) (PathEnd tr)) - (LMDouble op : ops) - Path tfrozen sfrozen rstFrozen -> do - -- lift $ putStrLn "1 Open Transition, 1+ frozen transition: \n" - pure $ genState <$> actions - where - actions = collectUnfreezeLeft (Inner $ sWContent sfrozen) tfrozen (sWContent midSlice) topen Stop True - genState (ActionDouble (sl, tl, slice, tr, st) op) = - SSSemiOpen rstFrozen sfrozen (Path tl midSlice open) (LMDouble op : ops) - - -- Two Open transitions: unfreeze or unsplit single - Path topenl sopen (PathEnd topenr@(Trans _ _ topenrBoundary)) -> do - let unsplitActions = Right <$> collectUnsplitSingle (Inner $ sWContent midSlice) topenl (sWContent sopen) topenr Stop - in case frozen of - PathEnd tfrozen -> do - -- lift $ putStrLn "2 Open Transitions, 1 frozen transition: \n" - pure $ genState <$> (unfreezeActions <> unsplitActions) - where - unfreezeActions = - Left - <$> collectUnfreezeLeft Start tfrozen (sWContent midSlice) topenl Stop topenrBoundary - - genState action = case action of - Left (ActionDouble (_, unfrozen, _, _, _) op) -> - SSOpen (Path unfrozen midSlice open) (LMDouble op : ops) - Right (ActionSingle (parentL, parent, parentR) op) -> - SSSemiOpen frozen midSlice (PathEnd parent) (LMSingle op : ops) -- change midSlice? - Path tfrozen sfrozen rstFrozen -> do - -- lift $ putStrLn "2 Open Transitions, 1+ frozen transitions: \n" - pure $ genState <$> (unfreezeActions <> unsplitActions) - where - unfreezeActions = - Left - <$> collectUnfreezeLeft (Inner $ sWContent sfrozen) tfrozen (sWContent midSlice) topenl (Inner (sWContent sopen)) topenrBoundary - genState action = case action of - Left (ActionDouble (_, unfrozen, _, _, _) op) -> - SSSemiOpen rstFrozen sfrozen (Path unfrozen midSlice open) (LMDouble op : ops) - Right (ActionSingle (_, parent, _) op) -> - SSSemiOpen frozen midSlice (PathEnd parent) (LMSingle op : ops) - - -- More than two open transitions - Path topenl sopenl (Path topenm@(Trans _ _ topenmBoundary) sopenr rstOpen) -> do - let doubleActions = - Right - <$> collectDoubles - (Inner $ sWContent midSlice) -- E C C G - topenl -- boundary - (sWContent sopenl) -- D C Bb F# - topenm -- no boundary - (sWContent sopenr) -- D C A F# - (BF.second sWContent rstOpen) - in case frozen of - PathEnd tfrozen -> do - -- lift $ putStrLn "2+ Open Transitions, 1 frozen transition Left: \n" - pure $ genState <$> (doubleActions <> unfreezeActions) - where - unfreezeActions = - Left <$> collectUnfreezeLeft Start tfrozen (sWContent midSlice) topenl (Inner $ sWContent sopenl) topenmBoundary - - genState action = case action of - Left (ActionDouble (_, unfrozen, _, _, _) op) -> - SSOpen (Path unfrozen midSlice open) (LMDouble op : ops) - Right (ActionDouble (_, topl, tops, topr, _) op) -> - SSSemiOpen frozen midSlice (Path topl (wrapSlice wrap tops) (pathSetHead rstOpen topr)) (LMDouble op : ops) - Path tfrozen sfrozen rstFrozen -> do - -- lift $ putStrLn "2+ Open Transitions, 1+ frozen transition left:\n" - pure $ genState <$> (doubleActions <> unfreezeActions) - where - unfreezeActions = - Left <$> collectUnfreezeLeft Start tfrozen (sWContent midSlice) topenl (Inner $ sWContent sopenl) topenmBoundary - - genState action = case action of - Left (ActionDouble (_, unfrozen, _, _, _) op) -> - SSSemiOpen rstFrozen sfrozen (Path unfrozen midSlice open) (LMDouble op : ops) - Right (ActionDouble (_, topl, tops, topr, _) op) -> - SSSemiOpen frozen midSlice (Path topl (wrapSlice wrap tops) (pathSetHead rstOpen topr)) (LMDouble op : ops) - where - collectUnfreezeSingle - :: StartStop ns - -> (Maybe es', Boundary) - -> StartStop ns - -> IsLast - -> [ActionSingle ns es s f] - collectUnfreezeSingle sl (t, boundary) sr isLast = - mapMaybe - getAction - (evalUnfreeze eval sl t sr isLast) - where - getAction (t', op) = case op of - LMSingle sop -> Just $ ActionSingle (sl, Trans t' False boundary, sr) sop - LMDouble _ -> Nothing - - collectUnfreezeLeft - :: StartStop ns - -> (Maybe es', Boundary) - -> ns - -> Trans es - -> StartStop ns - -> Boundary - -> [ActionDouble ns es s f h] - collectUnfreezeLeft sFrozen (tFrozen, frozenBoundary) sl (Trans tl _ tlBoundary) sr trBoundary - | allowUnfreeze frozenBoundary tlBoundary trBoundary = - mapMaybe - getAction - (evalUnfreeze eval sFrozen tFrozen (Inner sl) False) - | otherwise = [] - where - getAction (thawed, op) = case op of - LMDouble dop -> - Just $ ActionDouble (sFrozen, Trans thawed False frozenBoundary, sl, Trans tl False tlBoundary, sr) dop - LMSingle _ -> Nothing - - collectUnsplitSingle - :: ( StartStop ns - -> Trans es - -> ns - -> Trans es - -> StartStop ns - -> [ActionSingle ns es s f] - ) - collectUnsplitSingle sl (Trans tl _ tlBoundary) sm (Trans tr _ trBoundary) sr - | tlBoundary && trBoundary = [] - | otherwise = - mapMaybe getAction $ evalUnsplit eval sl tl sm tr sr SingleOfOne - where - getAction (ttop, op) = - case op of - LMSingle sop -> Just $ ActionSingle (sl, Trans ttop False (tlBoundary || trBoundary), sr) sop - LMDouble _ -> Nothing - - collectUnsplitLeft - :: ( StartStop ns - -> Trans es - -> ns - -> Trans es - -> ns - -> Trans es - -> StartStop ns - -> [ActionDouble ns es s f h] - ) - collectUnsplitLeft sstart (Trans tl _ tlBoundary) sl (Trans tm _ tmBoundary) sr tr send - | tlBoundary && tmBoundary = [] - | otherwise = - mapMaybe getAction $ - evalUnsplit eval sstart tl sl tm (Inner sr) LeftOfTwo - where - getAction (ttop, op) = - case op of - LMSingle _ -> Nothing - LMDouble dop -> - Just $ - ActionDouble - (sstart, Trans ttop False (tlBoundary || tmBoundary), sr, tr, send) - dop - - collectUnsplitRight - :: ( StartStop ns - -> Trans es - -> ns - -> Trans es - -> ns - -> Trans es - -> StartStop ns - -> [ActionDouble ns es s f h] - ) - collectUnsplitRight sstart tl sl (Trans tm m2nd tmBoundary) sr (Trans tr _ trBoundary) send - | not m2nd = [] - | tmBoundary && trBoundary = [] - | otherwise = - mapMaybe getAction $ - evalUnsplit eval (Inner sl) tm sr tr send RightOfTwo - where - getAction (ttop, op) = case op of - LMSingle _ -> Nothing - LMDouble dop -> - Just $ ActionDouble (sstart, tl, sl, Trans ttop True (tmBoundary || trBoundary), send) dop - - collectUnspreads - :: ( StartStop ns - -> Trans es - -> ns - -> Trans es - -> ns - -> Trans es - -> StartStop ns - -> [ActionDouble ns es s f h] - ) - collectUnspreads sstart (Trans tl _ tlBoundary) sl (Trans tm _ tmBoundary) sr (Trans tr _ trBoundary) send - | tmBoundary = [] - | otherwise = catMaybes $ do - (sTop, op) <- maybeToList $ evalUnspreadMiddle eval (sl, tm, sr) - lTop <- evalUnspreadLeft eval (tl, sl) sTop - rTop <- evalUnspreadRight eval (sr, tr) sTop - pure $ getAction lTop sTop rTop op - where - -- pure $ getAction $ evalUnsplit eval (Inner sl) tm sr tr send RightOfTwo - getAction lTop sTop rTop op = case op of - LMSingle _ -> Nothing - LMDouble dop -> - Just $ - ActionDouble - (sstart, Trans lTop False tlBoundary, sTop, Trans rTop True trBoundary, send) - dop - - collectDoubles sstart tl@(Trans _ _ tlBoundary) sl tm@(Trans _ _ tmBoundary) sr rst = leftUnsplits <> rightUnsplits <> unspreads - where - (tr@(Trans _ _ trBoundary), send) = case rst of - PathEnd t -> (t, Stop) - Path t s _ -> (t, Inner s) - leftUnsplits = collectUnsplitLeft sstart tl sl tm sr tr send - rightUnsplits = collectUnsplitRight sstart tl sl tm sr tr send - unspreads = collectUnspreads sstart tl sl tm sr tr send - - -- \| Defines if an unfreeze is allowed given the boundaries of the frozen transition, and of the nearest two neighboring transistions - -- > ...=[]—f—[]—l—[]—r-... - -- - allowUnfreeze - :: Bool -> Bool -> Bool -> Bool - allowUnfreeze frozenBoundary lBoundary rBoundary = - rBoundary || not (lBoundary || frozenBoundary) - -printPathFromState - :: (Show es, Show ns) - => SearchState es es' ns o - -> String -printPathFromState s = maybe "" show (getPathFromState s) - --- | Returns a list of all operations that have been taken up to the state given -getOpsFromState - :: SearchState es es' ns o - -> [o] -getOpsFromState s = case s of - SSOpen p d -> d - SSSemiOpen p m f d -> d - SSFrozen p -> [] - --- | Returns the latest operation that has been applied, or Nothing if no operations have been applied -getOpFromState - :: SearchState es es' ns o - -> Maybe o -getOpFromState s = case s of - SSOpen p (d : _) -> Just d - SSSemiOpen p m f (d : _) -> Just d - SSFrozen p -> Nothing - -getPathLengthFromState - :: SearchState es es' ns o - -> Int -getPathLengthFromState (SSOpen p d) = pathLen p -getPathLengthFromState (SSSemiOpen p m f d) = pathLen f + pathLen p -getPathLengthFromState (SSFrozen p) = pathLen p - -getSlicesFromState - :: SearchState es es' ns o - -> Maybe [SliceWrapped ns] -getSlicesFromState s = case s of - SSOpen p d -> Just $ pathBetweens p - SSSemiOpen p m f d -> Just $ [m] <> pathBetweens f - SSFrozen p -> Nothing - where - transformPath - :: Path (Trans es) (SliceWrapped ns) - -> Path es ns - transformPath (PathEnd t) = PathEnd (tContent t) - transformPath (Path t s rst) = Path (tContent t) (sWContent s) $ transformPath rst - -getPathFromState - :: SearchState es es' ns o - -> Maybe (Path es ns) -getPathFromState s = case s of - SSOpen p d -> Just $ transformPath p - SSSemiOpen p m f d -> Just $ transformPath f - SSFrozen p -> Nothing - where - transformPath - :: Path (Trans es) (SliceWrapped ns) - -> Path es ns - transformPath (PathEnd t) = PathEnd (tContent t) - transformPath (Path t s rst) = Path (tContent t) (sWContent s) $ transformPath rst - --- Get path from state, keeping chord label information -getPathFromState' - :: SearchState es es' ns o - -> Maybe (Path es (SliceWrapped ns)) -getPathFromState' s = case s of - SSOpen p d -> Just $ transformPath p - SSSemiOpen p m f d -> Just $ transformPath f - SSFrozen p -> Nothing - where - transformPath - :: Path (Trans es) (SliceWrapped ns) - -> Path es (SliceWrapped ns) - transformPath (PathEnd t) = PathEnd (tContent t) - transformPath (Path t s rst) = Path (tContent t) s $ transformPath rst - --- * Parsing Actions - -{- | A parsing action (reduction step) with a single parent transition. - Combines the parent elements with a single-transition derivation operation. --} -data ActionSingle ns tr s f - = ActionSingle - (StartStop ns, Trans tr, StartStop ns) - -- ^ parent transition (and adjacent slices) - (LeftmostSingle s f) - -- ^ single-transition operation - deriving (Show) - -{- | A parsing action (reduction step) with two parent transitions. - Combines the parent elements with a double-transition derivation operation. --} -data ActionDouble ns tr s f h - = ActionDouble - ( StartStop ns - , Trans tr - , ns - , Trans tr - , StartStop ns - ) - -- ^ parent transitions and slice - (LeftmostDouble s f h) - -- ^ double-transition operation - deriving (Show) - --- HELPER FUNCTIONS -showOp [] = "" -showOp (x : _) = case x of - LMDouble y -> show y - LMSingle y -> show y - --- | Returns 'True' if the parse is complete, and has been reduced to only one slice -goalTestSBS (SSOpen p _) | pathLen p == 2 = True -goalTestSBS _ = False - --- | Returns 'True' if the parse is complete and has been reduced to only one slice per segment -goalTest :: [ChordLabel] -> SearchState es es' ns o -> Bool -goalTest chordLabels (SSOpen p _) = pathLen p - 1 == length chordLabels -goalTest chordlabels _ = False - --- | Goal test for a search: Only complete once there is a single slice per segment -heursiticSearchGoalTest - :: SearchState es es' ns o - -> Bool -heursiticSearchGoalTest s = case s of - SSSemiOpen{} -> False - SSFrozen{} -> False - SSOpen p _ -> oneChordPerSegment p - where - oneChordPerSegment :: Path (Trans es) (SliceWrapped ns) -> Bool - oneChordPerSegment (PathEnd _) = True - oneChordPerSegment (Path tl _ rst) = tBoundary tl && oneChordPerSegment rst - --- | Returns a 'SliceWrapper' that guesses the most likely chord for a slice -sliceWrapper :: SliceWrapper (Notes SPitch) -sliceWrapper = SliceWrapper $ \ns -> let (l, p) = mostLikelyLabelFromSliceWithProb ns in SliceWrapped ns l p - --- | Returns the most likely chord labels for each input group of notes -guessChords :: [Notes SPitch] -> [ChordLabel] -guessChords slices = sLbl <$> (wrapSlice (SliceWrapper $ \ns -> let (l, p) = mostLikelyLabelFromSliceWithProb ns in SliceWrapped ns l p) <$> slices) - --- | Calculate a naive accuracy metric for two lists using equality -chordAccuracy :: (Eq a, Show a) => [a] -> [a] -> Double -chordAccuracy guesses truth = fromIntegral (numMatches guesses truth) / fromIntegral (length truth) - where - numMatches [] [] = 0 - numMatches (x : xs) (y : ys) - | x == y = 1 + numMatches xs ys - | otherwise = numMatches xs ys - numMatches _ _ = error $ show guesses <> show truth - -exploreStates' - :: forall es es' ns ns' s f h - . (Show s, Show f, Show h, Show es, Show es', Show ns, Show ns') - => SliceWrapper ns - -> EvalImpure es es' ns ns' (Leftmost s f h) - -> SearchState es es' ns (Leftmost s f h) - -> ExceptT String IO [SearchState es es' ns (Leftmost s f h)] - -- ^ Either a error message or a list of possible next states -exploreStates' wrap eval'@(EvalImpure eval evalUnsplitRandom) state = do - -- lift $ putStrLn "_________________________________________________________" - -- lift $ putStrLn $ "\n Exploring state: " <> show state <> "\n" - case state of - SSFrozen frozen -> case frozen of - -- Only one trasition: we unfreeze and terminate - PathEnd t -> do - -- lift $ putStrLn "1 frozen transition: " - pure $ genState <$> actions - where - actions = collectUnfreezeSingle Start t Stop True - genState (ActionSingle (sl, top, sr) op) = SSOpen (PathEnd top) [LMSingle op] - -- Multiple transitions: unfreeze first and continue - Path t slice rest -> do - -- lift $ putStrLn "1+ frozen transitions only:" - pure $ genState <$> actions - where - actions = collectUnfreezeSingle Start t (Inner $ sWContent slice) True - genState (ActionSingle (sl, top, sr) op) = SSSemiOpen rest slice (PathEnd top) [LMSingle op] - - -- Case: Every transition is unfrozen - SSOpen open ops -> reductions - where - reductions = case open of - -- A single transition - No operations - PathEnd _ -> do - -- lift $ putStrLn "0 Frozen, 1 open: No operations\n" - pure [] - -- Two open transitions: unsplit single - Path tl slice (PathEnd tr) -> do - -- lift $ putStrLn "2 open transitions only: \n" - actions <- lift $ collectUnsplitSingle Start tl (sWContent slice) tr Stop - pure $ genState <$> actions - where - genState (ActionSingle (sl, top, sr) op) = - SSOpen (PathEnd top) (LMSingle op : ops) - - -- Three open transitions: unsplitLeft, unsplitRight, or unspread (double ops) - Path tl sl (Path tm sr rst) -> do - -- lift $ putStrLn "3+ Open transitions:" - pure $ genState <$> actions - where - actions = collectDoubles Start tl (sWContent sl) tm (sWContent sr) (BF.second sWContent rst) - genState (ActionDouble (_, topl, tops, topr, _) op) = - SSOpen (Path topl (wrapSlice wrap tops) (pathSetHead rst topr)) (LMDouble op : ops) - - -- Mid Parse - -- - SSSemiOpen frozen midSlice open ops -> - let frozenBoundary = snd $ pathHead frozen - in case open of - -- Only one open transition: unfreeze - PathEnd topen -> case frozen of - PathEnd tfrozen -> do - -- lift $ putStrLn "1 Open Transition, 1 frozen transition: \n" - pure $ genState <$> actions - where - actions = collectUnfreezeLeft Start tfrozen (sWContent midSlice) topen Stop True - genState (ActionDouble (sl, tl, slice, tr, st) op) = - SSOpen - (Path tl (wrapSlice wrap slice) (PathEnd tr)) - (LMDouble op : ops) - Path tfrozen sfrozen rstFrozen -> do - -- lift $ putStrLn "1 Open Transition, 1+ frozen transition: \n" - pure $ genState <$> actions - where - actions = collectUnfreezeLeft (Inner $ sWContent sfrozen) tfrozen (sWContent midSlice) topen Stop True - genState (ActionDouble (sl, tl, slice, tr, st) op) = - SSSemiOpen rstFrozen sfrozen (Path tl midSlice open) (LMDouble op : ops) - - -- Two Open transitions: unfreeze or unsplit single - Path topenl sopen (PathEnd topenr@(Trans _ _ topenrBoundary)) -> do - unsplitActions' <- lift $ collectUnsplitSingle (Inner $ sWContent midSlice) topenl (sWContent sopen) topenr Stop - let unsplitActions = Right <$> unsplitActions' - case frozen of - PathEnd tfrozen -> do - -- lift $ putStrLn "2 Open Transitions, 1 frozen transition: \n" - pure $ genState <$> (unfreezeActions <> unsplitActions) - where - unfreezeActions = - Left - <$> collectUnfreezeLeft Start tfrozen (sWContent midSlice) topenl Stop topenrBoundary - - genState action = case action of - Left (ActionDouble (_, unfrozen, _, _, _) op) -> - SSOpen (Path unfrozen midSlice open) (LMDouble op : ops) - Right (ActionSingle (parentL, parent, parentR) op) -> - SSSemiOpen frozen midSlice (PathEnd parent) (LMSingle op : ops) -- change midSlice? - Path tfrozen sfrozen rstFrozen -> do - -- lift $ putStrLn "2 Open Transitions, 1+ frozen transitions: \n" - pure $ genState <$> (unfreezeActions <> unsplitActions) - where - unfreezeActions = - Left - <$> collectUnfreezeLeft (Inner $ sWContent sfrozen) tfrozen (sWContent midSlice) topenl (Inner (sWContent sopen)) topenrBoundary - genState action = case action of - Left (ActionDouble (_, unfrozen, _, _, _) op) -> - SSSemiOpen rstFrozen sfrozen (Path unfrozen midSlice open) (LMDouble op : ops) - Right (ActionSingle (_, parent, _) op) -> - SSSemiOpen frozen midSlice (PathEnd parent) (LMSingle op : ops) - - -- More than two open transitions - Path topenl sopenl (Path topenm@(Trans _ _ topenmBoundary) sopenr rstOpen) -> do - let doubleActions = - Right - <$> collectDoubles - (Inner $ sWContent midSlice) -- E C C G - topenl -- boundary - (sWContent sopenl) -- D C Bb F# - topenm -- no boundary - (sWContent sopenr) -- D C A F# - (BF.second sWContent rstOpen) - in case frozen of - PathEnd tfrozen -> do - -- lift $ putStrLn "2+ Open Transitions, 1 frozen transition Left: \n" - pure $ genState <$> (doubleActions <> unfreezeActions) - where - unfreezeActions = - Left <$> collectUnfreezeLeft Start tfrozen (sWContent midSlice) topenl (Inner $ sWContent sopenl) topenmBoundary - - genState action = case action of - Left (ActionDouble (_, unfrozen, _, _, _) op) -> - SSOpen (Path unfrozen midSlice open) (LMDouble op : ops) - Right (ActionDouble (_, topl, tops, topr, _) op) -> - SSSemiOpen frozen midSlice (Path topl (wrapSlice wrap tops) (pathSetHead rstOpen topr)) (LMDouble op : ops) - Path tfrozen sfrozen rstFrozen -> do - -- lift $ putStrLn "2+ Open Transitions, 1+ frozen transition left:\n" - pure $ genState <$> (doubleActions <> unfreezeActions) - where - unfreezeActions = - Left <$> collectUnfreezeLeft Start tfrozen (sWContent midSlice) topenl (Inner $ sWContent sopenl) topenmBoundary - - genState action = case action of - Left (ActionDouble (_, unfrozen, _, _, _) op) -> - SSSemiOpen rstFrozen sfrozen (Path unfrozen midSlice open) (LMDouble op : ops) - Right (ActionDouble (_, topl, tops, topr, _) op) -> - SSSemiOpen frozen midSlice (Path topl (wrapSlice wrap tops) (pathSetHead rstOpen topr)) (LMDouble op : ops) - where - collectUnfreezeSingle - :: StartStop ns - -> (Maybe es', Boundary) - -> StartStop ns - -> IsLast - -> [ActionSingle ns es s f] - collectUnfreezeSingle sl (t, boundary) sr isLast = - mapMaybe - getAction - (evalUnfreeze eval sl t sr isLast) - where - getAction (t', op) = case op of - LMSingle sop -> Just $ ActionSingle (sl, Trans t' False boundary, sr) sop - LMDouble _ -> Nothing - - collectUnfreezeLeft - :: StartStop ns - -> (Maybe es', Boundary) - -> ns - -> Trans es - -> StartStop ns - -> Boundary - -> [ActionDouble ns es s f h] - collectUnfreezeLeft sFrozen (tFrozen, frozenBoundary) sl (Trans tl _ tlBoundary) sr trBoundary - | allowUnfreeze frozenBoundary tlBoundary trBoundary = - mapMaybe - getAction - (evalUnfreeze eval sFrozen tFrozen (Inner sl) False) - | otherwise = [] - where - getAction (thawed, op) = case op of - LMDouble dop -> - Just $ ActionDouble (sFrozen, Trans thawed False frozenBoundary, sl, Trans tl False tlBoundary, sr) dop - LMSingle _ -> Nothing - - collectUnsplitSingle - :: ( StartStop ns - -> Trans es - -> ns - -> Trans es - -> StartStop ns - -> IO [ActionSingle ns es s f] - ) - collectUnsplitSingle sl (Trans tl _ tlBoundary) sm (Trans tr _ trBoundary) sr - | tlBoundary && trBoundary = pure [] - | otherwise = do - unsplits <- evalUnsplitRandom sl tl sm tr sr SingleOfOne - pure $ mapMaybe getAction unsplits - where - getAction (ttop, op) = - case op of - LMSingle sop -> Just $ ActionSingle (sl, Trans ttop False (tlBoundary || trBoundary), sr) sop - LMDouble _ -> Nothing - - collectUnsplitLeft - :: ( StartStop ns - -> Trans es - -> ns - -> Trans es - -> ns - -> Trans es - -> StartStop ns - -> [ActionDouble ns es s f h] - ) - collectUnsplitLeft sstart (Trans tl _ tlBoundary) sl (Trans tm _ tmBoundary) sr tr send - | tlBoundary && tmBoundary = [] - | otherwise = - mapMaybe getAction $ - evalUnsplit eval sstart tl sl tm (Inner sr) LeftOfTwo - where - getAction (ttop, op) = - case op of - LMSingle _ -> Nothing - LMDouble dop -> - Just $ - ActionDouble - (sstart, Trans ttop False (tlBoundary || tmBoundary), sr, tr, send) - dop - - collectUnsplitRight - :: ( StartStop ns - -> Trans es - -> ns - -> Trans es - -> ns - -> Trans es - -> StartStop ns - -> [ActionDouble ns es s f h] - ) - collectUnsplitRight sstart tl sl (Trans tm m2nd tmBoundary) sr (Trans tr _ trBoundary) send - | not m2nd = [] - | tmBoundary && trBoundary = [] - | otherwise = - mapMaybe getAction $ - evalUnsplit eval (Inner sl) tm sr tr send RightOfTwo - where - getAction (ttop, op) = case op of - LMSingle _ -> Nothing - LMDouble dop -> - Just $ ActionDouble (sstart, tl, sl, Trans ttop True (tmBoundary || trBoundary), send) dop - - collectUnspreads - :: ( StartStop ns - -> Trans es - -> ns - -> Trans es - -> ns - -> Trans es - -> StartStop ns - -> [ActionDouble ns es s f h] - ) - collectUnspreads sstart (Trans tl _ tlBoundary) sl (Trans tm _ tmBoundary) sr (Trans tr _ trBoundary) send - | tmBoundary = [] - | otherwise = catMaybes $ do - (sTop, op) <- maybeToList $ evalUnspreadMiddle eval (sl, tm, sr) - lTop <- evalUnspreadLeft eval (tl, sl) sTop - rTop <- evalUnspreadRight eval (sr, tr) sTop - pure $ getAction lTop sTop rTop op - where - -- pure $ getAction $ evalUnsplit eval (Inner sl) tm sr tr send RightOfTwo - getAction lTop sTop rTop op = case op of - LMSingle _ -> Nothing - LMDouble dop -> - Just $ - ActionDouble - (sstart, Trans lTop False tlBoundary, sTop, Trans rTop True trBoundary, send) - dop - - collectDoubles sstart tl@(Trans _ _ tlBoundary) sl tm@(Trans _ _ tmBoundary) sr rst = leftUnsplits <> rightUnsplits <> unspreads - where - (tr@(Trans _ _ trBoundary), send) = case rst of - PathEnd t -> (t, Stop) - Path t s _ -> (t, Inner s) - leftUnsplits = collectUnsplitLeft sstart tl sl tm sr tr send - rightUnsplits = collectUnsplitRight sstart tl sl tm sr tr send - unspreads = collectUnspreads sstart tl sl tm sr tr send - - -- \| Defines if an unfreeze is allowed given the boundaries of the frozen transition, and of the nearest two neighboring transistions - -- > ...=[]—f—[]—l—[]—r-... - -- - allowUnfreeze - :: Bool -> Bool -> Bool -> Bool - allowUnfreeze frozenBoundary lBoundary rBoundary = - rBoundary || not (lBoundary || frozenBoundary) - diff --git a/src/Heuristics.hs b/src/Heuristics.hs index 6f69d6144..b3ea91c0f 100644 --- a/src/Heuristics.hs +++ b/src/Heuristics.hs @@ -34,7 +34,7 @@ import Data.Vector qualified as V import Musicology.Core qualified as Music import Musicology.Pitch.Spelled -import HeuristicParser +import Parser.HeuristicParser import Harmony import Harmony.ChordLabel import Harmony.Params @@ -44,9 +44,6 @@ import Musicology.Pitch.Class (transpose) type State ns = SearchState (Edges ns) [Edge ns] (Notes ns) (PVLeftmost ns) --- alpha = 1.3 -- Child not weighting - lower means children are cared about less ---splitWeight = 1.4 -- Extra costs for splits - applyHeuristic :: ((State SPitch, State SPitch) -> ExceptT String IO Double) -> ( State SPitch, State SPitch) @@ -161,8 +158,6 @@ heuristicZero alpha splitWeight (prevState, state) = case getOpFromState state o scoreParent mps v = do multinomialLogProb (notesVector v) <$> mps - - scoreChildren :: [(SPitch, DoubleOrnament)] -> [(SPitch, PassingOrnament)] @@ -192,8 +187,6 @@ heuristicZero alpha splitWeight (prevState, state) = case getOpFromState state o maybeToList $ categoricalLogProb (fifths n) res - - -- Need to find all the parent on the left of the child slice -- And all the parents form the right of the child slice scoreSplit @@ -229,7 +222,7 @@ heuristicZero alpha splitWeight (prevState, state) = case getOpFromState state o (Notes $ MS.fromList rightParents) slcL slcR childFactor = scoreChildren childRegs childPasses childFromLefts childFromRights slcL slcR - score = - (childFactor*alpha + parentFactor)*(splitWeight) -- parentFactor bug + score = - (childFactor*alpha + parentFactor) -- *(defaultUnsplitBias) -- parentFactor bug in score @@ -382,11 +375,6 @@ heuristicZero alpha splitWeight (prevState, state) = case getOpFromState state o startStopToMaybe (Inner a) = Just a - -- pure - -- (parent, children) <- M.toList regSet - -- child <- children - -- pure (parent, child) - allPassings ornamentSet = do (parent, children) <- M.toList ornamentSet child <- children