module Music.Diatonic.Scale (
Scale, Scl(..),
majorScale, minorScale, majorPentatonicScale, minorPentatonicScale, minorHarmonicScale, minorMelodicScale,
tetrachord
) where
import Music.Diatonic.Note
import Music.Diatonic.Interval
import Music.Diatonic.Quality
import Music.Diatonic.Degree
data Scale = Diatonic Quality Note
| Pentatonic Quality Note
| Harmonic Note
| Melodic Note
deriving (Eq)
class Scl a where
scale :: a -> Scale
instance Nte Scale where
noteMap f (Diatonic Major n) = majorScale . f $ n
noteMap f (Diatonic Minor n) = minorScale . f $ n
noteMap f (Pentatonic Major n) = majorPentatonicScale . f $ n
noteMap f (Pentatonic Minor n) = minorPentatonicScale . f $ n
noteMap f (Harmonic n) = minorHarmonicScale . f $ n
noteMap f (Melodic n) = minorMelodicScale . f $ n
instance Nts Scale where
notes (Diatonic Major n) = init $ tc1 ++ tc2
where tc1 = tetrachord n
tc2 = tetrachord (Maj2nd `above` last tc1)
notes (Diatonic Minor n) = zipWith ($) [id, id, lower, id, id, lower, lower] (notes . majorScale $ n)
notes (Pentatonic Major n) = concat . zipWith ($) [return, return, return, const [], return, return, const []] $ (notes . majorScale $ n)
notes (Pentatonic Minor n) = concat . zipWith ($) [return, const [], return, return, return, const [], return] $ (notes . minorScale $ n)
notes (Harmonic n) = zipWith ($) [id, id, id, id, id, id, raise] $ (notes . minorScale $ n)
notes (Melodic n) = zipWith ($) [id, id, id, id, id, raise, raise] $ (notes . minorScale $ n)
instance Qual Scale where
quality (Diatonic q _) = q
quality (Pentatonic q _) = q
quality (Harmonic _) = Minor
quality (Melodic _) = Minor
instance Show Scale where
show s@(Harmonic n) = (show n) ++ "m (harmonic)"
show s@(Melodic n) = (show n) ++ "m (melodic)"
show s@(Pentatonic q n) = (show n) ++ (if quality s == Minor then "m" else "") ++ " (pentatonic)"
show s@(Diatonic q n) = (show n) ++ (if quality s == Minor then "m" else "")
instance Deg Scale Note where
tonic (Diatonic q t) = t
tonic (Pentatonic q t) = t
tonic (Harmonic t) = t
tonic (Melodic t) = t
degrees s = map (\n -> (intervalDegree . distance (tonic s) $ n, n)) ns
where ns = notes s
degree s n = Just . intervalDegree . distance (tonic s) $ n
findDegree s d = Just . above (degreeInterval d) . tonic $ s
majorScale :: Note -> Scale
majorScale = Diatonic Major
minorScale :: Note -> Scale
minorScale = Diatonic Minor
majorPentatonicScale :: Note -> Scale
majorPentatonicScale = Pentatonic Major
minorPentatonicScale :: Note -> Scale
minorPentatonicScale = Pentatonic Minor
minorHarmonicScale :: Note -> Scale
minorHarmonicScale = Harmonic
minorMelodicScale :: Note -> Scale
minorMelodicScale = Melodic
tetrachord :: Note -> [Note]
tetrachord n = scanl (\n i -> i `above` n) n [Maj2nd, Maj2nd, Min2nd]