music-score-1.6: src/Music/Score/Instances.hs
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
-------------------------------------------------------------------------------------
-- |
-- Copyright : (c) Hans Hoglund 2012
--
-- License : BSD-style
--
-- Maintainer : hans@hanshoglund.se
-- Stability : experimental
-- Portability : non-portable (TF,GNTD)
--
-- Instances for note transformers. This module should be imported as part
-- of "Music.Score".
--
-------------------------------------------------------------------------------------
module Music.Score.Instances () where
import Control.Applicative
import Control.Comonad
import Control.Monad
import Data.AffineSpace
import Data.Default
import Data.Foldable
import qualified Data.List as List
import Data.Maybe
import Data.Ratio
import Data.Semigroup
import Data.Typeable
import Data.VectorSpace
import Music.Dynamics.Literal
import Music.Pitch.Literal
import Music.Score.Articulation
import Music.Score.Chord
import Music.Score.Combinators
import Music.Score.Dynamics
import Music.Score.Ornaments
import Music.Score.Part
import Music.Score.Pitch
import Music.Score.Rhythm
import Music.Score.Score
import Music.Score.Ties
import Music.Score.Track
import Music.Score.Util
import Music.Score.Voice
import Music.Time
-------------------------------------------------------------------------------------
{-
Rewrite pairs:
CANNOT DO
ChordT
TODO
PartT
DONE
DynamicT
TieT
ArticulationT
TremoloT
HarmonicT
TextT
SlideT
-}
instance (IsPitch a, Enum n) => IsPitch (PartT n a) where
fromPitch l = PartT (toEnum 0, fromPitch l)
instance (IsDynamics a, Enum n) => IsDynamics (PartT n a) where
fromDynamics l = PartT (toEnum 0, fromDynamics l)
instance IsPitch a => IsPitch (ChordT a) where
fromPitch = return . fromPitch
instance IsDynamics a => IsDynamics (ChordT a) where
fromDynamics = return . fromDynamics
instance IsPitch a => IsPitch (TieT a) where
fromPitch = pure . fromPitch
instance IsDynamics a => IsDynamics (TieT a) where
fromDynamics = return . fromDynamics
instance IsPitch a => IsPitch (DynamicT a) where
fromPitch = pure . fromPitch
instance IsDynamics a => IsDynamics (DynamicT a) where
fromDynamics = return . fromDynamics
instance IsPitch a => IsPitch (TremoloT a) where
fromPitch = pure . fromPitch
instance IsDynamics a => IsDynamics (TremoloT a) where
fromDynamics = pure . fromDynamics
instance IsPitch a => IsPitch (TextT a) where
fromPitch = pure . fromPitch
instance IsDynamics a => IsDynamics (TextT a) where
fromDynamics = pure . fromDynamics
instance IsPitch a => IsPitch (HarmonicT a) where
fromPitch = pure . fromPitch
instance IsDynamics a => IsDynamics (HarmonicT a) where
fromDynamics = pure . fromDynamics
instance IsPitch a => IsPitch (SlideT a) where
fromPitch = pure . fromPitch
instance IsDynamics a => IsDynamics (SlideT a) where
fromDynamics = pure . fromDynamics
-------------------------------------------------------------------------------------
instance Reversible (ChordT a) where
rev = id
instance Reversible a => Reversible (DynamicT a) where
rev = fmap rev
instance Reversible a => Reversible (SlideT a) where
rev = fmap rev
instance Reversible a => Reversible (TieT a) where
rev = fmap rev
instance Reversible a => Reversible (HarmonicT a) where
rev = fmap rev
instance Reversible a => Reversible (ArticulationT a) where
rev = fmap rev
instance Reversible a => Reversible (TextT a) where
rev = fmap rev
instance Reversible a => Reversible (TremoloT a) where
rev = fmap rev
instance Reversible a => Reversible (PartT p a) where
rev = fmap rev
-------------------------------------------------------------------------------------
instance Semigroup a => Semigroup (DynamicT a) where
DynamicT (d1, x1) <> DynamicT (d2, x2) = DynamicT (d1 <> d2, x1 <> x2)
instance Semigroup a => Semigroup (SlideT a) where
(<>) = liftA2 (<>)
instance Semigroup a => Semigroup (TieT a) where
TieT (t1, x1) <> TieT (t2, x2) = TieT (t1 <> t2, x1 <> x2)
-- This instance is suspect: in general chord notes are not required to share ties,
-- so this instance may be removed (provided that TieT is moved inside ChordT for
-- all Preludes). See #134
instance Semigroup a => Semigroup (HarmonicT a) where
(<>) = liftA2 (<>)
instance Semigroup a => Semigroup (TextT a) where
(<>) = liftA2 (<>)
instance Semigroup a => Semigroup (TremoloT a) where
(<>) = liftA2 (<>)
instance Semigroup a => Semigroup (PartT n a) where
PartT (v1,x1) <> PartT (v2,x2) = PartT (v1, x1 <> x2)
-------------------------------------------------------------------------------------
-- Maybe
-- TODO this instance may be problematic with mapPhrase
instance HasArticulation a => HasArticulation (Maybe a) where
setEndSlur n = fmap (setEndSlur n)
setContSlur n = fmap (setContSlur n)
setBeginSlur n = fmap (setBeginSlur n)
setAccLevel n = fmap (setAccLevel n)
setStaccLevel n = fmap (setStaccLevel n)
type instance Part (Maybe a) = Part a
instance HasPart a => HasPart (Maybe a) where
getPart Nothing = error "Nothing: no part"
getPart (Just a) = getPart a
modifyPart f = fmap (modifyPart f)
type instance Pitch (Maybe a) = Pitch a
instance HasSetPitch a b => HasSetPitch (Maybe a) (Maybe b) where
type SetPitch g (Maybe a) = Maybe (SetPitch g a)
__mapPitch f (Nothing) = Nothing
__mapPitch f (Just a) = Just (__mapPitch f a)
-- PartT
instance HasChord a => HasChord (PartT n a) where
type ChordNote (PartT n a) = PartT n (ChordNote a)
getChord (PartT (v,x)) = fmap (\x -> PartT (v,x)) (getChord x)
type instance Pitch (PartT n a) = Pitch a
instance HasGetPitch a => HasGetPitch (PartT n a) where
__getPitch = __getPitch . extract
instance HasSetPitch a b => HasSetPitch (PartT n a) (PartT n b) where
type SetPitch g (PartT n a) = PartT n (SetPitch g a)
__mapPitch f = fmap (__mapPitch f)
instance Tiable a => Tiable (PartT n a) where
toTied (PartT (v,a)) = (PartT (v,b), PartT (v,c)) where (b,c) = toTied a
deriving instance HasDynamic a => HasDynamic (PartT n a)
deriving instance HasArticulation a => HasArticulation (PartT n a)
deriving instance HasTremolo a => HasTremolo (PartT n a)
deriving instance HasHarmonic a => HasHarmonic (PartT n a)
deriving instance HasSlide a => HasSlide (PartT n a)
deriving instance HasText a => HasText (PartT n a)
-- ChordT
instance Tiable a => Tiable (ChordT a) where
toTied (ChordT as) = (ChordT bs, ChordT cs) where (bs,cs) = (unzip . fmap toTied) as
-- There is no (HasPart ChordT) instance, so PartT must be outside ChordT in the stack
-- This restriction assures all chord notes are in the same part
type instance Pitch (ChordT a) = Pitch a
instance HasSetPitch a b => HasSetPitch (ChordT a) (ChordT b) where
type SetPitch g (ChordT a) = ChordT (SetPitch g a)
__mapPitch f = fmap (__mapPitch f)
instance HasDynamic a => HasDynamic (ChordT a) where
setEndDim n = fmap (setEndDim n)
setLevel n = fmap (setLevel n)
instance HasArticulation a => HasArticulation (ChordT a) where
setEndSlur n = fmap (setEndSlur n)
setContSlur n = fmap (setContSlur n)
setBeginSlur n = fmap (setBeginSlur n)
setAccLevel n = fmap (setAccLevel n)
setStaccLevel n = fmap (setStaccLevel n)
instance HasTremolo a => HasTremolo (ChordT a) where
setTrem n = fmap (setTrem n)
instance HasHarmonic a => HasHarmonic (ChordT a) where
setNatural n = fmap (setNatural n)
setHarmonic n = fmap (setHarmonic n)
instance HasSlide a => HasSlide (ChordT a) where
setBeginGliss n = fmap (setBeginGliss n)
setBeginSlide n = fmap (setBeginSlide n)
setEndGliss n = fmap (setEndGliss n)
setEndSlide n = fmap (setEndSlide n)
instance HasText a => HasText (ChordT a) where
addText s (ChordT as) = ChordT (mapF (addText s) as)
-- TieT
type instance Part (TieT a) = Part a
instance HasPart a => HasPart (TieT a) where
getPart (TieT (_,x)) = getPart x
modifyPart f = fmap (modifyPart f)
instance HasChord a => HasChord (TieT a) where
type ChordNote (TieT a) = TieT (ChordNote a)
getChord (TieT (t,x)) = fmap (\x -> TieT (t,x)) (getChord x)
type instance Pitch (TieT a) = Pitch a
instance HasGetPitch a => HasGetPitch (TieT a) where
__getPitch = __getPitch . get1
instance HasSetPitch a b => HasSetPitch (TieT a) (TieT b) where
type SetPitch g (TieT a) = TieT (SetPitch g a)
__mapPitch f = fmap (__mapPitch f)
deriving instance HasDynamic a => HasDynamic (TieT a)
deriving instance HasArticulation a => HasArticulation (TieT a)
deriving instance HasTremolo a => HasTremolo (TieT a)
deriving instance HasHarmonic a => HasHarmonic (TieT a)
deriving instance HasSlide a => HasSlide (TieT a)
deriving instance HasText a => HasText (TieT a)
-- DynamicT
-- end cresc/dim, level, begin cresc/dim
-- newtype DynamicT a = DynamicT { getDynamicT :: (Bool, Bool, Maybe Double, a, Bool, Bool) }
instance Tiable a => Tiable (DynamicT a) where
toTied (DynamicT (l, a)) = (DynamicT (l, b), DynamicT (mempty, c)) where (b,c) = toTied a
type instance Part (DynamicT a) = Part a
instance HasPart a => HasPart (DynamicT a) where
getPart (DynamicT (_,x)) = getPart x
modifyPart f = fmap (modifyPart f)
instance HasChord a => HasChord (DynamicT a) where
type ChordNote (DynamicT a) = DynamicT (ChordNote a)
getChord (DynamicT (d,as)) = fmap (\x -> DynamicT (d,x)) (getChord as)
type instance Pitch (DynamicT a) = Pitch a
instance HasGetPitch a => HasGetPitch (DynamicT a) where
__getPitch (DynamicT (_,x)) = __getPitch x
instance HasSetPitch a b => HasSetPitch (DynamicT a) (DynamicT b) where
type SetPitch g (DynamicT a) = DynamicT (SetPitch g a)
__mapPitch f = fmap (__mapPitch f)
deriving instance HasArticulation a => HasArticulation (DynamicT a)
deriving instance HasTremolo a => HasTremolo (DynamicT a)
deriving instance HasHarmonic a => HasHarmonic (DynamicT a)
deriving instance HasSlide a => HasSlide (DynamicT a)
deriving instance HasText a => HasText (DynamicT a)
-- ArticulationT
-- end slur, cont slur, acc level, stacc level, begin slur
-- newtype ArticulationT a = ArticulationT { getArticulationT :: (Bool, Bool, Int, Int, a, Bool) }
instance Tiable a => Tiable (ArticulationT a) where
toTied (ArticulationT (v,a)) = (ArticulationT (v,b), ArticulationT (v,c)) where (b,c) = toTied a
type instance Part (ArticulationT a) = Part a
instance HasPart a => HasPart (ArticulationT a) where
getPart = getPart . get1
modifyPart f = fmap (modifyPart f)
instance HasChord a => HasChord (ArticulationT a) where
type ChordNote (ArticulationT a) = ArticulationT (ChordNote a)
getChord (ArticulationT (v,x)) = fmap (\x -> ArticulationT (v,x)) (getChord x)
type instance Pitch (ArticulationT a) = Pitch a
instance HasGetPitch a => HasGetPitch (ArticulationT a) where
__getPitch (ArticulationT (_,a)) = __getPitch a
instance HasSetPitch a b => HasSetPitch (ArticulationT a) (ArticulationT b) where
type SetPitch g (ArticulationT a) = ArticulationT (SetPitch g a)
__mapPitch f (ArticulationT (v,x)) = (ArticulationT (v,__mapPitch f x))
deriving instance HasDynamic a => HasDynamic (ArticulationT a)
deriving instance HasTremolo a => HasTremolo (ArticulationT a)
deriving instance HasHarmonic a => HasHarmonic (ArticulationT a)
deriving instance HasSlide a => HasSlide (ArticulationT a)
deriving instance HasText a => HasText (ArticulationT a)
-- TremoloT
instance Tiable a => Tiable (TremoloT a) where
toTied (TremoloT (n,a)) = (TremoloT (n,b), TremoloT (n,c)) where (b,c) = toTied a
type instance Part (TremoloT a) = Part a
instance HasPart a => HasPart (TremoloT a) where
getPart (TremoloT (_,a)) = getPart a
modifyPart f (TremoloT (n,x)) = TremoloT (n, modifyPart f x)
instance HasChord a => HasChord (TremoloT a) where
type ChordNote (TremoloT a) = TremoloT (ChordNote a)
getChord (TremoloT (n,x)) = fmap (\x -> TremoloT (n,x)) (getChord x)
type instance Pitch (TremoloT a) = Pitch a
instance HasGetPitch a => HasGetPitch (TremoloT a) where
__getPitch = __getPitch . get1
instance HasSetPitch a b => HasSetPitch (TremoloT a) (TremoloT b) where
type SetPitch g (TremoloT a) = TremoloT (SetPitch g a)
__mapPitch f = fmap (__mapPitch f)
deriving instance HasDynamic a => HasDynamic (TremoloT a)
deriving instance HasArticulation a => HasArticulation (TremoloT a)
deriving instance HasHarmonic a => HasHarmonic (TremoloT a)
deriving instance HasSlide a => HasSlide (TremoloT a)
deriving instance HasText a => HasText (TremoloT a)
-- TextT
instance Tiable a => Tiable (TextT a) where
toTied (TextT (n,a)) = (TextT (n,b), TextT (mempty,c)) where (b,c) = toTied a
type instance Part (TextT a) = Part a
instance HasPart a => HasPart (TextT a) where
getPart (TextT (_,a)) = getPart a
modifyPart f = fmap (modifyPart f)
instance HasChord a => HasChord (TextT a) where
type ChordNote (TextT a) = TextT (ChordNote a)
getChord (TextT (n,x)) = fmap (\x -> TextT (n,x)) (getChord x)
type instance Pitch (TextT a) = Pitch a
instance HasGetPitch a => HasGetPitch (TextT a) where
__getPitch = __getPitch . get1
instance HasSetPitch a b => HasSetPitch (TextT a) (TextT b) where
type SetPitch g (TextT a) = TextT (SetPitch g a)
__mapPitch f = fmap (__mapPitch f)
deriving instance HasDynamic a => HasDynamic (TextT a)
deriving instance HasArticulation a => HasArticulation (TextT a)
deriving instance HasTremolo a => HasTremolo (TextT a)
deriving instance HasHarmonic a => HasHarmonic (TextT a)
deriving instance HasSlide a => HasSlide (TextT a)
-- HarmonicT
instance Tiable a => Tiable (HarmonicT a) where
toTied (HarmonicT (n,a)) = (HarmonicT (n,b), HarmonicT (n,c)) where (b,c) = toTied a
type instance Part (HarmonicT a) = Part a
instance HasPart a => HasPart (HarmonicT a) where
getPart (HarmonicT (_,a)) = getPart a
modifyPart f (HarmonicT (n,x)) = HarmonicT (n, modifyPart f x)
instance HasChord a => HasChord (HarmonicT a) where
type ChordNote (HarmonicT a) = HarmonicT (ChordNote a)
getChord (HarmonicT (n,x)) = fmap (\x -> HarmonicT (n,x)) (getChord x)
type instance Pitch (HarmonicT a) = Pitch a
instance HasGetPitch a => HasGetPitch (HarmonicT a) where
__getPitch = __getPitch . get1
instance HasSetPitch a b => HasSetPitch (HarmonicT a) (HarmonicT b) where
type SetPitch g (HarmonicT a) = HarmonicT (SetPitch g a)
__mapPitch f = fmap (__mapPitch f)
deriving instance HasDynamic a => HasDynamic (HarmonicT a)
deriving instance HasArticulation a => HasArticulation (HarmonicT a)
deriving instance HasTremolo a => HasTremolo (HarmonicT a)
deriving instance HasSlide a => HasSlide (HarmonicT a)
deriving instance HasText a => HasText (HarmonicT a)
-- SlideT
instance Tiable a => Tiable (SlideT a) where
toTied (SlideT (v,x)) = (SlideT (v,a), SlideT (v,b)) where (a,b) = toTied x
type instance Part (SlideT a) = Part a
instance HasPart a => HasPart (SlideT a) where
getPart = getPart . get1
modifyPart f = fmap (modifyPart f)
instance HasChord a => HasChord (SlideT a) where
type ChordNote (SlideT a) = SlideT (ChordNote a)
getChord (SlideT (x,as)) = fmap (\a -> SlideT (x,a)) (getChord as)
type instance Pitch (SlideT a) = Pitch a
instance HasGetPitch a => HasGetPitch (SlideT a) where
__getPitch = __getPitch . get1
instance HasSetPitch a b => HasSetPitch (SlideT a) (SlideT b) where
type SetPitch g (SlideT a) = SlideT (SetPitch g a)
__mapPitch f = fmap (__mapPitch f)
deriving instance HasDynamic a => HasDynamic (SlideT a)
deriving instance HasArticulation a => HasArticulation (SlideT a)
deriving instance HasTremolo a => HasTremolo (SlideT a)
deriving instance HasHarmonic a => HasHarmonic (SlideT a)
deriving instance HasText a => HasText (SlideT a)
-------------------------------------------------------------------------------------
-- Num, Integral, Enum and Bounded
-------------------------------------------------------------------------------------
-- PartT
instance (Enum v, Eq v, Num a) => Num (PartT v a) where
PartT (v,a) + PartT (_,b) = PartT (v,a+b)
PartT (v,a) * PartT (_,b) = PartT (v,a*b)
PartT (v,a) - PartT (_,b) = PartT (v,a-b)
abs (PartT (v,a)) = PartT (v,abs a)
signum (PartT (v,a)) = PartT (v,signum a)
fromInteger a = PartT (toEnum 0,fromInteger a)
instance (Enum v, Enum a) => Enum (PartT v a) where
toEnum a = PartT (toEnum 0, toEnum a) -- TODO use def, mempty or minBound?
fromEnum (PartT (v,a)) = fromEnum a
instance (Enum v, Bounded a) => Bounded (PartT v a) where
minBound = PartT (toEnum 0, minBound)
maxBound = PartT (toEnum 0, maxBound)
instance (Enum v, Ord v, Num a, Ord a, Real a) => Real (PartT v a) where
toRational (PartT (v,a)) = toRational a
instance (Enum v, Ord v, Real a, Enum a, Integral a) => Integral (PartT v a) where
PartT (v,a) `quotRem` PartT (_,b) = (PartT (v,q), PartT (v,r)) where (q,r) = a `quotRem` b
toInteger (PartT (v,a)) = toInteger a
-- ChordT
-- instance Num a => Num (ChordT a) where
-- ChordT [a] + ChordT [b] = ChordT [a+b]
-- ChordT [a] * ChordT [b] = ChordT [a*b]
-- ChordT [a] - ChordT [b] = ChordT [a-b]
-- abs (ChordT [a]) = ChordT [abs a]
-- signum (ChordT [a]) = ChordT [signum a]
-- fromInteger a = ChordT [fromInteger a]
instance Enum a => Enum (ChordT a) where
toEnum a = ChordT [toEnum a]
fromEnum (ChordT [a]) = fromEnum a
instance Bounded a => Bounded (ChordT a) where
minBound = ChordT [minBound]
maxBound = ChordT [maxBound]
-- instance (Num a, Ord a, Real a) => Real (ChordT a) where
-- toRational (ChordT [a]) = toRational a
-- instance (Real a, Enum a, Integral a) => Integral (ChordT a) where
-- ChordT [a] `quotRem` ChordT [b] = (ChordT [q], ChordT [r]) where (q,r) = a `quotRem` b
-- toInteger (ChordT [a]) = toInteger a
-- TieT
instance Num a => Num (TieT a) where
(+) = liftA2 (+)
(*) = liftA2 (*)
(-) = liftA2 (-)
abs = fmap abs
signum = fmap signum
fromInteger = pure . fromInteger
instance Fractional a => Fractional (TieT a) where
recip = fmap recip
fromRational = pure . fromRational
instance Floating a => Floating (TieT a) where
pi = pure pi
sqrt = fmap sqrt
exp = fmap exp
log = fmap log
sin = fmap sin
cos = fmap cos
asin = fmap asin
atan = fmap atan
acos = fmap acos
sinh = fmap sinh
cosh = fmap cosh
asinh = fmap asinh
atanh = fmap atanh
acosh = fmap acos
instance Enum a => Enum (TieT a) where
toEnum = pure . toEnum
fromEnum = fromEnum . get1
instance Bounded a => Bounded (TieT a) where
minBound = pure minBound
maxBound = pure maxBound
instance (Num a, Ord a, Real a) => Real (TieT a) where
toRational = toRational . get1
instance (Real a, Enum a, Integral a) => Integral (TieT a) where
quot = liftA2 quot
rem = liftA2 rem
toInteger = toInteger . get1
-- DynamicT
instance Num a => Num (DynamicT a) where
(+) = liftA2 (+)
(*) = liftA2 (*)
(-) = liftA2 (-)
abs = fmap abs
signum = fmap signum
fromInteger = pure . fromInteger
instance Fractional a => Fractional (DynamicT a) where
recip = fmap recip
fromRational = pure . fromRational
instance Floating a => Floating (DynamicT a) where
pi = pure pi
sqrt = fmap sqrt
exp = fmap exp
log = fmap log
sin = fmap sin
cos = fmap cos
asin = fmap asin
atan = fmap atan
acos = fmap acos
sinh = fmap sinh
cosh = fmap cosh
asinh = fmap asinh
atanh = fmap atanh
acosh = fmap acos
instance Enum a => Enum (DynamicT a) where
toEnum = pure . toEnum
fromEnum = fromEnum . get1
instance Bounded a => Bounded (DynamicT a) where
minBound = pure minBound
maxBound = pure maxBound
instance (Num a, Ord a, Real a) => Real (DynamicT a) where
toRational = toRational . get1
instance (Real a, Enum a, Integral a) => Integral (DynamicT a) where
quot = liftA2 quot
rem = liftA2 rem
toInteger = toInteger . get1
-- ArticulationT
instance Num a => Num (ArticulationT a) where
(+) = liftA2 (+)
(*) = liftA2 (*)
(-) = liftA2 (-)
abs = fmap abs
signum = fmap signum
fromInteger = pure . fromInteger
instance Fractional a => Fractional (ArticulationT a) where
recip = fmap recip
fromRational = pure . fromRational
instance Floating a => Floating (ArticulationT a) where
pi = pure pi
sqrt = fmap sqrt
exp = fmap exp
log = fmap log
sin = fmap sin
cos = fmap cos
asin = fmap asin
atan = fmap atan
acos = fmap acos
sinh = fmap sinh
cosh = fmap cosh
asinh = fmap asinh
atanh = fmap atanh
acosh = fmap acos
instance Enum a => Enum (ArticulationT a) where
toEnum = pure . toEnum
fromEnum = fromEnum . get1
instance Bounded a => Bounded (ArticulationT a) where
minBound = pure minBound
maxBound = pure maxBound
instance (Num a, Ord a, Real a) => Real (ArticulationT a) where
toRational = toRational . get1
instance (Real a, Enum a, Integral a) => Integral (ArticulationT a) where
quot = liftA2 quot
rem = liftA2 rem
toInteger = toInteger . get1
-- TremoloT
instance Num a => Num (TremoloT a) where
(+) = liftA2 (+)
(*) = liftA2 (*)
(-) = liftA2 (-)
abs = fmap abs
signum = fmap signum
fromInteger = pure . fromInteger
instance Fractional a => Fractional (TremoloT a) where
recip = fmap recip
fromRational = pure . fromRational
instance Floating a => Floating (TremoloT a) where
pi = pure pi
sqrt = fmap sqrt
exp = fmap exp
log = fmap log
sin = fmap sin
cos = fmap cos
asin = fmap asin
atan = fmap atan
acos = fmap acos
sinh = fmap sinh
cosh = fmap cosh
asinh = fmap asinh
atanh = fmap atanh
acosh = fmap acos
instance Enum a => Enum (TremoloT a) where
toEnum = pure . toEnum
fromEnum = fromEnum . get1
instance Bounded a => Bounded (TremoloT a) where
minBound = pure minBound
maxBound = pure maxBound
instance (Num a, Ord a, Real a) => Real (TremoloT a) where
toRational = toRational . get1
instance (Real a, Enum a, Integral a) => Integral (TremoloT a) where
quot = liftA2 quot
rem = liftA2 rem
toInteger = toInteger . get1
-- TextT
instance Num a => Num (TextT a) where
(+) = liftA2 (+)
(*) = liftA2 (*)
(-) = liftA2 (-)
abs = fmap abs
signum = fmap signum
fromInteger = pure . fromInteger
instance Fractional a => Fractional (TextT a) where
recip = fmap recip
fromRational = pure . fromRational
instance Floating a => Floating (TextT a) where
pi = pure pi
sqrt = fmap sqrt
exp = fmap exp
log = fmap log
sin = fmap sin
cos = fmap cos
asin = fmap asin
atan = fmap atan
acos = fmap acos
sinh = fmap sinh
cosh = fmap cosh
asinh = fmap asinh
atanh = fmap atanh
acosh = fmap acos
instance Enum a => Enum (TextT a) where
toEnum = pure . toEnum
fromEnum = fromEnum . get1
instance Bounded a => Bounded (TextT a) where
minBound = pure minBound
maxBound = pure maxBound
instance (Num a, Ord a, Real a) => Real (TextT a) where
toRational = toRational . get1
instance (Real a, Enum a, Integral a) => Integral (TextT a) where
quot = liftA2 quot
rem = liftA2 rem
toInteger = toInteger . get1
-- HarmonicT
instance Num a => Num (HarmonicT a) where
(+) = liftA2 (+)
(*) = liftA2 (*)
(-) = liftA2 (-)
abs = fmap abs
signum = fmap signum
fromInteger = pure . fromInteger
instance Fractional a => Fractional (HarmonicT a) where
recip = fmap recip
fromRational = pure . fromRational
instance Floating a => Floating (HarmonicT a) where
pi = pure pi
sqrt = fmap sqrt
exp = fmap exp
log = fmap log
sin = fmap sin
cos = fmap cos
asin = fmap asin
atan = fmap atan
acos = fmap acos
sinh = fmap sinh
cosh = fmap cosh
asinh = fmap asinh
atanh = fmap atanh
acosh = fmap acos
instance Enum a => Enum (HarmonicT a) where
toEnum = pure . toEnum
fromEnum = fromEnum . get1
instance Bounded a => Bounded (HarmonicT a) where
minBound = pure minBound
maxBound = pure maxBound
instance (Num a, Ord a, Real a) => Real (HarmonicT a) where
toRational = toRational . get1
instance (Real a, Enum a, Integral a) => Integral (HarmonicT a) where
quot = liftA2 quot
rem = liftA2 rem
toInteger = toInteger . get1
-- SlideT
instance Num a => Num (SlideT a) where
(+) = liftA2 (+)
(*) = liftA2 (*)
(-) = liftA2 (-)
abs = fmap abs
signum = fmap signum
fromInteger = pure . fromInteger
instance Fractional a => Fractional (SlideT a) where
recip = fmap recip
fromRational = pure . fromRational
instance Floating a => Floating (SlideT a) where
pi = pure pi
sqrt = fmap sqrt
exp = fmap exp
log = fmap log
sin = fmap sin
cos = fmap cos
asin = fmap asin
atan = fmap atan
acos = fmap acos
sinh = fmap sinh
cosh = fmap cosh
asinh = fmap asinh
atanh = fmap atanh
acosh = fmap acos
instance Enum a => Enum (SlideT a) where
toEnum = pure . toEnum
fromEnum = fromEnum . get1
instance Bounded a => Bounded (SlideT a) where
minBound = pure minBound
maxBound = pure maxBound
instance (Num a, Ord a, Real a) => Real (SlideT a) where
toRational = toRational . get1
instance (Real a, Enum a, Integral a) => Integral (SlideT a) where
quot = liftA2 quot
rem = liftA2 rem
toInteger = toInteger . get1
type instance Pitch (Behavior a) = Behavior (Pitch a)
-- TODO undecidable
instance (HasGetPitch a, HasSetPitch a b) => HasSetPitch (Behavior a) (Behavior b) where
type SetPitch (Behavior p) (Behavior a) = Behavior (SetPitch p a)
__mapPitch f a = liftA2 (__setPitch) (f $ (__getPitch) <$> a) a
instance Tiable a => Tiable (Behavior a) where toTied x = (x,x)
-- Safe for tuple-like types
get1 = head . toList
-- TODO replace with extract
fmaps :: Functor f => (a -> (b, c)) -> f a -> (f b, f c)
fmaps f x = ((fst . f) <$> x, (snd . f) <$> x)
liftsA2 :: Applicative f => (a -> b -> (c, d)) -> f a -> f b -> (f a, f b)
liftsA2 f x y = (fst <$> ((,) <$> x <*> y), snd <$> ((,) <$> x <*> y))