module Music.Theory.Time.Bel1990.R where
import Control.Monad
import Data.Function
import Data.List
import Data.Ratio
import qualified Text.ParserCombinators.Parsec as P
import qualified Music.Theory.List as T
import qualified Music.Theory.Math as T
data Par_Mode = Par_Left | Par_Right
| Par_Min | Par_Max
| Par_None
deriving (Eq,Show)
par_mode_brackets :: Par_Mode -> (String,String)
par_mode_brackets m =
case m of
Par_Left -> ("(",")")
Par_Right -> ("~(",")")
Par_Min -> ("~{","}")
Par_Max -> ("{","}")
Par_None -> ("[","]")
bel_brackets_match :: (Char,Char) -> Bool
bel_brackets_match (open,close) =
case (open,close) of
('{','}') -> True
('(',')') -> True
('[',']') -> True
_ -> False
type Tempo = Rational
data Term a = Value a
| Rest
| Continue
deriving (Eq,Show)
data Bel a = Node (Term a)
| Iso (Bel a)
| Seq (Bel a) (Bel a)
| Par Par_Mode (Bel a) (Bel a)
| Mul Tempo
deriving (Eq,Show)
bel_pp :: (a -> String) -> Bel a -> String
bel_pp f b =
case b of
Node Rest -> "-"
Node Continue -> "_"
Node (Value c) -> f c
Iso b' -> T.bracket_l ("{","}") (bel_pp f b')
Seq p q -> concat [bel_pp f p,bel_pp f q]
Par m p q ->
let pq = concat [bel_pp f p,",",bel_pp f q]
in T.bracket_l (par_mode_brackets m) pq
Mul n -> concat ["*",T.rational_pp n]
bel_char_pp :: Bel Char -> String
bel_char_pp = bel_pp return
par_analyse :: Tempo -> Par_Mode -> Bel a -> Bel a -> (Rational,Rational,Rational)
par_analyse t m p q =
let (_,d_p) = bel_tdur t p
(_,d_q) = bel_tdur t q
in case m of
Par_Left -> (d_p,1,d_q / d_p)
Par_Right -> (d_q,d_p / d_q,1)
Par_Min -> let r = min d_p d_q in (r,d_p / r,d_q / r)
Par_Max -> let r = max d_p d_q in (r,d_p / r,d_q / r)
Par_None -> (max d_p d_q,1,1)
par_dur :: Tempo -> Par_Mode -> Bel a -> Bel a -> Rational
par_dur t m p q =
let (d,_,_) = par_analyse t m p q
in d
bel_tdur :: Tempo -> Bel a -> (Tempo,Rational)
bel_tdur t b =
case b of
Node _ -> (t,1 / t)
Iso b' -> (t,snd (bel_tdur t b'))
Seq p q ->
let (t_p,d_p) = bel_tdur t p
(t_q,d_q) = bel_tdur t_p q
in (t_q,d_p + d_q)
Par m p q -> (t,par_dur t m p q)
Mul n -> (t * n,0)
bel_dur :: Tempo -> Bel a -> Rational
bel_dur t = snd . bel_tdur t
type Time = Rational
type Voice = [Char]
type L_St = (Time,Tempo,Voice)
type L_Term a = (L_St,Term a)
lterm_time :: L_Term a -> Time
lterm_time ((st,_,_),_) = st
lterm_duration :: L_Term a -> Time
lterm_duration ((_,tm,_),_) = 1 / tm
lterm_end_time :: L_Term a -> Time
lterm_end_time e = lterm_time e + lterm_duration e
type L_Bel a = [L_Term a]
bel_linearise :: L_St -> Bel a -> (L_Bel a,L_St)
bel_linearise l_st b =
let (st,tm,vc) = l_st
in case b of
Node e -> ([(l_st,e)],(st + 1/tm,tm,vc))
Iso p ->
let (p',(st',_,_)) = bel_linearise l_st p
in (p',(st',tm,vc))
Seq p q ->
let (p',l_st') = bel_linearise l_st p
(q',l_st'') = bel_linearise l_st' q
in (p' ++ q',l_st'')
Par m p q ->
let (du,p_m,q_m) = par_analyse tm m p q
(p',_) = bel_linearise (st,tm * p_m,'l':vc) p
(q',_) = bel_linearise (st,tm * q_m,'r':vc) q
in (p' `lbel_merge` q',(st + du,tm,vc))
Mul n -> ([],(st,tm * n,vc))
lbel_merge :: L_Bel a -> L_Bel a -> L_Bel a
lbel_merge = T.merge_on lterm_time
lbel_tempi :: L_Bel a -> [Tempo]
lbel_tempi = nub . sort . map (\((_,t,_),_) -> t)
lbel_tempo_mul :: Rational -> L_Bel a -> L_Bel a
lbel_tempo_mul n = map (\((st,tm,vc),e) -> ((st / n,tm * n,vc),e))
lbel_normalise :: L_Bel a -> L_Bel a
lbel_normalise b =
let t = lbel_tempi b
n = foldl1 lcm (map denominator t) % 1
m = foldl1 lcm (map numerator (map (* n) t)) % 1
in lbel_tempo_mul (n / m) b
voice_normalise :: Voice -> Voice
voice_normalise = dropWhile (== 'l')
voice_eq :: Voice -> Voice -> Bool
voice_eq = (==) `on` voice_normalise
lbel_voices :: L_Bel a -> [Voice]
lbel_voices =
sortOn reverse .
nub .
map (\((_,_,v),_) -> voice_normalise v)
lbel_duration :: L_Bel a -> Time
lbel_duration b =
let l = last (T.group_on lterm_time b)
in maximum (map (\((st,tm,_),_) -> st + recip tm) l)
lbel_lookup :: (Time,Voice) -> L_Bel a -> Maybe (L_Term a)
lbel_lookup (st,vc) =
let f ((st',tm,vc'),_) = (st >= st' && st < st' + (1 / tm)) &&
vc `voice_eq` vc'
in find f
lbel_grid :: L_Bel a -> [[Maybe (Term a)]]
lbel_grid l =
let n = lbel_normalise l
v = lbel_voices n
d = lbel_duration n
trs st ((st',_,_),e) = if st == st' then e else Continue
get vc st = fmap (trs st) (lbel_lookup (st,vc) n)
f vc = map (get vc) [0 .. d 1]
in map f v
bel_grid :: Bel a -> [[Maybe (Term a)]]
bel_grid b =
let (l,_) = bel_linearise (0,1,[]) b
in lbel_grid l
bel_ascii :: Bool -> Bel Char -> String
bel_ascii opt =
let f e = case e of
Nothing -> ' '
Just Rest -> '-'
Just Continue -> '_'
Just (Value c) -> c
g = if opt then intersperse ' ' else id
in unlines . map (g . map f) . bel_grid
bel_ascii_pr :: Bel Char -> IO ()
bel_ascii_pr = putStrLn . ('\n' :) . bel_ascii True
(~>) :: Bel a -> Bel a -> Bel a
p ~> q = Seq p q
lseq :: [Bel a] -> Bel a
lseq = foldl1 Seq
node :: a -> Bel a
node = Node . Value
nseq :: [a] -> Bel a
nseq = lseq . map node
cseq :: String -> Bel Char
cseq =
let f c = case c of
'_' -> Continue
'-' -> Rest
_ -> Value c
in foldl1 Seq . map (Node . f)
par :: Bel a -> Bel a -> Bel a
par = Par Par_Max
rest :: Bel a
rest = Node Rest
nrests :: Integral n => n -> Bel a
nrests n = lseq (genericReplicate n rest)
bel_parse_pp_ident :: String -> Bool
bel_parse_pp_ident s = bel_char_pp (bel_char_parse s) == s
bel_ascii_pp :: String -> IO ()
bel_ascii_pp s = do
let p = bel_char_parse s
putStrLn (concat ["\nBel(R): \"",bel_char_pp p,"\", Dur: ",T.rational_pp (bel_dur 1 p),""])
bel_ascii_pr p
type P a = P.GenParser Char () a
p_rest :: P (Term a)
p_rest = liftM (const Rest) (P.char '-')
p_nrests :: P (Bel a)
p_nrests = liftM nrests p_non_negative_integer
p_continue :: P (Term a)
p_continue = liftM (const Continue) (P.char '_')
p_char_value :: P (Term Char)
p_char_value = liftM Value P.lower
p_char_term :: P (Term Char)
p_char_term = P.choice [p_rest,p_continue,p_char_value]
p_char_node :: P (Bel Char)
p_char_node = liftM Node p_char_term
p_non_negative_integer :: P Integer
p_non_negative_integer = liftM read (P.many1 P.digit)
p_non_negative_rational :: P Rational
p_non_negative_rational = do
n <- p_non_negative_integer
_ <- P.oneOf "%/"
d <- p_non_negative_integer
return (n % d)
p_non_negative_double :: P Double
p_non_negative_double = do
a <- P.many1 P.digit
_ <- P.char '.'
b <- P.many1 P.digit
return (read (a ++ "." ++ b))
p_non_negative_number :: P Rational
p_non_negative_number =
P.choice [P.try p_non_negative_rational
,P.try (liftM toRational p_non_negative_double)
,P.try (liftM toRational p_non_negative_integer)]
p_mul :: P (Bel a)
p_mul = do
op <- P.oneOf "*/"
n <- p_non_negative_number
let n' = case op of
'*' -> n
'/' -> recip n
_ -> error "p_mul"
return (Mul n')
p_iso :: P (Bel a) -> P (Bel a)
p_iso f = do
open <- P.oneOf "{(["
iso <- P.many1 f
close <- P.oneOf "})]"
if bel_brackets_match (open,close)
then return (Iso (lseq iso))
else error "p_iso: open/close mismatch"
p_char_iso :: P (Bel Char)
p_char_iso = p_iso p_char_bel
p_par :: P (Bel a) -> P (Bel a)
p_par f = do
tilde <- P.optionMaybe (P.char '~')
open <- P.oneOf "{(["
lhs <- P.many1 f
_ <- P.char ','
rhs <- P.many1 f
close <- P.oneOf "})]"
let m = case (tilde,open,close) of
(Nothing,'{','}') -> Par_Max
(Just '~','{','}') -> Par_Min
(Nothing,'(',')') -> Par_Left
(Just '~','(',')') -> Par_Right
(Nothing,'[',']') -> Par_None
_ -> error "p_par: incoherent par"
return (Par m (lseq lhs) (lseq rhs))
p_char_par :: P (Bel Char)
p_char_par = p_par p_char_bel
p_char_bel :: P (Bel Char)
p_char_bel = P.choice [P.try p_char_par,p_char_iso,p_mul,p_nrests,p_char_node]
bel_char_parse :: String -> Bel Char
bel_char_parse s =
either
(\e -> error ("bel_parse failed\n" ++ show e))
lseq
(P.parse (P.many1 p_char_bel) "" s)