module Mezzo.Model.Rules.Classical
( ValidMelConcat
, ValidHarmConcat
, ValidHomConcat
, ValidPitch
, ValidMotion
) where
import Mezzo.Model.Types
import Mezzo.Model.Prim
import Mezzo.Model.Harmony
import Mezzo.Model.Errors
import GHC.TypeLits
import Data.Kind
class ValidMelInterval (e :: PitchPair) (i :: IntervalType)
instance PitchPairError "Major sevenths are not permitted in melody: " e
=> ValidMelInterval e (Interval Maj Seventh)
instance PitchPairError "Compound intervals are not permitted in melody: " e
=> ValidMelInterval e Compound
instance ValidMelInterval e i
class ValidMelLeap (p1 :: PitchType) (p2 :: PitchType)
instance ValidMelLeap Silence Silence
instance ValidMelLeap Silence (Pitch pc acc oct)
instance ValidMelLeap (Pitch pc acc oct) Silence
instance ValidMelInterval '(a, b) (MakeInterval a b) => ValidMelLeap a b
class ValidMelAppend (a :: Voice l1) (b :: Voice l2)
instance ValidMelAppend End a
instance ValidMelAppend a End
instance ValidMelLeap (Last vs1) (Head vs2) => ValidMelAppend vs1 vs2
class ValidMelConcat (ps1 :: Partiture n l1) (ps2 :: Partiture n l2)
instance ValidMelConcat None None
instance (ValidMelAppend v1 v2, ValidMelConcat vs1 vs2)
=> ValidMelConcat (v1 :-- vs1) (v2 :-- vs2)
class ValidHarmInterval (e :: PitchPair) (i :: IntervalType)
instance PitchPairError "Minor seconds are not permitted in harmony: " e
=> ValidHarmInterval e (Interval Aug Unison)
instance PitchPairError "Minor seconds are not permitted in harmony: " e
=> ValidHarmInterval e (Interval Min Second)
instance PitchPairError "Major sevenths are not permitted in harmony: " e
=> ValidHarmInterval e (Interval Maj Seventh)
instance PitchPairError "Major sevenths are not permitted in harmony: " e
=> ValidHarmInterval e (Interval Dim Octave)
instance PitchPairError "Augmented octaves are not permitted in harmony: " e
=> ValidHarmInterval e (Interval Aug Octave)
instance ValidHarmInterval e i
class ValidHarmDyad (p1 :: PitchType) (p2 :: PitchType)
instance ValidHarmDyad Silence Silence
instance ValidHarmDyad (Pitch pc acc oct) Silence
instance ValidHarmDyad Silence (Pitch pc acc oct)
instance ValidHarmInterval '(a, b) (MakeInterval a b) => ValidHarmDyad a b
class ValidHarmDyadsInVectors (v1 :: Voice l) (v2 :: Voice l)
instance AllPairsSatisfy ValidHarmDyad v1 v2 => ValidHarmDyadsInVectors v1 v2
class ValidHarmConcat (ps :: (Partiture n1 l, Partiture n2 l))
instance ValidHarmConcat '(None, vs)
instance ( ValidHarmConcat '(vs, us)
, AllSatisfyAll [ ValidHarmDyadsInVectors v
, ValidHarmMotionInVectors v] us)
=> ValidHarmConcat '((v :-- vs), us)
class ValidHomConcat (ps :: (Partiture n1 l, Partiture n2 l))
instance ValidHomConcat '(None, vs)
instance ( ValidHomConcat '(vs, us)
, AllSatisfyAll '[ValidHarmDyadsInVectors v] us)
=> ValidHomConcat '((v :-- vs), us)
type family ValidMotion (p1 :: PitchType) (p2 :: PitchType)
(q1 :: PitchType) (q2 :: PitchType)
:: Constraint where
ValidMotion Silence _ _ _ = Valid
ValidMotion _ Silence _ _ = Valid
ValidMotion _ _ Silence _ = Valid
ValidMotion _ _ _ Silence = Valid
ValidMotion p1 p2 q1 q2 =
If ((p1 .~. q1) .||. (p2 .~. q2))
(ObliqueMotion (MakeInterval p1 p2) (MakeInterval q1 q2))
(If (p1 <<? q1)
(If (p2 <<? q2)
(DirectMotion (DyPair p1 p2 q1 q2) (MakeInterval p1 p2) (MakeInterval q1 q2))
(ContraryMotion (MakeInterval p1 p2) (MakeInterval q1 q2)))
(If (p2 <<? q2)
(ContraryMotion (MakeInterval p1 p2) (MakeInterval q1 q2))
(DirectMotion (DyPair p1 p2 q1 q2) (MakeInterval p1 p2) (MakeInterval q1 q2))))
class ValidHarmMotionInVectors (v1 :: Voice l) (v2 :: Voice p)
instance ValidHarmMotionInVectors End End
instance ValidHarmMotionInVectors (p :* d1 :- End) (q :* d2 :- End)
instance ( ValidMotion p q (Head ps) (Head qs)
, ValidHarmMotionInVectors ps qs)
=> ValidHarmMotionInVectors (p :* d1 :- ps) (q :* d2 :- qs)
class ValidPitch (p :: PitchType)
instance PitchError "Note can't be lower than C natural of octave -1: " (Pitch C Flat Oct_1)
=> ValidPitch (Pitch C Flat Oct_1)
instance PitchError "Note can't be higher than B natural of octave 8: " (Pitch B Sharp Oct8)
=> ValidPitch (Pitch B Sharp Oct8)
instance ValidPitch p