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.2 +version: 1.3 cabal-version: >= 1.2 author: Hans Hoglund maintainer: Hans Hoglund @@ -14,7 +14,7 @@ description: Abstract representation of musical pitch. - This library is part of the Haskell Music Suite, see . + This library is part of the Music Suite , see . library build-depends: @@ -23,11 +23,20 @@ time, random, semigroups, - semigroupoids + semigroupoids, + music-pitch-literal, + vector-space hs-source-dirs: src exposed-modules: Music.Pitch Music.Pitch.Absolute Music.Pitch.Relative + Music.Pitch.Relative.Accidental + Music.Pitch.Relative.Interval + Music.Pitch.Relative.Name + Music.Pitch.Relative.Number + Music.Pitch.Relative.Pitch + Music.Pitch.Relative.Quality + Music.Pitch.Relative.Semitones Music.Pitch.Intonation diff --git a/src/Music/Pitch.hs b/src/Music/Pitch.hs --- a/src/Music/Pitch.hs +++ b/src/Music/Pitch.hs @@ -13,13 +13,13 @@ -- ------------------------------------------------------------------------------------- -module Music.Pitch -- ( --- ) -where +module Music.Pitch ( + module Music.Pitch.Absolute, + module Music.Pitch.Relative, + module Music.Pitch.Literal + ) where -import Data.Maybe -import Data.Either -import Data.Semigroup -import Control.Monad -import Control.Applicative +import Music.Pitch.Absolute +import Music.Pitch.Relative +import Music.Pitch.Literal 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 @@ -12,13 +12,23 @@ -- Stability : experimental -- Portability : portable -- --- Provides overloaded pitch literals. +-- Absolute pitch representation. +-- +-- The canonical pitch representation is frequency in Hertz (Hz). For conversion, see +-- 'HasFrequency'. -- ------------------------------------------------------------------------------------- -module Music.Pitch.Absolute -- ( --- ) -where +module Music.Pitch.Absolute ( + Hertz(..), + -- Octaves, + Cents, + Fifths, + HasFrequency(..), + -- octaves, + fifths, + cents, + ) where import Data.Maybe import Data.Either @@ -26,73 +36,72 @@ import Control.Monad import Control.Applicative --- | Frequency in Hertz -newtype Frequency = Frequency { getFrequency :: Double } - deriving ( Show, Eq, Enum, Num, Ord, Fractional, Floating ) - +-- | +-- Absolute frequency in Hertz. +newtype Hertz = Hertz { getHertz :: Double } + deriving (Read, Show, Eq, Enum, Num, Ord, Fractional, Floating, Real, RealFrac) --- | Logarithmic pitch reprentation. +-- | +-- Number of pure octaves. -- --- > convert (f * 2) = convert f + Octaves 1 -newtype Octaves = Octaves { getOctaves :: Frequency } - deriving ( Show, Eq, Enum, Num, Ord, Fractional, Floating ) +-- 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) --- | Logarithmic pitch reprentation. +-- | +-- Number of pure octaves. -- --- > convert (f * 2) = convert f + Octave 1 -newtype Fifths = Fifths { getFifths :: Frequency } - deriving ( Show, Eq, Enum, Num, Ord, Fractional, Floating ) +-- 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) --- | Logarithmic pitch reprentation. +-- | +-- Number of pure fifths. -- --- > convert (f * 2) = convert f + Cent 1200 -newtype Cents = Cents { getCents :: Frequency } - deriving ( Show, Eq, Enum, Num, Ord, Fractional, Floating ) +-- 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) -class HasFrequence a where - frequency :: a -> Frequency --- instance Convert Frequency Octave where --- convert f = Octave (logBase 2 f) --- reconvert (Octave f) = 2 ** f --- --- instance Convert Cent Octave where --- convert (Cent f) = Octave (f / 1200) --- reconvert (Octave f) = Cent (f * 1200) --- --- instance Convert Frequency Cent where --- convert f = Cent (logBase 2 f * 1200) --- reconvert (Cent f) = 2 ** (f / 1200) --- --- instance Convert Octave Frequency where --- convert = reconvert --- reconvert = convert --- --- instance Convert Octave Cent where --- convert = reconvert --- reconvert = convert --- --- instance Convert Cent Frequency where --- convert = reconvert --- reconvert = convert - +instance Semigroup Hertz where (<>) = (*) +instance Semigroup Octaves where (<>) = (+) +instance Semigroup Fifths where (<>) = (+) +instance Semigroup Cents where (<>) = (+) -cents :: HasFrequence a => a -> Cents -cents = undefined +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 = (+) } -fifths :: HasFrequence a => a -> Fifths -fifths = undefined +class HasFrequency a where + frequency :: a -> Hertz -octaves :: HasFrequence a => a -> Octaves -octaves = undefined +instance HasFrequency Hertz where + frequency = id --- unitFrequency :: Frequency --- unitFrequency = 1 +instance HasFrequency Octaves where + frequency (Octaves f) = (2/1) ** f --- unitOctave :: Octave --- unitOctave = Octave 0 +instance HasFrequency Fifths where + frequency (Fifths f) = (3/2) ** f --- unitCent :: Cent --- unitCent = Cent 0 +instance HasFrequency Cents where + frequency (Cents f) = (2/1) ** (f / 1200) + +octaves :: HasFrequency a => a -> Octaves +octaves a = Octaves $ logBase (2/1) (frequency a) + +fifths :: HasFrequency a => a -> Fifths +fifths a = Fifths $ logBase (3/2) (frequency a) + +cents :: HasFrequency a => a -> Cents +cents a = Cents $ logBase (2/1) (frequency a) * 1200 + 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 @@ -22,4 +22,15 @@ import Data.Semigroup import Control.Monad import Control.Applicative +import Music.Pitch.Absolute +type Intonation a = a -> Hertz + +pure :: Integral a => Intonation a +pure = undefined + +pythagorean :: Integral a => Intonation a +pythagorean = undefined + +twelveToneEqual :: Integral a => Intonation a +twelveToneEqual = undefined diff --git a/src/Music/Pitch/Relative.hs b/src/Music/Pitch/Relative.hs --- a/src/Music/Pitch/Relative.hs +++ b/src/Music/Pitch/Relative.hs @@ -1,4 +1,13 @@ +{-# LANGUAGE + GeneralizedNewtypeDeriving, + FlexibleInstances, + DeriveFunctor, + TypeFamilies, + StandaloneDeriving, + OverloadedStrings, + DeriveFoldable #-} + ------------------------------------------------------------------------------------- -- | -- Copyright : (c) Hans Hoglund 2012 @@ -13,13 +22,161 @@ -- ------------------------------------------------------------------------------------- -module Music.Pitch.Relative -- ( --- ) +module Music.Pitch.Relative ( + module Music.Pitch.Relative.Accidental, + module Music.Pitch.Relative.Interval, + module Music.Pitch.Relative.Name, + module Music.Pitch.Relative.Number, + module Music.Pitch.Relative.Pitch, + module Music.Pitch.Relative.Quality, + module Music.Pitch.Relative.Semitones, +) 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 hiding (Octaves(..), octaves) +import Music.Pitch.Literal +import qualified Data.List as List +import Music.Pitch.Relative.Semitones +import Music.Pitch.Relative.Accidental +import Music.Pitch.Relative.Quality +import Music.Pitch.Relative.Name +import Music.Pitch.Relative.Number +import Music.Pitch.Relative.Pitch +import Music.Pitch.Relative.Interval + + +{- + Some terminology: + + newtype Pitch = (PitchClass, Semitones) + For example (E, Natural) + We write [c,cs,db..] for [(C, Natural), (C, Sharp), (D, Flat)..] + + newtype Interval = (Number, Semitones) + For example (Augmented, IV) + + Interval is the relative representation of pitch + + Pitch is an affine space with Interval as the difference type + c .+^ major third = e + major third ^+^ major third = augmentedFifth + + + Pitch addition and enhamonic equivalence: + + + + + Semitones is the smallest musical unit (Semitones in Western music) + + The `semitones` function retrieves the number of Semitones in a pitch, for example + semitones :: Interval -> Semitones + semitones major third = 4 + + Note that semitones is surjetive. We can define a non-deterministic function `intervals` + intervals :: Semitones -> [Interval] + intervals 4 = [majorThird, diminishedFourth] + Law + map semitones (intervals a) = replicate n a for all n > 0 + Lemma + map semitones (intervals a) + + + isHemitonic [1,2,2] = True + isHemitonic [2,2,2] = False + isCohemitonic [1,1,2] = True + isCohemitonic [1,2,1] = False + isTritonic ... + + A Scale is a [Semitones], for example [2,2,1,2,2,2,1] + From this we can derive [2,4,5,7,9,11,12] + A Scale is a function (Number -> Interval) + A Scale is a function (Number -> Semitones) + + Tonal + isConsonance :: Interval -> Bool + isPerfectConsonance :: Interval -> Bool + isImperfectConsonance :: Interval -> Bool + isDissonance :: Interval -> Bool + isDissonance :: Interval -> Bool + isHemitonic :: Interval -> Bool + isTritonic :: Interval -> Bool + + isSemitone :: Interval -> Bool + isSemitone :: Interval -> Bool + isLeap :: Interval -> Bool + isSimple :: Interval -> Bool + isCompound :: Interval -> Bool + + -- TODO simplify etc + isMelodicDissonance :: Interval -> Bool + + + "Post-tonal" + + Messiaen + + mode1 = [2,2,2,2,2] + mode2 = [1,2, 1,2, 1,2, 1,2] + mode3 = [2,1,1, 2,1,1, 2,1,1] + mode4 = [1,1,3,1, 1,1,3,1] + mode5 = [1,4,1, 1,4,1] + mode6 = [2,2,1,1, 2,2,1,1] + mode7 = [1,1,1,2,1, 1,1,1,2,1] + + +- Old stuff> + + + +-- Semitone is an enumerated associated type +type family Semitone a :: * +type family Alteration a :: * + +-- A scale is a function :: Semitone a -> a +newtype Scale a = Scale { getScale :: [Semitone a] } +-- Eq, Show + +semitone :: Scale a -> Semitone a -> a +semitone = undefined + + +semitone (Scale xs) p = xs !! (fromIntegral p `mod` length xs) + + +fromSemitone :: (Num a, Ord a, Integral b, Num c) => Scale a -> b -> c +fromSemitone (Scale xs) p = fromIntegral $ fromMaybe (length xs - 1) $ List.findIndex (>= fromIntegral p) xs + +scaleFromSemitones :: Num a => [a] -> Scale a +scaleFromSemitones = Scale . accum + where + accum = snd . List.mapAccumL add 0 + add a x = (a + x, a + x) + +-- numberOfSemitones :: Scale a -> Int +numberOfSemitones = length . getScale + +major :: Num a => Scale a +major = scaleFromSemitones [0,2,2,1,2,2,2,1] + +naturalMinor :: Num a => Scale a +naturalMinor = scaleFromSemitones [0,2,1,2,2,1,2,2] + +harmonicMinor :: Num a => Scale a +harmonicMinor = scaleFromSemitones [0,2,1,2,2,1,3,1] + +-} + + +-- or' :: (t -> Bool) -> (t -> Bool) -> t -> Bool +-- or' p q x = p x || q x + +-- replicate' n = replicate (fromIntegral n) diff --git a/src/Music/Pitch/Relative/Accidental.hs b/src/Music/Pitch/Relative/Accidental.hs new file mode 100644 --- /dev/null +++ b/src/Music/Pitch/Relative/Accidental.hs @@ -0,0 +1,72 @@ + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, FlexibleInstances #-} + +module Music.Pitch.Relative.Accidental ( + -- * Alterable class + Alterable(..), + + -- * Accidentals + Accidental, + doubleFlat, + flat, + natural, + sharp, + doubleSharp, + ) where + +import Music.Pitch.Literal + +-- | +-- Class of things that can be altered. +-- +class Alterable a where + -- | + -- Increase the given pitch by one. + -- + sharpen :: a -> a + + -- | + -- Decrease the given pitch by one. + -- + flatten :: a -> a + +newtype Accidental = Accidental { getAccidental :: Integer } + deriving (Eq, Ord, Num, Enum, Real, Integral) + +instance Show Accidental where + show n | n == 0 = "natural" + | n > 0 = replicate' n 's' + | n < 0 = replicate' (negate n) 'b' + +instance Alterable Accidental where + sharpen = succ + flatten = pred + +instance Alterable Double where + sharpen = (+ 1) + flatten = (subtract 1) + +instance Alterable Integer where + sharpen = (+ 1) + flatten = (subtract 1) + +instance (IsPitch a, Alterable a) => IsPitch (Accidental -> a) where + fromPitch l acc + | acc == sharp = sharpen (fromPitch l) + | acc == flat = flatten (fromPitch l) + +sharp, flat, natural, doubleFlat, doubleSharp :: Accidental +-- | The double sharp accidental. +doubleSharp = 2 +-- | The sharp accidental. +sharp = 1 +-- | The natural accidental. +natural = 0 +-- | The flat accidental. +flat = -1 +-- | The double flat accidental. +doubleFlat = -2 + + +replicate' n = replicate (fromIntegral n) + diff --git a/src/Music/Pitch/Relative/Interval.hs b/src/Music/Pitch/Relative/Interval.hs new file mode 100644 --- /dev/null +++ b/src/Music/Pitch/Relative/Interval.hs @@ -0,0 +1,380 @@ + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, TypeFamilies #-} + +module Music.Pitch.Relative.Interval ( + -- ** Intervals + Interval, + + -- *** Creating intervals + interval, + perfect, + major, + minor, + augmented, + diminished, + doublyAugmented, + doublyDiminished, + + -- *** Inspecting intervals + number, + -- isPerfectUnison, + isPositive, + isNegative, + + -- *** Simple and compound intervals + isSimple, + isCompound, + separate, + simple, + + -- *** Inversion + invert, + + + -- * Utility + -- ** Spelling + Spelling, + spell, + sharps, + flats, + + -- * Literals (TODO move) + d1, _P1, _A1, + d2, m2, _M2, _A2, + d3, m3, _M3, _A3, + d4, _P4, _A4, + d5, _P5, _A5, + d6, m6, _M6, _A6, + d7, m7, _M7, _A7, + d8, _P8, _A8, + + -- TODO + intervalDiff, + interval', + octave, + ) 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 hiding (Octaves(..), octaves) +import Music.Pitch.Literal +import qualified Data.List as List + +import Music.Pitch.Relative.Quality +import Music.Pitch.Relative.Semitones +import Music.Pitch.Relative.Number + +-- | +-- An interval is the difference between two pitches, incuding negative +-- intervals. +-- +-- Intervals and pitches can be added using '.+^'. 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 intervals are 'Integer', using '^*' to stack intervals +-- of a certain type on top of each other. For example @_P5 ^* 2@ is a stack +-- of 2 perfect fifths. The 'Num' instance works as expected for '+', 'negate' +-- and 'abs', and arbitrarily uses octaves 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, -- octaves, may be negative + Int, -- diatonic semitone [0..6] + Int -- chromatic semitone [0..11] + ) } + deriving (Eq, Ord) + +instance Num Interval where + (+) = addInterval + negate = negateInterval + abs a = if isNegative a then negate a else a + a * b = fromIntegral (semitones a `div` 12) `stackInterval` b + signum a = if isNegative a then (-_P8) else _P8 + fromInteger 0 = _P1 + fromInteger _ = undefined + +instance Show Interval where + show a | isNegative a = "-" ++ show (quality a) ++ show (abs $ number a) + | otherwise = show (quality a) ++ show (abs $ number a) + +instance Semigroup Interval where + (<>) = addInterval + +instance Monoid Interval where + mempty = perfect unison + mappend = addInterval + +instance AdditiveGroup Interval where + zeroV = perfect unison + (^+^) = addInterval + negateV = negateInterval + +instance VectorSpace Interval where + type Scalar Interval = Integer + (*^) = stackInterval + +instance HasQuality Interval where + quality (Interval (o, d, c)) + | o >= 0 = diffToQuality (isPerfectNumber d) (c - diatonicToChromatic d) + | otherwise = invertQuality $ diffToQuality (isPerfectNumber d) (c - diatonicToChromatic d) + +instance Augmentable Interval where + augment (Interval (o, d, c)) = Interval (o, d, c + 1) + diminish (Interval (o, d, c)) = Interval (o, d, c - 1) + +instance HasOctaves Interval where + octaves = fst . separate + +instance HasSemitones Interval where + semitones (Interval (o, d, c)) = fromIntegral $ o * 12 + c + +instance HasSteps Interval where + steps a = fromIntegral $ semitones a `mod` 12 + +intervalDiff :: Interval -> Int +intervalDiff (Interval (o, d, c)) = c - diatonicToChromatic d + +-- | +-- Creates an interval from a quality and number. +-- +-- If given 'Perfect' with an imperfect number (such as 3 or 7) a major interval is +-- returned. If given 'Major' or 'Minor' with a perfect number (such as 5), constructs +-- a perfect or diminished interval respectively. +-- +interval :: Quality -> Number -> Interval +interval quality number = interval' (qualityToDiff (isPerfectNumber diatonic) quality) (fromIntegral number) + where + (_, diatonic) = (fromIntegral $ number - 1) `divMod` 7 + +interval' :: Int -> Int -> Interval +interval' diff number = Interval (octave, diatonic, diatonicToChromatic diatonic + diff) + where + (octave, diatonic) = (number - 1) `divMod` 7 + + +-- | Creates a perfect interval. +-- If given an inperfect number, constructs a major interval. +perfect = interval Perfect +-- | Creates a major interval. +-- If given a perfect number, constructs a perfect interval. +major = interval Major +-- | Creates a minor interval. +-- If given a perfect number, constructs a diminished interval. +minor = interval Minor +-- | Creates an augmented interval. +augmented = interval (Augmented 1) +-- | Creates a diminished interval. +diminished = interval (Diminished 1) +-- | Creates a doubly augmented interval. +doublyAugmented = interval (Augmented 2) +-- | Creates a doubly diminished interval. +doublyDiminished = interval (Diminished 2) + + +invertDiatonic :: Num a => a -> a +invertDiatonic d = 7 - d + +invertChromatic :: Num a => a -> a +invertChromatic c = 12 - c + +negateInterval :: Interval -> Interval +negateInterval (Interval (o, 0, 0)) = Interval (negate o, 0, 0) +negateInterval (Interval (oa, da,ca)) = Interval (negate (oa + 1), invertDiatonic da, invertChromatic ca) + +addInterval :: Interval -> Interval -> Interval +addInterval (Interval (oa, da,ca)) (Interval (ob, db,cb)) + = Interval (oa + ob + carry, steps, chroma) + where + (carry, steps) = (da + db) `divMod` 7 + chroma = trunc (ca + cb) + trunc = if carry > 0 then (`mod` 12) else id + +stackInterval :: Integer -> Interval -> Interval +stackInterval n a | n >= 0 = mconcat $ replicate (fromIntegral n) a + | otherwise = negate $ stackInterval (negate n) a + +-- | +-- Separate a compound interval into octaves and a simple interval. +-- +-- > (perfect octave)^*x + y = z iff (x, y) = separate z +-- +separate :: Interval -> (Octaves, Interval) +separate (Interval (o, d, c)) = (fromIntegral o, Interval (0, d, c)) + +-- | +-- Returns the simple part of an interval. +-- +-- > (perfect octave)^*x + y = z iff y = simple z +-- +simple :: Interval -> Interval +simple = snd . separate + + +-- | +-- Returns the number portion of an interval. +-- +-- The interval number is negative if and only if the interval is negative. +-- +-- See also 'quality', 'octaves' and 'semitones'. +-- +number :: Interval -> Number +number (Interval (o, d, c)) = fromIntegral $ inc $ o * 7 + d + where + inc a = if a >= 0 then succ a else pred a + + + +-- | +-- Returns whether the given interval is simple. +-- +-- A simple interval is an positive interval spanning less than one octave. +-- +isSimple :: Interval -> Bool +isSimple = (== 0) . octaves + +-- | +-- Returns whether the given interval is compound. +-- +-- A compound interval is either a negative interval, or a positive interval spanning +-- more than octave. +-- +isCompound :: Interval -> Bool +isCompound = (/= 0) . octaves + +isPerfectUnison :: Interval -> Bool +isPerfectUnison a = a == perfect unison + +-- | +-- Returns whether the given interval is positive. +-- +isPositive :: Interval -> Bool +isPositive (Interval (oa, _, _)) = oa > 0 + +-- | +-- Returns whether the given interval is negative. +-- +isNegative :: Interval -> Bool +isNegative (Interval (oa, _, _)) = oa < 0 + + +-- | +-- Intervallic inversion. +-- +-- The inversion of a simple interval is determined by the following rules: +-- +-- * The interval number and the number of its inversion always add up to nine +-- (i.e. 4 + 5 = 9). +-- +-- * The inversion of a major interval is a minor interval, and vice versa; +-- the inversion of a perfect interval is also perfect; the inversion of an +-- augmented interval is a diminished interval, and vice versa; the +-- inversion of a doubly augmented interval is a doubly diminished interval, +-- and vice versa. +-- +-- The inversion of any compound interval is always the same as the inversion +-- of the simple interval from which it is compounded, i.e.: +-- +-- > invert = simple . negate +-- +invert :: Interval -> Interval +invert = simple . negate + + + +type Spelling = Semitones -> Number + +spell :: HasSemitones a => Spelling -> a -> Interval +spell z = (\s -> Interval (fromIntegral $ s `div` 12, fromIntegral $ z s, fromIntegral s)) . semitones + +isPerfectNumber :: Int -> Bool +isPerfectNumber 0 = True +isPerfectNumber 1 = False +isPerfectNumber 2 = False +isPerfectNumber 3 = True +isPerfectNumber 4 = True +isPerfectNumber 5 = False +isPerfectNumber 6 = False + +diatonicToChromatic :: Int -> Int +diatonicToChromatic = go + where + go 0 = 0 + go 1 = 2 + go 2 = 4 + go 3 = 5 + go 4 = 7 + go 5 = 9 + go 6 = 11 + +sharps :: Semitones -> Number +sharps = go + where + go 0 = 0 + go 1 = 0 + go 2 = 1 + go 3 = 1 + go 4 = 2 + go 5 = 3 + go 6 = 3 + go 7 = 4 + go 8 = 4 + go 9 = 5 + go 10 = 5 + go 11 = 6 + +flats :: Semitones -> Number +flats = go + where + go 0 = 0 + go 1 = 1 + go 2 = 1 + go 3 = 2 + go 4 = 2 + go 5 = 3 + go 6 = 4 + go 7 = 4 + go 8 = 5 + go 9 = 5 + go 10 = 6 + go 11 = 6 + + + + +_ = 1 ; d1 = Interval (0,0,-1) ; _P1 = Interval (0,0,0) ; _A1 = Interval (0,0,1) +d2 = Interval (0,1,0) ; m2 = Interval (0,1,1) ; _M2 = Interval (0,1,2) ; _A2 = Interval (0,1,3) +d3 = Interval (0,2,2) ; m3 = Interval (0,2,3) ; _M3 = Interval (0,2,4) ; _A3 = Interval (0,2,5) +_ = 1 ; d4 = Interval (0,3,4) ; _P4 = Interval (0,3,5) ; _A4 = Interval (0,3,6) +_ = 1 ; d5 = Interval (0,4,6) ; _P5 = Interval (0,4,7) ; _A5 = Interval (0,4,8) +d6 = Interval (0,5,7) ; m6 = Interval (0,5,8) ; _M6 = Interval (0,5,9) ; _A6 = Interval (0,5,10) +d7 = Interval (0,6,9) ; m7 = Interval (0,6,10) ; _M7 = Interval (0,6,11) ; _A7 = Interval (0,6,12) +_ = 1 ; d8 = Interval (1,0,-1) ; _P8 = Interval (1,0,0) ; _A8 = Interval (1,0,1) + +d9 = d2 + _P8 ; m9 = m2 + _P8 ; _M9 = _M2 + _P8 ; _A9 = _A2 + _P8 +d10 = d3 + _P8 ; m10 = m3 + _P8 ; _M10 = _M3 + _P8 ; _A10 = _A3 + _P8 + + + diff --git a/src/Music/Pitch/Relative/Name.hs b/src/Music/Pitch/Relative/Name.hs new file mode 100644 --- /dev/null +++ b/src/Music/Pitch/Relative/Name.hs @@ -0,0 +1,20 @@ + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} + +module Music.Pitch.Relative.Name ( + -- ** Name + Name(..), + ) where + +instance Show Name where + show C = "c" + show D = "d" + show E = "e" + show F = "f" + show G = "g" + show A = "a" + show B = "b" + +data Name = C | D | E | F | G | A | B + deriving (Eq, Ord, Enum) + diff --git a/src/Music/Pitch/Relative/Number.hs b/src/Music/Pitch/Relative/Number.hs new file mode 100644 --- /dev/null +++ b/src/Music/Pitch/Relative/Number.hs @@ -0,0 +1,56 @@ + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} + +module Music.Pitch.Relative.Number ( + -- ** Number + Number, + unison, + prime, + second, + third, + fourth, + fifth, + sixth, + seventh, + octave, + -- ninth, + -- tenth, + -- twelfth, + -- thirteenth, + -- fourteenth, + -- duodecim, + ) where + +-- | +-- 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 :: Integer } + deriving (Eq, Ord, Num, Enum, Real, Integral) + +instance Show Number where { show = show . getNumber } + +unison :: Number +prime :: Number +second :: Number +third :: Number +fourth :: Number +fifth :: Number +sixth :: Number +seventh :: Number +octave :: Number +unison = 1 +prime = 1 +second = 2 +third = 3 +fourth = 4 +fifth = 5 +sixth = 6 +seventh = 7 +octave = 8 + diff --git a/src/Music/Pitch/Relative/Pitch.hs b/src/Music/Pitch/Relative/Pitch.hs new file mode 100644 --- /dev/null +++ b/src/Music/Pitch/Relative/Pitch.hs @@ -0,0 +1,148 @@ + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, TypeFamilies #-} + +module Music.Pitch.Relative.Pitch ( + -- * Pitch + Pitch, + pitch, + name, + accidental, + asPitch, + ) 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 hiding (Octaves(..), octaves) +import Music.Pitch.Literal +import qualified Data.List as List + +import Music.Pitch.Relative.Interval +import Music.Pitch.Relative.Quality +import Music.Pitch.Relative.Accidental +import Music.Pitch.Relative.Semitones +import Music.Pitch.Relative.Name + +-- | +-- Standard pitch representation. +-- +-- Intervals and pitches can be added using '.+^'. To get the interval between +-- two pitches, use '.-.'. +-- +-- 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, Num, Ord) + +instance AffineSpace Pitch where + type Diff Pitch = Interval + Pitch a .-. Pitch b = a ^-^ b + Pitch a .+^ b = Pitch (a ^+^ b) + +instance Show Pitch where + show p = show (name p) ++ showAccidental (accidental p) ++ showOctave (octaves p) + where + showOctave n + | n > 0 = replicate' n '\'' + | otherwise = replicate' (negate n) '_' + showAccidental n + | n > 0 = replicate' n 's' + | otherwise = replicate' (negate n) 'b' + +instance Alterable Pitch where + sharpen (Pitch a) = Pitch (augment a) + flatten (Pitch a) = Pitch (diminish a) + +-- | +-- This is just the identity function, but is useful to fix the type of 'Pitch'. +-- +asPitch :: Pitch -> Pitch +asPitch = id + +-- | +-- Creates a pitch from name accidental. +-- +pitch :: Name -> Accidental -> Pitch +pitch = undefined + +-- | +-- Returns the name of a pitch. +-- +-- See also 'octaves', and 'steps' and 'semitones'. +-- +name :: Pitch -> Name +name = toEnum . fromIntegral . pred . number . simple . getPitch + +-- | +-- Returns the accidental of a pitch. +-- +-- See also 'octaves', and 'steps' and 'semitones'. +-- +accidental :: Pitch -> Accidental +accidental = fromIntegral . intervalDiff . simple . getPitch + +instance HasOctaves Pitch where + octaves = octaves . getPitch + +instance HasSemitones Pitch where + semitones = semitones . getPitch + +instance HasSteps Pitch where + steps = steps . getPitch + + +instance IsPitch Pitch where + fromPitch (PitchL (c, a, o)) = + Pitch $ interval' (qual a) (c + 1) + ^+^ + (perfect octave^* fromIntegral (o - 4)) + where + qual Nothing = 0 + qual (Just n) = round n + +midiNumber :: Pitch -> Integer +midiNumber = fromIntegral . semitones . getPitch + diff --git a/src/Music/Pitch/Relative/Quality.hs b/src/Music/Pitch/Relative/Quality.hs new file mode 100644 --- /dev/null +++ b/src/Music/Pitch/Relative/Quality.hs @@ -0,0 +1,156 @@ + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} + +module Music.Pitch.Relative.Quality ( + + -- * Augmentable class + Augmentable(..), + + -- * Quality + Quality(..), + HasQuality(..), + -- invertQuality, + isPerfect, + isMajor, + isMinor, + isAugmented, + isDiminished, + + -- TODO + diffToQuality, + qualityToDiff, + invertQuality, + replicate', + ) where + +-- | +-- Class of types that can be augmented. +-- +class Augmentable a where + + -- | + -- Increase the size of this interval by one. + -- + augment :: a -> a + + -- | + -- Decrease the size of this interval by one. + -- + diminish :: a -> a + +-- | +-- Interval quality is either perfect, major, minor, augmented, and +-- diminished. This representation allows for an arbitrary number of +-- augmentation or diminishions, 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 + | Augmented Integer + | Diminished Integer + deriving (Eq, Ord) + +instance Show Quality where + show Major = "_M" + show Minor = "m" + show Perfect = "_P" + show (Augmented n) = "_" ++ replicate' n 'A' + show (Diminished n) = replicate' n 'd' + +instance HasQuality Quality where + quality = id + +-- TODO this instance should not be used +-- instance Augmentable Quality where +-- augment = go +-- where +-- go (Diminished 0) = Augmented n -- not unique! +-- go (Diminished n) = Augmented n +-- go Minor = Major +-- go Major = Augmented 1 +-- go Perfect = Augmented 1 +-- go (Augmented n) = Diminished (n) + +class HasQuality a where + quality :: a -> Quality + +invertQuality :: Quality -> Quality +invertQuality = go + where + go Major = Minor + go Minor = Major + go Perfect = Perfect + go (Augmented n) = Diminished n + go (Diminished n) = Augmented n + + +-- | +-- Returns whether the given quality is perfect. +-- +isPerfect :: HasQuality a => a -> Bool +isPerfect a = case quality a of { Perfect -> True ; _ -> False } + +-- | +-- Returns whether the given quality is major. +-- +isMajor :: HasQuality a => a -> Bool +isMajor a = case quality a of { Major -> True ; _ -> False } + +-- | +-- Returns whether the given quality is minor. +-- +isMinor :: HasQuality a => a -> Bool +isMinor a = case quality a of { Minor -> True ; _ -> False } + +-- | +-- 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). +-- +isDiminished :: HasQuality a => a -> Bool +isDiminished a = case quality a of { Diminished _ -> True ; _ -> False } + +-- | +-- Convert an offset to a quality. +-- +-- This is different for perfect and imperfect interals: +-- +-- Imperfect Perfect +-- === === +-- -3 dd ddd +-- -2 d dd +-- -1 m d +-- 0 M P +-- 1 a a +-- 2 aa aa +-- +diffToQuality :: Bool -> Int -> Quality +diffToQuality = go + where + go True 0 = Perfect + go True n = if n > 0 then Augmented (fromIntegral n) else Diminished (fromIntegral $ negate n) + go False 0 = Major + go False (-1) = Minor + go False n = if n > 0 then Augmented (fromIntegral n) else Diminished (fromIntegral $ negate $ n + 1) + +qualityToDiff :: Bool -> Quality -> Int +qualityToDiff perfect = go + where + go (Diminished n) = fromIntegral $ negate $ if perfect then n else n + 1 + go Minor = fromIntegral $ -1 + go Perfect = fromIntegral $ 0 + go Major = fromIntegral $ 0 + go (Augmented n) = fromIntegral $ n + + + +replicate' n = replicate (fromIntegral n) diff --git a/src/Music/Pitch/Relative/Semitones.hs b/src/Music/Pitch/Relative/Semitones.hs new file mode 100644 --- /dev/null +++ b/src/Music/Pitch/Relative/Semitones.hs @@ -0,0 +1,163 @@ + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} + +module Music.Pitch.Relative.Semitones ( + -- * Octaves + Octaves, + HasOctaves(..), + + -- * Steps + Steps, + HasSteps(..), + + -- * Semitones + Semitones, + HasSemitones(..), + semitone, + tone, + ditone, + tritone, + isSemitone, + isTone, + isTritone, + + -- ** 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) + +instance Show Octaves where { show = show . getOctaves } +instance HasOctaves Octaves where { octaves = id } + +-- | +-- Class of intervals that has a number of 'Octaves'. +-- +class HasOctaves a where + -- | + -- Returns the number of octaves spanned by an interval. + -- + -- The number of octaves is negative if and only if the interval is + -- negative. + -- + -- Examples: + -- + -- > octaves (perfect unison) = 0 + -- > octaves (d5 ^* 4) = 2 + -- > octaves (-_P8) = -1 + -- + octaves :: a -> Octaves + + +-- | +-- 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'. +-- +class HasSteps a where + -- | + -- The number of steps is always in the range /0 ≤ x < 12/. + -- + -- Examples: + -- + -- > octaves (perfect unison) = 0 + -- > octaves (d5 ^* 4) = 2 + -- > octaves (-m7) = -1 + -- + 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 as in: +-- +-- > spell sharps tritone == augmented fourth +-- > spell flats tritone == diminished fifth +-- +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 + + -- | + -- Returns the number of semitones spanned by an interval. + -- + -- The number of semitones is negative if and only if the interval is + -- negative. + -- + -- Examples: + -- + -- > semitones (perfect unison) = 0 + -- > semitones tritone = 6 + -- > semitones d5 = 6 + -- > semitones (-_P8) = -12 + -- + semitones :: a -> Semitones + + +semitone, tone, ditone, tritone :: Semitones + +-- | Precisely one semitone. +semitone = 1 +-- | Precisely one whole tone, or two semitones. +tone = 2 +-- | Precisely two whole tones, or four semitones. +ditone = 4 +-- | Precisely three whole tones, or six semitones. +tritone = 6 + +isTone, isSemitone, isTritone :: HasSemitones a => a -> Bool +-- | Returns true iff the given interval spans one semitone. +isSemitone = (== semitone) . abs . semitones +-- | Returns true iff the given interval spans one whole tone (two semitones). +isTone = (== tone) . abs . semitones +-- | Returns true iff the given interval spans three whole tones (six semitones). +isTritone = (== tritone) . abs . semitones + + +infix 4 =:= +infix 4 /:= + +-- | +-- Enharmonic equivalence. +-- +(=:=) :: HasSemitones a => a -> a -> Bool +a =:= b = semitones a == semitones b + +-- | +-- Enharmonic non-equivalence. +-- +(/:=) :: HasSemitones a => a -> a -> Bool +a /:= b = semitones a /= semitones b + +