diff --git a/HarmTrace-Base.cabal b/HarmTrace-Base.cabal new file mode 100644 --- /dev/null +++ b/HarmTrace-Base.cabal @@ -0,0 +1,35 @@ + +name: HarmTrace-Base +version: 1.0.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 libary 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, pedro@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.7, uu-parsinglib ==2.7.4.*, + ListLike ==3.1.*, binary >= 0.6.4 + + + ghc-options: -Wall + -O2 + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/HarmTrace/Base/ChordTokenizer.hs b/src/HarmTrace/Base/ChordTokenizer.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Base/ChordTokenizer.hs @@ -0,0 +1,194 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE FlexibleContexts #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Base.Parsing +-- Copyright : (c) 2010-2012 Universiteit Utrecht, 2012 University of Oxford +-- License : GPL3 +-- +-- Maintainer : bash@cs.uu.nl, jpm@cs.ox.ac.uk +-- 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 new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Base/MusicRep.hs @@ -0,0 +1,656 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Base.MusicRep +-- Copyright : (c) 2010-2012 Universiteit Utrecht, 2012 University of Oxford +-- License : GPL3 +-- +-- Maintainer : bash@cs.uu.nl, jpm@cs.ox.ac.uk +-- 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 new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Base/MusicTime.hs @@ -0,0 +1,293 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveFunctor #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Base.MusicTime +-- Copyright : (c) 2010-2012 Universiteit Utrecht, 2012 University of Oxford +-- License : GPL3 +-- +-- Maintainer : bash@cs.uu.nl, jpm@cs.ox.ac.uk +-- 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 + +) where + +import HarmTrace.Base.MusicRep + + +-- | 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 arbitrary datatype, adding (in this order) +-- a 'Beat', an onset, and an offset. +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 -- ++ ':' : printf "%.2f" 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 +-- | Combines a 'Beat' and a timestamp +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 diff --git a/src/HarmTrace/Base/Parsing.hs b/src/HarmTrace/Base/Parsing.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Base/Parsing.hs @@ -0,0 +1,90 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE FlexibleContexts #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Base.Parsing +-- Copyright : (c) 2010-2012 Universiteit Utrecht, 2012 University of Oxford +-- License : GPL3 +-- +-- Maintainer : bash@cs.uu.nl, jpm@cs.ox.ac.uk +-- 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 +