diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
--- /dev/null
+++ b/CHANGELOG.md
@@ -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
diff --git a/HarmTrace-Base.cabal b/HarmTrace-Base.cabal
--- a/HarmTrace-Base.cabal
+++ b/HarmTrace-Base.cabal
@@ -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
diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -1,165 +1,165 @@
- GNU LESSER GENERAL PUBLIC LICENSE
- Version 3, 29 June 2007
-
- Copyright (C) 2007 Free Software Foundation, Inc.
- 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.
+ 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.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -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]()_ (pp. 66-71).
+
+## Installing
+
+`cabal install`
+
+or
+
+`stack init` and `stack build`
diff --git a/Setup.hs b/Setup.hs
--- a/Setup.hs
+++ b/Setup.hs
@@ -1,2 +1,2 @@
-import Distribution.Simple
-main = defaultMain
+import Distribution.Simple
+main = defaultMain
diff --git a/src/HarmTrace/Base/Chord.hs b/src/HarmTrace/Base/Chord.hs
new file mode 100644
--- /dev/null
+++ b/src/HarmTrace/Base/Chord.hs
@@ -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
diff --git a/src/HarmTrace/Base/Chord/Analysis.hs b/src/HarmTrace/Base/Chord/Analysis.hs
new file mode 100644
--- /dev/null
+++ b/src/HarmTrace/Base/Chord/Analysis.hs
@@ -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
+
diff --git a/src/HarmTrace/Base/Chord/Datatypes.hs b/src/HarmTrace/Base/Chord/Datatypes.hs
new file mode 100644
--- /dev/null
+++ b/src/HarmTrace/Base/Chord/Datatypes.hs
@@ -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 ().
+--------------------------------------------------------------------------------
+
+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
diff --git a/src/HarmTrace/Base/Chord/Internal.hs b/src/HarmTrace/Base/Chord/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/HarmTrace/Base/Chord/Internal.hs
@@ -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
+ ]
diff --git a/src/HarmTrace/Base/Chord/Intervals.hs b/src/HarmTrace/Base/Chord/Intervals.hs
new file mode 100644
--- /dev/null
+++ b/src/HarmTrace/Base/Chord/Intervals.hs
@@ -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]
diff --git a/src/HarmTrace/Base/Chord/PitchClass.hs b/src/HarmTrace/Base/Chord/PitchClass.hs
new file mode 100644
--- /dev/null
+++ b/src/HarmTrace/Base/Chord/PitchClass.hs
@@ -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:
+--
+--------------------------------------------------------------------------------
+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):
+--
+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
diff --git a/src/HarmTrace/Base/ChordTokenizer.hs b/src/HarmTrace/Base/ChordTokenizer.hs
deleted file mode 100644
--- a/src/HarmTrace/Base/ChordTokenizer.hs
+++ /dev/null
@@ -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"
diff --git a/src/HarmTrace/Base/MusicRep.hs b/src/HarmTrace/Base/MusicRep.hs
deleted file mode 100644
--- a/src/HarmTrace/Base/MusicRep.hs
+++ /dev/null
@@ -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 ().
---------------------------------------------------------------------------------
-
-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
diff --git a/src/HarmTrace/Base/MusicTime.hs b/src/HarmTrace/Base/MusicTime.hs
deleted file mode 100644
--- a/src/HarmTrace/Base/MusicTime.hs
+++ /dev/null
@@ -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:
---
--- *
---
--- *
---
--- *
-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
diff --git a/src/HarmTrace/Base/Parse.hs b/src/HarmTrace/Base/Parse.hs
new file mode 100644
--- /dev/null
+++ b/src/HarmTrace/Base/Parse.hs
@@ -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
diff --git a/src/HarmTrace/Base/Parse/ChordParser.hs b/src/HarmTrace/Base/Parse/ChordParser.hs
new file mode 100644
--- /dev/null
+++ b/src/HarmTrace/Base/Parse/ChordParser.hs
@@ -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"
diff --git a/src/HarmTrace/Base/Parse/General.hs b/src/HarmTrace/Base/Parse/General.hs
new file mode 100644
--- /dev/null
+++ b/src/HarmTrace/Base/Parse/General.hs
@@ -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
diff --git a/src/HarmTrace/Base/Parsing.hs b/src/HarmTrace/Base/Parsing.hs
deleted file mode 100644
--- a/src/HarmTrace/Base/Parsing.hs
+++ /dev/null
@@ -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
-
diff --git a/src/HarmTrace/Base/Time.hs b/src/HarmTrace/Base/Time.hs
new file mode 100644
--- /dev/null
+++ b/src/HarmTrace/Base/Time.hs
@@ -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)
diff --git a/src/Tests.hs b/src/Tests.hs
new file mode 100644
--- /dev/null
+++ b/src/Tests.hs
@@ -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