{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE InstanceSigs #-}
module Harmonic.Rules.Types.Pitch
(
PitchClass(..)
, mkPitchClass
, NoteName(..)
, pitchClass
, notesToPCs
, sharp
, flat
, enharmFromNoteName
, transpose
, interval
, invert
, allPitchClasses
, pcSet
, zeroForm
) where
import GHC.Generics (Generic)
import Data.List (nub, sort)
import GHC.Base (modInt, quotInt, remInt)
import GHC.Real ((%))
newtype PitchClass = P { PitchClass -> Int
unPitchClass :: Int }
deriving (Eq PitchClass
Eq PitchClass =>
(PitchClass -> PitchClass -> Ordering)
-> (PitchClass -> PitchClass -> Bool)
-> (PitchClass -> PitchClass -> Bool)
-> (PitchClass -> PitchClass -> Bool)
-> (PitchClass -> PitchClass -> Bool)
-> (PitchClass -> PitchClass -> PitchClass)
-> (PitchClass -> PitchClass -> PitchClass)
-> Ord PitchClass
PitchClass -> PitchClass -> Bool
PitchClass -> PitchClass -> Ordering
PitchClass -> PitchClass -> PitchClass
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
$ccompare :: PitchClass -> PitchClass -> Ordering
compare :: PitchClass -> PitchClass -> Ordering
$c< :: PitchClass -> PitchClass -> Bool
< :: PitchClass -> PitchClass -> Bool
$c<= :: PitchClass -> PitchClass -> Bool
<= :: PitchClass -> PitchClass -> Bool
$c> :: PitchClass -> PitchClass -> Bool
> :: PitchClass -> PitchClass -> Bool
$c>= :: PitchClass -> PitchClass -> Bool
>= :: PitchClass -> PitchClass -> Bool
$cmax :: PitchClass -> PitchClass -> PitchClass
max :: PitchClass -> PitchClass -> PitchClass
$cmin :: PitchClass -> PitchClass -> PitchClass
min :: PitchClass -> PitchClass -> PitchClass
Ord, PitchClass -> PitchClass -> Bool
(PitchClass -> PitchClass -> Bool)
-> (PitchClass -> PitchClass -> Bool) -> Eq PitchClass
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PitchClass -> PitchClass -> Bool
== :: PitchClass -> PitchClass -> Bool
$c/= :: PitchClass -> PitchClass -> Bool
/= :: PitchClass -> PitchClass -> Bool
Eq, (forall x. PitchClass -> Rep PitchClass x)
-> (forall x. Rep PitchClass x -> PitchClass) -> Generic PitchClass
forall x. Rep PitchClass x -> PitchClass
forall x. PitchClass -> Rep PitchClass x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PitchClass -> Rep PitchClass x
from :: forall x. PitchClass -> Rep PitchClass x
$cto :: forall x. Rep PitchClass x -> PitchClass
to :: forall x. Rep PitchClass x -> PitchClass
Generic)
instance Show PitchClass where
show :: PitchClass -> String
show (P Int
n) = String
"P " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
instance Read PitchClass where
readsPrec :: Int -> ReadS PitchClass
readsPrec Int
_ (Char
'P':Char
' ':String
rest) = [(Int -> PitchClass
mkPitchClass (String -> Int
forall a. Read a => String -> a
read String
num), String
remaining)]
where (String
num, String
remaining) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"0123456789-" :: String)) String
rest
readsPrec Int
_ (Char
'P':String
rest) = [(Int -> PitchClass
mkPitchClass (String -> Int
forall a. Read a => String -> a
read String
num), String
remaining)]
where (String
num, String
remaining) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"0123456789-" :: String)) String
rest
readsPrec Int
_ String
_ = []
mkPitchClass :: Int -> PitchClass
mkPitchClass :: Int -> PitchClass
mkPitchClass Int
n = Int -> PitchClass
P (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12)
{-# INLINE mkPitchClass #-}
instance Bounded PitchClass where
minBound :: PitchClass
minBound = Int -> PitchClass
P Int
0
maxBound :: PitchClass
maxBound = Int -> PitchClass
P Int
11
instance Num PitchClass where
+ :: PitchClass -> PitchClass -> PitchClass
(+) (P Int
n1) (P Int
n2) = Int -> PitchClass
P ((Int
n1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12)
(-) (P Int
n1) (P Int
n2) = Int -> PitchClass
P ((Int
n1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12)
* :: PitchClass -> PitchClass -> PitchClass
(*) (P Int
n1) (P Int
n2) = Int -> PitchClass
P ((Int
n1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12)
negate :: PitchClass -> PitchClass
negate (P Int
n) = Int -> PitchClass
P ((Int
12 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12)
fromInteger :: Integer -> PitchClass
fromInteger Integer
n = Int -> PitchClass
P (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12)
abs :: PitchClass -> PitchClass
abs = PitchClass -> PitchClass
forall a. a -> a
id
signum :: PitchClass -> PitchClass
signum PitchClass
_ = PitchClass
1
instance Integral PitchClass where
toInteger :: PitchClass -> Integer
toInteger (P Int
n) = Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n
quotRem :: PitchClass -> PitchClass -> (PitchClass, PitchClass)
quotRem (P Int
a) (P Int
b)
| Int
b Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = String -> (PitchClass, PitchClass)
forall a. HasCallStack => String -> a
error String
"PitchClass: divide by zero"
| Bool
otherwise = (Int -> PitchClass
P (Int
a Int -> Int -> Int
`quotInt` Int
b), Int -> PitchClass
P (Int
a Int -> Int -> Int
`remInt` Int
b))
instance Real PitchClass where
toRational :: PitchClass -> Rational
toRational (P Int
n) = Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
1
instance Enum PitchClass where
succ :: PitchClass -> PitchClass
succ (P Int
n)
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
11 = Int -> PitchClass
P Int
0
| Bool
otherwise = Int -> PitchClass
P (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
pred :: PitchClass -> PitchClass
pred (P Int
n)
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Int -> PitchClass
P Int
11
| Bool
otherwise = Int -> PitchClass
P (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
toEnum :: Int -> PitchClass
toEnum Int
n = Int -> PitchClass
P (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12)
fromEnum :: PitchClass -> Int
fromEnum (P Int
n) = Int
n
data NoteName
= C | C' | Db | D | D' | Eb | E | F | F' | Gb
| G | G' | Ab | A | A' | Bb | B
deriving (NoteName -> NoteName -> Bool
(NoteName -> NoteName -> Bool)
-> (NoteName -> NoteName -> Bool) -> Eq NoteName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NoteName -> NoteName -> Bool
== :: NoteName -> NoteName -> Bool
$c/= :: NoteName -> NoteName -> Bool
/= :: NoteName -> NoteName -> Bool
Eq, Eq NoteName
Eq NoteName =>
(NoteName -> NoteName -> Ordering)
-> (NoteName -> NoteName -> Bool)
-> (NoteName -> NoteName -> Bool)
-> (NoteName -> NoteName -> Bool)
-> (NoteName -> NoteName -> Bool)
-> (NoteName -> NoteName -> NoteName)
-> (NoteName -> NoteName -> NoteName)
-> Ord NoteName
NoteName -> NoteName -> Bool
NoteName -> NoteName -> Ordering
NoteName -> NoteName -> NoteName
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
$ccompare :: NoteName -> NoteName -> Ordering
compare :: NoteName -> NoteName -> Ordering
$c< :: NoteName -> NoteName -> Bool
< :: NoteName -> NoteName -> Bool
$c<= :: NoteName -> NoteName -> Bool
<= :: NoteName -> NoteName -> Bool
$c> :: NoteName -> NoteName -> Bool
> :: NoteName -> NoteName -> Bool
$c>= :: NoteName -> NoteName -> Bool
>= :: NoteName -> NoteName -> Bool
$cmax :: NoteName -> NoteName -> NoteName
max :: NoteName -> NoteName -> NoteName
$cmin :: NoteName -> NoteName -> NoteName
min :: NoteName -> NoteName -> NoteName
Ord, ReadPrec [NoteName]
ReadPrec NoteName
Int -> ReadS NoteName
ReadS [NoteName]
(Int -> ReadS NoteName)
-> ReadS [NoteName]
-> ReadPrec NoteName
-> ReadPrec [NoteName]
-> Read NoteName
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS NoteName
readsPrec :: Int -> ReadS NoteName
$creadList :: ReadS [NoteName]
readList :: ReadS [NoteName]
$creadPrec :: ReadPrec NoteName
readPrec :: ReadPrec NoteName
$creadListPrec :: ReadPrec [NoteName]
readListPrec :: ReadPrec [NoteName]
Read, Int -> NoteName
NoteName -> Int
NoteName -> [NoteName]
NoteName -> NoteName
NoteName -> NoteName -> [NoteName]
NoteName -> NoteName -> NoteName -> [NoteName]
(NoteName -> NoteName)
-> (NoteName -> NoteName)
-> (Int -> NoteName)
-> (NoteName -> Int)
-> (NoteName -> [NoteName])
-> (NoteName -> NoteName -> [NoteName])
-> (NoteName -> NoteName -> [NoteName])
-> (NoteName -> NoteName -> NoteName -> [NoteName])
-> Enum NoteName
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: NoteName -> NoteName
succ :: NoteName -> NoteName
$cpred :: NoteName -> NoteName
pred :: NoteName -> NoteName
$ctoEnum :: Int -> NoteName
toEnum :: Int -> NoteName
$cfromEnum :: NoteName -> Int
fromEnum :: NoteName -> Int
$cenumFrom :: NoteName -> [NoteName]
enumFrom :: NoteName -> [NoteName]
$cenumFromThen :: NoteName -> NoteName -> [NoteName]
enumFromThen :: NoteName -> NoteName -> [NoteName]
$cenumFromTo :: NoteName -> NoteName -> [NoteName]
enumFromTo :: NoteName -> NoteName -> [NoteName]
$cenumFromThenTo :: NoteName -> NoteName -> NoteName -> [NoteName]
enumFromThenTo :: NoteName -> NoteName -> NoteName -> [NoteName]
Enum, NoteName
NoteName -> NoteName -> Bounded NoteName
forall a. a -> a -> Bounded a
$cminBound :: NoteName
minBound :: NoteName
$cmaxBound :: NoteName
maxBound :: NoteName
Bounded)
instance Show NoteName where
show :: NoteName -> String
show NoteName
C = String
"C"
show NoteName
C' = String
"C#"
show NoteName
Db = String
"Db"
show NoteName
D = String
"D"
show NoteName
D' = String
"D#"
show NoteName
Eb = String
"Eb"
show NoteName
E = String
"E"
show NoteName
F = String
"F"
show NoteName
F' = String
"F#"
show NoteName
Gb = String
"Gb"
show NoteName
G = String
"G"
show NoteName
G' = String
"G#"
show NoteName
Ab = String
"Ab"
show NoteName
A = String
"A"
show NoteName
A' = String
"A#"
show NoteName
Bb = String
"Bb"
show NoteName
B = String
"B"
pitchClass :: NoteName -> PitchClass
pitchClass :: NoteName -> PitchClass
pitchClass NoteName
C = Int -> PitchClass
P Int
0
pitchClass NoteName
C' = Int -> PitchClass
P Int
1
pitchClass NoteName
Db = Int -> PitchClass
P Int
1
pitchClass NoteName
D = Int -> PitchClass
P Int
2
pitchClass NoteName
D' = Int -> PitchClass
P Int
3
pitchClass NoteName
Eb = Int -> PitchClass
P Int
3
pitchClass NoteName
E = Int -> PitchClass
P Int
4
pitchClass NoteName
F = Int -> PitchClass
P Int
5
pitchClass NoteName
F' = Int -> PitchClass
P Int
6
pitchClass NoteName
Gb = Int -> PitchClass
P Int
6
pitchClass NoteName
G = Int -> PitchClass
P Int
7
pitchClass NoteName
G' = Int -> PitchClass
P Int
8
pitchClass NoteName
Ab = Int -> PitchClass
P Int
8
pitchClass NoteName
A = Int -> PitchClass
P Int
9
pitchClass NoteName
A' = Int -> PitchClass
P Int
10
pitchClass NoteName
Bb = Int -> PitchClass
P Int
10
pitchClass NoteName
B = Int -> PitchClass
P Int
11
sharp :: PitchClass -> NoteName
sharp :: PitchClass -> NoteName
sharp (P Int
0) = NoteName
C
sharp (P Int
1) = NoteName
C'
sharp (P Int
2) = NoteName
D
sharp (P Int
3) = NoteName
D'
sharp (P Int
4) = NoteName
E
sharp (P Int
5) = NoteName
F
sharp (P Int
6) = NoteName
F'
sharp (P Int
7) = NoteName
G
sharp (P Int
8) = NoteName
G'
sharp (P Int
9) = NoteName
A
sharp (P Int
10) = NoteName
A'
sharp (P Int
11) = NoteName
B
sharp PitchClass
_ = String -> NoteName
forall a. HasCallStack => String -> a
error String
"PitchClass out of range"
flat :: PitchClass -> NoteName
flat :: PitchClass -> NoteName
flat (P Int
0) = NoteName
C
flat (P Int
1) = NoteName
Db
flat (P Int
2) = NoteName
D
flat (P Int
3) = NoteName
Eb
flat (P Int
4) = NoteName
E
flat (P Int
5) = NoteName
F
flat (P Int
6) = NoteName
Gb
flat (P Int
7) = NoteName
G
flat (P Int
8) = NoteName
Ab
flat (P Int
9) = NoteName
A
flat (P Int
10) = NoteName
Bb
flat (P Int
11) = NoteName
B
flat PitchClass
_ = String -> NoteName
forall a. HasCallStack => String -> a
error String
"PitchClass out of range"
enharmFromNoteName :: NoteName -> (PitchClass -> NoteName)
enharmFromNoteName :: NoteName -> PitchClass -> NoteName
enharmFromNoteName NoteName
n = case NoteName
n of
NoteName
C -> PitchClass -> NoteName
flat
NoteName
C' -> PitchClass -> NoteName
sharp
NoteName
Db -> PitchClass -> NoteName
flat
NoteName
D -> PitchClass -> NoteName
sharp
NoteName
D' -> PitchClass -> NoteName
sharp
NoteName
Eb -> PitchClass -> NoteName
flat
NoteName
E -> PitchClass -> NoteName
sharp
NoteName
F -> PitchClass -> NoteName
flat
NoteName
F' -> PitchClass -> NoteName
sharp
NoteName
Gb -> PitchClass -> NoteName
flat
NoteName
G -> PitchClass -> NoteName
sharp
NoteName
G' -> PitchClass -> NoteName
sharp
NoteName
Ab -> PitchClass -> NoteName
flat
NoteName
A -> PitchClass -> NoteName
sharp
NoteName
A' -> PitchClass -> NoteName
sharp
NoteName
Bb -> PitchClass -> NoteName
flat
NoteName
B -> PitchClass -> NoteName
sharp
notesToPCs :: [NoteName] -> [Int]
notesToPCs :: [NoteName] -> [Int]
notesToPCs = (NoteName -> Int) -> [NoteName] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (PitchClass -> Int
unPitchClass (PitchClass -> Int) -> (NoteName -> PitchClass) -> NoteName -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteName -> PitchClass
pitchClass)
transpose :: Int -> PitchClass -> PitchClass
transpose :: Int -> PitchClass -> PitchClass
transpose Int
n (P Int
x) = Int -> PitchClass
P ((Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12)
{-# INLINE transpose #-}
interval :: PitchClass -> PitchClass -> PitchClass
interval :: PitchClass -> PitchClass -> PitchClass
interval (P Int
from) (P Int
to) = Int -> PitchClass
P ((Int
to Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
from) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12)
{-# INLINE interval #-}
invert :: PitchClass -> PitchClass
invert :: PitchClass -> PitchClass
invert (P Int
n) = Int -> PitchClass
P ((Int
12 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12)
{-# INLINE invert #-}
allPitchClasses :: [PitchClass]
allPitchClasses :: [PitchClass]
allPitchClasses = Int -> PitchClass
P (Int -> PitchClass) -> [Int] -> [PitchClass]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
0..Int
11]
pcSet :: [Int] -> [PitchClass]
pcSet :: [Int] -> [PitchClass]
pcSet = [PitchClass] -> [PitchClass]
forall a. Ord a => [a] -> [a]
sort ([PitchClass] -> [PitchClass])
-> ([Int] -> [PitchClass]) -> [Int] -> [PitchClass]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PitchClass] -> [PitchClass]
forall a. Eq a => [a] -> [a]
nub ([PitchClass] -> [PitchClass])
-> ([Int] -> [PitchClass]) -> [Int] -> [PitchClass]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PitchClass
mkPitchClass
zeroForm :: [Int] -> [PitchClass]
zeroForm :: [Int] -> [PitchClass]
zeroForm [] = []
zeroForm [Int]
xs =
let sorted :: [Int]
sorted = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) [Int]
xs
minVal :: Int
minVal = [Int] -> Int
forall a. HasCallStack => [a] -> a
head [Int]
sorted
in (Int -> PitchClass) -> [Int] -> [PitchClass]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> Int -> PitchClass
mkPitchClass (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
minVal)) [Int]
sorted