diff --git a/music-pitch.cabal b/music-pitch.cabal --- a/music-pitch.cabal +++ b/music-pitch.cabal @@ -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 diff --git a/src/Music/Pitch.hs b/src/Music/Pitch.hs --- a/src/Music/Pitch.hs +++ b/src/Music/Pitch.hs @@ -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 diff --git a/src/Music/Pitch/Absolute.hs b/src/Music/Pitch/Absolute.hs --- a/src/Music/Pitch/Absolute.hs +++ b/src/Music/Pitch/Absolute.hs @@ -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 - ] - diff --git a/src/Music/Pitch/Ambitus.hs b/src/Music/Pitch/Ambitus.hs --- a/src/Music/Pitch/Ambitus.hs +++ b/src/Music/Pitch/Ambitus.hs @@ -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 diff --git a/src/Music/Pitch/Clef.hs b/src/Music/Pitch/Clef.hs --- a/src/Music/Pitch/Clef.hs +++ b/src/Music/Pitch/Clef.hs @@ -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 + + diff --git a/src/Music/Pitch/Common.hs b/src/Music/Pitch/Common.hs --- a/src/Music/Pitch/Common.hs +++ b/src/Music/Pitch/Common.hs @@ -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 diff --git a/src/Music/Pitch/Common/Chromatic.hs b/src/Music/Pitch/Common/Chromatic.hs deleted file mode 100644 --- a/src/Music/Pitch/Common/Chromatic.hs +++ /dev/null @@ -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) - diff --git a/src/Music/Pitch/Common/Diatonic.hs b/src/Music/Pitch/Common/Diatonic.hs deleted file mode 100644 --- a/src/Music/Pitch/Common/Diatonic.hs +++ /dev/null @@ -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) diff --git a/src/Music/Pitch/Common/Harmony.hs b/src/Music/Pitch/Common/Harmony.hs --- a/src/Music/Pitch/Common/Harmony.hs +++ b/src/Music/Pitch/Common/Harmony.hs @@ -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, diff --git a/src/Music/Pitch/Common/Interval.hs b/src/Music/Pitch/Common/Interval.hs --- a/src/Music/Pitch/Common/Interval.hs +++ b/src/Music/Pitch/Common/Interval.hs @@ -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 - diff --git a/src/Music/Pitch/Common/Names.hs b/src/Music/Pitch/Common/Names.hs --- a/src/Music/Pitch/Common/Names.hs +++ b/src/Music/Pitch/Common/Names.hs @@ -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 diff --git a/src/Music/Pitch/Common/Number.hs b/src/Music/Pitch/Common/Number.hs --- a/src/Music/Pitch/Common/Number.hs +++ b/src/Music/Pitch/Common/Number.hs @@ -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@. diff --git a/src/Music/Pitch/Common/Pitch.hs b/src/Music/Pitch/Common/Pitch.hs --- a/src/Music/Pitch/Common/Pitch.hs +++ b/src/Music/Pitch/Common/Pitch.hs @@ -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) diff --git a/src/Music/Pitch/Common/Quality.hs b/src/Music/Pitch/Common/Quality.hs --- a/src/Music/Pitch/Common/Quality.hs +++ b/src/Music/Pitch/Common/Quality.hs @@ -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" #-} + diff --git a/src/Music/Pitch/Common/Semitones.hs b/src/Music/Pitch/Common/Semitones.hs --- a/src/Music/Pitch/Common/Semitones.hs +++ b/src/Music/Pitch/Common/Semitones.hs @@ -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 diff --git a/src/Music/Pitch/Common/Spell.hs b/src/Music/Pitch/Common/Spell.hs --- a/src/Music/Pitch/Common/Spell.hs +++ b/src/Music/Pitch/Common/Spell.hs @@ -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 diff --git a/src/Music/Pitch/Common/Types.hs b/src/Music/Pitch/Common/Types.hs new file mode 100644 --- /dev/null +++ b/src/Music/Pitch/Common/Types.hs @@ -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 +-} + diff --git a/src/Music/Pitch/Equal.hs b/src/Music/Pitch/Equal.hs --- a/src/Music/Pitch/Equal.hs +++ b/src/Music/Pitch/Equal.hs @@ -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 diff --git a/src/Music/Pitch/Intonation.hs b/src/Music/Pitch/Intonation.hs --- a/src/Music/Pitch/Intonation.hs +++ b/src/Music/Pitch/Intonation.hs @@ -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) +-} diff --git a/src/Music/Pitch/Scale.hs b/src/Music/Pitch/Scale.hs --- a/src/Music/Pitch/Scale.hs +++ b/src/Music/Pitch/Scale.hs @@ -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 diff --git a/src/Music/Pitch/StaffLines.hs b/src/Music/Pitch/StaffLines.hs deleted file mode 100644 --- a/src/Music/Pitch/StaffLines.hs +++ /dev/null @@ -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