-- | Midi + Tuning
module Music.Theory.Tuning.Midi where

import Data.List {- base -}
import qualified Data.Map as M {- containers -}
import Data.Maybe {- base -}
import qualified Safe {- safe -}

import qualified Music.Theory.List as T {- hmt -}
import qualified Music.Theory.Map as T {- hmt -}
import qualified Music.Theory.Pitch as T {- hmt -}
import qualified Music.Theory.Tuple as T {- hmt -}

import Music.Theory.Tuning {- hmt -}
import Music.Theory.Tuning.Type {- hmt -}

-- | (/n/ -> /dt/).  Function from midi note number /n/ to
-- 'Midi_Detune' /dt/.  The incoming note number is the key pressed,
-- which may be distant from the note sounded.
type Midi_Tuning_f = T.Midi -> T.Midi_Detune

-- | Variant for tunings that are incomplete.
type Sparse_Midi_Tuning_f = T.Midi -> Maybe T.Midi_Detune

-- | Variant for sparse tunings that require state.
type Sparse_Midi_Tuning_St_f st = st -> T.Midi -> (st,Maybe T.Midi_Detune)

-- | Lift 'Midi_Tuning_f' to 'Sparse_Midi_Tuning_f'.
lift_tuning_f :: Midi_Tuning_f -> Sparse_Midi_Tuning_f
lift_tuning_f :: Midi_Tuning_f -> Sparse_Midi_Tuning_f
lift_tuning_f Midi_Tuning_f
tn_f = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Midi_Tuning_f
tn_f

-- | Lift 'Sparse_Midi_Tuning_f' to 'Sparse_Midi_Tuning_St_f'.
lift_sparse_tuning_f :: Sparse_Midi_Tuning_f -> Sparse_Midi_Tuning_St_f st
lift_sparse_tuning_f :: forall st. Sparse_Midi_Tuning_f -> Sparse_Midi_Tuning_St_f st
lift_sparse_tuning_f Sparse_Midi_Tuning_f
tn_f st
st Midi
k = (st
st,Sparse_Midi_Tuning_f
tn_f Midi
k)

-- | (t,c,k) where
--   t=tuning (must have 12 divisions of octave),
--   c=cents deviation (ie. constant detune offset),
--   k=midi offset (ie. value to be added to incoming midi note number).
type D12_Midi_Tuning = (Tuning,Cents,T.Midi)

-- | 'Midi_Tuning_f' for 'D12_Midi_Tuning'.
--
-- > let f = d12_midi_tuning_f (equal_temperament 12,0,0)
-- > map f [0..127] == zip [0..127] (repeat 0)
d12_midi_tuning_f :: D12_Midi_Tuning -> Midi_Tuning_f
d12_midi_tuning_f :: D12_Midi_Tuning -> Midi_Tuning_f
d12_midi_tuning_f (Tuning
t,Double
c_diff,Midi
k) Midi
n =
    let (Midi
_,Midi
pc) = Midi -> (Midi, Midi)
T.midi_to_octpc (Midi
n forall a. Num a => a -> a -> a
+ Midi
k)
        dt :: [Double]
dt = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (-) (Tuning -> [Double]
tn_cents Tuning
t) [Double
0,Double
100 .. Double
1200]
    in if Tuning -> Midi
tn_divisions Tuning
t forall a. Eq a => a -> a -> Bool
/= Midi
12
       then forall a. HasCallStack => [Char] -> a
error [Char]
"d12_midi_tuning_f: not d12"
       else case [Double]
dt forall a. [a] -> Midi -> Maybe a
`Safe.atMay` Midi
pc of
              Maybe Double
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"d12_midi_tuning_f: pc?"
              Just Double
c -> (Midi
n,Double
c forall a. Num a => a -> a -> a
+ Double
c_diff)

-- | (t,f0,k,g) where
--   t=tuning, f0=fundamental-frequency, k=midi-note-number (for f0), g=gamut
type Cps_Midi_Tuning = (Tuning,Double,T.Midi,Int)

-- | 'Midi_Tuning_f' for 'Cps_Midi_Tuning'.  The function is sparse, it is only
-- valid for /g/ values from /k/.
--
-- > import qualified Music.Theory.Pitch as T
-- > let f = cps_midi_tuning_f (equal_temperament 72,T.midi_to_cps 59,59,72 * 4)
-- > map f [59 .. 59 + 72]
cps_midi_tuning_f :: Cps_Midi_Tuning -> Sparse_Midi_Tuning_f
cps_midi_tuning_f :: Cps_Midi_Tuning -> Sparse_Midi_Tuning_f
cps_midi_tuning_f (Tuning
t,Double
f0,Midi
k,Midi
g) Midi
n =
    let r :: [Double]
r = Tuning -> [Double]
tn_approximate_ratios_cyclic Tuning
t
        m :: [Midi_Detune]
m = forall a. Midi -> [a] -> [a]
take Midi
g (forall a b. (a -> b) -> [a] -> [b]
map (Double -> Midi_Detune
T.cps_to_midi_detune forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
* Double
f0)) [Double]
r)
    in [Midi_Detune]
m forall a. [a] -> Midi -> Maybe a
`Safe.atMay` Midi -> Midi
T.midi_to_int (Midi
n forall a. Num a => a -> a -> a
- Midi
k)

-- * Midi tuning tables.

-- | midi-note-number -> fractional-midi-note-number table, possibly sparse.
type Mnn_Fmnn_Table = [(Int,Double)]

-- | Load 'Mnn_Fmnn_Table' from two-column Csv file.
mnn_fmnn_table_load_csv :: FilePath -> IO Mnn_Fmnn_Table
mnn_fmnn_table_load_csv :: [Char] -> IO [Midi_Detune]
mnn_fmnn_table_load_csv [Char]
fn = do
  [Char]
s <- [Char] -> IO [Char]
readFile [Char]
fn
  let f :: [Char] -> (a, b)
f [Char]
x = case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
',') [Char]
x of
              ([Char]
lhs,Char
_:[Char]
rhs) -> (forall a. Read a => [Char] -> a
read [Char]
lhs,forall a. Read a => [Char] -> a
read [Char]
rhs)
              ([Char], [Char])
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"mnn_fmidi_table_load_csv?"
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b}. (Read a, Read b) => [Char] -> (a, b)
f ([Char] -> [[Char]]
lines [Char]
s))

-- | Midi-note-number -> Cps table, possibly sparse.
type Mnn_Cps_Table = [(T.Midi,Double)]

-- | Generates 'Mnn_Cps_Table' given 'Midi_Tuning_f' with keys for all valid @Mnn@.
--
-- > import Sound.SC3.Plot
-- > let f = cps_midi_tuning_f (equal_temperament 12,T.midi_to_cps 0,0,127)
-- > plot_p2_ln [map (fmap round) (gen_cps_tuning_tbl f)]
gen_cps_tuning_tbl :: Sparse_Midi_Tuning_f -> Mnn_Cps_Table
gen_cps_tuning_tbl :: Sparse_Midi_Tuning_f -> [Midi_Detune]
gen_cps_tuning_tbl Sparse_Midi_Tuning_f
tn_f =
    let f :: Sparse_Midi_Tuning_f
f Midi
n = case Sparse_Midi_Tuning_f
tn_f Midi
n of
                Just Midi_Detune
r -> forall a. a -> Maybe a
Just (Midi
n,forall m c. (Integral m, Real c) => (m, c) -> Double
T.midi_detune_to_cps Midi_Detune
r)
                Maybe Midi_Detune
Nothing -> forall a. Maybe a
Nothing
    in forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Sparse_Midi_Tuning_f
f [Midi
0 .. Midi
127]

-- * Derived (secondary) tuning table (DTT) lookup.

-- | Given an 'Mnn_Cps_Table' /tbl/, a list of @Cps@ /c/, and a @Mnn@ /m/
-- find the @Cps@ in /c/ that is nearest to the @Cps@ in /t/ for /m/.
-- In equal distance cases bias left.
dtt_lookup :: (Eq k, Num v, Ord v) => [(k,v)] -> [v] -> k -> (Maybe v,Maybe v)
dtt_lookup :: forall k v.
(Eq k, Num v, Ord v) =>
[(k, v)] -> [v] -> k -> (Maybe v, Maybe v)
dtt_lookup [(k, v)]
tbl [v]
cps k
n =
    let f :: Maybe v
f = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup k
n [(k, v)]
tbl
    in (Maybe v
f,forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall n. (Num n, Ord n) => Bool -> [n] -> n -> n
T.find_nearest_err Bool
True [v]
cps) Maybe v
f)

-- | Require table be non-sparse.
dtt_lookup_err :: (Eq k, Num v, Ord v) => [(k,v)] -> [v] -> k -> (k,v,v)
dtt_lookup_err :: forall k v.
(Eq k, Num v, Ord v) =>
[(k, v)] -> [v] -> k -> (k, v, v)
dtt_lookup_err [(k, v)]
tbl [v]
cps k
n =
    case forall k v.
(Eq k, Num v, Ord v) =>
[(k, v)] -> [v] -> k -> (Maybe v, Maybe v)
dtt_lookup [(k, v)]
tbl [v]
cps k
n of
      (Just v
f,Just v
g) -> (k
n,v
f,v
g)
      (Maybe v, Maybe v)
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"dtt_lookup"

-- | Given two tuning tables generate the @dtt@ table.
gen_dtt_lookup_tbl :: Mnn_Cps_Table -> Mnn_Cps_Table -> Mnn_Cps_Table
gen_dtt_lookup_tbl :: [Midi_Detune] -> [Midi_Detune] -> [Midi_Detune]
gen_dtt_lookup_tbl [Midi_Detune]
t0 [Midi_Detune]
t1 =
    let ix :: [Midi]
ix = [Midi
0..Midi
127]
        cps :: [Double]
cps = forall a. Ord a => [a] -> [a]
sort (forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a, b, c) -> c
T.p3_third forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v.
(Eq k, Num v, Ord v) =>
[(k, v)] -> [v] -> k -> (k, v, v)
dtt_lookup_err [Midi_Detune]
t0 (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [Midi_Detune]
t1)) [Midi]
ix)
    in forall a b. [a] -> [b] -> [(a, b)]
zip [Midi]
ix [Double]
cps

gen_dtt_lookup_f :: Mnn_Cps_Table -> Mnn_Cps_Table -> Midi_Tuning_f
gen_dtt_lookup_f :: [Midi_Detune] -> [Midi_Detune] -> Midi_Tuning_f
gen_dtt_lookup_f [Midi_Detune]
t0 [Midi_Detune]
t1 =
    let m :: Map Midi Double
m = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Midi_Detune] -> [Midi_Detune] -> [Midi_Detune]
gen_dtt_lookup_tbl [Midi_Detune]
t0 [Midi_Detune]
t1)
    in Double -> Midi_Detune
T.cps_to_midi_detune forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k c. Ord k => Map k c -> k -> c
T.map_ix_err Map Midi Double
m