module Music.Score.Pitch (
pitch',
pitch,
inv,
up,
down,
fifthsUp,
fifthsDown,
octavesUp,
octavesDown,
fifthsAbove,
fifthsBelow,
octavesAbove,
octavesBelow,
Pitch,
Interval,
HasGetPitch(..),
HasSetPitch(..),
HasPitch'(..),
HasPitch(..),
HasSetPitch'(..),
Transposable,
Transposable1,
) where
import Control.Monad (ap, mfilter, join, liftM, MonadPlus(..))
import Control.Applicative
import Control.Lens
import Data.Semigroup
import Data.String
import Data.Typeable
import Data.Foldable (Foldable)
import Data.Traversable (Traversable)
import Data.Ratio
import Data.VectorSpace
import Data.AffineSpace
import Data.AffineSpace.Point
import qualified Data.List as List
import Music.Time
import Music.Pitch.Literal
type family Pitch a
type Interval a = Diff (Pitch a)
class HasGetPitch s where
__getPitch :: (a ~ Pitch s) => s -> a
class (SetPitch (Pitch t) s ~ t) => HasSetPitch (s :: *) (t :: *) where
type SetPitch (b :: *) (s :: *) :: *
__setPitch :: Pitch t -> s -> t
__setPitch x = __mapPitch (const x)
__mapPitch :: (Pitch s -> Pitch t) -> s -> t
default __mapPitch :: HasGetPitch s => (Pitch s -> Pitch t) -> s -> t
__mapPitch f x = __setPitch p x where p = f (__getPitch x)
type HasPitch s t = (HasGetPitch s, HasSetPitch s t)
type HasPitch' a = HasPitch a a
type HasSetPitch' a = HasSetPitch a a
pitch' :: HasPitch' a => Lens' a (Pitch a)
pitch' = pitch
pitch :: HasPitch a b => Lens a b (Pitch a) (Pitch b)
pitch = lens __getPitch (flip __setPitch)
pitch_ :: HasSetPitch a b => Setter a b (Pitch a) (Pitch b)
pitch_ = sets __mapPitch
pitches' :: (Traversable t, HasPitch' a) => Traversal' (t a) (Pitch a)
pitches' = traverse . pitch'
pitches :: (Traversable t, HasPitch a b) => Traversal (t a) (t b) (Pitch a) (Pitch b)
pitches = traverse . pitch
type HasPitchConstr a = (
HasPitch' a,
VectorSpace (Interval a), Integer ~ Scalar (Interval a),
AffineSpace (Pitch a)
)
newtype PitchT p a = PitchT { __getPitchT :: (p, a) }
deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
instance (Semigroup p, Monoid p) => Applicative (PitchT p) where
pure x = PitchT (mempty,x)
PitchT (pf,vf) <*> PitchT (px,vx) = PitchT (pf <> px, vf $ vx)
instance Stretchable ()
instance Stretchable Double
instance Stretchable Float
instance Stretchable Int
instance Stretchable Integer
instance Integral a => Stretchable (Ratio a)
instance Delayable ()
instance Delayable Double
instance Delayable Float
instance Delayable Int
instance Delayable Integer
instance Integral a => Delayable (Ratio a)
type instance Pitch (c,a) = Pitch a
instance HasGetPitch a => HasGetPitch (c,a) where
__getPitch (c,a) = __getPitch a
instance (HasGetPitch a, HasSetPitch a b) => HasSetPitch (c,a) (c,b) where
type SetPitch b (c,a) = (c,SetPitch b a)
__setPitch b = fmap (__setPitch b)
#define HAS_PITCH_PRIM(T) \
type instance Pitch T = T; \
instance HasGetPitch T where { \
__getPitch = id }
#define HAS_SET_PITCH_PRIM(T) \
instance (a ~ Pitch a) => HasSetPitch T a where { \
type SetPitch a T = a; \
__mapPitch = id }
HAS_PITCH_PRIM(())
HAS_PITCH_PRIM(Bool)
HAS_PITCH_PRIM(Double)
HAS_PITCH_PRIM(Float)
HAS_PITCH_PRIM(Int)
HAS_PITCH_PRIM(Integer)
HAS_SET_PITCH_PRIM(())
HAS_SET_PITCH_PRIM(Bool)
HAS_SET_PITCH_PRIM(Double)
HAS_SET_PITCH_PRIM(Float)
HAS_SET_PITCH_PRIM(Int)
HAS_SET_PITCH_PRIM(Integer)
type Transposable a =
(
HasSetPitch' a,
Transposable1 a
)
type Transposable1 a =
(
Diff (Pitch a) ~ Interval a,
AffineSpace (Pitch a),
VectorSpace (Interval a),
IsPitch (Pitch a),
IsInterval (Interval a)
)
up :: Transposable a => Interval a -> a -> a
up a = pitch_ %~ (.+^ a)
down :: Transposable a => Interval a -> a -> a
down a = pitch_ %~ (.-^ a)
above :: (Semigroup a, Transposable a) => Interval a -> a -> a
above a x = x <> up a x
below :: (Semigroup a, Transposable a) => Interval a -> a -> a
below a x = x <> down a x
inv :: Transposable a => Pitch a -> a -> a
inv p = pitch_ %~ (reflectThrough p)
octavesUp :: Transposable a => Scalar (Interval a) -> a -> a
octavesUp a = up (_P8^*a)
octavesDown :: Transposable a => Scalar (Interval a) -> a -> a
octavesDown a = down (_P8^*a)
fifthsUp :: Transposable a => Scalar (Interval a) -> a -> a
fifthsUp a = up (_P8^*a)
fifthsDown :: Transposable a => Scalar (Interval a) -> a -> a
fifthsDown a = down (_P8^*a)
octavesAbove :: (Semigroup a, Transposable a) => Scalar (Interval a) -> a -> a
octavesAbove n x = x <> octavesUp n x
octavesBelow :: (Semigroup a, Transposable a) => Scalar (Interval a) -> a -> a
octavesBelow n x = x <> octavesUp n x
fifthsAbove :: (Semigroup a, Transposable a) => Scalar (Interval a) -> a -> a
fifthsAbove n x = x <> fifthsUp n x
fifthsBelow :: (Semigroup a, Transposable a) => Scalar (Interval a) -> a -> a
fifthsBelow n x = x <> fifthsUp n x