HarmTrace-0.4: MIR/Instances.hs
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverlappingInstances #-}
-- {-# LANGUAGE IncoherentInstances #-} -- for ghc-6.12
{-# LANGUAGE GADTs #-}
module MIR.Instances where
-- Generics stuff
import Generics.Instant.TH
-- Parser stuff
import Text.ParserCombinators.UU
import Text.ParserCombinators.UU.BasicInstances.List ()
-- Diff
import MIR.Matching.GDiff
-- Music stuff
import MIR.HarmGram.ParserChord
import MIR.HarmGram.ShowChord
import MIR.HarmGram.MIR
import MIR.HarmGram.Tokenizer
import MIR.HarmGram.TypeLevel
-- Library modules
import Control.Monad (join)
import Data.List (intersperse)
import Data.Array
import Control.Arrow
import Data.Typeable
--------------------------------------------------------------------------------
-- The non-generic part of the parser
--------------------------------------------------------------------------------
-- Ad-hoc cases for Base_SD
instance ParseG (Base_SD deg clss Ze) where parseG = empty
instance ParseG (Base_Vmin deg clss Ze) where parseG = empty
instance ( ParseG (Base_SD (VDom deg) DomClass n)
, ParseG (Min5 deg clss n)
) => ParseG (Base_SD deg clss (Su n)) where
parseG = Base_SD <$> parseG
<|> Cons_Vdom <$> parseG <*> parseG
-- Ad-hoc cases for Base_Vmin
instance ( ParseG (Base_SD (VMin deg) MinClass n)
, ParseG (TritMinVSub deg DomClass)
) => ParseG (Base_Vmin deg DomClass (Su n)) where
parseG = Base_Vmin <$> parseG
<|> Cons_Vmin <$> parseG <*> parseG
instance ( ParseG (TritMinVSub deg clss)
) => ParseG (Base_Vmin deg clss (Su n)) where
parseG = Base_Vmin <$> parseG
-- Ad-hoc cases for Base_Final
instance ParseG (Base_Final deg clss Ze) where parseG = empty
instance ( ParseG (Final deg clss)
) => ParseG (Base_Final deg clss (Su n)) where
parseG = Base_Final <$> parseG
instance ( ToDegree deg
, ParseG (Final deg DomClass)
, ParseG (Base_Final (Tritone deg) DomClass n)
, ParseG (Base_Final (Tritone deg) DimClass n)
) => ParseG (Base_Final deg DomClass (Su n)) where
parseG = Base_Final <$> parseG
<|> Final_Tritone <$> parseG
<|> Final_Dim_Trit <$> parseG
where deg = toDegree (undefined :: deg)
-- for dim chors
instance ParseG (Surface_Chord deg clss Ze) where parseG = empty
instance ( ToDegree deg
, ParseG (Surface_Chord (MinThird deg) DimClass n)
) => ParseG (Surface_Chord deg DimClass (Su n)) where
parseG = Dim_Chord_Trns <$> parseG
<|> pChord deg DimClass
where deg = toDegree (undefined :: deg)
-- all chords
instance ( ToDegree deg, ToClass clss
) => ParseG (Surface_Chord deg clss (Su n)) where
parseG = pChord deg clss
where deg = toDegree (undefined :: deg)
clss = toClass (undefined :: clss)
pChord :: Degree -> ClassType -> PMusic (Surface_Chord deg clss (Su n))
pChord deg clss = transform <$>
pSym (recognize, "ChordDegree",
Chord deg (Just (head classes)) [] "inserted" 1) where
recognize (Chord deg' (Just shrt) _ _ _) = deg == deg' && shrt `elem` classes
recognize (Chord deg' Nothing _ _ _) = False -- deg == deg'
-- It seems that we can't use
-- deg == deg' above, as we get
-- "ambiguous parser?" for some
-- sequences, e.g.
-- C:6 Bb:9 A:7 D:9 G:maj C: G:7 C:6
classes = case clss of
MajClass -> [Maj,Maj7,Maj6,Maj9,MinMaj7,Sus4]
MinClass -> [Min,Min7,Min6,Min9,HDim7]
DomClass -> [Sev,Nin,Aug]
DimClass -> [Dim,Dim7]
transform (Chord d s _ o n) =
Surface_Chord d [(Class clss (maybe (head classes) id s),t) | t <- words o ]
--------------------------------------------------------------------------------
-- The non-generic part of the pretty-printer
--------------------------------------------------------------------------------
-- Ad-hoc cases for Base_SD
instance ShowChord (Base_SD deg clss Ze) where
showChord _ = error "showChord: impossible?"
instance ( ShowChord (Min5 deg clss n)
, ShowChord (Base_SD (VDom deg) DomClass n)
, ToDegree (Tritone deg) -- can this go?
) => ShowChord (Base_SD deg clss (Su n)) where
showChord (Base_SD s) = showChord s
showChord (Cons_Vdom s d) = relVPrint "V" s d 0
-- Ad-hoc cases for Base_Vmin
instance ShowChord (Base_Vmin deg clss Ze) where
showChord _ = error "showChord: impossible?"
instance ( ShowChord (Base_SD (VMin deg) MinClass n)
, ShowChord (TritMinVSub deg DomClass)
) => ShowChord (Base_Vmin deg clss (Su n)) where
showChord (Base_Vmin d) = showChord d
-- pattern match into the SD to see if we are our target degree
-- is tritone substituted, if so, we "tritone-unsubstitute"
showChord (Cons_Vmin s d@(Final_Tritone _)) = relVPrint "v" s d 1
showChord (Cons_Vmin s d@(Final_Dim_Trit _)) = relVPrint "v" s d 1
showChord (Cons_Vmin s d ) = relVPrint "v" s d 0
-- Ad-hoc cases for Base_Final
instance ShowChord (Base_Final deg clss Ze) where
showChord _ = error "showChord: impossible?"
instance ( GetDegree (Base_Final (Tritone deg) DomClass n)
, GetDegree (Base_Final (Tritone deg) DimClass n)
, ShowChord (Final deg clss)
, ShowChord (Base_Final (Tritone deg) DomClass n)
, ShowChord (Base_Final (Tritone deg) DimClass n)
) => ShowChord (Base_Final deg clss (Su n)) where
showChord (Base_Final d) = showChord d
-- The tritone substitution of a relative V is as alsway one semitone above
-- the chord it is preceding
showChord (Final_Tritone d) = transPrint "IIb7/" d 11
showChord (Final_Dim_Trit d) = transPrint "IIb7b9/" d 11
-- dim base case
instance ShowChord (Surface_Chord deg clss Ze) where
showChord _ = error "showChord: impossible?"
instance ( ShowChord (Surface_Chord deg clss n)
, ShowChord (Surface_Chord (MinThird deg) DimClass n)
, GetDegree (Surface_Chord (MinThird deg) DimClass n)
) => ShowChord (Surface_Chord deg clss (Su n)) where
showChord (Surface_Chord d rs) = foldr (.) id
[ paren (shows d . shows r . paren (showString s)) | (r,s) <- rs ]
showChord (Dim_Chord_Trns d) = paren $ toDegVal d 9 . showChar '0' . showChord d
--------------------------------------------------------------------------------
-- Value level computation for pretty printing
--------------------------------------------------------------------------------
-- prints a secondary dominance structure, i.e. X/Y where X and Y are scaledegrees
relVPrint :: (GetDegree a, ShowChord b, ShowChord a) =>
String -> b -> a -> Int -> ShowS
relVPrint prfx s d trans =
paren (showString prfx . showChar '/' . toDegVal d trans . showChord s)
. showChord d
-- paren (toDegVal d 7
-- . paren (showString prfx . showChar '/' . toDegVal d trans . showChord s))
-- . showChord d
-- prints a single scale degree transformation
transPrint :: (GetDegree a, ShowChord a) =>
String -> a -> Int -> ShowS
transPrint prfx d trans =
paren $ showString prfx. toDegVal d trans . showChord d
-- This function retuns a value level description of a degree using getDegree.
-- Certain visualizations demand an addiional scale degree tranposition. The
-- addTrans integer value can be used for that (use 0 for no transposition)
toDegVal :: (GetDegree a) => a -> Int -> ShowS
toDegVal deg addTrans = case getDeg deg of
(deg, trans) -> shows $ transposeSem deg (trans + addTrans)
-- Given a degree getDegee ensures that all information about the internal
-- structure of a scale degree, i.e. the degree and the an int value representing
-- the transposition of that degree at the current level, is available.
class GetDegree a where
getDeg :: a -> (Degree, Int)
instance GetDegree (Base_Vmin deg clss n) where
getDeg (Base_Vmin d) = getDeg d
getDeg (Cons_Vmin _ d) = second (+5) (getDeg d)
instance ( GetDegree (Base_Final deg clss Ze)) where
getDeg = error "getDegree: impossible?"
instance ( GetDegree (Final deg clss)
, GetDegree (Base_Final (Tritone deg) DomClass n)
, GetDegree (Base_Final (Tritone deg) DimClass n)
) => GetDegree (Base_Final deg clss (Su n)) where
getDeg (Base_Final d) = getDeg d
-- The tritone substitution of a relative V is as alsway one semitone above
-- the chord it is preceding
getDeg (Final_Tritone d) = second (+6) (getDeg d)
getDeg (Final_Dim_Trit d) = second (+6) (getDeg d)
instance ( GetDegree (Surface_Chord deg clss Ze)) where
getDeg = error "getDegree: impossible?"
instance ( GetDegree (Surface_Chord deg clss n)
, GetDegree (Surface_Chord (MinThird deg) DimClass n)
) => GetDegree (Surface_Chord deg clss (Su n)) where
getDeg (Surface_Chord d _) = (d,0)
getDeg (Dim_Chord_Trns d ) = second (+9) (getDeg d)
--------------------------------------------------------------------------------
-- Value Level Scale Degree Transposition
--------------------------------------------------------------------------------
-- transposes a degree with sem semitones
transposeSem :: Degree -> Int -> Degree
transposeSem deg sem = semiToDia!((sem + (diaToSemi deg)) `mod` 12)
-- gives the semitone value [0,11] of a Degree, e.g. F# = 6
diaToSemi :: Degree -> Int
diaToSemi (Degree m dia) = (diaToSemi'!dia) + (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
-- mapping diatonic intervals to semitones
diaToSemi' :: Array Interval Int
diaToSemi' = listArray (1,7) [0,2,4,5,7,9,11]
-- mapping semitones to diatonic Degrees
-- TODO: what about pitch spelling...?
semiToDia :: Array Int Degree
semiToDia = listArray (0,11)
[ Degree Nothing 1 -- 0 C
, Degree (Just Fl) 2 -- 1 Db
, Degree Nothing 2 -- 2 D
, Degree (Just Fl) 3 -- 3 Eb
, Degree Nothing 3 -- 4 E
, Degree Nothing 4 -- 5 F
, Degree (Just Sh) 4 -- 6 F#
, Degree Nothing 5 -- 7 G
, Degree (Just Fl) 6 -- 8 Ab
, Degree Nothing 6 -- 9 A
, Degree (Just Fl) 7 -- 10 Bb
, Degree Nothing 7 -- 11 B
]
--------------------------------------------------------------------------------
-- The non-generic part of the diff
--------------------------------------------------------------------------------
instance Children (Base_SD deg clss Ze) where children _ = []
instance ( GDiff (Base_SD (VDom deg) DomClass n)
, GDiff (Min5 deg clss n)
) => Children (Base_SD deg clss (Su n)) where
children (Base_SD x) = [Ex x]
children (Cons_Vdom x y) = [Ex x, Ex y]
instance Children (Base_Vmin deg clss Ze) where children _ = []
instance ({- -- for ghc-6.12
Typeable (MinThird (MinThird (MinThird (MinThird (Tritone deg))))),
Typeable (MinThird (MinThird (MinThird (Tritone deg)))),
Typeable (MinThird (MinThird (Tritone deg))),
Typeable (MinThird (Tritone deg)),
Typeable (Tritone (Tritone deg)),
Typeable (Tritone deg),
Typeable deg,
-}
GDiff (Base_SD (VMin deg) MinClass n)
, GDiff (TritMinVSub deg DomClass)
) => Children (Base_Vmin deg DomClass (Su n)) where
children (Base_Vmin x) = [Ex x]
children (Cons_Vmin x y) = [Ex x, Ex y]
instance ( Typeable deg, Typeable clss, GDiff (TritMinVSub deg clss)
) => Children (Base_Vmin deg clss (Su n)) where
children (Base_Vmin x) = [Ex x]
instance Children (Base_Final deg clss Ze) where children _ = []
instance ( GDiff (Base_Final (Tritone deg) DomClass n)
, GDiff (Base_Final (Tritone deg) DimClass n)
, GDiff (Final deg DomClass), Typeable deg
) => Children (Base_Final deg DomClass (Su n)) where
children (Base_Final x) = [Ex x]
children (Final_Tritone x) = [Ex x]
children (Final_Dim_Trit x) = [Ex x]
instance (Typeable deg, Typeable clss, GDiff (Final deg clss))
=> Children (Base_Final deg clss (Su n)) where
children (Base_Final x) = [Ex x]
instance Children (Surface_Chord deg clss Ze) where children _ = []
instance Children (Surface_Chord deg clss (Su n)) where
children (Surface_Chord d ((c,_):_)) = [Ex d, Ex c]
instance (GDiff (Surface_Chord (MinThird deg) DimClass n))
=> Children (Surface_Chord deg DimClass (Su n)) where
children (Surface_Chord d ((c,_):_)) = [Ex d, Ex c]
children (Dim_Chord_Trns x) = [Ex x]
--------------------------------------------------------------------------------
instance Build (Base_SD deg clss Ze) where build _ _ = Nothing
instance ( Typeable n, Typeable (VDom deg), Typeable deg, Typeable clss
, GDiff (Base_SD (VDom deg) DomClass n)
, GDiff (Min5 deg clss n)
) => Build (Base_SD deg clss (Su n)) where
build (Base_SD _) ((Ex x):r) = cast x >>= Just . (flip (,) r) . Base_SD
build (Cons_Vdom _ _) ((Ex x):(Ex y):r) = do x' <- cast x
y' <- cast y
Just (Cons_Vdom x' y', r)
build _ _ = Nothing
instance Build (Base_Vmin deg clss Ze) where build _ _ = Nothing
instance ( Typeable n, Typeable (VMin deg), Typeable deg
, GDiff (Base_SD (VMin deg) MinClass n)
, GDiff (TritMinVSub deg DomClass)
) => Build (Base_Vmin deg DomClass (Su n)) where
build (Base_Vmin _) ((Ex x):r) = cast x >>= Just . (flip (,) r) . Base_Vmin
build (Cons_Vmin _ _) ((Ex x):(Ex y):r) = do x' <- cast x
y' <- cast y
Just (Cons_Vmin x' y', r)
instance ( Typeable deg, Typeable clss, GDiff (TritMinVSub deg clss)
) => Build (Base_Vmin deg clss (Su n)) where
build (Base_Vmin _) ((Ex x):r) = cast x >>= Just . (flip (,) r) . Base_Vmin
instance Build (Base_Final deg clss Ze) where build _ _ = Nothing
instance ( Typeable n, Typeable (Tritone deg), Typeable deg
, GDiff (Base_Final (Tritone deg) DomClass n)
, GDiff (Base_Final (Tritone deg) DimClass n)
, GDiff (Final deg DomClass)
) => Build (Base_Final deg DomClass (Su n)) where
build (Base_Final _) ((Ex x):r) = cast x >>= Just . (flip (,) r) . Base_Final
build (Final_Tritone _) ((Ex x):r) = cast x >>= Just . (flip (,) r) . Final_Tritone
build (Final_Dim_Trit _) ((Ex x):r) = cast x >>= Just . (flip (,) r) . Final_Dim_Trit
instance (Typeable deg, Typeable clss)
=> Build (Base_Final deg clss (Su n)) where
build (Base_Final _) ((Ex x):r) = cast x >>= Just . (flip (,) r) . Base_Final
instance Build (Surface_Chord den clss Ze) where build _ _ = Nothing
instance Build (Surface_Chord den clss (Su n)) where
build (Surface_Chord _ ((_,s):r)) ((Ex x):(Ex y):rs) =
do x' <- cast x
y' <- cast y
Just (Surface_Chord x' ((y',s):r),rs)
instance (Typeable (MinThird den), Typeable n)
=> Build (Surface_Chord den DimClass (Su n)) where
build (Dim_Chord_Trns _) ((Ex x):r) = cast x >>= Just . (flip (,) r) . Dim_Chord_Trns
build (Surface_Chord _ ((_,s):r)) ((Ex x):(Ex y):rs) =
do x' <- cast x
y' <- cast y
Just (Surface_Chord x' ((y',s):r),rs)
--------------------------------------------------------------------------------
instance SEq (Base_SD deg clss Ze) where shallowEq _ _ = False -- ?
instance ( GDiff (Base_SD (VDom deg) DomClass n)
, GDiff (Min5 deg clss n)
) => SEq (Base_SD deg clss (Su n)) where
shallowEq (Base_SD _) (Base_SD _) = True
shallowEq (Cons_Vdom _ _) (Cons_Vdom _ _) = True
shallowEq _ _ = False
instance SEq (Base_Vmin deg clss Ze) where shallowEq _ _ = False
instance ( GDiff (Base_SD (VMin deg) MinClass n)
, GDiff (TritMinVSub deg DomClass)
) => SEq (Base_Vmin deg DomClass (Su n)) where
shallowEq (Base_Vmin _) (Base_Vmin _) = True
shallowEq (Cons_Vmin _ _) (Cons_Vmin _ _) = True
shallowEq _ _ = False
instance ( GDiff (TritMinVSub deg clss)
) => SEq (Base_Vmin deg clss (Su n)) where
shallowEq (Base_Vmin _) (Base_Vmin _) = True
shallowEq _ _ = False
instance SEq (Base_Final deg clss Ze) where shallowEq _ _ = False
instance ( GDiff (Base_Final (Tritone deg) DomClass n)
, GDiff (Base_Final (Tritone deg) DimClass n)
, GDiff (Final deg DomClass)
) => SEq (Base_Final deg DomClass (Su n)) where
shallowEq (Base_Final _) (Base_Final _) = True
shallowEq (Final_Tritone _) (Final_Tritone _) = True
shallowEq (Final_Dim_Trit _) (Final_Dim_Trit _) = True
shallowEq _ _ = False
instance (SEq (Final deg clss)) => SEq (Base_Final deg clss (Su n)) where
shallowEq (Base_Final _) (Base_Final _) = True
shallowEq _ _ = False
instance SEq (Surface_Chord deg clss Ze) where shallowEq _ _ = False
instance SEq (Surface_Chord deg clss (Su n)) where
shallowEq (Surface_Chord _ _) (Surface_Chord _ _) = True
shallowEq _ _ = False
instance SEq (Surface_Chord deg DimClass (Su n)) where
shallowEq (Dim_Chord_Trns _) (Dim_Chord_Trns _) = True
shallowEq (Surface_Chord _ _) (Surface_Chord _ _) = True
shallowEq _ _ = False
--------------------------------------------------------------------------------
instance (Typeable deg, Typeable clss) =>
GDiff (Base_SD deg clss Ze)
instance ( Typeable deg, Typeable clss, Typeable n, Typeable (VDom deg)
, GDiff (Base_SD (VDom deg) DomClass n)
, GDiff (Min5 deg clss n)
) => GDiff (Base_SD deg clss (Su n))
instance (Typeable deg, Typeable clss)
=> GDiff (Base_Vmin deg clss Ze)
instance ({- -- for ghc-6.12
Typeable (MinThird (MinThird (MinThird (MinThird (Tritone deg))))),
Typeable (MinThird (MinThird (MinThird (Tritone deg)))),
Typeable (MinThird (MinThird (Tritone deg))),
Typeable (MinThird (Tritone deg)),
Typeable (Tritone (Tritone deg)),
Typeable (Tritone deg),
-}
Typeable (VMin deg), Typeable deg, Typeable n
, GDiff (Base_SD (VMin deg) MinClass n)
, GDiff (TritMinVSub deg DomClass)
) => GDiff (Base_Vmin deg DomClass (Su n))
instance ( Typeable deg, Typeable clss, Typeable n
, GDiff (TritMinVSub deg clss)
) => GDiff (Base_Vmin deg clss (Su n))
instance (Typeable deg, Typeable clss)
=> GDiff (Base_Final deg clss Ze)
instance ( Typeable deg, Typeable n, Typeable (Tritone deg)
, GDiff (Base_Final (Tritone deg) DomClass n)
, GDiff (Base_Final (Tritone deg) DimClass n)
, GDiff (Final deg DomClass)
) => GDiff (Base_Final deg DomClass (Su n))
instance (Typeable deg, Typeable clss, Typeable n, GDiff (Final deg clss))
=> GDiff (Base_Final deg clss (Su n))
instance (Typeable deg, Typeable clss)
=> GDiff (Surface_Chord deg clss Ze)
instance (Typeable deg, Typeable clss, Typeable n)
=> GDiff (Surface_Chord deg clss (Su n))
instance ( Typeable deg, Typeable n, Typeable (MinThird deg)
, GDiff (Surface_Chord (MinThird deg) DimClass n)
)
=> GDiff (Surface_Chord deg DimClass (Su n))
--------------------------------------------------------------------------------
instance Children Class where children _ = []
instance Build Class where build c r = Just (c,r)
instance SEq Class where shallowEq _ _ = True
instance GDiff Class
instance Children Degree where children _ = []
instance Build Degree where build c r = Just (c,r)
instance SEq Degree where shallowEq _ _ = True
instance GDiff Degree
--------------------------------------------------------------------------------
-- ChordDegree as tokens
--------------------------------------------------------------------------------
instance IsLocationUpdatedBy (Int, Int) ChordDegree where
advance (line,pos) _ = (line,pos+1)