module Music.Theory.Tuning.Scala where
import Control.Monad
import Data.Either
import Data.List
import Data.Maybe
import Data.Ratio
import System.Directory
import System.Environment
import System.FilePath
import qualified Music.Theory.Directory as T
import qualified Music.Theory.Either as T
import qualified Music.Theory.Function as T
import qualified Music.Theory.IO as T
import qualified Music.Theory.List as T
import qualified Music.Theory.Math as T
import qualified Music.Theory.Read as T
import qualified Music.Theory.String as T
import qualified Music.Theory.Tuning as T
type Pitch i = Either T.Cents (Ratio i)
data Pitch_Type = Pitch_Cents | Pitch_Ratio deriving (Eq,Show)
type Epsilon = Double
pitch_type :: Pitch i -> Pitch_Type
pitch_type = either (const Pitch_Cents) (const Pitch_Ratio)
pitch_cents :: Integral i => Pitch i -> T.Cents
pitch_cents p =
case p of
Left c -> c
Right r -> T.ratio_to_cents r
pitch_ratio :: Epsilon -> Pitch Integer -> Rational
pitch_ratio epsilon p =
case p of
Left c -> T.reconstructed_ratio epsilon c
Right r -> r
pitch_representations :: Integral t => [Pitch i] -> (t,t)
pitch_representations =
let f (l,r) p = case p of
Left _ -> (l + 1,r)
Right _ -> (l,r + 1)
in foldl f (0,0)
uniform_pitch_type :: [Pitch i] -> Maybe Pitch_Type
uniform_pitch_type p =
case pitch_representations p :: (Int,Int) of
(0,_) -> Just Pitch_Ratio
(_,0) -> Just Pitch_Cents
_ -> Nothing
pitch_type_predominant :: [Pitch i] -> Pitch_Type
pitch_type_predominant p =
let (c,r) = pitch_representations p :: (Int,Int)
in if c >= r then Pitch_Cents else Pitch_Ratio
type Scale i = (String,String,Int,[Pitch i])
scale_name :: Scale i -> String
scale_name (nm,_,_,_) = nm
scale_description :: Scale i -> String
scale_description (_,d,_,_) = d
scale_degree :: Scale i -> Int
scale_degree (_,_,n,_) = n
scale_pitches :: Scale i -> [Pitch i]
scale_pitches (_,_,_,p) = p
scale_verify :: Scale i -> Bool
scale_verify (_,_,n,p) = n == length p
scale_verify_err :: Scale i -> Scale i
scale_verify_err scl = if scale_verify scl then scl else error "invalid scale"
scale_octave :: Scale i -> Maybe (Pitch i)
scale_octave (_,_,_,s) =
case s of
[] -> Nothing
_ -> Just (last s)
perfect_octave :: Integral i => Scale i -> Bool
perfect_octave s = scale_octave s `elem` [Just (Right 2),Just (Left 1200)]
is_scale_uniform :: Scale i -> Bool
is_scale_uniform = isJust . uniform_pitch_type . scale_pitches
scale_uniform :: Epsilon -> Scale Integer -> Scale Integer
scale_uniform epsilon (nm,d,n,p) =
case pitch_type_predominant p of
Pitch_Cents -> (nm,d,n,map (Left . pitch_cents) p)
Pitch_Ratio -> (nm,d,n,map (Right . pitch_ratio epsilon) p)
scale_cents :: Integral i => Scale i -> [T.Cents]
scale_cents s = 0 : map pitch_cents (scale_pitches s)
scale_cents_i :: Integral i => Scale i -> [i]
scale_cents_i = map round . scale_cents
scale_ratios :: Epsilon -> Scale Integer -> [Rational]
scale_ratios epsilon s = 1 : map (pitch_ratio epsilon) (scale_pitches s)
scale_ratios_req :: Integral i => Scale i -> [Ratio i]
scale_ratios_req =
let err = error "scale_ratios_req"
in (1 :) . map (fromMaybe err . T.fromRight) . scale_pitches
scale_to_tuning :: Epsilon -> Scale Integer -> T.Tuning
scale_to_tuning epsilon (_,_,_,p) =
case partitionEithers p of
([],r) -> let (r',o) = T.separate_last r
in T.Tuning (Left (1 : r')) o
_ -> let (c,o) = T.separate_last p
c' = 0 : map pitch_cents c
o' = either (T.reconstructed_ratio epsilon) id o
in T.Tuning (Right c') o'
tuning_to_scale :: (String,String) -> T.Tuning -> Scale Integer
tuning_to_scale (nm,dsc) (T.Tuning p o) =
let n = either length length p
p' = either (map Right . tail) (map Left . tail) p ++ [Right o]
in (nm,dsc,n,p')
scale_eq :: Eq n => Scale n -> Scale n -> Bool
scale_eq (_,_,d0,p0) (_,_,d1,p1) = d0 == d1 && p0 == p1
scale_eqv :: Integral n => Scale n -> Scale n -> Bool
scale_eqv (_,_,d0,p0) (_,_,d1,p1) =
let f = map pitch_cents
in d0 == d1 && f p0 == f p1
is_comment :: String -> Bool
is_comment x =
case x of
'!':_ -> True
_ -> False
remove_eol_comments :: String -> String
remove_eol_comments = takeWhile (/= '!')
filter_comments :: [String] -> [String]
filter_comments =
map remove_eol_comments .
filter (not . T.predicate_any [is_comment,null])
parse_pitch :: (Read i,Integral i) => String -> Pitch i
parse_pitch p =
if '.' `elem` p
then Left (T.read_fractional_allow_trailing_point_err p)
else Right (T.read_ratio_with_div_err p)
parse_pitch_ln :: (Read i, Integral i) => String -> Pitch i
parse_pitch_ln x =
case words x of
p:_ -> parse_pitch p
_ -> error (show ("parse_pitch_ln",words x))
parse_scl :: (Read i, Integral i) => String -> String -> Scale i
parse_scl nm s =
case filter_comments (lines (T.filter_cr s)) of
t:n:p -> let scl = (nm,T.delete_trailing_whitespace t,T.read_err n,map parse_pitch_ln p)
in scale_verify_err scl
_ -> error "parse"
scl_get_dir :: IO [String]
scl_get_dir = fmap splitSearchPath (getEnv "SCALA_SCL_DIR")
scl_derive_filename :: FilePath -> IO FilePath
scl_derive_filename nm = do
dir <- scl_get_dir
when (null dir) (error "scl_derive_filename: SCALA_SCL_DIR: nil")
when (hasExtension nm) (error "scl_derive_filename: name has extension")
T.path_scan_err dir (nm <.> "scl")
scl_resolve_name :: String -> IO FilePath
scl_resolve_name nm =
let ex_f x = if x then return nm else error "scl_resolve_name: file does not exist"
in if isAbsolute nm && takeExtension nm == ".scl"
then doesFileExist nm >>= ex_f
else scl_derive_filename nm
scl_load :: (Read i, Integral i) => String -> IO (Scale i)
scl_load nm = do
fn <- scl_resolve_name nm
s <- T.read_file_iso_8859_1 fn
return (parse_scl (takeBaseName nm) s)
scl_load_tuning :: Epsilon -> String -> IO T.Tuning
scl_load_tuning epsilon = fmap (scale_to_tuning epsilon) . scl_load
scl_load_dir :: (Read i, Integral i) => FilePath -> IO [Scale i]
scl_load_dir d = T.dir_subset [".scl"] d >>= mapM scl_load
scl_load_db :: (Read i, Integral i) => IO [Scale i]
scl_load_db = do
dir <- scl_get_dir
r <- mapM scl_load_dir dir
return (concat r)
scale_stat :: (Integral i,Show i) => Scale i -> [String]
scale_stat s =
let ty = uniform_pitch_type (scale_pitches s)
in ["scale-name : " ++ scale_name s
,"scale-description : " ++ scale_description s
,"scale-degree : " ++ show (scale_degree s)
,"scale-type : " ++ maybe "non-uniform" show ty
,"perfect-octave : " ++ show (perfect_octave s)
,"scale-cents-i : " ++ show (scale_cents_i s)
,if ty == Just Pitch_Ratio
then "scale-ratios : " ++ intercalate "," (map T.rational_pp (scale_ratios_req s))
else ""]
pitch_pp :: Show i => Pitch i -> String
pitch_pp p =
case p of
Left c -> show c
Right r -> show (numerator r) ++ "/" ++ show (denominator r)
scale_pp :: Show i => Scale i -> [String]
scale_pp (nm,dsc,k,p) =
["! " ++ nm ++ ".scl"
,"!"
,dsc
,show k
,"!"] ++ map pitch_pp p
dist_get_dir :: IO String
dist_get_dir = getEnv "SCALA_DIST_DIR"
load_dist_file :: FilePath -> IO [String]
load_dist_file nm = do
d <- dist_get_dir
fmap lines (readFile (d </> nm))