module Fadno.Note
(Note(..),pitch,dur
,HasNote(..),toPair,(|:)
,Mono(..),maybeMono,mono,mono',mPitch,unMono,catMonos,_M
,rest,isRest
,Spelling(..),fromChroma,toChroma,spelling
,PitchRep(..),prPitch,prOctave,(@:),pitchRep
,sumDurs,mapTime
,tied,tied',legato,legato',merge
,transpose,transpose'
,(%)
)
where
import Control.Lens
import Control.Arrow
import Data.Ratio
import GHC.Generics (Generic)
import Data.Traversable
import Data.Function
import Data.Foldable
data Note p d = Note { _pitch :: p, _dur :: d }
deriving (Eq,Generic)
$(makeLenses ''Note)
instance (Show p, Show d) => Show (Note p d) where
show (Note p d) = show p ++ "|:" ++ show d
instance Bifunctor Note where
bimap f g (Note a b) = Note (f a) (g b)
instance Field1 (Note a b) (Note a' b) a a'
instance Field2 (Note a b) (Note a b') b b'
class HasNote s p d | s -> p d where
note :: Lens' s (Note p d)
fromNote :: (HasNote n p d) => n -> s
notePitch :: Lens' s p
notePitch = note.pitch
noteDur :: Lens' s d
noteDur = note.dur
instance HasNote (Note p d) p d where
note = ($)
fromNote = view note
toPair :: Iso' (Note p d) (p,d)
toPair = iso (\(Note p d) -> (p,d)) (uncurry Note)
infixl 5 |:
(|:) :: p -> d -> Note p d
(|:) = Note
data Mono p = Rest | M { _mPitch :: p }
deriving (Eq,Ord,Functor)
instance (Show p)=>Show (Mono p) where
show Rest = "Rest"
show (M p) = "M " ++ show p
makeLenses ''Mono
makePrisms ''Mono
instance Num p => Monoid (Mono p) where
mempty = Rest
mappend Rest b = b
mappend a Rest = a
mappend (M a) (M b) = M (a + b)
maybeMono :: Iso' (Maybe a) (Mono a)
maybeMono = iso toMono toMaybe
where toMono Nothing = Rest
toMono (Just a) = M a
toMaybe Rest = Nothing
toMaybe (M a) = Just a
mono :: HasNote n (Mono p) d => p -> d -> n
mono p = fromNote . mono' p
mono' :: p -> d -> Note (Mono p) d
mono' p = Note (M p)
unMono :: b -> (a -> b) -> Mono a -> b
unMono b _ Rest = b
unMono _ f (M a) = f a
catMonos :: Foldable f => f (Mono a) -> [a]
catMonos = foldMap (unMono [] pure)
rest :: (HasNote n p d, Monoid p) => d -> n
rest = fromNote . rest'
rest' :: Monoid p => d -> Note p d
rest' = Note mempty
isRest :: (Monoid p, Eq p, HasNote n p d) => n -> Bool
isRest = (mempty ==) . view notePitch
data Spelling = C|Cs|Db|D|Ds|Eb|E|F|Fs|Gb|G|Gs|Ab|A|As|Bb|B
deriving (Eq,Show,Read,Enum,Ord,Bounded,Generic)
fromChroma :: Integral a => a -> Spelling
fromChroma 0 = C
fromChroma 1 = Cs
fromChroma 2 = D
fromChroma 3 = Eb
fromChroma 4 = E
fromChroma 5 = F
fromChroma 6 = Fs
fromChroma 7 = G
fromChroma 8 = Gs
fromChroma 9 = A
fromChroma 10 = Bb
fromChroma 11 = B
fromChroma n | n > 11 = fromChroma $ n `mod` 12
| otherwise = fromChroma $ n `mod` 12 + 12
toChroma :: Integral a => Spelling -> a
toChroma C = 0
toChroma Cs = 1
toChroma Db = 1
toChroma D = 2
toChroma Ds = 3
toChroma Eb = 3
toChroma E = 4
toChroma F = 5
toChroma Fs = 6
toChroma Gb = 6
toChroma G = 7
toChroma Gs = 8
toChroma Ab = 8
toChroma A = 9
toChroma As = 10
toChroma Bb = 10
toChroma B = 11
spelling :: Integral a => Iso' a Spelling
spelling = iso fromChroma toChroma
data PitchRep = PitchRep { _prPitch :: Spelling, _prOctave :: Int }
deriving (Eq,Bounded,Generic)
instance Show PitchRep where show (PitchRep s o) = show s ++ "@:" ++ show o
$(makeLenses ''PitchRep)
infixl 6 @:
(@:) :: Spelling -> Int -> PitchRep
(@:) = PitchRep
instance Num PitchRep where
fromInteger i = fromChroma i @: ((fromIntegral i `div` 12) 1)
a * b = fromIntegral (toInteger a * toInteger b)
a + b = fromIntegral (toInteger a + toInteger b)
abs = fromIntegral . abs . toInteger
signum = fromIntegral . signum . toInteger
negate = fromIntegral . negate . toInteger
instance Enum PitchRep where
toEnum = fromInteger . fromIntegral
fromEnum = fromIntegral . toInteger
instance Ord PitchRep where
a <= b = fromIntegral a <= fromIntegral b
instance Real PitchRep where
toRational (PitchRep s o) = (((fromIntegral o + 1) * 12) + toChroma s) % 1
instance Integral PitchRep where
toInteger = truncate . toRational
a `quotRem` b = (fromInteger *** fromInteger) (toInteger a `quotRem` toInteger b)
pitchRep :: Integral a => Iso' a PitchRep
pitchRep = iso fromIntegral (fromIntegral . toInteger)
sumDurs :: (Num d, HasNote a p d, Traversable t) => t a -> d
sumDurs = sumOf (traverse.noteDur)
mapTime :: (Num d, Ord d, HasNote a p d, Traversable t) => t a -> [(d,a)]
mapTime = toList . snd .
mapAccumL (\t n -> (t + view noteDur n,(t,n))) 0
tied :: (Eq p,Num d,HasNote a p d,Traversable t,
Traversable u,Snoc (u a) (u a) a a,Monoid (u a)) => t a -> u a
tied = merge ((==) `on` view notePitch)
tied' :: (Eq p,Num d,HasNote a p d,Traversable t) => t a -> [a]
tied' = tied
legato :: (Eq p,Monoid p,Num d,HasNote a p d,Traversable t,
Traversable u,Snoc (u a) (u a) a a,Monoid (u a)) => t a -> u a
legato = merge $ \_ n -> view notePitch n == mempty
legato' :: (Eq p,Monoid p,Num d,HasNote a p d,Traversable t) => t a -> [a]
legato' = legato
merge :: (Num d,HasNote a p d,Traversable t,
Traversable u,Snoc (u a) (u a) a a,Monoid (u a)) => (a -> a -> Bool) -> t a -> u a
merge cmp = acc mempty . toListOf traverse where
acc rs [] = rs
acc (rs :> r) (n:ns) | cmp r n = acc (rs |> over noteDur (+ view noteDur n) r) ns
acc rs (n:ns) = acc (rs |> n) ns
transpose :: (Num p,HasNote a p d,Traversable t) => p -> t a -> t a
transpose by = over (traverse.notePitch) (+by)
transpose' :: (Num p,Functor f, HasNote a (f p) d,Traversable t) => p -> t a -> t a
transpose' by = over (traverse.notePitch.mapped) (+by)