{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Grammar.TonalHarmony
( tonalHarmony
) where
import qualified Grammar.Harmony as H
import Grammar.Types
import Music
data Degree =
I | II | III | IV | V | VI | VII
| Piece | TR | DR | SR | TS | DS | SS
deriving (Eq, Show, Enum, Bounded)
(|~>) :: Head [a] -> (a -> Body meta a) -> [Rule meta a]
(xs, w, activ) |~> k = [(x, w, activ) :-> k x | x <- xs]
tonalHarmony :: Grammar H.Modulation Degree
tonalHarmony = Piece |:
[
(Piece, 1, always) :-> \t ->
foldr1 (:-:) $ replicate (t // (4 * wn)) $ TR:%:(4 * wn)
, (TR, 1, (> wn)) :-> \t -> TR:%:t/2 :-: DR:%:t/2
, (TR, 1, always) :-> \t -> DR:%:t/2 :-: TS:%:t/2
, (DR, 1, always) :-> \t -> SR:%:t/2 :-: DS:%:t/2
] ++
(([TR, SR, DR], 1, (> wn)) |~> \x t -> x:%:t/2 :-: x:%:t/2) ++
[
(TR, 1, always) :-> (TS :%:)
, (DR, 1, always) :-> (DS :%:)
, (SR, 1, always) :-> (SS :%:)
, (DS, 1, (>= qn)) :-> \t -> H.Modulation P5 $: DS:%:t
, (SS, 1, (>= qn)) :-> \t -> H.Modulation P4 $: SS:%:t
] ++
(([TS, DS, SS], 1, (>= hn)) |~> \x t -> (H.Modulation P5 $: x:%:t/2) :-: x:%:t/2) ++
[
(TS, 1, (>= wn)) :-> \t -> I:%:t/2 :-: IV:%:t/4 :-: I:%:t/4
, (TS, 1, always) :-> (I :%:)
, (SS, 1, always) :-> (IV :%:)
, (DS, 1, always) :-> (V :%:)
, (DS, 1, always) :-> (VI :%:)
]
instance Expand H.HarmonyConfig Degree H.Modulation SemiChord where
expand conf = expand conf . fmap ((toEnum :: Int -> H.Degree) . fromEnum)