module HarmTrace.Models.Pop.Instances where
import Generics.Instant.TH
import Text.ParserCombinators.UU
import Text.ParserCombinators.UU.BasicInstances
import HarmTrace.Models.Parser
import HarmTrace.Models.Pop.Model
import HarmTrace.HAnTree.Tree
import HarmTrace.HAnTree.ToHAnTree
import HarmTrace.HAnTree.HAn
import HarmTrace.Models.ChordTokens as CT
import HarmTrace.Models.TypeLevel
import HarmTrace.Base.MusicRep
instance ParseG (Base_SD deg clss Ze) where parseG = empty
instance ( ToDegree (DiatV deg)
, ToDegree (VDom deg)
, ParseG (Base_SD (VDom deg) DomClass n)
, ParseG (Base_SD (DiatV deg) MinClass n)
, ParseG (Base_SD (DiatVM deg) MajClass n)
, ParseG (Base_SD deg MinClass n)
, ParseG (TritMinVSub deg MinClass )
) => ParseG (Base_SD deg MinClass (Su n)) where
parseG = Base_SD <$> parseG
<|> Cons_Vdom <$> parseG <*> parseG
<|> Cons_Diat <$> parseG <*> parseG
<|> Cons_DiatM' <$> parseG <*> parseG
instance ( ToDegree (DiatVM deg)
, ToDegree (VDom deg)
, ParseG (Base_SD (VDom deg) DomClass n)
, ParseG (Base_SD (DiatVM deg) MajClass n)
, ParseG (Base_SD deg MajClass n)
, ParseG (TritMinVSub deg MajClass )
) => ParseG (Base_SD deg MajClass (Su n)) where
parseG = Base_SD <$> parseG
<|> Cons_Vdom <$> parseG <*> parseG
<|> Cons_DiatM <$> parseG <*> parseG
instance ( ToDegree (VMin deg)
, ToDegree (VDom deg)
, ParseG (Base_SD (VDom deg) DomClass n)
, ParseG (Base_SD (VMin deg) MinClass n)
, ParseG (Base_SD deg DomClass n)
, ParseG (TritMinVSub deg DomClass )
) => ParseG (Base_SD deg DomClass (Su n)) where
parseG = Base_SD <$> parseG
<|> Cons_Vdom <$> parseG <*> parseG
<|> Cons_Vmin <$> parseG <*> parseG
instance ( ToDegree (VDom deg)
, ParseG (Base_SD (VDom deg) DomClass n)
, ParseG (Base_SD deg DimClass n)
, ParseG (TritMinVSub deg DimClass )
) => ParseG (Base_SD deg DimClass (Su n)) where
parseG = Base_SD <$> parseG
<|> Cons_Vdom <$> parseG <*> parseG
instance ParseG (Base_Final deg clss Ze) where parseG = empty
instance ( ParseG (FinalDimTrans deg clss)
) => ParseG (Base_Final deg clss (Su n)) where
parseG = Base_Final <$> parseG
instance ( ParseG (FinalDimTrans deg DomClass)
, ParseG (FinalDimTrans deg MinClass)
, ParseG (Base_Final (Tritone deg) DomClass n)
, ParseG (Base_Final (IIbDim deg) DimClass n)
) => ParseG (Base_Final deg DomClass (Su n)) where
parseG = Base_Final <$> parseG
instance ParseG (Surface_Chord deg clss Ze) where parseG = empty
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 :: ScaleDegree -> ClassType -> PMusic (Surface_Chord deg clss (Su n))
pChord (Note _ Imp) _clss = empty
pChord deg clss = setStatus <$> pSatisfy recognize insertion where
recognize ct = deg == root ct && clss == classType ct
setStatus c = case status c of
NotParsed -> Surface_Chord c {status = Parsed}
_ -> Surface_Chord c
insertion = Insertion "ChordToken" (ChordToken deg clss [] CT.Inserted 1 0) 5
toGTree :: (GetDegree a, GTree a) =>
(Int -> ScaleDegree -> Trans) -> Int -> a -> [Tree HAn]
toGTree con transp deg = [Node (HAnTrans . con 1 $ toTransSDVal transp deg)
(gTree deg) Nothing]
toGTreeSplit :: (GetDegree a, GetDegree b, GTree a, GTree b) =>
(Int -> ScaleDegree -> Prep) -> b -> a -> [Tree HAn]
toGTreeSplit con vof deg
= Node (HAnPrep . con 1 $ toSDVal deg) (gTree vof) Nothing : gTree deg
instance GTree Piece where
gTree (Piece p) = [Node (HAnFunc P) (gTree p) Nothing]
instance GTree (Base_SD deg clss Ze) where
gTree _ = error "gTree: impossible?"
instance ( GTree (Base_SD (VDom deg) DomClass n)
, GTree (Base_SD (DiatV deg) MinClass n)
, GTree (Base_SD (DiatVM deg) MajClass n)
, GTree (Base_SD (VMin deg) MinClass n)
, GTree (Base_SD deg clss n)
, GTree (Base_Final deg clss n)
) => GTree (Base_SD deg clss (Su n)) where
gTree (Base_SD d) = gTree d
gTree (Cons_Vdom s d) = toGTreeSplit SecDom s d
gTree (Cons_Diat s d) = toGTreeSplit DiatDom s d
gTree (Cons_DiatM s d) = toGTreeSplit DiatDom s d
gTree (Cons_DiatM' s d) = toGTreeSplit DiatDom s d
gTree (Cons_Vmin s d) = toGTreeSplit SecMin s d
instance GTree (Base_Final deg clss Ze) where
gTree _ = error "gTree: impossible?"
instance ( GetDegree (Base_Final (Tritone deg) DomClass n)
, GetDegree (Base_Final (IIbDim deg) DimClass n)
, GTree (FinalDimTrans deg clss)
, GTree (Base_Final (Tritone deg) DomClass n)
, GTree (Base_Final (IIbDim deg) DimClass n)
) => GTree (Base_Final deg clss (Su n)) where
gTree (Base_Final d) = gTree d
instance GTree (Surface_Chord deg clss Ze) where
gTree _ = error "gTree: impossible?"
instance ( GetDegree (Surface_Chord (MinThird deg) DimClass n)
, GTree (Surface_Chord (MinThird deg) DimClass n)
) => GTree (Surface_Chord deg clss (Su n)) where
gTree (Surface_Chord c) = [Node (HAnChord c) [] Nothing]
toTransSDVal :: (GetDegree a) => Int -> a -> ScaleDegree
toTransSDVal t d = let (a,i) = getDeg d in transposeSem a (i+t)
toSDVal :: (GetDegree a) => a -> ScaleDegree
toSDVal d = let (a,i) = getDeg d in transposeSem a i
class GetDegree a where
getDeg :: a -> (ScaleDegree, Int)
instance GetDegree (Base_SD deg clss n) where
getDeg (Base_SD d) = getDeg d
getDeg (Cons_Vdom _ d) = getDeg d
getDeg (Cons_Diat _ d) = getDeg d
getDeg (Cons_DiatM _ d) = getDeg d
getDeg (Cons_DiatM' _ d) = getDeg d
getDeg (Cons_Vmin _ d) = getDeg d
instance ( GetDegree (Base_Final deg clss Ze)) where
getDeg = error "getDegree: impossible?"
instance GetDegree (Base_Final deg clss n) where
getDeg (Base_Final d) = getDeg d
instance ( GetDegree (Surface_Chord deg clss Ze)) where
getDeg = error "getDegree: impossible?"
instance ( GetDegree (Surface_Chord (MinThird deg) DimClass n)
) => GetDegree (Surface_Chord deg clss (Su n)) where
getDeg (Surface_Chord (ChordToken d _cls _cs _stat _n _dur)) = (d,0)
deriveAllL allTypes
$(fmap join $ mapM (\t -> gadtInstance ''ParseG t 'parseG 'parseGdefault)
allTypes)
$(fmap join $ mapM (\t -> simplInstance ''GTree t 'gTree 'gTreeDefault)
allTypes)
instance IsLocationUpdatedBy Int ChordToken where
advance p c = p + chordNumReps c