{- | Scala "keyboard mapping" files (.kbm) and related data structure.

<http://www.huygens-fokker.org/scala/help.htm#mappings>
-}
module Music.Theory.Tuning.Scala.Kbm where

import Data.List {- base -}
import Data.Maybe {- base -}
import System.FilePath {- filepath -}
import Text.Printf {- base -}

import qualified Music.Theory.Directory as Directory {- hmt -}
import qualified Music.Theory.List as List {- hmt -}
import qualified Music.Theory.Pitch as Pitch {- hmt -}
import qualified Music.Theory.Tuning as Tuning {- hmt -}
import qualified Music.Theory.Tuning.Scala as Scala {- hmt -}

{- | Scala keyboard mapping

(sz,(m0,mN),mC,(mF,f),o,m)

- sz      = size of map, the pattern repeats every so many keys
- (m0,mN) = the first and last midi note numbers to retune
- mC      = the middle note where the first entry of the mapping is mapped to
- (mF,f)  = the reference midi-note for which a frequency is given, ie. (69,440)
- o       = scale degree to consider as formal octave
- m       = mapping, numbers represent scale degrees mapped to keys, Nothing indicates no mapping

-}
type Kbm = (Int,(Int,Int),Int,(Int,Double),Int,[Maybe Int])

-- | Pretty-printer for scala .kbm file.
kbm_pp :: Kbm -> String
kbm_pp :: Kbm -> String
kbm_pp (Int
sz,(Int
m0,Int
mN),Int
mC,(Int
mF,Double
f),Int
o,[Maybe Int]
m) =
  [String] -> String
unlines
  [forall r. PrintfType r => String -> r
printf String
"size = %d" Int
sz
  ,forall r. PrintfType r => String -> r
printf String
"note-range = (%d,%d)" Int
m0 Int
mN
  ,forall r. PrintfType r => String -> r
printf String
"note-center = %d" Int
mC
  ,forall r. PrintfType r => String -> r
printf String
"note-reference = (%d,%f)" Int
mF Double
f
  ,forall r. PrintfType r => String -> r
printf String
"formal-octave = %d" Int
o
  ,forall r. PrintfType r => String -> r
printf String
"map = [%s] #%d" (forall a. [a] -> [[a]] -> [a]
intercalate String
"," (forall a b. (a -> b) -> [a] -> [b]
map (forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"x" forall a. Show a => a -> String
show) [Maybe Int]
m)) (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe Int]
m)]

-- | Is /mnn/ in range?
kbm_in_rng :: Kbm -> Int -> Bool
kbm_in_rng :: Kbm -> Int -> Bool
kbm_in_rng (Int
_,(Int
m0,Int
mN),Int
_,(Int, Double)
_,Int
_,[Maybe Int]
_) Int
mnn = Int
mnn forall a. Ord a => a -> a -> Bool
>= Int
m0 Bool -> Bool -> Bool
&& Int
mnn forall a. Ord a => a -> a -> Bool
<= Int
mN

-- | Is /kbm/ linear?, ie. is size zero? (formal-octave may or may not be zero)
kbm_is_linear :: Kbm -> Bool
kbm_is_linear :: Kbm -> Bool
kbm_is_linear (Int
sz,(Int, Int)
_,Int
_,(Int, Double)
_,Int
_o,[Maybe Int]
_) = Int
sz forall a. Eq a => a -> a -> Bool
== Int
0 -- && o == 0

{- | Given kbm and midi-note-number lookup (octave,scale-degree).

> k <- kbm_load_dist "example.kbm" -- 12-tone scale
> k <- kbm_load_dist "a440.kbm" -- linear
> k <- kbm_load_dist "white.kbm" -- 7-tone scale on white notes
> k <- kbm_load_dist "black.kbm" -- 5-tone scale on black notes
> k <- kbm_load_dist "128.kbm"

> map (kbm_lookup k) [48 .. 72]

-}
kbm_lookup :: Kbm -> Int -> Maybe (Int,Int)
kbm_lookup :: Kbm -> Int -> Maybe (Int, Int)
kbm_lookup Kbm
kbm Int
mnn =
  if Bool -> Bool
not (Kbm -> Int -> Bool
kbm_in_rng Kbm
kbm Int
mnn)
  then forall a. Maybe a
Nothing
  else if Kbm -> Bool
kbm_is_linear Kbm
kbm
       then forall a. a -> Maybe a
Just (Int
0,Int
mnn)
       else let (Int
sz,(Int
_m0,Int
_mN),Int
mC,(Int
_mF,Double
_f),Int
_o,[Maybe Int]
m) = Kbm
kbm
                (Int
oct,Int
ix) = ((Int
mnn forall a. Num a => a -> a -> a
- Int
mC) forall a. Integral a => a -> a -> (a, a)
`divMod` Int
sz)
            in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Int
dgr -> (Int
oct,Int
dgr)) ([Maybe Int]
m forall a. [a] -> Int -> a
!! Int
ix)

-- | Return the triple (mF,kbm_lookup k mF,f).  The lookup for mF is not-nil by definition.
--
-- > kbm_lookup_mF k
kbm_lookup_mF :: Kbm -> (Int,(Int,Int),Double)
kbm_lookup_mF :: Kbm -> (Int, (Int, Int), Double)
kbm_lookup_mF k :: Kbm
k@(Int
_,(Int, Int)
_,Int
_,(Int
mF,Double
f),Int
_,[Maybe Int]
_) =
  case Kbm -> Int -> Maybe (Int, Int)
kbm_lookup Kbm
k Int
mF of
    Maybe (Int, Int)
Nothing -> forall a. HasCallStack => String -> a
error String
"kbm_lookup_mF?"
    Just (Int, Int)
r -> (Int
mF,(Int, Int)
r,Double
f)

-- | Parser for scala .kbm file.
kbm_parse :: String -> Kbm
kbm_parse :: String -> Kbm
kbm_parse String
s =
  let f :: String -> Maybe a
f String
x = case String
x of
              String
"x" -> forall a. Maybe a
Nothing
              String
_ -> forall a. a -> Maybe a
Just (forall a. Read a => String -> a
read String
x)
      to_m :: Int -> [String] -> [Maybe a]
to_m Int
sz = forall a. a -> Int -> [a] -> [a]
List.pad_right_no_truncate forall a. Maybe a
Nothing Int
sz forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Read a => String -> Maybe a
f -- _err -- some scala .kbm have |m| > sz?
  in case [String] -> [String]
Scala.filter_comments (String -> [String]
lines String
s) of
       String
i1:String
i2:String
i3:String
i4:String
i5:String
d1:String
i6:[String]
m ->
         let sz :: Int
sz = forall a. Read a => String -> a
read String
i1
         in (Int
sz,(forall a. Read a => String -> a
read String
i2,forall a. Read a => String -> a
read String
i3),forall a. Read a => String -> a
read String
i4,(forall a. Read a => String -> a
read String
i5,forall a. Read a => String -> a
read String
d1),forall a. Read a => String -> a
read String
i6,forall {a}. Read a => Int -> [String] -> [Maybe a]
to_m Int
sz [String]
m)
       [String]
_ -> forall a. HasCallStack => String -> a
error String
"kbm_parse?"

-- | 'kbm_parse' of 'readFile'
kbm_load_file :: FilePath -> IO Kbm
kbm_load_file :: String -> IO Kbm
kbm_load_file = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Kbm
kbm_parse forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO String
readFile

{- | 'kbm_parse' of 'Scala.load_dist_file'

> pp nm = kbm_load_dist nm >>= \x -> putStrLn (kbm_pp x)
> pp "example"
> pp "bp"
> pp "7" -- error -- 12/#13
> pp "8" -- error -- 12/#13
> pp "white" -- error -- 12/#13
> pp "black" -- error -- 12/#13
> pp "128"
> pp "a440"
> pp "61"
-}
kbm_load_dist :: String -> IO Kbm
kbm_load_dist :: String -> IO Kbm
kbm_load_dist String
nm = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Kbm
kbm_parse (String -> IO String
Scala.load_dist_file (String
nm String -> String -> String
<.> String
"kbm"))

-- | If /nm/ is a file name (has a .kbm) extension run 'kbm_load_file' else run 'kbm_load_dist'.
kbm_load :: String -> IO Kbm
kbm_load :: String -> IO Kbm
kbm_load String
nm = if String -> Bool
hasExtension String
nm then String -> IO Kbm
kbm_load_file String
nm else String -> IO Kbm
kbm_load_dist String
nm

-- | Load all .kbm files at directory.
kbm_load_dir_fn :: FilePath -> IO [(FilePath, Kbm)]
kbm_load_dir_fn :: String -> IO [(String, Kbm)]
kbm_load_dir_fn String
d = do
  [String]
fn <- [String] -> String -> IO [String]
Directory.dir_subset [String
".kbm"] String
d
  [Kbm]
kbm <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO Kbm
kbm_load [String]
fn
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. [a] -> [b] -> [(a, b)]
zip [String]
fn [Kbm]
kbm)

{- | Load all .kbm files at scala dist dir.

> db <- kbm_load_dist_dir_fn
> length db == 41
> x = map (\(fn,(sz,_,_,_,o,m)) -> (System.FilePath.takeFileName fn,sz,length m,o)) db
> filter (\(_,i,j,_) -> i < j) x -- size < map-length
> filter (\(_,i,_,k) -> i == 0 && k == 0) x -- size and formal octave both zero

> map (\(fn,k) -> (System.FilePath.takeFileName fn,kbm_lookup_mF k)) db
-}
kbm_load_dist_dir_fn :: IO [(FilePath, Kbm)]
kbm_load_dist_dir_fn :: IO [(String, Kbm)]
kbm_load_dist_dir_fn = IO String
Scala.dist_get_dir forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO [(String, Kbm)]
kbm_load_dir_fn

{- | Pretty-printer for scala .kbm file.

> m <- kbm_load_dist "7.kbm"
> kbm_parse (kbm_format m) == m
> putStrLn $ kbm_pp m
-}
kbm_format :: Kbm -> String
kbm_format :: Kbm -> String
kbm_format (Int
i1,(Int
i2,Int
i3),Int
i4,(Int
i5,Double
d1),Int
i6,[Maybe Int]
m) =
  let from_m :: [Maybe Int] -> [String]
from_m = forall a b. (a -> b) -> [a] -> [b]
map (forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"x" forall a. Show a => a -> String
show)
  in [String] -> String
unlines ([forall a. Show a => a -> String
show Int
i1,forall a. Show a => a -> String
show Int
i2,forall a. Show a => a -> String
show Int
i3,forall a. Show a => a -> String
show Int
i4,forall a. Show a => a -> String
show Int
i5,forall a. Show a => a -> String
show Double
d1,forall a. Show a => a -> String
show Int
i6] forall a. [a] -> [a] -> [a]
++ [Maybe Int] -> [String]
from_m [Maybe Int]
m)

-- | 'writeFile' of 'kbm_format'
kbm_wr :: FilePath -> Kbm -> IO ()
kbm_wr :: String -> Kbm -> IO ()
kbm_wr String
fn = String -> String -> IO ()
writeFile String
fn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kbm -> String
kbm_format

{- | Standard 12-tone mapping with A=440hz (ie. example.kbm)

> fmap (== kbm_d12_a440) (kbm_load_dist "example.kbm")
> putStrLn $ kbm_pp kbm_d12_a440
-}
kbm_d12_a440 :: Kbm
kbm_d12_a440 :: Kbm
kbm_d12_a440 = (Int
12,(Int
0,Int
127),Int
60,(Int
69,Double
440.0),Int
12,forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just [Int
0 .. Int
11])

kbm_d12_c256 :: Kbm
kbm_d12_c256 :: Kbm
kbm_d12_c256 = (Int
12,(Int
0,Int
127),Int
60,(Int
60,Double
256.0),Int
12,forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just [Int
0 .. Int
11])

-- | Given size and note-center calculate relative octave and key
--   number (not scale degree) of the zero entry.
--
-- > map (kbm_k0 12) [59,60,61] == [(-4,1),(-5,0),(-5,11)]
kbm_k0 :: Int -> Int -> (Int,Int)
kbm_k0 :: Int -> Int -> (Int, Int)
kbm_k0 Int
sz Int
mC = let (Int
o,Int
r) = Int
mC forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
sz in (forall a. Num a => a -> a
negate Int
o,forall a. Num a => a -> a
negate Int
r forall a. Integral a => a -> a -> a
`mod` Int
sz)

-- | Given size and note-center calculate complete octave and key
-- number sequence (ie. for entries 0 - 127).
--
-- > map (zip [0..] . kbm_oct_key_seq 12) [59,60,61]
kbm_oct_key_seq :: Kbm -> [(Int,(Int,Int))]
kbm_oct_key_seq :: Kbm -> [(Int, (Int, Int))]
kbm_oct_key_seq (Int
sz,(Int
m0,Int
mN),Int
mC,(Int
_mF,Double
_f),Int
_o,[Maybe Int]
_m) =
  let (Int
o0,Int
k0) = Int -> Int -> (Int, Int)
kbm_k0 Int
sz Int
mC
      dgr :: [Int]
dgr = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Integral a => a -> a -> a
`mod` Int
sz) (forall a. Int -> [a] -> [a]
take Int
128 [Int
k0 ..])
      upd :: a -> b -> (a, (a, b))
upd a
o b
j = if b
j forall a. Eq a => a -> a -> Bool
== b
0 then (a
o forall a. Num a => a -> a -> a
+ a
1,(a
o forall a. Num a => a -> a -> a
+ a
1,b
j)) else (a
o,(a
o,b
j))
      key_seq :: [(Int, Int)]
key_seq = forall a b. (a, b) -> b
snd (forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL forall {b} {a}. (Eq b, Num b, Num a) => a -> b -> (a, (a, b))
upd (Int
o0 forall a. Num a => a -> a -> a
- Int
1) [Int]
dgr)
  in forall a b. [a] -> [b] -> [(a, b)]
zip [Int
m0 .. ] (forall a. Int -> [a] -> [a]
take (Int
mN forall a. Num a => a -> a -> a
- Int
m0 forall a. Num a => a -> a -> a
+ Int
1) (forall a. Int -> [a] -> [a]
drop Int
m0 [(Int, Int)]
key_seq))

-- | Given Kbm and SCL calculate frequency of note-center.
kbm_mC_freq :: Kbm -> Scala.Scale -> Double
kbm_mC_freq :: Kbm -> Scale -> Double
kbm_mC_freq (Int
sz,(Int
_m0,Int
_mN),Int
mC,(Int
mF,Double
f),Int
_o,[Maybe Int]
m) Scale
scl =
  let dist_k :: Int
dist_k = (Int
mF forall a. Num a => a -> a -> a
- Int
mC) forall a. Integral a => a -> a -> a
`mod` Int
sz
      dgr :: Int
dgr = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"kbm_mC_freq") ([Maybe Int]
m forall a. [a] -> Int -> a
!! Int
dist_k)
      c :: Double
c = Scale -> [Double]
Scala.scale_cents Scale
scl forall a. [a] -> Int -> a
!! Int
dgr
  in forall a. Floating a => a -> a -> a
Tuning.cps_shift_cents Double
f (- Double
c)

-- | Given Kbm and SCL calculate fractional midi note-numbers for each key.
kbm_fmidi_tbl :: Kbm -> Scala.Scale -> [(Int, Double)]
kbm_fmidi_tbl :: Kbm -> Scale -> [(Int, Double)]
kbm_fmidi_tbl Kbm
kbm Scale
scl =
  let (Int
_sz,(Int
_m0,Int
_mN),Int
_mC,(Int
_mF,Double
_f),Int
o,[Maybe Int]
m) = Kbm
kbm
      mC_freq :: Double
mC_freq = Kbm -> Scale -> Double
kbm_mC_freq Kbm
kbm Scale
scl
      mC_fmidi :: Double
mC_fmidi = forall a. Floating a => a -> a
Pitch.cps_to_fmidi Double
mC_freq
      key_seq :: [(Int, (Int, Int))]
key_seq = Kbm -> [(Int, (Int, Int))]
kbm_oct_key_seq Kbm
kbm
      c :: [Double]
c = Scale -> [Double]
Scala.scale_cents Scale
scl
      oct_cents :: Double
oct_cents = [Double]
c forall a. [a] -> Int -> a
!! Int
o
      oct_key_to_cents :: (a, Int) -> Double
oct_key_to_cents (a
oct,Int
key) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Double
0 ([Double]
c forall a. [a] -> Int -> a
!!) ([Maybe Int]
m forall a. [a] -> Int -> a
!! Int
key) forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
oct forall a. Num a => a -> a -> a
* Double
oct_cents)
  in forall a b. (a -> b) -> [a] -> [b]
map (\(Int
mnn,(Int, Int)
oct_key) -> (Int
mnn,Double
mC_fmidi forall a. Num a => a -> a -> a
+ (forall {a}. Integral a => (a, Int) -> Double
oct_key_to_cents (Int, Int)
oct_key forall a. Fractional a => a -> a -> a
/ Double
100.0))) [(Int, (Int, Int))]
key_seq

-- | Given Kbm and SCL calculate frequencies for each key.
kbm_cps_tbl :: Kbm -> Scala.Scale -> [(Int, Double)]
kbm_cps_tbl :: Kbm -> Scale -> [(Int, Double)]
kbm_cps_tbl Kbm
kbm = let f :: (a, b) -> (a, b)
f (a
k,b
n) = (a
k,forall a. Floating a => a -> a
Tuning.fmidi_to_cps b
n) in forall a b. (a -> b) -> [a] -> [b]
map forall {b} {a}. Floating b => (a, b) -> (a, b)
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kbm -> Scale -> [(Int, Double)]
kbm_fmidi_tbl Kbm
kbm

{-

scl <- Scala.scl_load "young-lm_piano"
scl <- Scala.scl_load "meanquar"
scl <- Scala.scl_load "et12"
kbm <- kbm_load "example" -- d12_a440 -- kbm_d12_a440 kbm_d12_c256

kbm_fmidi_tbl kbm scl
kbm_cps_tbl kbm scl

-}