diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2020, Orestis Melkonian +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,367 @@ +import Control.Monad (when, forM) + +import Data.List ((\\), nub, isInfixOf) +import Data.Semigroup ((<>)) + +import Options.Applicative + +import Types +import Parser +import Analysis +import Render + +-- | Command-line options. +data Options = Options { experts :: Bool -- ^ analyse expert dataset + , algorithms :: Bool -- ^ analyse algorithm dataset + + , vm1 :: Bool -- ^ analyse algorithm dataset: VM1 + , vm2 :: Bool -- ^ analyse algorithm dataset: VM2 + , mp :: Bool -- ^ analyse algorithm dataset: MP + , siacf1 :: Bool -- ^ analyse algorithm dataset: SIAF1 + , siacp :: Bool -- ^ analyse algorithm dataset: SIACP + , siacr :: Bool -- ^ analyse algorithm dataset: SIACR + , cosia :: Bool + , cfp :: Bool + + , siacf1d :: Bool + , siacpd :: Bool + , siacrd :: Bool + + , classical :: Bool -- ^ analyze classical dataset + , folk :: Bool -- ^ analyze dutch folk dataset + , heman :: Bool + , eurovision :: Bool + , jazz :: Bool + , random :: Bool -- ^ analyze random datasets + , export :: Bool -- ^ export MIDI files + , verify :: Bool -- ^ whether to verify hypothesis + , toCompare :: Bool -- ^ run cross-dataset comparison + , toPrint :: Bool -- ^ whether to print results + } + +-- | Parsing command-line options. +parseOpts :: Parser Options +parseOpts = Options + <$> switch ( long "experts" + <> short 'E' + <> help "Analyze the expert dataset" ) + <*> switch ( long "algorithms" + <> short 'A' + <> help "Analyze the algorithm dataset" ) + + <*> switch ( long "vm1" + <> short '1' + <> help "Analyze the algorithm dataset: VM1" ) + <*> switch ( long "vm2" + <> short '2' + <> help "Analyze the algorithm dataset: VM2" ) + <*> switch ( long "mp" + <> short '3' + <> help "Analyze the algorithm dataset: MP" ) + <*> switch ( long "siacf1" + <> short '4' + <> help "Analyze the algorithm dataset: SIATECCompressF1" ) + <*> switch ( long "siacp" + <> short '5' + <> help "Analyze the algorithm dataset: SIATECCompressP" ) + <*> switch ( long "siacr" + <> short '6' + <> help "Analyze the algorithm dataset: SIATECCompressR" ) + <*> switch ( long "cosia" + <> short '7' + <> help "Analyze the algorithm dataset: COSIA" ) + <*> switch ( long "cfp" + <> short '8' + <> help "Analyze the algorithm dataset: CFP" ) + <*> switch ( long "siacf1d" + <> short '9' + <> help "Analyze the algorithm dataset: SIACCompressF1 -d" ) + <*> switch ( long "siacpd" + <> short 'q' + <> help "Analyze the algorithm dataset: SIACCompressP -d" ) + <*> switch ( long "siacrd" + <> short 'w' + <> help "Analyze the algorithm dataset: SIACCompressR -d" ) + + <*> switch ( long "classical" + <> short 'C' + <> help "Analyze the classical dataset" ) + <*> switch ( long "folk" + <> short 'F' + <> help "Analyze the dutch folk dataset" ) + <*> switch ( long "heman" + <> short 'H' + <> help "Analyze the HEMAN dataset" ) + <*> switch ( long "eurovision" + <> short 'o' + <> help "Analyze the eurovision dataset" ) + <*> switch ( long "jazz" + <> short 'j' + <> help "Analyze the Omnibook from Klaus jazz dataset" ) + <*> switch ( long "random" + <> short 'R' + <> help "Analyze the random datasets" ) + <*> switch ( long "export" + <> short 'X' + <> help "Export MIDI files" ) + <*> switch ( long "verify" + <> short 'V' + <> help "Verify equivalence-class hypothesis" ) + <*> switch ( long "compare" + <> short 'M' + <> help "Compare expert annotations and algorithmic output" ) + <*> switch ( long "print" + <> short 'P' + <> help "Whether to print results in the terminal." ) + +-- | Which kind of analysis to run? +currentAnalysis :: Analysis +currentAnalysis = fullAnalysis + +analysePg :: PatternGroup -> IO AnalysisResult +analysePg = return . analysePatternGroup currentAnalysis + +printAn :: Bool -> AnalysisResult -> IO () +printAn toP an = if toP then print (currentAnalysis, an) else putStr "." + +writeCSV :: String -> Bool -> [AnalysisResult] -> IO () +writeCSV fname expo as = dumpAnalyses fname expo currentAnalysis as + +-- | Main function. +main :: IO () +main = do + op <- execParser opts + let run = runAnalysis (export op, verify op, toPrint op) + when (classical op) $ do + when (experts op) $ + run "docs/out/classical/experts" parseClassicExperts + when (algorithms op) $ + run "docs/out/classical/algorithms" parseClassicAlgo + when (vm1 op) $ + run "docs/out/classical/vm1" parseClassicAlgoVM1 + when (vm2 op) $ + run "docs/out/classical/vm2" parseClassicAlgoVM2 + when (mp op) $ + run "docs/out/classical/mp" parseClassicAlgoMP + when (siacf1 op) $ + run "docs/out/classical/siacf1" parseClassicAlgoSIACF1 + when (siacp op) $ + run "docs/out/classical/siacp" parseClassicAlgoSIACP + when (siacr op) $ + run "docs/out/classical/siacr" parseClassicAlgoSIACR + when (toCompare op) $ + runComparison (export op, toPrint op) + ("docs/out/classical/experts", parseClassicExperts) + ("docs/out/classical/algorithms", parseClassicAlgo) + + when (folk op) $ do + when (experts op) $ + run "docs/out/folk/experts" parseFolkExperts + when (algorithms op) $ + run "docs/out/folk/algorithms" parseFolkAlgo + when (vm1 op) $ + run "docs/out/folk/vm1" parseFolkAlgoVM1 + when (vm2 op) $ + run "docs/out/folk/vm2" parseFolkAlgoVM2 + when (mp op) $ + run "docs/out/folk/mp" parseFolkAlgoMP + when (siacf1 op) $ + run "docs/out/folk/siacf1" parseFolkAlgoSIACF1 + when (siacp op) $ + run "docs/out/folk/siacp" parseFolkAlgoSIACP + when (siacr op) $ + run "docs/out/folk/siacr" parseFolkAlgoSIACR + when (cfp op) $ + run "docs/out/folk/cfp" parseFolkAlgoSIACFP + when (cosia op) $ + run "docs/out/folk/cosia" parseFolkAlgoCOSIA + + when (heman op) $ do + when (experts op) $ + run "docs/out/heman/annotations" parseHEMANAnnotations + when (siacf1 op) $ + run "docs/out/heman/siacf1" parseHEMANAlgoSIACF1 + when (siacp op) $ + run "docs/out/heman/siacp" parseHEMANAlgoSIACP + when (siacr op) $ + run "docs/out/heman/siacr" parseHEMANAlgoSIACR + when (siacf1d op) $ + run "docs/out/heman/siacf1d" parseHEMANAlgoSIACF1D + when (siacpd op) $ + run "docs/out/heman/siacpd" parseHEMANAlgoSIACPD + when (siacrd op) $ + run "docs/out/heman/siacrd" parseHEMANAlgoSIACRD + + when (eurovision op) $ do + when (siacf1 op) $ + run "docs/out/eurovision/siacf1" parseEuroAlgoSIACF1 + when (siacp op) $ + run "docs/out/eurovision/siacp" parseEuroAlgoSIACP + when (siacr op) $ + run "docs/out/eurovision/siacr" parseEuroAlgoSIACR + when (siacf1d op) $ + run "docs/out/eurovision/siacf1d" parseEuroAlgoSIACF1D + when (siacpd op) $ + run "docs/out/eurovision/siacpd" parseEuroAlgoSIACPD + when (siacrd op) $ + run "docs/out/eurovision/siacrd" parseEuroAlgoSIACRD + + when (jazz op) $ do + when (siacf1 op) $ + run "docs/out/jazz/siacf1" parsejazzAlgoSIACF1 + when (siacp op) $ + run "docs/out/jazz/siacp" parsejazzAlgoSIACP + when (siacr op) $ + run "docs/out/jazz/siacr" parsejazzAlgoSIACR + when (siacf1d op) $ + run "docs/out/jazz/siacf1d" parsejazzAlgoSIACF1D + when (siacpd op) $ + run "docs/out/jazz/siacpd" parsejazzAlgoSIACPD + when (siacrd op) $ + run "docs/out/jazz/siacrd" parsejazzAlgoSIACRD + + when (toCompare op) $ do + runComparison (export op, toPrint op) + ("docs/out/folk/experts", parseFolkExperts) + ("docs/out/folk/algorithms", parseFolkAlgo) + + + when (random op) $ + run "docs/out/random" parseRandom + + where + opts :: ParserInfo Options + opts = info (parseOpts <**> helper) + ( fullDesc + <> progDesc "Run analysis on the MIREX dataset" + <> header "hs-mirex: a tool for music pattern discovery" + ) + +runComparison :: (Bool, Bool) + -> (FilePath, IO [PatternGroup]) -- ^ experts + -> (FilePath, IO [PatternGroup]) -- ^ algorithms + -> IO () +runComparison (expo, toP) (f_experts, parseExperts) (f_algo, parseAlgo) = do + -- parse expert annotations + putStrLn $ "Parsing " ++ f_experts ++ "..." + pgsE <- filter (not . null . patterns) <$> parseExperts + putStrLn "Parsed." + + -- parse algorithmic output + putStrLn $ "Parsing " ++ f_algo ++ "..." + pgsA <- filter (not . null . patterns) <$> parseAlgo + putStrLn "Parsed." + + let algs = nub (expert_name <$> pgsA) + let pieces = nub (piece_name <$> pgsA) + + -- for each song + pieceAnalyses' <- forM pieces $ \piece -> do + let pgsE' = filter ((== piece) . piece_name) pgsE + let expertPrs = basePattern <$> pgsE' + + -- for each algorithm + algAnalyses <- forM algs $ \alg -> do + let pgsA' = filter (\pg -> (piece_name pg == piece) + && (expert_name pg == alg )) pgsA + let algPrototypes = basePattern <$> pgsA' + + -- for each expert prototype + analyses <- forM expertPrs $ \expertPrototype -> do + -- create a pattern group for analysis + let pg = PatternGroup { piece_name = piece + , expert_name = alg + , pattern_name = "-" + , basePattern = expertPrototype + , patterns = algPrototypes + } + analysePg pg + + -- Aggregate results for a particular piece/alg (containing all expert prototypes) + let finalAn = (mconcat analyses) + {name = "ALL(" ++ piece ++ ":" ++ alg ++ ")"} + printAn toP finalAn + + -- Output in CSV format + let f_root = f_algo ++ "/" ++ piece ++ "/" ++ alg + cd f_root $ + writeCSV "comparison" expo (finalAn:analyses) + putStrLn $ "\t\tWrote " ++ f_root ++ "/comparison.csv" + return finalAn + + -- Aggregate results for a particular piece (containing all algorithms) + let allAlgAnalyses = (mconcat algAnalyses) + {name = "ALL(" ++ piece ++ ")"} + let f_root = f_algo ++ "/" ++ piece + cd f_root $ + writeCSV "comparison" expo [allAlgAnalyses] + putStrLn $ "\tWrote " ++ f_root ++ "/comparison.csv" + + return algAnalyses + + -- Aggregate results for a particular algorithm (containing all pieces) + let pieceAnalyses = concat pieceAnalyses' + algAnalyses <- forM algs $ \alg -> do + let algPieceAnalyses = filter (isInfixOf alg . name) pieceAnalyses + let algAn = (mconcat algPieceAnalyses) {name = "ALL(" ++ alg ++ ")"} + cd f_algo $ + writeCSV alg expo [algAn] + putStrLn $ "Wrote " ++ f_algo ++ "/" ++ alg + return algAn + + -- Aggregate all results (coming from piece aggregations) + cd f_algo $ + writeCSV "comparison" expo [(mconcat pieceAnalyses) {name = "ALL"}] + putStrLn $ "\tWrote " ++ f_algo ++ "/comparison.csv" + + -- Aggregate all results (coming from algorithm aggregations) + cd f_algo $ + writeCSV "comparisonA" expo [(mconcat algAnalyses) {name = "ALL"}] + putStrLn $ "\tWrote " ++ f_algo ++ "/comparisonA.csv" + +-- Analyse given music pattern dataset. +runAnalysis :: (Bool, Bool, Bool) -> FilePath -> IO [PatternGroup] -> IO () +runAnalysis (expo, ver, toP) f_root parser = do + -- Parse dataset to retrieve all pattern groups. + putStrLn $ "Parsing " ++ f_root ++ "..." + allPatternGroups <- filter (not . null . patterns) <$> parser + putStrLn "Parsed." + -- Analyse individual pattern groups. + cd f_root $ do + analyses <- + forM allPatternGroups $ \pg -> do + an <- analysePg pg + + -- putStrLn (name an) + printAn toP an -- display on terminal + + -- Verify (hope to be slow) + when ver $ do + let uns = snd <$> unclassified an + let tot = length uns + when (tot > 0) $ do + uns' <- verifyEquivClassHypothesis uns (patterns pg \\ uns) + putStrLn $ "Verified (" ++ show uns' ++ " / " ++ show tot ++ ")" + + renderOne currentAnalysis pg an -- produce pie chart + return an + + -- Combine all individual analyses and render in one chart. + let finalAn = (mconcat analyses) { name = "ALL" } + printAn toP finalAn + render currentAnalysis "ALL" finalAn + + -- Output in CSV format + writeCSV "output" expo (finalAn:analyses) + +-- | Verify the hypothesis that our transformations form equivalence classes. +-- This is done by trying out other patterns in the group as base patterns. +verifyEquivClassHypothesis :: [Pattern] -- ^ unclassified patterns + -> [Pattern] -- ^ possible bases + -> IO Int +verifyEquivClassHypothesis [] _ = return 0 +verifyEquivClassHypothesis uns [] = return (length uns) +verifyEquivClassHypothesis uns (base:bases) = do + an <- analysePg (PatternGroup "" "" "" base uns) + let uns' = snd <$> unclassified an + verifyEquivClassHypothesis uns' bases diff --git a/hs-pattrans.cabal b/hs-pattrans.cabal new file mode 100644 --- /dev/null +++ b/hs-pattrans.cabal @@ -0,0 +1,70 @@ +name : hs-pattrans +version : 0.1.0.1 +homepage : https://github.com/omelkonian/hs-pattrans +author : Orestis Melkonian +maintainer : Orestis Melkonian +category : Language +build-type : Simple +cabal-version : >= 1.10 +tested-with : GHC == 8.0.2 +license : BSD3 +license-file : LICENSE +synopsis : DSL for musical patterns and transformation, based on contravariant functors. +description : + A music DSL for defining pattern transformations, analyzing pattern datasets and detecting patterns. + +source-repository head + type: git + location: git://github.com/omelkonian/hs-pattrans.git + +library + hs-source-dirs: src + exposed-modules: Types, + Transformations, + Parser, + Analysis, + Render, + MIDI, + EuterpeaUtils, + Discovery + build-depends: base >= 4.8 && < 4.10 , + parsec >= 3.1.13, + directory >= 1.3.1.5, + Chart >= 1.8, + Chart-cairo, + colour >= 2.3.3, + contravariant, + containers, + Euterpea == 2.0.6, + HCodecs == 0.5.1, + bytestring == 0.10.8.1, + cassava == 0.4.5.1, + parallel == 3.2.1.1, + async + ghc-options: -Wall -fno-warn-type-defaults + default-language: Haskell2010 + +executable hs-pattrans + hs-source-dirs: app + main-is: Main.hs + build-depends: base, + hs-pattrans, + optparse-applicative == 0.13.2.0, + bytestring == 0.10.8.1 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + -fno-warn-type-defaults + default-language: Haskell2010 + +test-suite spec + hs-source-dirs: test + main-is: Spec.hs + other-modules: TransformationsSpec + build-depends: base, + hs-pattrans, + QuickCheck, + hspec + build-tool-depends: hspec-discover:hspec-discover + type: exitcode-stdio-1.0 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + -fno-warn-type-defaults + default-language: Haskell2010 diff --git a/src/Analysis.hs b/src/Analysis.hs new file mode 100644 --- /dev/null +++ b/src/Analysis.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE DeriveGeneric, FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Analysis where + +import GHC.Generics (Generic) + +import Data.Char (isDigit) +import Data.Foldable (msum) +import Data.List (sortBy, elemIndex) +import qualified Data.Map as M + +import Types +import Transformations + +type ApproxLevel = Float +type Analysis = ([(String, Float -> Check Pattern)], [ApproxLevel]) + +data AnalysisResult = AnalysisResult + { name :: String + , results :: M.Map String Int + , unclassified :: [(String, Pattern)] + } + deriving Generic + +total :: AnalysisResult -> Int +total an = sum $ length (unclassified an) : M.elems (results an) + +instance {-# OVERLAPPING #-} Show (String, ApproxLevel) where + show (fn, l) = fn ++ showApprox l + where + showApprox :: Float -> String + showApprox = shorten . show + where shorten ('0':'.':d:_) = ['0',d] + shorten ('1':'.':'0':_) = "1" + shorten _ = error "showApprox: invalid approximation level" + +-- | Combining analysis results. +(<+>) :: M.Map String Int -> M.Map String Int -> M.Map String Int +(<+>) = M.unionWith (+) + +instance Monoid AnalysisResult where + mempty = AnalysisResult + { name = "" + , results = M.empty + , unclassified = [] + } + mappend a a' = AnalysisResult + { name = name a ++ name a' + , results = results a <+> results a' + , unclassified = unclassified a ++ unclassified a' + } + +-- | An empty result includes map entries for all analyses. +emptyRes :: Analysis -> M.Map String Int +emptyRes (as, ls) = M.fromList $ map (\s -> (s, 0)) [show (fn, l) | l <- ls, (fn, _) <- as] + +-- | Analyse a single pattern. +analysePattern :: Analysis -> (Pattern, Pattern, String) -> AnalysisResult +analysePattern an@(analyses, approxLvls) (base, p, notFound) = + case msum [ go (show (fn, lvl)) (f lvl) + | lvl <- approxLvls + , (fn, f) <- analyses ] of + Nothing -> AnalysisResult "" (emptyRes an) [(notFound, p)] + Just res -> res + where + go :: String -> Check Pattern -> Maybe AnalysisResult + go s ch | (base <=> p) ch + = Just $ AnalysisResult "" (emptyRes an <+> M.singleton s 1) [] + | otherwise + = Nothing + +-- | Analyse a pattern group. +analysePatternGroup :: Analysis -> PatternGroup -> AnalysisResult +analysePatternGroup analysis pg@(PatternGroup _ _ _ base pats) + = (mconcat (map check (zip [2..] pats))) { name = show pg } + where + check (i, p) = analysePattern analysis (base, p, show pg ++ ":" ++ show i) + +-- | Get the results of an analysis, ordered by their occurence in its definition. +orderedResults :: Analysis -> AnalysisResult -> [(String, Int)] +orderedResults curAnalysis = + sortBy (\(s1,_) (s2,_) -> cmpAnalyses s1 s2) . M.toList . results + where + cmpAnalyses :: String -> String -> Ordering + cmpAnalyses s1 s2 = + case compare i i' of + EQ -> case compare (getIndex s) (getIndex s') of + EQ -> error "cmp: duplicate analyses" + o -> o + LT -> GT + GT -> LT + where + [(s, i),(s', i')] = break isDigit <$> [s1, s2] + ordAn = map fst $ fst curAnalysis + + getIndex :: String -> Int + getIndex x = case x `elemIndex` ordAn of + Just j -> j + Nothing -> length ordAn + +-------------------- +-- Example analyses + +fullAnalysis :: Analysis +fullAnalysis = + ( [ ("exact", (exactOf ~~)) + , ("transposed", (transpositionOf ~~)) + , ("tonalTransped", (tonalTranspOf ~~)) + , ("inverted", (inversionOf ~~)) + , ("augmented", (augmentationOf ~~)) + , ("retrograded", (retrogradeOf ~~)) + , ("rotated", (rotationOf ~~)) + , ("trInverted", (trInversionOf ~~)) + , ("trAugmented", (trAugmentationOf ~~)) + , ("trRetrograded", (trRetrogradeOf ~~)) + ] + , [1,0.8..0.2] + ) + +exactAnalysis :: Analysis +exactAnalysis = + ( [("exact", (exactOf ~~))] + , [1,0.8..0.2] ++ [0.1,0.05] + ) + +protoAnalysis :: Analysis +protoAnalysis = + ( [ ("inverted", (inversionOf ~~)) + , ("retrograded", (retrogradeOf ~~)) + , ("rotated", (rotationOf ~~)) + ] + , [1,0.8,0.6] + ) + +compoAnalysis :: Analysis +compoAnalysis = + ( [ ("exact", (exactOf ~~)) + , ("transposed", (transpositionOf ~~)) + , ("tonalTransped", (tonalTranspOf ~~)) + , ("inverted", (inversionOf ~~)) + , ("augmented", (augmentationOf ~~)) + , ("retrograded", (retrogradeOf ~~)) + , ("rotated", (rotationOf ~~)) + , ("trInverted", (trInversionOf ~~)) + , ("trAugmented", (trAugmentationOf ~~)) + , ("trRetrograded", (trRetrogradeOf ~~)) + , ("trtonAugmented", (trtonAugmentationOf ~~)) + , ("trtonRotated", (trtonRotationOf ~~)) + ] + , [1] + ) + +approx6Analysis :: Analysis +approx6Analysis = fmap (filter (>= 0.6)) fullAnalysis + diff --git a/src/Discovery.hs b/src/Discovery.hs new file mode 100644 --- /dev/null +++ b/src/Discovery.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE ExistentialQuantification, FlexibleInstances #-} +module Discovery where + +import Control.Monad (forM_) + +import Types +import Parser +import Transformations +import EuterpeaUtils +import MIDI (writeToMidi) + +type WindowSize = Int +type Query a = (Check a, a) +data UserQuery a = ToPattern a => Check Pattern :@ a + +upTo :: Time -> Time -> (Time, Time) +upTo = (,) + +-- | Query equivalent patterns using a sliding window. +query :: Query Pattern -> MusicPiece -> [Pattern] +query (checker, base) = + filter (\p -> (base <=> p) checker) . slide (length base) + where + slide :: WindowSize -> [a] -> [[a]] + slide n xs = [ take n (drop m xs) | m <- [0..(length xs - n `max` 0)] ] + +queryMatchCount :: Query Pattern -> MusicPiece -> Int +queryMatchCount q mp = length (query q mp) + +-- | Example queries. +query1 :: UserQuery (Time, Time) +query1 = (transpositionOf ~~ 0.5) :@ (21 `upTo` 28) + +query2 :: UserQuery (Music Pitch) +query2 = (transpositionOf ~~ 0.5) :@ (line $ map ($qn) [c 4, e 4, g 4, c 5]) + +-- | Query patterns from the given song with given base pattern. +-- e.g. "bach" ?? query1/query2 +(??) :: ToPattern a => Song -> UserQuery a -> IO () +infix 0 ?? +song ?? q :@ base' = do + -- parse the music piece + piece <- parseMusic song + putStrLn $ "Piece length: " ++ show (length piece) + + -- get the base pattern + let base = toPattern piece base' + putStrLn $ "Base length: " ++ show (length base) + + -- extract patterns (do not extract the base pattern again) + let pats = filter (/= base) $ query (q, base) piece + putStrLn $ "Found patterns: " ++ show (length pats) + + -- export MIDI files + cd ("data/extracted/" ++ song ++ "/") $ do + emptyDirectory "." + writeToMidi "base.mid" base + forM_ (zip [1..] pats) $ + \(i, p) -> writeToMidi ("occ" ++ show i ++ ".mid") p + +-- | Types from which we can extract a pattern from a given song. +class ToPattern a where + toPattern :: MusicPiece -> a -> Pattern + +-- | Given a song name, one can extract a musical pattern +-- by parsing the song file and selecting some time period. +instance ToPattern (Time, Time) where + toPattern song (startT, endT) = + ( takeWhile ((<= endT) . ontime) + . dropWhile ((< startT) . ontime) + ) song + +-- | Given a datatype that can be converted to Euterpea's core Music datatype, +-- one can subsequently convert that to get a musical pattern. +instance ToMusic1 a => ToPattern (Music a) where + toPattern _ = musicToPattern diff --git a/src/EuterpeaUtils.hs b/src/EuterpeaUtils.hs new file mode 100644 --- /dev/null +++ b/src/EuterpeaUtils.hs @@ -0,0 +1,41 @@ +module EuterpeaUtils + ( -- re-exporting Euterpea things + module Export + -- conversion from/to Euterpea datatype + , patternToMusic, musicToPattern + ) where + +import Euterpea.Music as Export hiding (Rest, Note, pitch) +import qualified Euterpea.Music as M + +import Types + +-- | Convert our Pattern datatype to Euterpea's music datatype. +patternToMusic :: Pattern -> Music AbsPitch +patternToMusic = line . fmap convert . withDurations + where + withDurations :: Pattern -> [(MIDI, Time)] + withDurations ps = zip (pitch ps) (durations ps ++ [4]) + + convert :: (MIDI, Time) -> Music AbsPitch + convert (m, tt) = Prim $ M.Note (toRational tt) (fromInteger m) + +-- | Convert from Euterpea's music datatype to our pattern datatype. +musicToPattern :: ToMusic1 a => Music a -> Pattern +musicToPattern = withDurations . convert . fmap (absPitch . fst) . toMusic1 + where + convert :: Music AbsPitch -> [Either Time Note] + convert (n :+: ns) = convert n ++ convert ns + convert (n :=: _) = convert n + convert (Modify _ n) = convert n + convert (Prim prim) = + case prim of + M.Rest r -> [Left $ fromRational r] + M.Note dr p -> [Right $ Note (fromRational dr) (toInteger p)] + + withDurations :: [Either Time Note] -> [Note] + withDurations = snd . foldl go (0.0, []) + where go :: (Double, [Note]) -> Either Time Note -> (Double, [Note]) + go (acc, ns) (Left tt) = (acc + tt, ns) + go (acc, ns) (Right (Note tt m)) = (acc', ns ++ [Note acc m]) + where acc' = acc + tt diff --git a/src/MIDI.hs b/src/MIDI.hs new file mode 100644 --- /dev/null +++ b/src/MIDI.hs @@ -0,0 +1,25 @@ +module MIDI (readFromMidi, writeToMidi) where + +import Euterpea.IO.MIDI.ToMidi (writeMidi) +import Euterpea.IO.MIDI.FromMidi2 (fromMidi2) +import qualified Codec.Midi as MIDI + +import Types +import EuterpeaUtils (patternToMusic, musicToPattern) + +writeToMidi :: FilePath -> Pattern -> IO () +writeToMidi fn = writeMidi fn . patternToMusic + +readFromMidi :: FilePath -> IO Pattern +readFromMidi = fmap (musicToPattern . fromMidi2) . importFile + where + importFile :: FilePath -> IO MIDI.Midi + importFile fn = do + r <- MIDI.importFile fn + case r of + Left err -> error err + Right m -> return m + + + + diff --git a/src/Parser.hs b/src/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Parser.hs @@ -0,0 +1,403 @@ +module Parser ( parseClassicExperts, parseClassicAlgo + , parseClassicAlgoVM1, parseClassicAlgoVM2, parseClassicAlgoMP, parseClassicAlgoSIACF1, parseClassicAlgoSIACP, parseClassicAlgoSIACR + , parseFolkAlgoVM1, parseFolkAlgoVM2, parseFolkAlgoMP, parseFolkAlgoSIACF1, parseFolkAlgoSIACP, parseFolkAlgoSIACR, parseFolkAlgoCOSIA, parseFolkAlgoSIACFP, parseHEMANAnnotations, parseHEMANAlgoSIACRD, parseHEMANAlgoSIACPD, parseHEMANAlgoSIACR, parseHEMANAlgoSIACP, parseHEMANAlgoSIACF1, parseHEMANAlgoSIACF1D + , parseEuroAlgoSIACF1, parseEuroAlgoSIACF1D, parseEuroAlgoSIACP, parseEuroAlgoSIACPD, parseEuroAlgoSIACR, parseEuroAlgoSIACRD + , parsejazzAlgoSIACF1, parsejazzAlgoSIACF1D, parsejazzAlgoSIACP, parsejazzAlgoSIACPD, parsejazzAlgoSIACR, parsejazzAlgoSIACRD + , parseFolkExperts, parseFolkAlgo, parseRandom + , parseMusic + , cd, listDirs, listFiles, emptyDirectory + ) where + +import Control.Monad (forM, mapM_, filterM, void) +import Data.List (sort, isInfixOf, sortOn, groupBy) +import System.Directory + +import Text.Parsec +import Text.Parsec.Language +import Text.Parsec.String +import qualified Text.Parsec.Token as Tokens + +import Types +import MIDI (readFromMidi) + +-------------------- +-- Parsers. + +-- | Parse a music piece from the MIREX dataset. +-- the song can be one of [bach, beethoven, chopin, gibbons, mozart] +parseMusic :: Song -> IO MusicPiece +parseMusic song = cd ("data/pieces/" ++ sanitize song ++ "/monophonic/csv") $ do + [f_music] <- listFiles + parseMany mirexP f_music + where + -- | Parse one entry from a MIREX piece of music. + mirexP :: Parser Note + mirexP = Note <$> (floatP <* sepP) <*> (intP <* sepP) + <* (intP <* sepP) <* (floatP <* sepP) + <* intP <* newline + +parseHemanMusic :: Song -> IO MusicPiece +parseHemanMusic song = cd ("data/HEMAN/piece/csv" ++ sanitize song) $ do + [f_music] <- listFiles + parseMany mirexP f_music + where + -- | Parse one entry from a MIREX piece of music. + mirexP :: Parser Note + mirexP = Note <$> (floatP <* sepP) <*> (intP <* sepP) + <* (intP <* sepP) <* (floatP <* sepP) + <* intP <* newline + +-- ======== +parsejazzAlgoSIACRD :: IO [PatternGroup] +parsejazzAlgoSIACRD = cd "data/jazz/patterns/alg/tlrd/" $ do + algPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "SIARD")) + return algPgs + +parsejazzAlgoSIACPD :: IO [PatternGroup] +parsejazzAlgoSIACPD = cd "data/jazz/patterns/alg/tlpd/" $ do + algPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "SIAPD")) + return algPgs + +parsejazzAlgoSIACF1D :: IO [PatternGroup] +parsejazzAlgoSIACF1D = cd "data/jazz/patterns/alg/tlf1d/" $ do + algPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "SIAF1D")) + return algPgs + +parsejazzAlgoSIACR :: IO [PatternGroup] +parsejazzAlgoSIACR = cd "data/jazz/patterns/alg/tlr/" $ do + algPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "SIAR")) + return algPgs + +parsejazzAlgoSIACP :: IO [PatternGroup] +parsejazzAlgoSIACP = cd "data/jazz/patterns/alg/tlp/" $ do + algPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "SIAP")) + return algPgs + +parsejazzAlgoSIACF1 :: IO [PatternGroup] +parsejazzAlgoSIACF1 = cd "data/jazz/patterns/alg/tlf1/" $ do + algPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "SIAF1")) + return algPgs + + -- ======= +parseEuroAlgoSIACRD :: IO [PatternGroup] +parseEuroAlgoSIACRD = cd "data/eurovision/patterns/alg/tlrd/" $ do + algPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "SIARD")) + return algPgs + +parseEuroAlgoSIACPD :: IO [PatternGroup] +parseEuroAlgoSIACPD = cd "data/eurovision/patterns/alg/tlpd/" $ do + algPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "SIAPD")) + return algPgs + +parseEuroAlgoSIACF1D :: IO [PatternGroup] +parseEuroAlgoSIACF1D = cd "data/eurovision/patterns/alg/tlf1d/" $ do + algPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "SIAF1D")) + return algPgs + +parseEuroAlgoSIACR :: IO [PatternGroup] +parseEuroAlgoSIACR = cd "data/eurovision/patterns/alg/tlr/" $ do + algPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "SIAR")) + return algPgs + +parseEuroAlgoSIACP :: IO [PatternGroup] +parseEuroAlgoSIACP = cd "data/eurovision/patterns/alg/tlp/" $ do + algPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "SIAP")) + return algPgs + +parseEuroAlgoSIACF1 :: IO [PatternGroup] +parseEuroAlgoSIACF1 = cd "data/eurovision/patterns/alg/tlf1/" $ do + algPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "SIAF1")) + return algPgs + +-- ======== +parseHEMANAlgoSIACRD :: IO [PatternGroup] +parseHEMANAlgoSIACRD = cd "data/HEMAN/patterns/alg/tlrd/" $ do + algPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "SIARD")) + return algPgs + +parseHEMANAlgoSIACPD :: IO [PatternGroup] +parseHEMANAlgoSIACPD = cd "data/HEMAN/patterns/alg/tlpd/" $ do + algPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "SIAPD")) + return algPgs + +parseHEMANAlgoSIACF1D :: IO [PatternGroup] +parseHEMANAlgoSIACF1D = cd "data/HEMAN/patterns/alg/tlf1d/" $ do + algPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "SIAF1D")) + return algPgs + +parseHEMANAlgoSIACR :: IO [PatternGroup] +parseHEMANAlgoSIACR = cd "data/HEMAN/patterns/alg/tlr/" $ do + algPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "SIAR")) + return algPgs + +parseHEMANAlgoSIACP :: IO [PatternGroup] +parseHEMANAlgoSIACP = cd "data/HEMAN/patterns/alg/tlp/" $ do + algPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "SIAP")) + return algPgs + +parseHEMANAlgoSIACF1 :: IO [PatternGroup] +parseHEMANAlgoSIACF1 = cd "data/HEMAN/patterns/alg/tlf1/" $ do + algPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "SIAF1")) + return algPgs + +parseHEMANAnnotations :: IO [PatternGroup] +parseHEMANAnnotations = cd "data/HEMAN/patterns/annotations/" $ do + algPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "Human")) + return algPgs + +-- | Parse all (expert) pattern groups from the classical dataset. +parseClassicExperts :: IO [PatternGroup] +parseClassicExperts = cd "data/pieces" $ do + f_roots <- listDirs + res <- forM f_roots $ \f_root -> cd (f_root ++ "/monophonic/repeatedPatterns") $ do + f_patExs <- listDirs + allPats <- forM f_patExs $ \f_patEx -> cd f_patEx $ do + f_patTys <- listDirs + forM f_patTys $ \f_patTy -> do + basePat:pats <- cd (f_patTy ++ "/occurrences/csv") $ do + f_pats <- listFiles + pforM f_pats (parseMany noteP) + return $ PatternGroup { piece_name = f_root + , expert_name = f_patEx + , pattern_name = f_patTy + , basePattern = basePat + , patterns = pats } + return $ concat allPats + return $ concat res + +-- | Parse all (algorithmic) pattern groups from the classical dataset. +parseClassicAlgo :: IO [PatternGroup] +parseClassicAlgo = cd "data/algOutput" $ do + f_algs <- listDirs + allPgs <- forM f_algs $ \f_alg -> cd f_alg $ do + f_versions <- listDirs + if null f_versions then do + listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece f_alg)) + else + concat <$> forM f_versions + (\f_v -> cd f_v $ + listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece $ f_alg ++ ":" ++ f_v))) + return (concat allPgs) + +-- | Parse all (algorithmic, VM1) pattern groups from the classical dataset. +parseClassicAlgoVM1 :: IO [PatternGroup] +parseClassicAlgoVM1 = cd "data/algOutput/2016GV/VM1/" $ do + allPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "VM1")) + return allPgs + +parseClassicAlgoVM2 :: IO [PatternGroup] +parseClassicAlgoVM2 = cd "data/algOutput/2016GV/VM2/" $ do + allPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "VM2")) + return allPgs + +parseClassicAlgoMP :: IO [PatternGroup] +parseClassicAlgoMP = cd "data/algOutput/2016MP/" $ do + allPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "MP")) + return allPgs + +parseClassicAlgoSIACF1 :: IO [PatternGroup] +parseClassicAlgoSIACF1 = cd "data/algOutput/2016DM/SIATECCompressF1/" $ do + allPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "SIACF1")) + return allPgs + +parseClassicAlgoSIACP :: IO [PatternGroup] +parseClassicAlgoSIACP = cd "data/algOutput/2016DM/SIATECCompressP/" $ do + allPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "SIACP")) + return allPgs + +parseClassicAlgoSIACR :: IO [PatternGroup] +parseClassicAlgoSIACR = cd "data/algOutput/2016DM/SIATECCompressR/" $ do + allPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "SIACR")) + return allPgs + + +-- | Parse all (algorithmic, VM1) pattern groups from the folk dataset. +parseFolkAlgoVM1 :: IO [PatternGroup] +parseFolkAlgoVM1 = cd "data/MTC/patterns/alg/VM1/" $ do + allPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "VM1")) + return allPgs + +parseFolkAlgoVM2 :: IO [PatternGroup] +parseFolkAlgoVM2 = cd "data/MTC/patterns/alg/VM2/" $ do + allPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "VM2")) + return allPgs + +parseFolkAlgoMP :: IO [PatternGroup] +parseFolkAlgoMP = cd "data/MTC/patterns/alg/MP/" $ do + allPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "MP")) + return allPgs + +parseFolkAlgoSIACF1 :: IO [PatternGroup] +parseFolkAlgoSIACF1 = cd "data/MTC/patterns/alg/SIAF1/" $ do + allPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "SIACF1")) + return allPgs + +parseFolkAlgoSIACP :: IO [PatternGroup] +parseFolkAlgoSIACP = cd "data/MTC/patterns/alg/SIAP/" $ do + allPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "SIACP")) + return allPgs + +parseFolkAlgoSIACR :: IO [PatternGroup] +parseFolkAlgoSIACR = cd "data/MTC/patterns/alg/SIAR/" $ do + allPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "SIACR")) + return allPgs + +parseFolkAlgoCOSIA :: IO [PatternGroup] +parseFolkAlgoCOSIA = cd "data/MTC/patterns/alg/DM/" $ do + allPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "COSIA")) + return allPgs + +parseFolkAlgoSIACFP :: IO [PatternGroup] +parseFolkAlgoSIACFP = cd "data/MTC/patterns/alg/SIARCT-CFP/" $ do + allPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "SIACFP")) + return allPgs + +-- | Parse all (expert) pattern groups from the dutch folk dataset. +parseFolkExperts :: IO [PatternGroup] +parseFolkExperts = cd "data/MTC/patterns/expert" $ do + allPgs <- listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece "exp")) + return (groupPatterns allPgs) + where + groupPatterns :: [PatternGroup] -> [PatternGroup] + groupPatterns = (foldl1 combinePatterns <$>) + . groupBy samePattern + . sortOn show + + samePattern :: PatternGroup -> PatternGroup -> Bool + samePattern (PatternGroup p e pa _ _) (PatternGroup p' e' pa' _ _) = + p == p' && e == e' && pa == pa' + + combinePatterns :: PatternGroup -> PatternGroup -> PatternGroup + combinePatterns p1@(PatternGroup p e pa b os) p2@(PatternGroup _ _ _ b' os') + | samePattern p1 p2 = PatternGroup p e pa b $ (b' : os) ++ os' + | otherwise = error "Cannot combine occurences of different patterns" + +-- | Parse all (algorithmic) pattern groups from the dutch folk dataset. +parseFolkAlgo :: IO [PatternGroup] +parseFolkAlgo = cd "data/MTC/patterns/alg" $ do + f_algs <- listDirs + allPgs <- forM f_algs $ \f_alg -> cd f_alg $ + listFiles >>= ((concat <$>) . pmapM (parseAlgoPiece f_alg)) + return (concat allPgs) + +-- | Parse all patterns from the random dutch folk dataset and form random groups. +parseRandom :: IO [PatternGroup] +parseRandom = cd "data/MTC/ranexcerpts" $ do + f_groups <- listDirs + allPgs <- forM f_groups $ \f_group -> cd f_group $ do + fs <- listFiles + let families = groupBy (\x y -> sanitize x == sanitize y) $ sortOn sanitize fs + forM families $ \family -> do + (base:pats) <- pmapM readFromMidi family -- convert MIDI to Pattern + return PatternGroup { piece_name = sanitize (head family) + , expert_name = "RAND" + , pattern_name = f_group + , basePattern = base + , patterns = pats } + return (concat allPgs) + +parseAlgoPiece :: String -> FilePath -> IO [PatternGroup] +parseAlgoPiece algo_n fname = + parseMany (patternGroupP (sanitize fname) algo_n) fname + +-- | Normalize names of musical pieces to a static representation. +sanitize :: String -> String +sanitize s + -- Classical pieces + | (("bach" `isInfixOf` s) || ("wtc" `isInfixOf` s)) && not ("1" `isInfixOf` s) && not ("2" `isInfixOf` s) = "bachBWV889Fg" + | ("beethoven" `isInfixOf` s) || ("sonata01" `isInfixOf` s) = "beethovenOp2No1Mvt3" + | ("chopin" `isInfixOf` s) || ("mazurka" `isInfixOf` s) = "chopinOp24No4" + | ("gibbons" `isInfixOf` s) || ("silver" `isInfixOf` s) = "gibbonsSilverSwan1612" + | ("mozart" `isInfixOf` s) || ("sonata04" `isInfixOf` s) = "mozartK282Mvt2" + -- HEMAN pieces + | ("bach1" `isInfixOf` s) = "bach1" + | ("bach2" `isInfixOf` s) = "bach2" + | ("bee1" `isInfixOf` s) = "bee1" + | ("mo155" `isInfixOf` s) = "mo155" + | ("mo458" `isInfixOf` s) = "mo458" + -- Folk pieces + | ("Daar_g" `isInfixOf` s) = "DaarGingEenHeer" + | ("Daar_r" `isInfixOf` s) = "DaarReedEenJonkheer" + | ("Daar_w" `isInfixOf` s) = "DaarWasLaatstmaalEenRuiter" + | ("Daar_z" `isInfixOf` s) = "DaarZouErEenMaagdjeVroegOpstaan" + | ("Een_l" `isInfixOf` s) = "EenLindeboomStondInHetDal" + | ("Een_S" `isInfixOf` s) = "EenSoudaanHadEenDochtertje" + | ("En" `isInfixOf` s) = "EnErWarenEensTweeZoeteliefjes" + | ("Er_r" `isInfixOf` s) = "ErReedErEensEenRuiter" + | ("Er_was_een_h" `isInfixOf` s) = "ErWasEenHerderinnetje" + | ("Er_was_een_k" `isInfixOf` s) = "ErWasEenKoopmanRijkEnMachtig" + | ("Er_was_een_m" `isInfixOf` s) = "ErWasEenMeisjeVanZestienJaren" + | ("Er_woonde" `isInfixOf` s) = "ErWoondeEenVrouwtjeAlOverHetBos" + | ("Femmes" `isInfixOf` s) = "FemmesVoulezVousEprouver" + | ("Heer_Halewijn" `isInfixOf` s) = "HeerHalewijn" + | ("Het_v" `isInfixOf` s) = "HetVrouwtjeVanStavoren" + | ("Het_was_l" `isInfixOf` s) = "HetWasLaatstOpEenZomerdag" + | ("Het_was_o" `isInfixOf` s) = "HetWasOpEenDriekoningenavond" + | ("Ik" `isInfixOf` s) = "IkKwamLaatstEensInDeStad" + | ("Kom" `isInfixOf` s) = "KomLaatOnsNuZoStilNietZijn" + | ("Lieve" `isInfixOf` s) = "LieveSchipperVaarMeOver" + | ("O_God" `isInfixOf` s) = "OGodIkLeefInNood" + | ("Soldaat" `isInfixOf` s) = "SoldaatKwamUitDeOorlog" + | ("Vaarwel" `isInfixOf` s) = "VaarwelBruidjeSchoon" + | ("Wat" `isInfixOf` s) = "WatZagIkDaarVanVerre" + | ("Zolang" `isInfixOf` s) = "ZolangDeBoomZalBloeien" + | otherwise = s + +patternGroupP :: String -> String -> Parser PatternGroup +patternGroupP piece_n algo_n = + PatternGroup piece_n algo_n <$> nameP 'p' + <*> patternP + <*> many patternP + where + patternP :: Parser Pattern + patternP = nameP 'o' *> many noteP + nameP :: Char -> Parser String + nameP c = char c *> ((:) <$> return c <*> many1 alphaNum) <* lineP + +-------------------- +-- Parser utilities. + +parseMany :: Parser a -> FilePath -> IO [a] +parseMany p f = do + input <- readFile f + case runParser ((many p <* many lineP) <* eof) () f input of + Left err -> error $ show err + Right x -> return x + +noteP :: Parser Note +noteP = Note <$> (floatP <* sepP) + <*> intP <* lineP + +sepP :: Parser String +sepP = string ", " + +intP :: Parser Integer +intP = Tokens.integer haskell + <* optional (string "." <* many (string "0") <* optional (string " ")) + +floatP :: Parser Double +floatP = negP <|> Tokens.float haskell + where negP = (\i -> -i) <$> (string "-" *> Tokens.float haskell) + +lineP :: Parser () +lineP = void (newline <|> crlf) <|> void (many1 space) + +------------------------- +-- File-system utilities. + +cd :: FilePath -> IO a -> IO a +cd fpath c = createDirectoryIfMissing True fpath + >> withCurrentDirectory fpath c + +listDirs :: IO [FilePath] +listDirs = sort <$> (getCurrentDirectory + >>= listDirectory + >>= filterM doesDirectoryExist) + +listFiles :: IO [FilePath] +listFiles = sort <$> (getCurrentDirectory + >>= listDirectory + >>= filterM ((not <$>) . doesDirectoryExist)) + +emptyDirectory :: FilePath -> IO () +emptyDirectory f_root = cd f_root $ mapM_ removeFile =<< listFiles diff --git a/src/Render.hs b/src/Render.hs new file mode 100644 --- /dev/null +++ b/src/Render.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE FlexibleInstances, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Render (dumpAnalyses, renderOne, render) where + +import Control.Monad (forM_, when) +import Numeric (showFFloat) + +-- Chart +import Data.Char (isDigit) +import Data.Colour +import Data.Colour.Names +import Graphics.Rendering.Chart.Easy hiding (render) +import Graphics.Rendering.Chart.Backend.Cairo + +-- CSV +import Data.Csv hiding ((.=)) +import qualified Data.ByteString.Lazy as BL + +-- MIDI +import MIDI (writeToMidi) + +import Types +import Parser +import Analysis + +------------------- +-- CSV files + +-- | Whether to print absolute values or percentages in CSV fields. +data OutputMode = Absolute | Percentage + +-- | Conversion from AnalysisResult to CSV. +instance ToNamedRecord (OutputMode, Analysis, AnalysisResult) where + toNamedRecord (mode, curAnalysis, an) = namedRecord $ + [ ("name", toField (name an)) + , ("total", toField tot) ] ++ + map (\(s,n) -> (toField s, showPercentage n)) + (orderedResults curAnalysis an) ++ + [ ("unclassified", showPercentage $ length (unclassified an)) ] + where + tot = total an + + showPercentage n = case mode of + Absolute -> toField n + Percentage -> toField $ showFFloat (Just 2) (fromIntegral n / fromIntegral tot * 100) "" + +-- | Dump all files, relevant to a (group of) analyses. +dumpAnalyses :: String -> Bool -> Analysis -> [AnalysisResult] -> IO () +dumpAnalyses fname expo curAnalysis as = do + let resFields = (toField . fst) <$> orderedResults curAnalysis (head as) + let headerFields = header $ ["name", "total"] ++ resFields ++ ["unclassified"] + -- File #1: absolute values + BL.writeFile (fname ++ ".csv") $ + encodeByName headerFields (map (\a -> (Absolute, curAnalysis, a)) as) + -- File #2: percentage values + BL.writeFile (fname ++ "-percentages.csv") $ + encodeByName headerFields (map (\a -> (Percentage, curAnalysis, a)) as) + -- File #3: unclassified indices + let uncls = concatMap unclassified as + writeFile "unclassified.txt" $ unlines (fst <$> uncls) + when expo $ do + emptyDirectory "unclassified" + cd "unclassified" $ + forM_ uncls $ \(f, p) -> writeToMidi (f ++ ".mid") p + +-- | Show instance for AnalysisResult. +instance {-# OVERLAPPING #-} Show (Analysis, AnalysisResult) where + show (curAnalysis, an) = + name an ++ " {" + ++ "\n\ttotal: " ++ show tot + ++ concat [ "\n\t" ++ s ++ ": " ++ showPercentage n + | (s, n) <- orderedResults curAnalysis an ] + ++ "\n\tother: " ++ showPercentage (length $ unclassified an) + ++ "\n}" + where + tot = total an + showPercentage n + = showFFloat (Just 2) (fromIntegral n / fromIntegral tot * 100) "" + ++ "% (" ++ show n ++ ")" + +------------------- +-- Charts + +-- | Visualize the results of analyzing a single pattern group in a pie chart. +renderOne :: Analysis -> PatternGroup -> AnalysisResult -> IO () +renderOne curAnalysis (PatternGroup piece_n expert_n pattern_n _ _) an = + cd (piece_n ++ "/" ++ expert_n) $ + render curAnalysis pattern_n an + +-- | Visualize an arbitrary AnalysisResult. +render :: Analysis -> String -> AnalysisResult -> IO () +render curAnalysis fname an + | total an == 0 + = return () + | otherwise + = do toFile def (fname ++ ".png") $ do + pie_plot . pie_data .= values + pie_plot . pie_colors .= map opaque colours + pie_plot . pie_label_line_style . line_width .= 0.5 + pie_plot . pie_label_style . font_size .= 14 + where + colours :: [Colour Double] + colours = + -- transformations (100%, 80%, 60%, 40%) + take 50 (cycle [pink, darkblue, darkred, green, darkorange, darkcyan, darkmagenta, brown, darkviolet, darkorange]) + -- other + ++ [black] + + values :: [PieItem] + values = + [ pitem_value .~ v + $ pitem_label .~ (if v > 2 then formatLabel s else "") + $ pitem_offset .~ 30 + $ def + | (s, v) <- map (fmap (\n -> (fromIntegral n / fromIntegral (total an) * 100))) + (orderedResults curAnalysis an ++ [("other", length $ unclassified an)]) + ] + + formatLabel :: String -> String + formatLabel s = trS ++ case n of + ('0':_) -> " ~ " ++ show ((read n :: Int) * 10) ++ "%" + _ -> "" + where (trS, n) = break isDigit s diff --git a/src/Transformations.hs b/src/Transformations.hs new file mode 100644 --- /dev/null +++ b/src/Transformations.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE ImplicitParams, Rank2Types, ScopedTypeVariables, BangPatterns #-} +module Transformations where + +import Data.List (sortOn) +import Data.Semigroup +import Data.Functor.Contravariant hiding ((>$<), (>$), ($<)) + +import Types + +-------------------- +-- Combinator DSL + +newtype Check a = Check { getCheck :: a -> a -> Bool } + -- ^ Checks two patterns (horizontal translation in time is always assumed). + +(<=>) :: a -> a -> Check a -> Bool +(x <=> y) p = getCheck p x y + +instance Semigroup (Check a) where + p <> q = Check $ \x y -> and (x <=> y `map` [p, q]) + +instance Contravariant Check where + contramap f p = Check $ \x y -> (f x <=> f y) p + +infix 7 >$< +(>$<) :: (a -> b) -> Check b -> Check a +(>$<) = contramap + +infix 8 >$, $< +(>$), ($<) :: (a -> a) -> Check a -> Check a +f >$ p = Check $ \x y -> (f x <=> y) p +f $< p = Check $ \x y -> (x <=> f y) p + +type ApproxCheck a = (?p :: Float) => Check a + +(~~) :: ((?p::Float) => r) -> Float -> r +(~~) thing f = let ?p = f in thing + +--------------------- +-- Transformations + +-- | Exact repetition: move a pattern in time. +-- (AKA horizontal translation) +exactOf :: ApproxCheck Pattern +exactOf = rhythm >$< approxEq2 + <> pitch >$< approxEq + +-- | Transposition: move a pattern in pitch. +-- (AKA horizontal+vertical translation) +transpositionOf :: ApproxCheck Pattern +transpositionOf = rhythm >$< approxEq2 + <> intervals >$< approxEq2 + +transpositionOfPitchOnly :: ApproxCheck Pattern +transpositionOfPitchOnly = intervals >$< approxEq2 + +-- | Inversion: negate all pitch intervals (starting from the same base pitch). +inversionOf :: ApproxCheck Pattern +inversionOf = basePitch >$< equal + <> rhythm >$< approxEq2 + <> intervals >$< (inverse $< approxEq2) + +-- | Retrograde: mirror a pattern in both pitch and rhythm. +-- (AKA vertical reflection) +retrogradeOf :: ApproxCheck Pattern +retrogradeOf = rhythm >$< (reverse $< approxEq2) + <> pitch >$< (reverse $< approxEq) + +-- | Rotation: reversal of pitch intervals and reversal of rhythm. +-- (AKA retrograde inversion) +rotationOf :: ApproxCheck Pattern +rotationOf = rhythm >$< (reverse $< approxEq2) + <> intervals >$< (reverse $< approxEq2) + +-- | Augmentation: speed-up/slow-down the rhythmic structure of a pattern. +augmentationOf :: ApproxCheck Pattern +augmentationOf = normalRhythm >$< approxEq2 + <> pitch >$< approxEq + +----------------------- +-- Tonal transposition + +-- | Octave-agnostic tonal transposition, wrt a scale that 'fits' the base pattern +-- e.g. [I, IV, V] tonalTranspOf [III, VI, VII] +tonalTranspOf :: ApproxCheck Pattern +tonalTranspOf = rhythm >$< approxEq2 + <> Check (\xs ys -> (xs <=> ys) (applyScale (guessScale $ xs ++ ys) + >$< approxEq2)) + +-- | Taking into account of multiple possibilities of scales like in tonalTransCanofCore, but with approximation in the checking +tonalTranspOfCan :: ApproxCheck Pattern +tonalTranspOfCan = rhythm >$< approxEq2 + <> Check (\xs ys -> foldr (||) True (map (xs <=> ys) [checks >$< approxEq2 | checks <- (map applyScale (guessScaleCandidates 3 $ xs ++ ys))])) + +-- | Instead guess one scale, then check the scale degrees, we guess three scales, and fold over all the possible scale degree checks with || +-- The core is a version that does not allow for approximation +tonalTransCanOfCore :: Check Pattern +tonalTransCanOfCore = Check (\xs ys -> foldr (||) True (map (xs <=> ys) + [checks >$< equal | checks <- (map applyScale (guessScaleCandidates 3 $ xs ++ ys))])) + +tonalInversionOfCan :: ApproxCheck Pattern +tonalInversionOfCan = rhythm >$< approxEq2 + <> Check (\xs ys -> foldr (||) True (map (xs <=> ys) [checks >$< (inverse $< approxEq2) | checks <- (map applyScale (guessScaleCandidates 3 $ xs ++ ys))])) +----------------------- +-- Combinations + +-- | Transposition + Inversion. +trInversionOf :: ApproxCheck Pattern +trInversionOf = rhythm >$< approxEq2 + <> intervals >$< (inverse $< approxEq2) + +-- | Transposition + Augmentation. +trAugmentationOf :: ApproxCheck Pattern +trAugmentationOf = normalRhythm >$< approxEq2 + <> intervals >$< approxEq2 + + +-- | Transposition + Retrograde. +trRetrogradeOf :: ApproxCheck Pattern +trRetrogradeOf = rhythm >$< (reverse $< approxEq2) + <> intervals >$< (reverse . inverse $< approxEq2) + +-- | New tonal versions +trtonRotationOf :: ApproxCheck Pattern +trtonRotationOf = rhythm >$< (reverse $< approxEq2) + <> Check (\xs ys -> (xs <=> ys) (applyScale (guessScale xs) + >$< approxEq2)) + +trtonAugmentationOf :: ApproxCheck Pattern +trtonAugmentationOf = normalRhythm >$< approxEq2 + <> Check (\xs ys -> (xs <=> ys) (applyScale (guessScale xs) + >$< approxEq2)) + + +----------------------- +-- Approximate equality + +-- | Check that two elements are exactly equal (using `eq`). +-- e.g. [a, c, b] equal [a, c, b] +equal :: Eq a => Check a +equal = Check (==) + +-- | Influences the accuracy of `approxEq`, but also dramatically reduces +-- execution time of the analysis. +maxLookahead :: Int +maxLookahead = 5 + +approxEqWith :: forall b. (Show b, Num b, Eq b) + => ( b -- the element to delete + -> [b] -- the initial list + -> Int -- maximum elements to ignore + -> Maybe (Int, [b]) -- * Nothing, if there was no deletion + -- * Just(# of ignored,tail), otherwise + ) + -- ^ function that deletes an element from a list, possibly + -- reducing (summing) consecutive elements to be equal to the + -- element being deleted + -> ApproxCheck [b] +approxEqWith del1 + | ?p == 1.0 = equal -- short-circuit for faster results + | otherwise = Check go + where + go xs' ys' = + let [xs, ys] = sortOn length [xs', ys'] + [n, m] = length <$> [xs, ys] + maxIgnored = floor $ (1 - ?p) * fromIntegral n + maxAdded = floor $ (1 - ?p) * fromIntegral m + in del ys xs (maxIgnored, maxAdded) + + del :: [b] -> [b] -> (Int {-ignored-}, Int {-added-}) -> Bool + del ys [] (maxI, maxA) = 0 <= maxI && length ys <= maxA + del [] xs (maxI, maxA) = length xs <= maxI && 0 <= maxA + del ys (x:xs) (maxI, maxA) + -- surpassed the limits, abort + | maxI < 0 || maxA < 0 + = False + + -- no more additions/ignores allowed, resort to simple equality + | maxI + maxA == 0 + = ys == x:xs + + -- found the prototype element in the occurrence (possibly adding elements) + -- NB: maybe it's better to ignore it though, thus the second case + | Just (maxA', ys') <- del1 x ys maxA + , maxA' >= 0 + , maxA - maxA' <= maxLookahead + = del ys' xs (maxI, maxA') + -- `|| (maxI > 0 && del ys xs (maxI - 1, maxA))` -- too slow... + + -- did not find element, ignore if possible + | maxI > 0 + = del ys xs (maxI - 1, maxA) + + -- did not find element and cannot ignore it, abort + | otherwise + = False + +-- | First-order approximate equality of lists. +-- +-- Check that two lists are approximately equal, wrt a certain percentage. +-- A base pattern and an occurence are approximately equal with percentage `p` when: +-- 1. The occurence ignores (1-p)% notes of the base pattern +-- 2. (1-p)% notes of the occurence are additional notes (not in the base pattern) +-- e.g. [A,C,F,A,B] (approxEq 80%) [A,C,G,A,B] +approxEq :: (Show a, Num a, Eq a) => ApproxCheck [a] +approxEq = approxEqWith del1 + where + -- does not reduce consecutive elements (first-order) + del1 _ [] _ = Nothing + del1 x (y:ys) maxA + | maxA < 0 = Nothing + | x == y = Just (maxA, ys) + | otherwise = del1 x ys $! (maxA - 1) + +-- | Second-order approximate equality of lists. +-- +-- The essential difference with first-order approximate equality is the ability +-- to equate consecutive elements with their sum, hence the Ord/Num constraint. +-- +-- NB: motivated by lists which are the result of pairing an initial list +-- and we count approximation by checking the initial lists +-- e.g. * intervals from pitches +-- * rhythm from durations +approxEq2 :: (Show a, Ord a, Num a, Eq a) => ApproxCheck [a] +approxEq2 = approxEqWith del1 + where + -- reduces consecutive elements (second-order) + del1 _ [] _ = Nothing + del1 x (y:ys) maxA + | maxA < 0 = Nothing + | x == y = Just (maxA, ys) + | Just i <- findIndex 0 x (y:ys) maxLookahead -- NB: fixed look-ahead + , maxA >= i + = Just (maxA - i, snd $ splitAt i ys) + | otherwise + = del1 x ys $! (maxA - 1) + + findIndex i 0 _ _ = Just i + findIndex _ _ _ 0 = Nothing + findIndex _ _ [] _ = Nothing + findIndex i acc (y:ys) maxAc + | acc >= y = findIndex (i + 1) (acc - y) ys (maxAc - 1) + | otherwise = Nothing diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 --- /dev/null +++ b/src/Types.hs @@ -0,0 +1,192 @@ +module Types where + +import Control.Parallel.Strategies (parMap, rpar) +import Control.Concurrent.Async (forConcurrently, mapConcurrently) + +import Data.List (intersperse, maximumBy, sort, sortBy) +import qualified Data.Map as M +import qualified Data.Set as S + +-- | Time in crochet beats. +type Time = Double +-- | MIDI values are represented with integers. +type MIDI = Integer +-- | Intervals are represented with integers (i.e. number of semitones). +type Interval = Integer +type ScaleDegree = Int + +type Length = Int +-- | A pattern group is one of the patterns of a piece of music, identified by an expert +-- or algorithm, and defined by a pattern prototype and other pattern occurences. +data PatternGroup = PatternGroup + { piece_name :: String + -- ^ the name of the music piece, that the pattern group belongs to + , expert_name :: String + -- ^ music expert or algorithm that produced the pattern occurences + , pattern_name :: String + -- ^ the name of the current pattern group + , basePattern :: Pattern + -- ^ the pattern prototype (always taken from `occ1.csv`) + , patterns :: [Pattern] + -- ^ all other pattern occurences of the prototype + } deriving (Eq) + +instance Show PatternGroup where + -- | Get a title, unique to the given PatternGroup, in the following format: + -- ::. + show (PatternGroup piece_n expert_n pattern_n _ _) = + concat $ intersperse ":" [piece_n, expert_n, pattern_n] + +-- | A pattern is a sequence of notes. +type Pattern = [Note] + +-- | A simplistic music note (only time and pitch). +data Note = Note { ontime :: Time -- ^ onset time + , midi :: MIDI -- ^ MIDI number + } deriving (Eq, Show) + +-- | Infix variant of the Note constructor. +(.@) :: MIDI -> Time -> Note +(.@) = flip Note + +(.@@) :: [Time] -> [MIDI] -> [Note] +(.@@) = zipWith Note + +-- | A piece of music is a huge pattern. +type MusicPiece = Pattern + +-- | Songs are identified with a string. +type Song = String + +----------------------- +-- Utilities + +-- | Negate the values of a numeric list. +inverse :: Num a => [a] -> [a] +inverse = fmap negate + +-- | The base pitch of a pattern (the pitch of its first note). +-- e.g. basePitch [(25,1), (27,2), (25,2.5)] = Just 25 +basePitch :: Pattern -> Maybe MIDI +basePitch (Note _ m:_) = Just m +basePitch [] = Nothing + +-- | The (real) pitch structure of a pattern. +-- e.g. pitch [(25,1), (27,2), (25,2.5)] = [25, 27, 25] +pitch :: Pattern -> [MIDI] +pitch = fmap midi + +-- | The (relative) pitch structure of a pattern. +-- e.g. intervals [(25,1), (27,2), (25,2.5)] = [2, -2] +intervals :: Pattern -> [Interval] +intervals = fmap (uncurry (-)) . pairs . pitch + +-- | The (real) rhythmic structure of a pattern. +-- e.g. onset [(25,1), (27,2), (25,2.5)] = [1, 2, 2.5] +onsets :: Pattern -> [Time] +onsets = sort . fmap ontime + +-- | The (relative) rhythmic structure of a pattern. +-- e.g. rhythm [(25,1), (27,2), (25,2.5)] = [1, 0.5] +durations :: Pattern -> [Time] +durations = fmap (uncurry (-)) . pairs . onsets + +rhythm :: Pattern -> [Time] +rhythm = map (truncate' 2) . durations + +-- | Normalized (relative) rhythmic structure of a pattern. +-- e.g. normalRhythm [(A,2), (C#,6), (Eb,8), (B,1), (A,2)] = [1, 3, 4, 1/2, 1] +normalRhythm :: Pattern -> [Time] +normalRhythm = normalizeTime . rhythm + where + -- | Convert times to ratios wrt the first time unit used. + -- e.g. normalizeTime [2, 6, 8, 6, 1, 2] = [1, 3, 4, 1/2, 1] + normalizeTime :: [Time] -> [Time] + normalizeTime (tt : ts) = 1 : ((/ tt) <$> ts) + normalizeTime [] = [] + +-- | Translate a note horizontally (in time). +-- e.g. translateH (-0.5) [(25,1), (27,2), (25,2.5)] = [(25,0.5), (27,1.5), (25,2)] +translateH :: Time -> Note -> Note +translateH dt (Note tInit m) = Note (tInit + dt) m + +-- | Translate a note vertically (in pitch). +-- e.g. translateV (-20) [(25,1), (27,2), (25,2.5)] = [(5,1), (7,2), (5,2.5)] +translateV :: Interval -> Note -> Note +translateV dm (Note tt mInit) = Note tt (mInit + dm) + +-- | Get list as pairs of consecutive elements. +-- e.g. pairs [a, b, c, d] = [(a, b), (b, c), (c, d)] +pairs :: [a] -> [(a, a)] +pairs xs = zip (tail xs) xs + +truncate' :: Int -> Double -> Double +truncate' n x = fromIntegral (floor (x * t)) / t + where t = 10^n +----------------------- +-- Scales/modes + +type Octave = Integer +type Degree = Integer +type ScaleType = [Interval] +type Scale = M.Map MIDI (Degree, Octave) + +major, harmonicMinor, melodicMinor :: ScaleType +major = [0,2,4,5,7,9,11] +melodicMinor = [0,2,3,5,7,9,11] +harmonicMinor = [0,2,3,5,7,8,11] + +createScaleInC :: ScaleType -> Scale +createScaleInC scType = M.fromList [ (24 + (oct * 12) + m, (i, oct + 1)) + | oct <- [0..7] + , (i, m) <- zip [1..7] scType ] + + +createScaleInD :: ScaleType -> Scale +createScaleInD scType = M.fromList [ (26 + (oct * 12) + m, (i, oct + 1)) + | oct <- [0..7] + , (i, m) <- zip [1..7] scType ] + +allScales :: [Scale] +allScales = [ M.mapKeys (+ transp) (createScaleInC scType) + | scType <- [major, harmonicMinor, melodicMinor] + , transp <- [0..11] ] + +guessScale :: Pattern -> Scale +guessScale xs = + let scales = [ (sc, S.size $ M.keysSet sc `S.intersection` S.fromList (pitch xs)) + | sc <- allScales ] + in fst $ maximumBy (\(_,s1) (_,s2) -> if s1 > s2 then GT + else if s1 < s2 then LT + else EQ) scales + + +guessScaleCandidates :: Int -> Pattern -> [Scale] +guessScaleCandidates n xs = + let scales = [ (sc, S.size $ M.keysSet sc `S.intersection` S.fromList (pitch xs)) + | sc <- allScales ] + in take n $ map fst (sortBy (\(_,s1) (_,s2) -> if s1 > s2 then GT + else if s1 < s2 then LT + else EQ) scales) + +toDegree :: Scale -> MIDI -> Integer +toDegree sc m = i + (oct * 7) + where (i, oct) = M.findWithDefault (0, 0) m sc -- 0 for 'outside' note + +applyScale :: Scale -> Pattern -> [Interval] +applyScale sc = fmap (uncurry (-)) . pairs . fmap (toDegree sc) . pitch + +----------------------- +-- Parallel operations + +-- | Parallel map. +pmap :: (a -> b) -> [a] -> [b] +pmap = parMap rpar + +-- | Parallel forM. +pforM :: Traversable t => t a -> (a -> IO b) -> IO (t b) +pforM = forConcurrently + +-- | Parallel mapM. +pmapM :: Traversable t => (a -> IO b) -> t a -> IO (t b) +pmapM = mapConcurrently diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/TransformationsSpec.hs b/test/TransformationsSpec.hs new file mode 100644 --- /dev/null +++ b/test/TransformationsSpec.hs @@ -0,0 +1,274 @@ +module TransformationsSpec (spec) where + +import Control.Monad (forM_) + +import Test.Hspec + +import Types +import Transformations ((<=>), (~~), tonalTranspOf, exactOf, retrogradeOf, inversionOf, transpositionOf, rotationOf, augmentationOf, trInversionOf, trAugmentationOf, tonalTranspOfCan, tonalInversionOfCan) + +forAll :: Example r => [a] -> String -> (a -> r) -> SpecWith (Arg r) +forAll xs title k = + forM_ exs $ \(i, x) -> do + describe title $ do + it ("# " ++ show i) $ + k x + where exs = zip [1..] xs + +forAll2 :: Example r => [a] -> String -> (a -> a -> r) -> SpecWith (Arg r) +forAll2 xs title k = + forM_ [(x, y) | x <- exs, y <- exs, fst x < fst y] $ \((i, x), (i', x')) -> do + describe title $ do + it (show i ++ " ~ " ++ show i') $ + k x x' + where exs = zip [1..] xs + +createPitchesfromInterval :: MIDI -> [Interval] -> Length -> [MIDI] +createPitchesfromInterval m i l = map (+m) (take l (scanl1 (+) (cycle i))) + +createPitchesfromScaleDegree :: Length -> MIDI -> ScaleType -> [ScaleDegree] -> [MIDI] +createPitchesfromScaleDegree l n st degrees = take l seqMultipleOctaves + where + seqMultipleOctaves :: [MIDI] + seqMultipleOctaves = [(+) (o * 12) | o <- [0 .. 7]] <*> seqOneOctave + + seqOneOctave :: [MIDI] + seqOneOctave = oneOctaveLookup degrees oneOctaveScale + + oneOctaveLookup :: [ScaleDegree] -> [(MIDI, (ScaleDegree, Octave))] -> [MIDI] + oneOctaveLookup [] _ = [] + oneOctaveLookup (sd:sds) scale = map fst (filter (\x -> (fst $ snd x) == sd) scale) ++ oneOctaveLookup sds scale + + oneOctaveScale = [ (n + m, (i, 1)) | (i, m) <- zip [1..7] st] + + +spec :: Spec +spec = do + + forAll2 hs "guessScale" $ \x y -> do + guessScale (x++y) `shouldBe` createScaleInC major + + forAll2 hs "tonal transposition - hanons" $ \x y -> do + (x <=> y) (tonalTranspOf ~~ 1) + + forAll2 tris "tonal transposition - triads" $ \x y -> do + (x <=> y) (tonalTranspOf ~~ 1) + + forAll2 neighBb "tonal transposition - neighbour notes in Bb" $ \x y -> do + (x <=> y) (tonalTranspOf ~~ 1) + + forAll2 neighDu5u "This one will fail: use tonalTranspCan (the one after next test) instead. tonal transposition - neighbour notes in D up a fifth and neighbouring up" $ \x y -> do + (x <=> y) (tonalTranspOf ~~ 1) + + forAll2 neighDu5u "guess scale - neighbour notes in D up a fifth and neighbouring up" $ \x y -> do + guessScale (x++y) `shouldBe` createScaleInD major + + forAll2 neighDu5u "tonal transposition more candidates - neighbour notes in D up a fifth and neighbouring up" $ \x y -> do + (x <=> y) (tonalTranspOfCan ~~ 1) + + forAll2 neighDu5d "This one will fail: use tonalTranspCan (next test) instead. tonal transposition - neighbour notes in D up a fifth and neighbouring down" $ \x y -> do + (x <=> y) (tonalTranspOf ~~ 1) + + forAll2 neighDu5d "tonal transposition more candidates - neighbour notes in D up a fifth and neighbouring down" $ \x y -> do + (x <=> y) (tonalTranspOfCan ~~ 1) + + forAll2 neighAd5d "tonal transposition - neighbour notes in A down a fifth and neighbouring down" $ \x y -> do + (x <=> y) (tonalTranspOf ~~ 1) + + forAll2 reachF "tonal transposition - reaching notes in F" $ \x y -> do + (x <=> y) (tonalTranspOf ~~ 1) + + forAll2 escapeG "tonal transposition - escaping notes in G" $ \x y -> do + (x <=> y) (tonalTranspOf ~~ 1) + + forAll2 launchingEb "tonal transposition - launching notes in Eb" $ \x y -> do + (x <=> y) (tonalTranspOf ~~ 1) + + forAll2 landingAm "tonal transposition - landing notes in A minor" $ \x y -> do + (x <=> y) (tonalTranspOf ~~ 1) + + describe "retrograde" $ do + it "correctly detects self-retrograde with palindromeven" $ + (palindromeeven <=> palindromeeven) (retrogradeOf ~~ 1) + + describe "retrograde" $ do + it "correctly detects self-retrograde with palindromeodd" $ + (palindromeodd <=> palindromeodd) (retrogradeOf ~~ 1) + + describe "real transposition" $ do + it "correctly detects real transposition" $ + (h1 <=> h1trans) (transpositionOf ~~ 1) + + describe "exact approx" $ do + it "correctly detects exact repetition with approximation - deleted first note" $ + (h1trans <=> h1transdel1) (exactOf ~~ 0.8) + + describe "exact approx" $ do + it "correctly detects exact repetition with approximation - deleted second note" $ + (h1trans <=> h1transdel2) (exactOf ~~ 0.8) + + describe "exact approx" $ do + it "correctly detects exact repetition with approximation - deleted third note" $ + (h1trans <=> h1transdel3) (exactOf ~~ 0.8) + + describe "exact approx" $ do + it "correctly detects exact repetition with approximation - deleted last note" $ + (h1trans <=> h1transdel4) (exactOf ~~ 0.8) + + describe "exact approx" $ do + it "correctly detects exact repetition with approximation - inserted first note" $ + (h1trans <=> h1transins1) (exactOf ~~ 0.8) + + describe "exact approx" $ do + it "correctly detects exact repetition with approximation - inserted first three note" $ + (h1trans <=> h1transins2) (exactOf ~~ 0.7) + + describe "exact approx" $ do + it "correctly detects exact repetition with approximation - inserted last note" $ + (h1trans <=> h1transins3) (exactOf ~~ 0.8) + + describe "transposition approx" $ do + it "correctly detects real transformation with approximation - deleted first note" $ + (h1 <=> h1transdel1) (transpositionOf ~~ 0.8) + + describe "transposition approx" $ do + it "correctly detects real transformation with approximation - deleted second note, middle notes are different from first and last note (changing two intervals ~~ 0.71)" $ + (h1 <=> h1transdel2) (transpositionOf ~~ 0.71) + + describe "transposition approx" $ do + it "correctly detects real transformation with approximation - deleted third note (changing two intervals ~~ 0.71)" $ + (h1 <=> h1transdel3) (transpositionOf ~~ 0.71) + + describe "transposition approx" $ do + it "correctly detects real transformation with approximation - deleted last note" $ + (h1 <=> h1transdel4) (transpositionOf ~~ 0.8) + + describe "transposition approx" $ do + it "correctly detects real transformation with approximation - inserted first note" $ + (h1 <=> h1transins1) (transpositionOf ~~ 0.8) + + describe "transposition approx" $ do + it "correctly detects real transformation with approximation - inserted first three note" $ + (h1 <=> h1transins2) (transpositionOf ~~ 0.7) + + describe "transposition approx" $ do + it "correctly detects real transformation with approximation - inserted last note" $ + (h1 <=> h1transins3) (transpositionOf ~~ 0.8) + + describe "tonal inversion" $ do + it "correctly detects tonal inversion with hanon C" $ + (h1 <=> hback1) (tonalInversionOfCan ~~ 1) + + describe "tonal inversion" $ do + it "correctly detects tonal inversion with hanon D" $ + (h2 <=> hback2) (tonalInversionOfCan ~~ 1) + + describe "inversion" $ do + it "correctly detects real inversion with the triplet" $ + (triplet <=> tripletrealinv) (inversionOf ~~ 1) + + describe "transposed inversion" $ do + it "correctly detects real transposed inversion with the triplet" $ + (triplet <=> tripletrealinvtrans) (trInversionOf ~~ 1) + + describe "rotation" $ do + it "correctly detects rotation with the triplet" $ + (triplet <=> tripletRI) (rotationOf ~~ 1) + + describe "augmentation" $ do + it "correctly detects augmentation with the explicit notes" $ + (cna <=> ca) (augmentationOf ~~ 1) + + describe "augmentation" $ do + it "correctly detects trans augmentation with the explicit notes" $ + (cat <=> ca) (trAugmentationOf ~~ 1) + + + where + h = createPitchesfromScaleDegree 8 36 major [1,3,4,5,6,5,4,3] + h1 = (.@@) [1..] h + h2 = (.@@) [1..] [38,41,43,45,47,45,43,41] + h3 = (.@@) [1..] [40,43,45,47,48,47,45,43] + h4 = (.@@) [1..] [41,45,47,48,50,48,47,45] + h5 = (.@@) [1..] [43,47,48,50,52,50,48,47] + h6 = (.@@) [1..] [45,48,50,52,53,52,50,48] + h7 = (.@@) [1..] [47,50,52,53,55,53,52,50] + hs = [h1, h2, h3, h4, h5, h6, h7] + + triC = (.@@) [1..] [36,40,43] + triD = (.@@) [1..] [38,41,45] + triE = (.@@) [1..] [40,43,47] + triF = (.@@) [1..] [41,45,48] + triG = (.@@) [1..] [43,47,50] + tris = [triC, triD, triE, triF, triG] + + neighBb1 = (.@@) [1..] [34,36,34] + neighBb2 = (.@@) [1..] [36,38,36] + neighBb3 = (.@@) [1..] [38,39,38] + neighBb4 = (.@@) [1..] [39,41,39] + neighBb5 = (.@@) [1..] [41,43,41] + neighBb = [neighBb1, neighBb2, neighBb3, neighBb4, neighBb5] + + neighD1u5d = (.@@) [1..] [38,45,53,45] + neighD2u5d = (.@@) [1..] [40,47,45,47] + neighD3u5d = (.@@) [1..] [42,49,47,49] + neighD4u5d = (.@@) [1..] [43,50,49,50] + neighDu5d = [neighD1u5d, neighD2u5d, neighD3u5d, neighD4u5d] + + neighD1u5u = (.@@) [1..] [38,45,57,45] + neighD2u5u = (.@@) [1..] [40,47,49,47] + neighD3u5u = (.@@) [1..] [42,49,50,49] + neighD4u5u = (.@@) [1..] [43,50,52,50] + neighDu5u = [neighD1u5u, neighD2u5u, neighD3u5u, neighD4u5u] + + neighA1d5d = (.@@) [1..] [45,38,37,38] + neighA2d5d = (.@@) [1..] [47,40,38,40] + neighA3d5d = (.@@) [1..] [49,42,40,42] + neighA4d5d = (.@@) [1..] [50,44,42,44] + neighAd5d = [neighA1d5d, neighA2d5d, neighA3d5d, neighA4d5d] + + reachF1 = (.@@) [1..] [41,46,45] + reachF2 = (.@@) [1..] [43,48,46] + reachF3 = (.@@) [1..] [45,50,48] + reachF = [reachF1, reachF2, reachF3] + + escapeG1 = (.@@) [1..] [43,42,47] + escapeG2 = (.@@) [1..] [45,43,48] + escapeG3 = (.@@) [1..] [47,45,50] + escapeG = [escapeG1, escapeG2, escapeG3] + + launchingEb1 = (.@@) [1..] [39,41,46] + launchingEb2 = (.@@) [1..] [41,43,48] + launchingEb3 = (.@@) [1..] [43,44,50] + launchingEb = [launchingEb1, launchingEb2, launchingEb3] + + landingAm1 = (.@@) [1..] [33,38,40] + landingAm2 = (.@@) [1..] [35,40,41] + landingAm3 = (.@@) [1..] [36,41,43] + landingAm = [landingAm1, landingAm2, landingAm3] + + hback1 = (.@@) [1..] [60,57,55,53,52,53,55,57] + hback2 = (.@@) [1..] [59,55,53,52,50,52,53,55] + + palindromeeven = (.@@) [1..] [60,62,64,64,62,60] + palindromeodd = (.@@) [1..] [60,62,64,62,60] + + h1trans= (.@@) [1..] [37,41,42,44,46,44,42,41] + h1transdel1 = (.@@) [1..] [41,42,44,46,44,42,41] + h1transdel2 = (.@@) [1..] [37,42,44,46,44,42,41] + h1transdel3 = (.@@) [1..] [37,41,42,46,44,42,41] + h1transdel4 = (.@@) [1..] [37,41,42,44,46,44,42] + h1transins1 = (.@@) [1..] [36,37,41,42,44,46,44,42,41] + h1transins2 = (.@@) [1..] [34,35,36,37,41,42,44,46,44,42,41] + h1transins3 = (.@@) [1..] [37,41,42,44,46,44,42,41,40] + + triplet = (.@@) [1..] [60,62,64] + tripletrealinv = (.@@) [1..] [60,58,56] + tripletrealinvtrans = (.@@) [1..] [59,57,55] + tripletRI = (.@@) [1..] [56,58,60] + + cna = (.@@) [1,2,3] [36,40,41] + ca = (.@@) [1,3..] [36,40,41] + cat = (.@@) [1,3..] [38,42,43] + +