HarmTrace-Base 1.1.0.2 → 1.6.0.0
raw patch · 20 files changed
Files
- CHANGELOG.md +11/−0
- HarmTrace-Base.cabal +68/−33
- LICENSE +165/−165
- README.md +22/−0
- Setup.hs +2/−2
- src/HarmTrace/Base/Chord.hs +52/−0
- src/HarmTrace/Base/Chord/Analysis.hs +339/−0
- src/HarmTrace/Base/Chord/Datatypes.hs +399/−0
- src/HarmTrace/Base/Chord/Internal.hs +90/−0
- src/HarmTrace/Base/Chord/Intervals.hs +121/−0
- src/HarmTrace/Base/Chord/PitchClass.hs +170/−0
- src/HarmTrace/Base/ChordTokenizer.hs +0/−194
- src/HarmTrace/Base/MusicRep.hs +0/−656
- src/HarmTrace/Base/MusicTime.hs +0/−308
- src/HarmTrace/Base/Parse.hs +21/−0
- src/HarmTrace/Base/Parse/ChordParser.hs +176/−0
- src/HarmTrace/Base/Parse/General.hs +89/−0
- src/HarmTrace/Base/Parsing.hs +0/−90
- src/HarmTrace/Base/Time.hs +442/−0
- src/Tests.hs +195/−0
+ CHANGELOG.md view
@@ -0,0 +1,11 @@+### Changelog + +1.4.0.1 HarmTrace-Base has been completely rewritten and is not compatible + with software that depends on HarmTrace-Base < 1.4. + +1.6.0.0 Lot's of minor updates. + + * More functions to represent musical time at the beat level + * Stricktly adhere to the Harte shortands + * Add the option to print chords with inversions represented as notes instead of intervals + * Minor improvements
HarmTrace-Base.cabal view
@@ -1,33 +1,68 @@-name: HarmTrace-Base-version: 1.1.0.2-synopsis: Parsing and unambiguously representing musical chords.-description: HarmTrace: Harmony Analysis and Retrieval of Music - with Type-level Representations of Abstract- Chords Entities- .- We present HarmTrace-Base, a library for parsing and - unambiguously representing musical chords.--copyright: (c) 2012--2013 W. Bas de Haas and Jose Pedro Magalhaes-license: LGPL-3-license-file: LICENSE-author: W. Bas de Haas and Jose Pedro Magalhaes-maintainer: bas@chordify.net, dreixel@chordify.net --category: Music-build-type: Simple-tested-with: GHC == 7.4.1, GHC == 7.6.1-cabal-version: >=1.8--library- exposed-modules: HarmTrace.Base.Parsing, HarmTrace.Base.MusicTime, - HarmTrace.Base.MusicRep, HarmTrace.Base.ChordTokenizer- - hs-source-dirs: src - - build-depends: base >= 4.4 && < 4.8, uu-parsinglib >=2.7.4, - ListLike >=3.1, binary >= 0.6.4, ghc-prim >= 0.2- - - ghc-options: -Wall- -O2+name: HarmTrace-Base +version: 1.6.0.0 +synopsis: Parsing and unambiguously representing musical chords. +description: HarmTrace: Harmony Analysis and Retrieval of Music + with Type-level Representations of Abstract + Chords Entities + . + We present HarmTrace-Base, a library for parsing and + unambiguously representing musical chords. + +copyright: (c) 2012--2017 Chordify B.V. +homepage: https://bitbucket.org/bash/harmtrace-base +license: LGPL-3 +license-file: LICENSE +author: W. Bas de Haas, Jeroen Bransen and Jose Pedro Magalhaes +maintainer: haskelldevelopers@chordify.net +category: Music +build-type: Simple +tested-with: GHC == 7.4.1, GHC == 7.6.1, GHC == 7.8.2, GHC == 7.10.2, + GHC == 8.0.2, GHC == 8.2.1 +cabal-version: >=1.10 +extra-Source-Files: README.md CHANGELOG.md +source-repository head + type: git + location: git@bitbucket.org:bash/harmtrace-base.git + + +library + default-language: Haskell2010 + exposed-modules: HarmTrace.Base.Chord, + HarmTrace.Base.Chord.Datatypes, + HarmTrace.Base.Chord.Analysis, + HarmTrace.Base.Chord.PitchClass, + HarmTrace.Base.Chord.Intervals, + HarmTrace.Base.Parse, + HarmTrace.Base.Parse.General, + HarmTrace.Base.Parse.ChordParser, + HarmTrace.Base.Time + + other-modules: HarmTrace.Base.Chord.Internal + hs-source-dirs: src + + build-depends: base >= 4.4 && < 5, + uu-parsinglib ==2.9.1.*, + ListLike >= 3.0.1, + binary >= 0.6.4, + ghc-prim >= 0.2, + containers >= 0.5.0.0 + + ghc-options: -Wall + -O2 + +Test-Suite test-harmtrace-base + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Tests.hs + hs-source-dirs: src + build-depends: QuickCheck >= 2.7, + random >= 1.1, + HarmTrace-Base -any, + base >= 4.2, + uu-parsinglib ==2.9.1.*, + ListLike >= 3.0.1, + binary >= 0.6.4, + ghc-prim >= 0.2, + containers >= 0.5.0.0 + + ghc-options: -Wall
LICENSE view
@@ -1,165 +1,165 @@- GNU LESSER GENERAL PUBLIC LICENSE- Version 3, 29 June 2007-- Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>- Everyone is permitted to copy and distribute verbatim copies- of this license document, but changing it is not allowed.--- This version of the GNU Lesser General Public License incorporates-the terms and conditions of version 3 of the GNU General Public-License, supplemented by the additional permissions listed below.-- 0. Additional Definitions.-- As used herein, "this License" refers to version 3 of the GNU Lesser-General Public License, and the "GNU GPL" refers to version 3 of the GNU-General Public License.-- "The Library" refers to a covered work governed by this License,-other than an Application or a Combined Work as defined below.-- An "Application" is any work that makes use of an interface provided-by the Library, but which is not otherwise based on the Library.-Defining a subclass of a class defined by the Library is deemed a mode-of using an interface provided by the Library.-- A "Combined Work" is a work produced by combining or linking an-Application with the Library. The particular version of the Library-with which the Combined Work was made is also called the "Linked-Version".-- The "Minimal Corresponding Source" for a Combined Work means the-Corresponding Source for the Combined Work, excluding any source code-for portions of the Combined Work that, considered in isolation, are-based on the Application, and not on the Linked Version.-- The "Corresponding Application Code" for a Combined Work means the-object code and/or source code for the Application, including any data-and utility programs needed for reproducing the Combined Work from the-Application, but excluding the System Libraries of the Combined Work.-- 1. Exception to Section 3 of the GNU GPL.-- You may convey a covered work under sections 3 and 4 of this License-without being bound by section 3 of the GNU GPL.-- 2. Conveying Modified Versions.-- If you modify a copy of the Library, and, in your modifications, a-facility refers to a function or data to be supplied by an Application-that uses the facility (other than as an argument passed when the-facility is invoked), then you may convey a copy of the modified-version:-- a) under this License, provided that you make a good faith effort to- ensure that, in the event an Application does not supply the- function or data, the facility still operates, and performs- whatever part of its purpose remains meaningful, or-- b) under the GNU GPL, with none of the additional permissions of- this License applicable to that copy.-- 3. Object Code Incorporating Material from Library Header Files.-- The object code form of an Application may incorporate material from-a header file that is part of the Library. You may convey such object-code under terms of your choice, provided that, if the incorporated-material is not limited to numerical parameters, data structure-layouts and accessors, or small macros, inline functions and templates-(ten or fewer lines in length), you do both of the following:-- a) Give prominent notice with each copy of the object code that the- Library is used in it and that the Library and its use are- covered by this License.-- b) Accompany the object code with a copy of the GNU GPL and this license- document.-- 4. Combined Works.-- You may convey a Combined Work under terms of your choice that,-taken together, effectively do not restrict modification of the-portions of the Library contained in the Combined Work and reverse-engineering for debugging such modifications, if you also do each of-the following:-- a) Give prominent notice with each copy of the Combined Work that- the Library is used in it and that the Library and its use are- covered by this License.-- b) Accompany the Combined Work with a copy of the GNU GPL and this license- document.-- c) For a Combined Work that displays copyright notices during- execution, include the copyright notice for the Library among- these notices, as well as a reference directing the user to the- copies of the GNU GPL and this license document.-- d) Do one of the following:-- 0) Convey the Minimal Corresponding Source under the terms of this- License, and the Corresponding Application Code in a form- suitable for, and under terms that permit, the user to- recombine or relink the Application with a modified version of- the Linked Version to produce a modified Combined Work, in the- manner specified by section 6 of the GNU GPL for conveying- Corresponding Source.-- 1) Use a suitable shared library mechanism for linking with the- Library. A suitable mechanism is one that (a) uses at run time- a copy of the Library already present on the user's computer- system, and (b) will operate properly with a modified version- of the Library that is interface-compatible with the Linked- Version.-- e) Provide Installation Information, but only if you would otherwise- be required to provide such information under section 6 of the- GNU GPL, and only to the extent that such information is- necessary to install and execute a modified version of the- Combined Work produced by recombining or relinking the- Application with a modified version of the Linked Version. (If- you use option 4d0, the Installation Information must accompany- the Minimal Corresponding Source and Corresponding Application- Code. If you use option 4d1, you must provide the Installation- Information in the manner specified by section 6 of the GNU GPL- for conveying Corresponding Source.)-- 5. Combined Libraries.-- You may place library facilities that are a work based on the-Library side by side in a single library together with other library-facilities that are not Applications and are not covered by this-License, and convey such a combined library under terms of your-choice, if you do both of the following:-- a) Accompany the combined library with a copy of the same work based- on the Library, uncombined with any other library facilities,- conveyed under the terms of this License.-- b) Give prominent notice with the combined library that part of it- is a work based on the Library, and explaining where to find the- accompanying uncombined form of the same work.-- 6. Revised Versions of the GNU Lesser General Public License.-- The Free Software Foundation may publish revised and/or new versions-of the GNU Lesser General Public License from time to time. Such new-versions will be similar in spirit to the present version, but may-differ in detail to address new problems or concerns.-- Each version is given a distinguishing version number. If the-Library as you received it specifies that a certain numbered version-of the GNU Lesser General Public License "or any later version"-applies to it, you have the option of following the terms and-conditions either of that published version or of any later version-published by the Free Software Foundation. If the Library as you-received it does not specify a version number of the GNU Lesser-General Public License, you may choose any version of the GNU Lesser-General Public License ever published by the Free Software Foundation.-- If the Library as you received it specifies that a proxy can decide-whether future versions of the GNU Lesser General Public License shall-apply, that proxy's public statement of acceptance of any version is-permanent authorization for you to choose that version for the-Library.+ GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/> + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library.
+ README.md view
@@ -0,0 +1,22 @@+# README + +## HarmTrace Base: Parsing and unambiguously representing musical chords + +HarmTrace base is a library for representing musical chords. It is used a +small number of programs. A Chordify we build our back-end in Haskell and the +HarmTrace-Base library is used to represent, store, manipulate, print chords +etc. Basically the library offers a set of types and classes for representing +musical chords in an unambiguous manner as presented in [1]. + +[1] Christopher Harte, Mark Sandler and Samer Abdallah (2005), "Symbolic +representation of musical chords: a proposed syntax for text annotations" +_[In: Proceedings of 6th International Conference on Music Information +Retrieval](<http://ismir2005.ismir.net/proceedings/1080.pdf>)_ (pp. 66-71). + +## Installing + +`cabal install` + +or + +`stack init` and `stack build`
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple-main = defaultMain+import Distribution.Simple +main = defaultMain
+ src/HarmTrace/Base/Chord.hs view
@@ -0,0 +1,52 @@+{-# OPTIONS_GHC -Wall #-} +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Base.Chord +-- Copyright : (c) 2012--2016, Chordify BV +-- License : LGPL-3 +-- +-- Maintainer : haskelldevelopers@chordify.net +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: An interface to all the sub modules of HarmTrace.Base.Chord +-------------------------------------------------------------------------------- + +module HarmTrace.Base.Chord ( + module HarmTrace.Base.Chord.Datatypes + , module HarmTrace.Base.Chord.Analysis + , module HarmTrace.Base.Chord.PitchClass + , module HarmTrace.Base.Chord.Intervals + -- * Alternative Chord Printing + , showChordWithNoteInversion + ) where + +import HarmTrace.Base.Chord.Datatypes +import HarmTrace.Base.Chord.Analysis +import HarmTrace.Base.Chord.PitchClass +import HarmTrace.Base.Chord.Intervals + +import Data.List ( intercalate ) + + +-------------------------------------------------------------------------------- +-- Alternative printing +-------------------------------------------------------------------------------- + +-- | The Show instance obides the Harte syntax, but it can be more convenient +-- to show a chord with the inversion printed as a 'Note' instead of an +-- 'Interval' +showChordWithNoteInversion :: ChordLabel -> String +showChordWithNoteInversion c = + let showIv :: Root -> Interval -> String + showIv _ (Note Nat I1) = "" + showIv r i = '/' : show (intervalToPitch r i) + + showAdd :: [Addition] -> String + showAdd [] = "" + showAdd x = '(' : intercalate "," (map show x) ++ ")" + in case c of + NoChord -> "N" + UndefChord -> "X" + (Chord r None [] b) -> show r ++ ":1" ++ showIv r b + (Chord r sh add b) -> show r ++ ':' : show sh ++ showAdd add ++ showIv r b
+ src/HarmTrace/Base/Chord/Analysis.hs view
@@ -0,0 +1,339 @@+{-# OPTIONS_GHC -Wall #-} +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Base.MusicRep +-- Copyright : (c) 2012--2016, Chordify BV +-- License : LGPL-3 +-- +-- Maintainer : haskelldevelopers@chordify.net +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Analyses and transforms musical chords +-------------------------------------------------------------------------------- + +module HarmTrace.Base.Chord.Analysis ( + -- * Analysis + -- ** Triads and Sevenths + analyseTriad + , analyseTetra + , toTriad + , toMajMinChord + -- ** Chord components + , Third (..) + , Fifth (..) + , Sevth (..) + , analyseThird + , analyseFifth + , analyseSevth + -- ** Misc + , toMode + , toMajMin + , toClassType + , isSus2 + , isSus4 + -- * Scale degree transposition + , transposeRoot + , transposeCL + , transposeSD + , toChordDegree + , toScaleDegree + , intervalToPitch + , pitchToInterval + , toChord + ) where + +import HarmTrace.Base.Chord.Datatypes +import HarmTrace.Base.Chord.PitchClass +import HarmTrace.Base.Chord.Intervals +import HarmTrace.Base.Chord.Internal + +import Data.IntSet ( IntSet, toAscList, member, (\\) ) + +-------------------------------------------------------------------------------- +-- Transformation and analysis of chords +-------------------------------------------------------------------------------- + +-- | Returns the 'ClassType' given a 'Chord'. This function uses +-- 'analyseDegClassType' to analyse a chord and derive the 'ClassType' +toClassType :: Chord a -> ClassType +toClassType NoChord = NoClass +toClassType UndefChord = NoClass +toClassType (Chord _r sh [] _b) = shToClassType sh -- no additions +-- combine the degrees and analyse them. N.B., also NoAdd degrees are resolved +toClassType c = analyseDegClassType . toIntSet $ c + +-- | Analyses a degree list and returns 'MajTriad', 'MinTriad' or 'NoTriad' if +-- the degrees make a chord a major, minor, or no triad, respectively. +analyseDegClassType :: IntSet -> ClassType +analyseDegClassType degs = + case (analyseThird degs, analyseFifth degs, analyseSevth degs) of + -- Triads + (MinThird, DimFifth , DimSev) -> DimClass + (MajThird, _ , MinSev) -> DomClass + (_ , AugFifth , _ ) -> DomClass + (MajThird, DimFifth , _ ) -> DomClass + (MajThird, _ , _ ) -> MajClass + (MinThird, PerfFifth, _ ) -> MinClass + (MinThird, _ , _ ) -> MinClass + (NoThird, _ , _ ) -> NoClass + + +-- | Categorises a 'Shorthand' into a 'ClassType'. +shToClassType :: Shorthand -> ClassType +shToClassType Maj = MajClass +shToClassType Min = MinClass +shToClassType Dim = DimClass +shToClassType Aug = DomClass +shToClassType Maj7 = MajClass +shToClassType Min7 = MinClass +shToClassType Sev = DomClass +shToClassType Dim7 = DimClass +shToClassType HDim7 = MinClass +shToClassType MinMaj7 = MinClass +shToClassType Aug7 = DomClass +shToClassType Maj6 = MajClass +shToClassType Min6 = MinClass +shToClassType Nin = DomClass +shToClassType Maj9 = MajClass +shToClassType Min9 = MinClass +shToClassType Five = NoClass +shToClassType Sus2 = NoClass +shToClassType Sus4 = NoClass +shToClassType SevSus4 = NoClass +shToClassType None = NoClass +-- additional Billboard shorthands +shToClassType Min11 = MinClass +shToClassType Eleven = DomClass +shToClassType Min13 = MinClass +shToClassType Maj13 = MajClass +shToClassType Thirteen = DomClass + +-- should not be exported, used only in toTriad +-- | A 'Third' can by major, minor or absent +data Third = MajThird | MinThird | NoThird deriving (Eq, Show) + +-- | A 'Fifth' can be perfect, diminished, augmented or absent +data Fifth = DimFifth | PerfFifth | AugFifth | NoFifth deriving (Eq, Show) + +-- | A seventh can be major, minor, diminished, or absent +data Sevth = DimSev | MinSev | MajSev | NoSev deriving (Eq, Show) + +triadToSh :: Triad -> Shorthand +triadToSh t = case t of + MajTriad -> Maj + MinTriad -> Min + AugTriad -> Aug + DimTriad -> Dim + NoTriad -> None + +-- | Analyses the structure of an 'IntSet' and returns an appropriate +-- 'ShortHand', if possible +analyseTetra :: IntSet -> Shorthand +analyseTetra is = case (analyseTriad is, analyseSevth is) of + (MajTriad, MinSev) -> Sev + (MajTriad, MajSev) -> Maj7 + (MinTriad, MinSev) -> Min7 + (MinTriad, MajSev) -> MinMaj7 + (DimTriad, MinSev) -> HDim7 + (DimTriad, DimSev) -> Dim7 + (AugTriad, MinSev) -> Aug7 + (t , NoSev ) -> triadToSh t + _ -> None + +-- | Takes a 'Chord' and determines the 'Triad' +-- +-- >>> toTriad (Chord (Note Nat C) Min [NoAdd (Note Fl I3),Add (Note Nat I3)] 0 0) +-- maj +-- +-- >>> toTriad (Chord (Note Nat C) HDim7 [Add (Note Sh I11)] 0 0) +-- dim +-- +-- >>> toTriad (Chord (Note Nat C) Min [NoAdd (Note Fl I3)] 0 0) +-- NoTriad +-- +-- N.B. 'toTriad' throws an error when applied to a 'NoChord' or 'UndefChord'. +toTriad :: Chord a -> Triad +toTriad NoChord = error "toTriad: a NoChord has no triad to analyse" +toTriad UndefChord = error "toTriad: a UndefChord has no triad to analyse" +toTriad (Chord _r sh [] _b) = shToTriad sh -- there are no additions +-- combine the degrees and analyse them. N.B., also NoAdd degrees are resolved +toTriad c = analyseTriad . toIntSet $ c + +-- | Analyses a degree list and returns 'MajTriad', 'MinTriad' or 'NoTriad' if +-- the degrees make a chord a major, minor, or no triad, respectively. +analyseTriad :: IntSet -> Triad +analyseTriad is = + case (analyseThird is, analyseFifth is) of + (MajThird, PerfFifth) -> MajTriad + (MajThird, AugFifth ) -> AugTriad + (MajThird, DimFifth ) -> NoTriad + (MinThird, PerfFifth) -> MinTriad + (MinThird, AugFifth ) -> NoTriad + (MinThird, DimFifth ) -> DimTriad + (NoThird, _ ) -> NoTriad + (_ , NoFifth ) -> NoTriad + +-- | analyses the third in a degree list +analyseThird :: IntSet -> Third +analyseThird is + | member 4 is = MajThird + | member 3 is = MinThird + | otherwise = NoThird + +-- | analyses the fifth in a degree list +analyseFifth :: IntSet -> Fifth +analyseFifth is + | member 7 is = PerfFifth + | member 6 is = DimFifth + | member 8 is = AugFifth + | otherwise = NoFifth + +-- | analyses the fifth in a degree list +analyseSevth :: IntSet -> Sevth +analyseSevth is + | member 10 is = MinSev + | member 11 is = MajSev + | member 9 is = DimSev + | otherwise = NoSev + + +-- | Converts a 'Shorthand' to a 'Triad' +-- N.B. this function should not be exported because the shorthand alone cannot +-- determine the triad +shToTriad :: Shorthand -> Triad +shToTriad Maj = MajTriad +shToTriad Min = MinTriad +shToTriad Dim = DimTriad +shToTriad Aug = AugTriad +shToTriad Maj7 = MajTriad +shToTriad Min7 = MinTriad +shToTriad Sev = MajTriad +shToTriad Dim7 = DimTriad +shToTriad HDim7 = DimTriad +shToTriad MinMaj7 = MinTriad +shToTriad Aug7 = AugTriad +shToTriad Maj6 = MajTriad +shToTriad Min6 = MinTriad +shToTriad Nin = MajTriad +shToTriad Maj9 = MajTriad +shToTriad Min9 = MinTriad +shToTriad Five = NoTriad +shToTriad Sus2 = NoTriad +shToTriad Sus4 = NoTriad +shToTriad SevSus4 = NoTriad +shToTriad None = NoTriad +-- additional Billboard shorthands +shToTriad Min11 = MinTriad +shToTriad Eleven = MajTriad +shToTriad Min13 = MinTriad +shToTriad Maj13 = MajTriad +shToTriad Thirteen = MajTriad + + +-- | Converts a 'Shorthand' to a 'Mode' +toMode :: Triad -> Mode +toMode MajTriad = MajMode +toMode MinTriad = MinMode +toMode t = error ( "HarmTrace.Base.MusicRep.toMode: cannot convert " + ++ " triad to mode: " ++ show t) + +-- | Converts a 'Shorthand' to either a 'MajClass', 'MinClass' or 'NoClass' +-- 'ClassType'. +toMajMin :: Triad -> ClassType +toMajMin MajTriad = MajClass +toMajMin MinTriad = MinClass +toMajMin AugTriad = MajClass +toMajMin DimTriad = MinClass +toMajMin NoTriad = NoClass + +-- | applies 'toMajMin' to a 'Chord', in case there is no triad, e.g. +-- @:sus4@ or @:sus2@, an 'UndefChord' is returned. Also, chord +-- additions are removed. 'NoChord's and 'UndefChord's are returned untouched. +toMajMinChord :: ChordLabel -> ChordLabel +toMajMinChord NoChord = NoChord +toMajMinChord UndefChord = UndefChord +toMajMinChord c@(Chord r _ _ b) = case toMajMin (toTriad c) of + MajClass -> Chord r Maj [] b + MinClass -> Chord r Min [] b + NoClass -> UndefChord + -- catch all: cannot happen, see toMajMin + _ -> error ("HarmTrace.Base.MusicRep.toMajMinChord" + ++ " unexpected chord " ++ show c) + +-- | Returns True if the 'ChordLabel' has a major second, no third, +-- and no fourth. +isSus2 :: ChordLabel -> Bool +isSus2 c = let is = toIntSet c in member 2 is + && not (member 3 is) + && not (member 4 is) + && not (member 5 is) + +-- | Returns True if the 'ChordLabel' has a no major second, no third, +-- but has a fourth. +isSus4 :: ChordLabel -> Bool +isSus4 c = let is = toIntSet c in not (member 2 is) + && not (member 3 is) + && not (member 4 is) + && (member 5 is) +-------------------------------------------------------------------------------- +-- Value Level Scale Degree Transposition +-------------------------------------------------------------------------------- + +-- Chord root shorthand degrees location duration +-- | Given a 'Key', calculates the the 'ChordDegree' (i.e. relative, +-- 'ScaleDegree' based 'Chord') for an absolute 'ChordLabel' using +-- 'toScaleDegree'. +toChordDegree :: Key -> ChordLabel -> ChordDegree +toChordDegree k (Chord r sh a b) = Chord (toScaleDegree k r) sh a b +toChordDegree _ c = + error("HarmTrace.Base.Chord.Analysis: cannot create scale degree for " ++ show c) + +-- | Transformes a absolute 'Root' 'Note' into a relative 'ScaleDegree', given +-- a 'Key'. +toScaleDegree :: Key -> Root -> ScaleDegree +-- toScaleDegree _ n@(Note _ N) = + -- error ("HarmTrace.Base.MusicRep.toScaleDegree: cannot transpose " ++ show n) +toScaleDegree (Key kr _) cr = -- Note Nat I + scaleDegrees!!(((toPitchClass cr) - (toPitchClass kr)) `mod` 12) + +-- | Transposes a Root with a 'Int' semitones up +transposeRoot :: Root -> Int -> Root +transposeRoot = transpose roots + +-- | Transposes a ChordLabel with a 'Int' semitones up +transposeCL :: ChordLabel -> Int -> ChordLabel +transposeCL c sem = fmap (flip transposeRoot sem) c + +-- | Transposes a scale degree with 'Int' semitones up +transposeSD :: ScaleDegree -> Int -> ScaleDegree +transposeSD = transpose scaleDegrees + +transpose :: Diatonic a => [Note a] -> Note a -> Int -> Note a +transpose ns n sem = ns !! ((sem + (toPitchClass n)) `mod` 12) + + +-- | Similar to 'toScaleDegree', an interval is transformed into an absolute +-- 'Root' pitch, given another 'Root' that serves as a basis. +-- +-- >>> intervalToPitch (Note Sh G) (Note Fl I13) +-- >>> E +-- +-- >>> intervalToPitch (Note Nat C) (Note Sh I11) +-- >>> F# +-- +intervalToPitch :: Root -> Interval -> Root +intervalToPitch r = pcToRoot . intValToPitchClss r + +-- | The inverse of 'intervalToPitch' +pitchToInterval :: Root -> Root -> Interval +pitchToInterval ra rb = intervals !! ((toPitchClass rb - toPitchClass ra) `mod` 12) + +-- | Given an 'IntSet' (Interval Set), a 'Root' 'Note' and an optional +-- bass 'Interval', returns a 'Chord' +toChord :: Root -> IntSet -> Interval -> Chord Root +toChord r is mi = Chord r sh add mi + + where add = map (Add . icToInterval) $ toAscList (is \\ shToIntSet sh) + sh = analyseTetra is +
+ src/HarmTrace/Base/Chord/Datatypes.hs view
@@ -0,0 +1,399 @@+{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Base.MusicRep +-- Copyright : (c) 2012--2016, Chordify BV +-- License : LGPL-3 +-- +-- Maintainer : haskelldevelopers@chordify.net +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: A set of types and classes for representing musical chords. The +-- chord datatypes are based on the unambiguous chord representation presented +-- in: Christopher Harte, Mark Sandler and Samer Abdallah (2005), +-- /Symbolic representation of musical chords: a proposed syntax for text annotations/, +-- In: Proceedings of 6th International Conference on Music Information +-- Retrieval (<http://ismir2005.ismir.net/proceedings/1080.pdf>). +-------------------------------------------------------------------------------- + +module HarmTrace.Base.Chord.Datatypes ( + -- * Representing musical chords and keys + Note (..) + , Accidental (..) + , Root + , DiatonicNatural (..) + , ScaleDegree + , DiatonicDegree (..) + -- ** Keys + , Key (..) + , Mode (..) + -- ** Chords + , Chord (..) + , chordRoot + , chordShorthand + , chordAdditions + , chordBass + , Shorthand (..) + , Addition (..) + , IntNat (..) + , Interval + , ChordLabel + , ChordDegree + + -- ** Derived types for classification of chords + , ClassType (..) + , Triad (..) + -- * Tests & Utilities + , shortChord + , discardBass + , addition + , insertAdd + , isNoneChord + , isAddition + , catchNoChord + ) where + +import Data.Maybe ( fromJust ) +import Data.List ( elemIndex, intercalate, insert, delete ) +import Data.Binary ( Binary ) +import GHC.Generics ( Generic ) + +-------------------------------------------------------------------------------- +-- Representing musical information at the value level +-------------------------------------------------------------------------------- + + +-- | A musical key consising of a 'Root' and 'Mode' +data Key = Key { keyRoot :: Root, keyMode :: Mode } deriving (Eq, Ord, Generic) + +-- | The 'Mode' of a key, which can be major or minor +data Mode = MajMode | MinMode deriving (Eq, Ord, Generic) + +-- | A chord based on absolute 'Root' notes +type ChordLabel = Chord Root + +-- | A chord based on relative 'ScaleDegree's +type ChordDegree = Chord ScaleDegree + +-- | The representation for a single chord consisting of a root, a 'Shorthand' +-- representing the interval structure of the chord, a list of 'Additions', +-- for representing other (additional) structure, and the base 'Inversion' +data Chord a = Chord a Shorthand [Addition] Interval -- ^ a regular chord + | NoChord -- ^ No sounding chord (silence, noise, etc.) + | UndefChord -- ^ An undefined chord + deriving (Eq, Ord, Generic, Functor) + +-- | Returns the root of a 'Chord', and throws an error in case of a 'NoChord' +-- or an 'UndefChord'. +chordRoot :: Show a => Chord a -> a +chordRoot = catchNoChord "Chord.Datatypes.chordRoot" (\(Chord r _ _ _) -> r) + +-- | Returns the 'Shorthand' of a 'Chord', and throws an error in case of +-- a 'NoChord' or an 'UndefChord'. +chordShorthand :: Show a => Chord a -> Shorthand +chordShorthand = catchNoChord "Chord.Datatypes.chordShorthand" (\(Chord _ s _ _) ->s) + +-- | Returns the list of 'Additions' of a 'Chord', and throws an error in case +-- of a 'NoChord' or an 'UndefChord'. +chordAdditions :: Show a => Chord a -> [Addition] +chordAdditions = catchNoChord "Chord.Datatypes.chordAdditions" (\(Chord _ _ a _) ->a) + +-- | Returns the bass 'Interval' of a 'Chord', and throws an error in case of +-- a 'NoChord' or an 'UndefChord'. +chordBass :: Show a => Chord a -> Interval +chordBass = catchNoChord "Chord.Datatypes.chordBass" (\(Chord _ _ _ b) -> b) + +-- | Updates the root field of a 'Chord' +-- updateRoot :: Chord a -> a -> Chord a +-- updateRoot (Chord r sh a b) r' = Chord r' sh a b + +-- | We introduce four chord categories: major chords, minor chords, dominant +-- seventh chords, and diminished seventh chords +data ClassType = MajClass | MinClass | DomClass | DimClass | NoClass + deriving (Eq, Enum, Ord, Bounded, Generic) + +-- | Following Harte et al., we define a number of chord 'Shorthand's. We +-- support a few extra shorthand, but the show intance of 'Shorthand' will only +-- output the 'Shorthand's that are in the official specification +data Shorthand = -- | Triadic chords + Maj | Min | Dim | Aug + -- | Seventh chords + | Maj7 | Min7 | Sev | Dim7 | HDim7 | MinMaj7 | Aug7 + -- | Sixth chords + | Maj6 | Min6 + -- | Extended chords + | Nin | Maj9 | Min9 + -- | Suspended chords + | Sus4 | Sus2 | SevSus4 + -- | Power chords + | Five + -- | Only a root note + | None + -- | Additional shorthands in billboard collection + | Eleven | Thirteen | Min11 | Maj13 | Min13 + + deriving (Eq, Ord, Enum, Bounded, Generic) + + +-- | Key relative scale degrees to abstract from the absolute Root notes +type ScaleDegree = Note DiatonicDegree + +-- | All Diatonic scale degrees +data DiatonicDegree = I | II | III | IV | V | VI | VII + | Imp -- ^ for unrepresentable scale degrees + deriving (Show, Eq, Enum, Ord, Bounded, Generic) + +-- | Representing absolute 'Root' notes +type Root = Note DiatonicNatural + +-- | The seven diatonic naturals +data DiatonicNatural = C | D | E | F | G | A | B + deriving (Show, Eq, Enum, Ord, Bounded, Generic) + +-- | Intervals for additional chord notes +data Addition = Add Interval + | NoAdd Interval deriving (Eq, Ord, Generic) + +-- | Diatonic major intervals used to denote 'Chord' 'Addition's and bass +-- 'Interval's +data IntNat = I1 | I2 | I3 | I4 | I5 | I6 | I7 | I8 | I9 | I10 + | I11 | I12 | I13 + deriving (Eq, Enum, Ord, Bounded, Generic) + +-- \ Represents a musical interval +type Interval = Note IntNat + +-- | A musical note is a pitch (either absolute or relative) possibly modified +-- by an 'Accidental' +data Note a = Note Accidental a deriving (Eq, Ord, Generic) + +-- | A musical 'Accidental' +data Accidental = Nat -- ^ natural + | Sh -- ^ sharp + | Fl -- ^ flat + | SS -- ^ double sharp + | FF -- ^ double flat + deriving (Eq, Ord, Generic) + +-- | A 'Triad' comes in four flavours: major, minor, augmented, diminished, and +-- sometimes a chord does not have a triad (e.g. suspended chords, etc.) +data Triad = MajTriad | MinTriad | AugTriad | DimTriad | NoTriad + deriving (Ord, Eq, Generic) + +-------------------------------------------------------------------------------- +-- Instances for the general music datatypes +-------------------------------------------------------------------------------- + +instance Read DiatonicNatural where + readsPrec _ ('A':xs) = [(A, xs)] + readsPrec _ ('B':xs) = [(B, xs)] + readsPrec _ ('C':xs) = [(C, xs)] + readsPrec _ ('D':xs) = [(D, xs)] + readsPrec _ ('E':xs) = [(E, xs)] + readsPrec _ ('F':xs) = [(F, xs)] + readsPrec _ ('G':xs) = [(G, xs)] + readsPrec _ _ = [] + +instance Show Key where + show (Key r m) = show r ++ show m + +instance Read Key where + readsPrec i xs = + [ (Key r m, zs) + | (r, ys) <- readsPrec i xs + , (m, zs) <- readsPrec i ys + ] + +instance Show Mode where + show MajMode = "" + show MinMode = "m" + +instance Read Mode where + readsPrec _ ('m':xs) = [(MinMode, xs)] + readsPrec _ xs = [(MajMode, xs)] + +-- In showing chords, we obey Harte et al.'s syntax as much as possible +instance Show ChordLabel where + show NoChord = "N" + show UndefChord = "X" + show (Chord r None [] b) = show r ++ ":1" ++ showIv b + show (Chord r sh add b) = + let (sh', x) = toHarte sh + add' = foldl (insertAdd) add x + in show r ++ ':' : show sh' ++ showAdd add' ++ showIv b + +showIv :: Interval -> String +showIv (Note Nat I1) = "" +showIv i = '/' : show i + + +showAdd :: [Addition] -> String +showAdd [] = "" +showAdd x = '(' : intercalate "," (map show x) ++ ")" + +instance Show Shorthand where + show Maj = "maj" + show Min = "min" + show Dim = "dim" + show Aug = "aug" + show Maj7 = "maj7" + show Min7 = "min7" + show Sev = "7" + show Dim7 = "dim7" + show HDim7 = "hdim7" + show MinMaj7 = "minmaj7" + show Maj6 = "maj6" + show Min6 = "min6" + show Nin = "9" + show Maj9 = "maj9" + show Min9 = "min9" + show Sus4 = "sus4" + + -- not part of the official Harte specification + show Aug7 = "aug7" + show Min11 = "min11" + show Min13 = "min13" + show Maj13 = "maj13" + show Sus2 = "sus2" + show SevSus4 = "7sus4" + show Five = "5" + show Eleven = "11" + show Thirteen = "13" + show None = "" + +instance Show ClassType where + show MajClass = "" + show MinClass = "m" + show DomClass = "7" + show DimClass = "0" + show NoClass = "N" + + +instance Show (Note IntNat) where + show (Note m i) = show m ++ show i + +instance Show (Note DiatonicNatural) where + show (Note m r) = show r ++ show m + +instance Read (Note DiatonicNatural) where + readsPrec i xs = + [ (Note m r, zs) + | (r, ys) <- readsPrec i xs + , (m, zs) <- readsPrec i ys + ] + +instance Show (Note DiatonicDegree) where + show (Note m r) = show m ++ show r + +instance Show IntNat where + show a = show . ((!!) ([1..13]::[Integer])) + . fromJust $ elemIndex a [minBound..] + + +instance Show Accidental where + show Nat = "" + show Sh = "#" + show Fl = "b" + show SS = "##" + show FF = "bb" + +instance Read Accidental where + readsPrec _ ('#':'#':xs) = [(SS, xs)] + readsPrec _ ( '#':xs) = [(Sh, xs)] + readsPrec _ ('b':'b':xs) = [(FF, xs)] + readsPrec _ ( 'b':xs) = [(Fl, xs)] + readsPrec _ xs = [(Nat, xs)] + +instance Show Addition where + show (Add n) = show n + show (NoAdd n) = '*' : show n + +instance Show Triad where + show MajTriad = "maj" + show MinTriad = "min" + show AugTriad = "aug" + show DimTriad = "dim" + show NoTriad = "NoTriad" + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +-- | A Constructor for a simple chord based on a 'Root' and 'Shorthand' only +shortChord :: Root -> Shorthand -> ChordLabel +shortChord r sh = Chord r sh [] (Note Nat I1) + +-- | Returns True if the 'ChordLabel' is not a chord, and False otherwise +isNoneChord :: ChordLabel -> Bool +isNoneChord NoChord = True +isNoneChord _ = False + +-- | Returns true if the 'Chord' 'Addition' represents an addition and not +-- a degree that has to be removed (*). +isAddition :: Addition -> Bool +isAddition (Add _) = True +isAddition (NoAdd _) = False + +-- | Adds an 'Addition' to a 'Chord' +addition :: Chord a -> Addition -> Chord a +addition NoChord _ = NoChord +addition UndefChord _ = UndefChord +addition (Chord r sh ads b) a = Chord r sh (insertAdd ads a) b + +-- | Applies an 'Addition' to a list of 'Addition's +insertAdd :: [Addition] -> Addition -> [Addition] +insertAdd l (Add a) = insert (Add a) l +insertAdd l (NoAdd r) = delete (Add r) l + + +-- | Discards a base note by replacing the bass 'Interval' by a +-- 'Note' 'Nat' 'I1' +discardBass :: Chord a -> Chord a +discardBass NoChord = NoChord +discardBass UndefChord = UndefChord +discardBass (Chord r sh a _b) = Chord r sh a (Note Nat I1) + +-- | Checks if the 'ChordLabel' is a 'NoChord' or 'UndefChord' and throws +-- an error using the first argument as an function identifier for debugging. +-- In case of a 'ChordLabel' the second argument is applied to the third +-- argument. +catchNoChord :: Show a => String -> (Chord a -> b) -> Chord a -> b +catchNoChord s f c = case c of + NoChord -> error ("HarmTrace.Base."++s++" applied to a NoChord") + UndefChord -> error ("HarmTrace.Base."++s++" applied to a UndefChord") + _ -> f c + +toHarte :: Shorthand -> (Shorthand, [Addition]) +toHarte c = case c of + Aug7 -> (Aug, [Add (Note Fl I7 )]) + Min11 -> (Min9, [Add (Note Nat I11)]) + Min13 -> (Min9, [Add (Note Nat I11), Add (Note Nat I13)]) + Maj13 -> (Min13,[Add (Note Nat I11), Add (Note Nat I13)]) + Sus2 -> (Sus4, [NoAdd (Note Nat I4), Add (Note Nat I2)]) + SevSus4 -> (Sus4, [Add (Note Fl I7)]) + Five -> (None, [Add (Note Nat I5)]) + Eleven -> (Nin, [Add (Note Nat I11)]) + Thirteen -> (Nin, [Add (Note Nat I11),Add (Note Nat I13)]) + sh -> (sh, []) + +-------------------------------------------------------------------------------- +-- Binary instances +-------------------------------------------------------------------------------- + +instance Binary Key +instance Binary Mode +instance Binary a => Binary (Chord a) +instance Binary ClassType +instance Binary Shorthand +instance Binary DiatonicDegree +instance Binary DiatonicNatural +instance Binary Addition +instance Binary IntNat +instance Binary a => Binary (Note a) +instance Binary Accidental +instance Binary Triad
+ src/HarmTrace/Base/Chord/Internal.hs view
@@ -0,0 +1,90 @@+{-# OPTIONS_GHC -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Base.Chord.Internal +--- Copyright : (c) 2012--2016, Chordify BV +-- License : LGPL-3 +-- +-- Maintainer : haskelldevelopers@chordify.net +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Some common function that are not exported +-------------------------------------------------------------------------------- + +module HarmTrace.Base.Chord.Internal ( + modToInt + , scaleDegrees + , roots + , intervals + ) where + +import HarmTrace.Base.Chord.Datatypes + +-- | Transforms type-level Accidentals to semitones (Int values) +modToInt :: Accidental -> Int +modToInt Nat = 0 +modToInt Sh = 1 +modToInt Fl = -1 +modToInt SS = 2 +modToInt FF = -2 + +-- | A list of 12 'ScaleDegree's, ignoring pitch spelling. +scaleDegrees ::[ ScaleDegree ] +scaleDegrees = [ Note Nat I + , Note Sh I + , Note Nat II + , Note Fl III + , Note Nat III + , Note Nat IV + , Note Sh IV + , Note Nat V + , Note Fl VI + , Note Nat VI + , Note Fl VII + , Note Nat VII + ] + + +-- | A list of 12 'Note DiatonicNatural's, ignoring pitch spelling. +roots :: [ Root ] +roots = [ Note Nat C + , Note Sh C + , Note Nat D + , Note Fl E + , Note Nat E + , Note Nat F + , Note Sh F + , Note Nat G + , Note Fl A + , Note Nat A + , Note Fl B + , Note Nat B + ] + + +intervals :: [ Interval ] +intervals = [ Note Nat I1 -- 0: Prime + , Note Fl I2 -- 1: Minor second + , Note Nat I2 -- 2: Major second + , Note Fl I3 -- 3: Minor third + , Note Nat I3 -- 4: Major third + , Note Nat I4 -- 5: Perfect fourth + , Note Fl I5 -- 6: Diminished fifth (augmented fourth) + , Note Nat I5 -- 7: Perfect fifth + , Note Fl I6 -- 8: Minor sixth + , Note Nat I6 -- 9: Major sixth + , Note Fl I7 -- 10: Minor seventh + , Note Nat I7 -- 11: Major seventh + , Note Nat I8 -- 12: Perfect Octave + , Note Fl I9 -- 13: Flat nine -- in jazz jargon + , Note Nat I9 -- 14: Nine + , Note Sh I9 -- 15: Sharp nine + , Note Nat I10 -- 16: tenth: is viewed as third + , Note Nat I11 -- 17: eleventh + , Note Sh I11 -- 18: sharp eleventh + , Note Nat I12 -- 19: twelveth: viewed as fifth + , Note Fl I13 -- 20: Flat thirteen + , Note Nat I13 -- 21: Thirteen + ]
+ src/HarmTrace/Base/Chord/Intervals.hs view
@@ -0,0 +1,121 @@+{-# OPTIONS_GHC -Wall #-} +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Base.Chord.Intervals +-- Copyright : (c) 2012--2016, Chordify BV +-- License : LGPL-3 +-- +-- Maintainer : haskelldevelopers@chordify.net +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: We can represent a chord as a set of intervals relative to the +-- root of the chord. +-------------------------------------------------------------------------------- + +module HarmTrace.Base.Chord.Intervals ( + -- * Interval Conversion + icToInterval + , toIntervalClss + -- * Creating Interval Sets + -- , IntSet + , toIntSet + -- * Utilities + , addToIntSet + , shToIntSet + ) where + +import HarmTrace.Base.Chord.Datatypes +import HarmTrace.Base.Chord.Internal + +import Data.List ( partition ) +import Data.IntSet ( IntSet, fromList, union, insert, singleton + , empty, (\\) ) + +-- TODO wrap this Int in an IC newtype + +-- | Converts an 'Int'erval class to an 'Interval' +icToInterval :: Int -> Interval +icToInterval i + | 0 <= i && i <= 21 = intervals !! i + | otherwise = error ("HarmTrace.Base.MusicRep.toInterval " ++ + "invalid pitch class: " ++ show i) + +-- | Similar to 'toPitchClss', this function calculates an enharmonic +-- interval class for each 'Note Interval' in the range of [0 .. 23] +-- ( == ['Note Nat I1' .. 'Note SS I13'] +toIntervalClss :: Interval -> Int +toIntervalClss n@(Note m i) = + -- 1 2 3 4 5 6 7 8 9 10 11 12 13 + let ic = ([0,2,4,5,7,9,11,12,14,16,17,19,21] !! (fromEnum i)) + modToInt m + in if ic >= 0 then ic + else error ("HarmTrace.Base.MusicRep.toIntervalClss: no " + ++ "interval class for " ++ show n) + + +-- | Transforms a Chord into a list of relative intervals stored as an 'IntSet' +-- without the root an bass note represented as the number of semitones above +-- the root. +-- +-- >>> toIntSet (Chord (Note Nat C) HDim7 [Add (Note Sh I11)] (Note Fl I3)) +-- fromList [3,6,10,18] +-- +-- >>> toIntSet (Chord (Note Nat C) Min13 [NoAdd (Note Nat I11)] (Note Nat I1)) +-- fromList [3,7,10,14,21] +-- +-- >>> toIntSet (parseData pChord "D:7(b9)") +-- fromList [4,7,10,13] +-- +toIntSet :: Chord a -> IntSet +toIntSet (Chord _r sh [] _b) = shToIntSet sh +toIntSet (Chord _r sh a _b) = let (add, rm) = partition isAddition a + in (shToIntSet sh `union` toSet add) \\ toSet rm +toIntSet _ = error ("HarmTrace.Base.MusicRep.toIntValList: cannot create" ++ + "interval list for N or X") + +-- | Converts a list of addition to an 'IntSet' containing the relative +-- structure of the ('Addition' list of the) 'Chord' +addToIntSet :: [Addition] -> IntSet +addToIntSet add = toSet adds \\ toSet remv + where (adds, remv) = partition isAddition add + +-- not exported: strips the interval from a list of Additions regardless of +-- it is a Add or NoAdd +toSet :: [Addition] -> IntSet +toSet = fromList . map (toIntervalClss . getInt) where + + getInt :: Addition -> Interval + getInt (NoAdd i) = i + getInt (Add i) = i + + +-- | Expands a 'Shorthand' to its list of degrees +shToIntSet :: Shorthand -> IntSet +shToIntSet Maj = fromList [4,7] -- [Note Nat I3,Note Nat I5] +shToIntSet Min = fromList [3,7] -- [Note Fl I3,Note Nat I5] +shToIntSet Dim = fromList [3,6] -- [Note Fl I3,Note Fl I5] +shToIntSet Aug = fromList [4,8] -- [Note Nat I3,Note Sh I5] +shToIntSet Maj7 = insert 11 (shToIntSet Maj) -- ++ [Note Nat I7] +shToIntSet Min7 = insert 10 (shToIntSet Min) -- ++ [Note Fl I7] +shToIntSet Sev = insert 10 (shToIntSet Maj) -- ++ [Note Fl I7] +shToIntSet Dim7 = insert 9 (shToIntSet Dim) -- ++ [Note FF I7] +shToIntSet HDim7 = insert 10 (shToIntSet Dim) -- ++ [Note Fl I7] +shToIntSet MinMaj7 = insert 11 (shToIntSet Min) -- ++ [Note Nat I7] +shToIntSet Aug7 = insert 10 (shToIntSet Aug) -- ++ [Note Fl I7] +shToIntSet Maj6 = insert 9 (shToIntSet Maj) -- ++ [Note Nat I6] +-- Harte uses a 6 instead of b6 +shToIntSet Min6 = insert 8 (shToIntSet Min ) -- ++ [Note Fl I6] +shToIntSet Nin = insert 14 (shToIntSet Sev ) -- ++ [Note Nat I9] +shToIntSet Maj9 = insert 14 (shToIntSet Maj7) -- ++ [Note Nat I9] +shToIntSet Min9 = insert 14 (shToIntSet Min7) -- ++ [Note Nat I9] +shToIntSet Five = singleton 7 -- [Note Nat I5] +shToIntSet Sus2 = fromList [2,7] -- [Note Nat I2,Note Nat I5] +shToIntSet Sus4 = fromList [5,7] -- [Note Nat I4,Note Nat I5] +shToIntSet SevSus4 = insert 10 (shToIntSet Sus4) -- ++ [Note Fl I7] +shToIntSet None = empty +-- additional Billboard shorthands +shToIntSet Min11 = insert 17 (shToIntSet Min9 ) -- ++ [Note Nat I11] +shToIntSet Eleven = insert 17 (shToIntSet Nin ) -- ++ [Note Nat I11] +shToIntSet Min13 = insert 21 (shToIntSet Min11 ) -- ++ [Note Nat I13] +shToIntSet Maj13 = insert 21 (shToIntSet Maj9 ) -- ++ [Note Nat I13] +shToIntSet Thirteen= insert 21 (shToIntSet Eleven) -- ++ [Note Nat I13]
+ src/HarmTrace/Base/Chord/PitchClass.hs view
@@ -0,0 +1,170 @@+{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Base.Chord.PitchClass +-- Copyright : (c) 2012--2016, Chordify BV +-- License : LGPL-3 +-- +-- Maintainer : haskelldevelopers@chordify.net +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: this module provides some functions that transform notes and chords +-- into pitch classes and pitch class sets. See for more info: +-- <http://en.wikipedia.org/wiki/Pitch_class> +-------------------------------------------------------------------------------- +module HarmTrace.Base.Chord.PitchClass ( + PCSet -- Pitch Class Set + , pc -- Unwraps a 'PCSet' + -- * Pitch classes + , toPitchClass + , pcToRoot + -- * Pitch classes applied to chords + , toPitchClasses + , rootPC + , bassPC + , ignorePitchSpelling + , altPitchSpelling + -- * Pitch classes applied to keys + , keyPitchClasses + -- * Pitch classes applied to interval sets + , intValToPitchClss + , intSetToPC + -- * Enharmonic Equivalence + , EnHarEq (..) + -- * Diatonic Class + , Diatonic + ) where + +import HarmTrace.Base.Chord.Datatypes +import HarmTrace.Base.Chord.Intervals +import HarmTrace.Base.Chord.Internal + +import Data.Binary ( Binary ) +import Data.IntSet ( IntSet, fromList, union ) +import qualified Data.IntSet as S ( map ) +import GHC.Generics ( Generic ) + +-- | We hide the constructors, such that a PCSet can only be constructed with +-- 'toPitchClasses', this to overcome confusion between interval sets and +-- pitch class sets, which are both 'Data.IntSet.IntSet's +newtype PCSet = PCSet {pc :: IntSet} deriving (Show, Eq, Generic) + +instance Binary PCSet + +-- | The (relative) notes in a major scale +majorScale :: Num a => [a] +majorScale = [0,2,4,5,7,9,11] + +-- | The (relative) notes in a minor scale +minorScale :: Num a => [a] +minorScale = [0,2,3,5,7,8,10] + +-- | Returns the semitone value [0 .. 11] of a 'ScaleDegree' where +-- 0 = C, e.g. F# = 6. For the constructors 'N' and 'X' an error is thrown. +toPitchClass :: (Diatonic a) => Note a -> Int +toPitchClass (Note m p) + | ix <= 6 = ((majorScale !! ix) + modToInt m) `mod` 12 + | otherwise = error ("HarmTrace.Base.MusicRep.toPitchClass: no semitone for " + ++ show p ++ show m ) + where ix = fromEnum p + +-- | Transforms an interval set to and a root into a 'PCSet' +intSetToPC :: IntSet -> Root -> PCSet +intSetToPC is r = PCSet . S.map (transp (toPitchClass r)) $ is where + + transp :: Int -> Int -> Int + transp t i = (i + t) `mod` 12 + + +-- | As 'toIntervalClss', but returns the 'Int' pitch class. +intValToPitchClss :: Root -> Interval -> Int +intValToPitchClss r i = (toPitchClass r + toIntervalClss i) `mod` 12 + + +-- | The reverse of 'toPitchClass' returning the 'Note DiatonicNatural' given a +-- Integer [0..11] semitone, where 0 represents C. All pitch spelling is ignored +-- and the the following twelve pitch names will be output: C, C#, D, Eb, E, F +-- F#, G, Ab, A, Bb, B. When the integer is out of the range [0..11] an +-- error is thrown. +pcToRoot :: Int -> Root +pcToRoot i + | 0 <= i && i <= 11 = roots !! i + | otherwise = error ("HarmTrace.Base.MusicRep.toRoot " ++ + "invalid pitch class: " ++ show i) + +-- | Similar to 'toIntSet' but returns 'Int' pitch classes and includes the +-- 'Root' and the bass 'Note' of the the 'Chord'. 'toPitchClasses' throws an +-- error when applied to a 'NoChord' or 'UndefChord'. +toPitchClasses :: ChordLabel -> PCSet +toPitchClasses c = catchNoChord "Chord.PitchClass.toPitchClasses" + (intSetToPC ivs . chordRoot) c + + where ivs = toIntSet c `union` fromList [0, toIntervalClss (chordBass c)] + +-- | Return the set of pitches for the given key. +keyPitchClasses :: Key -> PCSet +keyPitchClasses k = intSetToPC (fromList scale) (keyRoot k) where + scale = case keyMode k of + MajMode -> majorScale + MinMode -> minorScale + +-- | A short-cut applying 'intValToPitchClss' to a 'Chord'. 'bassPC' throws an +-- error when applied to a 'NoChord' or 'UndefChord'. +bassPC :: ChordLabel -> Int +bassPC = catchNoChord "Chord.PitchClass.rootPC" bassPC' where + + bassPC' :: ChordLabel -> Int + bassPC' c = intValToPitchClss (chordRoot c) (chordBass c) + +-- | A short-cut applying 'toPitchClass' to a 'Chord'. 'rootPC' throws an +-- error when applied to a 'NoChord' or 'UndefChord'. +rootPC :: ChordLabel -> Int +rootPC = catchNoChord "Chord.PitchClass.rootPC" (toPitchClass . chordRoot) + +-- | Ignores the pitch spelling of a chord by applying 'pcToRoot' and +-- 'toPitchClass' to the root of a 'ChordLabel'. +ignorePitchSpelling :: ChordLabel -> ChordLabel +ignorePitchSpelling NoChord = NoChord +ignorePitchSpelling UndefChord = UndefChord +ignorePitchSpelling c = fmap (pcToRoot . toPitchClass) c + +-- | Give the alternative pitch spelling of a chord (if it exists) +altPitchSpelling :: ChordLabel -> Maybe ChordLabel +altPitchSpelling NoChord = Nothing +altPitchSpelling UndefChord = Nothing +altPitchSpelling (Chord (Note acc root) short add intervc) = case acc of + Nat -> Nothing + FF -> Nothing -- todo: is this right? + SS -> Nothing -- todo: is this right? + Fl -> Just $ Chord (Note Sh (pred root)) short add intervc + Sh -> Just $ Chord (Note Fl (succ root)) short add intervc + +-------------------------------------------------------------------------------- +-- Classes +-------------------------------------------------------------------------------- + +-- | A class to compare datatypes that sound the same (they contain the +-- same pitch class content): +-- <http://en.wikipedia.org/wiki/Enharmonic> +class EnHarEq a where + (&==) :: a -> a -> Bool + (&/=) :: a -> a -> Bool + + a &== b = not (a &/= b) + a &/= b = not (a &== b) + +instance Diatonic a => EnHarEq (Note a) where + a &== b = toPitchClass a == toPitchClass b + +instance EnHarEq ChordLabel where + a &== b = toPitchClasses a == toPitchClasses b + +-- | A class to mark certain datatypes to have a diatonic structure: +-- http://en.wikipedia.org/wiki/Diatonic_and_chromatic +class (Generic a, Show a, Enum a, Bounded a) => Diatonic a + +instance Diatonic DiatonicNatural +instance Diatonic DiatonicDegree
− src/HarmTrace/Base/ChordTokenizer.hs
@@ -1,194 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE FlexibleContexts #-}------------------------------------------------------------------------------------- |--- Module : HarmTrace.Base.Parsing--- Copyright : (c) 2012--2013 W. Bas de Haas and Jose Pedro Magalhaes--- License : LGPL-3------ Maintainer : bas@chordify.net, dreixel@chordify.net --- Stability : experimental--- Portability : non-portable------ Summary: Some general parsing utilities used for parsing textual chord--- representations.-----------------------------------------------------------------------------------module HarmTrace.Base.ChordTokenizer ( -- * Top level parser- parseChordSeq - -- * Parsing (elements of) chords- , pChord- , pShorthand- , pSongAbs- , pRoot- , pAdditions- , pAddition- , pKey- ) where--import HarmTrace.Base.Parsing-import HarmTrace.Base.MusicRep------------------------------------------------------------------------------------- Top level Chord sequence parser------------------------------------------------------------------------------------- | Top level parser that parsers a string into a 'PieceLabel' and a posibly--- empty list of errors-parseChordSeq :: String -> (PieceLabel, [Error LineColPos])-parseChordSeq = parseDataWithErrors pSongAbs------------------------------------------------------------------------------------- Tokenizing: parsing strings into tokens--------------------------------------------------------------------------------- ---- | Parser that parses a string of whitespace-separated 'Chord's, e.g.--- @C:maj Bb:9(s11);1 E:min7;1 Eb:min7;1 Ab:7;1 D:min7;1 G:7(13);1 C:maj6(9);1@--- The first 'Chord' must be the key of the piece, and the after each chord--- the semicolumn and an Integer representing the duration of the chord must --- be presented-pSongAbs :: Parser PieceLabel -- PieceRelToken -- -pSongAbs = PieceLabel <$> pKey <* pLineEnd - <*> (setLoc 0 <$> pListSep_ng pLineEnd pChordDur )- <* pList pLineEnd where- setLoc :: Int -> [Chord a] -> [Chord a] - setLoc _ [] = []- setLoc ix (Chord r c d _ l :cs) = (Chord r c d ix l) : setLoc (ix+1) cs ---- parses chords with a duration (separated by a ';')-pChordDur :: Parser ChordLabel-pChordDur = setDur <$> pChord <*> (pSym ';' *> pNaturalRaw) <?> "Chord;Int"- where setDur c d = c {duration = d}---- | Parses a 'ChordLabel' in Harte et al. syntax including possible additions, --- and removal of chord additions. If a chord has no 'Shorthand', the 'Degree' --- list (if any) is analysed and depending on the 'Triad' (if any) a --- 'Maj', 'Min','Aug', or 'Dim' 'Shorthand' is stored. By default all the --- duration stored in every 'Chord' is 1 (where the unit is application --- dependend, often these are beats, but they can also be eightnotes)-pChord :: Parser ChordLabel -{-# INLINE pChord #-}-pChord = pChordLabel - <|> (noneLabel <$ (pString "N" <|> pString "&pause"))- <|> (unknownLabel <$ (pSym '*' <|> pSym 'X'))- <?> "Chord"- --- Parses a chord label--- TODO add support for inversion-pChordLabel :: Parser ChordLabel-{-# INLINE pChordLabel #-}-pChordLabel = toChord <$> pRoot <* (pSym ':' `opt` ':') <*> pMaybe pShorthand- -- we ignore optional inversions for now- <*> ((pAdditions `opt` []) <* pInversion)- - where toChord :: Root -> Maybe Shorthand -> [Addition] -> ChordLabel- -- if there are no degrees and no shorthand, following Harte it - -- should be labelled a Maj chord- toChord r Nothing [] = Chord r Maj [] 0 1- toChord r Nothing d = case analyseDegTriad d of- MajTriad -> Chord r Maj (remTriadDeg d) 0 1- MinTriad -> Chord r Min (remTriadDeg d) 0 1- AugTriad -> Chord r Aug (remTriadDeg d) 0 1- DimTriad -> Chord r Dim (remTriadDeg d) 0 1- NoTriad -> Chord r None d 0 1- toChord r (Just s) d = Chord r s d 0 1- - -- removes the third and the fifth from a Addtion list- remTriadDeg :: [Addition] -> [Addition]- remTriadDeg = filter (\(Add (Note _ i)) -> i /= I3 || i /= I5)---- Parses an inversion, but inversionsion are ignored for now.-pInversion :: Parser (Maybe (Note Interval))-pInversion = (Just <$> (pSym '/' *> (Note <$> pMaybe pAccidental <*> pInterval))- <?> "/Inversion") `opt` Nothing - --- | parses a musical key description, e.g. @C:maj@, or @D:min@-pKey :: Parser Key -pKey = f <$> pRoot <* pSym ':' <*> pShorthand <?> "Key"- where f r m | m == Maj = Key r MajMode- | m == Min = Key r MinMode- | otherwise = error ("Tokenizer: key must be Major or Minor, "- ++ "found: " ++ show m)---- | Parses a shorthand following Harte et al. syntax, but also the shorthands--- added to the Billboard dataset, e.g. @maj@, @min@, or @9@.-pShorthand :: Parser Shorthand-{-# INLINE pShorthand #-}-pShorthand = Maj <$ pString "maj"- <|> Min <$ pString "min"- <|> Dim <$ pString "dim"- <|> Aug <$ pString "aug"- <|> Maj7 <$ pString "maj7"- <|> Min7 <$ pString "min7"- <|> Sev <$ pString "7"- <|> Dim7 <$ pString "dim7"- <|> HDim7 <$ pString "hdim" <* opt (pSym '7') '7'- <|> MinMaj7 <$ pString "minmaj7"- <|> Maj6 <$ pString "maj6"- <|> Maj6 <$ pString "6"- <|> Min6 <$ pString "min6"- <|> Nin <$ pString "9"- <|> Maj9 <$ pString "maj9"- <|> Min9 <$ pString "min9"- <|> Five <$ pString "5" - <|> Sus2 <$ pString "sus2" - <|> Sus4 <$ pString "sus4" - -- additional Billboard shorthands- <|> Min11 <$ pString "min11" - <|> Min13 <$ pString "min13" - <|> Maj13 <$ pString "maj13" - <|> Eleven <$ pString "11" - <|> Thirteen <$ pString "13" - <|> None <$ pString "1" -- no shorthand: used in billboard to - -- denote a rootnote only- <?> "Shorthand"---- | Parses a list of 'Chord' 'Addition's within parenthesis -pAdditions :: Parser [Addition]-pAdditions = pPacked (pSym '(') (pSym ')') ( pListSep (pSym ',') pAddition ) - <?> "Addition List"---- | Parses the a 'Chord' 'Addition' (or the removal of a chord addition, --- prefixed by a @*@)-pAddition :: Parser Addition-pAddition = (Add <$> (Note <$> pMaybe pAccidental <*> pInterval))- <|> (NoAdd <$> (pSym '*'*> (Note <$> pMaybe pAccidental <*> pInterval)))- <?> "Addition"---- | Parses in 'Accidental' -pAccidental :: Parser Accidental-pAccidental = Sh <$ pSym 's'- <|> Sh <$ pSym '#'- <|> Fl <$ pSym 'b'- <|> SS <$ pString "ss"- <|> FF <$ pString "bb" <?> "Accidental"---- | Parses an 'Interval'-pInterval :: Parser Interval-pInterval = ((!!) [minBound..] ) . pred <$> pNaturalRaw <?> "Interval"---- | Parses a 'Root' 'Note', e.g. @A@, @Bb@, or @F#@.-pRoot :: Parser Root-{-# INLINE pRoot #-}-pRoot = Note Nothing A <$ pSym 'A'- <|> Note Nothing B <$ pSym 'B'- <|> Note Nothing C <$ pSym 'C'- <|> Note Nothing D <$ pSym 'D'- <|> Note Nothing E <$ pSym 'E'- <|> Note Nothing F <$ pSym 'F'- <|> Note Nothing G <$ pSym 'G'- <|> Note (Just Fl) A <$ pString "Ab"- <|> Note (Just Fl) B <$ pString "Bb"- <|> Note (Just Fl) C <$ pString "Cb"- <|> Note (Just Fl) D <$ pString "Db"- <|> Note (Just Fl) E <$ pString "Eb"- <|> Note (Just Fl) F <$ pString "Fb"- <|> Note (Just Fl) G <$ pString "Gb"- <|> Note (Just Sh) A <$ pString "A#"- <|> Note (Just Sh) B <$ pString "B#"- <|> Note (Just Sh) C <$ pString "C#"- <|> Note (Just Sh) D <$ pString "D#"- <|> Note (Just Sh) E <$ pString "E#"- <|> Note (Just Sh) F <$ pString "F#"- <|> Note (Just Sh) G <$ pString "G#" <?> "Chord root"
− src/HarmTrace/Base/MusicRep.hs
@@ -1,656 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DeriveGeneric #-}------------------------------------------------------------------------------------- |--- Module : HarmTrace.Base.MusicRep--- Copyright : (c) 2012--2013 W. Bas de Haas and Jose Pedro Magalhaes--- License : LGPL-3------ Maintainer : bas@chordify.net, dreixel@chordify.net --- Stability : experimental--- Portability : non-portable------ Summary: A set of types and classes for representing musical chords. The --- chord datatypes are based on the unambiguous chord representation presented --- in: Christopher Harte, Mark Sandler and Samer Abdallah (2005), --- /Symbolic representation of musical chords: a proposed syntax for text annotations/, --- In: Proceedings of 6th International Conference on Music Information --- Retrieval (<http://ismir2005.ismir.net/proceedings/1080.pdf>). -----------------------------------------------------------------------------------module HarmTrace.Base.MusicRep (- -- * Representing musical chords and keys- PieceLabel (..)- , Note (..)- , Accidental (..)- , Root - , DiatonicNatural (..)- , ScaleDegree - , DiatonicDegree (..)- -- ** Keys- , Key (..)- , Mode (..)- -- ** Chords- , Chord (..)- -- , Class- , Shorthand (..)- , Addition (..)- , Interval (..)- , ChordLabel- , ChordDegree- , noneLabel- , unknownLabel- -- * Derived types for classification of chords- , ClassType (..)- , Triad (..)- -- * Tests- , isNone- , isNoneChord- , isUnknown- , isRoot- , isAddition- -- * Transformation and analysis of chords- , toClassType- , toTriad- , analyseDegTriad- , toDegreeList- , toMode- , toMajMin- , toMajMinChord- , simplifyRoot- -- * Scale degree transposition- , toChordDegree- , toScaleDegree- , transposeSem- , toSemitone- , toRoot- ) where- -import Data.Maybe (fromJust)-import Data.List (elemIndex, intercalate, (\\), partition)-import Data.Binary (Binary)-import GHC.Generics (Generic)------------------------------------------------------------------------------------- Representing musical information at the value level-------------------------------------------------------------------------------------- | A musical key consising of a 'Root' and 'Mode'-data Key = Key { keyRoot :: Root, keyMode :: Mode } deriving (Eq, Ord, Generic)---- | The 'Mode' of a key, which can be major or minor-data Mode = MajMode | MinMode deriving (Eq, Ord, Generic)---- | A container type combinint a key and a list of 'ChordLabel's-data PieceLabel = PieceLabel Key [ChordLabel] deriving Generic---- | A chord based on absolute 'Root' notes-type ChordLabel = Chord Root---- rename to noLabel?--- | No Chord label-noneLabel :: ChordLabel-noneLabel = (Chord (Note Nothing N) None [] 0 1)---- | Unknown Chord label-unknownLabel :: ChordLabel-unknownLabel = (Chord (Note Nothing X) None [] 0 1)---- | A chord based on relative 'ScaleDegree's-type ChordDegree = Chord ScaleDegree---- | The representation for a single chord -data Chord a = Chord { chordRoot :: a- , chordShorthand :: Shorthand- , chordAdditions :: [Addition]- -- | the index of the chord in the list of tokens- , getLoc :: Int - -- | the duration of the chord - , duration :: Int - } deriving Generic---- | We introduce four chord categories: major chords, minor chords, dominant--- seventh chords, and diminshed seventh chords-data ClassType = MajClass | MinClass | DomClass | DimClass | NoClass- deriving (Eq, Enum, Ord, Bounded, Generic)---- Following Harte et al., we define a number of chord 'Shorthand's-data Shorthand = -- | Triadic chords- Maj | Min | Dim | Aug- -- | Seventh chords- | Maj7 | Min7 | Sev | Dim7 | HDim7 | MinMaj7- -- | Sixth chords- | Maj6 | Min6- -- | Extended chords- | Nin | Maj9 | Min9- -- | Suspended chords- | Sus4 | Sus2- -- | Power chords- | Five- -- In some cases there is no chord a certain position- -- This is especially important for the chroma processing- | None- -- Additional shorthands in billboard collection- | Eleven | Thirteen | Min11 | Maj13 | Min13- - deriving (Eq, Ord, Enum, Bounded, Generic) ----- | Key relative scale degrees to abstract from the absolute Root notes-type ScaleDegree = Note DiatonicDegree---- | All Diatonic scale degrees -data DiatonicDegree = I | II | III | IV | V | VI | VII - | Imp -- ^ for unrepresentable scale degrees- deriving (Show, Eq, Enum, Ord, Bounded, Generic)---- | Representing absolute 'Root' notes -type Root = Note DiatonicNatural---- | The seven diatonic naturals-data DiatonicNatural = C | D | E | F | G | A | B - | N -- ^ for no root- | X -- ^ for representing unknown roots (used in MIREX)- deriving (Show, Eq, Enum, Ord, Bounded, Generic)- --- | Intervals for additonal chord notes -data Addition = Add (Note Interval)- | NoAdd (Note Interval) deriving (Eq, Ord, Generic)---- | Diatonic major intervals used to denote 'Chord' 'Addition's-data Interval = I1 | I2 | I3 | I4 | I5 | I6 | I7 | I8 | I9 | I10 - | I11 | I12 | I13 - deriving (Eq, Enum, Ord, Bounded, Generic) ---- | A musical note is a pitch (either absolute or relative) posibly modified--- by an 'Accidental'-data Note a = Note (Maybe Accidental) a deriving (Eq, Ord, Generic) - --- | A musical 'Accidental'-data Accidental = Sh -- ^ sharp - | Fl -- ^ flat- | SS -- ^ double sharp- | FF -- ^ double flat- deriving (Eq, Ord, Generic)---- | A 'Triad' comes in four flavours: major, minor, augmented, dimished, and --- sometimes a chord does not have a triad (e.g. suspended chords, etc.)-data Triad = MajTriad | MinTriad | AugTriad | DimTriad | NoTriad - deriving (Ord, Eq, Generic)- ------------------------------------------------------------------------------------ Instances for the general music datatypes--------------------------------------------------------------------------------- --instance Show Key where- show (Key r m) = show r ++ show m- -instance Show Mode where- show MajMode = ""- show MinMode = "m" ---- TODO: it is probably best to derive eq for Chord and define other eq's --- for specific tasks if needed. -instance Eq a => Eq (Chord a) where- (Chord ra sha dega _loc _d) == (Chord rb shb degb _locb _db) - = ra == rb && sha == shb && dega == degb ---- In showing chords, we obey Harte et al.'s syntax as much as possible-instance Show ChordLabel where- show (Chord r None [] _loc _d) = show r ++ (if isRoot r then ":1" else "")- show (Chord r None add _loc _d) = show r ++ ':' : showAdd add- show (Chord r sh add _loc _d) = show r ++ ':' : show sh ++ showAdd add- - -instance Show ChordDegree where- show (Chord r None [] _loc _d) = show r ++ ":1"- show (Chord r None add _loc _d) = show r ++ ':' : showAdd add- show (Chord r sh add _loc _d) = show r ++ ':' : show sh ++ showAdd add - -showAdd :: [Addition] -> String-showAdd [] = ""-showAdd x = '(' : intercalate "," (map show x) ++ ")"--instance Show Shorthand where- show Maj = "maj"- show Min = "min"- show Dim = "dim"- show Aug = "aug"- show Maj7 = "maj7"- show Min7 = "min7"- show Sev = "7"- show Dim7 = "dim7"- show HDim7 = "hdim7"- show MinMaj7 = "minmaj7"- show Maj6 = "maj6"- show Min6 = "min6"- show Maj9 = "maj9"- show Min9 = "min9"- show Min11 = "min11"- show Min13 = "min13"- show Maj13 = "maj13" - show Sus4 = "sus4"- show Sus2 = "sus2"- show Five = "5" - show Nin = "9" - show Eleven = "11"- show Thirteen = "13"- show None = ""- -instance Show ClassType where- show MajClass = ""- show MinClass = "m"- show DomClass = "7"- show DimClass = "0"- show NoClass = "N"---instance Show (Note Interval) where- show (Note m i) = maybe "" show m ++ show i--instance Show (Note DiatonicNatural) where- show (Note m r) = show r ++ maybe "" show m - -instance Show (Note DiatonicDegree) where- show (Note m r) = show r ++ maybe "" show m - -instance Show Interval where- show a = show . ((!!) ([1..13]::[Integer])) - . fromJust $ elemIndex a [minBound..]- - -instance Show Accidental where - show Sh = "#"- show Fl = "b"- show SS = "##"- show FF = "bb" --instance Show Addition where- show (Add n) = show n- show (NoAdd n) = '*' : show n --instance Show Triad where- show MajTriad = "maj"- show MinTriad = "min"- show AugTriad = "aug"- show DimTriad = "dim"- show NoTriad = "NoTriad"- ------------------------------------------------------------------------------------ Tests ------------------------------------------------------------------------------------ | Returns True if the 'Root' is not unknown or none-isRoot :: Root -> Bool-isRoot r | isNone r = False- | isUnknown r = False- | otherwise = True---- | Returns True if the 'Root' is 'N', and False otherwise -isNone :: Root -> Bool-isNone (Note _ N) = True-isNone _ = False---- | Returns True if the 'ChordLabel' is not a chord, and False otherwise -isNoneChord :: ChordLabel -> Bool-isNoneChord = isNone . chordRoot---- | Returns True if the 'Root' is unknown, and False otherwise -isUnknown :: Root -> Bool-isUnknown (Note _ X) = True-isUnknown _ = False---- | Returns true if the 'Chord' 'Addition' represents an addition and not --- a degree that has to be removed (*).-isAddition :: Addition -> Bool-isAddition (Add _) = True-isAddition (NoAdd _) = False------------------------------------------------------------------------------------- Transformation and analysis of chords------------------------------------------------------------------------------------- | Returns the 'ClassType' given a 'Chord'. This function uses --- 'analyseDegClassType' to analyse a chord and derive the 'ClassType'-toClassType :: Chord a -> ClassType-toClassType (Chord _r sh [] _loc _d) = shToClassType sh -- no additions--- combine the degrees and analyse them. N.B., also NoAdd degrees are resolved-toClassType c = analyseDegClassType . toDegreeList $ c---- | Analyses a degree list and returns 'MajTriad', 'MinTriad' or 'NoTriad' if--- the degrees make a chord a major, minor, or no triad, respectivly.-analyseDegClassType :: [Addition] -> ClassType-analyseDegClassType degs = - case (analyseThird degs, analyseFifth degs, analyseSevth degs) of- -- Triads- (_ , _ , MinSev) -> DomClass- (_ , AugFifth , _ ) -> DomClass- (MajThird, DimFifth , _ ) -> DomClass- (MajThird, _ , _ ) -> MajClass- (MinThird, PerfFifth, _ ) -> MinClass- (MinThird, DimFifth , DimSev) -> DimClass- (MinThird, _ , _ ) -> MinClass- (NoThird, _ , _ ) -> NoClass----- | Categorises a 'Shorthand' into a 'ClassType'.-shToClassType :: Shorthand -> ClassType-shToClassType Maj = MajClass-shToClassType Min = MinClass-shToClassType Dim = DimClass-shToClassType Aug = DomClass-shToClassType Maj7 = MajClass-shToClassType Min7 = MinClass-shToClassType Sev = DomClass-shToClassType Dim7 = DimClass-shToClassType HDim7 = MinClass-shToClassType MinMaj7 = MinClass-shToClassType Maj6 = MajClass -shToClassType Min6 = MinClass-shToClassType Nin = DomClass-shToClassType Maj9 = MajClass-shToClassType Min9 = MinClass-shToClassType Five = NoClass-shToClassType Sus2 = NoClass-shToClassType Sus4 = NoClass-shToClassType None = NoClass--- additional Billboard shorthands-shToClassType Min11 = MinClass-shToClassType Eleven = DomClass-shToClassType Min13 = MinClass-shToClassType Maj13 = MajClass-shToClassType Thirteen = DomClass---- should not be exported, used only in toTriad-data Third = MajThird | MinThird | NoThird deriving (Eq, Show)-data Fifth = DimFifth | PerfFifth | AugFifth | NoFifth deriving (Eq, Show)-data Sevth = DimSev | MinSev | MajSev | NoSev deriving (Eq, Show)- --- | Takes a 'Chord' and determines the 'Triad'------ >>> toTriad (Chord (Note Nothing C) Min [NoAdd (Note (Just Fl) I3),Add (Note Nothing I3)] 0 0)--- maj ------ >>> toTriad (Chord (Note Nothing C) HDim7 [Add (Note (Just Sh) I11)] 0 0)--- dim------ >>> toTriad (Chord (Note Nothing C) Min [NoAdd (Note (Just Fl) I3)] 0 0)--- NoTriad----toTriad :: Chord a -> Triad-toTriad (Chord _r sh [] _loc _d) = shToTriad sh -- there are no additions--- combine the degrees and analyse them. N.B., also NoAdd degrees are resolved-toTriad c = analyseDegTriad . toDegreeList $ c---- | Analyses a degree list and returns 'MajTriad', 'MinTriad' or 'NoTriad' if--- the degrees make a chord a major, minor, or no triad, respectivly.-analyseDegTriad :: [Addition] -> Triad-analyseDegTriad degs = - case (analyseThird degs, analyseFifth degs) of- (MajThird, PerfFifth) -> MajTriad- (MajThird, AugFifth ) -> AugTriad- (MajThird, DimFifth ) -> NoTriad- (MinThird, PerfFifth) -> MinTriad- (MinThird, AugFifth ) -> NoTriad- (MinThird, DimFifth ) -> DimTriad- (NoThird, _ ) -> NoTriad- (_ , NoFifth ) -> NoTriad- --- analyses the third in a degree list-analyseThird :: [Addition] -> Third-analyseThird d - | (Add (Note (Just Fl) I3)) `elem` d = MinThird- | (Add (Note Nothing I3)) `elem` d = MajThird- | otherwise = NoThird- --- analyses the fifth in a degree list -analyseFifth :: [Addition] -> Fifth-analyseFifth d - | (Add (Note (Just Fl) I5)) `elem` d = DimFifth- | (Add (Note (Just Sh) I5)) `elem` d = AugFifth- | (Add (Note Nothing I5)) `elem` d = PerfFifth- | otherwise = NoFifth---- analyses the fifth in a degree list -analyseSevth :: [Addition] -> Sevth-analyseSevth d - | (Add (Note (Just FF) I7)) `elem` d = DimSev- | (Add (Note (Just Fl) I7)) `elem` d = MinSev- | (Add (Note Nothing I7)) `elem` d = MajSev- | otherwise = NoSev- --- | Converts a 'Shorthand' to a 'Triad' --- N.B. this function should not be exported because the shorthand alone cannot--- determine the triad -shToTriad :: Shorthand -> Triad -shToTriad Maj = MajTriad-shToTriad Min = MinTriad-shToTriad Dim = DimTriad-shToTriad Aug = AugTriad-shToTriad Maj7 = MajTriad-shToTriad Min7 = MinTriad-shToTriad Sev = MajTriad-shToTriad Dim7 = MinTriad-shToTriad HDim7 = MinTriad-shToTriad MinMaj7 = MinTriad-shToTriad Maj6 = MajTriad -shToTriad Min6 = MinTriad-shToTriad Nin = MajTriad-shToTriad Maj9 = MajTriad-shToTriad Min9 = MinTriad-shToTriad Five = NoTriad-shToTriad Sus2 = NoTriad-shToTriad Sus4 = NoTriad-shToTriad None = NoTriad--- additional Billboard shorthands-shToTriad Min11 = MinTriad-shToTriad Eleven = MajTriad-shToTriad Min13 = MinTriad-shToTriad Maj13 = MajTriad-shToTriad Thirteen = MajTriad---- | Transforms a Chord into a list of relative degrees (i.e. 'Addition's,--- without the root note).--- --- >>> toDegreeList (Chord (Note Nothing C) HDim7 [Add (Note (Just Sh) I11)] 0 0)--- [3b,5b,7b,11#]------ >>> toDegreeList (Chord (Note Nothing C) Min13 [NoAdd (Note Nothing I11)] 0 0)--- [3b,5,7b,9,13]------ >>> toDegreeList (parseData pChord "D:7(b9)")--- [3,5,7b,9b]----toDegreeList :: Chord a -> [Addition]-toDegreeList (Chord _r sh [] _loc _d) = map Add (shToDeg sh)-toDegreeList (Chord _r sh deg _loc _d) = adds \\ (toAdds remv) where-- (adds, remv) = partition isAddition ((map Add . shToDeg $ sh) ++ deg)-- toAdds :: [Addition] -> [Addition]- toAdds = map (\(NoAdd x) -> (Add x))- --- | Expands a 'Shorthand' to its list of degrees-shToDeg :: Shorthand -> [Note Interval] -shToDeg Maj = [Note Nothing I3, Note Nothing I5]-shToDeg Min = [Note (Just Fl) I3, Note Nothing I5]-shToDeg Dim = [Note (Just Fl) I3, Note (Just Fl) I5]-shToDeg Aug = [Note Nothing I3, Note (Just Sh) I5]-shToDeg Maj7 = shToDeg Maj ++ [Note Nothing I7]-shToDeg Min7 = shToDeg Min ++ [Note (Just Fl) I7]-shToDeg Sev = shToDeg Maj ++ [Note (Just Fl) I7]-shToDeg Dim7 = shToDeg Dim ++ [Note (Just FF) I7]-shToDeg HDim7 = shToDeg Dim ++ [Note (Just Fl) I7]-shToDeg MinMaj7 = shToDeg Min ++ [Note Nothing I7]-shToDeg Maj6 = shToDeg Maj ++ [Note Nothing I6]-shToDeg Min6 = shToDeg Min ++ [Note (Just Fl) I6]-shToDeg Nin = shToDeg Sev ++ [Note Nothing I9]-shToDeg Maj9 = shToDeg Maj7 ++ [Note Nothing I9]-shToDeg Min9 = shToDeg Min7 ++ [Note Nothing I9]-shToDeg Five = [Note Nothing I5]-shToDeg Sus2 = [Note Nothing I2, Note Nothing I5]-shToDeg Sus4 = [Note Nothing I4, Note Nothing I5]-shToDeg None = []--- additional Billboard shorthands-shToDeg Min11 = shToDeg Min9 ++ [Note Nothing I11]-shToDeg Eleven = shToDeg Nin ++ [Note Nothing I11]-shToDeg Min13 = shToDeg Min11 ++ [Note Nothing I13]-shToDeg Maj13 = shToDeg Maj9 ++ [Note Nothing I13]-shToDeg Thirteen = shToDeg Eleven ++ [Note Nothing I13]- - --- | Converts a 'Shorthand' to a 'Mode'-toMode :: Triad -> Mode -toMode MajTriad = MajMode-toMode MinTriad = MinMode-toMode t = error ( "HarmTrace.Base.MusicRep.toMode: cannot convert "- ++ " triad to mode: " ++ show t)---- | Converts a 'Shorthand' to either a 'MajClass', 'MinClass' or 'NoClass' --- 'ClassType'.-toMajMin :: Triad -> ClassType-toMajMin MajTriad = MajClass-toMajMin MinTriad = MinClass-toMajMin AugTriad = MajClass-toMajMin DimTriad = MinClass-toMajMin NoTriad = NoClass---- | applies 'toMajMin' to a 'Chord'-toMajMinChord :: ChordLabel -> ChordLabel-toMajMinChord c = c {chordShorthand = majMinSh}- where majMinSh = case toMajMin (toTriad c) of- MajClass -> Maj- MinClass -> Min- NoClass -> None- -- catch all: cannot happen, see toMajMin- _ -> error ("HarmTrace.Base.MusicRep.toMajMinChord"- ++ " unexpected chord " ++ show c)------------------------------------------------------------------------------------ Value Level Scale Degree Transposition--------------------------------------------------------------------------------- - --- Chord root shorthand degrees location duration--- | Given a 'Key', calculates the the 'ChordDegree' (i.e. relative, --- 'ScaleDegree' based 'Chord') for an absolute 'ChordLabel' using --- 'toScaleDegree'.-toChordDegree :: Key -> ChordLabel -> ChordDegree-toChordDegree k (Chord r sh degs loc d) = - Chord (toScaleDegree k r) sh degs loc d - --- | Transformes a absolute 'Root' 'Note' into a relative 'ScaleDegree', given--- a 'Key'.-toScaleDegree :: Key -> Root -> ScaleDegree-toScaleDegree _ n@(Note _ N) = - error ("HarmTrace.Base.MusicRep.toScaleDegree: cannot transpose " ++ show n)-toScaleDegree (Key kr _) cr = -- Note Nothing I- scaleDegrees!!(((toSemitone cr) - (toSemitone kr)) `mod` 12)---- | Simplify note roots to a single enharmonic representation.--- For instance, D♭ becomes C♯, E♯ becomes F, and G𝄫 becomes F.-simplifyRoot :: Root -> Root--- Simplify double sharps-simplifyRoot (Note (Just SS) x) | x == E = Note (Just Sh) F- | x == B = Note (Just Sh) C- | otherwise = Note Nothing (succ x)--- Simplify double flats-simplifyRoot (Note (Just FF) x) | x == F = Note (Just Fl) E- | x == C = Note (Just Fl) B- | otherwise = Note Nothing (pred x)--- Simplify sharps-simplifyRoot (Note (Just Sh) D) = Note (Just Fl) E-simplifyRoot (Note (Just Sh) E) = Note Nothing F-simplifyRoot (Note (Just Sh) G) = Note (Just Fl) A-simplifyRoot (Note (Just Sh) A) = Note (Just Fl) B-simplifyRoot (Note (Just Sh) B) = Note Nothing C--- Simplify flats-simplifyRoot (Note (Just Fl) C) = Note Nothing B-simplifyRoot (Note (Just Fl) D) = Note (Just Sh) C-simplifyRoot (Note (Just Fl) F) = Note Nothing E-simplifyRoot (Note (Just Fl) G) = Note (Just Sh) F--- Everything else must be simple already-simplifyRoot x = x- --- | Transposes a scale degree with @sem@ semitones up-transposeSem :: ScaleDegree -> Int -> ScaleDegree-transposeSem deg sem = scaleDegrees!!((sem + (toSemitone deg)) `mod` 12) where---- | Returns the semitone value [0 .. 11] of a 'ScaleDegree' where--- 0 = C, e.g. F# = 6. For the constructors 'N' and 'X' an error is thrown.-toSemitone :: (Show a, Enum a) => Note a -> Int-toSemitone (Note m p) - | ix <= 6 = noNegatives (([0,2,4,5,7,9,11] !! ix) + modToSemi m) `mod` 12- | otherwise = error ("HarmTrace.Base.MusicRep.toSemitone: no semitone for "- ++ show p ++ maybe "" show m )- where ix = fromEnum p- noNegatives s | s < 0 = 12 + s- | otherwise = s---- | The reverse of 'toSemitone' returning the 'Note DiatonicNatural' given a --- Integer [0..11] semitone, where 0 represents C. When the integer is out --- of the range [0..11] an error is thrown.-toRoot :: Int -> Root-toRoot i - | 0 <= i && i <= 11 = roots !! i- | otherwise = error ("HarmTrace.Base.MusicRep.toRoot " ++- "invalid semitone: " ++ show i)- --- | Transforms type-level Accidentals to semitones (Int values)-modToSemi :: Maybe Accidental -> Int-modToSemi Nothing = 0-modToSemi (Just Sh) = 1-modToSemi (Just Fl) = -1-modToSemi (Just SS) = 2-modToSemi (Just FF) = -2---- | A list of 12 'ScaleDegree's, ignoring pitch spelling.-scaleDegrees ::[ ScaleDegree ] -scaleDegrees = [ Note Nothing I- , Note (Just Sh) I- , Note Nothing II- , Note (Just Fl) III- , Note Nothing III- , Note Nothing IV- , Note (Just Sh) IV- , Note Nothing V- , Note (Just Fl) VI- , Note Nothing VI- , Note (Just Fl) VII- , Note Nothing VII- ]- ---- | A list of 12 'Note DiatonicNatural's, ignoring pitch spelling.-roots :: [ Root ] -roots = [ Note Nothing C- , Note (Just Sh) C- , Note Nothing D- , Note (Just Fl) E- , Note Nothing E- , Note Nothing F- , Note (Just Sh) F- , Note Nothing G- , Note (Just Fl) A- , Note Nothing A- , Note (Just Fl) B- , Note Nothing B- ]------------------------------------------------------------------------------------- Binary instances-----------------------------------------------------------------------------------instance Binary Key-instance Binary Mode -instance Binary PieceLabel-instance Binary a => Binary (Chord a)-instance Binary ClassType-instance Binary Shorthand-instance Binary DiatonicDegree-instance Binary DiatonicNatural-instance Binary Addition-instance Binary Interval-instance Binary a => Binary (Note a)-instance Binary Accidental-instance Binary Triad
− src/HarmTrace/Base/MusicTime.hs
@@ -1,308 +0,0 @@-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DeriveFunctor #-}------------------------------------------------------------------------------------- |--- Module : HarmTrace.Base.MusicTime--- Copyright : (c) 2012--2013 W. Bas de Haas and Jose Pedro Magalhaes--- License : LGPL-3------ Maintainer : bas@chordify.net, dreixel@chordify.net --- Stability : experimental--- Portability : non-portable------ Summary: A set of types and classes for representing musical time, mainly--- (but not necessarily) in the context of recognising chords --- from an arbitrary audio source.-----------------------------------------------------------------------------------module HarmTrace.Base.MusicTime (- - -- * Datatypes- -- ** Types for representing Chords and their probabilities- ChordAnnotation - , ProbChordSeg (..)- , ProbChord (..)- , ChordCand (..)- - -- ** Representing musical time- , TimedData (..)- , Beat (..)- , BarTime (..)- , BarTimeTrackData - , NumData - - -- ** Representing raw audio data - , AudioFeat (..)- , ChordinoData - , ChordinoLine (..)- , KeyStrengthData - , BeatTrackerData - , BeatChroma - , ChordStruct -- -- * Functions- -- ** Data access- , timedData- , timedDataBT- , getBarTime - , getBeat - , onset- , offset- , setData- -- ** Type conversion and other utilities- , getBeatTrack- , concatTimedData- , nextBeat- , prevBeat - , updateTPChord- , dropProb- , dropTimed- , timeStamp- , beat - , prettyPrint--) where- -import HarmTrace.Base.MusicRep-import Data.List (intercalate)---- | When reducing and expaninding 'TimedData' types there might be rounding--- errors in the floating point time stamps. The 'roundingError' parameter--- sets the acceptable rounding error that is used in the comparison of --- time stamps (e.g. see 'timeComp')-roundingError :: NumData -roundingError = 0.0001 -- = one milisecond ---- | A type synonym is defined for our main numerical representation, this --- allows us to easily change the precision.-type NumData = Double------------------------------------------------------------------------------------- High-level structure------------------------------------------------------------------------------------- | A chord annotation consists of a--- list with chords and segment boundaries.-type ChordAnnotation = [TimedData ProbChord]---- | A datatype that wraps around an (musical) datatype, adding information --- about the musical time to this datatype. Musical time is stored as --- a list of 'BarTime' time stamps that can optionally be augmented--- with information about the 'Beat' position of the particular time stamp --- inside the bar.-data TimedData a = TimedData { -- | Returns the contained datatype - getData :: a - -- | Returns the list of TimeStamps- , getTimeStamps :: [BarTime]- } deriving (Functor, Show, Eq)---- | Clustering 'ProbChord's in a collection of chords that share a key-data ProbChordSeg = Segment { segKey :: Key - , segChords :: [TimedData [ProbChord]] - } deriving (Show, Eq)- - --- | Combines a 'ChordLabel' with a probability.-data ProbChord = ProbChord { chordLab :: ChordLabel- , prob :: NumData- }---- | A chord candidate: an intermediate datatype that matches shorthand, --- chord structure and root note (plus inversion)-data ChordCand = ChordCand { originalRootCC :: Root- , inversionRootCC :: Root- , shorthardCC :: Shorthand- , chordStructCC :: ChordStruct - } deriving (Show, Eq)---- | A chord template is list of 'NumData's-type ChordStruct = [NumData] ---- | For now, we fix the number of available beats to four, because this is also--- hard-coded into the bar and beat-tracker.-data Beat = One | Two | Three | Four | NoBeat deriving (Eq, Enum)------------------------------------------------------------------------------------- Instances of high-level data structure------------------------------------------------------------------------------------- TODO to be replaced by a deriving instance-instance Eq (ProbChord) where- a == b = chordLab a == chordLab b- -instance Show (ProbChord) where- show (ProbChord c p) = show c ++ ':' : show p- -instance Show Beat where- show One = "1"- show Two = "2"- show Three = "3"- show Four = "4"- show NoBeat = "x"--instance Show BarTime where- show (BarTime t bt) = '(' : show t ++ ", " ++ show bt ++ ")"- show (Time t) = '(' : show t ++ ")"-- ------------------------------------------------------------------------------------ numerical data representation------------------------------------------------------------------------------------- | Groups the three types of VAMP plug-in data: 'ChordinoData', --- 'BarTimeTrackData', and 'KeyStrengthData'. See for more information:------ * <http://www.vamp-plugins.org>------ * <http://isophonics.net/nnls-chroma>------ * <http://omras2.org/SonicAnnotator>-data AudioFeat = AudioFeat { getChroma :: ChordinoData - , getBeats :: BarTimeTrackData- , getKeys :: KeyStrengthData - , getAudioFeatId :: FilePath}--type ChordinoData = [ChordinoLine] ---- | Represents two chroma features and a time stamp. -data ChordinoLine = ChordinoLine -- TODO remove useless type synonym- { - -- | Returns the time stamp of the chroma features- time :: NumData - -- | Returns the bass chroma feature- , bass :: [NumData] -- each of the lists has always 12 elements - -- | Returns the treble chroma feature- , treb :: [NumData] -- A, Bb, B, C, Db, D, Eb, E, F, F#, G, Ab - } deriving (Eq, Show) -- and is shifted 3 positions to match C, Db, .., B- -type KeyStrengthData = ChordinoData --type BeatTrackerData = [NumData]---- TODO Rename to BeatTime--- | Represents a musical time stamp, which is a 'NumData' possibly augmented--- with a 'Beat' denoting the position of the time stamp within a bar.-data BarTime = BarTime NumData Beat- | Time NumData deriving Eq--type BarTimeTrackData = [BarTime]--type BeatChroma = TimedData [ChordinoLine] -- one list per beat---- we compare based on the timestamp only-instance Ord BarTime where- compare a b = compare (timeStamp a) (timeStamp b)------------------------------------------------------------------------------------- Some type conversion utilities------------------------------------------------------------------------------------- | alternative 'TimedData' constructor-timedData :: a -> NumData -> NumData -> TimedData a-timedData d x y = TimedData d [Time x, Time y]---- | alternative 'TimedData' constructor-timedDataBT :: a -> BarTime -> BarTime -> TimedData a-timedDataBT d x y = TimedData d [x, y]---- | concatenates the 'BarTime' timestamps of two 'TimedData's and --- creates a new 'TimedData' that stores the first argument. -concatTimedData :: a -> TimedData a -> TimedData a -> TimedData a-concatTimedData dat (TimedData _ ta) (TimedData _ tb) = - TimedData dat (mergeBeatTime ta tb) where-- mergeBeatTime :: [BarTime] -> [BarTime] -> [BarTime]- mergeBeatTime [] b = b- mergeBeatTime a [] = a- mergeBeatTime a b = case timeComp (timeStamp . last $ a) - (timeStamp . head $ b) of- GT -> error ("HarmTrace.Base.MusicTime.mergeBeatTime: " ++- "cannot merge BeatTimes " ++ show a ++ " and " ++ show b)- EQ -> a ++ tail b -- do not include the same timestamp twice- LT -> a ++ b - --- | compares to 'NumData' timestamps taking a rounding error 'roundingError'--- into account.-timeComp :: NumData -> NumData -> Ordering-timeComp a b - | a > (b + roundingError) = GT- | a < (b - roundingError) = LT- | otherwise = EQ---- | Converts 'BarTimeTrackData' into 'BeatTrackerData'-getBeatTrack :: BarTimeTrackData -> BeatTrackerData-getBeatTrack = map timeStamp---- | wraps a datatype in 'TimedData'-setData :: TimedData a -> b -> TimedData b-setData td d = td {getData = d}---- | Returns the start time stamp-getBarTime :: TimedData a -> BarTime-getBarTime td = case getTimeStamps td of- [] -> error "HarmTrace.Base.MusicTime.getBarTime: no timestamps are stored"- (h:_) -> h---- | Returns the start 'Beat'-getBeat :: TimedData a -> Beat-getBeat = beat . getBarTime ---- | Returns the 'NumData' timestamp, given a 'BarTime'-timeStamp :: BarTime -> NumData-timeStamp (BarTime t _bt) = t-timeStamp (Time t ) = t ---- | Returns the 'NumData' timestamp, given a 'BarTime'-beat :: BarTime -> Beat-beat (BarTime _t bt) = bt-beat (Time _t ) = NoBeat---- | Returns the onset time stamp-onset :: TimedData a -> NumData-onset = timeStamp . getBarTime ---- | Returns the offset time stamp-offset :: TimedData a -> NumData-offset td = case getTimeStamps td of- [] -> error "HarmTrace.Base.MusicTime.offset: no timestamps are stored"- l -> timeStamp . last $ l---- TODO: replace by ad-hoc enum instance?--- | returns the next beat, e.g. @ nextBeat Two = Three @. --- Following the (current) definition of 'Beat', we still assume 4/4, in the --- future this function should also have the meter as an argument.-nextBeat, prevBeat :: Beat -> Beat -nextBeat Four = One-nextBeat b = succ b---- | returns the previous 'Beat', similar to 'prevBeat'.-prevBeat One = Four-prevBeat b = pred b---- | Updates transforms ChordLabel wrapped in a 'ProbChord' and 'TimedData'-updateTPChord :: (ChordLabel -> ChordLabel) -> TimedData ProbChord - -> TimedData ProbChord-updateTPChord f = fmap (update f) where- update g (ProbChord c p) = (ProbChord (g c) p)---- | drops the probabilties paired with chordlabels (in a list of 'ProbChord's)--- and returns a list of 'ChordLabel's-dropProb :: [TimedData ProbChord] -> [TimedData ChordLabel]-dropProb = map (fmap chordLab)---- | drops the time (with or without 'Beat') information of a list --- 'Timed' data structure -dropTimed :: [TimedData a] -> [a]-dropTimed = map getData---- | Pretty prints a list of 'TimedData's, one per line-prettyPrint :: Show a => [TimedData a] -> String-prettyPrint = intercalate "\n" . map pprint where-- pprint :: Show a => TimedData a -> String- pprint (TimedData d [ ]) = "not set - not set: " ++ show d- pprint (TimedData d [x]) = show x ++" - not set: " ++ show d- pprint (TimedData d ts ) = show (head ts) ++ " - " ++ show (last ts) - ++ ": " ++ show d
+ src/HarmTrace/Base/Parse.hs view
@@ -0,0 +1,21 @@+{-# OPTIONS_GHC -Wall #-} +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Base.Parse +-- Copyright : (c) 2012--2016, Chordify BV +-- License : LGPL-3 +-- +-- Maintainer : haskelldevelopers@chordify.net +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: An interface to all the sub modules of HarmTrace.Base.Parse +-------------------------------------------------------------------------------- + +module HarmTrace.Base.Parse ( + module HarmTrace.Base.Parse.General + , module HarmTrace.Base.Parse.ChordParser + ) where + +import HarmTrace.Base.Parse.General +import HarmTrace.Base.Parse.ChordParser
+ src/HarmTrace/Base/Parse/ChordParser.hs view
@@ -0,0 +1,176 @@+{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE FlexibleContexts #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Base.Parse.ChordParser +-- Copyright : (c) 2012--2016, Chordify BV +-- License : LGPL-3 +-- +-- Maintainer : haskelldevelopers@chordify.net +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Some general parsing utilities used for parsing textual chord +-- representations. +-------------------------------------------------------------------------------- + +module HarmTrace.Base.Parse.ChordParser ( + -- * Parsing (elements of) chords + pChord + , pShorthand + , pRoot + , pAdditions + , pAddition + , pKey + , pBeat + ) where + +import HarmTrace.Base.Parse.General +import HarmTrace.Base.Chord +import HarmTrace.Base.Time + +import Data.List ( sort ) + +-------------------------------------------------------------------------------- +-- Parsing String of Musical Chords +-------------------------------------------------------------------------------- + +-- | Parses a 'ChordLabel' in Harte et al. syntax including possible additions, +-- and removal of chord additions. If a chord has no 'Shorthand', the 'Degree' +-- list (if any) is analysed and depending on the 'Triad' (if any) a +-- 'Maj', 'Min','Aug', or 'Dim' 'Shorthand' is stored. By default all the +-- duration stored in every 'Chord' is 1 (where the unit is application +-- depended, often these are beats, but they can also be eighth notes) +pChord :: Parser ChordLabel +{-# INLINE pChord #-} +pChord = pChordLabel + <|> (NoChord <$ (pString "N" <|> pString "&pause")) + <|> (UndefChord <$ (pSym '*' <|> pSym 'X')) + <?> "Chord" + +-- Parses a chord label +pChordLabel :: Parser ChordLabel +{-# INLINE pChordLabel #-} +pChordLabel = mkChord <$> pRoot <* (pSym ':' `opt` ':') + <*> pMaybe pShorthand + <*> (pAdditions `opt` []) + <*> pInversion where + + mkChord :: Root -> Maybe Shorthand -> [Addition] -> Either Interval Root + -> ChordLabel + -- if there are no degrees and no shorthand, following Harte it + -- should be labelled a Maj chord + mkChord r Nothing [] b = Chord r Maj [] (toInversion r b) + mkChord r Nothing a b = toChord r (addToIntSet a) (toInversion r b) + mkChord r (Just s) a b = Chord r s a (toInversion r b) + + toInversion :: Root -> Either Interval Root -> Interval + toInversion _ (Left iv) = iv + toInversion ra (Right rb) = pitchToInterval ra rb + + +pInversion :: Parser (Either Interval Root) +pInversion = Left <$ pSym '/' <*> pIntNote + <|> Right <$ pSym '/' <*> pRoot + <<|> pure (Left $ Note Nat I1) + <?> "/Inversion" + +-- | parses a musical key description, e.g. @C:maj@, or @D:min@ +pKey :: Parser Key +pKey = f <$> pRoot <* pSym ':' <*> pShorthand <?> "Key" + where f r m | m == Maj = Key r MajMode + | m == Min = Key r MinMode + | otherwise = error ("Tokenizer: key must be Major or Minor, " + ++ "found: " ++ show m) + +-- | Parses a shorthand following Harte et al. syntax, but also the 'Shorthand's +-- added to the Billboard dataset, e.g. @maj@, @min@, or @9@. +pShorthand :: Parser Shorthand +{-# INLINE pShorthand #-} +pShorthand = Maj <$ pString "maj" + <|> Min <$ pString "min" + <|> Dim <$ pString "dim" + <|> Aug <$ pString "aug" + <|> Maj7 <$ pString "maj7" + <|> Min7 <$ pString "min7" + <|> Sev <$ pString "7" + <|> Dim7 <$ pString "dim7" + <|> HDim7 <$ pString "hdim" <* opt (pSym '7') '7' + <|> MinMaj7 <$ pString "minmaj7" + <|> Aug7 <$ pString "aug7" + <|> Maj6 <$ pString "maj6" + <|> Maj6 <$ pString "6" + <|> Min6 <$ pString "min6" + <|> Nin <$ pString "9" + <|> Maj9 <$ pString "maj9" + <|> Min9 <$ pString "min9" + <|> Five <$ pString "5" + <|> Sus2 <$ pString "sus2" + <|> Sus4 <$ pString "sus4" + <|> SevSus4 <$ pString "7sus4" + -- additional Billboard shorthands + <|> Min11 <$ pString "min11" + <|> Min13 <$ pString "min13" + <|> Maj13 <$ pString "maj13" + <|> Eleven <$ pString "11" + <|> Thirteen <$ pString "13" + <|> None <$ pString "1" -- no shorthand: used in billboard to + -- denote a rootnote only + <?> "Shorthand" + +-- | Parses a list of 'Chord' 'Addition's within parenthesis +pAdditions :: Parser [Addition] +pAdditions = sort <$> pPacked (pSym '(') (pSym ')') ( pListSep (pSym ',') pAddition ) + <?> "Addition List" + +-- | Parses the a 'Chord' 'Addition' (or the removal of a chord addition, +-- prefixed by a @*@) +pAddition :: Parser Addition +pAddition = (Add <$> pIntNote) + <|> (NoAdd <$> (pSym '*'*> pIntNote)) + <?> "Addition" + +-- | Parses an 'Interval' +pIntNote :: Parser Interval +pIntNote = Note <$> pAccidental <*> pInterval + +-- | Parses in 'Accidental' +pAccidental :: Parser Accidental +pAccidental = Sh <$ pSym 's' + <|> Sh <$ pSym '#' + <|> Fl <$ pSym 'b' + <|> SS <$ pString "ss" + <|> SS <$ pString "##" + <|> FF <$ pString "bb" + <|> pure Nat <?> "Accidental" + +-- | Parses an 'Interval' +pInterval :: Parser IntNat +pInterval = foldr (<|>) pFail opts <?> "Interval" where + opts = [i <$ pString (show i) | i <- [minBound..] ] + +-- | Parses a 'Root' 'Note', e.g. @A@, @Bb@, or @F#@. +pRoot :: Parser Root +{-# INLINE pRoot #-} +pRoot = (flip Note) <$> pDiaNat <*> pAccidental + +-- | Parses a 'DiatonicNatural'. +pDiaNat :: Parser DiatonicNatural +{-# INLINE pDiaNat #-} +pDiaNat = A <$ pSym 'A' + <|> B <$ pSym 'B' + <|> C <$ pSym 'C' + <|> D <$ pSym 'D' + <|> E <$ pSym 'E' + <|> F <$ pSym 'F' + <|> G <$ pSym 'G' + +-- | Parses a 'Beat'. +pBeat :: Parser Beat +pBeat = One <$ pSym '1' + <|> Two <$ pSym '2' + <|> Three <$ pSym '3' + <|> Four <$ pSym '4' + <|> NoBeat <$ pSym 'x' + <?> "Beat"
+ src/HarmTrace/Base/Parse/General.hs view
@@ -0,0 +1,89 @@+{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE FlexibleContexts #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Base.Parse.General +-- Copyright : (c) 2012--2016, Chordify BV +-- License : LGPL-3 +-- +-- Maintainer : haskelldevelopers@chordify.net +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Some general parsing utilities used for parsing textual chord +-- representations. +-------------------------------------------------------------------------------- + + +module HarmTrace.Base.Parse.General ( -- * Top level parsers + parseData + , parseDataWithErrors + , parseDataSafe + -- * Some general parsers + , pString + , pLineEnd + , pManyTill + -- Re-exporting the uu-parsinglib + , module Text.ParserCombinators.UU + , module Text.ParserCombinators.UU.Utils + , module Text.ParserCombinators.UU.BasicInstances + -- , module Data.ListLike.Base + ) where + +import Text.ParserCombinators.UU +import Text.ParserCombinators.UU.Utils hiding ( pSpaces ) +import Text.ParserCombinators.UU.BasicInstances hiding ( IsLocationUpdatedBy ) +import Data.ListLike.Base ( ListLike ) +import Data.List ( intersperse ) + +-------------------------------------------------------------------------------- +-- A collection of parsing functions used by parsers throughout the project +-------------------------------------------------------------------------------- + +-- | This is identical to 'parseData' however it will throw an 'error' when +-- the the list with parsing errors is not empty. No, this will not make your +-- program more \safe\. However, in certain cases you really want to be sure +-- that parsing has finished without errors. In those cases you should use +-- 'parseDataSafe'. +parseDataSafe :: (ListLike s a, Show a, Show s) => + P (Str a s LineColPos) b -> s -> b +parseDataSafe p inp = case parseDataWithErrors p inp of + (dat, [] ) -> dat + (_ , err) -> error ("HarmTrace.Base.Parsing: a parsing" + ++ " function did not finish without errors. While" + ++ " parsing the data starting with:\n" + ++ (take 80 $ show inp) + ++ "\nThe following errors were encountered:\n" + ++ (concat . intersperse "\n" . take 50 + . map show $ err)) + +-- | Top-level parser that ignores error-reporting, regardless of there were +-- error in the parse +parseData :: (ListLike s a, Show a) => P (Str a s LineColPos) b -> s -> b +parseData p inp = fst ( parseDataWithErrors p inp ) + +-- | Top-level parser that returns both the result as well as a (possibly empty) +-- list of error-corrections. +parseDataWithErrors :: (ListLike s a, Show a) + => P (Str a s LineColPos) b -> s -> (b, [Error LineColPos]) +parseDataWithErrors p inp = (parse ( (,) <$> p <*> pEnd) + (createStr (LineColPos 0 0 0) inp)) + +-- | Parses a specific string +pString :: (ListLike state a, IsLocationUpdatedBy loc a, Show a, Eq a) + => [a] -> P (Str a state loc) [a] +{-# INLINABLE pString #-} +pString s = foldr (\a b -> (:) <$> a <*> b) (pure []) (map pSym s) + +-- | Parses UNIX and DOS/WINDOWS line endings including trailing whitespace +pLineEnd :: Parser String +pLineEnd = pString "\n" <|> pString "\r\n" <|> pString " " <|> pString "\t" + +-- | Parses an arbitrary times the first parsing combinator until the parsing +-- second parsing combinator is encountered. The result of the second parsing +-- combinator is ignored. +pManyTill :: P st a -> P st b -> P st [a] +pManyTill p end = [] <$ end + <<|> + (:) <$> p <*> pManyTill p end
− src/HarmTrace/Base/Parsing.hs
@@ -1,90 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE FlexibleContexts #-}------------------------------------------------------------------------------------- |--- Module : HarmTrace.Base.Parsing--- Copyright : (c) 2012--2013 W. Bas de Haas and Jose Pedro Magalhaes--- License : LGPL-3------ Maintainer : bas@chordify.net, dreixel@chordify.net --- Stability : experimental--- Portability : non-portable------ Summary: Some general parsing utilities used for parsing textual chord--- representations.------------------------------------------------------------------------------------module HarmTrace.Base.Parsing ( -- * Top level parsers - parseData- , parseDataWithErrors- , parseDataSafe- -- * Some general parsers- , pString- , pLineEnd- , pManyTill- -- Re-exporting the uu-parsinglib- , module Data.ListLike.Base- , module Text.ParserCombinators.UU - , module Text.ParserCombinators.UU.Utils- , module Text.ParserCombinators.UU.BasicInstances- ) where--import Text.ParserCombinators.UU-import Text.ParserCombinators.UU.Utils hiding (pSpaces)-import Text.ParserCombinators.UU.BasicInstances hiding (IsLocationUpdatedBy)-import Data.ListLike.Base (ListLike)-import Data.List (intersperse)------------------------------------------------------------------------------------- A collection of parsing functions used by parsers throughout the project--------------------------------------------------------------------------------- ---- | This is identical to 'parseData' however it will throw an 'error' when--- the the list with parsing errors is not empty. No, this will not make your--- program more \safe\. However, in certain cases you really want to be sure--- that parsing has finished without errors. In those cases you should use--- 'parseDataSafe'.-parseDataSafe :: (ListLike s a, Show a, Show s) => - P (Str a s LineColPos) b -> s -> b-parseDataSafe p inp = case parseDataWithErrors p inp of- (dat, [] ) -> dat- (_ , err) -> error ("HarmTrace.Base.Parsing: a parsing"- ++ " function did not finish without errors. While" - ++ " parsing the data starting with:\n"- ++ (take 80 $ show inp)- ++ "\nThe following errors were encountered:\n"- ++ (concat . intersperse "\n" . take 50 - . map show $ err))---- | Toplevel parser that ignores error-reporting, regardless of there were--- error in the parse-parseData :: (ListLike s a, Show a) => P (Str a s LineColPos) b -> s -> b-parseData p inp = fst ( parseDataWithErrors p inp )---- | Toplevel parser that returns both the result as well as a (possibly empty)--- list of error-corrections.-parseDataWithErrors :: (ListLike s a, Show a) - => P (Str a s LineColPos) b -> s -> (b, [Error LineColPos])-parseDataWithErrors p inp = (parse ( (,) <$> p <*> pEnd) - (createStr (LineColPos 0 0 0) inp))- --- | Parses a specific string-pString :: (ListLike state a, IsLocationUpdatedBy loc a, Show a, Eq a) - => [a] -> P (Str a state loc) [a]-{-# INLINABLE pString #-} -pString s = foldr (\a b -> (:) <$> a <*> b) (pure []) (map pSym s)---- | Parses UNIX and DOS/WINDOWS line endings including trailing whitespace-pLineEnd :: Parser String-pLineEnd = pString "\n" <|> pString "\r\n" <|> pString " " <|> pString "\t"---- | Parses an arbitrary times the first parsing combinator until the parsing --- second parsing combinator is encountered. The result of the second parsing--- combinator is ignored.-pManyTill :: P st a -> P st b -> P st [a]-pManyTill p end = [] <$ end - <<|> - (:) <$> p <*> pManyTill p end-
+ src/HarmTrace/Base/Time.hs view
@@ -0,0 +1,442 @@+ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Base.MusicTime +-- Copyright : (c) 2012--2016, Chordify BV +-- License : LGPL-3 +-- +-- Maintainer : haskelldevelopers@chordify.net +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: A set of types and classes for representing musical time, mainly +-- (but not necessarily) in the context of recognising chords +-- from an arbitrary audio source. +-------------------------------------------------------------------------------- + +module HarmTrace.Base.Time ( + + -- ** Representing musical time + Timed + , DTimed + , Timed' (..) + , Beat (..) + , BeatTime (..) + , MeterKind (..) + , BPM (..) + + -- * Functions + -- ** Data access + , timed + , timedBT + , onBeatTime + , offBeatTime + , onBeat + , offBeat + , onset + , offset + , duration + , setData + , getEndTime + + -- ** Type conversion and other utilities + -- , fromDurations + , mergeTimed + , mergeTimedWith + , expandTimed + , concatTimed + , splitTimed + , setMeterKind + , updateBeats + , updateBeat + , splitPickup -- remove + , nextBeat + , prevBeat + , lastBeat + , updBeat + , updTime + , updateTimeStamp + , dropTimed + , timeStamp + , timeComp + , roundingError + , beat + , pprint + , prettyPrint + , estimateTempo + +) where + +import Data.List ( intercalate, mapAccumL, sort ) +import Data.Ratio ( (%) ) +import Data.Binary ( Binary ) +import GHC.Generics ( Generic ) + +-- | When reducing and expanding 'Timed' types there might be rounding +-- errors in the floating point time stamps. The 'roundingError' parameter +-- sets the acceptable rounding error that is used in the comparison of +-- time stamps (e.g. see 'timeComp') +roundingError :: Fractional t => t +roundingError = fromRational (1 % 1000) -- = one millisecond + +-------------------------------------------------------------------------------- +-- High-level structure +-------------------------------------------------------------------------------- + +-- | a shorthand for a 'Timed'' datatype that uses 'Float' precision +-- (also for backwards competibility) +type Timed a = Timed' Float a + +-- | a shorthand for 'Double' precision +type DTimed a = Timed' Double a + +-- | A datatype that wraps around an (musical) datatype, adding information +-- about the musical time to this datatype. Musical time is stored as +-- a list of 'BeatTime' time stamps that can optionally be augmented +-- with information about the 'Beat' position of the particular time stamp +-- inside the bar. +data Timed' t a = Timed { getData :: a + -- ^ Returns the contained datatype + , getTimeStamps :: [BeatTime t] + -- ^ Returns the list of TimeStamps + } deriving (Functor, Show, Eq, Generic) + +-- | For now, we fix the number of available beats to four, because this is also +-- hard-coded into the bar and beat-tracker. +data Beat = One | Two | Three | Four | NoBeat deriving (Eq, Ord, Enum, Generic) + +-- | Having a high-level representation of a musical meter: 'Duple' is +-- counted in two and 'Triple' in three. +data MeterKind = Duple | Triple deriving (Eq, Show, Ord, Generic) + +-- | Number of beats per minute +newtype BPM = BPM {bpm :: Int} deriving (Show, Eq, Ord, Generic, Num) + +-------------------------------------------------------------------------------- +-- Instances of high-level data structure +-------------------------------------------------------------------------------- + +instance Binary Beat +instance Binary a => Binary (BeatTime a) +instance (Binary t, Binary a) => Binary (Timed' t a) + +instance Show Beat where + show One = "1" + show Two = "2" + show Three = "3" + show Four = "4" + show NoBeat = "x" + +instance (Show t, Fractional t) => Show (BeatTime t) where + show (BeatTime t bt) = '(' : showFracShort t ++ ',' : show bt ++ ")" + show (Time t) = '(' : showFracShort t ++ ")" + +showFracShort :: (Show t, Fractional t) => t -> String +showFracShort = take 5 . show + +-------------------------------------------------------------------------------- +-- numerical data representation +-------------------------------------------------------------------------------- + +-- | Represents a musical time stamp, which is a 'NumData' possibly augmented +-- with a 'Beat' denoting the position of the time stamp within a bar. +data BeatTime a = BeatTime a Beat + | Time a deriving (Functor, Eq, Generic) + +-- we compare based on the timestamp only +instance (Ord t, Fractional t) => Ord (BeatTime t) where + compare a b = compare (timeStamp a) (timeStamp b) + +-------------------------------------------------------------------------------- +-- Some type conversion utilities +-------------------------------------------------------------------------------- +{- +fromDurations :: NumData -> [(a,NumData)] -> [Timed a] +fromDurations z td = foldl' step [] td where + + step :: [Timed a] -> (a, NumData) -> [Timed a] + step [] (a, x) = [TimedData x [Time z, Time x]] + step [Timed _ [Time _, Time o]] (a, x) = [TimedData x [Time o, Time x]] +-} + +-- | alternative 'Timed' constructor +timed :: Fractional t => a -> t -> t -> Timed' t a +timed d x y = Timed d [Time x, Time y] + +-- | alternative 'Timed' constructor +timedBT :: Fractional t => a -> BeatTime t -> BeatTime t -> Timed' t a +timedBT d x y = Timed d [x, y] + +-- | concatenates the 'BeatTime' timestamps of two 'Timed's and +-- creates a new 'Timed' that stores the first argument. +-- N.B. this function uses 'timeComp' to allow for very small timing deviations +concatTimed :: a -> Timed a -> Timed a -> Timed a +concatTimed dat (Timed _ ta) (Timed _ tb) = + Timed dat (mergeBeatTime ta tb) where + + mergeBeatTime :: (Ord t, Show t, Fractional t) + => [BeatTime t] -> [BeatTime t] -> [BeatTime t] + mergeBeatTime [] b = b + mergeBeatTime a [] = a + mergeBeatTime a b = case timeComp (timeStamp . last $ a) + (timeStamp . head $ b) of + GT -> error ("HarmTrace.Base.MusicTime.mergeBeatTime: " ++ + "cannot merge BeatTimes " ++ show a ++ " and " ++ show b) + EQ -> a ++ tail b -- do not include the same timestamp twice + LT -> a ++ b + + +-- | the inverse of 'mergeTimed', expanding the list 'Timed' elements to all +-- timestamps stored in the 'getTimeStamps' list. N.B. +-- +-- >>> expandTimed (mergeTimed x) = x :: [Timed a] +-- +-- also, +-- +-- >>> (expandTimed cs) = cs +-- +-- and, +-- +-- >>> mergeTimed (mergeTimed (mergeTimed cs)) = (mergeTimed cs) +-- +-- hold. This has been tested on the first tranche of 649 Billboard songs. +expandTimed :: [Timed a] -> [Timed a] +expandTimed = concatMap replic where + + replic :: Timed a -> [Timed a] + replic (Timed c ts) = let reps = repeat c + in zipWith3 timedBT (c : reps) ts (tail ts) + +-- | merges consecutive 'Timed' values that store the same element (using +-- ('(==)'). For example: +-- +-- >>> mergeTimed [timed "c" 0 1, timed "c" 1 2, timed "d" 3 4, timed "d" 4 5, timed "e" 5 6] +-- >>> [Timed {getData = "c", getTimeStamps = [(0.0),(1.0),(2.0)]} +-- >>> ,Timed {getData = "d", getTimeStamps = [(3.0),(4.0),(5.0)]} +-- >>> ,Timed {getData = "e", getTimeStamps = [(5.0),(6.0)]}] +-- +mergeTimed :: Eq a => [Timed a] -> [Timed a] +mergeTimed = mergeTimedWith (==) + +-- | Does exactly what 'mergeTimed' does, but allows for a custom equality +-- function +mergeTimedWith :: forall a. Eq a => (a -> a -> Bool) -> [Timed a] -> [Timed a] +mergeTimedWith eq = foldr groupT [] where + + groupT :: Eq a => Timed a -> [Timed a] -> [Timed a] + groupT c [] = [c] + groupT tc@(Timed c _ ) (th@(Timed h _ ) : t) + | c `eq` h = concatTimed c tc th : t + | otherwise = tc : th : t + +-- | Splits a 'Timed' in two 'Timed's at the specified position. If +-- the position is out of range, an error is thrown. +-- +-- >>> splitTimed (Timed "x" [Time 2, Time 5]) 4 +-- >>> ( Timed {getData = "x", getTimeStamps = [(2.0),(4.0)]} +-- >>> , Timed {getData = "x", getTimeStamps = [(4.0),(5.0)]} ) +splitTimed :: (Show a, Ord t, Show t, Fractional t) + => Timed' t a -> t -> (Timed' t a, Timed' t a) +splitTimed td@(Timed d t) s + | s > onset td = case span ((< s) . timeStamp) t of + (_, []) -> e + (x, y ) -> ( Timed d (x ++ [Time s]) + , Timed d (Time s : y )) + | otherwise = e + where e = error ( "HarmTrace.Base.MusicTime.splitTimed: Timestamp " + ++ show s ++ " not in range of Timed: " ++ show td) + +-- | Changes the internal 'MeterKind' of a 'Timed' sequence. We assume +-- that meter changes do nog occur. +setMeterKind :: MeterKind -> [Timed a] -> [Timed a] +setMeterKind _ [] = [] +setMeterKind mk x = + let (pu, cs) = splitPickup x -- will expand the chords + + srtpu = (iterate (prevBeat mk) (lastBeat mk)) !! (pred . length $ pu) + srt = onBeat (head cs) + + in (updateBeats mk srtpu pu) ++ + (updateBeats mk srt cs) + +-- TODO: maybe setBeats is a better name..? +-- | applies updateBeat to a list. 'updateBeats' requires a 'MeterKind' +-- and a starting 'Beat'. +-- +-- >>> updateBeats Triple Three [ timedBT "a" (BeatTime 0 Three) (BeatTime 1 Four) +-- >>> , timedBT "a" (BeatTime 1 Four) (BeatTime 2 One) +-- >>> , Timed "a" [ BeatTime 2 One, BeatTime 3 Two +-- >>> , BeatTime 4 Three, BeatTime 5 Four]] +-- >>> [Timed {getData = "a", getTimeStamps = [(0.0, 3),(1.0, 1)]} +-- >>> ,Timed {getData = "a", getTimeStamps = [(1.0, 1),(2.0, 2)]} +-- >>> ,Timed {getData = "a", getTimeStamps = [(2.0, 2),(3.0, 3),(4.0, 1),(5.0, 2)]}] +updateBeats :: MeterKind -> Beat -> [Timed a] -> [Timed a] +updateBeats _ _ [] = [] +updateBeats Triple Four cs = updateBeats Triple One cs +updateBeats _ NoBeat cs = cs +updateBeats mk s cs = snd . mapAccumL f s $ cs + + where f :: Beat -> Timed a -> (Beat, Timed a) + f a b = let x = updateBeat mk a b in (offBeat x, x) + +-- | Update the 'Beat's in 'Timed' data given a 'MeterKind' and a +-- starting beat: +-- +-- >>> updateBeat Triple Two (Timed "c" [ BeatTime 0 Three +-- >>> , BeatTime 1 Four +-- >>> , BeatTime 2 One]) +-- >>> Timed {getData = "c", getTimeStamps = [(0.0, 2),(1.0, 3),(2.0, 1)]} +updateBeat :: MeterKind -> Beat -> Timed a -> Timed a +updateBeat mk strt (Timed d ts) = + Timed d . zipWith BeatTime (map timeStamp ts) + . iterate (nextBeat mk) $ strt + +-- | +-- N.B. calls 'expandTimed' before splitting +splitPickup :: [Timed a] -> ([Timed a], [Timed a]) +splitPickup cs = case span (\t -> (onBeat t) /= One) . expandTimed $ cs of + (x, []) -> ([], x) -- in case we have a very short sequence + -- don't treat it as a pickup + y -> y + + +-- | compares to 'NumData' timestamps taking a rounding error 'roundingError' +-- into account. +timeComp :: (Ord t, Fractional t) => t -> t -> Ordering +timeComp a b + | a > (b + roundingError) = GT + | a < (b - roundingError) = LT + | otherwise = EQ + +-- | wraps a datatype in 'Timed' +setData :: Timed a -> b -> Timed b +setData td d = td {getData = d} + +-- | Returns the 'NumData' timestamp, given a 'BeatTime' +timeStamp :: Fractional t => BeatTime t -> t +timeStamp (BeatTime t _bt) = t +timeStamp (Time t ) = t + +-- | Returns the 'NumData' timestamp, given a 'BeatTime' +beat :: BeatTime t -> Beat +beat (BeatTime _t bt) = bt +beat (Time _t ) = NoBeat + +-- | Returns the start 'BeatTime' +onBeatTime :: Fractional t => Timed' t a -> BeatTime t +onBeatTime td = case getTimeStamps td of + [] -> error "HarmTrace.Base.Time.onBeatTime: no timestamps are stored" + (h:_) -> h + +-- | Returns the offset time stamp +offBeatTime :: Fractional t => Timed' t a -> BeatTime t +offBeatTime td = case getTimeStamps td of + [] -> error "HarmTrace.Base.Time.offBeatTime: no timestamps are stored" + l -> last l + +-- | Returns the start 'Beat' +onBeat :: Timed a -> Beat +onBeat = beat . onBeatTime + +-- | Returns the offset time stamp +offBeat :: Timed a -> Beat +offBeat = beat . offBeatTime + +-- | Returns the onset time stamp +onset :: Fractional t => Timed' t a -> t +onset = timeStamp . onBeatTime + +-- | Returns the offset time stamp +offset :: Fractional t => Timed' t a -> t +offset = timeStamp . offBeatTime + +-- | Given a list of 'Timed' values, returns the end time of the latest element +-- in the list. +getEndTime :: Fractional t => [Timed' t a] -> t +getEndTime [] = error "getEndTime: empty list" +getEndTime l = offset . last $ l + +-- | Returns the duration of 'Timed' +duration :: Fractional t => Timed' t a -> t +duration td = offset td - onset td + +-- TODO: replace by ad-hoc enum instance? +-- | returns the next beat, e.g. @ nextBeat Two = Three @. +-- Following the (current) definition of 'Beat', we still assume 4/4, in the +-- future this function should also have the meter as an argument. +-- N.B. @ nextBeat Four = One @ +nextBeat :: MeterKind -> Beat -> Beat +nextBeat Duple Four = One +nextBeat Triple Three = One +nextBeat _ NoBeat = error "HarmTrace.Base.Time.nextBeat: nextBeat applied toNoBeat" +nextBeat _ b = succ b + +-- | returns the previous 'Beat', similar to 'prevBeat'. +prevBeat :: MeterKind -> Beat -> Beat +prevBeat Duple One = Four +prevBeat Triple One = Three +prevBeat _ NoBeat = error "HarmTrace.Base.Time.prevBeat: nextBeat applied toNoBeat" +prevBeat _ b = pred b + +-- | returns the last 'Beat' of the 'MeterKind' +-- +-- >>> lastBeat Duple +-- >>> Four +lastBeat :: MeterKind -> Beat +lastBeat Triple = Three +lastBeat Duple = Four + +-- | updates a 'Beat' in a 'BeatTime' +updBeat :: Fractional t => (Beat -> Beat) -> BeatTime t -> BeatTime t +updBeat _ (Time _) = error "updTimeBeatTime: cannot update non-existing beat" +updBeat f (BeatTime n b) = BeatTime n (f b) + +-- | updates a timestamp in a 'BeatTime' +updTime :: Fractional t => (t -> t) -> BeatTime t -> BeatTime t +updTime f (Time n ) = Time (f n) +updTime f (BeatTime n b) = BeatTime (f n) b + +-- | updates the timestamps in a 'Timed' datatype +updateTimeStamp :: Fractional t + => ([BeatTime t] -> [BeatTime t]) -> Timed' t a -> Timed' t a +updateTimeStamp f (Timed a ts) = Timed a (f ts) + +-- | drops the time (with or without 'Beat') information of a list +-- 'Timed' data structure +dropTimed :: [Timed a] -> [a] +dropTimed = map getData + +-- | Pretty prints a list of 'Timed's, one per line +prettyPrint :: Show a => [Timed a] -> String +prettyPrint = intercalate "\n" . map pprint + +-- | Pretty prints a single 'Timed' +pprint :: Show a => Timed a -> String +pprint (Timed d [ ]) = "not set - not set: " ++ show d +pprint (Timed d [x]) = show x ++" - not set: " ++ show d +pprint (Timed d ts ) = show (head ts) ++ " - " ++ show (last ts) + ++ ": " ++ show d + +-- | Estimate the tempo of the song by taking the median of the timestamps. The +-- result is returned as the number of semiquavers per minute. +estimateTempo :: [Timed a] -> BPM +estimateTempo ts = case ts of + [] -> BPM 0 + [t] -> BPM $ tempo $ offset t - onset t + _ -> BPM $ tempo $ median $ unify $ map onset ts + + where unify :: [Float] -> [Float] + unify l = zipWith (-) (tail l) l + + median :: [Float] -> Float + median l = sort l !! (length l `div` 2) + + tempo :: Float -> Int + tempo = round . (1 /) . (/ 60)
+ src/Tests.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Base.Chord.Tests +-- Copyright : (c) 2012--2016, Chordify BV +-- License : LGPL-3 +-- +-- Maintainer : haskelldevelopers@chordify.net +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Defines some property tests for testing the HarmTrace.Base package +-------------------------------------------------------------------------------- +module Main where + +import HarmTrace.Base.Chord +import HarmTrace.Base.Parse ( parseDataSafe, pChord ) +import HarmTrace.Base.Time + +import Test.QuickCheck +import Test.QuickCheck.Test ( isSuccess ) + +import Data.List ( sort, foldl' ) + +import System.Random ( Random ) +import System.Exit ( exitFailure, exitSuccess ) +import Control.Monad ( when ) + +instance Arbitrary DiatonicNatural where + arbitrary = elements . enumFrom $ C + +instance Arbitrary IntNat where + arbitrary = elements . enumFrom $ I1 + +instance Arbitrary Accidental where + arbitrary = elements [Nat,Sh,Fl,SS,FF] + + +instance Arbitrary Root where + arbitrary = elements . map pcToRoot $ [0..11] + +instance Arbitrary Interval where + arbitrary = choose (0,21) >>= return . icToInterval + +-- instance Arbitrary a => Arbitrary (Note a) where + -- arbitrary = do nat <- arbitrary + -- acc <- arbitrary + -- return (Note acc nat) + + +instance Arbitrary Shorthand where + arbitrary = elements . enumFrom $ Maj + +instance Arbitrary Addition where + arbitrary = oneof [ arbitrary >>= return . Add + , arbitrary >>= return . NoAdd ] + +instance Arbitrary a => Arbitrary (Chord a) where + arbitrary = do r <- arbitrary + sh <- elements [Maj, Min, Aug, Dim, Maj7, Min7, Sev, Dim7, HDim7, MinMaj7] + -- sh <- arbitrary + -- add <- arbitrary >>= listOf . return . Add + + b <- arbitrary + return (Chord r sh [] b ) -- (Note Nat I1)) + +instance Arbitrary a => Arbitrary (Timed a) where + arbitrary = do x <- arbitrary + s <- elements [2 .. 5] + ts <- vector s -- guarantee that this list has a minimum of 2 items + return . Timed x . sort $ ts + +data ChkTimed = ChkTimed MeterKind [Timed ChordLabel] deriving (Show, Eq) + +instance Arbitrary ChkTimed where + arbitrary = do let -- Step function for creating a Timed ChordLabel + f ::Fractional t => [Timed' t a] -> (a, [t]) -> [Timed' t a] + f _ (_,[]) = error "should not happen" + f [ ] (a, x) = [Timed a (map Time (0:x))] + f (h:t) (a, x) = let o = offset h + g y = Time (y + o) + in Timed a (map g (0:x)) : h : t + + -- creates additional duplicates at random places + -- dups ds ["a","b"] might return ["a", "a", "b"] + dups :: [Bool] -> [a] -> [a] + dups [ ] l = l + dups _ [ ] = [] + dups (b:bs) (e:es) | b = e : dups bs (e : es) + | otherwise = e : dups bs es + + ds <- arbitrary -- [Bool] + as <- arbitrary >>= return . dups ds -- chords including duplicates + + -- e.g. Gen [[1.2,3.4], [2.2]] etc. + ns <- arbitrary >>= return . map (sort . map abs) + >>= return . filter (\x -> let l = length x in l > 0 && l <= 4) + + mk <- arbitrary -- MeterKind + bt <- elements [One, Two, Three, Four] + + return . ChkTimed mk . updateBeats mk bt + . reverse . foldl' f [] $ zip as ns + +instance (Random t, Fractional t) => Arbitrary (BeatTime t) where + arbitrary = do choose (0.0, 100.0) >>= return . Time + +instance Arbitrary MeterKind where + arbitrary = elements [Duple, Triple] + +instance Arbitrary Beat where + arbitrary = elements [One, Two, Three, Four, NoBeat] + +instance Arbitrary Mode where + arbitrary = elements [MajMode, MinMode] + +instance Arbitrary Key where + arbitrary = Key <$> arbitrary <*> arbitrary + +pcProp :: Root -> Bool +pcProp r = (toPitchClass r) == toPitchClass (pcToRoot (toPitchClass r)) + +pcSetProp :: Chord Root -> Bool +pcSetProp c = c == toChord (chordRoot c) (toIntSet c) (chordBass c) + +intervalProp :: Interval -> Bool +intervalProp i = i == icToInterval (toIntervalClss i) + +-- intervalProp2 :: Int -> Bool +-- intervalProp2 i = i == toIntervalClss (icToInterval i) + +enHarEqProp :: Root -> Bool +enHarEqProp a = a &== a + +parseProp :: Chord Root -> Bool +parseProp c = parseDataSafe pChord (show c) == c + +-- N.B. this test passes if you limit the inversions to intervals within one +-- octave. +parseNoteInversionProp :: Chord Root -> Bool +parseNoteInversionProp c = parseDataSafe pChord (showChordWithNoteInversion c) == c + +mergeTimedTest, mergeTimedTest2, mergeTimedTest3, mergeTimedTest4 :: ChkTimed -> Bool +mergeTimedTest (ChkTimed _ cs) = expandTimed (mergeTimed cs) == expandTimed cs +mergeTimedTest2 (ChkTimed _ cs) = expandTimed (expandTimed cs) == expandTimed cs +mergeTimedTest3 (ChkTimed _ cs) = mergeTimed (mergeTimed cs) == mergeTimed cs +mergeTimedTest4 (ChkTimed _ cs) = mergeTimed (expandTimed cs) == mergeTimed cs + +meterKind1, meterKind2 :: ChkTimed -> Bool +meterKind1 (ChkTimed Duple cs) = mergeTimed (setMeterKind Duple cs) == mergeTimed cs +meterKind1 (ChkTimed Triple cs) = mergeTimed (setMeterKind Triple cs) == mergeTimed cs + +meterKind2 (ChkTimed Duple cs) = setMeterKind Duple cs == expandTimed cs +meterKind2 (ChkTimed Triple cs) = setMeterKind Triple cs == expandTimed cs + +-- meterKind1 (ChkTimed Duple cs) = setMeterKind Duple (setMeterKind Triple cs) == cs +-- meterKind1 (ChkTimed Triple cs) = setMeterKind Triple (setMeterKind Duple cs) == cs + +correctNextBeat :: ChkTimed -> Bool +correctNextBeat (ChkTimed mk cs) = and . map (correctBeatTimes mk . getTimeStamps) $ cs + +correctBeatTimes :: Fractional t => MeterKind -> [BeatTime t] -> Bool +correctBeatTimes _ [ ] = True +correctBeatTimes _ [_] = True +correctBeatTimes mk (a:b:tl) = beat b == nextBeat mk (beat a) && correctBeatTimes mk tl + +correctNextBeatMK :: (MeterKind, ChkTimed) -> Bool +correctNextBeatMK (mk, ChkTimed _ cs) = correctNextBeat + . ChkTimed mk . mergeTimed . setMeterKind mk $ cs + + +keyShowRead :: Key -> Bool +keyShowRead k = (read $ show k) == k + +-------------------------------------------------------------------------------- +-- Execute the tests +-------------------------------------------------------------------------------- + +main :: IO () +main = do let myTest :: Testable p => String -> [p] -> IO () + myTest s p = do putStrLn (" *** Testing HarmTrace-Base: "++ s ++": ... ") + rs <- mapM verboseCheckResult p + when (not . all isSuccess $ rs) exitFailure + + myTest "roots" [ pcProp, enHarEqProp ] + myTest "chords" [ pcSetProp, parseProp ] + myTest "intervals I" [ intervalProp ] + -- myTest "intervals II" [ intervalProp2 ] + myTest "mergeTimed" [ mergeTimedTest, mergeTimedTest2, mergeTimedTest3, mergeTimedTest4 ] + myTest "nextBeat" [ correctNextBeat ] + myTest "meterKind" [ meterKind1, meterKind2 ] + myTest "meterKind II" [ correctNextBeatMK ] + myTest "keyShowRead" [ keyShowRead ] + exitSuccess