hs-pattrans (empty) → 0.1.0.1
raw patch · 14 files changed
+1996/−0 lines, 14 filesdep +Chartdep +Chart-cairodep +Euterpeasetup-changed
Dependencies added: Chart, Chart-cairo, Euterpea, HCodecs, QuickCheck, async, base, bytestring, cassava, colour, containers, contravariant, directory, hs-pattrans, hspec, optparse-applicative, parallel, parsec
Files
- LICENSE +22/−0
- Setup.hs +2/−0
- app/Main.hs +367/−0
- hs-pattrans.cabal +70/−0
- src/Analysis.hs +156/−0
- src/Discovery.hs +76/−0
- src/EuterpeaUtils.hs +41/−0
- src/MIDI.hs +25/−0
- src/Parser.hs +403/−0
- src/Render.hs +124/−0
- src/Transformations.hs +243/−0
- src/Types.hs +192/−0
- test/Spec.hs +1/−0
- test/TransformationsSpec.hs +274/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -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
+ hs-pattrans.cabal view
@@ -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 <melkon.or@gmail.com>+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
+ src/Analysis.hs view
@@ -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+
+ src/Discovery.hs view
@@ -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
+ src/EuterpeaUtils.hs view
@@ -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
+ src/MIDI.hs view
@@ -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++++
+ src/Parser.hs view
@@ -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
+ src/Render.hs view
@@ -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
+ src/Transformations.hs view
@@ -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
+ src/Types.hs view
@@ -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:+ -- <piece>:<expert>:<pattern>.+ 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
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/TransformationsSpec.hs view
@@ -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]+ +