diff --git a/COPYING b/COPYING --- a/COPYING +++ b/COPYING @@ -9,14 +9,14 @@ * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of the nor the + * Neither the name of the Music Suite nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 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.3.1 +version: 1.6 cabal-version: >= 1.10 author: Hans Hoglund maintainer: Hans Hoglund @@ -12,23 +12,29 @@ build-type: Simple description: - Abstract representation of musical pitch. - - This library is part of the Music Suite, see . + This package provides various representations of musical pitch. + . + Note that this package is independent of @music-score@ and vice versa. + This is a deliberate design choice: the user should be free to combine any + pitch representation with any time structure. Normally you will include + both packages through @music-preludes@. + . + This library is part of the Music Suite, see + . source-repository head type: git - location: git://github.com/hanshoglund/music-pitch.git + location: git://github.com/music-suite/music-pitch.git library build-depends: - base >= 4 && < 5, - unix, + base >= 4 && < 5, time, random, + containers, semigroups, semigroupoids, - music-pitch-literal, + music-pitch-literal == 1.6, vector-space hs-source-dirs: src @@ -36,12 +42,13 @@ 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.Alterable + Music.Pitch.Augmentable + Music.Pitch.Common + Music.Pitch.Common.Interval + Music.Pitch.Common.Pitch + Music.Pitch.Common.Semitones + Music.Pitch.Common.Spell + Music.Pitch.Common.Harmony Music.Pitch.Intonation + other-modules: diff --git a/src/Music/Pitch.hs b/src/Music/Pitch.hs --- a/src/Music/Pitch.hs +++ b/src/Music/Pitch.hs @@ -1,5 +1,5 @@ -------------------------------------------------------------------------------------- +------------------------------------------------------------------------------------ -- | -- Copyright : (c) Hans Hoglund 2012 -- @@ -7,19 +7,49 @@ -- -- Maintainer : hans@hanshoglund.se -- Stability : experimental --- Portability : portable +-- Portability : non-portable (TF,GNTD) -- --- Provides overloaded pitch literals. +-- The "music-pitch" package provides several pitch and interval types. -- +-- See 'Pitch' and 'Interval' for common +-- representations. If you want to use an alternative represention, import the relevant +-- submodule. +-- ------------------------------------------------------------------------------------- module Music.Pitch ( + -- * Prerequisites + module Data.Semigroup, + module Data.VectorSpace, + module Data.AffineSpace, + + -- * Pitch representation + + -- -- | Augmentation and diminishing, generalized to work on all interval types. + module Music.Pitch.Augmentable, + + -- -- | Alteration, sharps and flats, generalized to work on all pitch types. + module Music.Pitch.Alterable, + + -- -- | Frequency, cents and other absolute measurements of pitch. module Music.Pitch.Absolute, - module Music.Pitch.Relative, - module Music.Pitch.Literal + + -- -- | Pitch and intervals, as defined in Common Music Theory (CMT). + -- -- + -- -- Includes representation of common practice pitches and intervalssuch as /c sharp/, + -- -- /diminished second/ and so on. + module Music.Pitch.Common, + + -- * Pitch literals + module Music.Pitch.Literal, ) where +import Data.Semigroup +import Data.VectorSpace hiding (Sum, getSum) +import Data.AffineSpace + import Music.Pitch.Absolute -import Music.Pitch.Relative +import Music.Pitch.Augmentable +import Music.Pitch.Alterable +import Music.Pitch.Common 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 @@ -1,6 +1,5 @@ -{-# LANGUAGE - GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------------- -- | @@ -38,6 +37,7 @@ -- | -- Absolute frequency in Hertz. +-- newtype Hertz = Hertz { getHertz :: Double } deriving (Read, Show, Eq, Enum, Num, Ord, Fractional, Floating, Real, RealFrac) @@ -47,6 +47,7 @@ -- 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) @@ -56,6 +57,7 @@ -- 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) @@ -65,6 +67,7 @@ -- 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) diff --git a/src/Music/Pitch/Alterable.hs b/src/Music/Pitch/Alterable.hs new file mode 100644 --- /dev/null +++ b/src/Music/Pitch/Alterable.hs @@ -0,0 +1,56 @@ + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} + +------------------------------------------------------------------------------------ +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +------------------------------------------------------------------------------------- + +module Music.Pitch.Alterable ( + -- * Alterable class + Alterable(..), + ) where + +import Data.Ratio + +-- | +-- Class of things that can be altered. +-- +-- > accidental (sharpen a) = sharpen (accidental a) +-- > accidental (flatten a) = flatten (accidental a) +-- > sharpen . flatten = id +-- +class Alterable a where + -- | + -- Increase the given pitch by one. + -- + sharpen :: a -> a + + -- | + -- Decrease the given pitch by one. + -- + flatten :: a -> a + + +instance Alterable a => Alterable (b -> a) where + sharpen = fmap sharpen + flatten = fmap flatten + +instance Alterable Double where + sharpen = (+ 1) + flatten = (subtract 1) + +instance Alterable Integer where + sharpen = (+ 1) + flatten = (subtract 1) + +instance Integral a => Alterable (Ratio a) where + sharpen = (+ 1) + flatten = (subtract 1) diff --git a/src/Music/Pitch/Augmentable.hs b/src/Music/Pitch/Augmentable.hs new file mode 100644 --- /dev/null +++ b/src/Music/Pitch/Augmentable.hs @@ -0,0 +1,52 @@ + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} + +------------------------------------------------------------------------------------ +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +------------------------------------------------------------------------------------- + +module Music.Pitch.Augmentable ( + -- * Augmentable class + Augmentable(..), + ) where + +import Data.Ratio + +-- | +-- Class of types that can be augmented. +-- +-- > quality (augment a) = augment (quality a) +-- > quality (diminish a) = diminish (quality a) +-- > augment . diminish = id +-- +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 + +instance Augmentable Double where + augment = (+ 1) + diminish = (subtract 1) + +instance Augmentable Integer where + augment = (+ 1) + diminish = (subtract 1) + +instance Integral a => Augmentable (Ratio a) where + augment = (+ 1) + diminish = (subtract 1) diff --git a/src/Music/Pitch/Common.hs b/src/Music/Pitch/Common.hs new file mode 100644 --- /dev/null +++ b/src/Music/Pitch/Common.hs @@ -0,0 +1,250 @@ + +------------------------------------------------------------------------------------ +-- | +-- 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). +-- +------------------------------------------------------------------------------------- + +module Music.Pitch.Common ( + -- * Enharmonic representation + -- ** Octaves + Octaves, + HasOctaves(..), + + -- ** Steps + Steps, + HasSteps(..), + + -- ** Semitones + Semitones, + HasSemitones(..), + semitone, + tone, + ditone, + tritone, + isSemitone, + isTone, + isTritone, + + -- ** Enharmonic equivalence + (=:=), + (/:=), + + -- * Pitches + -- ** Name type + Name(..), + + -- ** Accidental type + Accidental, + doubleFlat, + flat, + natural, + sharp, + doubleSharp, + + -- *** Inspecting accidentals + isNatural, + isSharpened, + isFlattened, + isStandard, + + -- ** Pitch type + Pitch, + pitch, + name, + accidental, + asPitch, + + -- module Music.Pitch.Common.Name, + -- module Music.Pitch.Common.Accidental, + -- module Music.Pitch.Common.Pitch, + + -- * Intervals + -- ** Number type + Number, + HasNumber(..), + unison, + prime, + second, + third, + fourth, + fifth, + sixth, + seventh, + octave, + ninth, + tenth, + twelfth, + duodecim, + thirteenth, + fourteenth, + fifteenth, + + -- ** Quality type + Quality(..), + HasQuality(..), + invertQuality, + isPerfect, + isMajor, + isMinor, + isAugmented, + isDiminished, + + -- ** Interval type + Interval, + + -- *** Creating intervals + interval, + perfect, + major, + minor, + augmented, + diminished, + doublyAugmented, + doublyDiminished, + asInterval, + + -- *** Inspecting intervals + isNegative, + isPositive, + isNonNegative, + isPerfectUnison, + isStep, + isLeap, + + -- *** Simple and compound intervals + isSimple, + isCompound, + separate, + simple, + + -- *** Inversion + invert, + + -- module Music.Pitch.Common.Number, + -- module Music.Pitch.Common.Quality, + -- module Music.Pitch.Common.Interval, + + -- * Miscellaneous + module Music.Pitch.Common.Spell, + module Music.Pitch.Common.Harmony, +) +where + +import Data.Maybe +import Data.Either +import Data.Semigroup +import Data.VectorSpace +import Data.AffineSpace +import Control.Monad +import Control.Applicative +import qualified Data.List as List + +import Music.Pitch.Absolute +import Music.Pitch.Literal +import Music.Pitch.Common.Pitch +import Music.Pitch.Common.Interval +import Music.Pitch.Common.Semitones +import Music.Pitch.Common.Spell +import Music.Pitch.Common.Harmony + + +{- + 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 `spellings` + spellings :: Semitones -> [Interval] + spellings 4 = [majorThird, diminishedFourth] + Law + map semitones (spellings a) = replicate n a for all n > 0 + Lemma + map semitones (spellings 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) + + -- 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/Common/Harmony.hs b/src/Music/Pitch/Common/Harmony.hs new file mode 100644 --- /dev/null +++ b/src/Music/Pitch/Common/Harmony.hs @@ -0,0 +1,62 @@ + +module Music.Pitch.Common.Harmony ( + isDissonance, + isConsonance, + isPerfectConsonance, + isImperfectConsonance, + isMelodicDissonance, + isMelodicConsonance, + ) where + +import Music.Pitch.Common.Interval +import Music.Pitch.Literal + +import Data.Semigroup +import Data.Set (Set) +import qualified Data.Set as Set + +-- | Whether the given interval is a (harmonic) dissonance. +isDissonance :: Interval -> Bool +isDissonance x = case number (simple x) of + 2 -> True + 7 -> True + _ -> False + +-- | Whether the given interval is a (harmonic) consonance. +isConsonance :: Interval -> Bool +isConsonance x = isPerfectConsonance x || isImperfectConsonance x + +-- | Whether the given interval is a perfect (harmonic) consonance. +isPerfectConsonance :: Interval -> Bool +isPerfectConsonance x = case number (simple x) of + 1 -> True + 4 -> True + 5 -> True + _ -> False + +-- | Whether the given interval is an imperfect (harmonic) consonance. +isImperfectConsonance :: Interval -> Bool +isImperfectConsonance x = case number (simple x) of + 3 -> True + 6 -> True + _ -> False + +-- | Whether the given interval is a melodic dissonance. +isMelodicDissonance :: Interval -> Bool +isMelodicDissonance x = not $ isMelodicConsonance x + +-- | Whether an interval is melodic consonance. +isMelodicConsonance :: Interval -> Bool +isMelodicConsonance x = quality x `elem` [Perfect, Major, Minor] + +type Chord = Set Interval + +majorTriad, minorTriad :: Chord +majorTriad = Set.fromList [_P1, _M3, _P5] +minorTriad = Set.fromList [_P1, m3, _P5] + +min7, maj7 :: Chord -> Chord +min7 = (<> Set.fromList [m7]) +maj7 = (<> Set.fromList [_M7]) + + diff --git a/src/Music/Pitch/Common/Interval.hs b/src/Music/Pitch/Common/Interval.hs new file mode 100644 --- /dev/null +++ b/src/Music/Pitch/Common/Interval.hs @@ -0,0 +1,636 @@ + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, TypeFamilies, + NoMonomorphismRestriction, DeriveDataTypeable #-} + +------------------------------------------------------------------------------------ +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides standard intervals. +-- +------------------------------------------------------------------------------------- + +module Music.Pitch.Common.Interval ( + -- * Quality + Quality(..), + HasQuality(..), + invertQuality, + isPerfect, + isMajor, + isMinor, + isAugmented, + isDiminished, + + -- ** Number + Number, + HasNumber(..), + unison, + prime, + second, + third, + fourth, + fifth, + sixth, + seventh, + octave, + ninth, + tenth, + twelfth, + duodecim, + thirteenth, + fourteenth, + fifteenth, + + -- ** Intervals + Interval, + + -- *** Creating intervals + interval, + perfect, + major, + minor, + augmented, + diminished, + doublyAugmented, + doublyDiminished, + + -- *** Inspecting intervals + isNegative, + isPositive, + isNonNegative, + isPerfectUnison, + isStep, + isLeap, + + -- *** Simple and compound intervals + isSimple, + isCompound, + separate, + simple, + + -- *** Inversion + invert, + + -- * Utility + asInterval, + intervalDiff, + interval', + ) where + +import Data.Maybe +import Data.Either +import Data.Semigroup +import Data.VectorSpace +import Data.AffineSpace +import Data.Typeable +import Control.Monad +import Control.Applicative +import qualified Data.List as List + +import Music.Pitch.Absolute +import Music.Pitch.Augmentable +import Music.Pitch.Literal +import Music.Pitch.Common.Semitones + +-- | +-- 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, Show) + +instance HasQuality Quality where + quality = id + +-- There is no instance for (Augmentable Quality) as we can not distinguish +-- between m/M and P in cases like (augment $ Diminished 1) or +-- (diminish $ Augmented 1). + +-- instance Augmentable Quality where +-- augment = go +-- where +-- go (Diminished 0) = error "Diminished 0" +-- go (Diminished 1) = Minor -- Or perfect +-- go (Diminished n) = Diminished (n - 1) +-- +-- go Minor = Major +-- go Perfect = Augmented 1 +-- go Major = Augmented 1 +-- +-- go (Augmented 0) = error "Augmented 0" +-- go (Augmented n) = Augmented (n + 1) +-- diminish = go +-- where +-- go (Diminished 0) = error "Diminished 0" +-- go (Diminished n) = Diminished (n + 1) +-- +-- go Major = Minor +-- go Perfect = Diminished 1 +-- go Minor = Diminished 1 +-- +-- go (Augmented 0) = error "Augmented 0" +-- go (Augmented 1) = Major -- or Perfect (?) +-- go (Augmented n) = Augmented (n - 1) + +class HasQuality a where + quality :: a -> Quality + +-- | +-- Invert a quality. +-- +-- Perfect is unaffected, major becomes minor and vice versa, augmented +-- becomes diminished and vice versa. +-- +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 + + +-- | +-- 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 } +instance HasNumber Number where number = id + +unison :: Number +prime :: Number +second :: Number +third :: Number +fourth :: Number +fifth :: Number +sixth :: Number +seventh :: Number +octave :: Number +ninth :: Number +tenth :: Number +eleventh :: Number +twelfth :: Number +duodecim :: Number +thirteenth :: Number +fourteenth :: Number +fifteenth :: Number + +-- | A synonym for @1@. +unison = 1 + +-- | A synonym for @2@. +prime = 1 + +-- | A synonym for @3@. +second = 2 + +-- | A synonym for @4@. +third = 3 + +-- | A synonym for @5@. +fourth = 4 + +-- | A synonym for @6@. +fifth = 5 + +-- | A synonym for @7@. +sixth = 6 + +-- | A synonym for @8@. +seventh = 7 + +-- | A synonym for @9@. +octave = 8 + +-- | A synonym for @10@. +ninth = 9 + +-- | A synonym for @11@. +tenth = 10 + +-- | A synonym for @12@. +eleventh = 11 + +-- | A synonym for @13@. +twelfth = 12 + +-- | A synonym for @14@. +duodecim = 12 + +-- | A synonym for @15@. +thirteenth = 13 + +-- | A synonym for @16@. +fourteenth = 14 + +-- | A synonym for @17@. +fifteenth = 15 + +class HasNumber a where + -- | + -- 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 :: a -> 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 'Interval' is '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, 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, -- octaves, may be negative + Int, -- diatonic remainder (positive) [0..6] + Int -- chromatic remainder (positive) [0..11] + ) } + deriving (Eq, Ord, Typeable) + +instance Num Interval where + (+) = addInterval + negate = negateInterval + abs a = if isNegative a then negate a else a + a * b = fromIntegral (semitones a) `stackInterval` b + signum a = if isNegative a then (-m2) else (if isPositive a then m2 else _P1) + fromInteger 0 = _P1 + + -- fromInteger n = n `stackInterval` m2 + fromInteger n = case fromInteger n `divMod` 12 of + (octave, chromatic) -> Interval (octave, sharpSpelling chromatic, chromatic) + where + -- Copied from Spellings (TODO factor out these) + sharpSpelling = 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 + +instance Show Interval where + show a | isNegative a = "-" ++ showQuality (quality a) ++ show (abs $ number a) + | otherwise = showQuality (quality a) ++ show (abs $ number a) + where + showQuality Major = "_M" + showQuality Minor = "m" + showQuality Perfect = "_P" + showQuality (Augmented n) = "_" ++ replicate' n 'A' + showQuality (Diminished n) = replicate' n 'd' + +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 HasNumber Interval where + number (Interval (o, d, c)) = fromIntegral $ inc $ o * 7 + d + where + inc a = if a >= 0 then succ a else pred a + +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 + +instance IsInterval Interval where + fromInterval (IntervalL (o,d,c)) = Interval (fromIntegral o, fromIntegral d, fromIntegral c) + +-- | +-- This is just the identity function, but is useful to fix the type of 'Interval'. +-- +asInterval :: Interval -> Interval +asInterval = id + +-- | +-- Creates an interval from a quality and number. +-- +-- Given 'Perfect' with an number not indicating a perfect consonant, 'interval' returns a +-- major interval instead. Given 'Major' or 'Minor' with a number indicating a perfect +-- consonance, 'interval' returns 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 + +intervalDiff :: Interval -> Int +intervalDiff (Interval (o, d, c)) = c - diatonicToChromatic d + +-- | +-- 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 whether the given interval is simple. +-- +-- A simple interval is a non-negative interval spanning less than one octave. +-- +isSimple :: Interval -> Bool +isSimple x = octaves x == 0 + +-- | +-- 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 x = octaves x /= 0 + +-- | +-- Returns whether the given interval is negative. +-- +isNegative :: Interval -> Bool +isNegative x = octaves x < 0 + +-- | +-- Returns whether the given interval is positive. +-- +isPositive :: Interval -> Bool +isPositive x = octaves x >= 0 && not (isPerfectUnison x) + +-- | +-- Returns whether the given interval is non-negative. This implies that it is either positive or a perfect unison. +-- +isNonNegative :: Interval -> Bool +isNonNegative x = octaves x >= 0 + +-- | +-- Returns whether the given interval a perfect unison. +-- +isPerfectUnison :: Interval -> Bool +isPerfectUnison = (== perfect unison) + +-- | +-- Returns whether the given interval is a step (a second or smaller). +-- +-- Only diatonic 'number' is taken into account, so @_A2@ is considered +-- a step and @m3@ a leap, even though they have the same number of +-- semitones. +-- +isStep :: Interval -> Bool +isStep x = isSimple (abs x) && number (abs x) <= 2 + +-- | +-- Returns whether the given interval is a leap (larger than a second). +-- +-- Only the diatonic 'number' is taken into account, so @_A2@ is considered +-- a step and @m3@ a leap, even though they have the same number of +-- semitones. +-- +isLeap :: Interval -> Bool +isLeap x = isCompound (abs x) || number (abs x) > 2 + + +-- | +-- Intervallic inversion. +-- +-- The inversion an interval is determined as follows: +-- +-- * The number of a simple interval the difference of nine and the number of its inversion. +-- +-- * The quality of a simple interval is the inversion of the quality of its inversion. +-- +-- * The inversion of a compound interval is the inversion of its simple component. +-- +invert :: Interval -> Interval +invert = simple . negate + + + +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 + +{-# DEPRECATED intervalDiff "This should be hidden" #-} +{-# DEPRECATED interval' "This should be hidden "#-} + +replicate' n = replicate (fromIntegral n) diff --git a/src/Music/Pitch/Common/Pitch.hs b/src/Music/Pitch/Common/Pitch.hs new file mode 100644 --- /dev/null +++ b/src/Music/Pitch/Common/Pitch.hs @@ -0,0 +1,273 @@ + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, TypeFamilies, + FlexibleInstances, DeriveDataTypeable #-} + +------------------------------------------------------------------------------------ +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides a standard pitch representation. +-- +------------------------------------------------------------------------------------- + +module Music.Pitch.Common.Pitch ( + -- * Accidentals + Accidental, + doubleFlat, + flat, + natural, + sharp, + doubleSharp, + + -- ** Inspecting accidentals + isNatural, + isSharpened, + isFlattened, + isStandard, + + -- ** Name + Name(..), + + -- * Pitch + Pitch, + pitch, + name, + accidental, + asPitch, + middleC, + ) where + +import Data.Maybe +import Data.Either +import Data.Semigroup +import Data.VectorSpace +import Data.AffineSpace +import Data.Typeable +import Control.Monad +import Control.Applicative +import qualified Data.Char as Char +import qualified Data.List as List + +import Music.Pitch.Absolute +import Music.Pitch.Literal +import Music.Pitch.Alterable +import Music.Pitch.Augmentable +import Music.Pitch.Common.Interval +import Music.Pitch.Common.Semitones + +-- | +-- An accidental is either flat, natural or sharp. +-- +-- This representation allows for an arbitrary number of flats or sharps rather than just +-- single (the ♯ and ♭ symbols) and double (i.e. the /x/ and ♭♭ symbols). +-- +-- 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@. +-- Requires @FlexibleInstances@. +-- +instance (IsPitch a, Alterable a) => IsPitch (Accidental -> a) where + fromPitch l 1 = sharpen (fromPitch l) + fromPitch l (-1) = 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 + +isNatural, isSharpened, isFlattened :: Accidental -> Bool + +-- | Returns whether this is a natural accidental. +isNatural = (== 0) + +-- | Returns whether this is a sharp, double sharp etc. +isSharpened = (> 0) + +-- | Returns whether this is a flat, double flat etc. +isFlattened = (< 0) + + +-- | Returns whether this is a standard accidental, i.e. +-- either a double flat, flat, natural, sharp or doubl sharp. +isStandard :: Accidental -> Bool +isStandard a = abs a < 2 + + +-- | +-- 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, Num, Ord, Typeable) + +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 = showName (name p) ++ showAccidental (accidental p) ++ showOctave (octaves $ getPitch p) + where + showName = fmap Char.toLower . show + 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) + +instance Enum Pitch where + toEnum = (c .+^) . perfect . fromIntegral + fromEnum = fromIntegral . number . (.-. c) + +-- | +-- 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 name acc = Pitch $ interval' (fromIntegral acc) (fromEnum name + 1) + +-- | +-- Returns the name of a pitch. +-- +-- To convert a pitch to a numeric type, use 'octaves', 'steps' or 'semitones' +-- on the relevant interval type, for example: +-- +-- @ semitones (a' .-. 'middleC') @ +-- +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 + +-- | The same as 'c', but fixed to 'Pitch'. This is useful if you want +-- to treat 'Pitch' as an affine space around middle C, that is /C4/ in Scientific Pitch Notation. +middleC :: Pitch +middleC = c + +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 + +replicate' n = replicate (fromIntegral n) diff --git a/src/Music/Pitch/Common/Semitones.hs b/src/Music/Pitch/Common/Semitones.hs new file mode 100644 --- /dev/null +++ b/src/Music/Pitch/Common/Semitones.hs @@ -0,0 +1,190 @@ + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} + +------------------------------------------------------------------------------------ +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides semitone, octave and step representaiton of intervals. +-- +------------------------------------------------------------------------------------- + +module Music.Pitch.Common.Semitones ( + -- * Types + -- ** 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 + + diff --git a/src/Music/Pitch/Common/Spell.hs b/src/Music/Pitch/Common/Spell.hs new file mode 100644 --- /dev/null +++ b/src/Music/Pitch/Common/Spell.hs @@ -0,0 +1,173 @@ + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, TypeFamilies #-} + +------------------------------------------------------------------------------------ +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides pitch spellings. +-- +------------------------------------------------------------------------------------- + +module Music.Pitch.Common.Spell ( + -- ** Spelling + -- * About + -- $semitonesAndSpellings + + -- * Spelling type + Spelling, + spell, + spelledWith, + + -- ** Standard spellings + modal, + sharps, + flats, + ) where + +import Data.VectorSpace +import Data.AffineSpace + +import Music.Pitch.Absolute +import Music.Pitch.Literal +import Music.Pitch.Alterable +import Music.Pitch.Augmentable +import Music.Pitch.Common.Pitch +import Music.Pitch.Common.Interval +import Music.Pitch.Common.Semitones + +-- $semitonesAndSpellings +-- +-- TODO document better +-- +-- 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 `spellings` +-- +-- > spellings :: Semitones -> [Interval] +-- > spellings 4 = [majorThird, diminishedFourth] +-- +-- /Law/ +-- +-- > map semitones (spellings a) = replicate n a for all n > 0 +-- +-- /Lemma/ +-- +-- > map semitones (spellings a) + +-- |  +-- A spelling provide a way of notating a semitone interval such as 'tritone'. +-- +-- Examples: +-- +-- > spell sharps tritone == _A4 +-- > spell flats tritone == d5 +-- > spell modal tone == _M2 +-- +type Spelling = Semitones -> Number + + +-- | +-- Spell an interval using the given 'Spelling'. +-- +spell :: HasSemitones a => Spelling -> a -> Interval +spell spelling x = let + -- TODO use Steps etc to remove fromIntegral + (octaves, steps) = semitones x `divMod` 12 + num = fromIntegral (spelling steps) + diff = fromIntegral steps - fromIntegral (diatonicToChromatic num) + in interval' diff (num + 1) ^+^ _P8^*(fromIntegral octaves) + where + diatonicToChromatic = go + where + go 0 = 0 + go 1 = 2 + go 2 = 4 + go 3 = 5 + go 4 = 7 + go 5 = 9 + go 6 = 11 + +-- | +-- Flipped version of 'spell'. To be used infix, as in: +-- +-- > d5 `spelledWith` sharps +-- +spelledWith :: HasSemitones a => a -> Spelling -> Interval +spelledWith = flip spell + +-- | +-- Spell using the most the most common accidentals. Double sharps and flats are not +-- preserved. +-- +-- This spelling is particularly useful for modal music with C or F as tonic. +-- +-- > c cs d eb e f fs g gs a bb b +-- +modal :: Spelling +modal = go + where + go 0 = 0 + go 1 = 0 + go 2 = 1 + go 3 = 2 + go 4 = 2 + go 5 = 3 + go 6 = 3 + go 7 = 4 + go 8 = 4 + go 9 = 5 + go 10 = 6 + go 11 = 6 + +-- | +-- Spell using sharps. Double sharps and flats are not preserved. +-- +-- > c cs d ds e f fs g gs a as b +-- +sharps :: Spelling +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 + +-- | +-- Spell using flats. Double sharps and flats are not preserved. +-- +-- > c db d eb e f gb g ab a bb b +-- +flats :: Spelling +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 + 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 @@ -9,7 +9,7 @@ -- Stability : experimental -- Portability : portable -- --- Provides overloaded pitch literals. +-- Provides intonation. -- ------------------------------------------------------------------------------------- diff --git a/src/Music/Pitch/Relative.hs b/src/Music/Pitch/Relative.hs deleted file mode 100644 --- a/src/Music/Pitch/Relative.hs +++ /dev/null @@ -1,182 +0,0 @@ - -{-# LANGUAGE - GeneralizedNewtypeDeriving, - FlexibleInstances, - DeriveFunctor, - TypeFamilies, - StandaloneDeriving, - OverloadedStrings, - DeriveFoldable #-} - -------------------------------------------------------------------------------------- --- | --- Copyright : (c) Hans Hoglund 2012 --- --- License : BSD-style --- --- Maintainer : hans@hanshoglund.se --- Stability : experimental --- Portability : portable --- --- Provides overloaded pitch literals. --- -------------------------------------------------------------------------------------- - -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 deleted file mode 100644 --- a/src/Music/Pitch/Relative/Accidental.hs +++ /dev/null @@ -1,72 +0,0 @@ - -{-# 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 deleted file mode 100644 --- a/src/Music/Pitch/Relative/Interval.hs +++ /dev/null @@ -1,380 +0,0 @@ - -{-# 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 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, -- 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) `stackInterval` b - signum a = if isNegative a then (-m2) else (if isPositive a then m2 else _P1) - fromInteger 0 = _P1 - fromInteger n = spell sharps (fromIntegral n :: Semitones) - -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 - --- | --- 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 - -intervalDiff :: Interval -> Int -intervalDiff (Interval (o, d, c)) = c - diatonicToChromatic d - --- | --- 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 deleted file mode 100644 --- a/src/Music/Pitch/Relative/Name.hs +++ /dev/null @@ -1,20 +0,0 @@ - -{-# 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 deleted file mode 100644 --- a/src/Music/Pitch/Relative/Number.hs +++ /dev/null @@ -1,56 +0,0 @@ - -{-# 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 deleted file mode 100644 --- a/src/Music/Pitch/Relative/Pitch.hs +++ /dev/null @@ -1,152 +0,0 @@ - -{-# 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 '.-.'. --- --- 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, 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 $ getPitch 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 name acc = Pitch $ interval' (fromIntegral acc) (fromEnum name + 1) - --- | --- 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 deleted file mode 100644 --- a/src/Music/Pitch/Relative/Quality.hs +++ /dev/null @@ -1,156 +0,0 @@ - -{-# 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 deleted file mode 100644 --- a/src/Music/Pitch/Relative/Semitones.hs +++ /dev/null @@ -1,163 +0,0 @@ - -{-# 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 - -