-- | Tuning theory
module Music.Theory.Tuning where

import qualified Data.Fixed as Fixed {- base -}
import Data.Ratio {- base -}

import qualified Music.Theory.Function as T {- hmt -}
import qualified Music.Theory.List as T {- hmt -}
import qualified Music.Theory.Math as T {- hmt -}
import qualified Music.Theory.Ord as T {- hmt -}

-- * Math/Floating

-- | Fractional /midi/ note number to cycles per second, given (k0,f0) pair.
--
-- > fmidi_to_cps_k0 (60,256) 69 == 430.5389646099018
fmidi_to_cps_k0 :: Floating a => (a,a) -> a -> a
fmidi_to_cps_k0 :: forall a. Floating a => (a, a) -> a -> a
fmidi_to_cps_k0 (a
k0,a
f0) a
i = a
f0 forall a. Num a => a -> a -> a
* (a
2 forall a. Floating a => a -> a -> a
** ((a
i forall a. Num a => a -> a -> a
- a
k0) forall a. Num a => a -> a -> a
* (a
1 forall a. Fractional a => a -> a -> a
/ a
12)))

-- | 'fmidi_to_cps_k0' with k0 of 69.
--
-- > fmidi_to_cps_f0 440 60 == 261.6255653005986
fmidi_to_cps_f0 :: Floating a => a -> a -> a
fmidi_to_cps_f0 :: forall a. Floating a => a -> a -> a
fmidi_to_cps_f0 a
f0 = forall a. Floating a => (a, a) -> a -> a
fmidi_to_cps_k0 (a
69,a
f0)

-- | 'fmidi_to_cps_k0' (69,440)
--
-- > map fmidi_to_cps [69,69.1] == [440.0,442.5488940698553]
fmidi_to_cps :: Floating a => a -> a
fmidi_to_cps :: forall a. Floating a => a -> a
fmidi_to_cps = forall a. Floating a => (a, a) -> a -> a
fmidi_to_cps_k0 (a
69,a
440)

-- | /Midi/ note number to cycles per second, given frequency of ISO A4.
midi_to_cps_k0 :: (Integral i,Floating f) => (f,f) -> i -> f
midi_to_cps_k0 :: forall i f. (Integral i, Floating f) => (f, f) -> i -> f
midi_to_cps_k0 (f, f)
o = forall a. Floating a => (a, a) -> a -> a
fmidi_to_cps_k0 (f, f)
o forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | 'midi_to_cps_k0' (69,440).
--
-- > map (round . midi_to_cps) [59,60,69] == [247,262,440]
midi_to_cps :: (Integral i,Floating f) => i -> f
midi_to_cps :: forall i f. (Integral i, Floating f) => i -> f
midi_to_cps = forall i f. (Integral i, Floating f) => (f, f) -> i -> f
midi_to_cps_k0 (f
69,f
440)

-- | Convert from interval in cents to frequency ratio.
--
-- > map cents_to_fratio [0,701.9550008653874,1200] == [1,3/2,2]
-- > map cents_to_fratio [-1800,1800] -- three octaves about zero
cents_to_fratio :: Floating a => a -> a
cents_to_fratio :: forall a. Floating a => a -> a
cents_to_fratio a
n = a
2 forall a. Floating a => a -> a -> a
** (a
n forall a. Fractional a => a -> a -> a
/ a
1200)

-- | Convert from a 'Floating' ratio to /cents/.
--
-- > let r = [0,498,702,1200]
-- > map (round . fratio_to_cents) [1,4/3,3/2,2] == r
fratio_to_cents :: (Real r,Floating n) => r -> n
fratio_to_cents :: forall r n. (Real r, Floating n) => r -> n
fratio_to_cents = (n
1200 forall a. Num a => a -> a -> a
*) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Floating a => a -> a -> a
logBase n
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac

-- | Frequency /n/ cents from /f/.
--
-- > import Music.Theory.Pitch {- hmt -}
-- > map (cps_shift_cents 440) [-100,100] == map octpc_to_cps [(4,8),(4,10)]
cps_shift_cents :: Floating a => a -> a -> a
cps_shift_cents :: forall a. Floating a => a -> a -> a
cps_shift_cents a
f = (forall a. Num a => a -> a -> a
* a
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Floating a => a -> a
cents_to_fratio

-- | Interval in /cents/ from /p/ to /q/, ie. 'ratio_to_cents' of /p/ '/' /q/.
--
-- > map (round . cps_difference_cents 440) [412,415,octpc_to_cps (5,2)] == [-114,-101,500]
--
-- > let abs_dif i j = abs (i - j)
-- > cps_difference_cents 440 (fmidi_to_cps 69.1) `abs_dif` 10 < 1e9
cps_difference_cents :: (Real r,Fractional r,Floating n) => r -> r -> n
cps_difference_cents :: forall r n. (Real r, Fractional r, Floating n) => r -> r -> n
cps_difference_cents r
p r
q = forall r n. (Real r, Floating n) => r -> n
fratio_to_cents (r
q forall a. Fractional a => a -> a -> a
/ r
p)

-- * Math/Ratio

-- | Convert a (signed) number of octaves difference of given ratio to a ratio.
--
-- > map (oct_diff_to_ratio 2) [-3 .. 3] == [1/8,1/4,1/2,1,2,4,8]
-- > map (oct_diff_to_ratio (9/8)) [-3 .. 3] == [512/729,64/81,8/9,1/1,9/8,81/64,729/512]
oct_diff_to_ratio :: Integral a => Ratio a -> Int -> Ratio a
oct_diff_to_ratio :: forall a. Integral a => Ratio a -> Int -> Ratio a
oct_diff_to_ratio Ratio a
r Int
n = if Int
n forall a. Ord a => a -> a -> Bool
>= Int
0 then forall n t. Integral n => n -> (t -> t) -> t -> t
T.recur_n Int
n (forall a. Num a => a -> a -> a
* Ratio a
r) Ratio a
1 else forall n t. Integral n => n -> (t -> t) -> t -> t
T.recur_n (forall a. Num a => a -> a
negate Int
n) (forall a. Fractional a => a -> a -> a
/ Ratio a
r) Ratio a
1

-- | 'ratio_to_cents' rounded to nearest multiple of 100, modulo 12.
--
-- > map (ratio_to_pc 0) [1,4/3,3/2,2] == [0,5,7,0]
ratio_to_pc :: Int -> Rational -> Int
ratio_to_pc :: Int -> Rational -> Int
ratio_to_pc Int
n = forall i. Integral i => i -> i
T.mod12 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+ Int
n) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
round forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Fractional a => a -> a -> a
/ Approximate_Ratio
100) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i. Integral i => Ratio i -> Approximate_Ratio
ratio_to_cents

-- | Fold ratio to lie within an octave, ie. @1@ '<' /n/ '<=' @2@.
--   It is an error for /n/ to be more than one octave outside of this range.
--
-- > map fold_ratio_to_octave_nonrec [2/3,3/4,4/5,4/7] == [4/3,3/2,8/5,8/7]
fold_ratio_to_octave_nonrec :: (Ord n,Fractional n) => n -> n
fold_ratio_to_octave_nonrec :: forall n. (Ord n, Fractional n) => n -> n
fold_ratio_to_octave_nonrec n
n =
  if n
n forall a. Ord a => a -> a -> Bool
>= n
1 Bool -> Bool -> Bool
&& n
n forall a. Ord a => a -> a -> Bool
< n
2
  then n
n
  else if n
n forall a. Ord a => a -> a -> Bool
>= n
2 Bool -> Bool -> Bool
&& n
n forall a. Ord a => a -> a -> Bool
< n
4
       then n
n forall a. Fractional a => a -> a -> a
/ n
2
       else if n
n forall a. Ord a => a -> a -> Bool
< n
1 Bool -> Bool -> Bool
&& n
n forall a. Ord a => a -> a -> Bool
>= (n
1forall a. Fractional a => a -> a -> a
/n
2)
            then n
n forall a. Num a => a -> a -> a
* n
2
            else forall a. HasCallStack => [Char] -> a
error [Char]
"fold_ratio_to_octave_nonrec"

-- | Fold ratio until within an octave, ie. @1@ '<' /n/ '<=' @2@.
--   It is an error if /n/ is less than or equal to zero.
--
-- > map fold_ratio_to_octave_err [2/2,2/3,3/4,4/5,4/7] == [1/1,4/3,3/2,8/5,8/7]
fold_ratio_to_octave_err :: (Ord n,Fractional n) => n -> n
fold_ratio_to_octave_err :: forall n. (Ord n, Fractional n) => n -> n
fold_ratio_to_octave_err =
  let f :: a -> a
f a
n =
        if a
n forall a. Ord a => a -> a -> Bool
<= a
0
        then forall a. HasCallStack => [Char] -> a
error [Char]
"fold_ratio_to_octave_err?"
        else if a
n forall a. Ord a => a -> a -> Bool
>= a
2 then a -> a
f (a
n forall a. Fractional a => a -> a -> a
/ a
2) else if a
n forall a. Ord a => a -> a -> Bool
< a
1 then a -> a
f (a
n forall a. Num a => a -> a -> a
* a
2) else a
n
  in forall n. (Ord n, Fractional n) => n -> n
f

-- | In /n/ is greater than zero, 'fold_ratio_to_octave_err', else 'Nothing'.
--
-- > map fold_ratio_to_octave [0,1] == [Nothing,Just 1]
fold_ratio_to_octave :: (Ord n,Fractional n) => n -> Maybe n
fold_ratio_to_octave :: forall n. (Ord n, Fractional n) => n -> Maybe n
fold_ratio_to_octave n
n = if n
n forall a. Ord a => a -> a -> Bool
<= n
0 then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (forall n. (Ord n, Fractional n) => n -> n
fold_ratio_to_octave_err n
n)

-- | The interval between two pitches /p/ and /q/ given as ratio
-- multipliers of a fundamental is /q/ '/' /p/.  The classes over such
-- intervals consider the 'fold_ratio_to_octave' of both /p/ to /q/
-- and /q/ to /p/ and select the minima at the /cmp_f/.
--
-- > map (ratio_interval_class_by id) [3/2,5/4] == [4/3,5/4]
ratio_interval_class_by :: (Ord t, Integral i) => (Ratio i -> t) -> Ratio i -> Ratio i
ratio_interval_class_by :: forall t i.
(Ord t, Integral i) =>
(Ratio i -> t) -> Ratio i -> Ratio i
ratio_interval_class_by Ratio i -> t
cmp_f Ratio i
i =
    let f :: Ratio i -> Ratio i
f = forall n. (Ord n, Fractional n) => n -> n
fold_ratio_to_octave_err
    in forall a t. Ord a => (t -> a) -> t -> t -> t
T.min_by Ratio i -> t
cmp_f (Ratio i -> Ratio i
f Ratio i
i) (Ratio i -> Ratio i
f (forall a. Fractional a => a -> a
recip Ratio i
i))

-- | 'ratio_interval_class_by' 'ratio_nd_sum'
--
-- > map ratio_interval_class [2/3,3/2,3/4,4/3] == [3/2,3/2,3/2,3/2]
-- > map ratio_interval_class [7/6,12/7] == [7/6,7/6]
ratio_interval_class :: Integral i => Ratio i -> Ratio i
ratio_interval_class :: forall i. Integral i => Ratio i -> Ratio i
ratio_interval_class = forall t i.
(Ord t, Integral i) =>
(Ratio i -> t) -> Ratio i -> Ratio i
ratio_interval_class_by forall t. Integral t => Ratio t -> t
T.ratio_nd_sum

-- * Types

-- | An approximation of a ratio.
type Approximate_Ratio = Double

-- | Type specialised 'fromRational'.
approximate_ratio :: Rational -> Approximate_Ratio
approximate_ratio :: Rational -> Approximate_Ratio
approximate_ratio = forall a. Fractional a => Rational -> a
fromRational

-- | A real valued division of a semi-tone into one hundred parts, and
-- hence of the octave into @1200@ parts.
type Cents = Double

-- | Integral cents value.
type Cents_I = Int

-- | Type specialised 'fratio_to_cents'.
approximate_ratio_to_cents :: Approximate_Ratio -> Cents
approximate_ratio_to_cents :: Approximate_Ratio -> Approximate_Ratio
approximate_ratio_to_cents = forall r n. (Real r, Floating n) => r -> n
fratio_to_cents

-- | 'approximate_ratio_to_cents' '.' 'approximate_ratio'.
--
-- > import Data.Ratio {- base -}
-- > map (\n -> (n,round (ratio_to_cents (fold_ratio_to_octave_err (n % 1))))) [1..21]
ratio_to_cents :: Integral i => Ratio i -> Cents
ratio_to_cents :: forall i. Integral i => Ratio i -> Approximate_Ratio
ratio_to_cents = Approximate_Ratio -> Approximate_Ratio
approximate_ratio_to_cents forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac

-- | Construct an exact 'Rational' that approximates 'Cents' to within /epsilon/.
--
-- > map (reconstructed_ratio 1e-5) [0,700,1200,1800] == [1,442/295,2,577/204]
--
-- > ratio_to_cents (442/295) == 699.9976981706735
reconstructed_ratio :: Double -> Cents -> Rational
reconstructed_ratio :: Approximate_Ratio -> Approximate_Ratio -> Rational
reconstructed_ratio Approximate_Ratio
epsilon Approximate_Ratio
c = forall a. RealFrac a => a -> a -> Rational
approxRational (forall a. Floating a => a -> a
cents_to_fratio Approximate_Ratio
c) Approximate_Ratio
epsilon

-- * Commas

-- | The Syntonic comma.
--
-- > syntonic_comma == 81/80
syntonic_comma :: Rational
syntonic_comma :: Rational
syntonic_comma = Integer
81 forall a. Integral a => a -> a -> Ratio a
% Integer
80

-- | The Pythagorean comma.
--
-- > pythagorean_comma == 3^12 / 2^19
pythagorean_comma :: Rational
pythagorean_comma :: Rational
pythagorean_comma = Rational
531441 forall a. Fractional a => a -> a -> a
/ Rational
524288

-- | Mercators comma.
--
-- > mercators_comma == 3^53 / 2^84
mercators_comma :: Rational
mercators_comma :: Rational
mercators_comma = Rational
19383245667680019896796723 forall a. Fractional a => a -> a -> a
/ Rational
19342813113834066795298816

-- | 12-tone equal temperament comma (ie. 12th root of 2).
--
-- > twelve_tone_equal_temperament_comma == 1.0594630943592953
twelve_tone_equal_temperament_comma :: (Floating a,Eq a) => a
twelve_tone_equal_temperament_comma :: forall a. (Floating a, Eq a) => a
twelve_tone_equal_temperament_comma = a
12 forall a. (Floating a, Eq a) => a -> a -> a
`T.nth_root` a
2

-- * Cents

-- | Give cents difference from nearest 12ET tone.
--
-- > let r = [50,-49,-2,0,2,49,50]
-- > map cents_et12_diff [650,651,698,700,702,749,750] == r
cents_et12_diff :: Integral n => n -> n
cents_et12_diff :: forall i. Integral i => i -> i
cents_et12_diff n
n =
    let m :: n
m = n
n forall a. Integral a => a -> a -> a
`mod` n
100
    in if n
m forall a. Ord a => a -> a -> Bool
> n
50 then n
m forall a. Num a => a -> a -> a
- n
100 else n
m

-- | Fractional form of 'cents_et12_diff'.
fcents_et12_diff :: Real n => n -> n
fcents_et12_diff :: forall n. Real n => n -> n
fcents_et12_diff n
n =
    let m :: n
m = n
n forall a. Real a => a -> a -> a
`Fixed.mod'` n
100
    in if n
m forall a. Ord a => a -> a -> Bool
> n
50 then n
m forall a. Num a => a -> a -> a
- n
100 else n
m

-- | The class of cents intervals has range @(0,600)@.
--
-- > map cents_interval_class [50,1150,1250] == [50,50,50]
--
-- > let r = concat [[0,50 .. 550],[600],[550,500 .. 0]]
-- > map cents_interval_class [1200,1250 .. 2400] == r
cents_interval_class :: Integral a => a -> a
cents_interval_class :: forall i. Integral i => i -> i
cents_interval_class a
n =
    let n' :: a
n' = a
n forall a. Integral a => a -> a -> a
`mod` a
1200
    in if a
n' forall a. Ord a => a -> a -> Bool
> a
600 then a
1200 forall a. Num a => a -> a -> a
- a
n' else a
n'

-- | Fractional form of 'cents_interval_class'.
fcents_interval_class :: Real a => a -> a
fcents_interval_class :: forall n. Real n => n -> n
fcents_interval_class a
n =
    let n' :: a
n' = a
n forall a. Real a => a -> a -> a
`Fixed.mod'` a
1200
    in if a
n' forall a. Ord a => a -> a -> Bool
> a
600 then a
1200 forall a. Num a => a -> a -> a
- a
n' else a
n'

-- | Always include the sign, elide @0@.
cents_diff_pp :: (Num a, Ord a, Show a) => a -> String
cents_diff_pp :: forall a. (Num a, Ord a, Show a) => a -> [Char]
cents_diff_pp a
n =
    case forall a. Ord a => a -> a -> Ordering
compare a
n a
0 of
      Ordering
LT -> forall a. Show a => a -> [Char]
show a
n
      Ordering
EQ -> [Char]
""
      Ordering
GT -> Char
'+' forall a. a -> [a] -> [a]
: forall a. Show a => a -> [Char]
show a
n

-- | Given brackets, print cents difference.
cents_diff_br :: (Num a, Ord a, Show a) => (String,String) -> a -> String
cents_diff_br :: forall a. (Num a, Ord a, Show a) => ([Char], [Char]) -> a -> [Char]
cents_diff_br ([Char], [Char])
br =
    let f :: [Char] -> [Char]
f [Char]
s = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
s then [Char]
s else forall a. ([a], [a]) -> [a] -> [a]
T.bracket_l ([Char], [Char])
br [Char]
s
    in [Char] -> [Char]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Num a, Ord a, Show a) => a -> [Char]
cents_diff_pp

-- | 'cents_diff_br' with parentheses.
--
-- > map cents_diff_text [-1,0,1] == ["(-1)","","(+1)"]
cents_diff_text :: (Num a, Ord a, Show a) => a -> String
cents_diff_text :: forall a. (Num a, Ord a, Show a) => a -> [Char]
cents_diff_text = forall a. (Num a, Ord a, Show a) => ([Char], [Char]) -> a -> [Char]
cents_diff_br ([Char]
"(",[Char]
")")

-- | 'cents_diff_br' with markdown superscript (@^@).
cents_diff_md :: (Num a, Ord a, Show a) => a -> String
cents_diff_md :: forall a. (Num a, Ord a, Show a) => a -> [Char]
cents_diff_md = forall a. (Num a, Ord a, Show a) => ([Char], [Char]) -> a -> [Char]
cents_diff_br ([Char]
"^",[Char]
"^")

-- | 'cents_diff_br' with HTML superscript (@<sup>@).
cents_diff_html :: (Num a, Ord a, Show a) => a -> String
cents_diff_html :: forall a. (Num a, Ord a, Show a) => a -> [Char]
cents_diff_html = forall a. (Num a, Ord a, Show a) => ([Char], [Char]) -> a -> [Char]
cents_diff_br ([Char]
"<SUP>",[Char]
"</SUP>")

-- * Savart

-- | Felix Savart (1791-1841), the ratio of 10:1 is assigned a value of 1000 savarts.
type Savarts = Double

-- | Ratio to savarts.
--
-- > fratio_to_savarts 10 == 1000
-- > fratio_to_savarts 2 == 301.02999566398114
fratio_to_savarts :: Floating a => a -> a
fratio_to_savarts :: forall a. Floating a => a -> a
fratio_to_savarts a
r = a
1000 forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a -> a
logBase a
10 a
r

-- | Savarts to ratio.
--
-- > savarts_to_fratio 1000 == 10
-- > savarts_to_fratio 301.02999566398118 == 2
savarts_to_fratio :: Floating a => a -> a
savarts_to_fratio :: forall a. Floating a => a -> a
savarts_to_fratio a
s = a
10 forall a. Floating a => a -> a -> a
** (a
s forall a. Fractional a => a -> a -> a
/ a
1000)

-- | Savarts to cents.
--
-- > savarts_to_cents 1 == 3.9863137138648352
savarts_to_cents :: Floating a => a -> a
savarts_to_cents :: forall a. Floating a => a -> a
savarts_to_cents a
s = a
s forall a. Num a => a -> a -> a
* (a
6 forall a. Fractional a => a -> a -> a
/ (a
5 forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a -> a
logBase a
10 a
2))

-- | Cents to savarts.
--
-- > cents_to_savarts 3.9863137138648352 == 1
-- > cents_to_savarts 1200 == ratio_to_savarts 2
cents_to_savarts :: Floating a => a -> a
cents_to_savarts :: forall a. Floating a => a -> a
cents_to_savarts a
c = a
c forall a. Fractional a => a -> a -> a
/ (a
6 forall a. Fractional a => a -> a -> a
/ (a
5 forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a -> a
logBase a
10 a
2))