HarmTrace-Base 1.5.3.1 → 1.6.0.0

raw patch · 10 files changed

+221/−50 lines, 10 filesdep ~HarmTrace-Basedep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: HarmTrace-Base, base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−2
• HarmTrace-Base.cabal +6/−5
• README.md +15/−8
• src/HarmTrace/Base/Chord.hs +27/−0
• src/HarmTrace/Base/Chord/Analysis.hs +11/−6
• src/HarmTrace/Base/Chord/Datatypes.hs +75/−13
• src/HarmTrace/Base/Chord/PitchClass.hs +13/−0
• src/HarmTrace/Base/Parse/ChordParser.hs +18/−13
• src/HarmTrace/Base/Time.hs +29/−1
• src/Tests.hs +18/−2

@@ -1,4 +1,11 @@-### Changelog ###
+### Changelog 
 
 1.4.0.1 HarmTrace-Base has been completely rewritten and is not compatible 
-        with software that depends on HarmTrace-Base < 1.4. +        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

@@ -1,5 +1,5 @@ name:                HarmTrace-Base
-version:             1.5.3.1
+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
@@ -8,7 +8,7 @@                      We present HarmTrace-Base, a library for parsing and
                      unambiguously representing musical chords.
 
-copyright:           (c) 2012--2016 Chordify B.V.
+copyright:           (c) 2012--2017 Chordify B.V.
 homepage:            https://bitbucket.org/bash/harmtrace-base
 license:             LGPL-3
 license-file:        LICENSE
@@ -16,7 +16,8 @@ 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.1
+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
@@ -39,7 +40,7 @@   other-modules:       HarmTrace.Base.Chord.Internal
   hs-source-dirs:      src
 
-  build-depends:       base >= 4.4 && < 4.10,
+  build-depends:       base >= 4.4 && < 5,
                        uu-parsinglib ==2.9.1.*,
                        ListLike >= 3.0.1,
                        binary >= 0.6.4,
@@ -56,7 +57,7 @@   hs-source-dirs:      src
   build-depends:       QuickCheck >= 2.7,
                        random >= 1.1,
-                       HarmTrace-Base == 1.5.3.0,
+                       HarmTrace-Base -any,
                        base >= 4.2,
                        uu-parsinglib ==2.9.1.*,
                        ListLike >= 3.0.1,

@@ -1,15 +1,22 @@-# README #
+# README 
 
-## HarmTrace Base: Parsing and unambiguously representing musical chords ##
+## 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, 
-like [HarmTrace](https://hackage.haskell.org/package/HarmTrace), which is also
-part of the back-end of [Chordify](http://chordify.net).
+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].
 
-HarmTrace: Harmony Analysis and Retrieval of Music with Type-level 
-Representations of Abstract Chords Entities
+[1] Christopher Harte, Mark Sandler and Samer Abdallah (2005), "Symbolic 
+representation of musical chords: a proposed syntax for text annotations"  
+_[In: Proceedings of 6th International Conference on Music Information 
+Retrieval](<http://ismir2005.ismir.net/proceedings/1080.pdf>)_ (pp. 66-71).
 
-## Installing ##
+## Installing 
 
 `cabal install` 
+
+or 
+
+`stack init` and `stack build`

@@ -17,9 +17,36 @@   , 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 

@@ -39,10 +39,8 @@   , toChordDegree
   , toScaleDegree
   , intervalToPitch
-
-  -- exported twice
-  -- , icToInterval
-  , toChord
+  , pitchToInterval
+  , toChord    
   ) where
 
 import HarmTrace.Base.Chord.Datatypes
@@ -59,6 +57,8 @@ -- | 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
@@ -325,10 +325,15 @@ 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 -> Maybe Interval -> Chord Root
-toChord r is mi = Chord r sh add (maybe (Note Nat I1) id mi)
+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
+      

@@ -51,13 +51,15 @@   -- * Tests & Utilities
   , shortChord
   , discardBass
+  , addition
+  , insertAdd
   , isNoneChord
   , isAddition
   , catchNoChord
   ) where
 
 import Data.Maybe                 ( fromJust )
-import Data.List                  ( elemIndex, intercalate )
+import Data.List                  ( elemIndex, intercalate, insert, delete )
 import Data.Binary                ( Binary )
 import GHC.Generics               ( Generic )
 
@@ -115,7 +117,9 @@ 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
+-- | 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
@@ -185,26 +189,43 @@ -- 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) = show r ++ ':' : show sh ++ showAdd add ++ showIv b
-  -- 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
-  -- show c = case chordRoot c of
-     -- n@(Note Nat N) -> show n
-     -- n@(Note Nat X) -> show n
-     -- r                  -> show r ++ ':' : show (chordShorthand c) ++ ' ' : show ( toPitchClasses  c)
+  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) = ""
@@ -226,19 +247,21 @@   show Dim7     = "dim7"
   show HDim7    = "hdim7"
   show MinMaj7  = "minmaj7"
-  show Aug7     = "aug7"
   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 Sus4     = "sus4"
   show Sus2     = "sus2"
   show SevSus4  = "7sus4"
   show Five     = "5"
-  show Nin      = "9"
   show Eleven   = "11"
   show Thirteen = "13"
   show None     = ""
@@ -257,6 +280,13 @@ 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
 
@@ -272,6 +302,13 @@   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
@@ -302,6 +339,18 @@ 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
@@ -319,6 +368,19 @@        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
 --------------------------------------------------------------------------------

@@ -26,6 +26,7 @@   , rootPC
   , bassPC
   , ignorePitchSpelling
+  , altPitchSpelling
     -- * Pitch classes applied to keys
   , keyPitchClasses
     -- * Pitch classes applied to interval sets
@@ -129,6 +130,18 @@ 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
 --------------------------------------------------------------------------------

@@ -30,6 +30,8 @@ import HarmTrace.Base.Chord
 import HarmTrace.Base.Time
 
+import Data.List                   ( sort )
+
 --------------------------------------------------------------------------------
 -- Parsing String of Musical Chords
 --------------------------------------------------------------------------------
@@ -48,7 +50,6 @@          <?> "Chord"
 
 -- Parses a chord label
--- TODO add support for inversion
 pChordLabel :: Parser ChordLabel
 {-# INLINE pChordLabel #-}
 pChordLabel = mkChord <$> pRoot <* (pSym ':' `opt` ':')
@@ -56,22 +57,25 @@                       <*> (pAdditions `opt` [])
                       <*> pInversion where
 
-  mkChord :: Root -> Maybe Shorthand -> [Addition] -> Maybe Interval
+  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             [] (inversion b)
-  mkChord r Nothing  a b = toChord r (addToIntSet a)    b
-  mkChord r (Just s) a b = Chord   r s               a  (inversion b)
-
-  -- prepares an inversion, if any
-  inversion :: Maybe Interval -> Interval
-  inversion = maybe (Note Nat I1) id
+  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)
 
--- Parses an inversion, but inversions are ignored for now.
-pInversion :: Parser (Maybe Interval)
-pInversion = pMaybe (pSym '/' *> pIntNote) <?> "/Inversion"
+  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"
@@ -117,7 +121,7 @@ 
 -- | Parses a list of 'Chord' 'Addition's within parenthesis
 pAdditions :: Parser [Addition]
-pAdditions = pPacked (pSym '(') (pSym ')') ( pListSep (pSym ',') pAddition )
+pAdditions = sort <$> pPacked (pSym '(') (pSym ')') ( pListSep (pSym ',') pAddition )
              <?> "Addition List"
 
 -- | Parses the a 'Chord' 'Addition' (or the removal of a chord addition,
@@ -151,6 +155,7 @@ {-# INLINE pRoot #-}
 pRoot = (flip Note) <$> pDiaNat <*> pAccidental
 
+-- | Parses a 'DiatonicNatural'.
 pDiaNat :: Parser DiatonicNatural
 {-# INLINE pDiaNat #-}
 pDiaNat =    A  <$ pSym 'A'

@@ -1,8 +1,10 @@+
 {-# LANGUAGE DeriveGeneric                    #-}
 {-# LANGUAGE TypeSynonymInstances             #-}
 {-# LANGUAGE FlexibleInstances                #-}
 {-# LANGUAGE ScopedTypeVariables              #-}
 {-# LANGUAGE DeriveFunctor                    #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving       #-}
 
 --------------------------------------------------------------------------------
 -- |
@@ -28,6 +30,7 @@   , Beat (..)
   , BeatTime (..)
   , MeterKind (..)
+  , BPM (..)
 
   -- * Functions
   -- ** Data access
@@ -67,11 +70,13 @@   , beat
   , pprint
   , prettyPrint
+  , estimateTempo
 
 ) where
 
-import Data.List                      ( intercalate, mapAccumL )
+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
@@ -111,10 +116,16 @@ -- 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"
@@ -412,3 +423,20 @@ 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)

@@ -58,7 +58,7 @@ 
 instance Arbitrary a => Arbitrary (Chord a) where
   arbitrary = do r   <- arbitrary
-                 sh  <- elements [Maj, Min, Aug, Dim, Maj7, Min7, Sev, Dim7, HDim7, Aug7, MinMaj7]
+                 sh  <- elements [Maj, Min, Aug, Dim, Maj7, Min7, Sev, Dim7, HDim7, MinMaj7]
                  -- sh  <- arbitrary
                  -- add <- arbitrary >>= listOf . return . Add
 
@@ -112,11 +112,17 @@ 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) (Just $ chordBass c)
+pcSetProp c = c == toChord (chordRoot c) (toIntSet c) (chordBass c)
 
 intervalProp :: Interval -> Bool
 intervalProp i = i == icToInterval (toIntervalClss i)
@@ -130,6 +136,11 @@ 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
@@ -158,6 +169,10 @@ correctNextBeatMK (mk, ChkTimed _ cs) = correctNextBeat
                                       . ChkTimed mk . mergeTimed . setMeterKind mk $ cs
 
+
+keyShowRead :: Key -> Bool
+keyShowRead k = (read $ show k) == k
+
 --------------------------------------------------------------------------------
 -- Execute the tests
 --------------------------------------------------------------------------------
@@ -176,4 +191,5 @@           myTest "nextBeat"     [ correctNextBeat ]
           myTest "meterKind"    [ meterKind1, meterKind2 ]
           myTest "meterKind II" [ correctNextBeatMK ]
+          myTest "keyShowRead"  [ keyShowRead ]
           exitSuccess