refactor: Move Parsers to /Parser/

judah-daniels · Apr 2, 2024 · 8c0fe99 · 8c0fe99
1 parent d7b7133
commit 8c0fe99
Show file tree

Hide file tree

Showing 13 changed files with 64 additions and 2,663 deletions.
diff --git a/.DS_Store b/.DS_Store
diff --git a/.gitignore b/.gitignore
@@ -6,6 +6,7 @@ fourmolu.yaml
 .venv
 testdata/.mscbackup/
 .DS_Store
+*.json
 *.lock
 __pycache__
 preprocessing/inputs/*

diff --git a/app/MainFullParse.hs b/app/MainFullParse.hs
@@ -19,7 +19,7 @@ import Algorithm
 import PVGrammar.Parse (protoVoiceEvaluator, protoVoiceEvaluatorImpure, protoVoiceEvaluatorLimitedSize)
 import qualified Algorithm as Core
 import Control.Monad (replicateM)
-import HeuristicParser (chordAccuracy)
+import Parser.HeuristicParser (chordAccuracy, guessChords)
 import Harmony
 import Harmony.ChordLabel
 import Harmony.Params
@@ -135,21 +135,33 @@ main = Log.withStderrLogging $ do
       case mTimedRes of
         Nothing -> 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
@@ -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
@@ -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
@@ -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
@@ -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