{-# LANGUAGE TypeInType, GADTs, TypeOperators, TypeFamilies, UndecidableInstances, TypeApplications, ScopedTypeVariables, FlexibleInstances, StandaloneDeriving, ViewPatterns #-} {-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} ----------------------------------------------------------------------------- -- | -- Module : Mezzo.Model.Types -- Description : Mezzo music types -- Copyright : (c) Dima Szamozvancev -- License : MIT -- -- Maintainer : ds709@cam.ac.uk -- Stability : experimental -- Portability : portable -- -- Types modeling basic musical constructs at the type level. -- ----------------------------------------------------------------------------- module Mezzo.Model.Types ( -- * Note properties PitchClass (..) , Accidental (..) , OctaveNum (..) , Duration (..) -- ** Singleton types for note properties , PC (..) , Acc (..) , Oct (..) , Dur (..) -- * Pitches , PitchType (..) , Pit (..) , type (=?=) , type (<<=?) , type (< PC pc -- | The singleton type for 'Accidental'. data Acc (acc :: Accidental) where Acc :: Primitive acc => Acc acc -- | The singleton type for 'Octave'. data Oct (oct :: OctaveNum) where Oct :: Primitive oct => Oct oct -- | The singleton type for 'Duration'. data Dur (dur :: Duration) where Dur :: Primitive dur => Dur dur ------------------------------------------------------------------------------- -- Pitches -- Encapsulates the pitch class, accidental and octave of a note. ------------------------------------------------------------------------------- -- | The type of pitches. data PitchType where -- | A pitch made up of a pitch class, an accidental and an octave. Pitch :: PitchClass -> Accidental -> OctaveNum -> PitchType -- | Silence, the pitch of rests. Silence :: PitchType -- | The singleton type for pitches. data Pit (p :: PitchType) where Pit :: Primitive p => Pit p ------------------------------------------------------------------------------- -- Harmonic types ------------------------------------------------------------------------------- -- | The mode of a key: major or minor. data Mode = MajorMode | MinorMode -- | The seven scale degrees. data ScaleDegree = I | II | III | IV | V | VI | VII -- | The of a scale, chord or piece. data KeyType = Key PitchClass Accidental Mode -- | The root of a chord. data RootType where -- | A pitch constructs a diatonic root. PitchRoot :: PitchType -> RootType -- | A key and a scale degree constructs a scalar root. DegreeRoot :: KeyType -> ScaleDegree -> RootType -- | The singleton type for 'Mode'. data Mod (m :: Mode) = Mod -- | The singleton type for 'ScaleDegree' data ScaDeg (sd :: ScaleDegree) = ScaDeg -- | The singleton type for 'KeyType'. data KeyS (k :: KeyType) = KeyS -- | The singleton type for 'Root'. data Root (r :: RootType) where Root :: Primitive r => Root r -- | Convert a root to a pitch. -- -- Note: the default octave for scalar roots is 'Oct2'. type family RootToPitch (dr :: RootType) :: PitchType where RootToPitch (PitchRoot p) = p RootToPitch (DegreeRoot (Key pc acc m) d) = HalfStepsUpBy (Pitch pc acc Oct2) (DegreeOffset m d) -- | Calculate the semitone offset of a scale degree in a given mode. type family DegreeOffset (m :: Mode) (d :: ScaleDegree) where DegreeOffset MajorMode I = 0 DegreeOffset MajorMode II = 2 DegreeOffset MajorMode III = 4 DegreeOffset MajorMode IV = 5 DegreeOffset MajorMode V = 7 DegreeOffset MajorMode VI = 9 DegreeOffset MajorMode VII = 11 DegreeOffset MinorMode I = 0 DegreeOffset MinorMode II = 2 DegreeOffset MinorMode III = 3 DegreeOffset MinorMode IV = 5 DegreeOffset MinorMode V = 7 DegreeOffset MinorMode VI = 8 DegreeOffset MinorMode VII = 10 -- | Sharpen a root. type family Sharpen (r :: RootType) :: RootType where Sharpen r = PitchRoot (HalfStepUp (RootToPitch r)) -- | Flatten a root. type family Flatten (r :: RootType) :: RootType where Flatten r = PitchRoot (HalfStepDown (RootToPitch r)) -- | Halve a type-level natural. type family HalfOf (n :: Nat) :: Nat where HalfOf 0 = 0 HalfOf 1 = 0 HalfOf 8 = 4 HalfOf 32 = 16 HalfOf n = 1 + (HalfOf (n - 2)) -- | Form a dotted duration. type family Dot (d :: Duration) :: Duration where Dot 1 = TypeError (Text "Can't have dotted thirty-seconds.") Dot n = n + HalfOf n -- | Create a new partiture with one voice of the given pitch. type family FromRoot (r :: RootType) (d :: Nat) :: Partiture 1 d where FromRoot r d = ((RootToPitch r) +*+ d) :-- None -- | Create a new partiture with one voice of silence. type family FromSilence (d :: Nat) :: Partiture 1 d where FromSilence d = (Silence +*+ d) :-- None ------------------------------------------------------------------------------- -- Type specialisations ------------------------------------------------------------------------------- -- | A 'Voice' is made up of a sequence of pitch repetitions. type Voice l = OptVector PitchType l -- | A 'Partiture' is made up of a fixed number of voices. type Partiture n l = Matrix PitchType n l ------------------------------------------------------------------------------- -- Intervals ------------------------------------------------------------------------------- -- | The size of the interval. data IntervalSize = Unison | Second | Third | Fourth | Fifth | Sixth | Seventh | Octave -- | The class of the interval. data IntervalClass = Maj | Perf | Min | Aug | Dim -- | The type of intervals. data IntervalType where -- | An interval smaller than 13 semitones, where musical rules -- can still be enforced. Interval :: IntervalClass -> IntervalSize -> IntervalType -- | An interval larger than 13 semitones, which is large enough -- so that dissonance effects are not significant. Compound :: IntervalType ------------------------------------------------------------------------------- -- Interval construction ------------------------------------------------------------------------------- -- | Make an interval from two arbitrary pitches. type family MakeInterval (p1 :: PitchType) (p2 :: PitchType) :: IntervalType where MakeInterval Silence Silence = TypeError (Text "Can't make intervals from rests.") MakeInterval Silence p2 = TypeError (Text "Can't make intervals from rests.") MakeInterval p1 Silence = TypeError (Text "Can't make intervals from rests.") MakeInterval p1 p2 = If (p1 <<=? p2) (MakeIntervalOrd p1 p2) (MakeIntervalOrd p2 p1) -- | Make an interval from two ordered pitches. type family MakeIntervalOrd (p1 :: PitchType) (p2 :: PitchType) :: IntervalType where -- Handling base cases. MakeIntervalOrd p p = Interval Perf Unison MakeIntervalOrd (Pitch C Natural o) (Pitch C Sharp o) = Interval Aug Unison MakeIntervalOrd (Pitch C Natural o) (Pitch D Flat o) = Interval Min Second MakeIntervalOrd (Pitch C acc o) (Pitch D acc o) = Interval Maj Second MakeIntervalOrd (Pitch C acc o) (Pitch E acc o) = Interval Maj Third MakeIntervalOrd (Pitch C acc o) (Pitch F acc o) = Interval Perf Fourth MakeIntervalOrd (Pitch C acc o) (Pitch G acc o) = Interval Perf Fifth MakeIntervalOrd (Pitch C acc o) (Pitch A acc o) = Interval Maj Sixth MakeIntervalOrd (Pitch C acc o) (Pitch B acc o) = Interval Maj Seventh -- Handling perfect and augmented octaves. MakeIntervalOrd (Pitch C acc o1) (Pitch C acc o2) = If (OctSucc o1 .~. o2) (Interval Perf Octave) Compound MakeIntervalOrd (Pitch C Natural o1) (Pitch C Sharp o2) = If (OctSucc o1 .~. o2) (Interval Aug Octave) Compound MakeIntervalOrd (Pitch C Flat o1) (Pitch C Natural o2) = If (OctSucc o1 .~. o2) (Interval Aug Octave) Compound -- Handling accidental first pitch. MakeIntervalOrd (Pitch C Flat o) (Pitch pc2 acc o) = Expand (MakeIntervalOrd (Pitch C Natural o) (Pitch pc2 acc o)) MakeIntervalOrd (Pitch C Sharp o) (Pitch pc2 acc o) = Shrink (MakeIntervalOrd (Pitch C Natural o) (Pitch pc2 acc o)) -- Handling accidental second pitch. MakeIntervalOrd (Pitch C Natural o) (Pitch pc2 Sharp o) = Expand (MakeIntervalOrd (Pitch C Natural o) (Pitch pc2 Natural o)) MakeIntervalOrd (Pitch C Natural o) (Pitch pc2 Flat o) = Shrink (MakeIntervalOrd (Pitch C Natural o) (Pitch pc2 Natural o)) -- Handling the general case. MakeIntervalOrd (Pitch pc1 acc1 o1) (Pitch pc2 acc2 o2) = If (o1 .~. o2 .||. OctSucc o1 .~. o2) (MakeIntervalOrd (HalfStepDown (Pitch pc1 acc1 o1)) (HalfStepDown (Pitch pc2 acc2 o2))) Compound -- Handling erroneous construction (shouldn't happen). MakeIntervalOrd _ _ = TypeError (Text "Invalid interval.") -- | Shrink an interval. type family Shrink (i :: IntervalType) :: IntervalType where Shrink (Interval Perf Unison) = TypeError (Text "Can't diminish unisons.") Shrink (Interval Perf is) = Interval Dim is Shrink (Interval Min is) = Interval Dim is Shrink (Interval Maj is) = Interval Min is Shrink (Interval Aug Unison) = Interval Perf Unison Shrink (Interval Aug Fourth) = Interval Perf Fourth Shrink (Interval Aug Fifth) = Interval Perf Fifth Shrink (Interval Aug Octave) = Interval Perf Octave Shrink (Interval Aug is) = Interval Maj is Shrink (Interval Dim Unison) = TypeError (Text "Can't diminish unisons.") Shrink (Interval Dim Second) = TypeError (Text "Can't diminish unisons.") Shrink (Interval Dim Fifth) = Interval Perf Fourth Shrink (Interval Dim Sixth) = Interval Dim Fifth Shrink (Interval Dim is) = Interval Min (IntSizePred is) Shrink Compound = Compound -- | Expand an interval. type family Expand (i :: IntervalType) :: IntervalType where Expand (Interval Perf Octave) = Interval Aug Octave Expand (Interval Perf is) = Interval Aug is Expand (Interval Maj is) = Interval Aug is Expand (Interval Min is) = Interval Maj is Expand (Interval Dim Unison) = TypeError (Text "Can't diminish unisons.") Expand (Interval Dim Fourth) = Interval Perf Fourth Expand (Interval Dim Fifth) = Interval Perf Fifth Expand (Interval Dim Octave) = Interval Perf Octave Expand (Interval Dim is) = Interval Min is Expand (Interval Aug Third) = Interval Aug Fourth Expand (Interval Aug Fourth) = Interval Perf Fifth Expand (Interval Aug Seventh) = Interval Aug Octave Expand (Interval Aug Octave) = Compound Expand (Interval Aug is) = Interval Maj (IntSizeSucc is) Expand Compound = Compound ------------------------------------------------------------------------------- -- Enumerations and orderings -- Implementation of enumerators and ordering relations for applicable types. ------------------------------------------------------------------------------- -- | Convert a pitch to a natural number (equal to its MIDI code). type family PitchToNat (p :: PitchType) :: Nat where PitchToNat Silence = TypeError (Text "Can't convert a rest to a number.") PitchToNat (Pitch C Natural Oct_1) = 0 PitchToNat (Pitch C Sharp Oct_1) = 1 PitchToNat (Pitch D Flat Oct_1) = 1 PitchToNat (Pitch C Natural Oct1) = 24 PitchToNat (Pitch C Natural Oct2) = 36 PitchToNat (Pitch C Natural Oct3) = 48 PitchToNat (Pitch C Natural Oct4) = 60 PitchToNat (Pitch C Natural Oct5) = 72 PitchToNat (Pitch C Natural Oct6) = 84 PitchToNat p = 1 + PitchToNat (HalfStepDown p) -- | Convert a natural number to a suitable pitch. -- Not a functional relation, so usage is not recommended. type family NatToPitch (n :: Nat) where NatToPitch 0 = Pitch C Natural Oct_1 NatToPitch 1 = Pitch C Sharp Oct_1 NatToPitch n = HalfStepUp (NatToPitch (n - 1)) -- | Greater than or equal to for pitches. type family (p1 :: PitchType) <<=? (p2 :: PitchType) where p1 <<=? p2 = PitchToNat p1 <=? PitchToNat p2 -- | Greater than for pitches. type family (p1 :: PitchType) < Primitive (Pitch pc acc oct) where type Rep (Pitch pc acc oct) = Int prim p = prim (PC @pc) + prim (Acc @acc) + prim (Oct @oct) pretty p = pretty (PC @pc) ++ pretty (Acc @acc) ++ pretty (Oct @oct) instance Primitive Silence where type Rep Silence = Int ; prim s = 60 ; pretty s = "~~~~" instance IntRep p => Primitive (Root (PitchRoot p)) where type Rep (Root (PitchRoot p)) = Int prim r = prim (Pit @p) pretty r = pretty (Pit @p) -- Modes instance Primitive MajorMode where type Rep MajorMode = Bool ; prim m = True ; pretty m = "Major" instance Primitive MinorMode where type Rep MinorMode = Bool ; prim m = False ; pretty m = "minor" -- Scale degrees instance Primitive I where type Rep I = Int ; prim d = 0 ; pretty d = "I" instance Primitive II where type Rep II = Int ; prim d = 1 ; pretty d = "II" instance Primitive III where type Rep III = Int ; prim d = 2 ; pretty d = "III" instance Primitive IV where type Rep IV = Int ; prim d = 3 ; pretty d = "IV" instance Primitive V where type Rep V = Int ; prim d = 4 ; pretty d = "V" instance Primitive VI where type Rep VI = Int ; prim d = 5 ; pretty d = "VI" instance Primitive VII where type Rep VII = Int ; prim d = 6 ; pretty d = "VII" instance (IntRep pc, IntRep acc, IntRep mo) => Primitive (Key pc acc mo) where type Rep (Key pc acc mo) = Int prim k = 0 -- to be changed pretty k = pretty (PC @pc) ++ pretty (Acc @acc) ++ " " ++ pretty (Mod @mo) instance (IntRep p, RootToPitch (DegreeRoot k sd) ~ p, Primitive sd) => Primitive (Root (DegreeRoot k sd)) where type Rep (Root (DegreeRoot k sd)) = Int prim r = prim (Pit @p) pretty r = pretty (ScaDeg @sd) instance IntRep p => Primitive (PitchRoot p) where type Rep (PitchRoot p) = Int prim p = prim (Pit @p) pretty p = pretty (Pit @p) instance KnownNat n => Primitive n where type Rep n = Int prim = fromInteger . natVal pretty (natVal -> 1) = "Th" pretty (natVal -> 2) = "Si" pretty (natVal -> 3) = "Si." pretty (natVal -> 4) = "Ei" pretty (natVal -> 6) = "Ei." pretty (natVal -> 8) = "Qu" pretty (natVal -> 12) = "Qu." pretty (natVal -> 16) = "Ha" pretty (natVal -> 24) = "Ha." pretty (natVal -> 32) = "Wh" pretty (natVal -> 48) = "Wh." pretty (natVal -> n) = ":" ++ show n