module Music.Pitch.Common.Interval (
Quality(..),
HasQuality(..),
invertQuality,
isPerfect,
isMajor,
isMinor,
isAugmented,
isDiminished,
Number,
HasNumber(..),
unison,
prime,
second,
third,
fourth,
fifth,
sixth,
seventh,
octave,
ninth,
tenth,
twelfth,
duodecim,
thirteenth,
fourteenth,
fifteenth,
Interval,
mkInterval,
perfect,
major,
minor,
augmented,
diminished,
doublyAugmented,
doublyDiminished,
octaves,
isNegative,
isPositive,
isNonNegative,
isPerfectUnison,
isStep,
isLeap,
isSimple,
isCompound,
separate,
simple,
invert,
asInterval,
intervalDiff,
mkInterval',
) 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
data Quality
= Major
| Minor
| Perfect
| Augmented Integer
| Diminished Integer
deriving (Eq, Ord, Show)
instance HasQuality Quality where
quality = id
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
isPerfect :: HasQuality a => a -> Bool
isPerfect a = case quality a of { Perfect -> True ; _ -> False }
isMajor :: HasQuality a => a -> Bool
isMajor a = case quality a of { Major -> True ; _ -> False }
isMinor :: HasQuality a => a -> Bool
isMinor a = case quality a of { Minor -> True ; _ -> False }
isAugmented :: HasQuality a => a -> Bool
isAugmented a = case quality a of { Augmented _ -> True ; _ -> False }
isDiminished :: HasQuality a => a -> Bool
isDiminished a = case quality a of { Diminished _ -> True ; _ -> False }
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
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
unison = 1
prime :: Number
prime = 1
second :: Number
second = 2
third :: Number
third = 3
fourth :: Number
fourth = 4
fifth :: Number
fifth = 5
sixth :: Number
sixth = 6
seventh :: Number
seventh = 7
octave :: Number
octave = 8
ninth :: Number
ninth = 9
tenth :: Number
tenth = 10
eleventh :: Number
eleventh = 11
twelfth :: Number
twelfth = 12
duodecim :: Number
duodecim = 12
thirteenth :: Number
thirteenth = 13
fourteenth :: Number
fourteenth = 14
fifteenth :: Number
fifteenth = 15
class HasNumber a where
number :: a -> Number
newtype Interval = Interval { getInterval :: (
Int,
Int,
Int
) }
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 = case fromInteger n `divMod` 12 of
(octave, chromatic) -> Interval (octave, sharpSpelling chromatic, chromatic)
where
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)
octaves = fst . separate
instance HasSemitones Interval where
semitones (Interval (o, d, c)) = fromIntegral $ o * 12 + c
instance IsInterval Interval where
fromInterval (IntervalL (o,d,c)) = Interval (fromIntegral o, fromIntegral d, fromIntegral c)
asInterval :: Interval -> Interval
asInterval = id
mkInterval :: Quality -> Number -> Interval
mkInterval quality number = mkInterval' (qualityToDiff (isPerfectNumber diatonic) quality) (fromIntegral number)
where
(_, diatonic) = (fromIntegral $ number 1) `divMod` 7
mkInterval' :: Int -> Int -> Interval
mkInterval' diff number = Interval (octave, diatonic, diatonicToChromatic diatonic + diff)
where
(octave, diatonic) = (number 1) `divMod` 7
perfect :: Number -> Interval
perfect = mkInterval Perfect
major :: Number -> Interval
major = mkInterval Major
minor :: Number -> Interval
minor = mkInterval Minor
augmented :: Number -> Interval
augmented = mkInterval (Augmented 1)
diminished :: Number -> Interval
diminished = mkInterval (Diminished 1)
doublyAugmented :: Number -> Interval
doublyAugmented = mkInterval (Augmented 2)
doublyDiminished :: Number -> Interval
doublyDiminished = mkInterval (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 :: Interval -> (Octaves, Interval)
separate (Interval (o, d, c)) = (fromIntegral o, Interval (0, d, c))
simple :: Interval -> Interval
simple = snd . separate
isSimple :: Interval -> Bool
isSimple x = octaves x == 0
isCompound :: Interval -> Bool
isCompound x = octaves x /= 0
isNegative :: Interval -> Bool
isNegative x = octaves x < 0
isPositive :: Interval -> Bool
isPositive x = octaves x >= 0 && not (isPerfectUnison x)
isNonNegative :: Interval -> Bool
isNonNegative x = octaves x >= 0
isPerfectUnison :: Interval -> Bool
isPerfectUnison = (== perfect unison)
isStep :: Interval -> Bool
isStep x = isSimple (abs x) && number (abs x) <= 2
isLeap :: Interval -> Bool
isLeap x = isCompound (abs x) || number (abs x) > 2
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
replicate' n = replicate (fromIntegral n)