{- | Parser for the Scala scale file format.

See <http://www.huygens-fokker.org/scala/scl_format.html> for details.

This module succesfully parses all scales in v.91 of the scale library.

-}
module Music.Theory.Tuning.Scala where

import Control.Monad {- base -}
import Data.Either {- base -}
import Data.List {- base -}
import Data.Maybe {- base -}
import Data.Ratio {- base -}
import System.Directory {- directory -}
import System.Environment {- base -}
import System.FilePath {- filepath -}

import qualified Music.Theory.Array.Csv as Csv {- hmt -}
import qualified Music.Theory.Directory as Directory {- hmt -}
import qualified Music.Theory.Either as Either {- hmt -}
import qualified Music.Theory.Function as Function {- hmt -}
import qualified Music.Theory.Io as Io {- hmt -}
import qualified Music.Theory.List as List {- hmt -}
import qualified Music.Theory.Math.Prime as Prime {- hmt -}
import qualified Music.Theory.Read as T {- hmt -}
import qualified Music.Theory.Show as T {- hmt -}
import qualified Music.Theory.String as T {- hmt -}
import qualified Music.Theory.Tuning as T {- hmt -}
import qualified Music.Theory.Tuning.Type as T {- hmt -}

-- * Pitch

-- | A @.scl@ pitch is either in 'Cents' or is a 'Ratio'.
type Pitch = Either T.Cents Rational

-- | An enumeration type for @.scl@ pitch classification.
data Pitch_Type = Pitch_Cents | Pitch_Ratio deriving (Pitch_Type -> Pitch_Type -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Pitch_Type -> Pitch_Type -> Bool
$c/= :: Pitch_Type -> Pitch_Type -> Bool
== :: Pitch_Type -> Pitch_Type -> Bool
$c== :: Pitch_Type -> Pitch_Type -> Bool
Eq,Int -> Pitch_Type -> ShowS
[Pitch_Type] -> ShowS
Pitch_Type -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Pitch_Type] -> ShowS
$cshowList :: [Pitch_Type] -> ShowS
show :: Pitch_Type -> String
$cshow :: Pitch_Type -> String
showsPrec :: Int -> Pitch_Type -> ShowS
$cshowsPrec :: Int -> Pitch_Type -> ShowS
Show)

-- | A nearness value for deriving approximate rationals.
type Epsilon = Double

-- | Derive 'Pitch_Type' from 'Pitch'.
pitch_type :: Pitch -> Pitch_Type
pitch_type :: Pitch -> Pitch_Type
pitch_type = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const Pitch_Type
Pitch_Cents) (forall a b. a -> b -> a
const Pitch_Type
Pitch_Ratio)

-- | Pitch as 'T.Cents', conversion by 'T.ratio_to_cents' if necessary.
pitch_cents :: Pitch -> T.Cents
pitch_cents :: Pitch -> Cents
pitch_cents Pitch
p =
    case Pitch
p of
      Left Cents
c -> Cents
c
      Right Rational
r -> forall i. Integral i => Ratio i -> Cents
T.ratio_to_cents Rational
r

-- | Pitch as 'Rational', conversion by 'T.reconstructed_ratio' if
-- necessary, hence /epsilon/.
pitch_ratio :: Epsilon -> Pitch -> Rational
pitch_ratio :: Cents -> Pitch -> Rational
pitch_ratio Cents
epsilon Pitch
p =
    case Pitch
p of
      Left Cents
c -> Cents -> Cents -> Rational
T.reconstructed_ratio Cents
epsilon Cents
c
      Right Rational
r -> Rational
r

-- | A pair giving the number of 'Cents' and number of 'Ratio' pitches.
pitch_representations :: [Pitch] -> (Int,Int)
pitch_representations :: [Pitch] -> (Int, Int)
pitch_representations =
    let f :: (a, b) -> Either a b -> (a, b)
f (a
l,b
r) Either a b
p = case Either a b
p of
                      Left a
_ -> (a
l forall a. Num a => a -> a -> a
+ a
1,b
r)
                      Right b
_ -> (a
l,b
r forall a. Num a => a -> a -> a
+ b
1)
    in forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {a} {b} {a} {b}.
(Num a, Num b) =>
(a, b) -> Either a b -> (a, b)
f (Int
0,Int
0)

-- | If scale is uniform, give type.
uniform_pitch_type :: [Pitch] -> Maybe Pitch_Type
uniform_pitch_type :: [Pitch] -> Maybe Pitch_Type
uniform_pitch_type [Pitch]
p =
    case [Pitch] -> (Int, Int)
pitch_representations [Pitch]
p of
      (Int
0,Int
_) -> forall a. a -> Maybe a
Just Pitch_Type
Pitch_Ratio
      (Int
_,Int
0) -> forall a. a -> Maybe a
Just Pitch_Type
Pitch_Cents
      (Int, Int)
_ -> forall a. Maybe a
Nothing

-- | The predominant type of the pitches for 'Scale'.
pitch_type_predominant :: [Pitch] -> Pitch_Type
pitch_type_predominant :: [Pitch] -> Pitch_Type
pitch_type_predominant [Pitch]
p =
    let (Int
c,Int
r) = [Pitch] -> (Int, Int)
pitch_representations [Pitch]
p
    in if Int
c forall a. Ord a => a -> a -> Bool
>= Int
r then Pitch_Type
Pitch_Cents else Pitch_Type
Pitch_Ratio

-- * Scale

-- | A scale has a name, a description, a degree, and a sequence of pitches.
--   The /name/ is the the file-name without the /.scl/ suffix.
--   By convention the first comment line gives the file name (with suffix).
--   The pitches do NOT include 1:1 or 0c and do include the octave.
type Scale = (String,String,Int,[Pitch])

-- | The name of a scale.
scale_name :: Scale -> String
scale_name :: Scale -> String
scale_name (String
nm,String
_,Int
_,[Pitch]
_) = String
nm

-- | Text description of a scale.
scale_description :: Scale -> String
scale_description :: Scale -> String
scale_description (String
_,String
d,Int
_,[Pitch]
_) = String
d

-- | The degree of the scale (number of 'Pitch'es).
scale_degree :: Scale -> Int
scale_degree :: Scale -> Int
scale_degree (String
_,String
_,Int
n,[Pitch]
_) = Int
n

-- | The 'Pitch'es at 'Scale'.
scale_pitches :: Scale -> [Pitch]
scale_pitches :: Scale -> [Pitch]
scale_pitches (String
_,String
_,Int
_,[Pitch]
p) = [Pitch]
p

-- | Is 'Pitch' outside of the standard octave (ie. cents 0-1200 and ratios 1-2)
pitch_non_oct :: Pitch -> Bool
pitch_non_oct :: Pitch -> Bool
pitch_non_oct Pitch
p =
  case Pitch
p of
    Left Cents
c -> Cents
c forall a. Ord a => a -> a -> Bool
< Cents
0 Bool -> Bool -> Bool
|| Cents
c forall a. Ord a => a -> a -> Bool
> Cents
1200
    Right Rational
r -> Rational
r forall a. Ord a => a -> a -> Bool
< Rational
1 Bool -> Bool -> Bool
|| Rational
r forall a. Ord a => a -> a -> Bool
> Rational
2

-- | Ensure degree and number of pitches align.
scale_verify :: Scale -> Bool
scale_verify :: Scale -> Bool
scale_verify (String
_,String
_,Int
n,[Pitch]
p) = Int
n forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pitch]
p

-- | Raise error if scale doesn't verify, else 'id'.
scale_verify_err :: Scale -> Scale
scale_verify_err :: Scale -> Scale
scale_verify_err Scale
scl = if Scale -> Bool
scale_verify Scale
scl then Scale
scl else forall a. HasCallStack => String -> a
error (String
"invalid scale: " forall a. [a] -> [a] -> [a]
++ Scale -> String
scale_name Scale
scl)

-- | The last 'Pitch' element of the scale (ie. the /octave/).  For empty scales give 'Nothing'.
scale_octave :: Scale -> Maybe Pitch
scale_octave :: Scale -> Maybe Pitch
scale_octave (String
_,String
_,Int
_,[Pitch]
s) =
    case [Pitch]
s of
      [] -> forall a. Maybe a
Nothing
      [Pitch]
_ -> forall a. a -> Maybe a
Just (forall a. [a] -> a
last [Pitch]
s)

-- | Error variant.
scale_octave_err :: Scale -> Pitch
scale_octave_err :: Scale -> Pitch
scale_octave_err = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"scale_octave?") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scale -> Maybe Pitch
scale_octave

-- | Is 'scale_octave' perfect, ie. 'Ratio' of @2@ or 'Cents' of @1200@.
perfect_octave :: Scale -> Bool
perfect_octave :: Scale -> Bool
perfect_octave Scale
s =
  case Scale -> Maybe Pitch
scale_octave Scale
s of
    Just (Right Rational
2) -> Bool
True
    Just (Left Cents
1200.0) -> Bool
True
    Maybe Pitch
_ -> Bool
False

-- | Are all pitches of the same type.
is_scale_uniform :: Scale -> Bool
is_scale_uniform :: Scale -> Bool
is_scale_uniform = forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pitch] -> Maybe Pitch_Type
uniform_pitch_type forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scale -> [Pitch]
scale_pitches

-- | Are the pitches in ascending sequence.
is_scale_ascending :: Scale -> Bool
is_scale_ascending :: Scale -> Bool
is_scale_ascending = forall a. Ord a => [a] -> Bool
List.is_ascending forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Pitch -> Cents
pitch_cents forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scale -> [Pitch]
scale_pitches

-- | Make scale pitches uniform, conforming to the most predominant pitch type.
scale_uniform :: Epsilon -> Scale -> Scale
scale_uniform :: Cents -> Scale -> Scale
scale_uniform Cents
epsilon (String
nm,String
d,Int
n,[Pitch]
p) =
    case [Pitch] -> Pitch_Type
pitch_type_predominant [Pitch]
p of
      Pitch_Type
Pitch_Cents -> (String
nm,String
d,Int
n,forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pitch -> Cents
pitch_cents) [Pitch]
p)
      Pitch_Type
Pitch_Ratio -> (String
nm,String
d,Int
n,forall a b. (a -> b) -> [a] -> [b]
map (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cents -> Pitch -> Rational
pitch_ratio Cents
epsilon) [Pitch]
p)

-- | Scale as list of 'T.Cents' (ie. 'pitch_cents') with @0@ prefix.
scale_cents :: Scale -> [T.Cents]
scale_cents :: Scale -> [Cents]
scale_cents Scale
s = Cents
0 forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Pitch -> Cents
pitch_cents (Scale -> [Pitch]
scale_pitches Scale
s)

-- | 'map' 'round' of 'scale_cents'.
scale_cents_i :: Scale -> [T.Cents_I]
scale_cents_i :: Scale -> [Int]
scale_cents_i = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (RealFrac a, Integral b) => a -> b
round forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scale -> [Cents]
scale_cents

-- | Scale as list of 'Rational' (ie. 'pitch_ratio') with @1@ prefix.
scale_ratios :: Epsilon -> Scale -> [Rational]
scale_ratios :: Cents -> Scale -> [Rational]
scale_ratios Cents
epsilon Scale
s = Rational
1 forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Cents -> Pitch -> Rational
pitch_ratio Cents
epsilon) (Scale -> [Pitch]
scale_pitches Scale
s)

-- | Require that 'Scale' be uniformly of 'Ratio's.
scale_ratios_u :: Scale -> Maybe [Rational]
scale_ratios_u :: Scale -> Maybe [Rational]
scale_ratios_u Scale
scl =
  let err :: a
err = forall a. HasCallStack => String -> a
error String
"scale_ratios_u?"
      p :: [Pitch]
p = Scale -> [Pitch]
scale_pitches Scale
scl
  in case [Pitch] -> Maybe Pitch_Type
uniform_pitch_type [Pitch]
p of
       Just Pitch_Type
Pitch_Ratio -> forall a. a -> Maybe a
Just (Rational
1 forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> Maybe a -> a
fromMaybe forall {a}. a
err forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x t. Either x t -> Maybe t
Either.from_right) [Pitch]
p)
       Maybe Pitch_Type
_ -> forall a. Maybe a
Nothing

-- | Erroring variant of 'scale_ratios_u.
scale_ratios_req :: Scale -> [Rational]
scale_ratios_req :: Scale -> [Rational]
scale_ratios_req = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"scale_ratios_req") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scale -> Maybe [Rational]
scale_ratios_u

{- | Are scales equal ('==') at degree and tuning data.

> db <- scl_load_db
> let r = [2187/2048,9/8,32/27,81/64,4/3,729/512,3/2,6561/4096,27/16,16/9,243/128,2/1]
> let Just py = find (scale_eq ("","",length r,map Right r)) db
> scale_name py == "pyth_12"

'scale_eqv' provides an approximate equality function.

> let c = map T.ratio_to_cents r
> let Just py' = find (scale_eqv 0.00001 ("","",length c,map Left c)) db
> scale_name py' == "pyth_12"

-}
scale_eq :: Scale -> Scale -> Bool
scale_eq :: Scale -> Scale -> Bool
scale_eq (String
_,String
_,Int
d0,[Pitch]
p0) (String
_,String
_,Int
d1,[Pitch]
p1) = Int
d0 forall a. Eq a => a -> a -> Bool
== Int
d1 Bool -> Bool -> Bool
&& [Pitch]
p0 forall a. Eq a => a -> a -> Bool
== [Pitch]
p1

-- | Are scales equal at degree and 'intersect' to at least /k/ places of tuning data.
scale_eq_n :: Int -> Scale -> Scale -> Bool
scale_eq_n :: Int -> Scale -> Scale -> Bool
scale_eq_n Int
k (String
_,String
_,Int
d0,[Pitch]
p0) (String
_,String
_,Int
d1,[Pitch]
p1) = Int
d0 forall a. Eq a => a -> a -> Bool
== Int
d1 Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Pitch]
p0 forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Pitch]
p1) forall a. Ord a => a -> a -> Bool
>= Int
k

-- | Is `s1` a proper subset of `s2`.
scale_sub :: Scale -> Scale -> Bool
scale_sub :: Scale -> Scale -> Bool
scale_sub (String
_,String
_,Int
d0,[Pitch]
p0) (String
_,String
_,Int
d1,[Pitch]
p1) = Int
d0 forall a. Ord a => a -> a -> Bool
< Int
d1 Bool -> Bool -> Bool
&& forall a. Eq a => [a] -> [a] -> [a]
intersect [Pitch]
p0 [Pitch]
p1 forall a. Eq a => a -> a -> Bool
== [Pitch]
p0

-- | Are scales equal at degree and equivalent to within /epsilon/ at 'pitch_cents'.
scale_eqv :: Epsilon -> Scale -> Scale -> Bool
scale_eqv :: Cents -> Scale -> Scale -> Bool
scale_eqv Cents
epsilon (String
_,String
_,Int
d0,[Pitch]
p0) (String
_,String
_,Int
d1,[Pitch]
p1) =
    let ~= :: Pitch -> Pitch -> Bool
(~=) Pitch
p Pitch
q = forall a. Num a => a -> a
abs (Pitch -> Cents
pitch_cents Pitch
p forall a. Num a => a -> a -> a
- Pitch -> Cents
pitch_cents Pitch
q) forall a. Ord a => a -> a -> Bool
< Cents
epsilon
    in Int
d0 forall a. Eq a => a -> a -> Bool
== Int
d1 Bool -> Bool -> Bool
&& forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Pitch -> Pitch -> Bool
(~=) [Pitch]
p0 [Pitch]
p1)

-- * Parser

-- | Comment lines begin with @!@.
is_comment :: String -> Bool
is_comment :: String -> Bool
is_comment String
x =
    case String
x of
      Char
'!':String
_ -> Bool
True
      String
_ -> Bool
False

-- | Remove to end of line @!@ comments.
--
-- > remove_eol_comments " 1 ! comment" == " 1 "
remove_eol_comments :: String -> String
remove_eol_comments :: ShowS
remove_eol_comments = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'!')

-- | Remove comments and trailing comments (the description may be empty, keep nulls)
--
-- > filter_comments ["!a","b","","c","d!e"] == ["b","","c","d"]
filter_comments :: [String] -> [String]
filter_comments :: [String] -> [String]
filter_comments =
    forall a b. (a -> b) -> [a] -> [b]
map ShowS
remove_eol_comments forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. [t -> Bool] -> t -> Bool
Function.predicate_any [String -> Bool
is_comment])

-- | Pitches are either cents (with decimal point, possibly trailing) or ratios (with @/@).
--
-- > map parse_pitch ["70.0","350.","3/2","2","2/1"] == [Left 70,Left 350,Right (3/2),Right 2,Right 2]
parse_pitch :: String -> Pitch
parse_pitch :: String -> Pitch
parse_pitch String
p =
    if Char
'.' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
p
    then forall a b. a -> Either a b
Left (forall n. Read n => String -> n
T.read_fractional_allow_trailing_point_err String
p)
    else forall a b. b -> Either a b
Right (forall i. (Integral i, Read i) => String -> Ratio i
T.read_ratio_with_div_err String
p)

-- | Pitch lines may contain commentary.
parse_pitch_ln :: String -> Pitch
parse_pitch_ln :: String -> Pitch
parse_pitch_ln String
x =
    case String -> [String]
words String
x of
      String
p:[String]
_ -> String -> Pitch
parse_pitch String
p
      [String]
_ -> forall a. HasCallStack => String -> a
error (forall a. Show a => a -> String
show (String
"parse_pitch_ln",String -> [String]
words String
x))

-- | Parse @.scl@ file.
parse_scl :: String -> String -> Scale
parse_scl :: String -> String -> Scale
parse_scl String
nm String
s =
    case [String] -> [String]
filter_comments (String -> [String]
lines (ShowS
T.filter_cr String
s)) of
      String
t:String
n:[String]
p -> let scl :: Scale
scl = (String
nm
                         ,ShowS
T.delete_trailing_whitespace String
t
                         ,forall a. Read a => String -> String -> a
T.read_err_msg String
"degree" String
n
                         ,forall a b. (a -> b) -> [a] -> [b]
map String -> Pitch
parse_pitch_ln [String]
p)
               in Scale -> Scale
scale_verify_err Scale
scl
      [String]
_ -> forall a. HasCallStack => String -> a
error String
"parse"

-- * Io

-- | Read the environment variable @SCALA_SCL_DIR@, which is a
-- sequence of directories used to locate scala files on.
--
-- > setEnv "SCALA_SCL_DIR" "/home/rohan/data/scala/90/scl"
scl_get_dir :: IO [FilePath]
scl_get_dir :: IO [String]
scl_get_dir = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> [String]
splitSearchPath (String -> IO String
getEnv String
"SCALA_SCL_DIR")

-- | Lookup the @SCALA_SCL_DIR@ environment variable, which must exist, and derive the filepath.
-- It is an error if the name has a file extension.
--
-- > mapM scl_derive_filename ["young-lm_piano","et12"]
scl_derive_filename :: FilePath -> IO FilePath
scl_derive_filename :: String -> IO String
scl_derive_filename String
nm = do
  [String]
dir <- IO [String]
scl_get_dir
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
dir) (forall a. HasCallStack => String -> a
error String
"scl_derive_filename: SCALA_SCL_DIR: nil")
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Bool
hasExtension String
nm) (forall a. HasCallStack => String -> a
error String
"scl_derive_filename: name has extension")
  [String] -> String -> IO String
Directory.path_scan_err [String]
dir (String
nm String -> ShowS
<.> String
"scl")

-- | If the name is an absolute file path and has a @.scl@ extension,
-- then return it, else run 'scl_derive_filename'.
--
-- > scl_resolve_name "young-lm_piano"
-- > scl_resolve_name "/home/rohan/data/scala/90/scl/young-lm_piano.scl"
-- > scl_resolve_name "/home/rohan/data/scala/90/scl/unknown-tuning.scl"
scl_resolve_name :: String -> IO FilePath
scl_resolve_name :: String -> IO String
scl_resolve_name String
nm =
    let ex_f :: Bool -> m String
ex_f Bool
x = if Bool
x then forall (m :: * -> *) a. Monad m => a -> m a
return String
nm else forall a. HasCallStack => String -> a
error String
"scl_resolve_name: file does not exist"
    in if String -> Bool
isAbsolute String
nm Bool -> Bool -> Bool
&& ShowS
takeExtension String
nm forall a. Eq a => a -> a -> Bool
== String
".scl"
       then String -> IO Bool
doesFileExist String
nm forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *}. Monad m => Bool -> m String
ex_f
       else String -> IO String
scl_derive_filename String
nm

-- | Load @.scl@ file, runs 'resolve_scl'.
--
-- > s <- scl_load "xenakis_chrom"
-- > pitch_representations (scale_pitches s) == (6,1)
-- > scale_ratios 1e-3 s == [1,21/20,29/23,179/134,280/187,11/7,100/53,2]
scl_load :: String -> IO Scale
scl_load :: String -> IO Scale
scl_load String
nm = do
  String
fn <- String -> IO String
scl_resolve_name String
nm
  String
s <- String -> IO String
Io.read_file_iso_8859_1 String
fn
  forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String -> Scale
parse_scl (ShowS
takeBaseName String
nm) String
s)

{- | Load all @.scl@ files at /dir/, associate with file-name.

> db <- scl_load_dir_fn "/home/rohan/data/scala/91/scl"
> length db == 5176 -- v.91
> map (\(fn,s) -> (takeFileName fn,scale_name s)) db
-}
scl_load_dir_fn :: FilePath -> IO [(FilePath,Scale)]
scl_load_dir_fn :: String -> IO [(String, Scale)]
scl_load_dir_fn String
d = do
  [String]
fn <- [String] -> String -> IO [String]
Directory.dir_subset [String
".scl"] String
d
  [Scale]
scl <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO Scale
scl_load [String]
fn
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. [a] -> [b] -> [(a, b)]
zip [String]
fn [Scale]
scl)

-- | 'snd' of 'scl_load_dir_fn'
scl_load_dir :: FilePath -> IO [Scale]
scl_load_dir :: String -> IO [Scale]
scl_load_dir = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO [(String, Scale)]
scl_load_dir_fn

-- | Load Scala data base at 'scl_get_dir'.
--
-- > db <- scl_load_db
-- > mapM_ (putStrLn . unlines . scale_stat) (filter (not . perfect_octave) db)
scl_load_db :: IO [Scale]
scl_load_db :: IO [Scale]
scl_load_db = do
  [String]
dir <- IO [String]
scl_get_dir
  [[Scale]]
r <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO [Scale]
scl_load_dir [String]
dir
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Scale]]
r)

-- * Pp

-- | <http://www.huygens-fokker.org/docs/scalesdir.txt>
scales_dir_txt_tbl :: [Scale] -> [[String]]
scales_dir_txt_tbl :: [Scale] -> [[String]]
scales_dir_txt_tbl =
  let f :: Scale -> [String]
f Scale
s = [Scale -> String
scale_name Scale
s,forall a. Show a => a -> String
show (Scale -> Int
scale_degree Scale
s),Scale -> String
scale_description Scale
s]
  in forall a b. (a -> b) -> [a] -> [b]
map Scale -> [String]
f

-- | Format as CSV file.
--
-- > db <- scl_load_db
-- > writeFile "/tmp/scl.csv" (scales_dir_txt_csv db)
scales_dir_txt_csv :: [Scale] -> String
scales_dir_txt_csv :: [Scale] -> String
scales_dir_txt_csv [Scale]
db = forall a. (a -> String) -> Csv_Opt -> Csv_Table a -> String
Csv.csv_table_pp forall a. a -> a
id Csv_Opt
Csv.def_csv_opt (forall a. Maybe a
Nothing,[Scale] -> [[String]]
scales_dir_txt_tbl [Scale]
db)

-- | Simple plain-text display of scale data.
--
-- > db <- scl_load_db
-- > writeFile "/tmp/scl.txt" (unlines (intercalate [""] (map scale_stat db)))
scale_stat :: Scale -> [String]
scale_stat :: Scale -> [String]
scale_stat Scale
s =
    let p :: [Pitch]
p = Scale -> [Pitch]
scale_pitches Scale
s
        u_ty :: Maybe Pitch_Type
u_ty = [Pitch] -> Maybe Pitch_Type
uniform_pitch_type [Pitch]
p
        n_ty :: String
n_ty = let p_ty :: Pitch_Type
p_ty = [Pitch] -> Pitch_Type
pitch_type_predominant [Pitch]
p
                   (Int
p_i,Int
p_j) = [Pitch] -> (Int, Int)
pitch_representations [Pitch]
p
               in forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"non-uniform (",forall a. Show a => a -> String
show Pitch_Type
p_ty,String
",",forall a. Show a => a -> String
show Int
p_i,String
":",forall a. Show a => a -> String
show Int
p_j,String
")"]
    in [String
"name        : " forall a. [a] -> [a] -> [a]
++ Scale -> String
scale_name Scale
s
       ,String
"description : " forall a. [a] -> [a] -> [a]
++ Scale -> String
scale_description Scale
s
       ,String
"degree      : " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Scale -> Int
scale_degree Scale
s)
       ,String
"type        : " forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
n_ty forall a. Show a => a -> String
show Maybe Pitch_Type
u_ty
       ,String
"perfect-oct : " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Scale -> Bool
perfect_octave Scale
s)
       ,String
"cents-i     : " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Scale -> [Int]
scale_cents_i Scale
s)
       ,if Maybe Pitch_Type
u_ty forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Pitch_Type
Pitch_Ratio
        then String
"ratios      : " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"," (forall a b. (a -> b) -> [a] -> [b]
map forall a. (Show a, Integral a) => Ratio a -> String
T.rational_pp (Scale -> [Rational]
scale_ratios_req Scale
s))
        else String
""]

-- | Pretty print 'Pitch' in @Scala@ format.
pitch_pp :: Pitch -> String
pitch_pp :: Pitch -> String
pitch_pp Pitch
p =
    case Pitch
p of
      Left Cents
c -> forall a. Show a => a -> String
show Cents
c
      Right Rational
r -> forall a. Show a => a -> String
show (forall a. Ratio a -> a
numerator Rational
r) forall a. [a] -> [a] -> [a]
++ String
"/" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Ratio a -> a
denominator Rational
r)

-- | Pretty print 'Scale' in @Scala@ format.
--
-- > scl <- scl_load "et19"
-- > scl <- scl_load "young-lm_piano"
-- > putStr $ unlines $ scale_pp scl
scale_pp :: Scale -> [String]
scale_pp :: Scale -> [String]
scale_pp (String
nm,String
dsc,Int
k,[Pitch]
p) =
    [String
"! " forall a. [a] -> [a] -> [a]
++ String
nm forall a. [a] -> [a] -> [a]
++ String
".scl"
    ,String
"!"
    ,String
dsc
    ,forall a. Show a => a -> String
show Int
k
    ,String
"!"] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Pitch -> String
pitch_pp [Pitch]
p

scale_wr :: FilePath -> Scale -> IO ()
scale_wr :: String -> Scale -> IO ()
scale_wr String
fn = String -> String -> IO ()
writeFile String
fn forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scale -> [String]
scale_pp

-- | Write /scl/ to /dir/ with the file-name 'scale_name'.scl
scale_wr_dir :: FilePath -> Scale -> IO ()
scale_wr_dir :: String -> Scale -> IO ()
scale_wr_dir String
dir Scale
scl = String -> Scale -> IO ()
scale_wr (String
dir String -> ShowS
</> Scale -> String
scale_name Scale
scl String -> ShowS
<.> String
"scl") Scale
scl

-- * Dist

-- | @scala@ distribution directory, given at @SCALA_DIST_DIR@.
--
-- > setEnv "SCALA_DIST_DIR" "/home/rohan/opt/build/scala-22"
dist_get_dir :: IO String
dist_get_dir :: IO String
dist_get_dir = String -> IO String
getEnv String
"SCALA_DIST_DIR"

-- | Load file from 'dist_get_dir'.
load_dist_file :: FilePath -> IO String
load_dist_file :: String -> IO String
load_dist_file String
nm = do
  String
d <- IO String
dist_get_dir
  String -> IO String
readFile (String
d String -> ShowS
</> String
nm)

{- | 'fmap' 'lines' 'load_dist_file'

> s <- load_dist_file_ln "intnam.par"
> length s == 565 -- Scala 2.46d
-}
load_dist_file_ln :: FilePath -> IO [String]
load_dist_file_ln :: String -> IO [String]
load_dist_file_ln = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> [String]
lines forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO String
load_dist_file

-- * Query

-- | Is scale just-intonation (ie. are all pitches ratios)
scl_is_ji :: Scale -> Bool
scl_is_ji :: Scale -> Bool
scl_is_ji = forall a. Eq a => a -> a -> Bool
(==) (forall a. a -> Maybe a
Just Pitch_Type
Pitch_Ratio) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pitch] -> Maybe Pitch_Type
uniform_pitch_type forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scale -> [Pitch]
scale_pitches

-- | Calculate limit for JI scale (ie. largest prime factor)
scl_ji_limit :: Scale -> Integer
scl_ji_limit :: Scale -> Integer
scl_ji_limit = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall i. Integral i => Ratio i -> [(i, Int)]
Prime.rational_prime_factors_m forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scale -> [Rational]
scale_ratios_req

-- | Sum of absolute differences to scale given in cents, sorted, with rotation.
scl_cdiff_abs_sum :: [T.Cents] -> Scale -> [(Double,[T.Cents],Int)]
scl_cdiff_abs_sum :: [Cents] -> Scale -> [(Cents, [Cents], Int)]
scl_cdiff_abs_sum [Cents]
c Scale
scl =
  let r :: [[Cents]]
r = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Num a => a -> [a] -> [a]
List.dx_d Cents
0) (forall a. [a] -> [[a]]
List.rotations (forall a. Num a => [a] -> [a]
List.d_dx (forall a. Ord a => [a] -> [a]
sort (Scale -> [Cents]
scale_cents Scale
scl))))
      ndiff :: [Cents] -> c -> (Cents, [Cents], c)
ndiff [Cents]
x c
i = let d :: [Cents]
d = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (-) [Cents]
c [Cents]
x in (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map forall a. Num a => a -> a
abs [Cents]
d),[Cents]
d,c
i)
  in forall a. Ord a => [a] -> [a]
sort (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {c}. [Cents] -> c -> (Cents, [Cents], c)
ndiff [[Cents]]
r [Int
0..])

{- | Variant selecting only nearest and with post-processing function.

> scl <- scl_load "holder"
> scale_cents_i scl
> c = [0,83,193,308,388,502,584,695,778,890,1004,1085,1200]
> (_,r,_) = scl_cdiff_abs_sum_1 round c scl
> r == [0,2,-1,1,0,-1,0,-1,0,0,0,0,0]
-}
scl_cdiff_abs_sum_1 :: (Double -> n) -> [T.Cents] -> Scale -> (Double,[n],Int)
scl_cdiff_abs_sum_1 :: forall n. (Cents -> n) -> [Cents] -> Scale -> (Cents, [n], Int)
scl_cdiff_abs_sum_1 Cents -> n
pp [Cents]
c Scale
scl =
  case [Cents] -> Scale -> [(Cents, [Cents], Int)]
scl_cdiff_abs_sum [Cents]
c Scale
scl of
    [] -> forall a. HasCallStack => String -> a
error String
"scl_cdiff_abs_sum_1"
    (Cents
n,[Cents]
d,Int
r):[(Cents, [Cents], Int)]
_ -> (Cents
n,forall a b. (a -> b) -> [a] -> [b]
map Cents -> n
pp [Cents]
d,Int
r)

{- | Sort DB into ascending order of sum of absolute of differences to scale given in cents.
     Scales are sorted and all rotations are considered.

> db <- scl_load_db
> c = [0,83,193,308,388,502,584,695,778,890,1004,1085,1200]
> r = scl_db_query_cdiff_asc round db c
> ((_,dx,_),_):_ = r
> dx == [0,2,-1,1,0,-1,0,-1,0,0,0,0,0]
> mapM_ (putStrLn . unlines . scale_stat . snd) (take 10 r)
-}
scl_db_query_cdiff_asc :: Ord n => (Double -> n) -> [Scale] -> [T.Cents] -> [((Double,[n],Int),Scale)]
scl_db_query_cdiff_asc :: forall n.
Ord n =>
(Cents -> n) -> [Scale] -> [Cents] -> [((Cents, [n], Int), Scale)]
scl_db_query_cdiff_asc Cents -> n
pp [Scale]
db [Cents]
c =
  let n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Cents]
c forall a. Num a => a -> a -> a
- Int
1
      db_n :: [Scale]
db_n = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== Int
n) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scale -> Int
scale_degree) [Scale]
db
  in forall a. Ord a => [a] -> [a]
sort (forall a b. (a -> b) -> [a] -> [b]
map (\Scale
scl -> (forall n. (Cents -> n) -> [Cents] -> Scale -> (Cents, [n], Int)
scl_cdiff_abs_sum_1 Cents -> n
pp [Cents]
c Scale
scl,Scale
scl)) [Scale]
db_n)

-- | Is /x/ the same scale as /scl/ under /cmp/.
scale_cmp_ji :: ([Rational] -> [Rational] -> Bool) -> [Rational] -> Scale -> Bool
scale_cmp_ji :: ([Rational] -> [Rational] -> Bool) -> [Rational] -> Scale -> Bool
scale_cmp_ji [Rational] -> [Rational] -> Bool
cmp [Rational]
x Scale
scl =
  case Scale -> Maybe [Rational]
scale_ratios_u Scale
scl of
    Maybe [Rational]
Nothing -> Bool
False
    Just [Rational]
r -> [Rational] -> [Rational] -> Bool
cmp [Rational]
x [Rational]
r

-- | Find scale(s) that are 'scale_cmp_ji' to /x/.
--   Usual /cmp/ are (==) and 'is_subset'.
scl_find_ji :: ([Rational] -> [Rational] -> Bool) -> [Rational] -> [Scale] -> [Scale]
scl_find_ji :: ([Rational] -> [Rational] -> Bool)
-> [Rational] -> [Scale] -> [Scale]
scl_find_ji [Rational] -> [Rational] -> Bool
cmp [Rational]
x = forall a. (a -> Bool) -> [a] -> [a]
filter (([Rational] -> [Rational] -> Bool) -> [Rational] -> Scale -> Bool
scale_cmp_ji [Rational] -> [Rational] -> Bool
cmp [Rational]
x)

-- * Tuning

-- | Translate 'Scale' to 'T.Tuning'.  If 'Scale' is uniformly
-- rational, 'T.Tuning' is rational, else it is in 'T.Cents'.
scale_to_tuning :: Scale -> T.Tuning
scale_to_tuning :: Scale -> Tuning
scale_to_tuning (String
_,String
_,Int
_,[Pitch]
p) =
    case forall a b. [Either a b] -> ([a], [b])
partitionEithers [Pitch]
p of
      ([],[Rational]
r) -> let ([Rational]
r',Rational
o) = forall a. [a] -> ([a], a)
List.separate_last [Rational]
r
                in Either [Rational] [Cents]
-> Maybe (Either Rational Cents) -> Tuning
T.Tuning (forall a b. a -> Either a b
Left (Rational
1 forall a. a -> [a] -> [a]
: [Rational]
r')) (if Rational
o forall a. Eq a => a -> a -> Bool
== Rational
2 then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (forall a b. a -> Either a b
Left Rational
o))
      ([Cents], [Rational])
_ -> let ([Pitch]
c,Pitch
o) = forall a. [a] -> ([a], a)
List.separate_last [Pitch]
p
               c' :: [Cents]
c' = Cents
0 forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Pitch -> Cents
pitch_cents [Pitch]
c
               o' :: Maybe (Either Rational Cents)
o' = if Pitch
o forall a. Eq a => a -> a -> Bool
== forall a b. a -> Either a b
Left Cents
1200 Bool -> Bool -> Bool
|| Pitch
o forall a. Eq a => a -> a -> Bool
== forall a b. b -> Either a b
Right Rational
2 then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (forall a b. Either a b -> Either b a
Either.either_swap Pitch
o)
           in Either [Rational] [Cents]
-> Maybe (Either Rational Cents) -> Tuning
T.Tuning (forall a b. b -> Either a b
Right [Cents]
c') Maybe (Either Rational Cents)
o'

-- | Convert 'T.Tuning' to 'Scale'.
--
-- > tuning_to_scale ("et12","12 tone equal temperament") (T.tn_equal_temperament 12)
tuning_to_scale :: (String,String) -> T.Tuning -> Scale
tuning_to_scale :: (String, String) -> Tuning -> Scale
tuning_to_scale (String
nm,String
dsc) tn :: Tuning
tn@(T.Tuning Either [Rational] [Cents]
p Maybe (Either Rational Cents)
_) =
    let n :: Int
n = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (t :: * -> *) a. Foldable t => t a -> Int
length forall (t :: * -> *) a. Foldable t => t a -> Int
length Either [Rational] [Cents]
p
        p' :: [Pitch]
p' = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
tail) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
tail) Either [Rational] [Cents]
p forall a. [a] -> [a] -> [a]
++ [forall a b. Either a b -> Either b a
Either.either_swap (Tuning -> Either Rational Cents
T.tn_octave_def Tuning
tn)]
    in (String
nm,String
dsc,Int
n,[Pitch]
p')

-- | 'scale_to_tuning' of 'scl_load'.
--
-- > fmap T.tn_limit (scl_load_tuning "pyra") -- Just 59
scl_load_tuning :: String -> IO T.Tuning
scl_load_tuning :: String -> IO Tuning
scl_load_tuning = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Scale -> Tuning
scale_to_tuning forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Scale
scl_load