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,
isNegative,
isPositive,
isNonNegative,
isPerfectUnison,
isStep,
isLeap,
isSimple,
isCompound,
separate,
simple,
octaves,
invert,
asInterval,
IntervalBasis(..),
convertBasis,
convertBasisFloat,
intervalDiv,
basis_P1,
basis_A1,
basis_d2,
basis_P8,
basis_P5,
intervalDiff,
mkInterval',
) where
import Data.Maybe
import Data.Either
import Data.Semigroup
import Data.VectorSpace
import Data.Basis
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 Int
| Diminished Int
deriving (Eq, Ord, Show)
instance HasQuality Quality where
quality = id
instance Augmentable Quality where
augment Major = Augmented 1
augment Minor = Major
augment Perfect = Augmented 1
augment (Augmented n) = Augmented (n + 1)
augment (Diminished n) = Diminished (n 1)
diminish Major = Minor
diminish Minor = Diminished 1
diminish Perfect = Diminished 1
diminish (Augmented n) = Augmented (n 1)
diminish (Diminished n) = Diminished (n + 1)
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 }
newtype Number = Number { getNumber :: Int }
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
) }
deriving (Eq, Ord, Typeable)
instance Num Interval where
(+) = addInterval
negate = negateInterval
abs a = if isNegative a then negate a else a
(*) = error "Music.Pitch.Common.Interval: no overloading for (*)"
signum = error "Music.Pitch.Common.Interval: no overloading for signum"
fromInteger = error "Music.Pitch.Common.Interval: no overloading for fromInteger"
instance Show Interval where
show a
| isNegative a = "-" ++ showQuality (extractQuality a) ++ show (abs $ extractNumber a)
| otherwise = showQuality (extractQuality a) ++ show (abs $ extractNumber 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
data IntervalBasis = Chromatic | Diatonic
deriving (Eq, Ord, Show, Enum)
instance HasBasis Interval where
type Basis Interval = IntervalBasis
basisValue Chromatic = basis_A1
basisValue Diatonic = basis_d2
decompose (Interval (c,d)) = [(Chromatic, fromIntegral c), (Diatonic, fromIntegral d)]
decompose' (Interval (c,d)) Chromatic = fromIntegral c
decompose' (Interval (c,d)) Diatonic = fromIntegral d
instance HasQuality Interval where
quality i = extractQuality i
instance HasNumber Interval where
number i = extractNumber i
instance Augmentable Interval where
augment i = i ^+^ basis_A1
diminish i = i ^-^ basis_A1
instance HasSemitones Interval where
semitones (Interval (a, d)) = fromIntegral a
instance IsInterval Interval where
fromInterval (IntervalL (o,d,c)) = (basis_P8^*o) ^+^ (basis_A1^*c) ^+^ (basis_d2^*d)
negateInterval :: Interval -> Interval
negateInterval (Interval (a, d)) = Interval (a, d)
addInterval :: Interval -> Interval -> Interval
addInterval (Interval (a1, d1)) (Interval (a2, d2)) = Interval (a1 + a2, d1 + d2)
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 (c, d)) = c diatonicToChromatic d
mkInterval'
:: Int
-> Int
-> Interval
mkInterval' diff diatonic = Interval (diatonicToChromatic diatonic + diff, diatonic)
basis_P1 = Interval (0, 0)
basis_A1 = Interval (1, 0)
basis_d2 = Interval (0, 1)
basis_P5 = Interval (7, 4)
basis_P8 = Interval (12, 7)
mkInterval :: Quality -> Number -> Interval
mkInterval Perfect 1 = basis_P1
mkInterval (Augmented 1) 1 = basis_A1
mkInterval (Diminished 1) 2 = basis_d2
mkInterval Minor 2 = basis_d2 ^+^ basis_A1
mkInterval Major 2 = (mkInterval Minor 2) ^+^ basis_A1
mkInterval (Augmented 1) 2 = (mkInterval Major 2) ^+^ basis_A1
mkInterval (Diminished 1) 3 = (mkInterval Minor 3) ^-^ basis_A1
mkInterval Minor 3 = (mkInterval Major 2) ^+^ (mkInterval Minor 2)
mkInterval Major 3 = (mkInterval Major 2) ^+^ (mkInterval Major 2)
mkInterval (Augmented 1) 3 = (mkInterval Major 3) ^+^ basis_A1
mkInterval (Diminished 1) 4 = (mkInterval Perfect 4) ^-^ basis_A1
mkInterval Perfect 4 = (mkInterval Major 3) ^+^ (mkInterval Minor 2)
mkInterval (Augmented 1) 4 = (mkInterval Perfect 4) ^+^ basis_A1
mkInterval (Diminished 1) 5 = (mkInterval Perfect 5) ^-^ basis_A1
mkInterval Perfect 5 = (mkInterval Perfect 4) ^+^ (mkInterval Major 2)
mkInterval (Augmented 1) 5 = (mkInterval Perfect 5) ^+^ basis_A1
mkInterval (Diminished 1) 6 = (mkInterval Minor 6) ^-^ basis_A1
mkInterval Minor 6 = (mkInterval Perfect 5) ^+^ (mkInterval Minor 2)
mkInterval Major 6 = (mkInterval Perfect 5) ^+^ (mkInterval Major 2)
mkInterval (Augmented 1) 6 = (mkInterval Major 6) ^+^ basis_A1
mkInterval (Diminished 1) 7 = (mkInterval Minor 7) ^-^ basis_A1
mkInterval Minor 7 = (mkInterval Major 6) ^+^ (mkInterval Minor 2)
mkInterval Major 7 = (mkInterval Major 6) ^+^ (mkInterval Major 2)
mkInterval (Augmented 1) 7 = (mkInterval Major 7) ^+^ basis_A1
mkInterval Minor 1 = error "invalid interval"
mkInterval Major 1 = error "invalid interval"
mkInterval Perfect 2 = error "invalid interval"
mkInterval Perfect 3 = error "invalid interval"
mkInterval Minor 4 = error "invalid interval"
mkInterval Major 4 = error "invalid interval"
mkInterval Minor 5 = error "invalid interval"
mkInterval Major 5 = error "invalid interval"
mkInterval Perfect 6 = error "invalid interval"
mkInterval Perfect 7 = error "invalid interval"
mkInterval (Diminished 0) n = error "(Diminished 0) is not a valid Quality"
mkInterval (Augmented 0) n = error "(Augmented 0) is not a valid Quality"
mkInterval (Diminished q) n = (mkInterval (Diminished (q 1)) n) ^-^ basis_A1
mkInterval (Augmented q) n = (mkInterval (Diminished (q 1)) n) ^+^ basis_A1
mkInterval q (Number n) = if n > 0
then (mkInterval q (Number (n 7))) ^+^ basis_P8
else (mkInterval q (Number (n + 7))) ^-^ basis_P8
extractNumber :: Interval -> Number
extractNumber (Interval (a, d))
| d >= 0 = Number (d + 1)
| otherwise = Number (d 1)
extractQuality :: Interval -> Quality
extractQuality (Interval (a, d))
| (a < 0) && (d == 0) = diminish (extractQuality (Interval ((a + 1), d)))
| (a, d) == (0, 0) = Perfect
| (a > 0) && (d == 0) = augment (extractQuality (Interval ((a 1), d)))
| (a < 1) && (d == 1) = diminish (extractQuality (Interval ((a + 1), d)))
| (a, d) == (1, 1) = Minor
| (a, d) == (2, 1) = Major
| (a > 2) && (d == 1) = augment (extractQuality (Interval ((a 1), d)))
| (a < 3) && (d == 2) = diminish (extractQuality (Interval ((a + 1), d)))
| (a, d) == (3, 2) = Minor
| (a, d) == (4, 2) = Major
| (a > 4) && (d == 2) = augment (extractQuality (Interval ((a 1), d)))
| (a < 5) && (d == 3) = diminish (extractQuality (Interval ((a + 1), d)))
| (a, d) == (5, 3) = Perfect
| (a > 5) && (d == 3) = augment (extractQuality (Interval ((a 1), d)))
| (a < 7) && (d == 4) = diminish (extractQuality (Interval ((a + 1), d)))
| (a, d) == (7, 4) = Perfect
| (a > 7) && (d == 4) = augment (extractQuality (Interval ((a 1), d)))
| (a < 8) && (d == 5) = diminish (extractQuality (Interval ((a + 1), d)))
| (a, d) == (8, 5) = Minor
| (a, d) == (9, 5) = Major
| (a > 9) && (d == 5) = augment (extractQuality (Interval ((a 1), d)))
| (a < 10) && (d == 6) = diminish (extractQuality (Interval ((a + 1), d)))
| (a, d) == (10, 6) = Minor
| (a, d) == (11, 6) = Major
| (a > 11) && (d == 6) = augment (extractQuality (Interval ((a 1), d)))
| (a < 12) && (d == 7) = diminish (extractQuality (Interval ((a + 1), d)))
| (a, d) == (12, 7) = Perfect
| (a > 12) && (d == 7) = augment (extractQuality (Interval ((a 1), d)))
| (a > 12) || (d > 7) = extractQuality (Interval ((a 12), (d 7)))
| (a < 0) || (d < 0) = extractQuality (Interval ((a), (d)))
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)
separate :: Interval -> (Octaves, Interval)
separate i = (fromIntegral o, i ^-^ (fromIntegral o *^ basis_P8))
where
o = octaves i
octaves :: Interval -> Octaves
octaves i
| isNegative i && not (isOctaveMultiple i) = negate (octaves' i) 1
| isNegative i && isOctaveMultiple i = negate (octaves' i)
| otherwise = octaves' i
isOctaveMultiple (Interval (_,d)) = d `mod` 7 == 0
octaves' i = fromIntegral $ intervalDiv i basis_P8
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 (Interval (a, d)) = d < 0
isPositive :: Interval -> Bool
isPositive x@(Interval (a, d)) = d >= 0 && not (isPerfectUnison x)
isNonNegative :: Interval -> Bool
isNonNegative (Interval (a, d)) = d >= 0
isPerfectUnison :: Interval -> Bool
isPerfectUnison = (== perfect unison)
isStep :: Interval -> Bool
isStep (Interval (a, d)) = (abs d) <= 2
isLeap :: Interval -> Bool
isLeap (Interval (a, d)) = (abs d) > 2
invert :: Interval -> Interval
invert = simple . negate
asInterval :: Interval -> Interval
asInterval = id
diatonicToChromatic :: Int -> Int
diatonicToChromatic d = (octaves*12) + go restDia
where
(octaves, restDia) = d `divMod` 7
go = ([0,2,4,5,7,9,11] !!)
replicate' n = replicate (fromIntegral n)
intervalDiv :: Interval -> Interval -> Int
intervalDiv (Interval (a, d)) (Interval (1, 0)) = a
intervalDiv (Interval (a, d)) (Interval (0, 1)) = d
intervalDiv i di
| (i > basis_P1) = intervalDivPos i di
| (i < basis_P1) = intervalDivNeg i di
| otherwise = 0 :: Int
where
intervalDivPos i di
| (i < basis_P1) = undefined
| (i ^-^ di) < basis_P1 = 0
| otherwise = 1 + (intervalDiv (i ^-^ di) di)
intervalDivNeg i di
| (i > basis_P1) = undefined
| (i ^+^ di) > basis_P1 = 0
| otherwise = 1 + (intervalDiv (i ^+^ di) di)
convertBasis
:: Interval
-> Interval
-> Interval
-> Maybe (Int, Int)
convertBasis i j k
| (p == 0) = Nothing
| not $ p `divides` r = Nothing
| not $ p `divides` q = Nothing
| otherwise = Just (r `div` p, q `div` p)
where Interval (m, n) = i
Interval (a, b) = j
Interval (c, d) = k
p = (a*d b*c)
q = (a*n b*m)
r = (d*m c*n)
convertBasisFloat :: (Fractional t, Eq t)
=> Interval
-> Interval
-> Interval
-> Maybe (t, t)
convertBasisFloat i j k
| (p == 0) = Nothing
| otherwise = Just (r / p, q / p)
where Interval (m, n) = i
Interval (a, b) = j
Interval (c, d) = k
p = fromIntegral $ (a*d b*c)
q = fromIntegral $ (a*n b*m)
r = fromIntegral $ (d*m c*n)
divides :: Integral a => a -> a -> Bool
x `divides` y = (y `rem` x) == 0