music-pitch 1.8.1 → 1.9.0

raw patch · 21 files changed

+1031/−1105 lines, 21 filesdep +aesondep ~lensdep ~music-pitch-literaldep ~positivePVP ok

version bump matches the API change (PVP)

Dependencies added: aeson

Dependency ranges changed: lens, music-pitch-literal, positive, vector-space, vector-space-points

API changes (from Hackage documentation)

Files

• music-pitch.cabal +20/−13
• src/Music/Pitch.hs +9/−6
• src/Music/Pitch/Absolute.hs +55/−118
• src/Music/Pitch/Ambitus.hs +11/−24
• src/Music/Pitch/Clef.hs +65/−46
• src/Music/Pitch/Common.hs +4/−28
• src/Music/Pitch/Common/Chromatic.hs +0/−15
• src/Music/Pitch/Common/Diatonic.hs +0/−13
• src/Music/Pitch/Common/Harmony.hs +1/−14
• src/Music/Pitch/Common/Interval.hs +100/−199
• src/Music/Pitch/Common/Names.hs +7/−20
• src/Music/Pitch/Common/Number.hs +24/−46
• src/Music/Pitch/Common/Pitch.hs +11/−125
• src/Music/Pitch/Common/Quality.hs +85/−72
• src/Music/Pitch/Common/Semitones.hs +7/−72
• src/Music/Pitch/Common/Spell.hs +4/−20
• src/Music/Pitch/Common/Types.hs +305/−0
• src/Music/Pitch/Equal.hs +40/−51
• src/Music/Pitch/Intonation.hs +47/−30
• src/Music/Pitch/Scale.hs +236/−114
• src/Music/Pitch/StaffLines.hs +0/−79

@@ -1,6 +1,6 @@  name:                   music-pitch-version:                1.8.1+version:                1.9.0 cabal-version:          >= 1.10 author:                 Hans Hoglund maintainer:             Hans Hoglund@@ -22,25 +22,25 @@   location:             git://github.com/music-suite/music-pitch.git    library                    -    build-depends:      base                    >= 4 && < 5,+    build-depends:      base                    >= 4        && < 5,                         containers,-                        lens                    >= 4.6      && < 4.7,+                        lens                    >= 4.11     && < 5,                         semigroups              >= 0.13.0.1 && < 1,-                        music-pitch-literal     == 1.8.1,-                        data-interval           >= 1.0.0 && < 2,-                        vector-space            >= 0.8.7 && < 0.9,-                        vector-space-points     >= 0.2 && < 0.3,+                        music-pitch-literal     == 1.9.0,+                        data-interval           >= 1.0.0    && < 2,+                        vector-space            >= 0.10.2   && < 1,+                        vector-space-points     >= 0.2      && < 1,                         nats,-                        positive                >= 0.3 && < 1,-                        type-unary              >= 0.2.16 && < 1.0+                        positive                >= 0.4      && < 1,+                        type-unary              >= 0.2.16   && < 1.0,+                        aeson                   >= 0.7.0.6  && < 1     exposed-modules:    Music.Pitch                         Music.Pitch.Absolute                         Music.Pitch.Equal                         Music.Pitch.Common+                        Music.Pitch.Common.Types                         Music.Pitch.Common.Quality                         Music.Pitch.Common.Number-                        Music.Pitch.Common.Diatonic-                        Music.Pitch.Common.Chromatic                         Music.Pitch.Common.Interval                         Music.Pitch.Common.Pitch                         Music.Pitch.Common.Semitones@@ -51,8 +51,15 @@                         Music.Pitch.Scale                         Music.Pitch.Clef                         Music.Pitch.Intonation-    other-modules:      Music.Pitch.StaffLines-                        Music.Pitch.Tokawa+    other-modules:      Music.Pitch.Tokawa     hs-source-dirs:     src     default-language:   Haskell2010+    default-extensions: StandaloneDeriving,+                        TypeFamilies,+                        TypeOperators,+                        GeneralizedNewtypeDeriving,+                        MultiParamTypeClasses,+                        DeriveDataTypeable,+                        ViewPatterns,+                        OverloadedStrings     ghc-options:        -fno-warn-typed-holes

@@ -18,32 +18,35 @@         module Data.VectorSpace,         module Data.AffineSpace,         module Data.AffineSpace.Point,+         module Music.Pitch.Augmentable,         module Music.Pitch.Alterable,+         module Music.Pitch.Absolute,-        module Music.Pitch.Ambitus,-        module Music.Pitch.Equal,         module Music.Pitch.Common,-        module Music.Pitch.Common.Names,-        module Music.Pitch.StaffLines,+        module Music.Pitch.Equal,+         module Music.Pitch.Clef,         module Music.Pitch.Intonation,         module Music.Pitch.Literal,+        module Music.Pitch.Ambitus,+        module Music.Pitch.Scale,   ) where  import Data.Semigroup import Data.VectorSpace hiding (Sum, getSum) import Data.AffineSpace import Data.AffineSpace.Point+ import Music.Pitch.Absolute import Music.Pitch.Augmentable import Music.Pitch.Alterable import Music.Pitch.Ambitus import Music.Pitch.Equal-import Music.Pitch.Common+import Music.Pitch.Common hiding (Mode) import Music.Pitch.Common.Names import Music.Pitch.Literal-import Music.Pitch.StaffLines import Music.Pitch.Clef import Music.Pitch.Intonation+import Music.Pitch.Scale 

@@ -1,38 +1,19 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies               #-}------------------------------------------------------------------------------------------ |--- Copyright   : (c) Hans Hoglund 2012------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : portable------ Absolute pitch representation.------ The canonical pitch representation is frequency in Hertz (Hz).------ For conversion, see 'HasFrequency'.-------------------------------------------------------------------------------------------module Music.Pitch.Absolute (-        -- * Absolute pitch representation-        Hertz(..),-        -- FreqRatio(..),-        -- Octaves,-        Cents,-        Fifths,-        -        -- * HasFrequency class-        HasFrequency(..),-        -- octaves,-        fifths,-        cents,+-- | Absolute pitch representation.+module Music.Pitch.Absolute+  (+  -- * Absolute pitch representation+  Hertz(..),+  -- FreqRatio(..),+  -- Octaves,+  Cents,+  Fifths,+  +  -- * HasFrequency class+  HasFrequency(..),+  -- octaves,+  fifths,+  cents,   ) where  import           Control.Applicative@@ -46,89 +27,61 @@  import           Music.Pitch.Literal --- |--- Absolute frequency in Hertz.---+{-|+Absolute frequency in Hertz.+-} newtype Hertz = Hertz { getHertz :: Double }-  deriving (Read, Show, Eq, Enum, Num, Ord, Fractional, Floating, Real, RealFrac)+    deriving (Read, Eq, Enum, Num, Ord, Fractional, Floating, Real, RealFrac) -{---- |--- A ratio between two different (Hertz) frequencies.----newtype FreqRatio = FreqRatio { getFreqRatio :: Double }-  deriving (Read, Show, Eq, Enum, Num, Ord, Fractional, Floating, Real, RealFrac)--}+{-|+Number of pure octaves. --- |--- Number of pure octaves.------ Octaves are a logarithmic representation of frequency such that------ > f * (2/1) = frequency (octaves f + 1)---+Octaves are a logarithmic representation of frequency such that++> f * (2/1) = frequency (octaves f + 1)+-} newtype Octaves = Octaves { getOctaves :: Hertz }   deriving (Read, Show, Eq, Enum, Num, Ord, Fractional, Floating, Real, RealFrac) --- |--- Number of pure octaves.------ Cents are a logarithmic representation of frequency such that------ > f * (2/1) = frequency (cents f + 1200)----newtype Cents = Cents { getCents :: Hertz }-  deriving (Read, Show, Eq, Enum, Num, Ord, Fractional, Floating, Real, RealFrac)+{-|+Number of pure fifths. --- |--- Number of pure fifths.------ Fifths are a logarithmic representation of frequency.------ > f * (3/2) = frequency (fifths f + 1)---+Fifths are a logarithmic representation of frequency.++> f * (3/2) = frequency (fifths f + 1)++-} newtype Fifths = Fifths { getFifths :: Hertz }   deriving (Read, Show, Eq, Enum, Num, Ord, Fractional, Floating, Real, RealFrac) +{-|+Number of cents. -instance Semigroup Hertz    where (<>) = (*)-instance Semigroup Octaves  where (<>) = (+)-instance Semigroup Fifths   where (<>) = (+)-instance Semigroup Cents    where (<>) = (+)+Cents are a logarithmic representation of frequency such that -instance Monoid Hertz       where { mempty  = 1 ; mappend = (*) }-instance Monoid Octaves     where { mempty  = 0 ; mappend = (+) }-instance Monoid Fifths      where { mempty  = 0 ; mappend = (+) }-instance Monoid Cents       where { mempty  = 0 ; mappend = (+) }+> f * (2/1) = frequency (cents f + 1200) -{--instance AdditiveGroup FreqRatio where-  zeroV   = 1-  (^+^)   = (*)-  negateV f = 1 / f+-}+newtype Cents = Cents { getCents :: Hertz }+  deriving (Read, Show, Eq, Enum, Num, Ord, Fractional, Floating, Real, RealFrac) -instance VectorSpace FreqRatio where-  type Scalar FreqRatio = Double-  (*^) x f = FreqRatio ((getFreqRatio f) ** x) -instance AffineSpace Hertz where-  type Diff Hertz = FreqRatio-  (.-.) f1 f2 = FreqRatio $ (getHertz f1) / (getHertz f2)-  (.+^) p f = Hertz $ (getHertz p) * (getFreqRatio f)--}-instance AdditiveGroup Hertz where-  zeroV   = 1-  (^+^)   = (*)-  negateV f = 1 / f+instance Show Hertz where show h = (show (getHertz h)) ++ " Hz" -instance VectorSpace Hertz where-  type Scalar Hertz = Hertz-  (*^) x f = Hertz ((getHertz f) ** getHertz x)+instance Semigroup Hertz    where (<>) = (*)+instance Semigroup Octaves  where (<>) = (+)+instance Semigroup Fifths   where (<>) = (+)+instance Semigroup Cents    where (<>) = (+) +instance Monoid Hertz       where mempty  = 1 ; mappend = (*)+instance Monoid Octaves     where mempty  = 0 ; mappend = (+)+instance Monoid Fifths      where mempty  = 0 ; mappend = (+)+instance Monoid Cents       where mempty  = 0 ; mappend = (+)+ instance AffineSpace Hertz where-  type Diff Hertz = Hertz-  (.-.) = (-)-  (.+^) = (+)+  type Diff Hertz = Double+  (.-.) f1 f2 = (getHertz f1) / (getHertz f2)+  (.+^) f x = Hertz $ (getHertz f) * x  class HasFrequency a where   frequency :: a -> Hertz@@ -145,31 +98,15 @@ instance HasFrequency Cents where   frequency (Cents f)   =  (2/1) ** (f / 1200) +-- | Convert a frequency to octaves. octaves :: HasFrequency a => a -> Octaves octaves a = Octaves $ logBase (2/1) (frequency a) +-- | Convert a frequency to fifths. fifths :: HasFrequency a => a -> Fifths fifths a = Fifths $ logBase (3/2) (frequency a) +-- | Convert a frequency to cents. cents :: HasFrequency a => a -> Cents cents a = Cents $ logBase (2/1) (frequency a) * 1200------- For convenience. TODO problematic for these reasons:------  * Confusing as _P8+m2 is not the same as _P8<>m2---  * Does not work with HasPitch (up, down...) etc as we do not have an affine/vector space pair------ Can we fix this with newtype wrappers?----instance IsInterval Hertz where-  fromInterval (IntervalL (o,d,c)) = (2**fromIntegral o) * (r !! fromIntegral c)-    where-      r = [-        1/1,-        (8*2)/15, 9/8,      (2*3)/5, 5/4,     (2*2)/3,-        10/7,-        3/2,      (4*2)/5,  5/3,     (2*8)/9, 15/8-        ]- 

@@ -1,25 +1,9 @@ -{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}----------------------------------------------------------------------------------------- |--- Copyright   : (c) Hans Hoglund, Edward Lilley 2012–2014------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : non-portable (TF,GNTD)------ Musical ambitus, or pitch ranges.------------------------------------------------------------------------------------------+-- | Pitch range or ambitus. module Music.Pitch.Ambitus (     Ambitus,     ambitus,-    ambitus',+    -- ambitus',     mapAmbitus,     ambitusHighest,     ambitusLowest,@@ -32,32 +16,35 @@ import Data.VectorSpace import Data.AffineSpace --- | An ambitus is a closed interval (in the mathematical sense).+-- | An ambitus is (mathematical) interval. --  -- Also known as /range/ or /tessitura/, this type can be used to restrict the--- range of a melody, chord or other pitch container.--- --- It is also used in @music-parts@ to represent the range of instruments.+-- range instruments, chords, melodies etc. --  newtype Ambitus a = Ambitus { getAmbitus :: (I.Interval a) }  instance Wrapped (Ambitus a) where   type Unwrapped (Ambitus a) = I.Interval a   _Wrapped' = iso getAmbitus Ambitus+ instance Rewrapped (Ambitus a) (Ambitus b)  instance (Show a, Num a, Ord a) => Show (Ambitus a) where   show a = show (a^.from ambitus) ++ "^.ambitus" + ambitus :: (Num a, Ord a) => Iso (a, a) (b, b) (Ambitus a) (Ambitus b) ambitus = iso toA unA . _Unwrapped   where     toA = (\(m, n) -> (I.<=..<=) (Finite m) (Finite n))     unA a = case (I.lowerBound a, I.upperBound a) of       (Finite m, Finite n) -> (m, n)+      -- FIXME this can happen as empty span can be represented as PosInf..NegInf+      -- _                    -> error $ "Strange ambitus: " ++ show (I.lowerBound a, I.upperBound a)+      _                    -> error $ "Strange ambitus" -ambitus' :: (Num a, Ord a) => Iso' (a, a) (Ambitus a)-ambitus' = ambitus+-- ambitus' :: (Num a, Ord a) => Iso' (a, a) (Ambitus a)+-- ambitus' = ambitus  -- | Not a true functor for similar reasons as sets. mapAmbitus :: (Ord b, Num b) => (a -> b) -> Ambitus a -> Ambitus b

@@ -1,40 +1,21 @@ -{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE DeriveTraversable          #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GADTs                      #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TypeFamilies               #-}----------------------------------------------------------------------------------------- |--- Copyright   : (c) Hans Hoglund, Edward Lilley 2012–2014------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : non-portable (TF,GNTD)------ Clefs and staff positions.-------------------------------------------------------------------------------------------module Music.Pitch.Clef (+-- | Clefs and staff positions.+module Music.Pitch.Clef+(+      -- * Staff lines+      StaffLines,+      HalfSpaces,+      ClefLine,+             -- * Clef representation-      ClefSymbol,+      ClefSymbol(..),       ClefOctave,-      Clef,+      Clef(..),       symbolName,       symbolPitch,       positionPitch,       pitchPosition,+       -- ** Properties       isModernClef,       isHistoricalClef,@@ -48,22 +29,47 @@       altoClef,       tenorClef,       baritoneClef,-  ) where+) where  import Data.Typeable -import Music.Pitch.StaffLines import Music.Pitch.Common import Music.Pitch.Literal +-- | Represents staff number relative middle. Staff zero is either the middle staff, or if using an+-- even number of lines, the staff below the middle space.+--+newtype StaffLines = StaffLines { getStaffLines :: Integer }+  deriving (Eq, Ord, Read, Show, Enum,+            Num, Real, Integral, Typeable)++-- | Represents the difference betwee  staff positions (often corresponding to one diatonic step).+newtype HalfSpaces = HalfSpaces { getHalfSpaces :: Integer }+  deriving (Eq, Ord, Read, Show, Enum,+            Num, Real, Integral, Typeable)++-- | Common clef symbols data ClefSymbol = GClef | CClef | FClef | PercClef | NeutralClef     deriving (Eq, Ord, Show, Typeable)  type ClefOctave = Integer type ClefLine   = StaffLines -type Clef = (ClefSymbol, ClefOctave, ClefLine)+newtype Clef = Clef { getClef :: (ClefSymbol, ClefOctave, ClefLine) }+  deriving (Eq, Ord, Typeable) +instance Show Clef where+  show x@(Clef a)+    | x == trebleClef       = "trebleClef"+    | x == bassClef         = "bassClef"+    | x == sopranoClef      = "sopranoClef"+    | x == mezzoSopranoClef = "mezzoSopranoClef"+    | x == altoClef         = "altoClef"+    | x == tenorClef        = "tenorClef"+    | x == baritoneClef     = "baritoneClef"+    | otherwise             = show a+    +-- | Return the English name of the given clef. symbolName :: ClefSymbol -> String symbolName GClef = "G clef" symbolName CClef = "C clef"@@ -71,21 +77,22 @@ symbolName PercClef = "Percussion clef" symbolName NeutralClef = "Neutral clef" +-- | Return the pitch implied by the given clef at the middle space or line. symbolPitch :: ClefSymbol -> Maybe Pitch-symbolPitch GClef = Just g+symbolPitch GClef = Just b' symbolPitch CClef = Just c-symbolPitch FClef = Just f+symbolPitch FClef = Just d_ symbolPitch _     = Nothing  -- TODO consolidate with common pitchPosition :: Clef -> Pitch -> Maybe StaffLines-pitchPosition (s,o,l) x = undefined+pitchPosition (Clef (s,o,l)) x = undefined   where     numbersPerOctave = 7     referencePitch = symbolPitch s :: Maybe Pitch  positionPitch :: Clef -> StaffLines -> Maybe Pitch-positionPitch (s,o,l) x = fmap (upDiatonic relativePosition) referencePitch+positionPitch (Clef (s,o,l)) x = fmap (upDiatonic relativePosition) referencePitch   where     numbersPerOctave = 7     referencePitch = symbolPitch s :: Maybe Pitch@@ -93,7 +100,7 @@  -- TODO implement fully in Pitch.Common.Diatonic upDiatonic :: Number -> Pitch -> Pitch-upDiatonic = error "Not implemented: upDiatonic"+upDiatonic = upDiatonicP c . fromIntegral -- TODO Why c?  {- TODO@@ -108,21 +115,30 @@   If 1), do we need to separate G/C/F in ClefSymbol, maybe just put a single constructor for common pitch.   In that case, maybe a function isStandardClefPitch (i.e. c/f/g) would be appropriate. -}++-- | Standard treble clef. trebleClef :: Clef+-- | Standard bass clef. bassClef :: Clef+-- | Standard soprano clef. sopranoClef :: Clef+-- | Standard mezzo soprano clef. mezzoSopranoClef :: Clef+-- | Standard alto clef. altoClef :: Clef+-- | Standard tenor clef. tenorClef :: Clef+-- | Standard baritone clef. baritoneClef :: Clef-trebleClef        = (GClef, -1 :: ClefOctave, -1 :: ClefLine)-bassClef          = (FClef, 1  :: ClefOctave, -1 :: ClefLine)-sopranoClef       = (CClef, 0  :: ClefOctave, -2 :: ClefLine)-mezzoSopranoClef  = (CClef, 0  :: ClefOctave, -1 :: ClefLine)-altoClef          = (CClef, 0  :: ClefOctave, 0  :: ClefLine)-tenorClef         = (CClef, 0  :: ClefOctave, 1  :: ClefLine)-baritoneClef      = (CClef, 0  :: ClefOctave, 2  :: ClefLine)+trebleClef        = Clef (GClef, -1 :: ClefOctave, -1 :: ClefLine)+bassClef          = Clef (FClef, 1  :: ClefOctave, -1 :: ClefLine)+sopranoClef       = Clef (CClef, 0  :: ClefOctave, -2 :: ClefLine)+mezzoSopranoClef  = Clef (CClef, 0  :: ClefOctave, -1 :: ClefLine)+altoClef          = Clef (CClef, 0  :: ClefOctave, 0  :: ClefLine)+tenorClef         = Clef (CClef, 0  :: ClefOctave, 1  :: ClefLine)+baritoneClef      = Clef (CClef, 0  :: ClefOctave, 2  :: ClefLine) +-- | Is this a clef used in contemporary notation? isModernClef :: Clef -> Bool isModernClef x | x == trebleClef  = True isModernClef x | x == bassClef    = True@@ -130,11 +146,14 @@ isModernClef x | x == tenorClef   = True isModernClef x | otherwise        = False +-- | Is this an historical clef? isHistoricalClef :: Clef -> Bool isHistoricalClef _ = False --- | Is this a voice clef, i.e. a c clef on some staff.+-- | Is this a traditional voice clef, i.e. a C clef on some staff. isVoiceClef :: Clef -> Bool isVoiceClef x | x == altoClef    = True isVoiceClef x | x == tenorClef   = True isVoiceClef x | otherwise        = False++

@@ -1,46 +1,22 @@ ---------------------------------------------------------------------------------------- |--- Copyright   : (c) Hans Hoglund 2012------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : non-portable (TF,GNTD)------ Provides a representation of pitch as defined in Common Music Theory (CMT).------------------------------------------------------------------------------------------+-- | Common pitch representation. module Music.Pitch.Common (     module Music.Pitch.Common.Semitones,     module Music.Pitch.Common.Quality,     module Music.Pitch.Common.Number,-    module Music.Pitch.Common.Diatonic,-    module Music.Pitch.Common.Chromatic,     module Music.Pitch.Common.Interval,     module Music.Pitch.Common.Pitch,     module Music.Pitch.Common.Spell,     module Music.Pitch.Common.Harmony,+    module Music.Pitch.Common.Names,   ) where -import Data.Maybe-import Data.Either-import Data.Semigroup-import Data.VectorSpace-import Data.AffineSpace-import Control.Monad-import Control.Applicative--import Music.Pitch.Absolute-import Music.Pitch.Literal import Music.Pitch.Common.Pitch import Music.Pitch.Common.Quality import Music.Pitch.Common.Number-import Music.Pitch.Common.Diatonic-import Music.Pitch.Common.Chromatic import Music.Pitch.Common.Interval import Music.Pitch.Common.Semitones import Music.Pitch.Common.Spell+import Music.Pitch.Common.Types import Music.Pitch.Common.Harmony+import Music.Pitch.Common.Names

@@ -1,15 +0,0 @@--{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoMonomorphismRestriction  #-}-{-# LANGUAGE StandaloneDeriving         #-}-{-# LANGUAGE TypeFamilies               #-}--module Music.Pitch.Common.Chromatic (-    ChromaticSteps,-  ) where---newtype ChromaticSteps = ChromaticSteps { getChromaticSteps :: Integer }-  deriving (Eq, Ord, Show, Enum, Num, Real, Integral)-

@@ -1,13 +0,0 @@--{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoMonomorphismRestriction  #-}-{-# LANGUAGE StandaloneDeriving         #-}-{-# LANGUAGE TypeFamilies               #-}--module Music.Pitch.Common.Diatonic (-    DiatonicSteps,-  ) where--newtype DiatonicSteps = DiatonicSteps { getDiatonicSteps :: Integer }-  deriving (Eq, Ord, Show, Enum, Num, Real, Integral)

@@ -1,18 +1,5 @@ ---------------------------------------------------------------------------------------- |--- Copyright   : (c) Hans Hoglund, Edward Lilley 2012–2014------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : non-portable (TF,GNTD)------ Provides standard intervals.------------------------------------------------------------------------------------------+-- | Basic harmony. module Music.Pitch.Common.Harmony (         isDissonance,         isConsonance,

@@ -1,32 +1,13 @@ -{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoMonomorphismRestriction  #-}-{-# LANGUAGE StandaloneDeriving         #-}-{-# LANGUAGE TypeFamilies               #-}----------------------------------------------------------------------------------------- |--- Copyright   : (c) Hans Hoglund, Edward Lilley 2012–2014------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : non-portable (TF,GNTD)------ Provides standard intervals.-------------------------------------------------------------------------------------------module Music.Pitch.Common.Interval (--+-- | Common intervals.+module Music.Pitch.Common.Interval+(         -- * Intervals         Interval,         -- ** Creating intervals         interval,         interval',+        interval'',         _number,         _quality,         _steps,@@ -59,9 +40,6 @@         -- *** Inversion         invert, -        -- * Utility-        asInterval,-         -- * Basis values         IntervalBasis(..), @@ -69,7 +47,7 @@         convertBasis,         convertBasisFloat,         intervalDiv,-  ) where+) where  import           Data.Either import           Data.Maybe@@ -83,79 +61,22 @@ import qualified Data.List                    as List import           Data.Typeable import           Numeric.Positive+import           Data.Aeson                    (ToJSON (..))+import qualified Data.Aeson  import           Music.Pitch.Absolute import           Music.Pitch.Augmentable+import           Music.Pitch.Common.Types import           Music.Pitch.Common.Semitones import           Music.Pitch.Common.Quality import           Music.Pitch.Common.Number-import           Music.Pitch.Common.Chromatic-import           Music.Pitch.Common.Diatonic import           Music.Pitch.Literal  --------------- |--- A musical interval such as minor third, augmented fifth, duodecim etc.------ We include direction in in this definition, so a downward minor third (written @-m3@)--- is distinct from an upward minor third (written @m3@). Note that @_P1@ and @-P1@ are--- synynoms.------ Not to be confused with a mathematical inverval in pitch space, which is called--- 'Ambitus'. Intervals and pitches form an affine-vector space pair with intervals and--- /vectors/ and pitches as /points/. To add an interval to a, use '.+^'. To get the--- interval between two pitches, use '.-.'.------ > c .+^ minor third == eb--- > f .-. c           == perfect fourth------ Adding intervals preserves spelling. For example:------ > m3 ^+^ _M3 = _P5--- > d5 ^+^ _M6 = m10------ The scalar type of 'Interval' is 'Int', using '^*' to stack intervals of a certain type--- on top of each other. For example @_P5 ^* 2@ is a stack of 2 perfect fifths, or a major--- ninth. The 'Num' instance works as expected for '+', 'negate' and 'abs', and--- (arbitrarily) uses minor seconds for multiplication. If you find yourself '*', or--- 'signum' on intervals, consider switching to '*^' or 'normalized'.------ Intervals are generally described in terms of 'Quality' and 'Number'. To construct an--- interval, use the 'interval' constructor, the utility constructors 'major', 'minor',--- 'augmented' and 'diminished', or the interval literals:------ > m5  == minor   fifth    == interval Minor   5 > _P4 == perfect fourth   == interval--- Perfect 5 > d5  == diminished fifth == diminish (perfect fifth)----newtype Interval = Interval { getInterval :: (-            Int,  -- Number of A1, i.e. chromatic steps-            Int   -- Number of d2, i.e. diatonic steps-    ) }-    deriving (Eq, Typeable)---- | Lexicographical ordering, comparing the 'd2' component of the--- Interval first, as it's tied to the Number which is expected to be--- 'bigger' than the Quality, assuming ordinary tuning systems-instance Ord Interval where-  Interval a `compare` Interval b = swap a `compare` swap b-    where swap (x,y) = (y,x)- -- | Avoid using '(*)', or 'signum' on intervals. instance Num Interval where-  (+)           = addInterval-  negate        = negateInterval+  (+)           = (^+^)+  negate        = negateV   abs a         = if isNegative a then negate a else a   (*)           = error "Music.Pitch.Common.Interval: no overloading for (*)"   signum        = error "Music.Pitch.Common.Interval: no overloading for signum"@@ -173,24 +94,24 @@       showQuality (Diminished n)   = replicate (fromIntegral n) 'd'  instance Semigroup Interval where-  (<>)    = addInterval+  (<>)    = (^+^)  instance Monoid Interval where   mempty  = basis_P1-  mappend = addInterval+  mappend = (^+^)  instance AdditiveGroup Interval where   zeroV   = basis_P1-  (^+^)   = addInterval-  negateV = negateInterval+  (Interval (a1, d1)) ^+^ (Interval (a2, d2)) = Interval (a1 ^+^ a2, d1 ^+^ d2)+  negateV (Interval (a, d)) = Interval (-a, -d)  instance VectorSpace Interval where   type Scalar Interval = Integer   (*^) = stackInterval---- TODO move-data IntervalBasis = Chromatic | Diatonic-  deriving (Eq, Ord, Show, Enum)+    where+      stackInterval n a+        | n >= 0    = mconcat $ replicate (fromIntegral n) a+        | otherwise = negate $ stackInterval (negate n) a  instance HasBasis Interval where   type Basis Interval = IntervalBasis@@ -216,19 +137,17 @@ instance IsInterval Interval where   fromInterval (IntervalL (o,d,c)) = (basis_P8^*o) ^+^ (basis_A1^*c) ^+^ (basis_d2^*d) -negateInterval :: Interval -> Interval-negateInterval (Interval (a, d)) = Interval (-a, -d)+instance ToJSON DiatonicSteps where+  toJSON = toJSON . toInteger -addInterval :: Interval -> Interval -> Interval-addInterval (Interval (a1, d1)) (Interval (a2, d2)) = Interval (a1 + a2, d1 + d2)+instance ToJSON ChromaticSteps where+  toJSON = toJSON . toInteger -stackInterval :: Integer -> Interval -> Interval-stackInterval n a-  | n >= 0    = mconcat $ replicate (fromIntegral n) a-  | otherwise = negate $ stackInterval (negate n) a+instance ToJSON Interval where+  toJSON i = Data.Aeson.object [("steps", toJSON $ i^._steps), ("alteration", toJSON $ i^._alteration)]  intervalDiff :: Interval -> Int-intervalDiff (Interval (c, d)) = c - diatonicToChromatic d+intervalDiff (Interval (c, d)) = fromIntegral $ c - fromIntegral (diatonicToChromatic d)  -- | -- Creates an interval from a quality and number.@@ -241,7 +160,7 @@   :: Int        -- ^ Difference in chromatic steps (?).   -> Int        -- ^ Number of diatonic steps (NOT interval number).   -> Interval-mkInterval' diff diatonic = Interval (diatonicToChromatic diatonic + diff, diatonic)+mkInterval' diff diatonic = Interval (diatonicToChromatic (fromIntegral diatonic) + fromIntegral diff, fromIntegral diatonic)  basis_P1 = Interval (0, 0) basis_A1 = Interval (1, 0)@@ -259,10 +178,10 @@ -- in the d * d2 part (adding a unison, perfect or otherwise, can -- never increase the number of the interval) ---extractNumber :: Interval -> Number+extractNumber                     :: Interval -> Number extractNumber (Interval (a, d))-  | d >= 0    = Number (d + 1)-  | otherwise = Number (d - 1)+  | d >= 0                        = fromIntegral (d + 1)+  | otherwise                     = fromIntegral (d - 1)   -- |@@ -273,39 +192,39 @@ -- we are used to reading.  extractQuality :: Interval -> Quality-extractQuality (Interval (a, d))-  | (a < 0) && (d == 0) = diminish (extractQuality (Interval ((a + 1), d)))-  | (a, d) == (0, 0) = Perfect-  | (a > 0) && (d == 0) = augment (extractQuality (Interval ((a - 1), d)))-  | (a < 1) && (d == 1) = diminish (extractQuality (Interval ((a + 1), d)))-  | (a, d) == (1, 1) = Minor-  | (a, d) == (2, 1) = Major-  | (a > 2) && (d == 1) = augment (extractQuality (Interval ((a - 1), d)))-  | (a < 3) && (d == 2) = diminish (extractQuality (Interval ((a + 1), d)))-  | (a, d) == (3, 2) = Minor-  | (a, d) == (4, 2) = Major-  | (a > 4) && (d == 2) = augment (extractQuality (Interval ((a - 1), d)))-  | (a < 5) && (d == 3) = diminish (extractQuality (Interval ((a + 1), d)))-  | (a, d) == (5, 3) = Perfect-  | (a > 5) && (d == 3) = augment (extractQuality (Interval ((a - 1), d)))-  | (a < 7) && (d == 4) = diminish (extractQuality (Interval ((a + 1), d)))-  | (a, d) == (7, 4) = Perfect-  | (a > 7) && (d == 4) = augment (extractQuality (Interval ((a - 1), d)))-  | (a < 8) && (d == 5) = diminish (extractQuality (Interval ((a + 1), d)))-  | (a, d) == (8, 5) = Minor-  | (a, d) == (9, 5) = Major-  | (a > 9) && (d == 5) = augment (extractQuality (Interval ((a - 1), d)))-  | (a < 10) && (d == 6) = diminish (extractQuality (Interval ((a + 1), d)))-  | (a, d) == (10, 6) = Minor-  | (a, d) == (11, 6) = Major-  | (a > 11) && (d == 6) = augment (extractQuality (Interval ((a - 1), d)))-  | (a < 12) && (d == 7) = diminish (extractQuality (Interval ((a + 1), d)))-  | (a, d) == (12, 7) = Perfect-  | (a > 12) && (d == 7) = augment (extractQuality (Interval ((a - 1), d)))--- note: these last two cases *have* to be this way round, otherwise--- infinite loop occurs.-  | (a > 12) || (d > 7) = extractQuality (Interval ((a - 12), (d - 7)))-  | (a < 0) || (d < 0) = extractQuality (Interval ((-a), (-d)))+extractQuality (Interval (a, d))  +  | (a < 0)  && (d == 0)          = diminish $ extractQuality (Interval ((a + 1), d))+  | (a, d)   == (0, 0)            = Perfect+  | (a > 0)  && (d == 0)          = augment  $ extractQuality (Interval ((a - 1), d))+  | (a < 1)  && (d == 1)          = diminish $ extractQuality (Interval ((a + 1), d))+  | (a, d)   == (1, 1)            = Minor+  | (a, d)   == (2, 1)            = Major+  | (a > 2)  && (d == 1)          = augment  $ extractQuality (Interval ((a - 1), d))+  | (a < 3)  && (d == 2)          = diminish $ extractQuality (Interval ((a + 1), d))+  | (a, d)   == (3, 2)            = Minor+  | (a, d)   == (4, 2)            = Major+  | (a > 4)  && (d == 2)          = augment  $ extractQuality (Interval ((a - 1), d))+  | (a < 5)  && (d == 3)          = diminish $ extractQuality (Interval ((a + 1), d))+  | (a, d)   == (5, 3)            = Perfect+  | (a > 5)  && (d == 3)          = augment  $ extractQuality (Interval ((a - 1), d))+  | (a < 7)  && (d == 4)          = diminish $ extractQuality (Interval ((a + 1), d))+  | (a, d)   == (7, 4)            = Perfect+  | (a > 7)  && (d == 4)          = augment  $ extractQuality (Interval ((a - 1), d))+  | (a < 8)  && (d == 5)          = diminish $ extractQuality (Interval ((a + 1), d))+  | (a, d)   == (8, 5)            = Minor+  | (a, d)   == (9, 5)            = Major+  | (a > 9)  && (d == 5)          = augment  $ extractQuality (Interval ((a - 1), d))+  | (a < 10) && (d == 6)          = diminish $ extractQuality (Interval ((a + 1), d))+  | (a, d)   == (10, 6)           = Minor+  | (a, d)   == (11, 6)           = Major+  | (a > 11) && (d == 6)          = augment  $ extractQuality (Interval ((a - 1), d))+  | (a < 12) && (d == 7)          = diminish $ extractQuality (Interval ((a + 1), d))+  | (a, d)   == (12, 7)           = Perfect+  | (a > 12) && (d == 7)          = augment  $ extractQuality (Interval ((a - 1), d))+  -- note: these last two cases *have* to be this way round, otherwise+  -- infinite loop occurs.+  | (a > 12) || (d > 7)           = extractQuality (Interval ((a - 12), (d - 7)))+  | (a < 0)  || (d < 0)           = extractQuality (Interval ((-a), (-d)))   -- | Creates a perfect interval.@@ -339,24 +258,19 @@ doublyDiminished :: Number -> Interval doublyDiminished = mkInterval (Diminished 2) -{---Prelude Music.Prelude> separate (2*^_P8+m3)-(2,m3)-Prelude Music.Prelude>-Prelude Music.Prelude> separate (3*^_P8+m3)-(3,m3)-Prelude Music.Prelude>-Prelude Music.Prelude> separate (0*^_P8+m3)-(0,m3)-Prelude Music.Prelude> separate ((-1)*^_P8+m3)---} -- | -- Separate a compound interval into octaves and a simple interval. ----- > (perfect octave)^*x + y = z  iff  (x, y) = separate z+-- > x*^_P8 + y = z  iff  (x, y) = separate z --+-- >>> separate (2*^_P8+m3)+-- (2,m3)+-- >>> separate (3*^_P8+m3)+-- (3,m3)+-- >>> separate (0*^_P8+m3)+-- (0,m3)+-- >>> separate ((-1)*^_P8+m3)+--  separate :: Interval -> (Octaves, Interval) separate i = (fromIntegral o, i ^-^ (fromIntegral o *^ basis_P8))   where@@ -390,8 +304,14 @@ -- Returns whether the given interval is compound. -- -- A compound interval is either a negative interval, or a positive interval spanning--- one octave or more.+-- one octave or more. Note that compound intervals may be smaller than an octave if+-- they are negative, so --+-- >>> isCompound (-m3)+-- True +-- >>> isCompound $ abs (-m3)+-- False +-- isCompound :: Interval -> Bool isCompound x = octaves x /= 0 @@ -454,18 +374,10 @@ invert :: Interval -> Interval invert = simple . negate --- |--- This is just the identity function, but is useful to fix the type of 'Interval'.----asInterval :: Interval -> Interval-asInterval = id    --- mkInterval :: Quality -> Number -> Interval mkInterval q n = mkInterval' (fromIntegral diff) (fromIntegral steps)   where@@ -506,24 +418,17 @@ interval' = iso (\(d,s) -> mkInterval' (fromIntegral d) (fromIntegral s))    (\x -> (qualityToDiff (number x >= 0) (expectedQualityType (number x)) (quality x), (number x)^.diatonicSteps)) -{----- -- TODO be "nice"--- mkIntervalNice :: Quality -> Number -> Interval--- mkIntervalNice q n---   | expectedQualityType n `elem` qualityTypes q = mkInterval q n ---   | expectedQualityType n == MajorMinorType     = mkInterval (toMajorMinorType q) n---   | expectedQualityType n == PerfectType        = mkInterval (toPerfectType q) n+-- | View an interval as a pair of total number of chromatic and diatonic steps.+interval'' :: Iso' (ChromaticSteps, DiatonicSteps) Interval+interval'' = iso Interval getInterval -toMajorMinorType Perfect = Major-toPerfectType    Major   = Perfect-toPerfectType    Minor   = (Diminished 1)--- toPerfectType    x = x+{-+Note: This is *not* the same as wrapping/unwrapping, as the number of chromatic steps viewed here is+an *alteration*, rather than the total number of chromatic steps (basis d2). +E.g. d5 is internally represented as (6,4) but _P5^.from interval' == (-1,4). -}---          +          {-| >>> m3 & _number %~ pred m2@@ -555,24 +460,23 @@ d5 >>> _P5 & _quality .~ (Diminished 1) d5- -}                -- Internal stuff  -- TODO more generic pattern here-diatonicToChromatic :: Int -> Int-diatonicToChromatic d = (octaves*12) + go restDia+diatonicToChromatic :: DiatonicSteps -> ChromaticSteps+diatonicToChromatic d = fromIntegral $ (octaves*12) + go restDia     where         -- restDia is always in [0..6]-        (octaves, restDia) = d `divMod` 7+        (octaves, restDia) = fromIntegral d `divMod` 7         go = ([0,2,4,5,7,9,11] !!)  -- | Integer div of intervals: i / di = x, where x is an integer intervalDiv :: Interval -> Interval -> Int-intervalDiv (Interval (a, d)) (Interval (1, 0)) = a-intervalDiv (Interval (a, d)) (Interval (0, 1)) = d+intervalDiv (Interval (a, d)) (Interval (1, 0)) = fromIntegral a+intervalDiv (Interval (a, d)) (Interval (0, 1)) = fromIntegral d intervalDiv i di   | (i > basis_P1) = intervalDivPos i di   | (i < basis_P1) = intervalDivNeg i di@@ -604,13 +508,15 @@   | not $ p `divides` q = Nothing   | otherwise = Just (r `div` p, q `div` p)   where-    Interval (m, n) = i-    Interval (a, b) = j-    Interval (c, d) = k+    Interval (fromIntegral -> m, fromIntegral -> n) = i+    Interval (fromIntegral -> a, fromIntegral -> b) = j+    Interval (fromIntegral -> c, fromIntegral -> d) = k     p = (a*d - b*c)     q = (a*n - b*m)     r = (d*m - c*n)-+    +    divides :: Integral a => a -> a -> Bool+    x `divides` y = (y `rem` x) == 0  -- | Same as above, but don't worry if new interval has non-integer -- coefficients -- useful when getting a value to use as a frequency@@ -623,14 +529,9 @@ convertBasisFloat i j k   | (p == 0) = Nothing   | otherwise = Just (r / p, q / p)-  where Interval (m, n) = i-        Interval (a, b) = j-        Interval (c, d) = k+  where Interval (fromIntegral -> m, fromIntegral -> n) = i+        Interval (fromIntegral -> a, fromIntegral -> b) = j+        Interval (fromIntegral -> c, fromIntegral -> d) = k         p = fromIntegral $ (a*d - b*c)         q = fromIntegral $ (a*n - b*m)         r = fromIntegral $ (d*m - c*n)---divides :: Integral a => a -> a -> Bool-x `divides` y = (y `rem` x) == 0-

@@ -1,18 +1,5 @@ ---------------------------------------------------------------------------------------- |--- Copyright   : (c) Hans Hoglund, Edward Lilley 2012–2014------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : non-portable (TF,GNTD)------ Provides standard intervals.------------------------------------------------------------------------------------------+-- | Common pitch names in various (human) languages. module Music.Pitch.Common.Names (       Language(..),       Mode(..),@@ -48,6 +35,12 @@   | NewSwedish   deriving (Show, Eq, Ord)   +data Mode = MajorMode | MinorMode+  deriving (Eq, Ord, Show)++showKey :: Language -> Pitch -> Mode -> String+showKey lang pitch mode = showPitch lang pitch ++ showSep lang ++ showMode lang mode+ showPitch :: Language -> Pitch -> String showPitch lang pitch = (!! (pitchToIndex + pitchNameOffset)) $ fromMaybe (error "showPitch: Bad lang") $ listToMaybe $ filter (\xs -> head xs == show lang) $ pitchNames   where@@ -62,18 +55,12 @@        bb,b,bs]          pitchNameOffset = 3 -data Mode = MajorMode | MinorMode-  deriving (Eq, Ord, Show)- showMode :: Language -> Mode -> String showMode lang mode = (!! (modeToIndex + modeNameOffset)) $ fromMaybe (error "showMode: Bad lang") $ listToMaybe $ filter (\xs -> head xs == show lang) $ modeNames   where     modeToIndex = fromMaybe (error "showPitch: Bad mode") $ Data.List.findIndex (== mode)        [MajorMode,MinorMode]          modeNameOffset = 1--showKey :: Language -> Pitch -> Mode -> String-showKey lang pitch mode = showPitch lang pitch ++ showSep lang ++ showMode lang mode  showSep :: Language -> String showSep lang = fromMaybe (error "showSep: Bad lang") $ Data.List.lookup (show lang) nameModeSeparator

@@ -1,53 +1,31 @@ -{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoMonomorphismRestriction  #-}-{-# LANGUAGE StandaloneDeriving         #-}-{-# LANGUAGE TypeFamilies               #-}--module Music.Pitch.Common.Number where+-- | Number component of intervals.+module Music.Pitch.Common.Number+(+        Number,+        HasNumber(..),+        unison,+        prime,+        second,+        third,+        fourth,+        fifth,+        sixth,+        seventh,+        octave,+        ninth,+        tenth,+        eleventh,+        twelfth,+        thirteenth,+        fourteenth,+        fifteenth,+        diatonicSteps,+) where  import Control.Lens-import Music.Pitch.Common.Diatonic--{----- ** Number-Number,-HasNumber(..),-unison,-prime,-second,-third,-fourth,-fifth,-sixth,-seventh,-octave,-ninth,-tenth,-twelfth,-duodecim,-thirteenth,-fourteenth,-fifteenth,---}----- |--- The number portion of an interval (i.e. second, third, etc).------ Note that the interval number is always one step larger than number of steps spanned by--- the interval (i.e. a third spans two diatonic steps). Thus 'number' does not distribute--- over addition:------ > number (a + b) = number a + number b - 1----newtype Number = Number { getNumber :: Int }-  deriving (Eq, Ord, Num, Enum, Real, Integral)+import Music.Pitch.Common.Types -instance Show Number where { show = show . getNumber } instance HasNumber Number where number = id  -- | A synonym for @1@.

@@ -1,25 +1,7 @@ -{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE StandaloneDeriving         #-}-{-# LANGUAGE TypeFamilies               #-}----------------------------------------------------------------------------------------- |--- Copyright   : (c) Hans Hoglund, Edward Lilley 2012–2014------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : non-portable (TF,GNTD)------ Provides a standard pitch representation.-------------------------------------------------------------------------------------------module Music.Pitch.Common.Pitch (+-- | Common pitch.+module Music.Pitch.Common.Pitch+(         -- * Accidentals         Accidental,         natural,@@ -50,10 +32,7 @@         downChromaticP,         invertDiatonicallyP,         invertChromaticallyP,-        -        -- ** Utility-        asPitch-  ) where+) where  import           Control.Applicative import           Control.Monad@@ -67,50 +46,19 @@ import           Data.Semigroup import           Data.Typeable import           Data.VectorSpace+import           Data.Aeson                    (ToJSON (..))+import qualified Data.Aeson  import           Music.Pitch.Absolute import           Music.Pitch.Alterable import           Music.Pitch.Augmentable+import           Music.Pitch.Common.Types import           Music.Pitch.Common.Number import           Music.Pitch.Common.Interval import           Music.Pitch.Common.Semitones-import           Music.Pitch.Common.Chromatic-import           Music.Pitch.Common.Diatonic import           Music.Pitch.Literal --- |--- An accidental is either flat, natural or sharp.------ This representation allows for an arbitrary number of flats or sharps rather than just--- single and double.------ The 'Num' and 'Enum' instances treat 'Accidental' as the number of altered semitones,--- i.e. a double flat is @-2@, natural @0@ and so on.----newtype Accidental = Accidental { getAccidental :: Integer }-  deriving (Eq, Ord, Num, Enum, Real, Integral) -instance Show Accidental where-  show n | n == 0    = "natural"-         | n == 1    = "sharp"-         | n == (-1) = "flat"-         | n == 2    = "doubleSharp"-         | n == (-2) = "doubleFlat"-         | n > 0     = "sharp * " ++ show (getAccidental n)-         | n < 0     = "flat * " ++ show (negate $ getAccidental n)--instance Alterable Accidental where-  sharpen = succ-  flatten = pred---- |--- Magic instance that allow us to write @c sharp@ instead of @sharpen c@.----instance (IsPitch a, Alterable a) => IsPitch (Accidental -> a) where-  fromPitch l 1     = sharpen (fromPitch l)-  fromPitch l (-1)  = flatten (fromPitch l)--- Requires FlexibleInstances- sharp, flat, natural, doubleFlat, doubleSharp :: Accidental  -- | The double sharp accidental.@@ -146,66 +94,7 @@ isStandardAccidental a = abs a < 2 -- was: isStandard --- |--- A pitch name.----data Name = C | D | E | F | G | A | B-  deriving (Eq, Ord, Show, Enum) --- |--- Common pitch representation.------ Intervals and pitches can be added using '.+^'. To get the interval between--- two pitches, use '.-.'.------ Pitches are normally entered using the following literals.------ > c d e f g a b------ Notes with accidentals can be written by adding the @s@ or @b@ suffices--- (or two for double sharps and flats).------ > cs, ds, es ...    -- sharp--- > cb, db, eb ...    -- flat--- > css, dss, ess ... -- double sharp--- > cbb, dbb, ebb ... -- double flat------ There is also a convenience syntax for entering pitches one octave up or--- down, using @'@ and @_@ respectively.------ > g a b c'--- > d c b_ c------ Because of some overloading magic, we can actually write @sharp@ and--- @flat@ as /postfix/ functions. This gives a better read:------ > cs == c sharp--- > db == c flat------ You can of course use typical functional transformation of pitch as well.--- For example 'sharpen' and 'flatten' are the ordinary (prefix) versions of--- 'sharp' and 'flat'------ > sharpen c             == c sharp       == cs--- > flatten d             == d flat        == ds--- > (sharpen . sharpen) c == c doubleSharp == css--- > (flatten . flatten) d == d doubleFlat  == dss------ Note that there is no guarantee that your pitch representation use--- enharmonic equivalence, so @cs == db@ may or may not hold.------ > c .+^ minor third == eb--- > f .-. c           == perfect fourth------ Pitches are described by name, accidental and octave number.------ > c   == fromIntegral 0--- > _P4 == perfect fourth   == interval Perfect 5--- > d5  == diminished fifth == diminish (perfect fifth)----newtype Pitch = Pitch { getPitch :: Interval }-  deriving (Eq, Ord, Typeable)- instance IsPitch Pitch where   fromPitch (PitchL (c, a, o)) =     Pitch $ (\a b -> (fromIntegral a, fromIntegral b)^.interval') (qual a) c ^+^ (_P8^* fromIntegral o)@@ -238,13 +127,16 @@   abs (Pitch a)     = Pitch (abs a)   (*)           = error  "Music.Pitch.Common.Pitch: no overloading for (*)"   signum        = error "Music.Pitch.Common.Pitch: no overloading for signum"-  fromInteger   = error "Music.Pitch.Common.Pitch: no overloading for fromInteger"+  fromInteger   = toEnum . fromInteger  instance AffineSpace Pitch where   type Diff Pitch     = Interval   Pitch a .-. Pitch b = a ^-^ b   Pitch a .+^ b       = Pitch (a ^+^ b) +instance ToJSON Pitch where+  toJSON = toJSON . (.-. c)+ -- | -- Creates a pitch from name accidental. --@@ -278,12 +170,6 @@ accidental = fromIntegral . intervalDiff . simple . getPitch   where     intervalDiff = view (from interval'._1)---- |--- This is just the identity function, but is useful to fix the type of 'Pitch'.----asPitch :: Pitch -> Pitch-asPitch = id  upChromaticP :: Pitch -> ChromaticSteps -> Pitch -> Pitch upChromaticP origin n = relative origin $ (_alteration +~ n)

@@ -1,32 +1,34 @@ -{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoMonomorphismRestriction  #-}-{-# LANGUAGE StandaloneDeriving         #-}-{-# LANGUAGE TypeFamilies               #-}+-- | Common interval quality.+module Music.Pitch.Common.Quality+(+        -- * Quality+        Quality(..),+        qualityTypes,+        +        HasQuality(..),+        invertQuality,+        isPerfect,+        isMajor,+        isMinor,+        isAugmented,+        isDiminished, -module Music.Pitch.Common.Quality (-    -- * Quality-    Quality(..),-    HasQuality(..),-    invertQuality,-    isPerfect,-    isMajor,-    isMinor,-    isAugmented,-    isDiminished,+        -- ** Quality type+        QualityType(..),+        expectedQualityType, -    -- * Quality type-    QualityType(..),-    expectedQualityType,-    qualityTypes,-    qualityToDiff+        -- ** Quality to alteration+        Direction(..),+        qualityToAlteration, +        qualityToDiff ) where  import           Music.Pitch.Augmentable+import           Music.Pitch.Common.Types import           Music.Pitch.Common.Number-import           Music.Pitch.Common.Chromatic+import           Data.Maybe (fromMaybe)  -- | Types of value that has an interval quality (mainly 'Interval' and 'Quality' itself). class HasQuality a where@@ -51,36 +53,17 @@ isMinor a = case quality a of { Minor -> True ; _ -> False }  -- |--- Returns whether the given quality is /augmented/ (including double augmented etc).+-- Returns whether the given quality is augmented (including double augmented etc). -- isAugmented :: HasQuality a => a -> Bool isAugmented a = case quality a of { Augmented _ -> True ; _ -> False }  -- |--- Returns whether the given quality is /diminished/ (including double diminished etc).+-- Returns whether the given quality is diminished (including double diminished etc). -- isDiminished :: HasQuality a => a -> Bool isDiminished a = case quality a of { Diminished _ -> True ; _ -> False } --- |--- Interval quality is either perfect, major, minor, augmented, and--- diminished. This representation allows for an arbitrary number of--- augmentations or diminutions, so /augmented/ is represented by @Augmented--- 1@, /doubly augmented/ by @Augmented 2@ and so on.------ The quality of a compound interval is the quality of the simple interval on--- which it is based.----data Quality-  = Major-  | Minor-  | Perfect-  -- TODO we really want to use Positive here, but that requires a-  -- rewrite of extractQuality below-  | Augmented Integer-  | Diminished Integer-  deriving (Eq, Ord, Show)- instance HasQuality Quality where   quality = id @@ -93,17 +76,18 @@ -- intervals.  instance Augmentable Quality where-  augment Major = Augmented 1-  augment Minor = Major-  augment Perfect = Augmented 1-  augment (Augmented n) = Augmented (n + 1)-  augment (Diminished n) = Diminished (n - 1)-  diminish Major = Minor-  diminish Minor = Diminished 1-  diminish Perfect = Diminished 1-  diminish (Augmented n) = Augmented (n - 1)-  diminish (Diminished n) = Diminished (n + 1)+  augment Major                   = Augmented 1+  augment Minor                   = Major+  augment Perfect                 = Augmented 1+  augment (Augmented n)           = Augmented (n + 1)+  augment (Diminished n)          = Diminished (n - 1) +  diminish Major                  = Minor+  diminish Minor                  = Diminished 1+  diminish Perfect                = Diminished 1+  diminish (Augmented n)          = Augmented (n - 1)+  diminish (Diminished n)         = Diminished (n + 1)+ -- | -- Invert a quality. --@@ -120,35 +104,64 @@     go (Diminished n)   = Augmented n  -data QualityType = PerfectType | MajorMinorType-  deriving (Eq, Ord, Read, Show)--expectedQualityType :: HasNumber a => a -> QualityType-expectedQualityType x = if ((abs (number x) - 1) `mod` 7) + 1 `elem` [1,4,5]+-- | +-- The quality type expected for a given number, i.e. perfect for unisons, fourths,+-- and fifths and major/minor for everything else.  +expectedQualityType :: Number -> QualityType+expectedQualityType x = if ((abs x - 1) `mod` 7) + 1 `elem` [1,4,5]   then PerfectType else MajorMinorType +-- |+-- Return all possible quality types for a given quality. qualityTypes :: Quality -> [QualityType] qualityTypes Perfect = [PerfectType] qualityTypes Major   = [MajorMinorType] qualityTypes Minor   = [MajorMinorType] qualityTypes _       = [PerfectType, MajorMinorType] --- FIXME problem that this treats major as neutral, while this only holds for positive intervals-qualityToDiff :: Bool -> QualityType -> Quality -> ChromaticSteps-qualityToDiff positive qt q = fromIntegral $ go positive qt q+-- |+-- Return whether the given combination of quality and number forms a valid interval+-- expression.+--  +isValidQualityNumber :: Quality -> Number -> Bool+isValidQualityNumber q n = expectedQualityType n `elem` qualityTypes q++data Direction = Upward | Downward+  deriving (Eq, Ord, Show)++-- |+-- Return the alteration in implied by the given quality to a number of a given quality type.+--+qualityToAlteration :: Direction -> QualityType -> Quality -> Maybe ChromaticSteps+qualityToAlteration d qt q = fmap fromIntegral $ go d qt q   where-    go True MajorMinorType (Augmented n)  = 0 + n-    go True MajorMinorType Major          = 0-    go True MajorMinorType Minor          = (-1)-    go True MajorMinorType (Diminished n) = -(1 + n)+    go Upward MajorMinorType (Augmented n)    = Just $ 0 + n+    go Upward MajorMinorType Major            = Just $ 0+    go Upward MajorMinorType Minor            = Just $ (-1)+    go Upward MajorMinorType (Diminished n)   = Just $ -(1 + n) -    go False MajorMinorType (Augmented n)  = -(1 + n)-    go False MajorMinorType Major          = -1-    go False MajorMinorType Minor          = 0-    go False MajorMinorType (Diminished n) = 0 + n+    go Downward MajorMinorType (Augmented n)  = Just $ -(1 + n)+    go Downward MajorMinorType Major          = Just $ -1+    go Downward MajorMinorType Minor          = Just $ 0+    go Downward MajorMinorType (Diminished n) = Just $ 0 + n     -    go _ PerfectType (Augmented n)  = 0 + n-    go _ PerfectType Perfect        = 0-    go _ PerfectType (Diminished n) = 0 - n+    go Upward PerfectType (Augmented n)       = Just $ 0 + n+    go Upward PerfectType Perfect             = Just $ 0+    go Upward PerfectType (Diminished n)      = Just $ 0 - n++    go Downward PerfectType (Augmented n)     = Just $ 0 - n+    go Downward PerfectType Perfect           = Just $ 0+    go Downward PerfectType (Diminished n)    = Just $ 0 + n     -    go _ qt q = error $ "qualityToDiff: Unknown interval expression (" ++ show qt ++ ", " ++ show q ++ ")"+    go _ qt q = Nothing++qualityToDiff x qt q = fromMaybe e $ qualityToAlteration (f x) qt q+  where+    f True  = Upward+    f False = Downward+    e       = error $+      "qualityToDiff: Unknown interval expression (" +      ++ show qt ++ ", " ++ show q ++ ")"++{-# DEPRECATED qualityToDiff "Use qualityToAlteration" #-}+

@@ -1,31 +1,11 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE StandaloneDeriving         #-}----------------------------------------------------------------------------------------- |--- Copyright   : (c) Hans Hoglund, Edward Lilley 2012–2014------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : non-portable (TF,GNTD)------ Provides semitone, octave and step representation of intervals.-------------------------------------------------------------------------------------------module Music.Pitch.Common.Semitones (+-- | Semitones and enharmonic equivalence.+module Music.Pitch.Common.Semitones+(         -- * Types         -- ** Octaves         Octaves,-        -- HasOctaves(..), -        -- ** Steps-        Steps,-        -- HasSteps(..),-         -- ** Semitones         Semitones,         HasSemitones(..),@@ -40,20 +20,9 @@         -- * Enharmonic equivalence         (=:=),         (/:=),-  ) where---- |--- An interval represented as a number of octaves, including negative--- intervals.------ > octaves a = semitones a `div` 12--- > steps   a = semitones a `mod` 12----newtype Octaves = Octaves { getOctaves :: Integer }-  deriving (Eq, Ord, Num, Enum, Real, Integral)+) where -instance Show       Octaves where { show = show . getOctaves }-instance HasOctaves Octaves where { octaves = id }+import Music.Pitch.Common.Types  -- | -- Class of intervals that has a number of 'Octaves'.@@ -73,20 +42,9 @@   --   octaves :: a -> Octaves +instance HasOctaves Octaves where { octaves = id }  --- |--- An interval represented as a number of steps in the range /0 ≤ x < 12/.------ > octaves a = semitones a `div` 12--- > steps   a = semitones a `mod` 12----newtype Steps = Steps { getSteps :: Integer }-  deriving (Eq, Ord, Num, Enum, Real, Integral)--instance Show Steps where { show = show . getSteps }--- instance HasSteps Steps where { steps = id }- {- -- | -- Class of intervals that has a number of 'Steps'.@@ -104,31 +62,7 @@   steps :: a -> Steps -} -- -- |--- An interval represented as a number of semitones, including negative--- intervals, as well as intervals larger than one octave. This representation--- does not take spelling into account, so for example a major third and a--- diminished fourth can not be distinguished.------ Intervals that name a number of semitones (i.e. 'semitone', 'tritone') does--- not have an unequivocal spelling. To convert these to an interval, a--- 'Spelling' must be provided:------ >>> spell usingSharps tritone--- _A4------ >>> spell usingFlats  tritone--- d5----newtype Semitones = Semitones { getSemitones :: Integer }-  deriving (Eq, Ord, Num, Enum, Real, Integral)--instance Show         Semitones where { show = show . getSemitones }-instance HasSemitones Semitones where { semitones = id }---- | -- Class of intervals that can be converted to a number of 'Semitones'. -- class HasSemitones a where@@ -150,6 +84,7 @@   --   semitones :: a -> Semitones +instance HasSemitones ChromaticSteps where { semitones = id }   semitone, tone, ditone, tritone :: Semitones

@@ -1,23 +1,7 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE StandaloneDeriving         #-}-{-# LANGUAGE TypeFamilies               #-}----------------------------------------------------------------------------------------- |--- Copyright   : (c) Hans Hoglund, Edward Lilley 2012–2014------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : non-portable (TF,GNTD)------ Provides pitch spellings.-------------------------------------------------------------------------------------------module Music.Pitch.Common.Spell (+-- | Provides pitch spelling.+module Music.Pitch.Common.Spell+(         -- ** Spelling         -- * About         -- $semitonesAndSpellings@@ -31,7 +15,7 @@         modally,         usingSharps,         usingFlats,-  ) where+) where  import           Data.AffineSpace import           Data.VectorSpace

@@ -0,0 +1,305 @@++{-# LANGUAGE FlexibleInstances #-}++-- | Common (Western classical) pitches, intervals and related types.+module Music.Pitch.Common.Types+(+        -- * Even octaves and steps+        Octaves,+        DiatonicSteps,+        ChromaticSteps,+        Semitones,+        +        -- * Intervals+        Number,+        Quality(..),+        QualityType(..),+        IntervalBasis(..),+        Interval(..),++        -- * Pitch+        Name(..),+        Accidental,+        Pitch(..),        +) where++import Data.Typeable+import Data.AdditiveGroup++import Music.Pitch.Literal+import Music.Pitch.Alterable+import Music.Pitch.Augmentable++{-|+Number of chromatic steps.+May be negative, indicating a downward interval. +-}+newtype ChromaticSteps = ChromaticSteps { getChromaticSteps :: Int }+  deriving (Eq, Ord, Show, Enum, Num, Real, Integral)++{-| +Number of diatonic steps.+May be negative, indicating a downward interval. +-}+newtype DiatonicSteps = DiatonicSteps { getDiatonicSteps :: Int }+  deriving (Eq, Ord, Show, Enum, Num, Real, Integral)++{-| +Number of octaves.+May be negative, indicating a downward interval. +-}+newtype Octaves = Octaves { getOctaves :: Int }+  deriving (Eq, Ord, Num, Enum, Real, Integral)++{-|+Number of semitones.+May be negative, indicating a downward interval. +-}+type Semitones = ChromaticSteps++{-|+The /number/ component of an interval (fourth, fifth) etc.+May be negative, indicating a downward interval. +-}+newtype Number = Number { getNumber :: Integer }+  deriving (Eq, Ord, Num, Enum, Real, Integral)++{-|+The /quality/ component of an interval (minor, major, augmented).+Generalized from single\/double augmented\/diminished to any number of steps.+-}+data Quality+  = Major+  | Minor+  | Perfect+  | Augmented Integer+  | Diminished Integer+  deriving (Eq, Ord, Show)+{-+TODO we really want to use Positive instead of Integer+Alternatively, we could do it as a recursive type++data Quality+  = Major+  | Minor+  | Perfect+  | Augment Quality+  | Diminish Quality+-}++{-|+The alteration implied by a quality is dependent on whether it is attached+to a major\/minor vs. a perfect-style number. This type represents the two possibilities.+-}+data QualityType = PerfectType | MajorMinorType+  deriving (Eq, Ord, Read, Show)++{-|+Accidental, represented as number of alterations.+Generalized from natural and single\/double sharp\/flat to any number of steps.+-}+newtype Accidental = Accidental { getAccidental :: Integer }+  deriving (Eq, Ord, Num, Enum, Real, Integral)++{-|+Pitch name component.+-}+data Name = C | D | E | F | G | A | B+  deriving (Eq, Ord, Show, Enum)++{-|+This type represents standard basis for intervbals.+ -}+data IntervalBasis = Chromatic | Diatonic+  deriving (Eq, Ord, Show, Enum)++{-|+Interval type.+ -}+newtype Interval = Interval { getInterval :: (ChromaticSteps, DiatonicSteps) }+  deriving (Eq, Typeable)++{-|+Pitch type.+-}+newtype Pitch = Pitch { getPitch :: Interval }+  deriving (Eq, Ord, Typeable)++++instance Show Octaves where+  show = show . getOctaves++instance Show Number where+  show = show . getNumber++instance Show Accidental where+  show n | n == 0    = "natural"+         | n == 1    = "sharp"+         | n == (-1) = "flat"+         | n == 2    = "doubleSharp"+         | n == (-2) = "doubleFlat"+         | n > 0     = "sharp * " ++ show (getAccidental n)+         | n < 0     = "flat * " ++ show (negate $ getAccidental n)++instance Alterable Accidental where+  sharpen = succ+  flatten = pred++-- | Magic instance that allow us to write @c sharp@ instead of @sharpen c@.+instance (IsPitch a, Alterable a) => IsPitch (Accidental -> a) where+  fromPitch l 1     = sharpen (fromPitch l)+  fromPitch l (-1)  = flatten (fromPitch l)+-- Requires FlexibleInstances++{-| Lexicographical ordering, comparing the 'd2' component of the+Interval first, as it's tied to the Number which is expected to be+'bigger' than the Quality, assuming ordinary tuning systems+-}+instance Ord Interval where+  Interval a `compare` Interval b = swap a `compare` swap b+    where swap (x,y) = (y,x)++instance AdditiveGroup ChromaticSteps where+  zeroV = 0+  (^+^) = (+)+  negateV = negate++instance AdditiveGroup DiatonicSteps where+  zeroV = 0+  (^+^) = (+)+  negateV = negate++++++{-+The number portion of an interval (i.e. second, third, etc).++Note that the interval number is always one step larger than number of steps spanned by+the interval (i.e. a third spans two diatonic steps). Thus 'number' does not distribute+over addition:++> number (a + b) = number a + number b - 1+-}++{-+Common pitch representation.++Intervals and pitches can be added using '.+^'. To get the interval between+two pitches, use '.-.'.++Pitches are normally entered using the following literals.++> c d e f g a b++Notes with accidentals can be written by adding the @s@ or @b@ suffices+(or two for double sharps and flats).++> cs, ds, es ...    -- sharp+> cb, db, eb ...    -- flat+> css, dss, ess ... -- double sharp+> cbb, dbb, ebb ... -- double flat++There is also a convenience syntax for entering pitches one octave up or+down, using @'@ and @_@ respectively.++> g a b c'+> d c b_ c++Because of some overloading magic, we can actually write @sharp@ and+@flat@ as /postfix/ functions. This gives a better read:++> cs == c sharp+> db == c flat++You can of course use typical functional transformation of pitch as well.+For example 'sharpen' and 'flatten' are the ordinary (prefix) versions of+'sharp' and 'flat'++> sharpen c             == c sharp       == cs+> flatten d             == d flat        == ds+> (sharpen . sharpen) c == c doubleSharp == css+> (flatten . flatten) d == d doubleFlat  == dss++Note that there is no guarantee that your pitch representation use+enharmonic equivalence, so @cs == db@ may or may not hold.++> c .+^ minor third == eb+> f .-. c           == perfect fourth++Pitches are described by name, accidental and octave number.++> c   == fromIntegral 0+> _P4 == perfect fourth   == interval Perfect 5+> d5  == diminished fifth == diminish (perfect fifth)++-}++{-+A musical interval such as minor third, augmented fifth, duodecim etc.++We include direction in in this definition, so a downward minor third (written @-m3@)+is distinct from an upward minor third (written @m3@). Note that @_P1@ and @-P1@ are+synynoms.++Not to be confused with a mathematical inverval in pitch space, which is called+'Ambitus'. Intervals and pitches form an affine-vector space pair with intervals and+/vectors/ and pitches as /points/. To add an interval to a, use '.+^'. To get the+interval between two pitches, use '.-.'.++> c .+^ minor third == eb+> f .-. c           == perfect fourth++Adding intervals preserves spelling. For example:++> m3 ^+^ _M3 = _P5+> d5 ^+^ _M6 = m10++The scalar type of 'Interval' is 'Int', using '^*' to stack intervals of a certain type+on top of each other. For example @_P5 ^* 2@ is a stack of 2 perfect fifths, or a major+ninth. The 'Num' instance works as expected for '+', 'negate' and 'abs', and+(arbitrarily) uses minor seconds for multiplication. If you find yourself '*', or+'signum' on intervals, consider switching to '*^' or 'normalized'.++Intervals are generally described in terms of 'Quality' and 'Number'. To construct an+interval, use the 'interval' constructor, the utility constructors 'major', 'minor',+'augmented' and 'diminished', or the interval literals:++> m5  == minor   fifth    == interval Minor   5 > _P4 == perfect fourth   == interval+Perfect 5 > d5  == diminished fifth == diminish (perfect fifth)++-}+++{-+An accidental is either flat, natural or sharp.++This representation allows for an arbitrary number of flats or sharps rather than just+single and double.++The 'Num' and 'Enum' instances treat 'Accidental' as the number of altered semitones,+i.e. a double flat is @-2@, natural @0@ and so on.++-}++{-+Interval quality is either perfect, major, minor, augmented, and+diminished. This representation allows for an arbitrary number of+augmentations or diminutions, so /augmented/ is represented by @Augmented+1@, /doubly augmented/ by @Augmented 2@ and so on.++The quality of a compound interval is the quality of the simple interval on+which it is based.++-}++{-+An interval represented as a number of octaves, including negative+intervals.++> octaves a = semitones a `div` 12+> steps   a = semitones a `mod` 12+-}+

@@ -1,28 +1,15 @@ -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------------------- |--- Copyright   : (c) Hans Hoglund 2012------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : portable------ Generic equal temperament pitch.------ Use the type-level numbers from @type-unary@ to construct an temperement dividing--- the octave in any number of steps. Common cases such as 6-TET (whole-tones),--- 12-TET (half-tones) and 24-TET (quarter-tones) are provided for convenience.-----------------------------------------------------------------------------------------+{-| Generic equal temperament pitch. -module Music.Pitch.Equal (+Use the type-level numbers to construct an temperement dividing+the octave in any number of equal-sized steps.++Common cases such as 6, 12 and 24 are provided for convenience.+-}+module Music.Pitch.Equal+(     -- * Equal temperament     Equal,     toEqual,@@ -63,11 +50,12 @@  newtype Equal a = Equal { getEqual :: Int } -deriving instance {-IsNat a =>-} Eq (Equal a)-deriving instance {-IsNat a =>-} Ord (Equal a)+deriving instance Eq (Equal a)+deriving instance Ord (Equal a) -instance {-IsNat a =>-} Show (Equal a) where+instance Show (Equal a) where   show (Equal a) = show a+  -- OR:   -- showsPrec d (Equal x) = showParen (d > app_prec) $   --      showString "Equal " . showsPrec (app_prec+1) x   --   where app_prec = 10@@ -100,14 +88,14 @@ getSize :: IsNat a => Equal a -> Nat a getSize _ = nat  --- | Size of this type (value not evaluated).--- --- >>> size (undefined :: Equal N2)--- 2--- --- >>> size (undefined :: Equal N12)--- 12--- +{-| Size of this type (value not evaluated).++>>> size (undefined :: Equal N2)+2++>>> size (undefined :: Equal N12)+12+-} size :: IsNat a => Equal a -> Int size = natToZ . getSize @@ -138,28 +126,29 @@ fromEqual :: IsNat a => Equal a -> Int fromEqual = getEqual --- | Convert an equal-temeperament value to a frequency ratio.------ >>> equalToRatio (7 :: Equal12)--- 1.4983070768766815------ >>> equalToRatio (4 :: Equal12)--- 1.2599210498948732---+{-| Convert an equal-temeperament value to a frequency ratio.++>>> equalToRatio (7 :: Equal12)+1.4983070768766815++>>> equalToRatio (4 :: Equal12)+1.2599210498948732++-} equalToRatio :: IsNat a => Equal a -> Double equalToRatio x = 2**(realToFrac (fromEqual x) / realToFrac (size x)) --- | Safely cast a tempered value to another size.------ >>> cast (1 :: Equal12) :: Equal24--- 2 :: Equal24------ >>> cast (8 :: Equal12) :: Equal6--- 4 :: Equal6------ >>> (2 :: Equal12) + cast (2 :: Equal24)--- 3 :: Equal12---+{-| Safely cast a tempered value to another size.++>>> cast (1 :: Equal12) :: Equal24+2 :: Equal24++>>> cast (8 :: Equal12) :: Equal6+4 :: Equal6++>>> (2 :: Equal12) + cast (2 :: Equal24)+3 :: Equal12+-} cast :: (IsNat a, IsNat b) => Equal a -> Equal b cast = cast' undefined 

@@ -1,28 +1,13 @@ -{-# LANGUAGE ViewPatterns #-}------------------------------------------------------------------------------------------ |--- Copyright   : (c) Hans Hoglund 2012------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : portable------ Provides intonation, i.e. mappings from relative to absolute pitch.------------------------------------------------------------------------------------------+-- | Intonation and tuning. module Music.Pitch.Intonation (-      Intonation,-      Tuning,+      Intonation(..),+      Tuning(..),        intone,       -- makeBasis,       synTune,-      tetTune,+      -- tetTune,       pureOctaveWith,        -- * Specific tunings@@ -47,8 +32,11 @@ import Data.Semigroup import Data.VectorSpace import Data.AffineSpace+import Data.Basis import Control.Monad import Control.Applicative+import Data.Fixed+import Data.Ratio import Control.Lens  import Music.Pitch.Absolute@@ -56,30 +44,39 @@ import Music.Pitch.Common.Interval import Music.Pitch.Common.Pitch -type Intonation p = p -> Hertz-type Tuning i = i -> {-FreqRatio-}Hertz+newtype Tuning i = Tuning { getTuning :: i -> Double } -synTune :: (Interval, {-FreqRatio-}Hertz) -> (Interval, {-FreqRatio-}Hertz) -> Interval -> {-FreqRatio-}Hertz-synTune (i1, i1rat) (i2, i2rat) (view (from interval') -> (a1, d2)) =-  ((makeA1 (i1, i1rat) (i2, i2rat)) ^* (fromIntegral a1)) ^+^ ((maked2 (i1, i1rat) (i2, i2rat)) ^* (fromIntegral d2))-  where makeA1 = makeBasis (Intervals._A1 :: Interval)-        maked2 = makeBasis (Intervals.d2  :: Interval)+newtype Intonation p = Intonation { getIntonation :: p -> Hertz } -makeBasis :: Interval -> (Interval, {-FreqRatio-}Hertz) -> (Interval, {-FreqRatio-}Hertz) -> {-FreqRatio-}Hertz+basis_A1 :: Interval+basis_A1 = basisValue Chromatic++basis_d2 :: Interval+basis_d2 = basisValue Diatonic++synTune :: (Interval, Double) -> (Interval, Double) -> Interval -> Double+synTune (i1, i1rat) (i2, i2rat) (view (from interval'') -> (a1, d2)) =+  ((makeA1 (i1, i1rat) (i2, i2rat)) ** (fromIntegral a1)) * ((maked2 (i1, i1rat) (i2, i2rat)) ** (fromIntegral d2))+  where makeA1 = makeBasis basis_A1+        maked2 = makeBasis basis_d2++makeBasis :: Interval -> (Interval, Double) -> (Interval, Double) -> Double makeBasis i (i1, r1) (i2, r2) = case (convertBasisFloat i i1 i2) of-  Just (x, y) -> (x *^ r1) ^+^ (y *^ r2)+  Just (x, y) -> (r1 ** x) * (r2 ** y)   Nothing -> error ("Cannot use intervals " ++ (show i1) ++ " and " ++ (show i2) ++ " as basis pair to represent " ++ (show i))  -- | Turn a tuning into an intonation. intone :: (Pitch, Hertz) -> Tuning Interval -> Intonation Pitch-intone (b, f) t p = f .+^ (t i) where i = p .-. b+intone (b, f) (Tuning t) = Intonation $ int+  where int p = f .+^ (t i) where i = p .-. b -- More generally: -- intone :: AffineSpace p => (p, Hertz) -> Tuning (Diff p) -> Intonation p   -- Standard syntonic (meantone) tunings, with P8 = 2 -pureOctaveWith = synTune (_P8, 2)+pureOctaveWith :: (Interval, Double) -> Tuning Interval+pureOctaveWith = Tuning . synTune (_P8, 2)  pythagorean :: Tuning Interval pythagorean = pureOctaveWith (_P5, 3/2)@@ -92,6 +89,7 @@  -- TET tunings, i.e. where P8 = 2 and (some other interval) = 1 +tetTune :: Interval -> Tuning Interval tetTune i = pureOctaveWith (i, 1)  fiveToneEqual :: Tuning Interval@@ -115,3 +113,22 @@ -- | Modern standard intonation, i.e. 12-TET with @a = 440 Hz@. standardIntonation :: Intonation Pitch standardIntonation = intone (a, 440) twelveToneEqual++{-+Possible instances for numeric types based on standard intonation.++Not used, the user should choose perform the appropriate conversion for a given+tuning system.++instance IsInterval Double where+  fromInterval i = getTuning twelveToneEqual $ fromInterval i++instance IsInterval Float where+    fromInterval x = realToFrac (fromInterval x :: Double)++instance HasResolution a => IsInterval (Fixed a) where+    fromInterval x = realToFrac (fromInterval x :: Double)++instance Integral a => IsInterval (Ratio a) where+    fromInterval x = realToFrac (fromInterval x :: Double)+-}

@@ -1,188 +1,310 @@ -{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE DeriveTraversable          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE TypeFamilies               #-}+-- | Scales and chords.+module Music.Pitch.Scale+(+        -- * Modes and scales+        Mode,+        modeFromSteps,+        modeIntervals,+        modeRepeat,+        Scale,+        scaleTonic,+        scaleMode,+        leadingInterval,           +        invertMode,                +        modeToScale,+        scaleToList, ---------------------------------------------------------------------------------------- |--- Copyright   : (c) Hans Hoglund, Edward Lilley 2012–2014------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : non-portable (TF,GNTD)-----------------------------------------------------------------------------------------+        -- * Chord types and chords+        Function,+        functionFromSteps,+        functionIntervals,+        functionRepeat,+        Chord,+        chordTonic,+        chordFunction,+        complementInterval,        +        invertChord,               +        functionToChord,           +        chordToList,                -module Music.Pitch.Scale (-  Mode,-  Scale,-  majorScale,-  pureMinorScale,-  harmonicMinorScale,-  melodicMinorScale,-  aeolian,-  locrian,-  ionian,-  dorian,-  phrygian,-  lydian,-  mixolydian,-  majorPentaTonic,-  minorPentaTonic,-  bluesScale,-  bebopScale,-  wholeTone,-  octatonic,-  firstMode,-  secondMode,-  thirdMode,-  fourthMode,-  fifthMode,-  sixthMode,-  seventhMode,+        -- * Common modes+        -- ** Classical modes+        majorScale,+        pureMinorScale,+        harmonicMinorScale,+        melodicMinorScaleUp,+        -- ** Church modes+        aeolian,+        locrian,+        ionian,+        dorian,+        phrygian,+        lydian,+        mixolydian,+        majorPentaTonic,+        minorPentaTonic,+        bluesMinor,+        bluesMajor,+        bebopScale,+        +        -- ** Miscellaneous modes+        wholeTone,+        octatonic,+        +        -- ** Modes of limited transposition+        firstMode,+        secondMode,+        thirdMode,+        fourthMode,+        fifthMode,+        sixthMode,+        seventhMode, -  Function,-  _intervals,-  _repeat,-  Chord,-  _tonic,-  -  majorTriad,-  minorTriad,-  augmentedChord,-  diminishedChord,-  halfDiminishedChord,-  majorSeventhChord,+        -- * Common chords+        majorTriad,+        minorTriad,+        augmentedChord,+        diminishedChord,+        halfDiminishedChord,+        majorMinorSeventhChord,+        majorMajorSeventhChord,   -  ) where+) where  import Data.VectorSpace import Data.AffineSpace import Music.Pitch.Literal import Control.Lens-import Music.Pitch hiding (Mode) -- Test+import Music.Pitch.Literal+import Music.Pitch.Common hiding (Mode) ++-- | A mode is a list of intervals and a characteristic repeating interval.  data Mode a = Mode [Diff a] (Diff a) -- intervals, repeat (usually octave)-data Scale a = Scale a (Mode a) -- root, mode +-- |+-- > [Interval] -> Interval -> Mode Pitch+modeFromSteps :: [Diff a] -> Diff a -> Mode a+modeFromSteps = Mode++-- |+-- > Lens' (Mode Pitch) [Interval]+modeIntervals :: Lens' (Mode a) [Diff a]+modeIntervals f (Mode is r) = fmap (\is -> Mode is r) $ f is++-- |+-- > Lens' (Mode Pitch) Interval+modeRepeat :: Lens' (Mode a) (Diff a)+modeRepeat f (Mode is r) = fmap (\r -> Mode is r) $ f r++-- | A scale is a mode with a specified tonic.+data Scale a = Scale a (Mode a)      -- root, mode++modeToScale :: AffineSpace a => a -> Mode a -> Scale a+modeToScale = Scale++-- |+-- > Lens' (Scale Pitch) Pitch+scaleTonic :: Lens' (Scale a) a+scaleTonic f (Scale t xs) = fmap (\t -> Scale t xs) $ f t++-- |+-- > Lens' (Scale Pitch) (Mode Pitch)+scaleMode :: Lens' (Scale a) (Mode a)+scaleMode f (Scale t xs) = fmap (\xs -> Scale t xs) $ f xs++-- |+--+-- >>> leadingInterval majorScale +-- m2+-- >>> leadingInterval harmonicMinorScale +-- m2+-- >>> leadingInterval pureMinorScale +-- _M2+--+leadingInterval :: AffineSpace a => Mode a -> Diff a+leadingInterval (Mode steps repeating) = repeating ^-^ sumV steps++invertMode :: AffineSpace a => Int -> Mode a -> Mode a+invertMode 0 = id+invertMode n = invertMode (n-1) . invertMode1+  where+    invertMode1 :: AffineSpace a => Mode a -> Mode a+    invertMode1 mode@(Mode steps repeating) = Mode (tail steps ++ [leadingInterval mode]) repeating++scaleToList :: AffineSpace a => Scale a -> [a]+scaleToList (Scale tonic mode@(Mode steps repeating)) = offsetPoints tonic steps+  where+    -- TODO consolidate+    offsetPoints :: AffineSpace p => p -> [Diff p] -> [p]+    offsetPoints = scanl (.+^)++++ data Function a = Function [Diff a] (Diff a) -- intervals, repeat, repeat (usually octave)-data Chord a = Chord a (Function a) -- root, function  -_intervals :: Lens' (Function a) [Diff a]-_intervals f (Function is r) = fmap (\is -> Function is r) $ f is+-- |+-- > [Interval] -> Interval -> Function Pitch+functionFromSteps :: [Diff a] -> Diff a -> Function a+functionFromSteps = Function -_repeat :: Lens' (Function a) (Diff a)-_repeat f (Function is r) = fmap (\r -> Function is r) $ f r+-- |+-- > Lens' (Function Pitch) [Interval]+functionIntervals :: Lens' (Function a) [Diff a]+functionIntervals f (Function is r) = fmap (\is -> Function is r) $ f is -{--_pitches :: Lens' (Chord a) [a]-_pitches f (Chord t xs) = fmap (\xs -> Chord t (fmap (.-. t) xs)) $ f (fmap (.+^ t) $ xs) . _intervals--}+-- |+-- > Lens' (Function Pitch) Interval+functionRepeat :: Lens' (Function a) (Diff a)+functionRepeat f (Function is r) = fmap (\r -> Function is r) $ f r -_tonic :: Lens' (Chord a) a-_tonic f (Chord t xs) = fmap (\t -> Chord t xs) $ f t+data Chord a = Chord a (Function a)          -- root, function +functionToChord :: AffineSpace a => a -> Function a -> Chord a+functionToChord = Chord++-- |+-- > Lens' (Chord Pitch) Pitch+chordTonic :: Lens' (Chord a) a+chordTonic f (Chord t xs) = fmap (\t -> Chord t xs) $ f t++-- |+-- > Lens' (Chord Pitch) (Function Pitch)+chordFunction :: Lens' (Chord a) (Function a)+chordFunction f (Chord t xs) = fmap (\xs -> Chord t xs) $ f xs++-- |+--+-- >>> complementInterval majorTriad+-- _P4+-- >>> complementInterval minorTriad+-- _P4+-- >>> complementInterval majorMinorSeventhChord+-- _M2+--+-- > Lens' (Function Pitch) Interval+complementInterval :: AffineSpace a => Function a -> Diff a+complementInterval (Function leaps repeating) = repeating ^-^ sumV leaps++invertChord :: AffineSpace a => Int -> Function a -> Function a+invertChord 0 = id+invertChord n = invertChord (n-1) . invertChord1+  where+    invertChord1 :: AffineSpace a => Function a -> Function a+    invertChord1 function@(Function leaps repeating) = Function (tail leaps ++ [complementInterval function]) repeating++-- | Returns a single inversion of the given chord (no repeats!).+chordToList :: AffineSpace a => Chord a -> [a]+chordToList (Chord tonic mode@(Function leaps repeating)) = offsetPoints tonic leaps+-- TODO inversion?+  where+    -- TODO consolidate+    offsetPoints :: AffineSpace p => p -> [Diff p] -> [p]+    offsetPoints = scanl (.+^)+++++-- Common scales+ majorScale :: Mode Pitch-majorScale = Mode [_M2,_M2] _P8+majorScale = modeFromSteps [_M2,_M2,m2,_M2,_M2,_M2] _P8  pureMinorScale :: Mode Pitch-pureMinorScale = undefined+pureMinorScale = modeFromSteps [_M2,m2,_M2,_M2,m2,_M2] _P8  harmonicMinorScale :: Mode Pitch-harmonicMinorScale = undefined--melodicMinorScale :: Mode Pitch-melodicMinorScale = undefined--aeolian :: Mode Pitch-aeolian = Mode [_M2,_M2,m2,_M2,_M2,m2,_M2] _P8+harmonicMinorScale = modeFromSteps [_M2,m2,_M2,_M2,m2,_A2] _P8 -locrian :: Mode Pitch-locrian = undefined+melodicMinorScaleUp :: Mode Pitch+melodicMinorScaleUp = modeFromSteps [_M2,m2,_M2,_M2,_M2,_M2] _P8  ionian :: Mode Pitch-ionian = undefined+ionian = invertMode 0 majorScale  dorian :: Mode Pitch-dorian = undefined+dorian = invertMode 1 majorScale  phrygian :: Mode Pitch-phrygian = undefined+phrygian = invertMode 2 majorScale  lydian :: Mode Pitch-lydian = undefined+lydian = invertMode 3 majorScale  mixolydian :: Mode Pitch-mixolydian = undefined+mixolydian = invertMode 4 majorScale +aeolian :: Mode Pitch+aeolian = invertMode 5 majorScale++locrian :: Mode Pitch+locrian = invertMode 6 majorScale+ majorPentaTonic :: Mode Pitch-majorPentaTonic = undefined+majorPentaTonic = modeFromSteps [_M2,_M2,m3,_M2] _P8 -minorPentaTonic :: Mode Pitch-minorPentaTonic = undefined+bluesMinor :: Mode Pitch+bluesMinor = invertMode 2 majorPentaTonic -bluesScale :: Mode Pitch-bluesScale = undefined+bluesMajor :: Mode Pitch+bluesMajor = invertMode 3 majorPentaTonic +minorPentaTonic :: Mode Pitch+minorPentaTonic = invertMode 4 majorPentaTonic+ bebopScale :: Mode Pitch-bebopScale = undefined+bebopScale = modeFromSteps [_M2,_M2,m2,_M2,m2,m2,_M2] _P8  wholeTone :: Mode Pitch-wholeTone = undefined+wholeTone = firstMode  octatonic :: Mode Pitch-octatonic = undefined+octatonic = secondMode  firstMode :: Mode Pitch-firstMode = undefined+firstMode = modeFromSteps [_M2,_M2,_M2,_M2,_M2] _P8  secondMode :: Mode Pitch-secondMode = undefined+secondMode = modeFromSteps [m2,_M2,_A1,_M2,m2,_M2,m2] _P8  thirdMode :: Mode Pitch-thirdMode = undefined+thirdMode = modeFromSteps [_M2,m2,m2,_M2,m2,m2,_M2,m2] _P8  fourthMode :: Mode Pitch-fourthMode = undefined+fourthMode = modeFromSteps [m2,m2,m3,m2,m2,m2,m3] _P8  fifthMode :: Mode Pitch-fifthMode = undefined+fifthMode = modeFromSteps [m2,_M3,m2,m2,_M3] _P8  sixthMode :: Mode Pitch-sixthMode = undefined+sixthMode = modeFromSteps [_M2,_M2,m2,m2,_M2,_M2,m2] _P8  seventhMode :: Mode Pitch-seventhMode = undefined--+seventhMode = modeFromSteps [m2,m2,m2,_M2,m2,m2,m2,m2,_M2] _P8 +-- Common chords  majorTriad :: Function Pitch-majorTriad = undefined+majorTriad = Function [_M3,m3] _P8  minorTriad :: Function Pitch-minorTriad = undefined+minorTriad = Function [m3,_M3] _P8  augmentedChord :: Function Pitch-augmentedChord = undefined+augmentedChord = Function [_M3,_M3] _P8  diminishedChord :: Function Pitch-diminishedChord = undefined+diminishedChord = Function [m3,m3,_A2] _P8  halfDiminishedChord :: Function Pitch-halfDiminishedChord = undefined--majorSeventhChord :: Function Pitch-majorSeventhChord = undefined--+halfDiminishedChord = Function [m3,m3,_M3] _P8 +majorMinorSeventhChord :: Function Pitch+majorMinorSeventhChord = Function [_M3,m3,m3] _P8 +majorMajorSeventhChord :: Function Pitch+majorMajorSeventhChord = Function [_M3,m3,_M3] _P8  

@@ -1,79 +0,0 @@--{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE DeriveTraversable          #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GADTs                      #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TypeFamilies               #-}----------------------------------------------------------------------------------------- |--- Copyright   : (c) Hans Hoglund, Edward Lilley 2012–2014------ License     : BSD-style------ Maintainer  : hans@hanshoglund.se--- Stability   : experimental--- Portability : non-portable (TF,GNTD)------ Lines and staff positions.-------------------------------------------------------------------------------------------module Music.Pitch.StaffLines (-        StaffLines,-        HalfSpaces,-  ) where--import Numeric.Natural-import Data.Typeable---- TODO maybe parameterize stafflines on number of staves---- |--- For notation systems using staff lines (i.e. CMN), this type represents staff number.------ Rules:------ * Incrementing staff lines means moving upward.-------- * For staff systems with an odd number of lines, 0 is the middle staff.------ * For staff systems with an even number of lines, 0 is the staff below the middle space.------ I.e. in CMN the staff lines are @[-2..2]@, with negative numbers representing the lines--- below the middle line and positions numbers representing the lines above it.----newtype StaffLines = StaffLines { getStaffLines :: Integer }-  deriving (Eq, Ord, Read, Show, Enum,-           Num, Real, Integral, Typeable)---- |--- For notation systems using staff lines, this type represents the difference betwee two--- staff positions (i.e. one diatonic step in CMN).------ Rules:------ * Incrementing half spaces means moving upward.------ * For staff systems with an odd number of lines, 0 is the middle staff.------ * For staff systems with an even number of lines, 0 is the middle space.------ I.e. in CMN, the non-ledger positions are @[-5..5]@ with the even numbers representing--- lines and the odd representing spaces and with positive numbers representing positions--- above the middle line and negative numbers representing positions below.----newtype HalfSpaces = HalfSpaces { getHalfSpaces :: Integer }-  deriving (Eq, Ord, Read, Show, Enum,-           Num, Real, Integral, Typeable)----- staffLinesForNumber :: Int -> StaffLines--- staffLinesForNumber