module Sound.SC3.Lang.Control.Event where
import qualified Data.Map as M
import Data.Maybe
import qualified Sound.OpenSoundControl as O
import qualified Sound.SC3.Server as S
import qualified Sound.SC3.Lang.Control.Duration as D
import qualified Sound.SC3.Lang.Control.Instrument as I
import qualified Sound.SC3.Lang.Control.Pitch as P
type Key = String
type Value = Double
data Type = E_s_new | E_n_set | E_rest deriving (Eq,Show)
data Event = Event {e_type :: Type
,e_id :: Maybe Int
,e_instrument :: Maybe I.Instrument
,e_map :: M.Map Key Value}
deriving (Eq,Show)
defaultEvent :: Event
defaultEvent =
Event {e_type = E_s_new
,e_id = Nothing
,e_instrument = Nothing
,e_map = M.empty}
lookup_m :: Key -> Event -> Maybe Value
lookup_m k e = M.lookup k (e_map e)
lookup_v :: Value -> Key -> Event -> Value
lookup_v v k e = fromMaybe v (lookup_m k e)
lookup_t :: t -> (Value -> t) -> Key -> Event -> t
lookup_t v f k e =
case lookup_m k e of
Nothing -> v
Just v' -> f v'
pitch :: Event -> P.Pitch Double
pitch e =
let get_r v k = lookup_v v k e
get_m v k = lookup_t v const k e
in P.Pitch {P.mtranspose = get_r 0 "mtranspose"
,P.gtranspose = get_r 0 "gtranspose"
,P.ctranspose = get_r 0 "ctranspose"
,P.octave = get_r 5 "octave"
,P.root = get_r 0 "root"
,P.degree = get_r 0 "degree"
,P.scale = [0, 2, 4, 5, 7, 9, 11]
,P.stepsPerOctave = get_r 12 "stepsPerOctave"
,P.detune = get_r 0 "detune"
,P.harmonic = get_r 1 "harmonic"
,P.freq_f = get_m P.default_freq_f "freq"
,P.midinote_f = get_m P.default_midinote_f "midinote"
,P.note_f = get_m P.default_note_f "note"}
duration :: Event -> D.Duration Double
duration e =
let get_r v k = lookup_v v k e
get_m v k = lookup_t v const k e
get_o k = lookup_m k e
in D.Duration {D.tempo = get_r 60 "tempo"
,D.dur = get_r 1 "dur"
,D.stretch = get_r 1 "stretch"
,D.legato = get_r 0.8 "legato"
,D.sustain_f = get_m D.default_sustain_f "sustain"
,D.delta_f = get_m D.default_delta_f "delta"
,D.lag = get_r 0.1 "lag"
,D.fwd' = get_o "fwd'"}
insert :: Key -> Value -> Event -> Event
insert k v e = e {e_map = M.insert k v (e_map e)}
db :: Event -> Value
db = lookup_v (20) "db"
dbAmp' :: Floating a => a -> a
dbAmp' a = 10 ** (a * 0.05)
amp :: Event -> Value
amp e = lookup_v (dbAmp' (db e)) "amp" e
fwd :: Event -> Double
fwd = D.fwd . duration
latency :: Event -> Double
latency = lookup_v 0.1 "latency"
model_keys :: [Key]
model_keys =
["amp","db"
,"delta","dur","legato","fwd'","stretch","sustain","tempo"
,"ctranspose","degree","freq","midinote","mtranspose","note","octave"
,"rest"]
reserved :: [Key]
reserved = ["freq","midinote","note"
,"delta","sustain"
,"amp"]
parameters' :: (Key,Value) -> Maybe (Key,Value)
parameters' (k,v) =
if k `elem` reserved
then Nothing
else Just (k,v)
parameters :: Event -> [(Key,Value)]
parameters = mapMaybe parameters' . M.toList . e_map
edit_v :: Key -> Value -> (Value -> Value) -> Event -> Event
edit_v k v f e =
case lookup_m k e of
Just n -> insert k (f n) e
Nothing -> insert k (f v) e
edit :: Key -> (Value -> Value) -> Event -> Event
edit k f e =
case lookup_m k e of
Just n -> insert k (f n) e
Nothing -> e
from_list :: Type -> Maybe Int -> Maybe I.Instrument -> [(Key,Value)] -> Event
from_list t n i l =
Event {e_type = t
,e_id = n
,e_instrument = i
,e_map = M.fromList l}
event :: [(Key,Value)] -> Event
event l =
Event {e_type = E_s_new
,e_id = Nothing
,e_instrument = Nothing
,e_map = M.fromList l}
instrument_name :: Event -> String
instrument_name e =
case e_instrument e of
Nothing -> "default"
Just (I.InstrumentDef s _) -> S.synthdefName s
Just (I.InstrumentName s _) -> s
instrument_def :: Event -> Maybe S.Synthdef
instrument_def e =
case e_instrument e of
Nothing -> Nothing
Just (I.InstrumentDef s _) -> Just s
Just (I.InstrumentName _ _) -> Nothing
instrument_send_release :: Event -> Bool
instrument_send_release e =
case e_instrument e of
Nothing -> True
Just i -> I.send_release i
f_merge :: Ord a => [(a,t)] -> [(a,t)] -> [(a,t)]
f_merge p q =
case (p,q) of
([],_) -> q
(_,[]) -> p
((t0,e0):r0,(t1,e1):r1) ->
if t0 <= t1
then (t0,e0) : f_merge r0 q
else (t1,e1) : f_merge p r1
type Time = Double
merge' :: (Time,[Event]) -> (Time,[Event]) -> [(Time,Event)]
merge' (pt,p) (qt,q) =
let p_st = map (+ pt) (0 : scanl1 (+) (map fwd p))
q_st = map (+ qt) (0 : scanl1 (+) (map fwd q))
in f_merge (zip p_st p) (zip q_st q)
add_fwd :: [(Time,Event)] -> [Event]
add_fwd e =
case e of
(t0,e0):(t1,e1):e' ->
insert "fwd'" (t1 t0) e0 : add_fwd ((t1,e1):e')
_ -> map snd e
merge :: (Time,[Event]) -> (Time,[Event]) -> [Event]
merge p q = add_fwd (merge' p q)
is_rest :: Event -> Bool
is_rest e =
case lookup_m "rest" e of
Just r -> r > 0
Nothing -> False
to_sc3_bundle :: Time -> Int -> Event -> Maybe (O.Bundle,O.Bundle)
to_sc3_bundle t j e =
let s = instrument_name e
sr = instrument_send_release e
p = pitch e
d = duration e
rt = D.sustain d
f = P.detunedFreq p
pr = ("freq",f) : ("midinote",P.midinote p) : ("note",P.note p) :
("delta",D.delta d) : ("sustain",rt) :
("amp",amp e) :
parameters e
i = fromMaybe j (e_id e)
t' = t + latency e
in if is_rest e || isNaN f
then Nothing
else let m_on = case e_type e of
E_s_new -> [S.s_new s i S.AddToTail 1 pr]
E_n_set -> [S.n_set i pr]
E_rest -> []
m_off = if not sr
then []
else case e_type e of
E_s_new -> [S.n_set i [("gate",0)]]
E_n_set -> [S.n_set i [("gate",0)]]
E_rest -> []
in Just (O.Bundle (O.UTCr t') m_on
,O.Bundle (O.UTCr (t' + rt)) m_off)