module Music.Pitch.Common.Interval (
Interval,
interval,
interval',
_number,
_quality,
_steps,
_alteration,
perfect,
major,
minor,
augmented,
diminished,
doublyAugmented,
doublyDiminished,
isNegative,
isPositive,
isNonNegative,
isPerfectUnison,
isStep,
isLeap,
isSimple,
isCompound,
separate,
simple,
octaves,
invert,
asInterval,
IntervalBasis(..),
convertBasis,
convertBasisFloat,
intervalDiv,
) where
import Data.Either
import Data.Maybe
import Data.Semigroup
import Data.VectorSpace
import Data.AffineSpace.Point (relative)
import Control.Applicative
import Control.Monad
import Control.Lens hiding (simple)
import Data.Basis
import qualified Data.List as List
import Data.Typeable
import Numeric.Positive
import Music.Pitch.Absolute
import Music.Pitch.Augmentable
import Music.Pitch.Common.Semitones
import Music.Pitch.Common.Quality
import Music.Pitch.Common.Number
import Music.Pitch.Common.Chromatic
import Music.Pitch.Common.Diatonic
import Music.Pitch.Literal
newtype Interval = Interval { getInterval :: (
Int,
Int
) }
deriving (Eq, Typeable)
instance Ord Interval where
Interval a `compare` Interval b = swap a `compare` swap b
where swap (x,y) = (y,x)
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 (fromIntegral n) 'A'
showQuality (Diminished n) = replicate (fromIntegral n) 'd'
instance Semigroup Interval where
(<>) = addInterval
instance Monoid Interval where
mempty = basis_P1
mappend = addInterval
instance AdditiveGroup Interval where
zeroV = basis_P1
(^+^) = 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)
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 (Interval (_,d)) = fromIntegral $ d `div` 7
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 (Interval (a, d)) = (a,d) == (0,0)
isStep :: Interval -> Bool
isStep (Interval (a, d)) = (abs d) <= 1
isLeap :: Interval -> Bool
isLeap (Interval (a, d)) = (abs d) > 1
invert :: Interval -> Interval
invert = simple . negate
asInterval :: Interval -> Interval
asInterval = id
mkInterval :: Quality -> Number -> Interval
mkInterval q n = mkInterval' (fromIntegral diff) (fromIntegral steps)
where
diff = qualityToDiff (n > 0) (expectedQualityType n) (q)
steps = case n `compare` 0 of
GT -> n 1
EQ -> error "diatonicSteps: Invalid number 0"
LT -> n + 1
_alteration :: Lens' Interval ChromaticSteps
_alteration = from interval' . _1
_steps :: Lens' Interval DiatonicSteps
_steps = from interval' . _2
_quality :: Lens' Interval Quality
_quality = from interval . _1
_number :: Lens' Interval Number
_number = from interval . _2
interval :: Iso' (Quality, Number) Interval
interval = iso (uncurry mkInterval) (\x -> (quality x, number x))
interval' :: Iso' (ChromaticSteps, DiatonicSteps) Interval
interval' = iso (\(d,s) -> mkInterval' (fromIntegral d) (fromIntegral s))
(\x -> (qualityToDiff (number x >= 0) (expectedQualityType (number x)) (quality x), (number x)^.diatonicSteps))
diatonicToChromatic :: Int -> Int
diatonicToChromatic d = (octaves*12) + go restDia
where
(octaves, restDia) = d `divMod` 7
go = ([0,2,4,5,7,9,11] !!)
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