HarmTrace-0.7: src/HarmTrace/Base/MusicRep.hs
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GADTs #-}
module HarmTrace.Base.MusicRep where
import Data.Maybe
import Data.List (elemIndex, intersperse, intercalate)
import Control.DeepSeq
import HarmTrace.HAnTree.Binary
import Generics.Instant.TH
import Data.Binary
--------------------------------------------------------------------------------
-- Representing musical information at the value level
--------------------------------------------------------------------------------
-- Keys (at the value level)
data Key = Key Root Mode deriving (Show, Eq)
data Mode = MinMode | MajMode deriving Eq
instance NFData Mode where
rnf MinMode = ()
rnf MajMode = ()
type ChordLabel = Chord Root
type ChordDegree = Chord ScaleDegree
-- the representation for a single tokenized chord
data Chord a = Chord { chordRoot :: a
, chordShorthand :: Shorthand
, chordAdditions :: [Addition]
, getLoc :: Int -- the index of the chord
, duration :: Int -- in the list of tokens
}
data Class = Class ClassType Shorthand
data ClassType = MajClass | MinClass | DomClass | DimClass deriving (Eq)
data Shorthand = -- Triad chords
Maj | Min | Dim | Aug
-- Seventh chords
| Maj7 | Min7 | Sev | Dim7 | HDim7 | MinMaj7
-- Sixth chords
| Maj6 | Min6
-- Extended chords
| Nin | Maj9 | Min9
-- Suspended chords
| Sus4
-- In some cases there is no chord a certain position
-- This is especially important for the chroma processing
| None
deriving (Show, Eq, Enum, Bounded)
-- Key relative scale degrees to abstract from the absolute Root notes
type ScaleDegree = Note DiatonicDegree
data DiatonicDegree = I | II | III | IV | V | VI | VII | Imp
deriving (Show, Eq, Enum, Ord, Bounded)
-- Representing absolute root notes
type Root = Note DiatonicNatural
data DiatonicNatural = C | D | E | F | G | A | B | N -- N is for no root
deriving (Show, Eq, Enum, Ord, Bounded)
-- Intervals for additonal chord notes
type Addition = Note Interval
data Interval = I1 | I2 | I3 | I4 | I5 | I6 | I7 | I8 | I9 | I10
| I11 | I12 | I13
deriving (Eq, Enum, Ord, Bounded)
data Note a = Note (Maybe Modifier) a deriving (Eq)
data Modifier = Sh | Fl | SS | FF -- Sharp, flat, double sharp, double flat
deriving (Eq)
--------------------------------------------------------------------------------
-- Instances for the general music datatypes
--------------------------------------------------------------------------------
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 a) => Show (Chord a) where
show (Chord r sh deg loc d) = show r ++ ':' : show sh
++ (if not (null deg) then showAdds deg else "")
++ '_' : show loc ++ ':' : show d
showAdds :: Show a => [a] -> String
showAdds x = '(' : intercalate "," (map show x) ++ ")"
instance Show Class where show (Class ct _) = show ct
instance Show ClassType where
show (MajClass) = ""
show (MinClass) = "m"
show (DomClass) = "7"
show (DimClass) = "0"
instance (Show a) => Show (Note a) where
show (Note m interval) = show interval ++ maybe "" show m
instance Show Interval where
show a = show . ((!!) ([1..13]::[Integer]))
. fromJust $ elemIndex a [minBound..]
instance Show Modifier where
show Sh = "#"
show Fl = "b"
show SS = "##"
show FF = "bb"
-- for showing additional additions
showAdditions :: [Addition] -> String
showAdditions a
| null a = ""
| otherwise = "(" ++ concat (intersperse "," (map show a)) ++ ")"
--------------------------------------------------------------------------------
-- Utils
--------------------------------------------------------------------------------
toClassType :: Shorthand -> ClassType
toClassType sh
| sh `elem` [Maj,Maj7,Maj6,Maj9,MinMaj7,Sus4] = MajClass
| sh `elem` [Min,Min7,Min6,Min9,HDim7] = MinClass
| sh `elem` [Sev,Nin,Aug] = DomClass
| sh `elem` [Dim,Dim7] = DimClass
| otherwise = error ("toClassType: unknow shorthand: " ++ show sh)
--------------------------------------------------------------------------------
-- Value Level Scale Degree Transposition
--------------------------------------------------------------------------------
isNoneChord :: ChordLabel -> Bool
isNoneChord (Chord (Note _ N) _ _ _ _) = True
isNoneChord (Chord _ None _ _ _) = True
isNoneChord _ = False
-- Chord root shorthand degrees location duration
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 = -- Note Nothing I
scaleDegrees!!(((diaNatToSemi cr) - (diaNatToSemi kr)) `mod` 12)
-- transposes a degree with sem semitones up
transposeSem :: ScaleDegree -> Int -> ScaleDegree
transposeSem deg sem = scaleDegrees!!((sem + (diaDegToSemi deg)) `mod` 12) where
-- gives the semitone value [0,11] of a Degree, e.g. F# = 6
diaDegToSemi :: ScaleDegree -> Int
diaDegToSemi (Note m deg) =
([0,2,4,5,7,9,11] !! (fromJust $ elemIndex deg [minBound..])) + (modToSemi m)
diaNatToSemi :: Root -> Int
diaNatToSemi (Note m nat) =
([0,2,4,5,7,9,11] !! (fromJust $ elemIndex nat [minBound..])) + (modToSemi m)
-- transforms type-level modifiers to semitones (Int values)
modToSemi :: Maybe Modifier -> 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 Fl) II
, 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
]
--------------------------------------------------------------------------------
-- Binary instances
--------------------------------------------------------------------------------
deriveAllL [''Note, ''DiatonicDegree
, ''Mode, ''Chord, ''DiatonicNatural, ''ClassType
, ''Modifier, ''Shorthand, ''Interval]
instance (Binary a) => Binary (Note a) where
put = putDefault
get = getDefault
instance Binary DiatonicDegree where
put = putDefault
get = getDefault
instance Binary Mode where
put = putDefault
get = getDefault
instance (Binary a) => Binary (Chord a) where
put = putDefault
get = getDefault
instance Binary DiatonicNatural where
put = putDefault
get = getDefault
instance Binary ClassType where
put = putDefault
get = getDefault
instance Binary Modifier where
put = putDefault
get = getDefault
instance Binary Shorthand where
put = putDefault
get = getDefault
instance Binary Interval where
put = putDefault
get = getDefault