module Music.Pitch.Relative.Interval (
Interval,
interval,
perfect,
major,
minor,
augmented,
diminished,
doublyAugmented,
doublyDiminished,
number,
isPositive,
isNegative,
isSimple,
isCompound,
separate,
simple,
invert,
Spelling,
spell,
sharps,
flats,
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,
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
newtype Interval = Interval { getInterval :: (
Int,
Int,
Int
) }
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
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
perfect = interval Perfect
major = interval Major
minor = interval Minor
augmented = interval (Augmented 1)
diminished = interval (Diminished 1)
doublyAugmented = interval (Augmented 2)
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 :: Interval -> (Octaves, Interval)
separate (Interval (o, d, c)) = (fromIntegral o, Interval (0, d, c))
simple :: Interval -> Interval
simple = snd . separate
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
isSimple :: Interval -> Bool
isSimple = (== 0) . octaves
isCompound :: Interval -> Bool
isCompound = (/= 0) . octaves
isPerfectUnison :: Interval -> Bool
isPerfectUnison a = a == perfect unison
isPositive :: Interval -> Bool
isPositive (Interval (oa, _, _)) = oa > 0
isNegative :: Interval -> Bool
isNegative (Interval (oa, _, _)) = oa < 0
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