module HarmTrace.Base.MusicRep (
PieceLabel (..)
, Note (..)
, Accidental (..)
, Root
, DiatonicNatural (..)
, ScaleDegree
, DiatonicDegree (..)
, Key (..)
, Mode (..)
, Chord (..)
, Shorthand (..)
, Addition (..)
, Interval (..)
, ChordLabel
, ChordDegree
, noneLabel
, unknownLabel
, ClassType (..)
, Triad (..)
, isNone
, isNoneChord
, isUnknown
, isRoot
, isAddition
, toClassType
, toTriad
, analyseDegTriad
, toDegreeList
, toMode
, toMajMin
, toMajMinChord
, simplifyRoot
, toChordDegree
, toScaleDegree
, transposeSem
, toSemitone
, toRoot
) where
import Data.Maybe (fromJust)
import Data.List (elemIndex, intercalate, (\\), partition)
import Data.Binary (Binary)
import GHC.Generics (Generic)
data Key = Key { keyRoot :: Root, keyMode :: Mode } deriving (Eq, Ord, Generic)
data Mode = MajMode | MinMode deriving (Eq, Ord, Generic)
data PieceLabel = PieceLabel Key [ChordLabel] deriving Generic
type ChordLabel = Chord Root
noneLabel :: ChordLabel
noneLabel = (Chord (Note Nothing N) None [] 0 1)
unknownLabel :: ChordLabel
unknownLabel = (Chord (Note Nothing X) None [] 0 1)
type ChordDegree = Chord ScaleDegree
data Chord a = Chord { chordRoot :: a
, chordShorthand :: Shorthand
, chordAdditions :: [Addition]
, getLoc :: Int
, duration :: Int
} deriving Generic
data ClassType = MajClass | MinClass | DomClass | DimClass | NoClass
deriving (Eq, Enum, Ord, Bounded, Generic)
data Shorthand =
Maj | Min | Dim | Aug
| Maj7 | Min7 | Sev | Dim7 | HDim7 | MinMaj7
| Maj6 | Min6
| Nin | Maj9 | Min9
| Sus4 | Sus2
| Five
| None
| Eleven | Thirteen | Min11 | Maj13 | Min13
deriving (Eq, Ord, Enum, Bounded, Generic)
type ScaleDegree = Note DiatonicDegree
data DiatonicDegree = I | II | III | IV | V | VI | VII
| Imp
deriving (Show, Eq, Enum, Ord, Bounded, Generic)
type Root = Note DiatonicNatural
data DiatonicNatural = C | D | E | F | G | A | B
| N
| X
deriving (Show, Eq, Enum, Ord, Bounded, Generic)
data Addition = Add (Note Interval)
| NoAdd (Note Interval) deriving (Eq, Ord, Generic)
data Interval = I1 | I2 | I3 | I4 | I5 | I6 | I7 | I8 | I9 | I10
| I11 | I12 | I13
deriving (Eq, Enum, Ord, Bounded, Generic)
data Note a = Note (Maybe Accidental) a deriving (Eq, Ord, Generic)
data Accidental = Sh
| Fl
| SS
| FF
deriving (Eq, Ord, Generic)
data Triad = MajTriad | MinTriad | AugTriad | DimTriad | NoTriad
deriving (Ord, Eq, Generic)
instance Show Key where
show (Key r m) = show r ++ show m
instance Show Mode where
show MajMode = ""
show MinMode = "m"
instance Eq a => Eq (Chord a) where
(Chord ra sha dega _loc _d) == (Chord rb shb degb _locb _db)
= ra == rb && sha == shb && dega == degb
instance Show ChordLabel where
show (Chord r None [] _loc _d) = show r ++ (if isRoot r then ":1" else "")
show (Chord r None add _loc _d) = show r ++ ':' : showAdd add
show (Chord r sh add _loc _d) = show r ++ ':' : show sh ++ showAdd add
instance Show ChordDegree where
show (Chord r None [] _loc _d) = show r ++ ":1"
show (Chord r None add _loc _d) = show r ++ ':' : showAdd add
show (Chord r sh add _loc _d) = show r ++ ':' : show sh ++ showAdd add
showAdd :: [Addition] -> String
showAdd [] = ""
showAdd x = '(' : intercalate "," (map show x) ++ ")"
instance Show Shorthand where
show Maj = "maj"
show Min = "min"
show Dim = "dim"
show Aug = "aug"
show Maj7 = "maj7"
show Min7 = "min7"
show Sev = "7"
show Dim7 = "dim7"
show HDim7 = "hdim7"
show MinMaj7 = "minmaj7"
show Maj6 = "maj6"
show Min6 = "min6"
show Maj9 = "maj9"
show Min9 = "min9"
show Min11 = "min11"
show Min13 = "min13"
show Maj13 = "maj13"
show Sus4 = "sus4"
show Sus2 = "sus2"
show Five = "5"
show Nin = "9"
show Eleven = "11"
show Thirteen = "13"
show None = ""
instance Show ClassType where
show MajClass = ""
show MinClass = "m"
show DomClass = "7"
show DimClass = "0"
show NoClass = "N"
instance Show (Note Interval) where
show (Note m i) = maybe "" show m ++ show i
instance Show (Note DiatonicNatural) where
show (Note m r) = show r ++ maybe "" show m
instance Show (Note DiatonicDegree) where
show (Note m r) = show r ++ maybe "" show m
instance Show Interval where
show a = show . ((!!) ([1..13]::[Integer]))
. fromJust $ elemIndex a [minBound..]
instance Show Accidental where
show Sh = "#"
show Fl = "b"
show SS = "##"
show FF = "bb"
instance Show Addition where
show (Add n) = show n
show (NoAdd n) = '*' : show n
instance Show Triad where
show MajTriad = "maj"
show MinTriad = "min"
show AugTriad = "aug"
show DimTriad = "dim"
show NoTriad = "NoTriad"
isRoot :: Root -> Bool
isRoot r | isNone r = False
| isUnknown r = False
| otherwise = True
isNone :: Root -> Bool
isNone (Note _ N) = True
isNone _ = False
isNoneChord :: ChordLabel -> Bool
isNoneChord = isNone . chordRoot
isUnknown :: Root -> Bool
isUnknown (Note _ X) = True
isUnknown _ = False
isAddition :: Addition -> Bool
isAddition (Add _) = True
isAddition (NoAdd _) = False
toClassType :: Chord a -> ClassType
toClassType (Chord _r sh [] _loc _d) = shToClassType sh
toClassType c = analyseDegClassType . toDegreeList $ c
analyseDegClassType :: [Addition] -> ClassType
analyseDegClassType degs =
case (analyseThird degs, analyseFifth degs, analyseSevth degs) of
(_ , _ , MinSev) -> DomClass
(_ , AugFifth , _ ) -> DomClass
(MajThird, DimFifth , _ ) -> DomClass
(MajThird, _ , _ ) -> MajClass
(MinThird, PerfFifth, _ ) -> MinClass
(MinThird, DimFifth , DimSev) -> DimClass
(MinThird, _ , _ ) -> MinClass
(NoThird, _ , _ ) -> NoClass
shToClassType :: Shorthand -> ClassType
shToClassType Maj = MajClass
shToClassType Min = MinClass
shToClassType Dim = DimClass
shToClassType Aug = DomClass
shToClassType Maj7 = MajClass
shToClassType Min7 = MinClass
shToClassType Sev = DomClass
shToClassType Dim7 = DimClass
shToClassType HDim7 = MinClass
shToClassType MinMaj7 = MinClass
shToClassType Maj6 = MajClass
shToClassType Min6 = MinClass
shToClassType Nin = DomClass
shToClassType Maj9 = MajClass
shToClassType Min9 = MinClass
shToClassType Five = NoClass
shToClassType Sus2 = NoClass
shToClassType Sus4 = NoClass
shToClassType None = NoClass
shToClassType Min11 = MinClass
shToClassType Eleven = DomClass
shToClassType Min13 = MinClass
shToClassType Maj13 = MajClass
shToClassType Thirteen = DomClass
data Third = MajThird | MinThird | NoThird deriving (Eq, Show)
data Fifth = DimFifth | PerfFifth | AugFifth | NoFifth deriving (Eq, Show)
data Sevth = DimSev | MinSev | MajSev | NoSev deriving (Eq, Show)
toTriad :: Chord a -> Triad
toTriad (Chord _r sh [] _loc _d) = shToTriad sh
toTriad c = analyseDegTriad . toDegreeList $ c
analyseDegTriad :: [Addition] -> Triad
analyseDegTriad degs =
case (analyseThird degs, analyseFifth degs) of
(MajThird, PerfFifth) -> MajTriad
(MajThird, AugFifth ) -> AugTriad
(MajThird, DimFifth ) -> NoTriad
(MinThird, PerfFifth) -> MinTriad
(MinThird, AugFifth ) -> NoTriad
(MinThird, DimFifth ) -> DimTriad
(NoThird, _ ) -> NoTriad
(_ , NoFifth ) -> NoTriad
analyseThird :: [Addition] -> Third
analyseThird d
| (Add (Note (Just Fl) I3)) `elem` d = MinThird
| (Add (Note Nothing I3)) `elem` d = MajThird
| otherwise = NoThird
analyseFifth :: [Addition] -> Fifth
analyseFifth d
| (Add (Note (Just Fl) I5)) `elem` d = DimFifth
| (Add (Note (Just Sh) I5)) `elem` d = AugFifth
| (Add (Note Nothing I5)) `elem` d = PerfFifth
| otherwise = NoFifth
analyseSevth :: [Addition] -> Sevth
analyseSevth d
| (Add (Note (Just FF) I7)) `elem` d = DimSev
| (Add (Note (Just Fl) I7)) `elem` d = MinSev
| (Add (Note Nothing I7)) `elem` d = MajSev
| otherwise = NoSev
shToTriad :: Shorthand -> Triad
shToTriad Maj = MajTriad
shToTriad Min = MinTriad
shToTriad Dim = DimTriad
shToTriad Aug = AugTriad
shToTriad Maj7 = MajTriad
shToTriad Min7 = MinTriad
shToTriad Sev = MajTriad
shToTriad Dim7 = MinTriad
shToTriad HDim7 = MinTriad
shToTriad MinMaj7 = MinTriad
shToTriad Maj6 = MajTriad
shToTriad Min6 = MinTriad
shToTriad Nin = MajTriad
shToTriad Maj9 = MajTriad
shToTriad Min9 = MinTriad
shToTriad Five = NoTriad
shToTriad Sus2 = NoTriad
shToTriad Sus4 = NoTriad
shToTriad None = NoTriad
shToTriad Min11 = MinTriad
shToTriad Eleven = MajTriad
shToTriad Min13 = MinTriad
shToTriad Maj13 = MajTriad
shToTriad Thirteen = MajTriad
toDegreeList :: Chord a -> [Addition]
toDegreeList (Chord _r sh [] _loc _d) = map Add (shToDeg sh)
toDegreeList (Chord _r sh deg _loc _d) = adds \\ (toAdds remv) where
(adds, remv) = partition isAddition ((map Add . shToDeg $ sh) ++ deg)
toAdds :: [Addition] -> [Addition]
toAdds = map (\(NoAdd x) -> (Add x))
shToDeg :: Shorthand -> [Note Interval]
shToDeg Maj = [Note Nothing I3, Note Nothing I5]
shToDeg Min = [Note (Just Fl) I3, Note Nothing I5]
shToDeg Dim = [Note (Just Fl) I3, Note (Just Fl) I5]
shToDeg Aug = [Note Nothing I3, Note (Just Sh) I5]
shToDeg Maj7 = shToDeg Maj ++ [Note Nothing I7]
shToDeg Min7 = shToDeg Min ++ [Note (Just Fl) I7]
shToDeg Sev = shToDeg Maj ++ [Note (Just Fl) I7]
shToDeg Dim7 = shToDeg Dim ++ [Note (Just FF) I7]
shToDeg HDim7 = shToDeg Dim ++ [Note (Just Fl) I7]
shToDeg MinMaj7 = shToDeg Min ++ [Note Nothing I7]
shToDeg Maj6 = shToDeg Maj ++ [Note Nothing I6]
shToDeg Min6 = shToDeg Min ++ [Note (Just Fl) I6]
shToDeg Nin = shToDeg Sev ++ [Note Nothing I9]
shToDeg Maj9 = shToDeg Maj7 ++ [Note Nothing I9]
shToDeg Min9 = shToDeg Min7 ++ [Note Nothing I9]
shToDeg Five = [Note Nothing I5]
shToDeg Sus2 = [Note Nothing I2, Note Nothing I5]
shToDeg Sus4 = [Note Nothing I4, Note Nothing I5]
shToDeg None = []
shToDeg Min11 = shToDeg Min9 ++ [Note Nothing I11]
shToDeg Eleven = shToDeg Nin ++ [Note Nothing I11]
shToDeg Min13 = shToDeg Min11 ++ [Note Nothing I13]
shToDeg Maj13 = shToDeg Maj9 ++ [Note Nothing I13]
shToDeg Thirteen = shToDeg Eleven ++ [Note Nothing I13]
toMode :: Triad -> Mode
toMode MajTriad = MajMode
toMode MinTriad = MinMode
toMode t = error ( "HarmTrace.Base.MusicRep.toMode: cannot convert "
++ " triad to mode: " ++ show t)
toMajMin :: Triad -> ClassType
toMajMin MajTriad = MajClass
toMajMin MinTriad = MinClass
toMajMin AugTriad = MajClass
toMajMin DimTriad = MinClass
toMajMin NoTriad = NoClass
toMajMinChord :: ChordLabel -> ChordLabel
toMajMinChord c = c {chordShorthand = majMinSh}
where majMinSh = case toMajMin (toTriad c) of
MajClass -> Maj
MinClass -> Min
NoClass -> None
_ -> error ("HarmTrace.Base.MusicRep.toMajMinChord"
++ " unexpected chord " ++ show c)
toChordDegree :: Key -> ChordLabel -> ChordDegree
toChordDegree k (Chord r sh degs loc d) =
Chord (toScaleDegree k r) sh degs loc d
toScaleDegree :: Key -> Root -> ScaleDegree
toScaleDegree _ n@(Note _ N) =
error ("HarmTrace.Base.MusicRep.toScaleDegree: cannot transpose " ++ show n)
toScaleDegree (Key kr _) cr =
scaleDegrees!!(((toSemitone cr) (toSemitone kr)) `mod` 12)
simplifyRoot :: Root -> Root
simplifyRoot (Note (Just SS) x) | x == E = Note (Just Sh) F
| x == B = Note (Just Sh) C
| otherwise = Note Nothing (succ x)
simplifyRoot (Note (Just FF) x) | x == F = Note (Just Fl) E
| x == C = Note (Just Fl) B
| otherwise = Note Nothing (pred x)
simplifyRoot (Note (Just Sh) D) = Note (Just Fl) E
simplifyRoot (Note (Just Sh) E) = Note Nothing F
simplifyRoot (Note (Just Sh) G) = Note (Just Fl) A
simplifyRoot (Note (Just Sh) A) = Note (Just Fl) B
simplifyRoot (Note (Just Sh) B) = Note Nothing C
simplifyRoot (Note (Just Fl) C) = Note Nothing B
simplifyRoot (Note (Just Fl) D) = Note (Just Sh) C
simplifyRoot (Note (Just Fl) F) = Note Nothing E
simplifyRoot (Note (Just Fl) G) = Note (Just Sh) F
simplifyRoot x = x
transposeSem :: ScaleDegree -> Int -> ScaleDegree
transposeSem deg sem = scaleDegrees!!((sem + (toSemitone deg)) `mod` 12) where
toSemitone :: (Show a, Enum a) => Note a -> Int
toSemitone (Note m p)
| ix <= 6 = noNegatives (([0,2,4,5,7,9,11] !! ix) + modToSemi m) `mod` 12
| otherwise = error ("HarmTrace.Base.MusicRep.toSemitone: no semitone for "
++ show p ++ maybe "" show m )
where ix = fromEnum p
noNegatives s | s < 0 = 12 + s
| otherwise = s
toRoot :: Int -> Root
toRoot i
| 0 <= i && i <= 11 = roots !! i
| otherwise = error ("HarmTrace.Base.MusicRep.toRoot " ++
"invalid semitone: " ++ show i)
modToSemi :: Maybe Accidental -> Int
modToSemi Nothing = 0
modToSemi (Just Sh) = 1
modToSemi (Just Fl) = 1
modToSemi (Just SS) = 2
modToSemi (Just FF) = 2
scaleDegrees ::[ ScaleDegree ]
scaleDegrees = [ Note Nothing I
, Note (Just Sh) I
, Note Nothing II
, Note (Just Fl) III
, Note Nothing III
, Note Nothing IV
, Note (Just Sh) IV
, Note Nothing V
, Note (Just Fl) VI
, Note Nothing VI
, Note (Just Fl) VII
, Note Nothing VII
]
roots :: [ Root ]
roots = [ Note Nothing C
, Note (Just Sh) C
, Note Nothing D
, Note (Just Fl) E
, Note Nothing E
, Note Nothing F
, Note (Just Sh) F
, Note Nothing G
, Note (Just Fl) A
, Note Nothing A
, Note (Just Fl) B
, Note Nothing B
]
instance Binary Key
instance Binary Mode
instance Binary PieceLabel
instance Binary a => Binary (Chord a)
instance Binary ClassType
instance Binary Shorthand
instance Binary DiatonicDegree
instance Binary DiatonicNatural
instance Binary Addition
instance Binary Interval
instance Binary a => Binary (Note a)
instance Binary Accidental
instance Binary Triad