{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveFunctor #-}

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 Data.Semigroup
import GHC.Generics (Generic)
import Data.Traversable
import Data.Function
import Data.Foldable

-- | Note = pitch and duration.
data Note p d = Note { Note p d -> p
_pitch :: p, Note p d -> d
_dur :: d }
                deriving (Note p d -> Note p d -> Bool
(Note p d -> Note p d -> Bool)
-> (Note p d -> Note p d -> Bool) -> Eq (Note p d)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall p d. (Eq p, Eq d) => Note p d -> Note p d -> Bool
/= :: Note p d -> Note p d -> Bool
$c/= :: forall p d. (Eq p, Eq d) => Note p d -> Note p d -> Bool
== :: Note p d -> Note p d -> Bool
$c== :: forall p d. (Eq p, Eq d) => Note p d -> Note p d -> Bool
Eq,(forall x. Note p d -> Rep (Note p d) x)
-> (forall x. Rep (Note p d) x -> Note p d) -> Generic (Note p d)
forall x. Rep (Note p d) x -> Note p d
forall x. Note p d -> Rep (Note p d) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall p d x. Rep (Note p d) x -> Note p d
forall p d x. Note p d -> Rep (Note p d) x
$cto :: forall p d x. Rep (Note p d) x -> Note p d
$cfrom :: forall p d x. Note p d -> Rep (Note p d) x
Generic)
$(makeLenses ''Note)

instance (Show p, Show d) => Show (Note p d) where
    show :: Note p d -> String
show (Note p
p d
d) = p -> String
forall a. Show a => a -> String
show p
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"|:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ d -> String
forall a. Show a => a -> String
show d
d
instance Bifunctor Note where
    bimap :: (a -> b) -> (c -> d) -> Note a c -> Note b d
bimap a -> b
f c -> d
g (Note a
a c
b) = b -> d -> Note b d
forall p d. p -> d -> Note p d
Note (a -> b
f a
a) (c -> d
g c
b)
instance Field1 (Note a b) (Note a' b) a a'
instance Field2 (Note a b) (Note a b') b b'

-- | Hand-rolled class providing monomorphic lenses.
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 p d -> f (Note p d)) -> s -> f s
forall s p d. HasNote s p d => Lens' s (Note p d)
note((Note p d -> f (Note p d)) -> s -> f s)
-> ((p -> f p) -> Note p d -> f (Note p d))
-> (p -> f p)
-> s
-> f s
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(p -> f p) -> Note p d -> f (Note p d)
forall a b a'. Lens (Note a b) (Note a' b) a a'
pitch
  noteDur :: Lens' s d
  noteDur = (Note p d -> f (Note p d)) -> s -> f s
forall s p d. HasNote s p d => Lens' s (Note p d)
note((Note p d -> f (Note p d)) -> s -> f s)
-> ((d -> f d) -> Note p d -> f (Note p d))
-> (d -> f d)
-> s
-> f s
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(d -> f d) -> Note p d -> f (Note p d)
forall a b b'. Lens (Note a b) (Note a b') b b'
dur
instance HasNote (Note p d) p d where
    note :: (Note p d -> f (Note p d)) -> Note p d -> f (Note p d)
note = (Note p d -> f (Note p d)) -> Note p d -> f (Note p d)
forall a b. (a -> b) -> a -> b
($)
    fromNote :: n -> Note p d
fromNote = Getting (Note p d) n (Note p d) -> n -> Note p d
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Note p d) n (Note p d)
forall s p d. HasNote s p d => Lens' s (Note p d)
note

-- iso with pair
toPair :: Iso' (Note p d) (p,d)
toPair :: p (p, d) (f (p, d)) -> p (Note p d) (f (Note p d))
toPair = (Note p d -> (p, d))
-> ((p, d) -> Note p d) -> Iso (Note p d) (Note p d) (p, d) (p, d)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\(Note p
p d
d) -> (p
p,d
d)) ((p -> d -> Note p d) -> (p, d) -> Note p d
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry p -> d -> Note p d
forall p d. p -> d -> Note p d
Note)


infixl 5 |:
-- | 'Note' smart constructor.
(|:) :: p -> d -> Note p d
|: :: p -> d -> Note p d
(|:) = p -> d -> Note p d
forall p d. p -> d -> Note p d
Note

-- | Monophonic pitch functor, i.e. Maybe with a sum monoid.
data Mono p = Rest | M { Mono p -> p
_mPitch :: p }
    deriving (Mono p -> Mono p -> Bool
(Mono p -> Mono p -> Bool)
-> (Mono p -> Mono p -> Bool) -> Eq (Mono p)
forall p. Eq p => Mono p -> Mono p -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Mono p -> Mono p -> Bool
$c/= :: forall p. Eq p => Mono p -> Mono p -> Bool
== :: Mono p -> Mono p -> Bool
$c== :: forall p. Eq p => Mono p -> Mono p -> Bool
Eq,Eq (Mono p)
Eq (Mono p)
-> (Mono p -> Mono p -> Ordering)
-> (Mono p -> Mono p -> Bool)
-> (Mono p -> Mono p -> Bool)
-> (Mono p -> Mono p -> Bool)
-> (Mono p -> Mono p -> Bool)
-> (Mono p -> Mono p -> Mono p)
-> (Mono p -> Mono p -> Mono p)
-> Ord (Mono p)
Mono p -> Mono p -> Bool
Mono p -> Mono p -> Ordering
Mono p -> Mono p -> Mono p
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall p. Ord p => Eq (Mono p)
forall p. Ord p => Mono p -> Mono p -> Bool
forall p. Ord p => Mono p -> Mono p -> Ordering
forall p. Ord p => Mono p -> Mono p -> Mono p
min :: Mono p -> Mono p -> Mono p
$cmin :: forall p. Ord p => Mono p -> Mono p -> Mono p
max :: Mono p -> Mono p -> Mono p
$cmax :: forall p. Ord p => Mono p -> Mono p -> Mono p
>= :: Mono p -> Mono p -> Bool
$c>= :: forall p. Ord p => Mono p -> Mono p -> Bool
> :: Mono p -> Mono p -> Bool
$c> :: forall p. Ord p => Mono p -> Mono p -> Bool
<= :: Mono p -> Mono p -> Bool
$c<= :: forall p. Ord p => Mono p -> Mono p -> Bool
< :: Mono p -> Mono p -> Bool
$c< :: forall p. Ord p => Mono p -> Mono p -> Bool
compare :: Mono p -> Mono p -> Ordering
$ccompare :: forall p. Ord p => Mono p -> Mono p -> Ordering
$cp1Ord :: forall p. Ord p => Eq (Mono p)
Ord,a -> Mono b -> Mono a
(a -> b) -> Mono a -> Mono b
(forall a b. (a -> b) -> Mono a -> Mono b)
-> (forall a b. a -> Mono b -> Mono a) -> Functor Mono
forall a b. a -> Mono b -> Mono a
forall a b. (a -> b) -> Mono a -> Mono b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Mono b -> Mono a
$c<$ :: forall a b. a -> Mono b -> Mono a
fmap :: (a -> b) -> Mono a -> Mono b
$cfmap :: forall a b. (a -> b) -> Mono a -> Mono b
Functor)
instance (Show p)=>Show (Mono p) where
    show :: Mono p -> String
show Mono p
Rest = String
"Rest"
    show (M p
p) = String
"M " String -> ShowS
forall a. [a] -> [a] -> [a]
++ p -> String
forall a. Show a => a -> String
show p
p
makeLenses ''Mono
makePrisms ''Mono
instance Num p => Semigroup (Mono p) where
    Mono p
Rest <> :: Mono p -> Mono p -> Mono p
<> Mono p
b = Mono p
b
    Mono p
a <> Mono p
Rest = Mono p
a
    (M p
a) <> (M p
b) = p -> Mono p
forall p. p -> Mono p
M (p
a p -> p -> p
forall a. Num a => a -> a -> a
+ p
b)
instance Num p => Monoid (Mono p) where
    mempty :: Mono p
mempty = Mono p
forall p. Mono p
Rest
    mappend :: Mono p -> Mono p -> Mono p
mappend = Mono p -> Mono p -> Mono p
forall a. Semigroup a => a -> a -> a
(<>)

-- | Mono/Maybe isomorphism.
maybeMono :: Iso' (Maybe a) (Mono a)
maybeMono :: p (Mono a) (f (Mono a)) -> p (Maybe a) (f (Maybe a))
maybeMono = (Maybe a -> Mono a)
-> (Mono a -> Maybe a) -> Iso (Maybe a) (Maybe a) (Mono a) (Mono a)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Maybe a -> Mono a
forall p. Maybe p -> Mono p
toMono Mono a -> Maybe a
forall a. Mono a -> Maybe a
toMaybe
    where toMono :: Maybe p -> Mono p
toMono Maybe p
Nothing = Mono p
forall p. Mono p
Rest
          toMono (Just p
a) = p -> Mono p
forall p. p -> Mono p
M p
a
          toMaybe :: Mono a -> Maybe a
toMaybe Mono a
Rest = Maybe a
forall a. Maybe a
Nothing
          toMaybe (M a
a) = a -> Maybe a
forall a. a -> Maybe a
Just a
a

-- | Mono 'HasNote'
mono :: HasNote n (Mono p) d => p -> d -> n
mono :: p -> d -> n
mono p
p = Note (Mono p) d -> n
forall s p d n. (HasNote s p d, HasNote n p d) => n -> s
fromNote (Note (Mono p) d -> n) -> (d -> Note (Mono p) d) -> d -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> d -> Note (Mono p) d
forall p d. p -> d -> Note (Mono p) d
mono' p
p

-- | Mono 'Note'.
mono' :: p -> d -> Note (Mono p) d
mono' :: p -> d -> Note (Mono p) d
mono' p
p = Mono p -> d -> Note (Mono p) d
forall p d. p -> d -> Note p d
Note (p -> Mono p
forall p. p -> Mono p
M p
p)

-- | Mono eliminator
unMono :: b -> (a -> b) -> Mono a -> b
unMono :: b -> (a -> b) -> Mono a -> b
unMono b
b a -> b
_ Mono a
Rest = b
b
unMono b
_ a -> b
f (M a
a) = a -> b
f a
a

-- | cf 'catMaybe'. Grab all non-rest values.
catMonos :: Foldable f => f (Mono a) -> [a]
catMonos :: f (Mono a) -> [a]
catMonos = (Mono a -> [a]) -> f (Mono a) -> [a]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ([a] -> (a -> [a]) -> Mono a -> [a]
forall b a. b -> (a -> b) -> Mono a -> b
unMono [] a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure)

-- | 'Note' from duration, given 'Monoid' pitch.
-- Interoperates with 'chord' and 'mono'.
-- Useful for batch duration conversion.
rest :: (HasNote n p d, Monoid p) => d -> n
rest :: d -> n
rest = Note p d -> n
forall s p d n. (HasNote s p d, HasNote n p d) => n -> s
fromNote (Note p d -> n) -> (d -> Note p d) -> d -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> Note p d
forall p d. Monoid p => d -> Note p d
rest'

rest' :: Monoid p => d -> Note p d
rest' :: d -> Note p d
rest' = p -> d -> Note p d
forall p d. p -> d -> Note p d
Note p
forall a. Monoid a => a
mempty

isRest :: (Monoid p, Eq p, HasNote n p d) => n -> Bool
isRest :: n -> Bool
isRest = (p
forall a. Monoid a => a
mempty p -> p -> Bool
forall a. Eq a => a -> a -> Bool
==) (p -> Bool) -> (n -> p) -> n -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting p n p -> n -> p
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting p n p
forall s p d. HasNote s p d => Lens' s p
notePitch




-- | Chroma as enharmonic names.
data Spelling = C|Cs|Db|D|Ds|Eb|E|F|Fs|Gb|G|Gs|Ab|A|As|Bb|B
            deriving (Spelling -> Spelling -> Bool
(Spelling -> Spelling -> Bool)
-> (Spelling -> Spelling -> Bool) -> Eq Spelling
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Spelling -> Spelling -> Bool
$c/= :: Spelling -> Spelling -> Bool
== :: Spelling -> Spelling -> Bool
$c== :: Spelling -> Spelling -> Bool
Eq,Int -> Spelling -> ShowS
[Spelling] -> ShowS
Spelling -> String
(Int -> Spelling -> ShowS)
-> (Spelling -> String) -> ([Spelling] -> ShowS) -> Show Spelling
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Spelling] -> ShowS
$cshowList :: [Spelling] -> ShowS
show :: Spelling -> String
$cshow :: Spelling -> String
showsPrec :: Int -> Spelling -> ShowS
$cshowsPrec :: Int -> Spelling -> ShowS
Show,ReadPrec [Spelling]
ReadPrec Spelling
Int -> ReadS Spelling
ReadS [Spelling]
(Int -> ReadS Spelling)
-> ReadS [Spelling]
-> ReadPrec Spelling
-> ReadPrec [Spelling]
-> Read Spelling
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Spelling]
$creadListPrec :: ReadPrec [Spelling]
readPrec :: ReadPrec Spelling
$creadPrec :: ReadPrec Spelling
readList :: ReadS [Spelling]
$creadList :: ReadS [Spelling]
readsPrec :: Int -> ReadS Spelling
$creadsPrec :: Int -> ReadS Spelling
Read,Int -> Spelling
Spelling -> Int
Spelling -> [Spelling]
Spelling -> Spelling
Spelling -> Spelling -> [Spelling]
Spelling -> Spelling -> Spelling -> [Spelling]
(Spelling -> Spelling)
-> (Spelling -> Spelling)
-> (Int -> Spelling)
-> (Spelling -> Int)
-> (Spelling -> [Spelling])
-> (Spelling -> Spelling -> [Spelling])
-> (Spelling -> Spelling -> [Spelling])
-> (Spelling -> Spelling -> Spelling -> [Spelling])
-> Enum Spelling
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Spelling -> Spelling -> Spelling -> [Spelling]
$cenumFromThenTo :: Spelling -> Spelling -> Spelling -> [Spelling]
enumFromTo :: Spelling -> Spelling -> [Spelling]
$cenumFromTo :: Spelling -> Spelling -> [Spelling]
enumFromThen :: Spelling -> Spelling -> [Spelling]
$cenumFromThen :: Spelling -> Spelling -> [Spelling]
enumFrom :: Spelling -> [Spelling]
$cenumFrom :: Spelling -> [Spelling]
fromEnum :: Spelling -> Int
$cfromEnum :: Spelling -> Int
toEnum :: Int -> Spelling
$ctoEnum :: Int -> Spelling
pred :: Spelling -> Spelling
$cpred :: Spelling -> Spelling
succ :: Spelling -> Spelling
$csucc :: Spelling -> Spelling
Enum,Eq Spelling
Eq Spelling
-> (Spelling -> Spelling -> Ordering)
-> (Spelling -> Spelling -> Bool)
-> (Spelling -> Spelling -> Bool)
-> (Spelling -> Spelling -> Bool)
-> (Spelling -> Spelling -> Bool)
-> (Spelling -> Spelling -> Spelling)
-> (Spelling -> Spelling -> Spelling)
-> Ord Spelling
Spelling -> Spelling -> Bool
Spelling -> Spelling -> Ordering
Spelling -> Spelling -> Spelling
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Spelling -> Spelling -> Spelling
$cmin :: Spelling -> Spelling -> Spelling
max :: Spelling -> Spelling -> Spelling
$cmax :: Spelling -> Spelling -> Spelling
>= :: Spelling -> Spelling -> Bool
$c>= :: Spelling -> Spelling -> Bool
> :: Spelling -> Spelling -> Bool
$c> :: Spelling -> Spelling -> Bool
<= :: Spelling -> Spelling -> Bool
$c<= :: Spelling -> Spelling -> Bool
< :: Spelling -> Spelling -> Bool
$c< :: Spelling -> Spelling -> Bool
compare :: Spelling -> Spelling -> Ordering
$ccompare :: Spelling -> Spelling -> Ordering
$cp1Ord :: Eq Spelling
Ord,Spelling
Spelling -> Spelling -> Bounded Spelling
forall a. a -> a -> Bounded a
maxBound :: Spelling
$cmaxBound :: Spelling
minBound :: Spelling
$cminBound :: Spelling
Bounded,(forall x. Spelling -> Rep Spelling x)
-> (forall x. Rep Spelling x -> Spelling) -> Generic Spelling
forall x. Rep Spelling x -> Spelling
forall x. Spelling -> Rep Spelling x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Spelling x -> Spelling
$cfrom :: forall x. Spelling -> Rep Spelling x
Generic)

-- | Convert to 'Spelling' with 0==C, using 'Cs','Eb','Fs','Gs','Bb' enharmonics.
fromChroma :: Integral a => a -> Spelling
fromChroma :: a -> Spelling
fromChroma a
0 = Spelling
C
fromChroma a
1 = Spelling
Cs
fromChroma a
2 = Spelling
D
fromChroma a
3 = Spelling
Eb
fromChroma a
4 = Spelling
E
fromChroma a
5 = Spelling
F
fromChroma a
6 = Spelling
Fs
fromChroma a
7 = Spelling
G
fromChroma a
8 = Spelling
Gs
fromChroma a
9 = Spelling
A
fromChroma a
10 = Spelling
Bb
fromChroma a
11 = Spelling
B
fromChroma a
n | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
11 = a -> Spelling
forall a. Integral a => a -> Spelling
fromChroma (a -> Spelling) -> a -> Spelling
forall a b. (a -> b) -> a -> b
$ a
n a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
12
             | Bool
otherwise = a -> Spelling
forall a. Integral a => a -> Spelling
fromChroma (a -> Spelling) -> a -> Spelling
forall a b. (a -> b) -> a -> b
$ a
n a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
12 a -> a -> a
forall a. Num a => a -> a -> a
+ a
12

-- | 'Spelling' to 0-11.
toChroma :: Integral a => Spelling -> a
toChroma :: Spelling -> a
toChroma Spelling
C = a
0
toChroma Spelling
Cs = a
1
toChroma Spelling
Db = a
1
toChroma Spelling
D = a
2
toChroma Spelling
Ds = a
3
toChroma Spelling
Eb = a
3
toChroma Spelling
E = a
4
toChroma Spelling
F = a
5
toChroma Spelling
Fs = a
6
toChroma Spelling
Gb = a
6
toChroma Spelling
G = a
7
toChroma Spelling
Gs = a
8
toChroma Spelling
Ab = a
8
toChroma Spelling
A = a
9
toChroma Spelling
As = a
10
toChroma Spelling
Bb = a
10
toChroma Spelling
B = a
11

-- | 'Spelling'-to-chroma degenerate 'Iso'.
spelling :: Integral a => Iso' a Spelling
spelling :: Iso' a Spelling
spelling = (a -> Spelling) -> (Spelling -> a) -> Iso' a Spelling
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso a -> Spelling
forall a. Integral a => a -> Spelling
fromChroma Spelling -> a
forall a. Integral a => Spelling -> a
toChroma

-- | Represent pitch as chroma and octave.
-- It's a full 'Num', 'Integral' instance, so negative octave values OK.
-- Instances use C4 == 60.
data PitchRep = PitchRep { PitchRep -> Spelling
_prPitch :: Spelling, PitchRep -> Int
_prOctave :: Int  }
              deriving (PitchRep -> PitchRep -> Bool
(PitchRep -> PitchRep -> Bool)
-> (PitchRep -> PitchRep -> Bool) -> Eq PitchRep
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PitchRep -> PitchRep -> Bool
$c/= :: PitchRep -> PitchRep -> Bool
== :: PitchRep -> PitchRep -> Bool
$c== :: PitchRep -> PitchRep -> Bool
Eq,PitchRep
PitchRep -> PitchRep -> Bounded PitchRep
forall a. a -> a -> Bounded a
maxBound :: PitchRep
$cmaxBound :: PitchRep
minBound :: PitchRep
$cminBound :: PitchRep
Bounded,(forall x. PitchRep -> Rep PitchRep x)
-> (forall x. Rep PitchRep x -> PitchRep) -> Generic PitchRep
forall x. Rep PitchRep x -> PitchRep
forall x. PitchRep -> Rep PitchRep x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PitchRep x -> PitchRep
$cfrom :: forall x. PitchRep -> Rep PitchRep x
Generic)
instance Show PitchRep where show :: PitchRep -> String
show (PitchRep Spelling
s Int
o) = Spelling -> String
forall a. Show a => a -> String
show Spelling
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"@:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
o
$(makeLenses ''PitchRep)

infixl 6 @:
(@:) :: Spelling -> Int -> PitchRep
@: :: Spelling -> Int -> PitchRep
(@:) = Spelling -> Int -> PitchRep
PitchRep

instance Num PitchRep where
    fromInteger :: Integer -> PitchRep
fromInteger Integer
i = Integer -> Spelling
forall a. Integral a => a -> Spelling
fromChroma Integer
i Spelling -> Int -> PitchRep
@: ((Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
12) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    PitchRep
a * :: PitchRep -> PitchRep -> PitchRep
* PitchRep
b = Integer -> PitchRep
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PitchRep -> Integer
forall a. Integral a => a -> Integer
toInteger PitchRep
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* PitchRep -> Integer
forall a. Integral a => a -> Integer
toInteger PitchRep
b)
    PitchRep
a + :: PitchRep -> PitchRep -> PitchRep
+ PitchRep
b = Integer -> PitchRep
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PitchRep -> Integer
forall a. Integral a => a -> Integer
toInteger PitchRep
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ PitchRep -> Integer
forall a. Integral a => a -> Integer
toInteger PitchRep
b)
    abs :: PitchRep -> PitchRep
abs = Integer -> PitchRep
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> PitchRep)
-> (PitchRep -> Integer) -> PitchRep -> PitchRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer
forall a. Num a => a -> a
abs (Integer -> Integer)
-> (PitchRep -> Integer) -> PitchRep -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PitchRep -> Integer
forall a. Integral a => a -> Integer
toInteger
    signum :: PitchRep -> PitchRep
signum = Integer -> PitchRep
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> PitchRep)
-> (PitchRep -> Integer) -> PitchRep -> PitchRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer
forall a. Num a => a -> a
signum (Integer -> Integer)
-> (PitchRep -> Integer) -> PitchRep -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PitchRep -> Integer
forall a. Integral a => a -> Integer
toInteger
    negate :: PitchRep -> PitchRep
negate = Integer -> PitchRep
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> PitchRep)
-> (PitchRep -> Integer) -> PitchRep -> PitchRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer
forall a. Num a => a -> a
negate (Integer -> Integer)
-> (PitchRep -> Integer) -> PitchRep -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PitchRep -> Integer
forall a. Integral a => a -> Integer
toInteger

instance Enum PitchRep where
    toEnum :: Int -> PitchRep
toEnum = Integer -> PitchRep
forall a. Num a => Integer -> a
fromInteger (Integer -> PitchRep) -> (Int -> Integer) -> Int -> PitchRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    fromEnum :: PitchRep -> Int
fromEnum = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> (PitchRep -> Integer) -> PitchRep -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PitchRep -> Integer
forall a. Integral a => a -> Integer
toInteger

instance Ord PitchRep where
    PitchRep
a <= :: PitchRep -> PitchRep -> Bool
<= PitchRep
b = PitchRep -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral PitchRep
a Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= PitchRep -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral PitchRep
b

instance Real PitchRep where
    toRational :: PitchRep -> Rational
toRational (PitchRep Spelling
s Int
o) = (((Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
o Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
12) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Spelling -> Integer
forall a. Integral a => Spelling -> a
toChroma Spelling
s) Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
1

instance Integral PitchRep where
    toInteger :: PitchRep -> Integer
toInteger = Rational -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Rational -> Integer)
-> (PitchRep -> Rational) -> PitchRep -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PitchRep -> Rational
forall a. Real a => a -> Rational
toRational
    PitchRep
a quotRem :: PitchRep -> PitchRep -> (PitchRep, PitchRep)
`quotRem` PitchRep
b = (Integer -> PitchRep
forall a. Num a => Integer -> a
fromInteger (Integer -> PitchRep)
-> (Integer -> PitchRep)
-> (Integer, Integer)
-> (PitchRep, PitchRep)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Integer -> PitchRep
forall a. Num a => Integer -> a
fromInteger) (PitchRep -> Integer
forall a. Integral a => a -> Integer
toInteger PitchRep
a Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
`quotRem` PitchRep -> Integer
forall a. Integral a => a -> Integer
toInteger PitchRep
b)

-- | Iso to integrals.
pitchRep :: Integral a => Iso' a PitchRep
pitchRep :: Iso' a PitchRep
pitchRep = (a -> PitchRep) -> (PitchRep -> a) -> Iso' a PitchRep
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso a -> PitchRep
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> a) -> (PitchRep -> Integer) -> PitchRep -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PitchRep -> Integer
forall a. Integral a => a -> Integer
toInteger)


--
-- Utilities
--

-- | compute total duration of notes
sumDurs :: (Num d, HasNote a p d, Traversable t) => t a -> d
sumDurs :: t a -> d
sumDurs = Getting (Endo (Endo d)) (t a) d -> t a -> d
forall a s. Num a => Getting (Endo (Endo a)) s a -> s -> a
sumOf ((a -> Const (Endo (Endo d)) a)
-> t a -> Const (Endo (Endo d)) (t a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse((a -> Const (Endo (Endo d)) a)
 -> t a -> Const (Endo (Endo d)) (t a))
-> ((d -> Const (Endo (Endo d)) d) -> a -> Const (Endo (Endo d)) a)
-> Getting (Endo (Endo d)) (t a) d
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(d -> Const (Endo (Endo d)) d) -> a -> Const (Endo (Endo d)) a
forall s p d. HasNote s p d => Lens' s d
noteDur)

-- | map notes to arrival time
mapTime :: (Num d, Ord d, HasNote a p d, Traversable t) => t a -> [(d,a)]
mapTime :: t a -> [(d, a)]
mapTime = t (d, a) -> [(d, a)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (t (d, a) -> [(d, a)]) -> (t a -> t (d, a)) -> t a -> [(d, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (d, t (d, a)) -> t (d, a)
forall a b. (a, b) -> b
snd ((d, t (d, a)) -> t (d, a))
-> (t a -> (d, t (d, a))) -> t a -> t (d, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          (d -> a -> (d, (d, a))) -> d -> t a -> (d, t (d, a))
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (\d
t a
n -> (d
t d -> d -> d
forall a. Num a => a -> a -> a
+ Getting d a d -> a -> d
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting d a d
forall s p d. HasNote s p d => Lens' s d
noteDur a
n,(d
t,a
n))) d
0

-- | merge same-pitch notes
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 :: t a -> u a
tied = (a -> a -> Bool) -> t a -> u a
forall d a p (t :: * -> *) (u :: * -> *).
(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 (p -> p -> Bool
forall a. Eq a => a -> a -> Bool
(==) (p -> p -> Bool) -> (a -> p) -> a -> a -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Getting p a p -> a -> p
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting p a p
forall s p d. HasNote s p d => Lens' s p
notePitch)

tied' :: (Eq p,Num d,HasNote a p d,Traversable t) => t a -> [a]
tied' :: t a -> [a]
tied' = t a -> [a]
forall p d a (t :: * -> *) (u :: * -> *).
(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 rests with prior note
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 :: t a -> u a
legato = (a -> a -> Bool) -> t a -> u a
forall d a p (t :: * -> *) (u :: * -> *).
(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 ((a -> a -> Bool) -> t a -> u a) -> (a -> a -> Bool) -> t a -> u a
forall a b. (a -> b) -> a -> b
$ \a
_ a
n -> Getting p a p -> a -> p
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting p a p
forall s p d. HasNote s p d => Lens' s p
notePitch a
n p -> p -> Bool
forall a. Eq a => a -> a -> Bool
== p
forall a. Monoid a => a
mempty

legato' :: (Eq p,Monoid p,Num d,HasNote a p d,Traversable t) => t a -> [a]
legato' :: t a -> [a]
legato' = t a -> [a]
forall p d a (t :: * -> *) (u :: * -> *).
(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 notes meeting some comparison by accumulating durations
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 :: (a -> a -> Bool) -> t a -> u a
merge a -> a -> Bool
cmp = u a -> [a] -> u a
forall p a s. (HasNote a p a, Snoc s s a a, Num a) => s -> [a] -> s
acc u a
forall a. Monoid a => a
mempty ([a] -> u a) -> (t a -> [a]) -> t a -> u a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Endo [a]) (t a) a -> t a -> [a]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf Getting (Endo [a]) (t a) a
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse where
    acc :: s -> [a] -> s
acc s
rs [] = s
rs
    acc (s
rs :> a
r) (a
n:[a]
ns) | a -> a -> Bool
cmp a
r a
n = s -> [a] -> s
acc (s
rs s -> a -> s
forall s a. Snoc s s a a => s -> a -> s
|> ASetter a a a a -> (a -> a) -> a -> a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter a a a a
forall s p d. HasNote s p d => Lens' s d
noteDur (a -> a -> a
forall a. Num a => a -> a -> a
+ Getting a a a -> a -> a
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting a a a
forall s p d. HasNote s p d => Lens' s d
noteDur a
n) a
r) [a]
ns
    acc s
rs (a
n:[a]
ns) = s -> [a] -> s
acc (s
rs s -> a -> s
forall s a. Snoc s s a a => s -> a -> s
|> a
n) [a]
ns


-- | Pitch addition
transpose :: (Num p,HasNote a p d,Traversable t) => p -> t a -> t a
transpose :: p -> t a -> t a
transpose p
by = ASetter (t a) (t a) p p -> (p -> p) -> t a -> t a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((a -> Identity a) -> t a -> Identity (t a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse((a -> Identity a) -> t a -> Identity (t a))
-> ((p -> Identity p) -> a -> Identity a)
-> ASetter (t a) (t a) p p
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(p -> Identity p) -> a -> Identity a
forall s p d. HasNote s p d => Lens' s p
notePitch) (p -> p -> p
forall a. Num a => a -> a -> a
+p
by)

-- | Pitch addition over a functor
transpose' :: (Num p,Functor f, HasNote a (f p) d,Traversable t) => p -> t a -> t a
transpose' :: p -> t a -> t a
transpose' p
by = ASetter (t a) (t a) p p -> (p -> p) -> t a -> t a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((a -> Identity a) -> t a -> Identity (t a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse((a -> Identity a) -> t a -> Identity (t a))
-> ((p -> Identity p) -> a -> Identity a)
-> ASetter (t a) (t a) p p
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(f p -> Identity (f p)) -> a -> Identity a
forall s p d. HasNote s p d => Lens' s p
notePitch((f p -> Identity (f p)) -> a -> Identity a)
-> ((p -> Identity p) -> f p -> Identity (f p))
-> (p -> Identity p)
-> a
-> Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(p -> Identity p) -> f p -> Identity (f p)
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped) (p -> p -> p
forall a. Num a => a -> a -> a
+p
by)