{-# LANGUAGE NoMonomorphismRestriction #-} ------------------------------------------------------------------------------------- -- | -- Copyright : (c) Hans Hoglund 2012 -- -- License : BSD-style -- -- Maintainer : hans@hanshoglund.se -- Stability : experimental -- Portability : portable -- -- Provides overloaded pitch literals. -- ------------------------------------------------------------------------------------- module Music.Pitch.Literal.Pitch ( IsPitch(..), PitchL(..), cs'', ds'', es'', fs'', gs'', as'', bs'', c'' , d'' , e'' , f'' , g'' , a'' , b'' , cb'', db'', eb'', fb'', gb'', ab'', bb'', cs' , ds' , es' , fs' , gs' , as' , bs' , c' , d' , e' , f' , g' , a' , b' , cb' , db' , eb' , fb' , gb' , ab' , bb' , cs , ds , es , fs , gs , as , bs , c , d , e , f , g , a , b , cb , db , eb , fb , gb , ab , bb , cs_ , ds_ , es_ , fs_ , gs_ , as_ , bs_ , c_ , d_ , e_ , f_ , g_ , a_ , b_ , cb_ , db_ , eb_ , fb_ , gb_ , ab_ , bb_ , cs__, ds__, es__, fs__, gs__, as__, bs__, c__ , d__ , e__ , f__ , g__ , a__ , b__ , cb__, db__, eb__, fb__, gb__, ab__, bb__ ) where import Data.Semigroup import Control.Applicative -- Pitch literal, defined as @(class, alteration, octave)@, where -- -- * @class@ is a pitch class number in @[0..6]@, starting from C. -- -- * @alteration@ is the number of semitones, i.e. 0 is natural, 1 for sharp 2 for double sharp, -1 for flat and -2 for double flat. -- Alteration is in 'Maybe' because some pitch representations differ between explicit and explicit accidentals, i.e. a diatonic -- pitch type may assume @(0,Nothing,4)@ to mean C sharp rather than C. -- -- * @octave@ is octave number in scientific pitch notation. -- -- Middle C is represented by the pitch literal @(0, Nothing, 4)@. -- newtype PitchL = PitchL { getPitchL :: (Int, Maybe Double, Int) } deriving (Eq, Show, Ord) class IsPitch a where fromPitch :: PitchL -> a instance IsPitch PitchL where fromPitch = id instance IsPitch a => IsPitch (Maybe a) where fromPitch = pure . fromPitch instance IsPitch a => IsPitch (First a) where fromPitch = pure . fromPitch instance IsPitch a => IsPitch (Last a) where fromPitch = pure . fromPitch instance IsPitch a => IsPitch [a] where fromPitch = pure . fromPitch instance (Monoid b, IsPitch a) => IsPitch (b, a) where fromPitch = pure . fromPitch instance IsPitch Double where fromPitch (PitchL (pc, sem, oct)) = fromIntegral $ semitones sem + diatonic pc + oct * 12 where semitones = maybe 0 round diatonic pc = case pc of 0 -> 0 1 -> 2 2 -> 4 3 -> 5 4 -> 7 5 -> 9 6 -> 11 instance IsPitch Integer where fromPitch (PitchL (pc, sem, oct)) = fromIntegral $ semitones sem + diatonic pc + oct * 12 where semitones = maybe 0 round diatonic pc = case pc of 0 -> 0 1 -> 2 2 -> 4 3 -> 5 4 -> 7 5 -> 9 6 -> 11 cs'' = fromPitch $ PitchL (0, Just 1, 2) ds'' = fromPitch $ PitchL (1, Just 1, 2) es'' = fromPitch $ PitchL (2, Just 1, 2) fs'' = fromPitch $ PitchL (3, Just 1, 2) gs'' = fromPitch $ PitchL (4, Just 1, 2) as'' = fromPitch $ PitchL (5, Just 1, 2) bs'' = fromPitch $ PitchL (6, Just 1, 2) c'' = fromPitch $ PitchL (0, Nothing, 2) d'' = fromPitch $ PitchL (1, Nothing, 2) e'' = fromPitch $ PitchL (2, Nothing, 2) f'' = fromPitch $ PitchL (3, Nothing, 2) g'' = fromPitch $ PitchL (4, Nothing, 2) a'' = fromPitch $ PitchL (5, Nothing, 2) b'' = fromPitch $ PitchL (6, Nothing, 2) cb'' = fromPitch $ PitchL (0, Just (-1), 2) db'' = fromPitch $ PitchL (1, Just (-1), 2) eb'' = fromPitch $ PitchL (2, Just (-1), 2) fb'' = fromPitch $ PitchL (3, Just (-1), 2) gb'' = fromPitch $ PitchL (4, Just (-1), 2) ab'' = fromPitch $ PitchL (5, Just (-1), 2) bb'' = fromPitch $ PitchL (6, Just (-1), 2) cs' = fromPitch $ PitchL (0, Just 1, 1) ds' = fromPitch $ PitchL (1, Just 1, 1) es' = fromPitch $ PitchL (2, Just 1, 1) fs' = fromPitch $ PitchL (3, Just 1, 1) gs' = fromPitch $ PitchL (4, Just 1, 1) as' = fromPitch $ PitchL (5, Just 1, 1) bs' = fromPitch $ PitchL (6, Just 1, 1) c' = fromPitch $ PitchL (0, Nothing, 1) d' = fromPitch $ PitchL (1, Nothing, 1) e' = fromPitch $ PitchL (2, Nothing, 1) f' = fromPitch $ PitchL (3, Nothing, 1) g' = fromPitch $ PitchL (4, Nothing, 1) a' = fromPitch $ PitchL (5, Nothing, 1) b' = fromPitch $ PitchL (6, Nothing, 1) cb' = fromPitch $ PitchL (0, Just (-1), 1) db' = fromPitch $ PitchL (1, Just (-1), 1) eb' = fromPitch $ PitchL (2, Just (-1), 1) fb' = fromPitch $ PitchL (3, Just (-1), 1) gb' = fromPitch $ PitchL (4, Just (-1), 1) ab' = fromPitch $ PitchL (5, Just (-1), 1) bb' = fromPitch $ PitchL (6, Just (-1), 1) cs = fromPitch $ PitchL (0, Just 1, 0) ds = fromPitch $ PitchL (1, Just 1, 0) es = fromPitch $ PitchL (2, Just 1, 0) fs = fromPitch $ PitchL (3, Just 1, 0) gs = fromPitch $ PitchL (4, Just 1, 0) as = fromPitch $ PitchL (5, Just 1, 0) bs = fromPitch $ PitchL (6, Just 1, 0) c = fromPitch $ PitchL (0, Nothing, 0) d = fromPitch $ PitchL (1, Nothing, 0) e = fromPitch $ PitchL (2, Nothing, 0) f = fromPitch $ PitchL (3, Nothing, 0) g = fromPitch $ PitchL (4, Nothing, 0) a = fromPitch $ PitchL (5, Nothing, 0) b = fromPitch $ PitchL (6, Nothing, 0) cb = fromPitch $ PitchL (0, Just (-1), 0) db = fromPitch $ PitchL (1, Just (-1), 0) eb = fromPitch $ PitchL (2, Just (-1), 0) fb = fromPitch $ PitchL (3, Just (-1), 0) gb = fromPitch $ PitchL (4, Just (-1), 0) ab = fromPitch $ PitchL (5, Just (-1), 0) bb = fromPitch $ PitchL (6, Just (-1), 0) cs_ = fromPitch $ PitchL (0, Just 1, -1) ds_ = fromPitch $ PitchL (1, Just 1, -1) es_ = fromPitch $ PitchL (2, Just 1, -1) fs_ = fromPitch $ PitchL (3, Just 1, -1) gs_ = fromPitch $ PitchL (4, Just 1, -1) as_ = fromPitch $ PitchL (5, Just 1, -1) bs_ = fromPitch $ PitchL (6, Just 1, -1) c_ = fromPitch $ PitchL (0, Nothing, -1) d_ = fromPitch $ PitchL (1, Nothing, -1) e_ = fromPitch $ PitchL (2, Nothing, -1) f_ = fromPitch $ PitchL (3, Nothing, -1) g_ = fromPitch $ PitchL (4, Nothing, -1) a_ = fromPitch $ PitchL (5, Nothing, -1) b_ = fromPitch $ PitchL (6, Nothing, -1) cb_ = fromPitch $ PitchL (0, Just (-1), -1) db_ = fromPitch $ PitchL (1, Just (-1), -1) eb_ = fromPitch $ PitchL (2, Just (-1), -1) fb_ = fromPitch $ PitchL (3, Just (-1), -1) gb_ = fromPitch $ PitchL (4, Just (-1), -1) ab_ = fromPitch $ PitchL (5, Just (-1), -1) bb_ = fromPitch $ PitchL (6, Just (-1), -1) cs__ = fromPitch $ PitchL (0, Just 1, -2) ds__ = fromPitch $ PitchL (1, Just 1, -2) es__ = fromPitch $ PitchL (2, Just 1, -2) fs__ = fromPitch $ PitchL (3, Just 1, -2) gs__ = fromPitch $ PitchL (4, Just 1, -2) as__ = fromPitch $ PitchL (5, Just 1, -2) bs__ = fromPitch $ PitchL (6, Just 1, -2) c__ = fromPitch $ PitchL (0, Nothing, -2) d__ = fromPitch $ PitchL (1, Nothing, -2) e__ = fromPitch $ PitchL (2, Nothing, -2) f__ = fromPitch $ PitchL (3, Nothing, -2) g__ = fromPitch $ PitchL (4, Nothing, -2) a__ = fromPitch $ PitchL (5, Nothing, -2) b__ = fromPitch $ PitchL (6, Nothing, -2) cb__ = fromPitch $ PitchL (0, Just (-1), -2) db__ = fromPitch $ PitchL (1, Just (-1), -2) eb__ = fromPitch $ PitchL (2, Just (-1), -2) fb__ = fromPitch $ PitchL (3, Just (-1), -2) gb__ = fromPitch $ PitchL (4, Just (-1), -2) ab__ = fromPitch $ PitchL (5, Just (-1), -2) bb__ = fromPitch $ PitchL (6, Just (-1), -2)