module Music.Theory.Tuning.Scala where
import qualified Codec.Binary.UTF8.String as U
import qualified Data.ByteString as B
import Data.List
import Data.Ratio
import qualified Music.Theory.Tuning as T
import System.Directory
import System.FilePath
type Pitch i = Either T.Cents (Ratio i)
type Scale i = (String,i,[Pitch i])
scale_description :: Scale i -> String
scale_description (d,_,_) = d
scale_degree :: Scale i -> i
scale_degree (_,n,_) = n
scale_pitches :: Scale i -> [Pitch i]
scale_pitches (_,_,p) = p
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)]
scale_pitch_representations :: (Integral t) => Scale i -> (t,t)
scale_pitch_representations s =
let f (l,r) p = case p of
Left _ -> (l + 1,r)
Right _ -> (l,r + 1)
in foldl f (0,0) (scale_pitches s)
pitch_cents :: Pitch Integer -> T.Cents
pitch_cents p =
case p of
Left c -> c
Right r -> T.to_cents_r r
type Epsilon = Double
pitch_ratio :: Epsilon -> Pitch Integer -> Rational
pitch_ratio epsilon p =
case p of
Left c -> T.reconstructed_ratio epsilon c
Right r -> r
scale_uniform :: Epsilon -> Scale Integer -> Scale Integer
scale_uniform epsilon s =
let (d,n,p) = s
(c,r) = scale_pitch_representations s :: (Int,Int)
in if c >= r
then (d,n,map (Left . pitch_cents) p)
else (d,n,map (Right . pitch_ratio epsilon) p)
scale_cents :: Scale Integer -> [T.Cents]
scale_cents s = 0 : map pitch_cents (scale_pitches s)
scale_ratios :: Epsilon -> Scale Integer -> [Rational]
scale_ratios epsilon s = 1 : map (pitch_ratio epsilon) (scale_pitches s)
comment_p :: String -> Bool
comment_p x =
case x of
'!':_ -> True
_ -> False
filter_cr :: String -> String
filter_cr = filter (not . (==) '\r')
p_or :: [a -> Bool] -> a -> Bool
p_or p x =
case p of
[] -> False
f:p' -> f x || p_or p' x
remove_eol_comments :: String -> String
remove_eol_comments = takeWhile (/= '!')
filter_comments :: [String] -> [String]
filter_comments = map remove_eol_comments .
filter (not . p_or [comment_p,null])
delete_trailing_point :: String -> String
delete_trailing_point s =
case reverse s of
'.':s' -> reverse s'
_ -> s
pitch :: (Read i,Integral i) => String -> Pitch i
pitch p =
if '.' `elem` p
then Left (read (delete_trailing_point p))
else case break (== '/') p of
(n,'/':d) -> Right (read n % read d)
_ -> Right (read p % 1)
pitch_ln :: (Read i, Integral i) => String -> Pitch i
pitch_ln x =
case words x of
p:_ -> pitch p
_ -> error (show ("pitch",words x))
parse :: (Read i, Integral i) => String -> Scale i
parse s =
case filter_comments (lines (filter_cr s)) of
t:n:p -> (t,read n,map pitch_ln p)
_ -> error "parse"
load :: (Read i, Integral i) => FilePath -> IO (Scale i)
load fn = do
b <- B.readFile fn
let s = U.decode (B.unpack b)
return (parse s)
dir_subset :: [String] -> FilePath -> IO [FilePath]
dir_subset ext dir = do
let f nm = takeExtension nm `elem` ext
c <- getDirectoryContents dir
return (map (dir </>) (sort (filter f c)))
load_dir :: (Read i, Integral i) => FilePath -> IO [Scale i]
load_dir d = dir_subset [".scl"] d >>= mapM load