HarmTrace 2.2.0 → 2.2.1
raw patch · 13 files changed
+477/−331 lines, 13 filesdep +matrixdep −HCodecsdep −hmatrixdep −hmatrix-gsl-statsdep ~HarmTrace-Basedep ~basedep ~instant-genericsnew-uploader
Dependencies added: matrix
Dependencies removed: HCodecs, hmatrix, hmatrix-gsl-stats, parseargs
Dependency ranges changed: HarmTrace-Base, base, instant-generics, template-haskell, uu-parsinglib
Files
- CHANGELOG.md +6/−0
- HarmTrace.cabal +30/−73
- README +0/−23
- README.md +103/−0
- src/Constants.hs +22/−22
- src/HarmTrace/Audio/ChromaChord.hs +83/−85
- src/HarmTrace/Audio/ChromaKey.hs +24/−19
- src/HarmTrace/Audio/VectorNumerics.hs +103/−0
- src/HarmTrace/HarmTrace.hs +13/−13
- src/HarmTrace/IO/Recognise.hs +1/−4
- src/HarmTrace/Models/Jazz/Instances.hs +46/−46
- src/HarmTrace/Models/Pop/Instances.hs +44/−44
- src/Main.hs +2/−2
+ CHANGELOG.md view
@@ -0,0 +1,6 @@+# CHANGELOG + +2.2.1 + + * Made HarmTrace compile again using Stack. + * updated README.md
HarmTrace.cabal view
@@ -1,7 +1,7 @@ name: HarmTrace -version: 2.2.0 +version: 2.2.1 synopsis: Harmony Analysis and Retrieval of Music -description: HarmTrace: Harmony Analysis and Retrieval of Music +description: HarmTrace: Harmony Analysis and Retrieval of Music with Type-level Representations of Abstract Chords Entities . @@ -17,6 +17,7 @@ copyright: (c) 2010--2013 Universiteit Utrecht, 2012--2013 University of Oxford + 2016 Chordify BV license: GPL-3 license-file: LICENSE author: W. Bas de Haas and Jose Pedro Magalhaes @@ -24,11 +25,13 @@ maintainer: bash@cs.uu.nl, jpm@cs.ox.ac.uk homepage: http://www.cs.uu.nl/wiki/GenericProgramming/HarmTrace category: Music -build-type: Custom +build-type: Simple cabal-version: >= 1.6 -tested-with: GHC == 7.0.3, GHC == 7.2.1, GHC == 7.4.1, GHC == 7.6.1 +tested-with: GHC == 7.0.3, GHC == 7.2.1, GHC == 7.4.1, GHC == 7.6.1, + GHC == 7.10 -extra-source-files: README +extra-source-files: README.md + CHANGELOG.md executable harmtrace hs-source-dirs: src @@ -45,6 +48,7 @@ HarmTrace.Audio.Key HarmTrace.Audio.Evaluation HarmTrace.Audio.Statistical + HarmTrace.Audio.VectorNumerics HarmTrace.Base.Instances @@ -87,77 +91,30 @@ HarmTrace.Models.Pop.Model main-is: Main.hs - build-depends: base >= 4.2 && < 4.7, template-haskell >=2.4 && <2.9, - mtl, directory, filepath, array, parallel >= 3, - Diff == 0.1.*, cmdargs >= 0.10.1, process >= 1.0, - uu-parsinglib == 2.7.4.*, ListLike >= 3.0.1, - vector >= 0.7, deepseq, sox >= 0.2.2.2, - instant-generics >= 0.3.6 && < 0.4, binary >= 0.6.4, - hmatrix >= 0.11.0.3, hmatrix-gsl-stats >= 0.1.2.9, - HarmTrace-Base >= 1.0.0.2, ghc-prim >= 0.2 + build-depends: base >= 4.2 && < 5, + template-haskell >=2.4 && < 2.11, + mtl, + directory, + filepath, + array, + parallel >= 3, + Diff == 0.1.*, + cmdargs >= 0.10.1, + process >= 1.0, + uu-parsinglib >= 2.7.4, + ListLike >= 3.0.1, + vector >= 0.7, + deepseq, + matrix >= 0.3.4, + sox >= 0.2.2.2, + instant-generics >= 0.6, + binary >= 0.6.4, + HarmTrace-Base < 1.2, + -- statistics >= 0.13, + ghc-prim >= 0.2 ghc-options: -Wall -O2 -fno-spec-constr-count -funbox-strict-fields -fcontext-stack=50 -threaded -feager-blackholing -rtsopts - ghc-prof-options: -auto-all - - -library --- Note the extreme duplication of information --- I don't think there's much we can do about that - build-depends: base >= 4.2 && < 4.7, template-haskell >=2.4 && <2.9, - mtl, directory, filepath, array, parallel >= 3, - Diff == 0.1.*, parseargs >= 0.1.3.2, process >= 1.0, - uu-parsinglib == 2.7.4.*, ListLike >= 3.0.1, - vector >= 0.7, deepseq, HCodecs >= 0.2.2, - instant-generics >= 0.3.6 && < 0.4, binary >= 0.6.4, - hmatrix >= 0.11.0.3, hmatrix-gsl-stats >= 0.1.2.9, - HarmTrace-Base >= 1.0.0.2, ghc-prim >= 0.2 - - ghc-options: -Wall - -O2 -fno-spec-constr-count -funbox-strict-fields - -fcontext-stack=50 - -feager-blackholing -rtsopts - - ghc-prof-options: -auto-all - - hs-source-dirs: src - - exposed-modules: HarmTrace.Audio.Annotate - HarmTrace.Audio.AnnotationParser - HarmTrace.Audio.DataParser - HarmTrace.Audio.ChromaChord - HarmTrace.Audio.ChromaKey - HarmTrace.Audio.Key - HarmTrace.Audio.Evaluation - HarmTrace.Audio.Statistical - - HarmTrace.Base.Instances - - HarmTrace.HAnTree.HAn - HarmTrace.HAnTree.HAnParser - HarmTrace.HAnTree.PostProcess - HarmTrace.HAnTree.ToHAnTree - HarmTrace.HAnTree.Tree - - HarmTrace.Matching.Alignment - HarmTrace.Matching.HChord - HarmTrace.Matching.Sim - HarmTrace.Matching.SimpleChord - HarmTrace.Matching.Standard - HarmTrace.Matching.GuptaNishimura - - HarmTrace.Models.Models - HarmTrace.Models.Parser - HarmTrace.Models.ChordTokens - HarmTrace.Models.TypeLevel - - HarmTrace.Models.Jazz.Instances - HarmTrace.Models.Jazz.Main - HarmTrace.Models.Jazz.Model - - HarmTrace.Models.Pop.Instances - HarmTrace.Models.Pop.Main - HarmTrace.Models.Pop.Model
− README
@@ -1,23 +0,0 @@-HarmTrace (Harmony Analysis and Retrieval of Music with Type-level -Representations of Abstract Chords Entities) is a system for automatic harmony -analysis of music. It takes a sequence of chords as input and produces a harmony -analysis, which can be visualised as a tree. - -Music theory has been essential in composing and performing music for centuries. -Within Western tonal music, from the early Baroque on to modern-day jazz and pop -music, the function of chords within a chord sequence can be explained by -harmony theory. Although Western tonal harmony theory is a thoroughly studied -area, formalising this theory is a hard problem. - -With HarmTrace we have developed a formalisation of the rules of tonal harmony -as a Haskell (generalized) algebraic datatype. Given a sequence of chord labels, -the harmonic function of a chord in its tonal context is automatically derived. -For this, we use several advanced functional programming techniques, such as -type-level computations, datatype-generic programming, and error-correcting -parsers. Our functional model of harmony offers various benefits: it can be used -to define harmonic similarity measures and facilitate music retrieval, or it can -help musicologists in batch-analysing large corpora of digitised scores, for -instance. - -More information about HarmTrace, including how to use and example output, is -available on its webpage: http://www.cs.uu.nl/wiki/GenericProgramming/HarmTrace
+ README.md view
@@ -0,0 +1,103 @@+# Introduction + +HarmTrace (Harmony Analysis and Retrieval of Music with Type-level +Representations of Abstract Chords Entities) is a system for automatic harmony +analysis of music. It takes a sequence of chords as input and produces a harmony +analysis, which can be visualised as a tree. + + +Music theory has been essential in composing and performing music for centuries. +Within Western tonal music, from the early Baroque on to modern-day jazz and pop +music, the function of chords within a chord sequence can be explained by +harmony theory. Although Western tonal harmony theory is a thoroughly studied +area, formalising this theory is a hard problem. + + +With HarmTrace we have developed a formalisation of the rules of tonal harmony +as a Haskell (generalized) algebraic datatype. Given a sequence of chord labels, +the harmonic function of a chord in its tonal context is automatically derived. +For this, we use several advanced functional programming techniques, such as +type-level computations, datatype-generic programming, and error-correcting +parsers. Our functional model of harmony offers various benefits: it can be used +to define harmonic similarity measures and facilitate music retrieval, or it can +help musicologists in batch-analysing large corpora of digitised scores, for +instance. + + +HarmTrace is covered in depth in the following papers: + +de Haas, W. B., et al. "Automatic Functional Harmonic Analysis." +_[Computer Music Journal](http://www.mitpressjournals.org/doi/10.1162/COMJ_a_00209)_ +37.4 (2013): 37-53. +([PDF](http://www.mitpressjournals.org/doi/pdf/10.1162/COMJ_a_00209)) + +Magalhaes, J. P., & de Haas, W. B. (2011, September). Functional modelling of +musical harmony: an experience report. In +_[ACM SIGPLAN Notices](http://dl.acm.org/citation.cfm?id=2034797&dl=ACM&coll=DL&CFID=792765209&CFTOKEN=90344854)_ +(Vol. 46, No. 9, pp. 156-162). ACM. +([PDF](http://www.cs.uu.nl/groups/MG/multimedia/publications/art/icfp2011.pdf)) + +# Installation + +Because the main authors of HarmTrace are are no longer affiliated with +academic institutions and HarmTrace is only modestly maintained, installing +Harmtrace can be a challenge. However, [Stack]( +https://docs.haskellstack.org/en/stable/README/) helps considerably. One of +the difficulties is that HarmTrace currently only build on a relatively old +version of GHC, namely 7.10. Provided that you have intalled a Haskell system +and pulled this repository, Stack should take care of it: + +`stack init --solver --install-ghc` + +`stack build` + +# Running HarmTrace + +You can use Stack to run HarmTrace: + +``` +>>> stack exec harmtrace +harmtrace [COMMAND] ... [OPTIONS] + Harmonic Analysis and Retrieval of Music + +Commands: + parse Parse files into harmonic analysis trees + match Harmonic similarity matching + recognise Recognise chords from audio files + + -r=file File to read flags from + -? --help Display help message + -V --version Print version information +``` + +All modes have separate help pages: +``` +>>> stack exec harmtrace parse -- --help +parse [OPTIONS] + Parse files into harmonic analysis trees + + -g --grammar=string Grammar to use (jazz|pop) + -c --chords=string Input chord sequence to parse + -i --file=filepath Input file to parse + -d --dir=filepath Input directory to parse all files within + -o --out=filepath Output binary file to write parse results to + -k --key=filepath Ground-truth key annotation file + -x --key-dir=filepath Ground-truth key annotation directory + -p --print Output a .png of the parse tree + -s --print-insertions Show inserted nodes + -r=file File to read flags from + -? --help Display help message + -V --version Print version information +``` + +You can parse a chord sequence with `--chords` the chord should be in [Harte +syntax](http://ismir2005.ismir.net/proceedings/1080.pdf) suffixed with a +`;INT` indicating the duration of the chord and separated by spaces. The +first 'chord' represents a key signature. For instance: +``` +>>> stack exec harmtrace parse -- --grammar=jazz --chords="C:maj D:min;1 G:7;2 C:maj;1" +parsed 3 chords into 1 analysis tree(s) +[Piece[PD[D_1_1[S_1par_1[IIm_1[D:min]]][D_2_1[V7_2[G:7]]]]][PT[T_1_1[I_1[C:maj]]]]] +``` +If you add `--print`, HarmTrace will render a .PNG image for you using +[http://ironcreek.net/phpsyntaxtree/](http://ironcreek.net/phpsyntaxtree/)
src/Constants.hs view
@@ -34,13 +34,13 @@ vERSION = gitVersion ++ " (master)" gitVersion :: String -gitVersion = "HarmTrace-2.0-145-g3a005f7" +gitVersion = "HarmTrace-2.2.0" -------------------------------------------------------------------------------- -- Chord Transcription Parameters -------------------------------------------------------------------------------- --- | The cutOffProbability is the value that determines the length of the +-- | The cutOffProbability is the value that determines the length of the -- probChord list (a sorted list with normalised distances to the chroma vector) cutOffProbability :: NumData cutOffProbability = 0.85 @@ -50,13 +50,13 @@ maxProbChordListLength = 6 -- | The maximum size of a list of chord candidate lists (of which all possible --- combinations will be parsed). If, in the segmentation procedure, this --- threshold is crossed an 'emergency split' will be made (see +-- combinations will be parsed). If, in the segmentation procedure, this +-- threshold is crossed an 'emergency split' will be made (see -- Harmtrace.Audio.Annotate.emergencySplit for details) maxSegmentSize = 12 --- | Chord candidate list segments can contain long and short chord candidate --- lists. This strongly influences the number of considered chord sequence +-- | Chord candidate list segments can contain long and short chord candidate +-- lists. This strongly influences the number of considered chord sequence -- combinations, i.e. the LProductSize. If the number of possible combinations -- becomes greater than the 'maxLProductSize' also an 'emergency split' will -- be made, similar to maxSegmentSize. @@ -69,7 +69,7 @@ evaluationSampleRate, displaySampleRate :: NumData -- | The sample rate used in a normal (non-visual) comparison (in seconds). evaluationSampleRate = 0.01 --- | The sample rate used when visually comparing a chord annotation with a +-- | The sample rate used when visually comparing a chord annotation with a -- ground-truth annotation. Often a higher sample rate is preferred. Although -- one uses precision, the visual result is easier to read. displaySampleRate = 0.3 @@ -80,12 +80,12 @@ -------------------------------------------------------------------------------- outputSampleRate, outputBitsPerSample, outputNrOfChannels :: Int --- | Before feature extraction, all audio is downsampled to 'outputSampleRate' +-- | Before feature extraction, all audio is downsampled to 'outputSampleRate' -- Hz. N.B. If the sample rate is changed the VAMP plugin transforms should be -- updated accordingly (see 'beat', 'chroma', 'key'). outputSampleRate = 22050 --- | Before feature extraction, all audio is converted to contain +-- | Before feature extraction, all audio is converted to contain -- 'outputBitsPerSample' bits per sample. outputBitsPerSample = 16 @@ -93,12 +93,12 @@ -- of channels, e.g. 1 for mono or 2 for stereo. outputNrOfChannels = 1 --- | Controls whether the downsampled wav file is deleted after feature +-- | Controls whether the downsampled wav file is deleted after feature -- extraction. deleteDownsampledWav, downSample :: Bool deleteDownsampledWav = True --- | Controls whether SoX is used to downsample the audio or whether the +-- | Controls whether SoX is used to downsample the audio or whether the -- audio file is passed to the sonic annotator directly. If 'downSample is -- set to False, all paramters downsampling parameters will be ignored downSample = True @@ -107,20 +107,20 @@ keyStr, chromaStr, beatStr :: String chromaStr = "_vamp_nnls-chroma_nnls-chroma_bothchroma.csv" keyStr = "_vamp_nnls-chroma_nnls-chroma_chroma.csv" --- beatStr = "_vamp_qm-vamp-plugins_qm-tempotracker_beats.csv" +-- beatStr = "_vamp_qm-vamp-plugins_qm-tempotracker_beats.csv" beatStr = "_vamp_qm-vamp-plugins_qm-barbeattracker_beats.csv" beatVampPath, chromaVampPath, keyVampPath :: FilePath -- | specifying the filename of the beat tracker VAMP plugin transform file -beatVampPath = "beat-tracker-one.txt" +beatVampPath = "beat-tracker-one.txt" -- | specifying the filename of the NNLS chroma VAMP plugin transform file -chromaVampPath = "both-chroma.txt" +chromaVampPath = "both-chroma.txt" -- | specifying the filename of the key-finding chroma VAMP plugin transform file keyVampPath = "tuned-chroma.txt" - + defaultVampDir, defaultLogDir, defaultOutDir, defaultFeatDir :: FilePath -- | The default base directory is the current directory -defaultVampDir = "" +defaultVampDir = "" defaultOutDir = "" defaultLogDir = "" defaultFeatDir = "" @@ -134,7 +134,7 @@ data ChordPrintOpts = PrintMajMin | PrintChordClass -- | By default we only display major and minor chords to the user (because --- the transcription quality of these chords is better than that of the +-- the transcription quality of these chords is better than that of the -- chord class). defaultChordPrinting :: ChordPrintOpts defaultChordPrinting = PrintMajMin @@ -143,12 +143,12 @@ -- Chroma key estimation -------------------------------------------------------------------------------- --- | The penatly given in the cumulative key strength calculation. For every --- beat the correlation between a Krumhansl profile and the current beat --- synchronised chroma feature is calculated for all 24 keys at every beat. --- An optimal path through this table can be defined as: +-- | The penatly given in the cumulative key strength calculation. For every +-- beat the correlation between a Krumhansl profile and the current beat +-- synchronised chroma feature is calculated for all 24 keys at every beat. +-- An optimal path through this table can be defined as: -- $M[i,j] = max \{ M[i-1,j] + K[i,j], --- M[i-1,j] + K[i,k] + p, } +-- M[i-1,j] + K[i,k] + p, } -- where \{k \mid \forall x : K[i,x] \leq K[i,k]\}$ -- where $p$ is the modulationPenalty, i.e. the penalty for changing the key -- at that particular beat.
src/HarmTrace/Audio/ChromaChord.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} -------------------------------------------------------------------------------- @@ -13,17 +14,15 @@ -- Summary: Recognise audio chroma vectors into textual chord descriptions. -------------------------------------------------------------------------------- -module HarmTrace.Audio.ChromaChord ( createChordRanks, beatSync +module HarmTrace.Audio.ChromaChord ( createChordRanks + , beatSync -- , mergeByBeat , meanBeatSyncVectors , mergeByOneAndThree - -- , addBeatTimeStamp - , module Numeric.LinearAlgebra - , module Numeric.GSL.Statistics ) where import Constants (maxProbChordListLength, cutOffProbability) - + import HarmTrace.Audio.DataParser (shift) import HarmTrace.Base.MusicTime import HarmTrace.Base.MusicRep @@ -32,24 +31,22 @@ import Data.List (sortBy,find) -- , elemIndices, minimumBy) import Data.Maybe (mapMaybe) import Data.Ord (comparing) -import Data.Functor ((<$>)) --- http://hackage.haskell.org/package/hmatrix -import Numeric.LinearAlgebra hiding (find) --- import qualified Numeric.GSL.Statistics as GSL hiding (mean) -import Numeric.GSL.Statistics hiding (mean) +import HarmTrace.Audio.VectorNumerics +import Data.Vector ( Vector, slice, generate ) +import Data.Matrix ( Matrix, fromLists, ncols, nrows, getCol, prettyMatrix ) -------------------------------------------------------------------------------- -- Matching chords and chroma --------------------------------------------------------------------------------- - --- | Synchronises the 'ChordinoData' with the list of beats +-------------------------------------------------------------------------------- + +-- | Synchronises the 'ChordinoData' with the list of beats -- by grouping the 'ChordinoLines' of the 'ChordinoData' in separate lists. beatSync :: BarTimeTrackData -> [ChordinoLine] -> [BeatChroma] -- = [TimedData ChordinoLine] beatSync _ [] = [] beatSync [] _ = error "HarmTrace.Audio.ChromaChord: no beat tracker data" beatSync bt cs = beatTime fstBeat syncbt beatAlignedChroma where - + fstBeat = BarTime 0 (prevBeat . beat . head $ bt) lstBeat = BarTime (time . last $ cs) (nextBeat . beat . last $ bt) syncbt = takeWhile (< lstBeat) bt ++ [lstBeat] @@ -62,22 +59,22 @@ groupChroma [] _ c = [c] -- TODO: prv should be first arg groupChroma (b:bs) prv c -- we also store the previous group in case beat < time | null x = prv : groupChroma bs prv c -- Why do we need this? - | otherwise = x : groupChroma bs x xs - where (x, xs) = span ((b >=) . time) c - + | otherwise = x : groupChroma bs x xs + where (x, xs) = span ((b >=) . time) c + -- given beatTracker data and a grouped chroma, the grouped chroma is wrapped -- into a TimedData type beatTime :: BarTime -> [BarTime] -> [a] -> [TimedData a] -- TODO replace last by this case - -- beatTime (BarTime (on, onbt)) [] [c] = TimedData c onbt on (time . last $ c) + -- beatTime (BarTime (on, onbt)) [] [c] = TimedData c onbt on (time . last $ c) beatTime _ [] [] = [] beatTime (BarTime on onbt) (next@(BarTime off _) : bs) (x : xs) = TimedData x [BarTime on onbt, BarTime off (nextBeat onbt)] : beatTime next bs xs beatTime _ _ _ = error "beatSync: asynchronous beats and data" - - + + -- | Merges chord segments, adding a bias toward merging at the first --- and the third 'Beat' +-- and the third 'Beat' mergeByOneAndThree :: [TimedData [ProbChord]] -> [TimedData [ProbChord]] mergeByOneAndThree = mergeByBeat canMerge intersectPC where -- specifies which combinations of beats are allowed to merge @@ -89,29 +86,29 @@ -- Conditionally combines lists wrapped in a 'BeatTimeData' in a list. The first -- argument should determine at which combinations of beats the merging function -- (the second argument) should be applied. N.B. this function cannot --- be rewritten with a foldr, because the outcome is dependend of the --- left-to-right processing. Rewriting the function with foldl makes the --- whole recognition process about 1/3 slower... -mergeByBeat :: (Beat -> Beat -> Bool) -> ([a] -> [a] -> [a]) +-- be rewritten with a foldr, because the outcome is dependend of the +-- left-to-right processing. Rewriting the function with foldl makes the +-- whole recognition process about 1/3 slower... +mergeByBeat :: (Beat -> Beat -> Bool) -> ([a] -> [a] -> [a]) -> [TimedData [a]] -> [TimedData [a]] mergeByBeat _ _ [] = [] mergeByBeat _ _ [a] = [a] -mergeByBeat canMerge merge (x:y:xs) - | canMerge (getBeat x) (getBeat y) +mergeByBeat canMerge merge (x:y:xs) + | canMerge (getBeat x) (getBeat y) && not (null m) = mergeByBeat canMerge merge (xy:xs) - | otherwise = x : mergeByBeat canMerge merge ( y:xs) + | otherwise = x : mergeByBeat canMerge merge ( y:xs) where xy = TimedData m (getTimeStamps x ++ (tail . getTimeStamps $ y)) m = merge (getData x) (getData y) --- | Calculates the intersection of to ['ProbChord]' N.B. because of the --- set-based nature of the function the function is rather expensive, luckily +-- | Calculates the intersection of to ['ProbChord]' N.B. because of the +-- set-based nature of the function the function is rather expensive, luckily -- the length of the ['ProbChord'] is constant. Also, because the intersection --- might change the order of the 'ProbChord's we sort the list again +-- might change the order of the 'ProbChord's we sort the list again -- descendingly intersectPC :: [ProbChord] -> [ProbChord] -> [ProbChord] -intersectPC a b = reverse . sortBy (comparing prob) - $ mapMaybe (findAndMerge a') b' where - (a',b') = order a b +intersectPC a b = reverse . sortBy (comparing prob) + $ mapMaybe (findAndMerge a') b' where + (a',b') = order a b -- N.B. the probabilities are not divided by their length so > 1, -- due to the addition findAndMerge :: [ProbChord] -> ProbChord -> Maybe ProbChord @@ -128,82 +125,82 @@ -------------------------------------------------------------------------------- -- Matrix Functions for matching chords --------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- --- | Having a matrix of beat-synchronised bass and treble chromagrams and a +-- | Having a matrix of beat-synchronised bass and treble chromagrams and a -- chord dictionary, the probability of a chord sounding at a particular beat is --- estimated by calculating the Euclidean distance between the chord structures --- and the chroma feature. These distances are calculated for every chord --- candidate at every beat. Next, we sort the chord candidates by descending --- Euclidean distance. To obtain a relative measure of the fit +-- estimated by calculating the Euclidean distance between the chord structures +-- and the chroma feature. These distances are calculated for every chord +-- candidate at every beat. Next, we sort the chord candidates by descending +-- Euclidean distance. To obtain a relative measure of the fit -- between a chord candidate and the chroma vector in the range [0,1], --- the distances are normalised by dividing them by distance of the best --- matching chord candidate. +-- the distances are normalised by dividing them by distance of the best +-- matching chord candidate. createChordRanks :: [BeatChroma] -> [TimedData [ProbChord]] -createChordRanks = - map (selectTop . normalize . sortTake . matchCDictionary <$>) . meanBeatSyncVectors +createChordRanks = + map (selectTop . normalize . sortTake . matchCDictionary <$>) . meanBeatSyncVectors where -- here prob is still (unnormalised) euclidean distance - sortTake, normalize :: [ProbChord] -> [ProbChord] + sortTake, normalize :: [ProbChord] -> [ProbChord] sortTake = take maxProbChordListLength . sortBy (comparing prob) - normalize l@(h:_) = let ph = prob h in map (\p -> p{prob = ph / prob p }) l + normalize l@(h:_) = let ph = prob h in map (\p -> p{prob = ph / prob p }) l normalize [] = [] - + selectTop l -- selects the everything with a probability > x - | null s = none + | null s = none -- so far, this had not positive effect - -- length s > maxProbChordListLength = none + -- length s > maxProbChordListLength = none | otherwise = s - where s = takeWhile ((> cutOffProbability) . prob) l + where s = takeWhile ((> cutOffProbability) . prob) l none = [ProbChord noneLabel 0.0] -- takes the mean of every "beat block" and these Vectors as one Matrix -- Each row of this matrix corresponds to the chroma within one beat -- N.B. BeatChroma = BeatTimeData ChordinoLine -meanBeatSyncVectors :: [BeatChroma] -> [TimedData (Vector NumData)] -meanBeatSyncVectors = map (mean <$>) . beatSyncMatrix - +meanBeatSyncVectors :: [BeatChroma] -> [TimedData (Vector NumData)] +meanBeatSyncVectors = map (meanMat <$>) . beatSyncMatrix + -- creates a list of matrices, in which each matrix corresponds to the -- collection of chroma vectors within one beat (drop the time stamp) beatSyncMatrix :: [BeatChroma] -> [TimedData (Matrix NumData)] -beatSyncMatrix = map (dropColumns 1 . toChromaMatrix <$>) +beatSyncMatrix = map (toChromaMatrix <$>) -- converts a ChordinoData into a Matrix toChromaMatrix :: [ChordinoLine] -> Matrix NumData toChromaMatrix = fromLists . map mergeLine where mergeLine :: ChordinoLine -> [NumData] - mergeLine (ChordinoLine tm bs tb) = tm : bs ++ tb - + mergeLine (ChordinoLine tm bs tb) = bs ++ tb + -- matches all transpositions of a chord structure with a chroma vector matchCDictionary :: Vector NumData -> [ProbChord] matchCDictionary v = map (matchStruct v) chordDictionary --- calculate an Euclidean (PNorm2) norm +-- calculate an Euclidean (PNorm2) norm -- I also tried using the maximum norm, but this gave inferior results matchStruct :: Vector NumData -> ChordCand -> ProbChord -matchStruct chroma (ChordCand r _ir None cs) = - ProbChord (Chord r None [] 0 1) (pnorm PNorm2 (chroma - fromList (cs ++ cs))) -matchStruct chroma (ChordCand r _ir sh cs) = +matchStruct chroma (ChordCand r _ir None cs) = + ProbChord (Chord r None [] 0 1) (norm2 (chroma - fromList (cs ++ cs))) +matchStruct chroma (ChordCand r _ir sh cs) = -- Chord root shorthand degrees location duration -- ProbChord (Chord r sh [] 0 1) (sqrt (bss * bss + treble * treble)) ProbChord (Chord r sh [] 0 1) ((bss + treble) * 0.5) - where treble = pnorm PNorm2 (subVector 12 12 chroma - fromList cs) - - (_ir,bss) = matchInv r + where treble = norm2 (slice 12 12 chroma - fromList cs) + (_ir,bss) = matchInv r + -- calculates the euclidean distance between the bass chromagram -- and all bass note inversions. matchInv :: Root -> (Root, NumData) - matchInv ir = (ir, pnorm PNorm2 (subVector 0 12 chroma - bcs)) where + matchInv ir = (ir, norm2 (slice 0 12 chroma - bcs)) where bcs = fromList (pre ++ [1.0] ++ tail post) (pre, post) = splitAt (toSemitone ir) (shortHandToCS None) - -- For a given chord structure, compute all possible + -- For a given chord structure, compute all possible -- roots for inversions -- rootInvs :: ChordStruct -> [Root] -- rootInvs cs = map iThRoot (elemIndices 1 cs) - + -------------------------------------------------------------------------------- -- The Chord Dictionary -------------------------------------------------------------------------------- @@ -211,12 +208,12 @@ -- the chord dictionary of all chords that are matched chordDictionary :: [ChordCand] chordDictionary = concatMap transpose12 [minBound..] -- all shorthands :-) - + -- takes a ChordStruct and returns a list containing the 12 transposed versions -- (including the original) of the ChordStruct, times the number of possible -- inversions (3 or 4, depending on the number of notes in the shorthand). transpose12 :: Shorthand -> [ChordCand] -transpose12 sh +transpose12 sh | null cstruct = [] | sh == None = [ChordCand (Note Nothing N) (Note Nothing N) None cstruct] | otherwise = concatMap mkChordCands [0..11] @@ -231,24 +228,24 @@ r = toRoot n shortHandToCS :: Shorthand -> ChordStruct -shortHandToCS sh = case sh of +shortHandToCS sh = case sh of -- 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11 -- C, Db, D, Eb, E, F, F#, G, Ab, A, Bb, B - Maj -> [1.5, 0, 0.5, 0, 1.0, 0, 0, 1.5, 0, 0.5, 0, 0.5 ] + Maj -> [1.5, 0, 0.5, 0, 1.0, 0, 0, 1.5, 0, 0.5, 0, 0.5 ] Min -> [1.5, 0, 0 , 1.0, 0 , 0, 0, 1.5, 0, 0 , 1.0, 0 ] - Sev -> [1.5, 0, 0 , 0, 1.0, 0, 0, 1.5, 0, 0.0, 1.0, 0 ] - -- Dim -> [1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0 ] - -- HDim7 -> [1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 1, 0 ] - -- Dim -> [1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0 ] - -- Maj6 -> [1, 0, 0, 0, 1, 0, 0, 1, 0, 1, 0, 0 ] - -- Dim7 -> [1, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0 ] - -- Maj7 -> [1, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 1 ] + Sev -> [1.5, 0, 0 , 0, 1.0, 0, 0, 1.5, 0, 0.0, 1.0, 0 ] + -- Dim -> [1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0 ] + -- HDim7 -> [1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 1, 0 ] + -- Dim -> [1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0 ] + -- Maj6 -> [1, 0, 0, 0, 1, 0, 0, 1, 0, 1, 0, 0 ] + -- Dim7 -> [1, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0 ] + -- Maj7 -> [1, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 1 ] -- Min7 -> [1, 0, 0, 1, 0, 0, 0, 1, 0, 0, 1, 0 ] -- Min6 -> [1, 0, 0, 1, 0, 0, 0, 1, 0, 1, 0, 0 ] - -- Sus4 -> [1, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 0 ] - - None -> [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ] - -- None -> [1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ] + -- Sus4 -> [1, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 0 ] + + None -> [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ] + -- None -> [1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ] _ -> [] -- none -- all @@ -258,7 +255,8 @@ -- general Matrix stuff -------------------------------------------------------------------------------- --- given a matrix, calculates the mean vector -mean :: (Product t, Fractional t) => Matrix t -> Vector t -mean a = constant (recip . fromIntegral . rows $ a) (rows a) <> a - +-- given a matrix, calculates the mean vector +meanMat :: forall t. (Fractional t, Num t, Show t) => Matrix t -> Vector t +meanMat m = generate (ncols m) vmean where + vmean :: Int -> t + vmean i = mean (getCol (i+1) m)
src/HarmTrace/Audio/ChromaKey.hs view
@@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | --- Module : HarmTrace.Audio.ChromaKey +-- Module : HarmTrace.Audio.ChromaKey -- Copyright : (c) 2010-2012 Universiteit Utrecht, 2012 University of Oxford -- License : GPL3 -- @@ -14,56 +14,61 @@ module HarmTrace.Audio.ChromaKey ( beatSyncKeyStrength, keyMap ) where -import HarmTrace.Audio.ChromaChord ( Vector, fromList, correlation - , beatSync, meanBeatSyncVectors +import HarmTrace.Audio.ChromaChord ( beatSync + , meanBeatSyncVectors ) + +import Data.Vector ( Vector, fromList ) import HarmTrace.Base.MusicTime import HarmTrace.Base.MusicRep - +-- import Statistics.Correlation ( pearson ) -------------------------------------------------------------------------------- -- Chroma key estimation -------------------------------------------------------------------------------- --- | Calculates the beat synchronised key strenght for all +-- TODO implement a pearson correlation coefficient +pearson = undefined + +-- | Calculates the beat synchronised key strenght for all -- 24 keys (ordered by 'KeyMap'). beatSyncKeyStrength :: BarTimeTrackData -> ChordinoData -> [TimedData [NumData]] -beatSyncKeyStrength bts key = +beatSyncKeyStrength bts key = map matchKeyProfiles . meanBeatSyncVectors $ beatSync bts key where - + -- canMerge :: Beat -> Beat -> Bool -- canMerge One Two = True -- canMerge One Three = True -- canMerge One Four = True -- canMerge _ _ = False - + nanToZero :: Double -> NumData nanToZero n = if isNaN n then 0 else n - + matchKeyProfiles :: TimedData (Vector NumData) -> TimedData [NumData] -- matchKeyProfiles chroma = map (\x -> pnorm PNorm2 (chroma - x)) allKeyProfiles -- matchKeyProfiles crm = map (nanToZero . GSL.correlation crm) allKeyProfiles -- matchKeyProfiles crm = map (nanToZero . correlation crm) allKeyProfiles -matchKeyProfiles = fmap (\x -> map (nanToZero . correlation x) allKeyProfiles) +matchKeyProfiles = fmap (\x -> map (nanToZero . pearson x) allKeyProfiles) allKeyProfiles :: [Vector Double] -allKeyProfiles = map (fromList . keyToProfile) keyMap - -keyToProfile :: Key -> [Double] -keyToProfile (Key root m) = reverseShift (toSemitone root) (selectProfile m) +allKeyProfiles = map (fromList . keyToProfile) keyMap + +keyToProfile :: Key -> [Double] +keyToProfile (Key root m) = reverseShift (toSemitone root) (selectProfile m) where reverseShift :: Int -> [a] -> [a] - reverseShift p l = b ++ a where (a,b) = splitAt (length l - p) l + reverseShift p l = b ++ a where (a,b) = splitAt (length l - p) l selectProfile :: Mode -> [Double] selectProfile MajMode = temperleyProfCMaj selectProfile MinMode = temperleyProfCMin - + -- krumhanslProfCMaj, krumhanslProfCMin :: [NumData] --- krumhanslProfCMaj = +-- krumhanslProfCMaj = -- [6.35, 2.23, 3.48, 2.33, 4.38, 4.09, 2.52, 5.19, 2.39, 3.66, 2.29, 2.88] --- krumhanslProfCMin = +-- krumhanslProfCMin = -- [6.33, 2.68, 3.52, 5.38, 2.60, 3.53, 2.54, 4.75, 3.98, 2.69, 3.34, 3.17] - + temperleyProfCMaj, temperleyProfCMin :: [Double] temperleyProfCMaj = [5.0, 2.0, 3.5, 2.0, 4.5, 4.0, 2.0, 4.5, 2.0, 3.5, 1.5, 4.0 ]
+ src/HarmTrace/Audio/VectorNumerics.hs view
@@ -0,0 +1,103 @@+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} + +module HarmTrace.Audio.VectorNumerics ( -- Matrix + -- , Vector + -- , ix + -- disp + -- , dispf + -- | * Numerical calculation + scale + , sum + , mean + , norm2 + , Num () + -- | * Utilities + -- | * List converstions + -- , fromLists + -- , toLists + , V.fromList + ) where + +import qualified Data.Vector as V +import Data.Vector ( Vector ) +-- import Data.List ( intercalate ) +-- import Text.Printf ( printf, PrintfArg ) +import Prelude hiding (sum) +{- +-- | A matrix is a Vector of Vectors, we could also use one large Vector with +-- another 'ix' function +type Matrix a = Vector (Vector a) + +-- | Displaying a matrix +disp :: Show a => Matrix a -> String +disp = disp' dispRow + + where dispRow :: Show a => Vector a -> String + dispRow = intercalate " " . V.foldr (\j js -> show j : js ) [] + +-- | Displaying a matrix +dispf :: PrintfArg a => Matrix a -> String +dispf = disp' dispRow + + where dispRow :: PrintfArg a => Vector a -> String + dispRow = concat . V.foldr (\j js -> printf "\t%.2f" j : js ) [] + +-- | Displaying a matrix +disp :: (Vector a -> String) -> Matrix a -> String +disp dispRow = intercalate "\n" . V.foldr (\i is -> dispRow i : is) ["\n"] +-} +-- | replaces a 0.0 by a very small number 1.0e-10 +-- replaceZero :: Vector Prob -> Vector Prob +-- replaceZero = V.map repl where + + -- repl :: Prob -> Prob + -- repl 0.0 = 1.0e-10 + -- repl p = p + +-------------------------------------------------------------------------------- +-- Numerical Vectors +-------------------------------------------------------------------------------- + +-- using a Matrix +instance Num a => Num (Vector a) where + va + vb = mergeVectorsSameSize (+) va vb + va - vb = mergeVectorsSameSize (-) va vb + va * vb = mergeVectorsSameSize (*) va vb + signum = V.map signum + negate = V.map negate + abs = V.map abs + fromInteger = V.singleton . fromInteger + +-- | Scales a numerical Vector +scale :: Num a => a -> Vector a -> Vector a +scale s = V.map (s *) + +-- | Sums the elements of the Vector +sum :: Num a => Vector a -> a +sum = V.foldr (+) 0 + +-- | Calculates the mean of the elements of the Vectors +mean :: (Fractional a, Num a) => Vector a -> a +mean v = sum v / fromIntegral (V.length v) + +-- merges to Vectors by applying a function to index pairs of both Vectors +mergeVectorsSameSize :: Num a => (a -> a -> a) + -> Vector a -> Vector a -> Vector a +mergeVectorsSameSize f va vb + | V.length va == V.length vb = V.zipWith f va vb + | otherwise = error ( "mergeVectorsSameSize: vectors of different sizes: " + ++ show (V.length va) ++ " and " ++ show (V.length vb)) + +norm2 :: (Floating a, Num a) => Vector a -> a +norm2 v = sqrt $ sum (v * v) + +-------------------------------------------------------------------------------- +-- Numerical Vectors +-------------------------------------------------------------------------------- +{- +fromLists :: [[a]] -> Matrix a +fromLists = V.fromList . map V.fromList + +toLists :: Matrix a -> [[a]] +toLists = V.toList . V.map V.toList +-}
src/HarmTrace/HarmTrace.hs view
@@ -27,7 +27,7 @@ import HarmTrace.Base.MusicTime (dropTimed, getData) -- Parser stuff -import Text.ParserCombinators.UU +import Text.ParserCombinators.UU hiding ( P ) import Text.ParserCombinators.UU.BasicInstances as PC -------------------------------------------------------------------------------- @@ -40,18 +40,18 @@ , pieceTreeHAn :: Tree HAn , nrAmbTrees :: Int , tokenizerErrors :: [Error LineColPos ] - , pieceErrors :: [Error Int] + , pieceErrors :: [Error Int] , postProcessing :: [PPOption]} - + -- parses s with string2Piece and merges the deleted chords with the tree -- (Representable a, GTree (Rep a)) postProc :: (GTree g) => [PPOption] -> ParseResult g -> ParseResult g -postProc opts beforePostProc = beforePostProc { pieceTreeHAn = t } +postProc opts beforePostProc = beforePostProc { pieceTreeHAn = t } where t = selectTree $ map (postProcess fs . gTreeHead) (parsedPiece beforePostProc) fs = map opt2Func opts opt2Func :: PPOption -> (Tree HAn -> Tree HAn) - opt2Func RemoveInsertions = removeInsertions + opt2Func RemoveInsertions = removeInsertions opt2Func RemovePDPT = removePDPT opt2Func MergeDelChords = mergeDelChords (parsedKey beforePostProc) (pieceErrors beforePostProc) @@ -64,8 +64,8 @@ getNrFuncNodes :: Tree HAn -> Int getNrFuncNodes (Node (HAnFunc P) nodes _) = length nodes -getNrFuncNodes _ = error "HarmTrace.hs: not a correctly formed HAn Tree" - +getNrFuncNodes _ = error "HarmTrace.hs: not a correctly formed HAn Tree" + postProcess :: [Tree HAn -> Tree HAn] -> Tree HAn -> Tree HAn postProcess [] tree = tree postProcess (f:fs) tree = f (postProcess fs tree) @@ -77,9 +77,9 @@ string2Piece g s = let (PieceLabel key tok, err) = parse ((,) <$> pSongAbs <*> pEnd) (createStr (LineColPos 0 0 0) s) - (trees, err2) = case g of + (trees, err2) = case g of Jazz -> parse_h ((,) <$> pJazz key <*> pEnd) - (createStr 0 (toKeyRelTok key tok)) + (createStr 0 (toKeyRelTok key tok)) Pop -> parse_h ((,) <$> pPop key <*> pEnd) (createStr 0 (toKeyRelTok key tok)) in ParseResult key tok trees emptyHAnTree (length trees) err err2 [] @@ -87,7 +87,7 @@ -------------------------------------------------------------------------------- -- Parsing audio file ground-truth annotations --------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- gt2Piece :: (GTree g) => Grammar g -> String -> String -> ParseResult g gt2Piece g kstr cstr = let @@ -95,9 +95,9 @@ key = getData . head $ filter (not . isNone . keyRoot . getData) ks (tok, errT) = parseDataWithErrors parseAnnotationData cstr ppTok = dropTimed tok - (ts, errP) = case g of + (ts, errP) = case g of Jazz -> parse_h ((,) <$> pJazz key <*> pEnd) - (createStr 0 (toKeyRelTok key ppTok)) + (createStr 0 (toKeyRelTok key ppTok)) Pop -> parse_h ((,) <$> pPop key <*> pEnd) (createStr 0 (toKeyRelTok key ppTok)) - in ParseResult key ppTok ts emptyHAnTree (length ts) (errK ++ errT) errP [] + in ParseResult key ppTok ts emptyHAnTree (length ts) (errK ++ errT) errP []
src/HarmTrace/IO/Recognise.hs view
@@ -29,13 +29,10 @@ import Constants ( keyStr, chromaStr, beatStr , ChordPrintOpts (..) ) --- Parser stuff -import Text.ParserCombinators.UU - -- Music stuff import HarmTrace.Base.MusicRep import HarmTrace.Models.Jazz.Instances () -import HarmTrace.Base.Parsing +import HarmTrace.Base.Parsing hiding ((<.>)) import HarmTrace.Models.Models -- Audio stuff
src/HarmTrace/Models/Jazz/Instances.hs view
@@ -31,7 +31,7 @@ import Generics.Instant.TH -- Parser stuff -import Text.ParserCombinators.UU +import Text.ParserCombinators.UU hiding (P) import Text.ParserCombinators.UU.BasicInstances -- Music stuff @@ -52,20 +52,20 @@ -------------------------------------------------------------------------------- instance ParseG (Base_SD deg clss Ze) where parseG = empty - + instance ( ToDegree (DiatV deg) , ToDegree (VDom deg) , ParseG (Base_SD (VDom deg) DomClass n) , ParseG (Base_SD (DiatV deg) MinClass n) , ParseG (Base_SD (DiatVM deg) MajClass n) , ParseG (Base_SD deg MinClass n) - , ParseG (TritMinVSub deg MinClass ) + , ParseG (TritMinVSub deg MinClass ) ) => ParseG (Base_SD deg MinClass (Su n)) where parseG = Base_SD <$> parseG <|> Cons_Vdom <$> parseG <*> parseG - <|> Cons_Diat <$> parseG <*> parseG - <|> Cons_DiatM' <$> parseG <*> parseG - + <|> Cons_Diat <$> parseG <*> parseG + <|> Cons_DiatM' <$> parseG <*> parseG + instance ( ToDegree (DiatVM deg) , ToDegree (VDom deg) , ParseG (Base_SD (VDom deg) DomClass n) @@ -75,19 +75,19 @@ ) => ParseG (Base_SD deg MajClass (Su n)) where parseG = Base_SD <$> parseG <|> Cons_Vdom <$> parseG <*> parseG - <|> Cons_DiatM <$> parseG <*> parseG - + <|> Cons_DiatM <$> parseG <*> parseG + instance ( ToDegree (VMin deg) , ToDegree (VDom deg) , ParseG (Base_SD (VDom deg) DomClass n) , ParseG (Base_SD (VMin deg) MinClass n) , ParseG (Base_SD deg DomClass n) - , ParseG (TritMinVSub deg DomClass ) + , ParseG (TritMinVSub deg DomClass ) ) => ParseG (Base_SD deg DomClass (Su n)) where parseG = Base_SD <$> parseG <|> Cons_Vdom <$> parseG <*> parseG - <|> Cons_Vmin <$> parseG <*> parseG - + <|> Cons_Vmin <$> parseG <*> parseG + instance ( ToDegree (VDom deg) , ParseG (Base_SD (VDom deg) DomClass n) , ParseG (Base_SD deg DimClass n) @@ -102,7 +102,7 @@ instance ( ParseG (FinalDimTrans deg clss) ) => ParseG (Base_Final deg clss (Su n)) where parseG = Base_Final <$> parseG - + instance ( ParseG (FinalDimTrans deg DomClass) , ParseG (FinalDimTrans deg MinClass) , ParseG (Base_Final (Tritone deg) DomClass n) @@ -115,22 +115,22 @@ -- Ad-hoc cases for Surface_Chord instance ParseG (Surface_Chord deg clss Ze) where parseG = empty -instance ( ToDegree deg +instance ( ToDegree deg , ParseG (Surface_Chord (MinThird deg) DimClass n) ) => ParseG (Surface_Chord deg DimClass (Su n)) where parseG = Dim_Chord_Trns <$> parseG <|> pChord deg DimClass - where deg = toDegree (undefined :: deg) - + where deg = toDegree (undefined :: deg) + -- all chords instance ( ToDegree deg, ToClass clss ) => ParseG (Surface_Chord deg clss (Su n)) where parseG = pChord deg clss where deg = toDegree (undefined :: deg) clss = toClass (undefined :: clss) - + -- generic ad-hoc parser that forms the bridge between the type-level and --- value-level representation +-- value-level representation pChord :: ScaleDegree -> ClassType -> PMusic (Surface_Chord deg clss (Su n)) -- Do not parse Imp degrees pChord (Note _ Imp) _clss = empty @@ -138,12 +138,12 @@ pChord deg clss = setStatus <$> pSatisfy recognize insertion where {-# INLINE recognize #-} recognize ct = deg == root ct && clss == classType ct - + {-# INLINE setStatus #-} setStatus c = case status c of NotParsed -> Surface_Chord c {status = Parsed} - _ -> Surface_Chord c - + _ -> Surface_Chord c + insertion = Insertion "ChordToken" (ChordToken deg clss [] CT.Inserted 1 0) 5 -------------------------------------------------------------------------------- @@ -151,23 +151,23 @@ -------------------------------------------------------------------------------- toGTree :: (GetDegree a, GTree a) => (Int -> ScaleDegree -> Trans) -> Int -> a -> [Tree HAn] -toGTree con transp deg = [Node (HAnTrans . con 1 $ toTransSDVal transp deg) +toGTree con transp deg = [Node (HAnTrans . con 1 $ toTransSDVal transp deg) (gTree deg) Nothing] -- create a branching Tree HAn toGTreeSplit :: (GetDegree a, GetDegree b, GTree a, GTree b) => (Int -> ScaleDegree -> Prep) -> b -> a -> [Tree HAn] -toGTreeSplit con vof deg +toGTreeSplit con vof deg = Node (HAnPrep . con 1 $ toSDVal deg) (gTree vof) Nothing : gTree deg - --- Ad-Hoc case for Piece + +-- Ad-Hoc case for Piece instance GTree Piece where -- we take the children to skip a "list node" gTree (Piece p) = [Node (HAnFunc P) (gTree p) Nothing] -- Ad-hoc cases for Base_SD instance GTree (Base_SD deg clss Ze) where gTree _ = error "gTree: impossible?" - + instance ( GTree (Base_SD (VDom deg) DomClass n) , GTree (Base_SD (DiatV deg) MinClass n) , GTree (Base_SD (DiatVM deg) MajClass n) @@ -176,11 +176,11 @@ , GTree (Base_Final deg clss n) ) => GTree (Base_SD deg clss (Su n)) where gTree (Base_SD d) = gTree d - gTree (Cons_Vdom s d) = toGTreeSplit SecDom s d - gTree (Cons_Diat s d) = toGTreeSplit DiatDom s d - gTree (Cons_DiatM s d) = toGTreeSplit DiatDom s d - gTree (Cons_DiatM' s d) = toGTreeSplit DiatDom s d - gTree (Cons_Vmin s d) = toGTreeSplit SecMin s d + gTree (Cons_Vdom s d) = toGTreeSplit SecDom s d + gTree (Cons_Diat s d) = toGTreeSplit DiatDom s d + gTree (Cons_DiatM s d) = toGTreeSplit DiatDom s d + gTree (Cons_DiatM' s d) = toGTreeSplit DiatDom s d + gTree (Cons_Vmin s d) = toGTreeSplit SecMin s d -- Ad-hoc cases for Base_Final instance GTree (Base_Final deg clss Ze) where @@ -195,22 +195,22 @@ gTree (Base_Final d) = gTree d -- The tritone substitution of a relative V is as alsway one semitone above -- the chord it is preceding - gTree (Final_Tritone d) = toGTree Trit 6 d - gTree (Final_Dim_V d) = toGTree DimTrit 11 d + gTree (Final_Tritone d) = toGTree Trit 6 d + gTree (Final_Dim_V d) = toGTree DimTrit 11 d -- Ad-hoc cases for Surface_Chord instance GTree (Surface_Chord deg clss Ze) where gTree _ = error "gTree: impossible?" - + instance ( GetDegree (Surface_Chord (MinThird deg) DimClass n) , GTree (Surface_Chord (MinThird deg) DimClass n) ) => GTree (Surface_Chord deg clss (Su n)) where gTree (Surface_Chord c) = [Node (HAnChord c) [] Nothing] gTree (Dim_Chord_Trns c) = toGTree DimTrans 9 c -- pretty print? - + -------------------------------------------------------------------------------- -- Ad hoc getDegree instaces --------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- toTransSDVal :: (GetDegree a) => Int -> a -> ScaleDegree toTransSDVal t d = let (a,i) = getDeg d in transposeSem a (i+t) @@ -221,17 +221,17 @@ -- structure of a scale degree,i.e. the degree and the an int value representing -- the transposition of that degree at the current level, is available. class GetDegree a where - getDeg :: a -> (ScaleDegree, Int) + getDeg :: a -> (ScaleDegree, Int) instance GetDegree (Base_SD deg clss n) where getDeg (Base_SD d) = getDeg d - getDeg (Cons_Vdom _ d) = getDeg d - getDeg (Cons_Diat _ d) = getDeg d - getDeg (Cons_DiatM _ d) = getDeg d - getDeg (Cons_DiatM' _ d) = getDeg d - getDeg (Cons_Vmin _ d) = getDeg d + getDeg (Cons_Vdom _ d) = getDeg d + getDeg (Cons_Diat _ d) = getDeg d + getDeg (Cons_DiatM _ d) = getDeg d + getDeg (Cons_DiatM' _ d) = getDeg d + getDeg (Cons_Vmin _ d) = getDeg d -instance ( GetDegree (Base_Final deg clss Ze)) where +instance ( GetDegree (Base_Final deg clss Ze)) where getDeg = error "getDegree: impossible?" instance GetDegree (Base_Final deg clss n) where getDeg (Base_Final d) = getDeg d @@ -240,12 +240,12 @@ getDeg (Final_Tritone d) = second (+6) (getDeg d) getDeg (Final_Dim_V d) = second (+1) (getDeg d) -instance ( GetDegree (Surface_Chord deg clss Ze)) where +instance ( GetDegree (Surface_Chord deg clss Ze)) where getDeg = error "getDegree: impossible?" - + instance ( GetDegree (Surface_Chord (MinThird deg) DimClass n) ) => GetDegree (Surface_Chord deg clss (Su n)) where - getDeg (Surface_Chord (ChordToken d _cls _cs _stat _n _dur)) = (d,0) + getDeg (Surface_Chord (ChordToken d _cls _cs _stat _n _dur)) = (d,0) getDeg (Dim_Chord_Trns d) = second (+9) (getDeg d) -------------------------------------------------------------------------------- @@ -264,5 +264,5 @@ -- ChordToken as tokens -------------------------------------------------------------------------------- -instance IsLocationUpdatedBy Int ChordToken where +instance IsLocationUpdatedBy Int ChordToken where advance p c = p + chordNumReps c
src/HarmTrace/Models/Pop/Instances.hs view
@@ -18,7 +18,7 @@ import Generics.Instant.TH -- Parser stuff -import Text.ParserCombinators.UU +import Text.ParserCombinators.UU hiding (P) import Text.ParserCombinators.UU.BasicInstances -- Music stuff @@ -39,20 +39,20 @@ -------------------------------------------------------------------------------- instance ParseG (Base_SD deg clss Ze) where parseG = empty - + instance ( ToDegree (DiatV deg) , ToDegree (VDom deg) , ParseG (Base_SD (VDom deg) DomClass n) , ParseG (Base_SD (DiatV deg) MinClass n) , ParseG (Base_SD (DiatVM deg) MajClass n) , ParseG (Base_SD deg MinClass n) - , ParseG (TritMinVSub deg MinClass ) + , ParseG (TritMinVSub deg MinClass ) ) => ParseG (Base_SD deg MinClass (Su n)) where parseG = Base_SD <$> parseG <|> Cons_Vdom <$> parseG <*> parseG - <|> Cons_Diat <$> parseG <*> parseG - <|> Cons_DiatM' <$> parseG <*> parseG - + <|> Cons_Diat <$> parseG <*> parseG + <|> Cons_DiatM' <$> parseG <*> parseG + instance ( ToDegree (DiatVM deg) , ToDegree (VDom deg) , ParseG (Base_SD (VDom deg) DomClass n) @@ -62,19 +62,19 @@ ) => ParseG (Base_SD deg MajClass (Su n)) where parseG = Base_SD <$> parseG <|> Cons_Vdom <$> parseG <*> parseG - <|> Cons_DiatM <$> parseG <*> parseG - + <|> Cons_DiatM <$> parseG <*> parseG + instance ( ToDegree (VMin deg) , ToDegree (VDom deg) , ParseG (Base_SD (VDom deg) DomClass n) , ParseG (Base_SD (VMin deg) MinClass n) , ParseG (Base_SD deg DomClass n) - , ParseG (TritMinVSub deg DomClass ) + , ParseG (TritMinVSub deg DomClass ) ) => ParseG (Base_SD deg DomClass (Su n)) where parseG = Base_SD <$> parseG <|> Cons_Vdom <$> parseG <*> parseG - <|> Cons_Vmin <$> parseG <*> parseG - + <|> Cons_Vmin <$> parseG <*> parseG + instance ( ToDegree (VDom deg) , ParseG (Base_SD (VDom deg) DomClass n) , ParseG (Base_SD deg DimClass n) @@ -89,7 +89,7 @@ instance ( ParseG (FinalDimTrans deg clss) ) => ParseG (Base_Final deg clss (Su n)) where parseG = Base_Final <$> parseG - + instance ( ParseG (FinalDimTrans deg DomClass) , ParseG (FinalDimTrans deg MinClass) , ParseG (Base_Final (Tritone deg) DomClass n) @@ -101,7 +101,7 @@ -- Ad-hoc cases for Surface_Chord instance ParseG (Surface_Chord deg clss Ze) where parseG = empty - + -- all chords instance ( ToDegree deg, ToClass clss ) => ParseG (Surface_Chord deg clss (Su n)) where @@ -110,7 +110,7 @@ clss = toClass (undefined :: clss) -- generic ad-hoc parser that forms the bridge between the type-level and --- value-level representation +-- value-level representation pChord :: ScaleDegree -> ClassType -> PMusic (Surface_Chord deg clss (Su n)) -- Do not parse Imp degrees pChord (Note _ Imp) _clss = empty @@ -118,36 +118,36 @@ pChord deg clss = setStatus <$> pSatisfy recognize insertion where {-# INLINE recognize #-} recognize ct = deg == root ct && clss == classType ct - + {-# INLINE setStatus #-} setStatus c = case status c of NotParsed -> Surface_Chord c {status = Parsed} - _ -> Surface_Chord c - + _ -> Surface_Chord c + insertion = Insertion "ChordToken" (ChordToken deg clss [] CT.Inserted 1 0) 5 - + -------------------------------------------------------------------------------- -- The non-generic part of the GTree wrapper -------------------------------------------------------------------------------- toGTree :: (GetDegree a, GTree a) => (Int -> ScaleDegree -> Trans) -> Int -> a -> [Tree HAn] -toGTree con transp deg = [Node (HAnTrans . con 1 $ toTransSDVal transp deg) +toGTree con transp deg = [Node (HAnTrans . con 1 $ toTransSDVal transp deg) (gTree deg) Nothing] -- create a branching Tree HAn toGTreeSplit :: (GetDegree a, GetDegree b, GTree a, GTree b) => (Int -> ScaleDegree -> Prep) -> b -> a -> [Tree HAn] -toGTreeSplit con vof deg +toGTreeSplit con vof deg = Node (HAnPrep . con 1 $ toSDVal deg) (gTree vof) Nothing : gTree deg - --- Ad-Hoc case for Piece + +-- Ad-Hoc case for Piece instance GTree Piece where -- we take the children to skip a "list node" gTree (Piece p) = [Node (HAnFunc P) (gTree p) Nothing] -- Ad-hoc cases for Base_SD instance GTree (Base_SD deg clss Ze) where gTree _ = error "gTree: impossible?" - + instance ( GTree (Base_SD (VDom deg) DomClass n) , GTree (Base_SD (DiatV deg) MinClass n) , GTree (Base_SD (DiatVM deg) MajClass n) @@ -156,11 +156,11 @@ , GTree (Base_Final deg clss n) ) => GTree (Base_SD deg clss (Su n)) where gTree (Base_SD d) = gTree d - gTree (Cons_Vdom s d) = toGTreeSplit SecDom s d - gTree (Cons_Diat s d) = toGTreeSplit DiatDom s d - gTree (Cons_DiatM s d) = toGTreeSplit DiatDom s d - gTree (Cons_DiatM' s d) = toGTreeSplit DiatDom s d - gTree (Cons_Vmin s d) = toGTreeSplit SecMin s d + gTree (Cons_Vdom s d) = toGTreeSplit SecDom s d + gTree (Cons_Diat s d) = toGTreeSplit DiatDom s d + gTree (Cons_DiatM s d) = toGTreeSplit DiatDom s d + gTree (Cons_DiatM' s d) = toGTreeSplit DiatDom s d + gTree (Cons_Vmin s d) = toGTreeSplit SecMin s d -- Ad-hoc cases for Base_Final instance GTree (Base_Final deg clss Ze) where @@ -175,22 +175,22 @@ gTree (Base_Final d) = gTree d -- The tritone substitution of a relative V is as alsway one semitone above -- the chord it is preceding - -- gTree (Final_Tritone d) = toGTree Trit 6 d - -- gTree (Final_Dim_V d) = toGTree DimTrit 11 d + -- gTree (Final_Tritone d) = toGTree Trit 6 d + -- gTree (Final_Dim_V d) = toGTree DimTrit 11 d -- Ad-hoc cases for Surface_Chord instance GTree (Surface_Chord deg clss Ze) where gTree _ = error "gTree: impossible?" - + instance ( GetDegree (Surface_Chord (MinThird deg) DimClass n) , GTree (Surface_Chord (MinThird deg) DimClass n) ) => GTree (Surface_Chord deg clss (Su n)) where gTree (Surface_Chord c) = [Node (HAnChord c) [] Nothing] -- gTree (Dim_Chord_Trns c) = toGTree DimTrans 9 c -- pretty print? - + -------------------------------------------------------------------------------- -- Ad hoc getDegree instaces --------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- toTransSDVal :: (GetDegree a) => Int -> a -> ScaleDegree toTransSDVal t d = let (a,i) = getDeg d in transposeSem a (i+t) @@ -201,17 +201,17 @@ -- structure of a scale degree,i.e. the degree and the an int value representing -- the transposition of that degree at the current level, is available. class GetDegree a where - getDeg :: a -> (ScaleDegree, Int) + getDeg :: a -> (ScaleDegree, Int) instance GetDegree (Base_SD deg clss n) where getDeg (Base_SD d) = getDeg d - getDeg (Cons_Vdom _ d) = getDeg d - getDeg (Cons_Diat _ d) = getDeg d - getDeg (Cons_DiatM _ d) = getDeg d - getDeg (Cons_DiatM' _ d) = getDeg d - getDeg (Cons_Vmin _ d) = getDeg d + getDeg (Cons_Vdom _ d) = getDeg d + getDeg (Cons_Diat _ d) = getDeg d + getDeg (Cons_DiatM _ d) = getDeg d + getDeg (Cons_DiatM' _ d) = getDeg d + getDeg (Cons_Vmin _ d) = getDeg d -instance ( GetDegree (Base_Final deg clss Ze)) where +instance ( GetDegree (Base_Final deg clss Ze)) where getDeg = error "getDegree: impossible?" instance GetDegree (Base_Final deg clss n) where getDeg (Base_Final d) = getDeg d @@ -220,12 +220,12 @@ -- getDeg (Final_Tritone d) = second (+6) (getDeg d) -- getDeg (Final_Dim_V d) = second (+1) (getDeg d) -instance ( GetDegree (Surface_Chord deg clss Ze)) where +instance ( GetDegree (Surface_Chord deg clss Ze)) where getDeg = error "getDegree: impossible?" - + instance ( GetDegree (Surface_Chord (MinThird deg) DimClass n) ) => GetDegree (Surface_Chord deg clss (Su n)) where - getDeg (Surface_Chord (ChordToken d _cls _cs _stat _n _dur)) = (d,0) + getDeg (Surface_Chord (ChordToken d _cls _cs _stat _n _dur)) = (d,0) -- getDeg (Dim_Chord_Trns d) = second (+9) (getDeg d) -------------------------------------------------------------------------------- @@ -244,5 +244,5 @@ -- ChordToken as tokens -------------------------------------------------------------------------------- -instance IsLocationUpdatedBy Int ChordToken where +instance IsLocationUpdatedBy Int ChordToken where advance p c = p + chordNumReps c
src/Main.hs view
@@ -402,13 +402,13 @@ getGram (_:t) = getGram t getMode :: [MyArgs] -> MatchMode -getMode [] = error "impossible?" +getMode [] = error "getMode impossible?" getMode ((MatchMode m):_) = m getMode (_:t) = getMode t getAnn :: [MyArgs] -> (GrammarEx -> Maybe [TimedData Key] -> AudioFeat -> ChordAnnotation) -getAnn [] = error "impossible?" +getAnn [] = error "getAnn impossible?" getAnn ((RecognitionMode (RecognitionFun f)):_) = f getAnn (_:t) = getAnn t